--- /dev/null
+: basic variables
+package=perl
+baserev=4.1
+patchbranch=1
+mydiff='diff -c'
+maintname='Larry Wall'
+maintloc='lwall@netlabs.com'
+ftpsite=''
+orgname='NetLabs, Inc.'
+newsgroups='comp.lang.perl'
+recipients=''
+ftpdir=''
+
+: derivative variables--do not change
+revbranch="$baserev.$patchbranch"
+packver='1'
--- /dev/null
+
+
+
+
+
+
+ Larry Wall
+ Matthias Neeracher
+ c/o 4920 El Camino Real
+ Los Altos, CA 94022
+
+ March 26, 1993
+
+
+ Gary Little
+ M/S 37-X
+ Apple Computer, Inc.
+ 20525 Mariani Ave.
+ Cupertino, CA 95014
+
+ Dear Gary,
+
+ We are writing you as the product manager of Apple's
+ EssentialsoToolsoObjects (E.T.O.) CD-ROM. As the authors of Perl for
+ MPW, we hereby authorize Apple to distribute Perl for MPW including
+ source code on E.T.O. according to the terms of the "Artistic" license
+ distributed with Perl and enclosed with this letter. The Perl for MPW
+ materials are hereby confirmed as being provided to Apple free of
+ charge, for the purpose of being distributed on E.T.O. This
+ authorization includes distribution of Perl for MPW on successive
+ releases of E.T.O. and distribution of revisions to Perl for MPW that
+ we provide you with or agree to.
+
+ Thank you for your efforts in promoting the use of Perl amongst
+ Macintosh developers.
+
+ Sincerely,
+
+
+ ________________________ ________________________
+
+ Larry Wall Matthias Neeracher
"Standard Version" refers to such a Package if it has not been
modified, or has been modified in accordance with the wishes
- of the Copyright Holder.
+ of the Copyright Holder as specified below.
"Copyright Holder" is whoever is named in the copyright or
copyrights for the package.
b) accompany the distribution with the machine-readable source of
the Package with your modifications.
- c) accompany any non-standard executables with their corresponding
- Standard Version executables, giving the non-standard executables
- non-standard names, and clearly documenting the differences in manual
- pages (or equivalent), together with instructions on where to get
- the Standard Version.
+ c) give non-standard executables non-standard names, and clearly
+ document the differences in manual pages (or equivalent), together
+ with instructions on where to get the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
5. You may charge a reasonable copying fee for any distribution of this
-Package. You may charge any fee you choose for support of this Package.
-You may not charge a fee for this Package itself. However,
+Package. You may charge any fee you choose for support of this
+Package. You may not charge a fee for this Package itself. However,
you may distribute this Package in aggregate with other (possibly
commercial) programs as part of a larger (possibly commercial) software
distribution provided that you do not advertise this Package as a
-product of your own.
+product of your own. You may embed this Package's interpreter within
+an executable of yours (by linking); this shall be construed as a mere
+form of aggregation, provided that the complete Standard Version of the
+interpreter is so embedded.
6. The scripts and library files supplied as input to or produced as
output from the programs of this Package do not automatically fall
under the copyright of this Package, but belong to whomever generated
them, and may be sold commercially, and may be aggregated with this
+Package. If such scripts or library files are aggregated with this
+Package via the so-called "undump" or "unexec" methods of producing a
+binary executable image, then distribution of such an image shall
+neither be construed as a distribution of this Package nor shall it
+fall under the restrictions of Paragraphs 3 and 4, provided that you do
+not represent such an executable image as a Standard Version of this
Package.
-7. C subroutines supplied by you and linked into this Package in order
-to emulate subroutines and variables of the language defined by this
+7. C subroutines (or comparably compiled subroutines in other
+languages) supplied by you and linked into this Package in order to
+emulate subroutines and variables of the language defined by this
Package shall not be considered part of this Package, but are the
equivalent of input as in Paragraph 6, provided these subroutines do
not change the language in any way that would cause it to fail the
--- /dev/null
+$ActualRevision = "M";
+
+($junk, $ActualRevision) = '';
+
+chop($ActualRevision);
+
+($name, $ActualRevision, $junk) = split(/\s+/, $ActualRevision);
--- /dev/null
+#!./perl
+
+#!/usr/bin/perl
+$month = (split(' ',`date`))[1];
+
+while (<DATA>) {
+ next if 1 .. ?^$month\b?o;
+ next unless /deposit/;
+ ($day) = /(\d+)/;
+ local(*where) = m:([^/]+)$:;
+ # with the local, you get bad free's. with it, you get a core dump
+ $where{$day}++;
+}
+
+@days = sort { $a <=> $b } keys %personal;
+
+foreach $place ('tivoli', 'lists', 'personal') {
+ *where = $place;
+ foreach $day (@days) {
+ printf "Aug %02d: %3d in %s\n", $day, $where{$day}, $place;
+ }
+}
+
+__END__
+Aug 27 10:40:20 New mail from hess
+Aug 27 10:40:20 deposit into /home/wraeththu/tchrist/Mail/in.coming/tivoli
+Aug 27 10:42:27 New mail from jcarson
+Aug 27 10:42:27 deposit into /home/wraeththu/tchrist/Mail/in.coming/tivoli
+Aug 27 10:48:18 New mail from dean
+Aug 27 10:48:18 deposit into /home/wraeththu/tchrist/Mail/in.coming/tivoli
+Aug 27 11:05:56 New mail from hess
+Aug 27 11:05:56 deposit into personal
+Aug 27 11:13:28 New mail from hess
+Aug 27 11:13:28 deposit into personal
--- /dev/null
+#!./perl
+# These filenames doesn't seem to matter, as long as the first one exists,
+# and we have permission to create the second one.
+open(OLD_FILE, "/etc/passwd");
+open(NEW_FILE, ">/tmp/foobar");
+
+# This line is unnecessary to trigger death, but it helps to show where
+# we crash and burn.
+$| = 1;
+
+# Seemingly, this loop is necessary to activate the bug. If I just say
+# $_ = <OLD_FILE>
+# instead of the loop, everything works as expected.
+while (<OLD_FILE>) {
+ # This was originally just a random typing spaz on my part, but it causes
+ # perl to crash later.
+ print <NEW_FILE>;
+}
+
+print "About to die...\n";
+print "dest = '$dest'\n";
+print "Didn't die!\n";
+
--- /dev/null
+sleep(1) &sort
--- /dev/null
+#!./perl
+
+sub minmax {
+ eval '@_ = sort { $a '.shift().' $b } @_';
+ (shift, pop(@_));
+}
+
+($x, $y) = &minmax('<=>', 2, 4, 1, 0, 3);
+print "x = $x, y = $y\n";
+($x, $y) = &minmax('cmp', "foo", "bar", "zot", "xyzzy");
+print "x = $x, y = $y\n";
+
--- /dev/null
+print STDERR "Can't open $mib_name: $!\n"
+&objviews'Exit;
--- /dev/null
+
+ s'$lhs'$rhs' now does no interpolation on either side. It used to
+ interplolate $lhs but not $rhs.
+
+ The second and third arguments of splice are now evaluated in scalar
+ context (like the book says) rather than list context.
+
+ Saying shift @foo + 20 is now a semantic error.
+
+ The elements of argument lists for formats are now evaluated in list
+ context.
+
+ You can't do a goto into a block that is optimized away.
+
+ It is no longer syntactically legal to use whitespace as the name
+ of a variable.
+
+ Some error messages will be different.
+++ /dev/null
-#! /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.)
-#
-# $RCSfile: Configure,v $$Revision: 4.0.1.9 $$Date: 92/06/23 12:28:33 $
-#
-# 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.)
-
-cat >/tmp/c1$$ <<EOF
-ARGGGHHHH!!!!!
-
-Your csh still thinks true is false. Write to your vendor today and tell
-them that next year Configure ought to "rm /bin/csh" unless they fix their
-blasted shell. :-)
-
-[End of diatribe. We now return you to your regularly scheduled
-programming...]
-
-EOF
-cat >/tmp/c2$$ <<EOF
-OOPS! You naughty creature! You didn't run Configure with sh!
-I will attempt to remedy the situation by running sh for you...
-
-EOF
-
-true || cat /tmp/c1$$ /tmp/c2$$
-true || exec sh $0
-
-export PATH || cat /tmp/c2$$
-export PATH || exec sh $0
-rm -f /tmp/c1$$ /tmp/c2$$
-
-PATH=".:$PATH:/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/local:/usr/lbin:/etc:/usr/new:/usr/new/bin:/usr/nbin"
-
-if test ! -t 0; then
- echo "Say 'sh Configure', not 'sh <Configure'"
- exit 1
-fi
-
-(alias) >/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.)"
-
-unset CDPATH
-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=''
-bash=''
-ksh=''
-lex=''
-flex=''
-bison=''
-Log=''
-Header=''
-Id=''
-lastuname=''
-alignbytes=''
-bin=''
-installbin=''
-byteorder=''
-contains=''
-cppstdin=''
-cppminus=''
-d_bcmp=''
-d_bcopy=''
-d_safebcpy=''
-d_bzero=''
-d_castneg=''
-castflags=''
-d_charsprf=''
-d_chsize=''
-d_crypt=''
-cryptlib=''
-d_csh=''
-d_dosuid=''
-d_dup2=''
-d_fchmod=''
-d_fchown=''
-d_fcntl=''
-d_flexfnam=''
-d_flock=''
-d_getgrps=''
-d_gethent=''
-d_getpgrp=''
-d_getpgrp2=''
-d_getprior=''
-d_htonl=''
-d_index=''
-d_isascii=''
-d_killpg=''
-d_lstat=''
-d_memcmp=''
-d_memcpy=''
-d_safemcpy=''
-d_memmove=''
-d_memset=''
-d_mkdir=''
-d_msg=''
-d_msgctl=''
-d_msgget=''
-d_msgrcv=''
-d_msgsnd=''
-d_ndbm=''
-d_odbm=''
-d_open3=''
-d_readdir=''
-d_rename=''
-d_rewindir=''
-d_rmdir=''
-d_seekdir=''
-d_select=''
-d_sem=''
-d_semctl=''
-d_semget=''
-d_semop=''
-d_setegid=''
-d_seteuid=''
-d_setpgrp=''
-d_setpgrp2=''
-d_setprior=''
-d_setregid=''
-d_setresgid=''
-d_setreuid=''
-d_setresuid=''
-d_setrgid=''
-d_setruid=''
-d_shm=''
-d_shmat=''
-d_voidshmat=''
-d_shmctl=''
-d_shmdt=''
-d_shmget=''
-d_socket=''
-d_sockpair=''
-d_oldsock=''
-socketlib=''
-d_statblks=''
-d_stdstdio=''
-d_strctcpy=''
-d_strerror=''
-d_symlink=''
-d_syscall=''
-d_telldir=''
-d_truncate=''
-d_vfork=''
-d_voidsig=''
-d_tosignal=''
-d_volatile=''
-d_vprintf=''
-d_charvspr=''
-d_wait4=''
-d_waitpid=''
-gidtype=''
-groupstype=''
-i_fcntl=''
-i_gdbm=''
-i_grp=''
-i_niin=''
-i_sysin=''
-i_pwd=''
-d_pwquota=''
-d_pwage=''
-d_pwchange=''
-d_pwclass=''
-d_pwexpire=''
-d_pwcomment=''
-i_sys_file=''
-i_sysioctl=''
-i_time=''
-i_sys_time=''
-i_sys_select=''
-d_systimekernel=''
-i_utime=''
-i_varargs=''
-i_vfork=''
-intsize=''
-libc=''
-nm_opts=''
-libndir=''
-i_my_dir=''
-i_ndir=''
-i_sys_ndir=''
-i_dirent=''
-i_sys_dir=''
-d_dirnamlen=''
-ndirc=''
-ndiro=''
-mallocsrc=''
-mallocobj=''
-d_mymalloc=''
-mallocptrtype=''
-mansrc=''
-manext=''
-models=''
-split=''
-small=''
-medium=''
-large=''
-huge=''
-optimize=''
-ccflags=''
-cppflags=''
-ldflags=''
-cc=''
-nativegcc=''
-libs=''
-n=''
-c=''
-package=''
-randbits=''
-scriptdir=''
-installscr=''
-sig_name=''
-spitshell=''
-shsharp=''
-sharpbang=''
-startsh=''
-stdchar=''
-uidtype=''
-usrinclude=''
-inclPath=''
-void=''
-voidhave=''
-voidwant=''
-w_localtim=''
-w_s_timevl=''
-w_s_tm=''
-yacc=''
-lib=''
-privlib=''
-installprivlib=''
-CONFIG=''
-: get the name of the package
-package=perl
-: Here we go...
-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'
-
-: the hints files may add more components to libpth
-test -d /usr/cs/lib && libpth="$libpth /usr/cs/lib"
-test -d /usr/ccs/lib && libpth="$libpth /usr/ccs/lib"
-test -d /usr/lib && libpth="$libpth /usr/lib"
-test -d /usr/ucblib && libpth="$libpth /usr/ucblib"
-test -d /usr/local/lib && libpth="$libpth /usr/local/lib"
-test -d /usr/lib/large && libpth="$libpth /usr/lib/large"
-test -d /lib && libpth="$libpth /lib"
- libpth="$libpth $xlibpth"
-test -d /lib/large && libpth="$libpth /lib/large"
-test -d /usr/lib/small && libpth="$libpth /usr/lib/small"
-test -d /lib/small && libpth="$libpth /lib/small"
-test -d /usr/lib/cmplrs/cc && libpth="$libpth /usr/lib/cmplrs/cc"
-
-smallmach='pdp11 i8086 z8000 i80286 iAPX286'
-trap 'echo " "; exit 1' 1 2 3
-
-: We must find out about Eunice early
-eunicefix=':'
-if test -f /etc/unixtovms; then
- eunicefix=/etc/unixtovms
-fi
-if test -f /etc/unixtovms.exe; then
- eunicefix=/etc/unixtovms.exe
-fi
-
-attrlist="DGUX M_I186 M_I286 M_I386 M_I8086 M_XENIX UTS __DGUX__"
-attrlist="$attrlist __STDC__ __m88k__ ansi bsd4_2 gcos gimpel"
-attrlist="$attrlist hp9000s300 hp9000s500 hp9000s800 hpux"
-attrlist="$attrlist i186 i386 i8086 iAPX286 ibm interdata"
-attrlist="$attrlist m68k m88k mc300 mc500 mc68000 mc68k mc700 mert"
-attrlist="$attrlist ns16000 ns32000 nsc32000 os pdp11 posix pyr sinix"
-attrlist="$attrlist sparc sun tower tower32 tower32_600 tower32_800 tss"
-attrlist="$attrlist u3b2 u3b20 u3b200 u3b5 ultrix unix vax venix xenix"
-attrlist="$attrlist z8000"
-boPATH=""
-eoPATH="/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 /bsd43/usr/bin /usr/ccs/lib /opt/SUNWste/bin /usr/opt/SUNWste/bin"
-d_newshome="/usr/NeWS"
-errnolist=errnolist
-h_fcntl=false
-h_sys_file=false
-serve_shm=""
-serve_msg="$undef"
-serve_inet_udp=""
-serve_inet_tcp=""
-serve_unix_udp=""
-serve_unix_tcp=""
-d_ndir=ndir
-voidwant=1
-voidwant=7
-libswanted="c_s net_s net socket nsl_s nsl nm ndir dir ndbm dbm PW malloc sun m bsd BSD x posix ucb"
-inclwanted='/usr/include /usr/netinclude /usr/include/sun /usr/include/bsd /usr/include/lan /usr/ucbinclude'
-
-: Now test for existence of everything in MANIFEST
-
-echo "First let's make sure your kit is complete. Checking..."
-awk '$1 !~ /PACKINGLIST/ {print $1}' ../MANIFEST | split -100
-rm -f missing
-for filelist in x??; do
- (cd ..; ls `cat UU/$filelist` >/dev/null 2>>UU/missing)
-done
-if test -s missing; then
- echo "WARNING: the following files are missing:"
- cat missing
- echo "INTERRUPT NOW, OR HIT RETURN TO PROCEED AT YOUR OWN RISK"
- read junk
-else
- echo "Looks good..."
-fi
-
-: some greps do not return status, grrr.
-echo "grimblepritz" >contains.txt
-if grep blurfldyick contains.txt >/dev/null 2>&1 ; then
- contains=contains
-elif grep grimblepritz contains.txt >/dev/null 2>&1 ; then
- contains=grep
-else
- contains=contains
-fi
-: 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..."
- if test -f /bsd43/bin/echo; then
- echo "#!/bsd43/bin/echo hi" > spit.sh
- else
- echo "#!/bin/echo hi" > spit.sh
- fi
- $eunicefix spit.sh
- chmod +x spit.sh
- ./spit.sh > today
- if $contains hi today >/dev/null 2>&1; then
- echo "It does."
- sharpbang='#!'
- else
- echo "#! /bin/echo hi" > spit.sh
- $eunicefix spit.sh
- chmod +x spit.sh
- ./spit.sh > 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 >start.sh <<EOSS
-$startsh
-set abc
-test "$?abc" != 1
-EOSS
-
-chmod +x start.sh
-$eunicefix start.sh
-if ./start.sh; then
- echo "Yup, it does."
-else
- echo "Nope. You may have to fix up the shell scripts to make sure sh runs them."
-fi
-
-: first determine how to suppress newline on echo command
-echo "Checking echo to see how to suppress newlines..."
-(echo "hi there\c" ; echo " ") >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
-
-: now set up to do reads with possible shell escape and default assignment
-cat <<EOSC >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 <<EOH
-
-This installation shell script will examine your system and ask you questions
-to determine how the $package package should be installed. If you get stuck
-on a question, you may use a ! shell escape to start a subshell or execute
-a command. Many of the questions will have default answers in square
-brackets--typing carriage return will give you the default.
-
-On some of the questions which ask for file or directory names you are
-allowed to use the ~name construct to specify the login directory belonging
-to "name", even if you don't have a shell which knows about that. Questions
-where this is allowed will be marked "(~name ok)".
-
-EOH
-rp="[Type carriage return to continue]"
-echo $n "$rp $c"
-. myread
-cat <<EOH
-
-Much effort has been expended to ensure that this shell script will run on any
-Unix system. If despite that it blows up on you, your best bet is to edit
-Configure and run it again. Also, let me (lwall@netlabs.com)
-know how I blew it. If you can't run Configure for some reason, you'll have
-to generate a config.sh file by hand.
-
-This installation script affects things in two ways: 1) it may do direct
-variable substitutions on some of the files included in this kit, and
-2) it builds a config.h file for inclusion in C programs. You may edit
-any of these files as the need arises after running this script.
-
-If you make a mistake on a question, there is no easy way to back up to it
-currently. The easiest thing to do is to edit config.sh and rerun all the
-SH files. Configure will offer to let you do this before it runs the SH files.
-
-EOH
-rp="[Type carriage return to continue]"
-echo $n "$rp $c"
-. myread
-
-: find out where common programs are
-echo " "
-echo "Locating common programs..."
-cat <<EOSC >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
-bison
-cpp
-csh
-egrep
-line
-nroff
-perl
-test
-uname
-yacc
-"
-pth=`echo :$boPATH:$PATH:$eoPATH: | sed -e 's/:/ /g'`
-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" >Loc1.txt
- echo $n "hi there$c" >Loc2.txt
- if cmp Loc1.txt Loc2.txt >/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 <<FOO
-They are not compatible! You are probably running ksh on a non-USG system.
-I'll have to use /bin/echo instead of the builtin, since Bourne shell doesn't
-have echo built in and we may have to run some Bourne shell scripts. That
-means I'll have to use $ans to suppress newlines now. Life is ridiculous.
-
-FOO
- rp="Your cursor should be here-->"
- $echo $n "$rp$c"
- . myread
- fi
- ;;
-*)
- : cross your fingers
- echo=echo
- ;;
-esac
-
-: set up shell script to do ~ expansion
-cat >filexp <<EOSS
-$startsh
-: expand filename
-case "\$1" in
- ~/*|~)
- echo \$1 | $sed "s|~|\${HOME-\$LOGDIR}|"
- ;;
- ~*)
- if $test -f /bin/csh; then
- /bin/csh -f -c "glob \$1"
- echo ""
- else
- name=\`$expr x\$1 : '..\([^/]*\)'\`
- dir=\`$sed -n -e "/^\${name}:/{s/^[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:\([^:]*\).*"'\$'"/\1/" -e p -e q -e '}' </etc/passwd\`
- if $test ! -d "\$dir"; then
- me=\`basename \$0\`
- echo "\$me: can't locate home directory for: \$name" >&2
- exit 1
- fi
- case "\$1" in
- */*)
- echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\`
- ;;
- *)
- echo \$dir
- ;;
- esac
- fi
- ;;
-*)
- echo \$1
- ;;
-esac
-EOSS
-chmod +x filexp
-$eunicefix filexp
-
-: get old answers, if there is a config file out there
-hint=default
-if test -f ../config.sh; then
- echo " "
- eval "`grep lastuname ../config.sh`"
- tmp=`(uname -a) 2>&1`
- if test "X$tmp" = "X$lastuname"; then
- dflt=y
- else
- dflt=n
- fi
- lastuname="$tmp"
- rp="I see a config.sh file. Did Configure make it on THIS system? [$dflt]"
- echo $n "$rp $c"
- . myread
- case "$ans" in
- n*) echo "OK, I'll ignore it."; mv ../config.sh ../config.sh.old;;
- *) echo "Fetching default answers from your old config.sh file..."
- tmp="$n"
- ans="$c"
- . ../config.sh
- n="$tmp"
- c="$ans"
- hint=previous
- ;;
- esac
-else
- lastuname=`(uname -a) 2>&1`
-fi
-if test -d ../hints && test ! -f ../config.sh; then
- echo ' '
- echo "First time through, eh? I have some defaults handy for the following systems:"
- (cd ../hints; ls -C *.sh | sed 's/\.sh/ /g')
- dflt=''
- : Half the following guesses are probably wrong...
- test -f /irix && dflt="$dflt sgi"
- test -f /xenix && dflt="$dflt sco_xenix"
- test -f /dynix && dflt="$dflt dynix"
- test -f /dnix && dflt="$dflt dnix"
- test -f /bin/mips && /bin/mips && dflt="$dflt mips"
- test -d /NextApps && test -f /usr/adm/software_version && dflt="$dflt next"
- if test -f /bin/uname || test -f /usr/bin/uname; then
- set `uname -a | tr '[A-Z]' '[a-z]'`
-
- test -f "../hints/$5.sh" && dflt="$dflt $5"
-
- case "$5" in
- 3b2) dflt="$dflt 3b2";;
- fps*) dflt="$dflt fps";;
- mips*) dflt="$dflt mips";;
- [23]100) dflt="$dflt mips";;
- next*) dflt="$dflt next" ;;
- 6000) dflt="$dflt mc6000";;
- esac
-
- test -f "../hints/$1.sh" && dflt="$dflt $1"
-
- case "$1" in
- aix) dflt="$dflt aix_rs" ;;
- sunos) case "$3" in
- 3.4) dflt="$dflt sunos_3_4" ;;
- 3.5) dflt="$dflt sunos_3_5" ;;
- 4.0.1) dflt="$dflt sunos_4_0_1" ;;
- 4.0.2) dflt="$dflt sunos_4_0_2" ;;
- esac
- ;;
- hp*ux) dflt="$dflt hpux"
- extra_hints="hp"`echo $5 | sed -e s#/#_#g -e s/..$/00/`
- if test -f ../hints/$extra_hints.sh; then
- dflt="$dflt $extra_hints"
- fi;;
- irix) dflt="$dflt sgi" ;;
- ultrix) case "$3" in
- 1*) dflt="$dflt ultrix_1" ;;
- 3*) dflt="$dflt ultrix_3" ;;
- 4*) dflt="$dflt ultrix_4" ;;
- esac
- ;;
- uts) dflt="$dflt uts" ;;
- $2) if test -f /etc/systemid; then
- set `echo $3 | sed 's/\./ /'` $4
- if test -f ../hints/sco_$1_$2_$3.sh; then
- dflt="$dflt sco_$1_$2_$3"
- elif test -f ../hints/sco_$1_$2.sh; then
- dflt="$dflt sco_$1_$2"
- elif test -f ../hints/sco_$1.sh; then
- dflt="$dflt sco_$1"
- fi
- fi
- ;;
- esac
- fi
- set X `echo $dflt | tr ' ' '\012' | sort | uniq`
- shift
- dflt=${1+"$@"}
- case "$dflt" in
- '') dflt=none;;
- esac
- echo '(You may give one or more space-separated answers, or "none" if appropriate.'
- echo 'If your OS version has no hints, do not give a wrong version--say "none".)'
- rp="Which of these apply, if any? [$dflt]"
- echo $n "$rp $c"
- . myread
- for file in $ans; do
- if test -f ../hints/$file.sh; then
- . ../hints/$file.sh
- cat ../hints/$file.sh >>../config.sh
- hint=recommended
- fi
- done
-fi
-
-cat >whoa <<'EOF'
-eval "was=\$$2"
-dflt=y
-echo ' '
-echo "*** WHOA THERE!!! ***"
-echo " The $hint value for \$$2 on this machine was \"$was\"!"
-rp=" Keep the $hint value? [y]"
-echo $n "$rp $c"
-. myread
-case "$ans" in
-y) td=$was; tu=$was;;
-esac
-EOF
-
-setvar='td=$define; tu=$undef; set X $1; eval "was=\$$2";
-case "$val$was" in
-defineundef) . whoa; eval "$2=\$td";;
-undefdefine) . whoa; eval "$2=\$tu";;
-*) eval "$2=$val";;
-esac'
-
-: determine where manual pages go
-$cat <<EOM
-
-$package has manual pages available in source form.
-EOM
-case "$nroff" in
-'nroff')
- echo "However, you don't have nroff, so they're probably useless to you."
- case "$mansrc" in
- '')
- mansrc="none"
- ;;
- esac
-esac
-echo "If you don't want the manual sources installed, answer 'none'."
-case "$mansrc" in
-'')
- dflt=`./loc . none /usr/man/local/man1 /usr/man/man.L /usr/man/manl /usr/man/mann /usr/man/u_man/man1 /usr/man/man1 /usr/local/man/man1`
- ;;
-*) dflt="$mansrc"
- ;;
-esac
-cont=true
-while $test "$cont" ; do
- echo " "
- rp="Where do the manual pages (source) go (~name ok)? [$dflt]"
- $echo $n "$rp $c"
- . myread
- case "$ans" in
- 'none')
- mansrc=''
- cont=''
- ;;
- *)
- mansrc=`./filexp "$ans"`
- if $test -d "$mansrc"; then
- cont=''
- else
- if $test "$fastread" = yes; then
- dflt=y
- else
- dflt=n
- fi
- rp="Directory $mansrc doesn't exist. Use that name anyway? [$dflt]"
- $echo $n "$rp $c"
- . myread
- dflt=''
- case "$ans" in
- y*) cont='';;
- esac
- fi
- ;;
- esac
-done
-case "$mansrc" in
-'')
- manext=''
- ;;
-*l)
- manext=l
- ;;
-*n)
- manext=n
- ;;
-*o)
- manext=l
- ;;
-*p)
- manext=n
- ;;
-*C)
- manext=C
- ;;
-*L)
- manext=L
- ;;
-*)
- manext=1
- ;;
-esac
-
-: Sigh. Well, at least the box is fast...
-echo " "
-$echo $n "Hmm... $c"
-case "$usrinclude" in
-'') dflt='/usr/include';;
-*) dflt=$usrinclude;;
-esac
-inclPath=''
-if $test -f /bin/mips && /bin/mips; then
- echo "Looks like a MIPS system..."
- $cat >usrinclude.c <<'EOCP'
-#ifdef SYSTYPE_BSD43
-/bsd43
-#endif
-EOCP
- if cc -E usrinclude.c > usrinclude.out && $contains / usrinclude.out >/dev/null 2>&1 ; then
- echo "and you're compiling with the BSD43 compiler and libraries."
- dflt='/bsd43/usr/include'
- inclPath='/bsd43'
- else
- echo "and you're compiling with the SysV compiler and libraries."
- fi
-else
- echo "Doesn't look like a MIPS system."
- echo "exit 1" >mips
- chmod +x mips
- $eunicefix mips
-fi
-
-cont=true
-while $test "$cont" ; do
- echo " "
- rp="Where are the include files you want to use? [$dflt]"
- $echo $n "$rp $c"
- . myread
- usrinclude="$ans"
- if $test -d $ans; then
- cont=''
- else
- if $test "$fastread" = yes; then
- dflt=y
- else
- dflt=n
- fi
- rp="Directory $ans doesn't exist. Use that name anyway? [$dflt]"
- $echo $n "$rp $c"
- . myread
- dflt=''
- case "$ans" in
- y*) cont='';;
- esac
- fi
-done
-
-: make some quick guesses about what we are up against
-echo " "
-echo exit 1 >bsd
-echo exit 1 >usg
-echo exit 1 >v7
-echo exit 1 >osf1
-echo exit 1 >eunice
-echo exit 1 >xenix
-echo exit 1 >venix
-cat $usrinclude/signal.h $usrinclude/sys/signal.h >guess.txt 2>/dev/null
-if test "$usrinclude" = "/bsd43/usr/include" ; then
- echo "Looks kind of like a SysV MIPS running BSD, but we'll see..."
- echo exit 0 >bsd
-elif test -f /osf_boot || $contains "OSF/1" /usr/include/ctype.h; then
- echo "Looks like an OSF/1 system, but we'll see..."
- echo exit 0 >osf1
-elif test `echo abc | tr a-z A-Z` = Abc ; then
- echo "Looks kind of like a USG system, but we'll see..."
- echo exit 0 >usg
-elif $contains SIGTSTP guess.txt >/dev/null 2>&1 ; then
- echo "Looks kind of like a BSD system, but we'll see..."
- echo exit 0 >bsd
-else
- echo "Looks kind of like a version 7 system, but we'll see..."
- 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"
- ;;
-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..."
-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
-fi
-chmod +x bsd usg v7 osf1 eunice venix
-$eunicefix bsd usg v7 eunice venix
-
-: see what memory models we can support
-case "$models" in
-'')
- : We may not use Cppsym or we get a circular dependency through cc.
- : But this should work regardless of which cc we eventually use.
- cat >pdp11.c <<'EOP'
-main() {
-#ifdef pdp11
- exit(0);
-#else
- exit(1);
-#endif
-}
-EOP
- cc -o pdp11 pdp11.c >/dev/null 2>&1
- if pdp11 2>/dev/null; then
- dflt='unsplit split'
- else
- ans=`./loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge`
- case "$ans" in
- X) dflt='none';;
- *) if $test -d /lib/small || $test -d /usr/lib/small; then
- dflt='small'
- else
- dflt=''
- fi
- if $test -d /lib/medium || $test -d /usr/lib/medium; then
- dflt="$dflt medium"
- fi
- if $test -d /lib/large || $test -d /usr/lib/large; then
- dflt="$dflt large"
- fi
- if $test -d /lib/huge || $test -d /usr/lib/huge; then
- dflt="$dflt huge"
- fi
- esac
- fi
- ;;
-*) dflt="$models" ;;
-esac
-$cat <<EOM
-
-Some systems have different model sizes. On most systems they are called
-small, medium, large, and huge. On the PDP11 they are called unsplit and
-split. If your system doesn't support different memory models, say "none".
-If you wish to force everything to one memory model, say "none" here and
-put the appropriate flags later when it asks you for other cc and ld flags.
-Venix systems may wish to put "none" and let the compiler figure things out.
-(In the following question multiple model names should be space separated.)
-
-EOM
-rp="Which models are supported? [$dflt]"
-$echo $n "$rp $c"
-. myread
-models="$ans"
-
-case "$models" in
-none)
- small=''
- medium=''
- large=''
- huge=''
- unsplit=''
- split=''
- ;;
-*split)
- case "$split" in
- '')
- if $contains '\-i' $mansrc/man1/ld.1 >/dev/null 2>&1 || \
- $contains '\-i' $mansrc/man1/cc.1 >/dev/null 2>&1; then
- dflt='-i'
- else
- dflt='none'
- fi
- ;;
- *) dflt="$split";;
- esac
- rp="What flag indicates separate I and D space? [$dflt]"
- $echo $n "$rp $c"
- . myread
- case "$ans" in
- none) ans='';;
- esac
- split="$ans"
- unsplit=''
- ;;
-*large*|*small*|*medium*|*huge*)
- case "$models" in
- *large*)
- case "$large" in
- '') dflt='-Ml';;
- *) dflt="$large";;
- esac
- rp="What flag indicates large model? [$dflt]"
- $echo $n "$rp $c"
- . myread
- case "$ans" in
- none) ans='';
- esac
- large="$ans"
- ;;
- *) large='';;
- esac
- case "$models" in
- *huge*)
- case "$huge" in
- '') dflt='-Mh';;
- *) dflt="$huge";;
- esac
- rp="What flag indicates huge model? [$dflt]"
- $echo $n "$rp $c"
- . myread
- case "$ans" in
- none) ans='';
- esac
- huge="$ans"
- ;;
- *) huge="$large";;
- esac
- case "$models" in
- *medium*)
- case "$medium" in
- '') dflt='-Mm';;
- *) dflt="$medium";;
- esac
- rp="What flag indicates medium model? [$dflt]"
- $echo $n "$rp $c"
- . myread
- case "$ans" in
- none) ans='';
- esac
- medium="$ans"
- ;;
- *) medium="$large";;
- esac
- case "$models" in
- *small*)
- case "$small" in
- '') dflt='none';;
- *) dflt="$small";;
- esac
- rp="What flag indicates small model? [$dflt]"
- $echo $n "$rp $c"
- . myread
- case "$ans" in
- none) ans='';
- esac
- small="$ans"
- ;;
- *) small='';;
- esac
- ;;
-*)
- echo "Unrecognized memory models--you may have to edit Makefile.SH"
- ;;
-esac
-
-: see if we need a special compiler
-echo " "
-if usg; then
- case "$cc" in
- '')
- case "$Mcc" in
- /*) dflt='Mcc'
- ;;
- *)
- case "$large" in
- -M*)
- dflt='cc'
- ;;
- *)
- if $contains '\-M' $mansrc/cc.1 >/dev/null 2>&1 ; then
- dflt='cc -M'
- else
- dflt='cc'
- fi
- ;;
- esac
- ;;
- esac
- ;;
- *) dflt="$cc";;
- esac
- $cat <<'EOM'
-
-On some systems the default C compiler will not resolve multiple global
-references that happen to have the same name. On some such systems the
-"Mcc" command may be used to force these to be resolved. On other systems
-a "cc -M" command is required. (Note that the -M flag on other systems
-indicates a memory model to use!) If you have the Gnu C compiler, you
-might wish to use that instead. What command will force resolution on
-EOM
- $echo $n "this system? [$dflt] $c"
- rp="Command to resolve multiple refs? [$dflt]"
- . myread
- cc="$ans"
-else
- case "$cc" in
- '') dflt=cc;;
- *) dflt="$cc";;
- esac
- rp="Use which C compiler? [$dflt]"
- $echo $n "$rp $c"
- . myread
- cc="$ans"
-fi
-case "$cc" in
-*gcc*) cpp=`./loc gcc-cpp $cpp $pth`
- case "$nativegcc" in
- '') case "$ccflags" in
- *-fpcc-struct-return*) dflt=n;;
- *) dflt=y;;
- esac
- ;;
- undef) dflt=n;;
- *) dflt=y;;
- esac
- echo " "
- rp="Are your system (especially dbm) libraries compiled with gcc? [$dflt]"
- $echo $n "$rp $c"
- . myread
- case "$ans" in
- n*) nativegcc="$undef"; gccflags='-fpcc-struct-return';;
- *) nativegcc="$define"; gccflags='';;
- esac
- case "$gccflags" in
- *-ansi*) ;;
- *-traditional*) ;;
- *) gccflags="$gccflags -traditional -Dvolatile=__volatile__" ;;
- esac
- ;;
-esac
-
-: determine optimize, if desired, or use for debug flag also
-case "$optimize" in
-' ') dflt="none"
- ;;
-'') dflt="-O";
- ;;
-*) dflt="$optimize"
- ;;
-esac
-cat <<EOH
-
-Some C compilers have problems with their optimizers, by default, $package
-compiles with the -O flag to use the optimizer. Alternately, you might
-want to use the symbolic debugger, which uses the -g flag (on traditional
-Unix systems). Either flag can be specified here. To use neither flag,
-specify the word "none".
-
-EOH
-rp="What optimizer/debugger flag should be used? [$dflt]"
-$echo $n "$rp $c"
-. myread
-optimize="$ans"
-case "$optimize" in
-'none') optimize=" "
- ;;
-esac
-
-case "$ccflags" in
-'') case "$cc" in
- *gcc*) dflt="$gccflags";;
- *) dflt='';;
- esac
- ;;
-*-fpcc-struct-return*) dflt="$ccflags";;
-*) case "$cc" in
- *gcc*) dflt="$ccflags $gccflags";;
- *) dflt="$ccflags";;
- esac
- ;;
-esac
-for thisincl in $inclwanted; do
- if test -d $thisincl; then
- if test "x$thisincl" != "x$usrinclude"; then
- case "$dflt" in
- *$thisincl*);;
- *) dflt="$dflt -I$thisincl";;
- esac
- fi
- fi
-done
-case "$optimize" in
--g*)
- case "$dflt" in
- *DEBUGGING*);;
- *) dflt="$dflt -DDEBUGGING";;
- esac
- ;;
-esac
-if $contains 'LANGUAGE_C' $usrinclude/signal.h >/dev/null 2>&1; then
- case "$dflt" in
- *LANGUAGE_C*);;
- *) dflt="$dflt -DLANGUAGE_C";;
- *) if osf1; then
- dflt="$dflt -D__LANGUAGE_C__"
- else
- dflt="$dflt -DLANGUAGE_C"
- fi
- ;;
- esac
-fi
-if $contains '_NO_PROTO' $usrinclude/signal.h >/dev/null 2>&1; then
- case "$dflt" in
- *_NO_PROTO*);;
- *) osf1 || dflt="$dflt -D_NO_PROTO";;
- esac
-fi
-case "$dflt" in
-'') dflt=none;;
-esac
-cat <<EOH
-
-Your C compiler may want other flags. For this question you should
-include -I/whatever and -DWHATEVER flags and any other flags used by
-the C compiler, but you should NOT include libraries or ld flags like
--lwhatever. For instance, this would be a good place to specify
--DDEBUGGING. To use no flags, specify the word "none".
-
-EOH
-rp="Any additional cc flags? [$dflt]"
-$echo $n "$rp $c"
-. myread
-case "$ans" in
-none) ans='';
-esac
-ccflags="$ans"
-
-: the following weeds options from ccflags that are of no interest to cpp
-cppflags="$ccflags"
-case "$cc" in
-*gcc*) cppflags="$cppflags -D__GNUC__";;
-esac
-case "$cppflags" in
-'');;
-*) set X $cppflags
- cppflags=''
- for flag do
- case $flag in
- -D*|-U*|-I*|-traditional|-ansi|-nostdinc) cppflags="$cppflags $flag";;
- esac
- done
- case "$cppflags" in
- *-*) echo "(C preprocessor flags: $cppflags)";;
- esac
- ;;
-esac
-
-case "$ldflags" in
-'') if venix; then
- dflt='-i -z'
- else
- dflt='none'
- fi
- ;;
-*) dflt="$ldflags";;
-esac
-echo " "
-rp="Any additional ld flags (NOT including libraries)? [$dflt]"
-$echo $n "$rp $c"
-. myread
-case "$ans" in
-none) ans='';
-esac
-ldflags="$ans"
-
-echo " "
-echo "Checking for optional libraries..."
-case "$libs" in
-'') dflt=' ';;
-*) dflt="$libs ";;
-esac
-case "$libswanted" in
-'') libswanted='c_s';;
-esac
-for thislib in $libswanted; do
- case "$thislib" in
- dbm) thatlib=ndbm;;
- *_s) thatlib=NONE;;
- *) thatlib="${thislib}_s";;
- *) thatlib=NONE;;
- esac
- xxx=`./loc lib$thislib.a X /usr/ccs/lib /usr/lib /usr/ucblib /usr/local/lib /lib`
- if test -f $xxx; then
- echo "Found -l$thislib."
- case "$dflt" in
- *-l$thislib\ *|*-l$thatlib\ *);;
- *) dflt="$dflt -l$thislib ";;
- esac
- else
- xxx=`./loc lib$thislib.a X $libpth`
- if test -f $xxx; then
- echo "Found $xxx."
- case "$dflt" in
- *"$xxx "*);;
- *) dflt="$dflt $xxx ";;
- esac
- else
- xxx=`./loc Slib$thislib.a X $xlibpth`
- if test -f $xxx; then
- echo "Found -l$thislib."
- case "$dflt" in
- *-l$thislib\ *|*-l$thatlib\ *);;
- *) dflt="$dflt -l$thislib ";;
- esac
- else
- xxx=`./loc lib$thislib.so X /usr/ccs/lib /usr/lib /usr/ucblib /usr/local/lib /lib`
- if test -f $xxx; then
- echo "Found -l$thislib as a shared object only."
- case "$dflt" in
- *-l$thislib\ *|*-l$thatlib\ *);;
- *) dflt="$dflt -l$thislib ";;
- esac
- else
- echo "No -l$thislib."
- fi
- fi
- fi
- fi
-done
-set X $dflt
-shift
-dflt="$*"
-case "$dflt" in
-'') dflt='none';;
-esac
-
-$cat <<EOM
-
-Some versions of Unix support shared libraries, which make
-executables smaller but make load time slightly longer.
-
-On some systems, mostly newer Unix System V's, the shared library
-is included by putting the option "-lc_s" as the last thing on the
-cc command line when linking. Other systems use shared libraries
-by default. There may be other libraries needed to compile $package
-on your machine as well. If your system needs the "-lc_s" option,
-include it here. Include any other special libraries here as well.
-Say "none" for none.
-EOM
-
-echo " "
-rp="Any additional libraries? [$dflt]"
-$echo $n "$rp $c"
-. myread
-case "$ans" in
-none) ans='';
-esac
-libs="$ans"
-
-: check for size of random number generator
-echo " "
-case "$alignbytes" in
-'')
- echo "Checking alignment constraints..."
- $cat >try.c <<'EOCP'
-struct foobar {
- char foo;
- double bar;
-} try;
-main()
-{
- printf("%d\n", (char*)&try.bar - (char*)&try.foo);
-}
-EOCP
- if $cc $ccflags 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="$alignbytes"
- ;;
-esac
-rp="Doubles must be aligned on a how-many-byte boundary? [$dflt]"
-$echo $n "$rp $c"
-. myread
-alignbytes="$ans"
-$rm -f try.c try
-
-: determine where public executables go
-cat <<EOF
-
-The following questions distinguish the directory in which executables
-reside from the directory in which they are installed (and from which they
-are presumably copied to the former directory by occult means). This
-distinction is often necessary under afs. On most other systems, however,
-the two directories are the same.
-
-EOF
-case "$bin" in
-'')
- dflt=`./loc . /usr/local/bin /usr/local/bin /usr/lbin /usr/local /usr/bin /bin`
- ;;
-*) dflt="$bin"
- ;;
-esac
-cont=true
-while $test "$cont" ; do
- rp="In which directory will public executables reside (~name ok)? [$dflt]"
- $echo "In which directory will public executables reside (~name ok)?"
- $echo $n "[$dflt] $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
-
-case "$bin" in
- ?????????????????????????)
- cat <<EOF
-
-NOTE: you have a fairly long path name there. Some systems have trouble
-executing a script if the #! line ends up longer than 32 characters. If
-you have this trouble you may have to reinstall somewhere else, or make
-a symbolic link from someplace with a shorter name.
-
-EOF
- ;;
-esac
-
-case "$installbin" in
-'')
- dflt=`echo $bin | sed 's#^/afs/#/afs/.#'`
- test -d $dflt || dflt="$bin"
- ;;
-*) dflt="$installbin"
- ;;
-esac
-cont=true
-while $test "$cont" ; do
- rp="In which directory will public executables be installed (~name ok)? [$dflt]"
- $echo "In which directory will public executables be installed (~name ok)?"
- $echo $n "[$dflt] $c"
- . myread
- installbin="$ans"
- installbin=`./filexp $installbin`
- if test -d $installbin; then
- cont=''
- else
- case "$fastread" in
- yes) dflt=y;;
- *) dflt=n;;
- esac
- rp="Directory $installbin doesn't exist. Use that name anyway? [$dflt]"
- $echo $n "$rp $c"
- . myread
- dflt=''
- case "$ans" in
- y*) cont='';;
- esac
- fi
-done
-
-: check for ordering of bytes in a long
-case "$byteorder" in
-'')
-cat <<'EOM'
-
-In the following, larger digits indicate more significance. A big-endian
-machine like a Pyramid or a Motorola 680?0 chip will come out to 4321. A
-little-endian machine like a Vax or an Intel 80?86 chip would be 1234. Other
-machines may have weird orders like 3412. A Cray will report 87654321. If
-the test program works the default is probably right.
-I'm now running the test program...
-EOM
- $cat >byteorder.c <<'EOCP'
-#include <stdio.h>
-main()
-{
- int i;
- union {
- unsigned long l;
- char c[sizeof(long)];
- } u;
-
- if (sizeof(long) > 4)
- u.l = (0x08070605L << 32) | 0x04030201L;
- else
- u.l = 0x04030201L;
- for (i=0; i < sizeof(long); i++)
- printf("%c",u.c[i]+'0');
- printf("\n");
-}
-EOCP
- if $cc byteorder.c -o byteorder >/dev/null 2>&1 ; then
- dflt=`./byteorder`
- 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"
-
-: check for ability to cast negative floats to unsigned
-echo " "
-echo 'Checking to see if your C compiler can cast weird floats to unsigned'
-$cat >try.c <<'EOCP'
-#include <signal.h>
-
-blech() { exit(3); }
-
-main()
-{
- double f = -123;
- unsigned long along;
- unsigned int aint;
- unsigned short ashort;
- int result = 0;
-
- signal(SIGFPE, blech);
- along = (unsigned long)f;
- aint = (unsigned int)f;
- ashort = (unsigned short)f;
- if (along != (unsigned long)-123)
- result |= 1;
- if (aint != (unsigned int)-123)
- result |= 1;
- if (ashort != (unsigned short)-123)
- result |= 1;
- f = (double)0x40000000;
- f = f + f;
- along = 0;
- along = (unsigned long)f;
- if (along != 0x80000000)
- result |= 2;
- f -= 1;
- along = 0;
- along = (unsigned long)f;
- if (along != 0x7fffffff)
- result |= 1;
- f += 2;
- along = 0;
- along = (unsigned long)f;
- if (along != 0x80000001)
- result |= 2;
- exit(result);
-}
-EOCP
-if $cc -o try $ccflags try.c >/dev/null 2>&1; then
- ./try
- castflags=$?
-else
- castflags=3
-fi
-case "$castflags" in
-0) val="$define"
- echo "Yup, it does."
- ;;
-*) val="$undef"
- echo "Nope, it doesn't."
- ;;
-esac
-set d_castneg
-eval $setvar
-$rm -f 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
-
-cd ..
-echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin
-chmod 755 cppstdin
-wrapper=cppstdin
-
-case "$cppstdin" in
-/*cppstdin) cppstdin=cppstdin;;
-esac
-cp cppstdin UU
-cd UU
-
-if test "X$cppstdin" != "X" && \
- $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \
- $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "You used to use $cppstdin $cppminus so we'll use that again."
-elif test "$cc" = gcc && \
- (echo "Using gcc, eh? We'll try to force gcc -E using a wrapper..."; \
- $wrapper <testcpp.c >testcpp.out 2>&1; \
- $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1) ; then
- echo "Yup, we can."
- cppstdin="$wrapper"
- cppminus='';
-elif echo 'Maybe "'"$cc"' -E" will work...'; \
- $cc -E <testcpp.c >testcpp.out 2>&1; \
- $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "Yup, it does."
- cppstdin="$cc -E"
- cppminus='';
-elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \
- $cc -E - <testcpp.c >testcpp.out 2>&1; \
- $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "Yup, it does."
- cppstdin="$cc -E"
- cppminus='-';
-elif echo 'No such luck, maybe "'$cpp'" will work...'; \
- $cpp <testcpp.c >testcpp.out 2>&1; \
- $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "It works!"
- cppstdin="$cpp"
- cppminus='';
-elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \
- $cpp - <testcpp.c >testcpp.out 2>&1; \
- $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "Hooray, it works! I was beginning to wonder."
- cppstdin="$cpp"
- cppminus='-';
-elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \
- $wrapper <testcpp.c >testcpp.out 2>&1; \
- $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- cppstdin="$wrapper"
- cppminus=''
- echo "Eureka!."
-elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \
- $cc -P <testcpp.c >testcpp.out 2>&1; \
- $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "Yipee, that works!"
- cppstdin="$cc -P"
- cppminus='';
-elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \
- $cc -P - <testcpp.c >testcpp.out 2>&1; \
- $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "At long last!"
- cppstdin="$cc -P"
- cppminus='-';
-else
- dflt=blurfl
- $echo $n "No dice. I can't find a C preprocessor. Name one: $c"
- rp='Name a C preprocessor:'
- . myread
- cppstdin="$ans"
- $cppstdin <testcpp.c >testcpp.out 2>&1
- if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "OK, that will do."
- else
- echo "Sorry, I can't get that to work. Go find one and rerun Configure."
- exit 1
- fi
-fi
-
-: get list of predefined functions in a handy place
-echo " "
-case "$libc" in
-'') libc=unknown;;
-esac
-case "$nm_opts" in
-'') if test -f /mach_boot; then
- nm_opts=''
- elif test -d /usr/ccs/lib; then
- nm_opts='-p'
- else
- nm_opts=''
- fi
- ;;
-esac
-: on mips, we DO NOT want /lib, and we want inclPath/usr/lib
-case "$libpth" in
-'') if mips; then
- libpth='$inclPath/usr/lib /usr/local/lib'
- nm_opts="-B"
- else
- libpth='/usr/ccs/lib /lib /usr/lib /usr/ucblib /usr/local/lib'
- fi
- ;;
-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/ccs/lib/libc.so
-test -f $1 || set /usr/lib/libc.so
-test -f $1 || set /usr/shlib/libc.so
-test -f $1 || set /usr/lib/libc.so.[0-9]*
-test -f $1 || set /lib/libsys_s.a
-eval set \$$#
-if test -f "$1"; then
- echo "Your (shared) C library seems to be in $1."
- libc="$1"
-elif test -f "$libc"; then
- echo "Your C library seems to be in $libc."
-elif test -f /lib/libc.a; then
- echo "Your C library seems to be in /lib/libc.a. You're normal."
- libc=/lib/libc.a
-else
- if ans=`./loc libc.a blurfl/dyick $libpth`; test -f "$ans"; then
- :
- elif ans=`./loc libc blurfl/dyick $libpth`; test -f "$ans"; then
- libnames="$libnames "`./loc clib blurfl/dyick $libpth`
- elif ans=`./loc clib blurfl/dyick $libpth`; test -f "$ans"; then
- :
- elif ans=`./loc Slibc.a blurfl/dyick $xlibpth`; test -f "$ans"; then
- :
- elif ans=`./loc Mlibc.a blurfl/dyick $xlibpth`; test -f "$ans"; then
- :
- elif ans=`./loc Llibc.a blurfl/dyick $xlibpth`; test -f "$ans"; then
- :
- fi
- if test -f "$ans"; then
- echo "Your C library seems to be in $ans, of all places."
- libc=$ans
- else
- cat <<EOM
-
-I can't seem to find your C library. I've looked in the following places:
-
- $libpth
-
-None of these seems to contain your C library. What is the full name
-EOM
- dflt=None
- $echo $n "of your C library? $c"
- rp='C library full name?'
- . myread
- libc="$ans"
- fi
-fi
-echo " "
-if test $libc = "/lib/libc"; then
- libc="$libc /lib/clib"
-fi
-cat <<END
-
-If the guess above is wrong (which it might be if you're using a strange
-compiler, or your machine supports multiple models), you can override it here.
-END
-dflt="$libc";
-rp="Your C library is where? [$dflt]"
-$echo $n "$rp $c"
-. myread
-libc="$ans"
-echo " "
-echo $libc $libnames | tr ' ' '\012' | sort | uniq >libnames
-$echo "Extracting names from the following files for later perusal:"
-sed 's/^/ /' libnames
-echo $n "This may take a while...$c"
-set X `cat libnames`
-shift
-nm $nm_opts $* 2>/dev/null >libc.tmp
-$sed -n -e 's/^.* [ATDS] *[_.]*//p' -e 's/^.* [ATDS] //p' <libc.tmp >libc.list
-if $contains '^printf$' libc.list >/dev/null 2>&1; then
- echo done
-elif $sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p' \
- <libc.tmp >libc.list; \
- $contains '^printf$' libc.list >/dev/null 2>&1; then
- echo done
-elif $sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p' <libc.tmp >libc.list; \
- $contains '^printf$' libc.list >/dev/null 2>&1; then
- echo done
-elif $sed -n -e 's/^.* D __*//p' -e 's/^.* D //p' <libc.tmp >libc.list; \
- $contains '^printf$' libc.list >/dev/null 2>&1; then
- echo done
-elif $sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p' \
- <libc.tmp >libc.list; \
- $contains '^printf$' libc.list >/dev/null 2>&1; then
- echo done
-elif $grep '|' <libc.tmp | $sed -n -e '/|COMMON/d' -e '/|DATA/d' -e '/ file/d' \
- -e 's/^\([^ ]*\).*/\1/p' >libc.list
- $contains '^printf$' libc.list >/dev/null 2>&1; then
- echo done
-elif $sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p' \
- <libc.tmp >libc.list; \
- $contains '^printf$' libc.list >/dev/null 2>&1; then
- echo done
-elif $sed -n -e 's/^[ ]*[0-9][0-9a-f]*[ ]*Def. Text[ ]*//p' \
- < libc.tmp | $sed -e 's/\[.*\]//' > libc.list; \
- $contains '^printf$' libc.list >/dev/null 2>&1; then
- echo done
-else
- nm -p $* 2>/dev/null >libc.tmp
- $sed -n -e 's/^.* [AT] *_[_.]*//p' -e 's/^.* [AT] //p' <libc.tmp >libc.list
- if $contains '^printf$' libc.list >/dev/null 2>&1; then
- nm_opts='-p'
- 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
-if test -f /lib/syscalls.exp; then
- echo "Also extracting names from /lib/syscalls.exp for good ole AIX..."
- sed -n 's/^\([^ ]*\)[ ]*syscall$/\1/p' /lib/syscalls.exp >>libc.list
-fi
-
-inlibc='echo " "; td=$define; tu=$undef;
-if $contains "^$1\$" libc.list >/dev/null 2>&1;
-then echo "$1() found";
- eval "case \"\$$2\" in undef) . whoa; esac"; eval "$2=\$td";
-else echo "$1() NOT found";
- eval "case \"\$$2\" in define) . whoa; esac"; eval "$2=\$tu"; fi'
-
-: see if bcmp exists
-set bcmp d_bcmp
-eval $inlibc
-
-: see if bcopy exists
-set bcopy d_bcopy
-eval $inlibc
-
-case "$d_safebcpy" in
-'')
- : assume the worst
- d_safebcpy=undef
- case "$d_bcopy" in
- define)
- echo "Checking to see if your bcopy() can do overlapping copies..."
- $cat >safebcpy.c <<'EOCP'
-main()
-{
- char buf[128];
- register char *b;
- register int len;
- register int off;
- register int align;
-
- for (align = 7; align >= 0; align--) {
- for (len = 36; len; len--) {
- b = buf+align;
- bcopy("abcdefghijklmnopqrstuvwxyz0123456789", b, len);
- for (off = 1; off <= len; off++) {
- bcopy(b, b+off, len);
- bcopy(b+off, b, len);
- if (bcmp(b, "abcdefghijklmnopqrstuvwxyz0123456789", len))
- exit(1);
- }
- }
- }
- exit(0);
-}
-EOCP
- if $cc safebcpy.c -o safebcpy $ccflags $libs >/dev/null 2>&1 ; then
- if ./safebcpy; then
- echo "It can."
- d_safebcpy=define
- else
- echo "It can't."
- fi
- else
- echo "(I can't compile the test program, so we'll assume not...)"
- fi
- ;;
- esac
- ;;
-esac
-
-: 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'
-#include <stdio.h>
-main()
-{
- int sprintf();
- 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)."
- val="$undef"
-else
- echo "Your sprintf() returns (char*)."
- val="$define"
-fi
-set d_charsprf
-eval $setvar
-
-: see if vprintf exists
-echo " "
-if $contains '^vprintf$' libc.list >/dev/null 2>&1; then
- echo 'vprintf() found.'
- val="$define"
- cat >vprintf.c <<'EOF'
-#include <varargs.h>
-
-main() { xxx("foo"); }
-
-xxx(va_alist)
-va_dcl
-{
- va_list args;
- char buf[10];
-
- va_start(args);
- exit((unsigned long)vsprintf(buf,"%s",args) > 10L);
-}
-EOF
- if $cc $ccflags vprintf.c -o vprintf >/dev/null 2>&1 && ./vprintf; then
- echo "Your vsprintf() returns (int)."
- val2="$undef"
- else
- echo "Your vsprintf() returns (char*)."
- val2="$define"
- fi
-else
- echo 'vprintf() NOT found.'
- val="$undef"
- val2="$undef"
-fi
-set d_vprintf
-eval $setvar
-val=$val2
-set d_charvspr
-eval $setvar
-
-: see if chsize exists
-set chsize d_chsize
-eval $inlibc
-
-: see if crypt exists
-echo " "
-if $contains '^crypt$' libc.list >/dev/null 2>&1; then
- echo 'crypt() found.'
- val="$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.'
- val="$undef"
- else
- val="$define"
- fi
-fi
-set d_crypt
-eval $setvar
-
-: get csh whereabouts
-case "$csh" in
-'csh') val="$undef" ;;
-*) val="$define" ;;
-esac
-set d_csh
-eval $setvar
-
-: see if readdir exists
-set readdir d_readdir
-eval $inlibc
-
-: see if there are directory access routines out there
-echo " "
-xxx=`./loc ndir.h x $usrinclude /usr/local/include $inclwanted`
-case "$xxx" in
-x)
- xxx=`./loc sys/ndir.h x $usrinclude /usr/local/include $inclwanted`
- ;;
-esac
-D_dirnamlen="$undef"
-I_dirent="$undef"
-I_sys_dir="$undef"
-I_my_dir="$undef"
-I_ndir="$undef"
-I_sys_ndir="$undef"
-libndir=''
-ndirc=''
-ndiro=''
-if $test -r $usrinclude/dirent.h; then
- echo "dirent.h found."
- if $contains 'd_namlen' $usrinclude/dirent.h >/dev/null 2>&1; then
- D_dirnamlen="$define"
- fi
- I_dirent="$define"
-elif $test -r $xxx; then
- echo "You seem to use <$xxx>,"
- if $test "$d_readdir" = "$define"; then
- echo "and I can get readdir() from your C library."
- elif $test -r /usr/lib/libndir.a || $test -r /usr/local/lib/libndir.a; then
- echo "and I'll get the routines using -lndir ."
- libndir='-lndir'
- else
- ans=`./loc libndir.a x $libpth`
- case "$ans" in
- x)
- echo "but I can't find the ndir library!"
- ;;
- *)
- echo "and I found the directory library in $ans."
- libndir="$ans"
- ;;
- esac
- fi
- if $contains 'd_namlen' $xxx >/dev/null 2>&1; then
- D_dirnamlen="$define"
- fi
- case "$xxx" in
- sys/)
- I_sys_ndir="$define"
- ;;
- *)
- I_ndir="$define"
- ;;
- esac
-else
- : The next line used to require this to be a bsd system.
- if $contains '^readdir$' libc.list >/dev/null 2>&1 ; then
- echo "No ndir library found, but you have readdir() so we'll use that."
- if $contains 'd_namlen' $usrinclude/sys/dir.h >/dev/null 2>&1; then
- D_dirnamlen="$define"
- fi
- I_sys_dir="$define"
- else
- echo "No ndir library found--using ./$d_ndir.c."
-: This will lose since $d_ndir.h is in another directory.
-: I doubt we can rely on it being in ../$d_ndir.h .
-: At least it will fail in a conservative manner.
- if $contains 'd_namlen' $d_ndir.h >/dev/null 2>&1; then
- D_dirnamlen="$define"
- fi
- I_my_dir="$define"
- ndirc="$d_ndir.c"
- ndiro="$d_ndir.o"
- fi
-fi
-val=$D_dirnamlen; set d_dirnamlen; eval $setvar
-val=$I_dirent; set i_dirent; eval $setvar
-val=$I_sys_dir; set i_sys_dir; eval $setvar
-val=$I_my_dir; set i_my_dir; eval $setvar
-val=$I_ndir; set i_ndir; eval $setvar
-val=$I_sys_ndir; set i_sys_ndir; eval $setvar
-
-: now see if they want to do setuid emulation
-case "$d_dosuid" in
-'') dflt=n;;
-*undef*) dflt=n;;
-*) dflt=y;;
-esac
-cat <<EOM
-
-Some sites have disabled setuid #! scripts because of a bug in the kernel
-that prevents them from being secure. If you are on such a system, the
-setuid/setgid bits on scripts are currently useless. It is possible for
-$package to detect those bits and emulate setuid/setgid in a secure fashion
-until a better solution is devised for the kernel problem.
-
-EOM
-rp="Do you want to do setuid/setgid emulation? [$dflt]"
-$echo $n "$rp $c"
-. myread
-case "$ans" in
-'') $ans="$dflt";;
-esac
-case "$ans" in
-y*) d_dosuid="$define";;
-*) d_dosuid="$undef";;
-esac
-
-: see if dup2 exists
-set dup2 d_dup2
-eval $inlibc
-
-: see if fchmod exists
-set fchmod d_fchmod
-eval $inlibc
-
-: see if fchown exists
-set fchown d_fchown
-eval $inlibc
-
-: see if this is an fcntl system
-set fcntl d_fcntl
-eval $inlibc
-
-: see if we can have long filenames
-echo " "
-rm -f 123456789abcde
-if (echo hi >123456789abcdef) 2>/dev/null; then
- : not version 8
- if test -f 123456789abcde; then
- echo 'You cannot have filenames longer than 14 characters. Sigh.'
- val="$undef"
- else
- echo 'You can have filenames longer than 14 characters.'
- val="$define"
- fi
-else
- : version 8 probably
- echo "You can't have filenames longer than 14 chars. You can't even think about them!"
- val="$undef"
-fi
-set d_flexfnam
-eval $setvar
-
-: see if flock exists
-set flock d_flock
-eval $inlibc
-
-: see if getgroups exists
-set getgroups d_getgrps
-eval $inlibc
-
-: see if gethostent exists
-set gethostent d_gethent
-eval $inlibc
-
-: see if getpgrp exists
-set getpgrp d_getpgrp
-eval $inlibc
-
-: see if getpgrp2 exists
-set getpgrp2 d_getpgrp2
-eval $inlibc
-
-: see if getpriority exists
-set getpriority d_getprior
-eval $inlibc
-
-: see if htonl exists
-set htonl d_htonl
-eval $inlibc
-
-: index or strcpy
-echo " "
-case "$d_index" in
-undef) dflt=y;;
-define) dflt=n;;
-*) if $test -f /unix; then
- dflt=n
- else
- dflt=y
- fi
- ;;
-esac
-if $contains '^index$' libc.list >/dev/null 2>&1 ; then
- if $contains '^strchr$' libc.list >/dev/null 2>&1 ; then
- echo "Your system has both index() and strchr(). Shall I use"
- rp="index() rather than strchr()? [$dflt]"
- $echo $n "$rp $c"
- . myread
- case "$ans" in
- n*) d_index="$define" ;;
- *) d_index="$undef" ;;
- esac
- else
- d_index="$undef"
- echo "index() found."
- fi
-else
- 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 isascii exists
-set isascii d_isascii
-eval $inlibc
-
-: 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
-
-case "$d_safemcpy" in
-'')
- : assume the worst
- d_safemcpy=undef
- case "$d_memcpy" in
- define)
- echo "Checking to see if your memcpy() can do overlapping copies..."
- $cat >safemcpy.c <<'EOCP'
-main()
-{
- char buf[128];
- register char *b;
- register int len;
- register int off;
- register int align;
-
- for (align = 7; align >= 0; align--) {
- for (len = 36; len; len--) {
- b = buf+align;
- memcpy(b,"abcdefghijklmnopqrstuvwxyz0123456789", len);
- for (off = 1; off <= len; off++) {
- memcpy(b+off, b, len);
- memcpy(b, b+off, len);
- if (memcmp(b, "abcdefghijklmnopqrstuvwxyz0123456789", len))
- exit(1);
- }
- }
- }
- exit(0);
-}
-EOCP
- if $cc safemcpy.c -o safemcpy $ccflags $libs >/dev/null 2>&1 ; then
- if ./safemcpy; then
- echo "It can."
- d_safemcpy=define
- else
- echo "It can't."
- fi
- else
- echo "(I can't compile the test program, so we'll assume not...)"
- fi
- ;;
- esac
- ;;
-esac
-
-: see if memmove exists
-set memmove d_memmove
-eval $inlibc
-
-: see if memset exists
-set memset d_memset
-eval $inlibc
-
-: see if mkdir exists
-set mkdir d_mkdir
-eval $inlibc
-
-: see if msgctl exists
-set msgctl d_msgctl
-eval $inlibc
-
-: see if msgget exists
-set msgget d_msgget
-eval $inlibc
-
-: see if msgsnd exists
-set msgsnd d_msgsnd
-eval $inlibc
-
-: see if msgrcv exists
-set msgrcv d_msgrcv
-eval $inlibc
-
-: see how much of the 'msg*(2)' library is present.
-h_msg=true
-echo " "
-case "$d_msgctl$d_msgget$d_msgsnd$d_msgrcv" in
-*undef*) h_msg=false;;
-esac
-: we could also check for sys/ipc.h ...
-if $h_msg && $test -r $usrinclude/sys/msg.h; then
- echo "You have the full msg*(2) library."
- val="$define"
-else
- echo "You don't have the full msg*(2) library."
- val="$undef"
-fi
-set d_msg
-eval $setvar
-
-: determine which malloc to compile in
-echo " "
-case "$d_mymalloc" in
-'')
- case "$usemymalloc" in
- '')
- if bsd || v7; then
- dflt='y'
- else
- dflt='n'
- fi
- ;;
- n*) dflt=n;;
- *) dflt=y;;
- esac
- ;;
-define) dflt="y"
- ;;
-*) dflt="n"
- ;;
-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
-case "$ans" in
-y*) mallocsrc='malloc.c'; mallocobj='malloc.o'
- libs=`echo $libs | sed 's/-lmalloc//'`
- val="$define"
- case "$mallocptrtype" in
- '')
- cat >usemymalloc.c <<'END'
-#ifdef __STDC__
-#include <stdlib.h>
-#else
-#include <malloc.h>
-#endif
-void *malloc();
-END
- if $cc $ccflags -c usemymalloc.c >/dev/null 2>&1; then
- mallocptrtype=void
- else
- mallocptrtype=char
- fi
- ;;
- esac
- echo " "
- echo "Your system wants malloc to return $mallocptrtype*, it would seem."
- ;;
-*) mallocsrc='';
- mallocobj='';
- mallocptrtype=void
- val="$undef"
- ;;
-esac
-set d_mymalloc
-eval $setvar
-
-: see if ndbm is available
-echo " "
-xxx=`./loc ndbm.h x $usrinclude /usr/local/include $inclwanted`
-if test -f $xxx; then
- val="$define"
- echo "ndbm.h found."
-else
- val="$undef"
- echo "ndbm.h NOT found."
-fi
-set d_ndbm
-eval $setvar
-
-: see if we have the old dbm
-echo " "
-xxx=`./loc dbm.h x $usrinclude /usr/local/include $inclwanted`
-if test -f $xxx; then
- val="$define"
- echo "dbm.h found."
-else
- val="$undef"
- echo "dbm.h NOT found."
-fi
-set d_odbm
-eval $setvar
-
-: see whether socket exists
-echo " "
-socketlib=''
-if $contains socket libc.list >/dev/null 2>&1; then
- echo "Looks like you have Berkeley networking support."
- val="$define"
- : now check for advanced features
- if $contains setsockopt libc.list >/dev/null 2>&1; then
- val2="$undef"
- else
- echo "...but it uses the old 4.1c interface, rather than 4.2"
- val2="$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."
- val="$define"
- : we will have to assume that it supports the 4.2 BSD interface
- val2="$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 -lnsl_s"
- val="$define"
- : now check for advanced features
- if $contains setsockopt libc.list >/dev/null 2>&1; then
- val2="$undef"
- else
- echo "...using the old 4.1c interface, rather than 4.2"
- val2="$define"
- fi
- else
- echo "or even in libnet.a, which is peculiar."
- val="$undef"
- val2="$undef"
- fi
- else
- echo "or anywhere else I see."
- val="$undef"
- val2="$undef"
- fi
- fi
-fi
-set d_socket
-eval $setvar
-
-if $contains socketpair libc.list >/dev/null 2>&1; then
- val="$define"
-else
- val="$undef"
-fi
-set d_sockpair
-eval $setvar
-val=$val2
-set d_oldsock
-eval $setvar
-
-: Locate the flags for 'open()'
-echo " "
-$cat >open3.c <<'EOCP'
-#include <sys/types.h>
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
-main() {
-
- if(O_RDONLY);
-
-#ifdef O_TRUNC
- exit(0);
-#else
- exit(1);
-#endif
-}
-EOCP
-: check sys/file.h first to get FREAD on Sun
-if $test -r $usrinclude/sys/file.h && \
- $cc $cppflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then
- h_sys_file=true;
- echo "sys/file.h defines the O_* constants..."
- if ./open3; then
- echo "and you have the 3 argument form of open()."
- val="$define"
- else
- echo "but not the 3 argument form of open(). Oh, well."
- val="$undef"
- fi
-elif $test -r $usrinclude/fcntl.h && \
- $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then
- h_fcntl=true;
- echo "fcntl.h defines the O_* constants..."
- if ./open3; then
- echo "and you have the 3 argument form of open()."
- val="$define"
- else
- echo "but not the 3 argument form of open(). Oh, well."
- val="$undef"
- fi
-else
- val="$undef"
- echo "I can't find the O_* constant definitions! You got problems."
-fi
-set d_open3
-eval $setvar
-
-: see if how pwd stuff is defined
-echo " "
-if $test -r $usrinclude/pwd.h ; then
- i_pwd="$define"
- echo "pwd.h found."
- $cppstdin $cppflags $cppminus <$usrinclude/pwd.h | \
- sed -n '/struct[ ][ ]*passwd/,/^};/p' >pwd.txt
- if $contains 'pw_quota' pwd.txt >/dev/null 2>&1; then
- d_pwquota="$define"
- else
- d_pwquota="$undef"
- fi
- if $contains 'pw_age' pwd.txt >/dev/null 2>&1; then
- d_pwage="$define"
- else
- d_pwage="$undef"
- fi
- if $contains 'pw_change' pwd.txt >/dev/null 2>&1; then
- d_pwchange="$define"
- else
- d_pwchange="$undef"
- fi
- if $contains 'pw_class' pwd.txt >/dev/null 2>&1; then
- d_pwclass="$define"
- else
- d_pwclass="$undef"
- fi
- if $contains 'pw_expire' pwd.txt >/dev/null 2>&1; then
- d_pwexpire="$define"
- else
- d_pwexpire="$undef"
- fi
- if $contains 'pw_comment' pwd.txt >/dev/null 2>&1; then
- d_pwcomment="$define"
- else
- d_pwcomment="$undef"
- fi
-else
- i_pwd="$undef"
- d_pwquota="$undef"
- d_pwage="$undef"
- d_pwchange="$undef"
- d_pwclass="$undef"
- d_pwexpire="$undef"
- d_pwcomment="$undef"
- echo "No pwd.h found."
-fi
-
-: see if rename exists
-set rename d_rename
-eval $inlibc
-
-: see if rewindir exists
-set rewinddir d_rewindir
-eval $inlibc
-
-: see if rmdir exists
-set rmdir d_rmdir
-eval $inlibc
-
-: see if seekdir exists
-set seekdir d_seekdir
-eval $inlibc
-
-: see if select exists
-set select d_select
-eval $inlibc
-
-: see if semctl exists
-set semctl d_semctl
-eval $inlibc
-
-: see if semget exists
-set semget d_semget
-eval $inlibc
-
-: see if semop exists
-set semop d_semop
-eval $inlibc
-
-: see how much of the 'sem*(2)' library is present.
-h_sem=true
-echo " "
-case "$d_semctl$d_semget$d_semop" in
-*undef*) h_sem=false;;
-esac
-: we could also check for sys/ipc.h ...
-if $h_sem && $test -r $usrinclude/sys/sem.h; then
- echo "You have the full sem*(2) library."
- val="$define"
-else
- echo "You don't have the full sem*(2) library."
- val="$undef"
-fi
-set d_sem
-eval $setvar
-
-: 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
-
-: see if shmctl exists
-set shmctl d_shmctl
-eval $inlibc
-
-: see if shmget exists
-set shmget d_shmget
-eval $inlibc
-
-: see if shmat exists
-set shmat d_shmat
-eval $inlibc
-
-d_voidshmat="$undef"
-case "$d_shmat" in
-define)
- $cppstdin $cppflags $cppminus < $usrinclude/sys/shm.h >voidshmat.txt 2>/dev/null
- if $contains "void.*shmat" voidshmat.txt >/dev/null 2>&1; then
- echo "and shmat returns (void*)"
- d_voidshmat="$define"
- else
- echo "and shmat returns (char*)"
- fi
- ;;
-esac
-
-: see if shmdt exists
-set shmdt d_shmdt
-eval $inlibc
-
-: see how much of the 'shm*(2)' library is present.
-h_shm=true
-echo " "
-case "$d_shmctl$d_shmget$d_shmat$d_shmdt" in
-*undef*) h_shm=false;;
-esac
-: we could also check for sys/ipc.h ...
-if $h_shm && $test -r $usrinclude/sys/shm.h; then
- echo "You have the full shm*(2) library."
- val="$define"
-else
- echo "You don't have the full shm*(2) library."
- val="$undef"
-fi
-set d_shm
-eval $setvar
-
-: see if stat knows about block sizes
-echo " "
-if $contains 'st_blocks;' $usrinclude/sys/stat.h >/dev/null 2>&1 ; then
- if $contains 'st_blksize;' $usrinclude/sys/stat.h >/dev/null 2>&1 ; then
- echo "Your stat knows about block sizes."
- val="$define"
- else
- echo "Your stat doesn't know about block sizes."
- val="$undef"
- fi
-else
- echo "Your stat doesn't know about block sizes."
- val="$undef"
-fi
-set d_statblks
-eval $setvar
-
-: see if stdio is really std
-echo " "
-if $contains 'char.*_ptr.*;' $usrinclude/stdio.h >/dev/null 2>&1 ; then
- if $contains '_cnt;' $usrinclude/stdio.h >/dev/null 2>&1 ; then
- echo "Your stdio is pretty std."
- val="$define"
- else
- echo "Your stdio isn't very std."
- val="$undef"
- fi
-else
- echo "Your stdio isn't very std."
- val="$undef"
-fi
-set d_stdstdio
-eval $setvar
-
-: check for structure copying
-echo " "
-echo "Checking to see if your C compiler can copy structs..."
-$cat >strctcpy.c <<'EOCP'
-main()
-{
- struct blurfl {
- int dyick;
- } foo, bar;
-
- foo = bar;
-}
-EOCP
-if $cc -c strctcpy.c >/dev/null 2>&1 ; then
- val="$define"
- echo "Yup, it can."
-else
- val="$undef"
- echo "Nope, it can't."
-fi
-set d_strctcpy
-eval $setvar
-
-: 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
-
-: set if package uses struct tm
-w_s_tm=1
-
-: set if package uses struct timeval
-case "$d_select" in
-define) w_s_timevl=1 ;;
-esac
-
-: set if package uses localtime function
-w_localtim=1
-
-: see which of time.h, sys/time.h, and sys/select should be included.
-idefs=''
-cat <<'EOM'
-
-Testing to see which of <time.h>, <sys/time.h>, and <sys/select.h>
-should be included, because this application wants:
-
-EOM
-case "$w_s_itimer" in
-1)
- echo " struct itimerval"
- idefs="-DS_ITIMERVAL $idefs"
- ;;
-esac
-case "$w_s_timevl" in
-1)
- echo " struct timeval"
- idefs="-DS_TIMEVAL $idefs"
- ;;
-esac
-case "$w_s_tm" in
-1)
- echo " struct tm"
- idefs="-DS_TM $idefs"
- ;;
-esac
-case "$w_localtim" in
-1)
- echo " ctime(3) declarations"
- idefs="-DD_CTIME $idefs"
- ;;
-esac
-case "$idefs" in
-'')
- echo " (something I don't know about)"
- ;;
-esac
-echo " "
-echo "I'm now running the test program..."
-$cat >i_time.c <<'EOCP'
-#include <sys/types.h>
-#ifdef I_TIME
-#include <time.h>
-#endif
-#ifdef I_SYS_TIME
-#ifdef SYSTIMEKERNEL
-#define KERNEL
-#endif
-#include <sys/time.h>
-#endif
-#ifdef I_SYS_SELECT
-#include <sys/select.h>
-#endif
-main()
-{
- struct tm foo;
- struct tm *tmp;
-#ifdef S_TIMEVAL
- struct timeval bar;
-#endif
-#ifdef S_ITIMERVAL
- struct itimerval baz;
-#endif
-
- if (foo.tm_sec == foo.tm_sec)
- exit(0);
-#ifdef S_TIMEVAL
- if (bar.tv_sec == bar.tv_sec)
- exit(0);
-#endif
-#ifdef S_ITIMERVAL
- if (baz.it_interval == baz.it_interval)
- exit(0);
-#endif
-#ifdef S_TIMEVAL
- if (bar.tv_sec == bar.tv_sec)
- exit(0);
-#endif
-#ifdef D_CTIME
- /* this might not do anything for us... */
- tmp = localtime((time_t *)0);
-#endif
- exit(1);
-}
-EOCP
-flags=''
-for i_sys_select in '' '-DI_SYS_SELECT'; do
- for d_systimekernel in '' '-DSYSTIMEKERNEL'; do
- for i_time in '' '-DI_TIME'; do
- for i_systime in '-DI_SYS_TIME' ''; do
- case "$flags" in
- '') echo Trying $i_time $i_systime $d_systimekernel $i_sys_select
- if $cc $ccflags $idefs \
- $i_time $i_systime $d_systimekernel $i_sys_select \
- i_time.c -o i_time >/dev/null 2>&1 ; then
- set X $i_time $i_systime $d_systimekernel $i_sys_select
- shift
- flags="$*"
- echo Succeeded with $flags
- fi
- ;;
- esac
- done
- done
- done
-done
-case "$flags" in
-*SYSTIMEKERNEL*) val="$define";;
-*) val="$undef";;
-esac
-set d_systimekernel
-eval $setvar
-case "$flags" in
-*I_TIME*) val="$define";;
-*) val="$undef";;
-esac
-set i_time
-eval $setvar
-case "$flags" in
-*I_SYS_SELECT*) val="$define";;
-*) val="$undef";;
-esac
-set i_sys_select
-eval $setvar
-case "$flags" in
-*I_SYS_TIME*) val="$define";;
-*) val="$undef";;
-esac
-set i_sys_time
-eval $setvar
-case "$flags$i_sys_time$i_time" in
-undefundef) i_sys_time="$define"; i_time="$define";
- echo "ICK, NOTHING WORKED!!! You may have to diddle the includes.";;
-esac
-
-: see if telldir exists
-set telldir d_telldir
-eval $inlibc
-
-: see if signal is declared as pointer to function returning int or void
-echo " "
-$cppstdin $cppflags $cppminus < $usrinclude/signal.h >d_voidsig.txt
-if $contains 'int[^A-Za-z]*signal' d_voidsig.txt >/dev/null 2>&1 ; then
- echo "You have int (*signal())() instead of void."
- val="$undef"
-else
- echo "You have void (*signal())() instead of int."
- val="$define"
-fi
-set d_voidsig
-eval $setvar
-case $voidsig in
-define) d_tosignal=void;;
-*) d_tosignal=int;;
-esac
-
-: see if truncate exists
-set truncate d_truncate
-eval $inlibc
-
-: see if there is a vfork
-set vfork d_vfork
-eval $inlibc
-
-: check for volatile keyword
-echo " "
-echo 'Checking to see if your C compiler knows about "volatile"...'
-$cat >try.c <<'EOCP'
-main()
-{
- typedef unsigned short foo_t;
- char *volatile foo;
- volatile int bar;
- volatile foo_t blech;
- foo = foo;
-}
-EOCP
-if $cc -c $ccflags try.c >/dev/null 2>&1 ; then
- val="$define"
- echo "Yup, it does."
-else
- val="$undef"
- echo "Nope, it doesn't."
-fi
-set d_volatile
-eval $setvar
-$rm -f try.*
-
-: see if there is a wait4
-set wait4 d_wait4
-eval $inlibc
-
-: see if there is a waitpid
-set waitpid d_waitpid
-eval $inlibc
-
-: see what type gids are declared as in the kernel
-case "$gidtype" in
-'')
- if $contains 'gid_t;' $usrinclude/sys/types.h >/dev/null 2>&1 ; then
- dflt='gid_t';
- else
- set `grep '_rgid;' $usrinclude/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 " "
-rp="What type are groups ids returned by getgid(), etc.? [$dflt]"
-$echo $n "$rp $c"
-. myread
-gidtype="$ans"
-
-: see what type gids are returned by getgroups
-echo " "
-case "$groupstype" 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 'getgroups.*short' /usr/include/libc.h >/dev/null 2>&1; then
- dflt='short'
- elif $contains 'getgroups.*int' /usr/include/libc.h >/dev/null 2>&1; then
- dflt='int'
- elif $contains 'getgroups.*short' /usr/lib/lint/llib-lbsd >/dev/null 2>&1; then
- dflt='short'
- elif $contains 'getgroups.*int' /usr/lib/lint/llib-lbsd >/dev/null 2>&1; then
- dflt='int'
- elif $contains 'int.*gidset' /usr/man/man2/getgroups.2 >/dev/null 2>&1; then
- dflt='int'
- elif $contains 'gid_t;' $usrinclude/sys/types.h >/dev/null 2>&1 ; then
- dflt='gid_t'
- else
- set `grep 'groups\[NGROUPS\];' $usrinclude/sys/user.h 2>/dev/null` unsigned short
- case $1 in
- unsigned) dflt="$1 $2" ;;
- *) dflt="$1" ;;
- esac
- fi
- ;;
-*) dflt="$groupstype"
- ;;
-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
-groupstype="$ans"
-
-: check for length of integer
-echo " "
-case "$intsize" in
-'')
- echo "Checking to see how big your integers are..."
- $cat >intsize.c <<'EOCP'
-#include <stdio.h>
-main()
-{
- printf("%d\n", sizeof(int));
-}
-EOCP
- if $cc intsize.c -o intsize >/dev/null 2>&1 ; then
- dflt=`./intsize`
- 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"
-
-: 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 <<EOM
-
-The $package package has some auxiliary files that should be reside in a library
-that is accessible by everyone. Where should these "private" but accessible
-EOM
-$echo $n "files reside? (~name ok) [$dflt] $c"
-rp="Private files will reside where? [$dflt]"
-. myread
-privlib=`./filexp "$ans"`
-
-case "$installprivlib" in
-'')
- dflt=`echo $privlib | sed 's#^/afs/#/afs/.#'`
- test -d $dflt || dflt="$privlib"
- ;;
-*) dflt="$installprivlib"
- ;;
-esac
-$cat <<EOM
-
-On some systems (such as afs) you have to install the library files in a
-different directory to get them to go to the right place. Where should the
-EOM
-$echo $n "library files be installed? (~name ok) [$dflt] $c"
-rp="Install private files where? [$dflt]"
-. myread
-installprivlib=`./filexp "$ans"`
-
-: check for size of random number generator
-echo " "
-case "$randbits" in
-'')
- echo "Checking to see how many bits your rand function produces..."
- $cat >randbits.c <<'EOCP'
-#include <stdio.h>
-main()
-{
- register int i;
- register unsigned long tmp;
- register unsigned long max = 0L;
-
- for (i=1000; i; i--) {
- tmp = (unsigned long)rand();
- if (tmp > max) max = tmp;
- }
- for (i=0; max; i++)
- max /= 2;
- printf("%d\n",i);
-}
-EOCP
- if $cc randbits.c -o randbits >/dev/null 2>&1 ; then
- dflt=`./randbits`
- 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"
-
-: determine where publicly executable scripts go
-case "$scriptdir" in
-'')
- dflt="$bin"
- : guess some guesses
- test -d /usr/share/scripts && dflt=/usr/share/scripts
- test -d /usr/share/bin && dflt=/usr/share/bin
- ;;
-*) dflt="$scriptdir"
- ;;
-esac
-cont=true
-$cat <<EOM
-
-Some installations have a separate directory just for executable scripts so
-that they can mount it across multiple architectures but keep the scripts in
-one spot. You might, for example, have a subdirectory of /usr/share for this.
-Or you might just lump your scripts in with all your other executables.
-
-EOM
-while $test "$cont" ; do
- rp="Where will publicly executable scripts reside (~name ok)? [$dflt]"
- $echo $n "$rp $c"
- . myread
- scriptdir="$ans"
- scriptdir=`./filexp "$scriptdir"`
- if test -d $scriptdir; then
- cont=''
- else
- case "$fastread" in
- yes) dflt=y;;
- *) dflt=n;;
- esac
- rp="Directory $scriptdir doesn't exist. Use that name anyway? [$dflt]"
- $echo $n "$rp $c"
- . myread
- dflt=''
- case "$ans" in
- y*) cont='';;
- esac
- fi
-done
-
-case "$installscr" in
-'')
- dflt=`echo $scriptdir | sed 's#^/afs/#/afs/.#'`
- test -d $dflt || dflt="$scriptdir"
- ;;
-*) dflt="$scriptdir"
- ;;
-esac
-cont=true
-$cat <<EOM
-
-Some installations must install scripts in a different directory than where
-they will eventually reside. On most systems they're the same directory.
-EOM
-while $test "$cont" ; do
- rp="Where do you install publicly executable scripts (~name ok)? [$dflt]"
- $echo $n "$rp $c"
- . myread
- installscr="$ans"
- installscr=`./filexp "$installscr"`
- if test -d $installscr; then
- cont=''
- else
- case "$fastread" in
- yes) dflt=y;;
- *) dflt=n;;
- esac
- rp="Directory $installscr doesn't exist. Use that name anyway? [$dflt]"
- $echo $n "$rp $c"
- . myread
- dflt=''
- case "$ans" in
- y*) cont='';;
- esac
- fi
-done
-
-: generate list of signal names
-echo " "
-case "$sig_name" in
-'')
- echo "Generating a list of signal names..."
- set X `cat $usrinclude/signal.h $usrinclude/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 </tmp/foo$$`
- shift
- case $# in
- 0)set HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM
- ;;
- esac
- ;;
- esac
- sig_name="ZERO $*"
- ;;
-esac
-echo "Signals are: $sig_name"
-
-: see what type of char stdio uses.
-echo " "
-if $contains 'unsigned.*char.*\*.*_ptr.*;' $usrinclude/stdio.h >/dev/null 2>&1 ; then
- echo "Your stdio uses unsigned chars."
- stdchar="unsigned char"
-else
- echo "Your stdio uses signed chars."
- stdchar="char"
-fi
-
-: see what type uids are declared as in the kernel
-case "$uidtype" in
-'')
- if $contains 'uid_t;' $usrinclude/sys/types.h >/dev/null 2>&1 ; then
- dflt='uid_t';
- else
- set `grep '_ruid;' $usrinclude/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"
-
-: check for void type
-echo " "
-$cat <<EOM
-Checking to see how well your C compiler groks the void type...
-
- Support flag bits are:
- 1: basic void declarations.
- 2: arrays of pointers to functions returning void.
- 4: operations between pointers to and addresses of void functions.
-
-EOM
-case "$voidhave" in
-'')
- $cat >void.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 -c -DTRY=$voidwant void.c >void.out 2>&1 ; then
- voidhave=$voidwant
- echo "It appears to support void to the level $package wants ($voidwant)."
- if $contains warning void.out >/dev/null 2>&1; then
- echo "However, you might get some warnings that look like this:"
- $cat void.out
- fi
- else
- echo "Hmm, your compiler has some difficulty with void. Checking further..."
- if $cc -c -DTRY=1 void.c >/dev/null 2>&1 ; then
- echo "It supports 1..."
- if $cc -c -DTRY=3 void.c >/dev/null 2>&1 ; then
- voidhave=3
- echo "And it supports 2 but not 4."
- else
- echo "It doesn't support 2..."
- if $cc -c -DTRY=5 void.c >/dev/null 2>&1 ; then
- voidhave=5
- echo "But it supports 4."
- else
- voidhave=1
- echo "And it doesn't support 4."
- fi
- fi
- else
- echo "There is no support at all for void."
- voidhave=0
- fi
- fi
-esac
-dflt="$voidhave";
-rp="Your void support flags add up to what? [$dflt]"
-$echo $n "$rp $c"
-. myread
-voidhave="$ans"
-
-: preserve RCS keywords in files with variable substitution, grrr
-Log='$Log'
-Header='$Header'
-Id='$Id'
-Author='$Author'
-Date='$Date'
-Locker='$Locker'
-RCSfile='$RCSfile'
-Revision='$Revision'
-Source='$Source'
-State='$State'
-
-
-: determine compiler compiler
-case "$yacc" in
-'') if xenix; then
- dflt=yacc
- else
- dflt='yacc -Sm25000'
- fi
- ;;
-*) 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"
-
-: see if we can include fcntl.h
-echo " "
-if $h_fcntl; then
- val="$define"
- echo "We'll be including <fcntl.h>."
-else
- val="$undef"
- if $h_sys_file; then
- echo "We don't need to <fcntl.h> if we include <sys/file.h>."
- else
- echo "We won't be including <fcntl.h>."
- fi
-fi
-set i_fcntl
-eval $setvar
-
-: see if gdbm is available
-echo " "
-xxx=`./loc gdbm.h x $usrinclude /usr/local/include $inclwanted`
-if test -f $xxx; then
- val="$define"
- echo "gdbm.h found."
-else
- val="$undef"
- echo "gdbm.h NOT found."
-fi
-set i_gdbm
-eval $setvar
-
-: see if this is an grp system
-echo " "
-if $test -r $usrinclude/grp.h ; then
- val="$define"
- echo "grp.h found."
-else
- val="$undef"
- echo "No grp.h found."
-fi
-set i_grp
-eval $setvar
-
-: see if this is a netinet/in.h or sys/in.h system
-echo " "
-xxx=`./loc netinet/in.h x $usrinclude /usr/local/include $inclwanted`
-if test -f $xxx; then
- val="$define"
- val2="$undef"
- echo "netinet/in.h found."
-else
- val="$undef"
- echo "No netinet/in.h found, ..."
- xxx=`./loc sys/in.h x $usrinclude /usr/local/include $inclwanted`
- if test -f $xxx; then
- val2="$define"
- echo "but I found sys/in.h instead."
- else
- val2="$undef"
- echo "and I didn't find sys/in.h either."
- fi
-fi
-set i_niin
-eval $setvar
-val=$val2
-set i_sysin
-eval $setvar
-
-: Do we need to #include <sys/file.h> ?
-echo " "
-if $h_sys_file; then
- val="$define"
- echo "We'll be including <sys/file.h>."
-else
- val="$undef"
- echo "We won't be including <sys/file.h>."
-fi
-set i_sys_file
-eval $setvar
-
-: see if ioctl defs are in sgtty/termio or sys/ioctl
-echo " "
-if $test -r $usrinclude/sys/ioctl.h ; then
- val="$define"
- echo "sys/ioctl.h found."
-else
- val="$undef"
- echo "sys/ioctl.h NOT found, assuming ioctl args are defined in sgtty.h."
-fi
-set i_sysioctl
-eval $setvar
-
-: see if we should include utime.h
-echo " "
-if $test -r $usrinclude/utime.h ; then
- val="$define"
- echo "utime.h found."
-else
- val="$undef"
- echo "No utime.h found, but that's ok."
-fi
-set i_utime
-eval $setvar
-
-: see if this is a varargs system
-echo " "
-if $test -r $usrinclude/varargs.h ; then
- val="$define"
- echo "varargs.h found."
-else
- val="$undef"
- echo "No varargs.h found, but that's ok (I hope)."
-fi
-set i_varargs
-eval $setvar
-
-: see if this is a vfork system
-echo " "
-if $test -r $usrinclude/vfork.h ; then
- val="$define"
- echo "vfork.h found."
-else
- val="$undef"
- echo "No vfork.h found."
-fi
-set i_vfork
-eval $setvar
-
-: end of configuration questions
-echo " "
-echo "End of configuration questions."
-echo " "
-
-: create config.sh file
-echo " "
-if test -d ../UU; then
- cd ..
-fi
-echo "Creating config.sh..."
-test -f config.sh && cp config.sh UU/oldconfig.sh
-$spitshell <<EOT >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'
-bash='$bash'
-ksh='$ksh'
-lex='$lex'
-flex='$flex'
-bison='$bison'
-Log='$Log'
-Header='$Header'
-Id='$Id'
-lastuname='$lastuname'
-alignbytes='$alignbytes'
-bin='$bin'
-installbin='$installbin'
-byteorder='$byteorder'
-contains='$contains'
-cppstdin='$cppstdin'
-cppminus='$cppminus'
-d_bcmp='$d_bcmp'
-d_bcopy='$d_bcopy'
-d_safebcpy='$d_safebcpy'
-d_bzero='$d_bzero'
-d_castneg='$d_castneg'
-castflags='$castflags'
-d_charsprf='$d_charsprf'
-d_chsize='$d_chsize'
-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_flexfnam='$d_flexfnam'
-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_isascii='$d_isascii'
-d_killpg='$d_killpg'
-d_lstat='$d_lstat'
-d_memcmp='$d_memcmp'
-d_memcpy='$d_memcpy'
-d_safemcpy='$d_safemcpy'
-d_memmove='$d_memmove'
-d_memset='$d_memset'
-d_mkdir='$d_mkdir'
-d_msg='$d_msg'
-d_msgctl='$d_msgctl'
-d_msgget='$d_msgget'
-d_msgrcv='$d_msgrcv'
-d_msgsnd='$d_msgsnd'
-d_ndbm='$d_ndbm'
-d_odbm='$d_odbm'
-d_open3='$d_open3'
-d_readdir='$d_readdir'
-d_rename='$d_rename'
-d_rewindir='$d_rewindir'
-d_rmdir='$d_rmdir'
-d_seekdir='$d_seekdir'
-d_select='$d_select'
-d_sem='$d_sem'
-d_semctl='$d_semctl'
-d_semget='$d_semget'
-d_semop='$d_semop'
-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_shm='$d_shm'
-d_shmat='$d_shmat'
-d_voidshmat='$d_voidshmat'
-d_shmctl='$d_shmctl'
-d_shmdt='$d_shmdt'
-d_shmget='$d_shmget'
-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_telldir='$d_telldir'
-d_truncate='$d_truncate'
-d_vfork='$d_vfork'
-d_voidsig='$d_voidsig'
-d_tosignal='$d_tosignal'
-d_volatile='$d_volatile'
-d_vprintf='$d_vprintf'
-d_charvspr='$d_charvspr'
-d_wait4='$d_wait4'
-d_waitpid='$d_waitpid'
-gidtype='$gidtype'
-groupstype='$groupstype'
-i_fcntl='$i_fcntl'
-i_gdbm='$i_gdbm'
-i_grp='$i_grp'
-i_niin='$i_niin'
-i_sysin='$i_sysin'
-i_pwd='$i_pwd'
-d_pwquota='$d_pwquota'
-d_pwage='$d_pwage'
-d_pwchange='$d_pwchange'
-d_pwclass='$d_pwclass'
-d_pwexpire='$d_pwexpire'
-d_pwcomment='$d_pwcomment'
-i_sys_file='$i_sys_file'
-i_sysioctl='$i_sysioctl'
-i_time='$i_time'
-i_sys_time='$i_sys_time'
-i_sys_select='$i_sys_select'
-d_systimekernel='$d_systimekernel'
-i_utime='$i_utime'
-i_varargs='$i_varargs'
-i_vfork='$i_vfork'
-intsize='$intsize'
-libc='$libc'
-nm_opts='$nm_opts'
-libndir='$libndir'
-i_my_dir='$i_my_dir'
-i_ndir='$i_ndir'
-i_sys_ndir='$i_sys_ndir'
-i_dirent='$i_dirent'
-i_sys_dir='$i_sys_dir'
-d_dirnamlen='$d_dirnamlen'
-ndirc='$ndirc'
-ndiro='$ndiro'
-mallocsrc='$mallocsrc'
-mallocobj='$mallocobj'
-d_mymalloc='$d_mymalloc'
-mallocptrtype='$mallocptrtype'
-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'
-nativegcc='$nativegcc'
-libs='$libs'
-n='$n'
-c='$c'
-package='$package'
-randbits='$randbits'
-scriptdir='$scriptdir'
-installscr='$installscr'
-sig_name='$sig_name'
-spitshell='$spitshell'
-shsharp='$shsharp'
-sharpbang='$sharpbang'
-startsh='$startsh'
-stdchar='$stdchar'
-uidtype='$uidtype'
-usrinclude='$usrinclude'
-inclPath='$inclPath'
-void='$void'
-voidhave='$voidhave'
-voidwant='$voidwant'
-w_localtim='$w_localtim'
-w_s_timevl='$w_s_timevl'
-w_s_tm='$w_s_tm'
-yacc='$yacc'
-lib='$lib'
-privlib='$privlib'
-installprivlib='$installprivlib'
-EOT
-
-test -f patchlevel.h && awk '{printf "%s=%s\n",$2,$3}' patchlevel.h >>config.sh
-echo "CONFIG=true" >>config.sh
-
-if test -f UU/oldconfig.sh; then
- sed -n 's/^\([a-zA-Z_0-9]*\)=.*/\1/p' config.sh config.sh UU/oldconfig.sh |\
- sort | uniq -u >UU/oldsyms
- set X `cat UU/oldsyms`
- shift
- case $# in
- 0) ;;
- *) echo "Hmm...You had some extra variables I don't know about...I'll try to keep 'em..."
- for sym in `cat UU/oldsyms`; do
- echo " Propagating $hint variable "'$'"$sym..."
- eval 'tmp="$'"${sym}"'"'
- echo "$tmp" | \
- sed -e "s/'/'\"'\"'/g" -e "s/^/$sym='/" -e "s/$/'/" >>config.sh
- done
- ;;
- esac
-fi
-
-: Finish up
-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
-chmod +x doSH
-./doSH
-
-if $contains '^depend:' [Mm]akefile >/dev/null 2>&1; then
- dflt=n
- $cat <<EOM
-
-Now you need to generate make dependencies by running "make depend".
-You might prefer to run it in background: "make depend > 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 [Mm]akefile; then
- echo " "
- echo "Now you must run a make."
-else
- echo "Done."
-fi
-
-$rm -f kit*isdone
-$rm -rf UU
-: end of Configure
-/* $RCSfile: EXTERN.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:10:32 $
+/* $RCSfile: EXTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:03 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: EXTERN.h,v $
+ * Revision 4.1 92/08/07 17:18:03 lwall
+ * Stage 6 Snapshot
+ *
* Revision 4.0.1.1 91/06/07 10:10:32 lwall
* patch4: new copyright notice
*
-/* $RCSfile: INTERN.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:10:42 $
+/* $RCSfile: INTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:04 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: INTERN.h,v $
+ * Revision 4.1 92/08/07 17:18:04 lwall
+ * Stage 6 Snapshot
+ *
* Revision 4.0.1.1 91/06/07 10:10:42 lwall
* patch4: new copyright notice
*
--- /dev/null
+#ifdef I_PWD
+#include <pwd.h>
+#endif
+#ifdef I_GRP
+#include <grp.h>
+#endif
+#ifdef I_UTIME
+#include <utime.h>
+#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
cmd.h Public declarations for the above
config.H Sample config.h
config_h.SH Produces config.h
+config_c++.h TEMP FILE
cons.c Routines to construct cmd nodes of a parse tree
consarg.c Routines to construct arg nodes of a parse tree
doSH Script to run all the *.SH files
doarg.c Scalar expression evaluation
doio.c I/O operations
dolist.c Array expression evaluation
+dosish.h
dump.c Debugging output
eg/ADB An adb wrapper to put in your crash dir
eg/README Intro to example perl scripts
emacs/perldb.el Emacs debugging
emacs/perldb.pl Emacs debugging
emacs/tedstuff Some optional patches
+embed_h.SH
eval.c The expression evaluator
form.c Format processing
form.h Public declarations for the above
gettest A little script to test the get* routines
+global.var
h2ph.SH A thing to turn C .h file into perl .ph files
h2pl/README How to turn .ph files into .pl files
h2pl/cbreak.pl cbreak routines using .ph
hints/uts.sh
hints/vax.sh
installperl Perl script to do "make install" dirty work
+interp.var
ioctl.pl Sample ioctl.pl
+keywords.h
lib/abbrev.pl An abbreviation table builder
lib/assert.pl assertion and panic with stack trace
lib/bigfloat.pl An arbitrary precision floating point package
lib/termcap.pl Perl library supporting termcap usage
lib/timelocal.pl Perl library supporting inverse of localtime, gmtime
lib/validate.pl Perl library supporting wholesale file mode validation
+main.c
makedepend.SH Precursor to makedepend
makedir.SH Precursor to makedir
+makefile.lib make libperl.a
malloc.c A version of malloc you might not want
msdos/Changes.dds Expanation of MS-DOS patches by Diomidis Spinellis
msdos/Makefile MS-DOS makefile
perlsh A poor man's perl shell
perly.fixer A program to remove yacc stack limitations
perly.y Yacc grammar for perl
+pp.h Push/Pop code defs
+pp.c Push/Pop code
+proto.h
regcomp.c Regular expression compiler
regcomp.h Private declarations for above
regexec.c Regular expression evaluator
t/op/vec.t See if vectors work
t/op/write.t See if write works
toke.c The tokener
+unixish.h
usersub.c User supplied (possibly proprietary) subroutines
usub/Makefile Makefile for curseperl
usub/README Instructions for user supplied subroutines
-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 2>/dev/null
- . ./config.sh
- ;;
-esac
-case "$0" in
-*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
-esac
-
-case "$d_symlink" in
-*define*) sln='ln -s' ;;
-*) sln='ln';;
-esac
-
-case "$d_dosuid" in
-*define*) suidperl='suidperl' ;;
-*) suidperl='';;
-esac
-
-echo "Extracting Makefile (with variable substitutions)"
-rm -f Makefile
-cat >Makefile <<!GROK!THIS!
-# $RCSfile: Makefile.SH,v $$Revision: 4.0.1.4 $$Date: 92/06/08 11:40:43 $
+# : Makefile.SH,v 15738Revision: 4.1 15738Date: 92/08/07 17:18:08 $
#
# $Log: Makefile.SH,v $
+# Revision 4.1 92/08/07 17:18:08 lwall
+# Stage 6 Snapshot
+#
# Revision 4.0.1.4 92/06/08 11:40:43 lwall
# patch20: cray didn't give enough memory to /bin/sh
# patch20: various and sundry fixes
#
#
-CC = $cc
-YACC = $yacc
-bin = $installbin
-scriptdir = $scriptdir
-privlib = $installprivlib
-mansrc = $mansrc
-manext = $manext
-LDFLAGS = $ldflags
-CLDFLAGS = $ldflags
-SMALL = $small
-LARGE = $large $split
-mallocsrc = $mallocsrc
-mallocobj = $mallocobj
-SLN = $sln
+CC = cc
+YACC = /bin/yacc
+bin = /usr/local/bin
+scriptdir = /usr/local/bin
+privlib = /usr/local/lib/perl
+mansrc = /usr/man/manl
+manext = l
+LDFLAGS =
+CLDFLAGS =
+SMALL =
+LARGE =
+mallocsrc = malloc.c
+mallocobj = malloc.o
+SLN = ln -s
RMS = rm -f
-libs = $libs $cryptlib
-
-public = perl taintperl $suidperl
+libs = -ldbm -lm -lposix
-shellflags = $shellflags
+public = perl
-# To use an alternate make, set $altmake in config.sh.
-MAKE = ${altmake-make}
+shellflags =
-!GROK!THIS!
+# To use an alternate make, set in config.sh.
+MAKE = make
-cat >>Makefile <<'!NO!SUBS!'
CCCMD = `sh $(shellflags) cflags $@`
sh = Makefile.SH makedepend.SH h2ph.SH
-h1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h form.h handy.h
-h2 = hash.h perl.h regcomp.h regexp.h spat.h stab.h str.h util.h
+h1 = EXTERN.h INTERN.h av.h cop.h config.h embed.h form.h handy.h
+h2 = hv.h op.h opcode.h perl.h regcomp.h regexp.h gv.h sv.h util.h
h = $(h1) $(h2)
-c1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c
-c2 = eval.c form.c hash.c $(mallocsrc) perl.c regcomp.c regexec.c
-c3 = stab.c str.c toke.c util.c usersub.c
+c1 = av.c cop.c cons.c consop.c doop.c doio.c dolist.c
+c2 = eval.c hv.c main.c $(mallocsrc) perl.c pp.c regcomp.c regexec.c
+c3 = gv.c sv.c toke.c util.c usersub.c
c = $(c1) $(c2) $(c3)
-s1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c
-s2 = eval.c form.c hash.c perl.c regcomp.c regexec.c
-s3 = stab.c str.c toke.c util.c usersub.c perly.c
+s1 = av.c cop.c cons.c consop.c doop.c doio.c dolist.c
+s2 = eval.c hv.c main.c perl.c pp.c regcomp.c regexec.c
+s3 = gv.c sv.c toke.c util.c usersub.c perly.c
saber = $(s1) $(s2) $(s3)
-obj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o
-obj2 = eval.o form.o $(mallocobj) perl.o regcomp.o regexec.o
-obj3 = stab.o str.o toke.o util.o
+obj1 = av.o scope.o op.o doop.o doio.o dolist.o dump.o
+obj2 = $(mallocobj) mg.o pp.o regcomp.o regexec.o
+obj3 = gv.o sv.o toke.o util.o deb.o run.o
obj = $(obj1) $(obj2) $(obj3)
-tobj1 = tarray.o tcmd.o tcons.o tconsarg.o tdoarg.o tdoio.o tdolist.o tdump.o
-tobj2 = teval.o tform.o thash.o $(mallocobj) tregcomp.o tregexec.o
-tobj3 = tstab.o tstr.o ttoke.o tutil.o
+tobj1 = tav.o tcop.o tcons.o tconsop.o tdoop.o tdoio.o tdolist.o tdump.o
+tobj2 = teval.o thv.o $(mallocobj) tpp.o tregcomp.o tregexec.o
+tobj3 = tgv.o tsv.o ttoke.o tutil.o
tobj = $(tobj1) $(tobj2) $(tobj3)
.c.o:
$(CCCMD) $*.c
-all: $(public) $(private) $(util) uperl.o $(scripts)
- cd x2p; $(MAKE) all
- touch all
+
+all: perl
+
+#all: $(public) $(private) $(util) uperl.o $(scripts)
+# cd x2p; $(MAKE) all
+# touch all
# This is the standard version that contains no "taint" checks and is
# used for all scripts that aren't set-id or running under something set-id.
# The $& notation is tells Sequent machines that it can do a parallel make,
# and is harmless otherwise.
-perl: $& perly.o $(obj) hash.o usersub.o
- $(CC) $(LARGE) $(CLDFLAGS) $(obj) hash.o perly.o usersub.o $(libs) -o perl
-
-# This command assumes that /usr/include/dbz.h and /usr/lib/dbz.o exist.
-
-dbzperl: $& perly.o $(obj) zhash.o usersub.o
- $(CC) $(LARGE) $(CLDFLAGS) $(obj) zhash.o /usr/lib/dbz.o perly.o usersub.o $(libs) -o dbzperl
+perl: $& main.o perly.o perl.o $(obj) hv.o usersub.o
+ $(CC) -Bstatic $(LARGE) $(CLDFLAGS) main.o perly.o perl.o $(obj) hv.o usersub.o $(libs) -o perl
+ echo "\a"
-zhash.o: hash.c $(h)
- $(RMS) zhash.c
- $(SLN) hash.c zhash.c
- $(CCCMD) -DWANT_DBZ zhash.c
- $(RMS) zhash.c
+libperl.rlb: libperl.a
+ ranlib libperl.a
+ touch libperl.rlb
-uperl.o: $& perly.o $(obj) hash.o
- -ld $(LARGE) $(LDFLAGS) -r $(obj) hash.o perly.o -o uperl.o
-
-saber: $(saber)
- # load $(saber)
- # load /lib/libm.a
+libperl.a: $& perly.o perl.o $(obj) hv.o usersub.o
+ ar rcuv libperl.a $(obj) hv.o perly.o usersub.o
# This version, if specified in Configure, does ONLY those scripts which need
# set-id emulation. Suidperl must be setuid root. It contains the "taint"
# checks as well as the special code to validate that the script in question
# has been invoked correctly.
-suidperl: $& tperly.o sperl.o $(tobj) usersub.o
- $(CC) $(LARGE) $(CLDFLAGS) sperl.o $(tobj) tperly.o usersub.o $(libs) \
- -o suidperl
+suidperl: $& sperl.o tmain.o libtperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) sperl.o tmain.o libtperl.a $(libs) -o suidperl
# This version interprets scripts that are already set-id either via a wrapper
# or through the kernel allowing set-id scripts (bad idea). Taintperl must
# NOT be setuid to root or anything else. The only difference between it
# and normal perl is the presence of the "taint" checks.
-taintperl: $& tperly.o tperl.o $(tobj) usersub.o
- $(CC) $(LARGE) $(CLDFLAGS) tperl.o $(tobj) tperly.o usersub.o $(libs) \
- -o taintperl
+taintperl: $& tmain.o libtperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) tmain.o libtperl.a $(libs) -o taintperl
+
+libtperl.rlb: libtperl.a
+ ranlib libtperl.a
+ touch libtperl.rlb
+
+libtperl.a: $& tperly.o tperl.o $(tobj) thv.o usersub.o
+ ar rcuv libtperl.a $(tobj) thv.o tperly.o usersub.o tperl.o
+
+# This command assumes that /usr/include/dbz.h and /usr/lib/dbz.o exist.
+
+dbzperl: $& main.o zhv.o libperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) main.o zhv.o /usr/lib/dbz.o libperl.a $(libs) -o dbzperl
+
+zhv.o: hv.c $(h)
+ $(RMS) zhv.c
+ $(SLN) hv.c zhv.c
+ $(CCCMD) -DWANT_DBZ zhv.c
+ $(RMS) zhv.c
+
+uperl.o: $& $(obj) main.o hv.o perly.o
+ -ld $(LARGE) $(LDFLAGS) -r $(obj) main.o hv.o perly.o -o uperl.o
+
+saber: $(saber)
+ # load $(saber)
+ # load /lib/libm.a
# Replicating all this junk is yucky, but I don't see a portable way to fix it.
$(CCCMD) -DTAINT -DIAMSUID sperl.c
$(RMS) sperl.c
-tarray.o: array.c $(h)
- $(RMS) tarray.c
- $(SLN) array.c tarray.c
- $(CCCMD) -DTAINT tarray.c
- $(RMS) tarray.c
+tav.o: av.c $(h)
+ $(RMS) tav.c
+ $(SLN) av.c tav.c
+ $(CCCMD) -DTAINT tav.c
+ $(RMS) tav.c
-tcmd.o: cmd.c $(h)
- $(RMS) tcmd.c
- $(SLN) cmd.c tcmd.c
- $(CCCMD) -DTAINT tcmd.c
- $(RMS) tcmd.c
+tcop.o: cop.c $(h)
+ $(RMS) tcop.c
+ $(SLN) cop.c tcop.c
+ $(CCCMD) -DTAINT tcop.c
+ $(RMS) tcop.c
tcons.o: cons.c $(h) perly.h
$(RMS) tcons.c
$(CCCMD) -DTAINT tcons.c
$(RMS) tcons.c
-tconsarg.o: consarg.c $(h)
- $(RMS) tconsarg.c
- $(SLN) consarg.c tconsarg.c
- $(CCCMD) -DTAINT tconsarg.c
- $(RMS) tconsarg.c
+tconsop.o: consop.c $(h)
+ $(RMS) tconsop.c
+ $(SLN) consop.c tconsop.c
+ $(CCCMD) -DTAINT tconsop.c
+ $(RMS) tconsop.c
-tdoarg.o: doarg.c $(h)
- $(RMS) tdoarg.c
- $(SLN) doarg.c tdoarg.c
- $(CCCMD) -DTAINT tdoarg.c
- $(RMS) tdoarg.c
+tdoop.o: doop.c $(h)
+ $(RMS) tdoop.c
+ $(SLN) doop.c tdoop.c
+ $(CCCMD) -DTAINT tdoop.c
+ $(RMS) tdoop.c
tdoio.o: doio.c $(h)
$(RMS) tdoio.c
$(CCCMD) -DTAINT teval.c
$(RMS) teval.c
-tform.o: form.c $(h)
- $(RMS) tform.c
- $(SLN) form.c tform.c
- $(CCCMD) -DTAINT tform.c
- $(RMS) tform.c
+thv.o: hv.c $(h)
+ $(RMS) thv.c
+ $(SLN) hv.c thv.c
+ $(CCCMD) -DTAINT thv.c
+ $(RMS) thv.c
-thash.o: hash.c $(h)
- $(RMS) thash.c
- $(SLN) hash.c thash.c
- $(CCCMD) -DTAINT thash.c
- $(RMS) thash.c
+tmain.o: main.c $(h)
+ $(RMS) tmain.c
+ $(SLN) main.c tmain.c
+ $(CCCMD) -DTAINT tmain.c
+ $(RMS) tmain.c
+
+tpp.o: pp.c $(h)
+ $(RMS) tpp.c
+ $(SLN) pp.c tpp.c
+ $(CCCMD) -DTAINT tpp.c
+ $(RMS) tpp.c
tregcomp.o: regcomp.c $(h)
$(RMS) tregcomp.c
$(CCCMD) -DTAINT tregexec.c
$(RMS) tregexec.c
-tstab.o: stab.c $(h)
- $(RMS) tstab.c
- $(SLN) stab.c tstab.c
- $(CCCMD) -DTAINT tstab.c
- $(RMS) tstab.c
+tgv.o: gv.c $(h)
+ $(RMS) tgv.c
+ $(SLN) gv.c tgv.c
+ $(CCCMD) -DTAINT tgv.c
+ $(RMS) tgv.c
-tstr.o: str.c $(h) perly.h
- $(RMS) tstr.c
- $(SLN) str.c tstr.c
- $(CCCMD) -DTAINT tstr.c
- $(RMS) tstr.c
+tsv.o: sv.c $(h) perly.h
+ $(RMS) tsv.c
+ $(SLN) sv.c tsv.c
+ $(CCCMD) -DTAINT tsv.c
+ $(RMS) tsv.c
ttoke.o: toke.c $(h) perly.h
$(RMS) ttoke.c
@ echo Dummy dependency for dumb parallel make
touch perly.h
+embed.h: embed_h.SH global.var interp.var
+ sh embed_h.SH
+
perly.c: perly.y perly.fixer
@ \
case "$(YACC)" in \
- *bison*) echo 'Expect' 25 shift/reduce and 59 reduce/reduce conflicts;; \
- *) echo 'Expect' 27 shift/reduce and 57 reduce/reduce conflicts;; \
+ *bison*) echo 'Expect' 25 shift/reduce and 53 reduce/reduce conflicts;; \
+ *) echo 'Expect' 27 shift/reduce and 51 reduce/reduce conflicts;; \
esac
$(YACC) -d perly.y
sh $(shellflags) ./perly.fixer y.tab.c perly.c
echo $(sh) | tr ' ' '\012' >.shlist
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
-$(obj) hash.o:
+$(obj) hv.o:
@ echo "You haven't done a "'"make depend" yet!'; exit 1
makedepend: makedepend.SH
/bin/sh $(shellflags) makedepend.SH
-!NO!SUBS!
-$eunicefix Makefile
-case `pwd` in
-*SH)
- $rm -f ../Makefile
- ln Makefile ../Makefile
- ;;
-esac
-rm -f makefile
+
+++ /dev/null
-After all the perl kits are run you should have the following files:
-
-Filename Kit Description
--------- --- -----------
-Configure:AA 3 Run this first
-Configure:AB 20
-Copying 26 The GNU General Public License
-EXTERN.h 36 Included before foreign .h files
-INTERN.h 36 Included before domestic .h files
-MANIFEST 13 This list of files
-Makefile.SH 28 Precursor to Makefile
-PACKINGLIST 16 Which files came from which kits
-README 1 The Instructions
-README.uport 1 Special instructions for Microports
-README.xenix 1 Special instructions for Xenix
-Wishlist 36 Some things that may or may not happen
-arg.h 19 Public declarations for the above
-array.c 30 Numerically subscripted arrays
-array.h 35 Public declarations for the above
-client 35 A client to test sockets
-cmd.c 18 Command interpreter
-cmd.h 30 Public declarations for the above
-config.H 25 Sample config.h
-config_h.SH 24 Produces config.h
-cons.c 13 Routines to construct cmd nodes of a parse tree
-consarg.c 19 Routines to construct arg nodes of a parse tree
-doarg.c 12 Scalar expression evaluation
-doio.c:AA 5 I/O operations
-doio.c:AB 28
-dolist.c 11 Array expression evaluation
-dump.c 25 Debugging output
-eg/ADB 36 An adb wrapper to put in your crash dir
-eg/README 1 Intro to example perl scripts
-eg/changes 35 A program to list recently changed files
-eg/down 36 A program to do things to subdirectories
-eg/dus 35 A program to do du -s on non-mounted dirs
-eg/findcp 34 A find wrapper that implements a -cp switch
-eg/findtar 22 A find wrapper that pumps out a tar file
-eg/g/gcp 33 A program to do a global rcp
-eg/g/gcp.man 34 Manual page for gcp
-eg/g/ged 15 A program to do a global edit
-eg/g/ghosts 35 A sample /etc/ghosts file
-eg/g/gsh 32 A program to do a global rsh
-eg/g/gsh.man 33 Manual page for gsh
-eg/muck 33 A program to find missing make dependencies
-eg/muck.man 35 Manual page for muck
-eg/myrup 35 A program to find lightly loaded machines
-eg/nih 36 Script to insert #! workaround
-eg/relink 33 A program to change symbolic links
-eg/rename 34 A program to rename files
-eg/rmfrom 20 A program to feed doomed filenames to
-eg/scan/scan_df 34 Scan for filesystem anomalies
-eg/scan/scan_last 34 Scan for login anomalies
-eg/scan/scan_messages 30 Scan for console message anomalies
-eg/scan/scan_passwd 35 Scan for passwd file anomalies
-eg/scan/scan_ps 10 Scan for process anomalies
-eg/scan/scan_sudo 33 Scan for sudo anomalies
-eg/scan/scan_suid 33 Scan for setuid anomalies
-eg/scan/scanner 33 An anomaly reporter
-eg/shmkill 35 A program to remove unused shared memory
-eg/sysvipc/README 1 Intro to Sys V IPC examples
-eg/sysvipc/ipcmsg 35 Example of SYS V IPC message queues
-eg/sysvipc/ipcsem 35 Example of Sys V IPC semaphores
-eg/sysvipc/ipcshm 35 Example of Sys V IPC shared memory
-eg/travesty 35 A program to print travesties of its input text
-eg/van/empty 35 A program to empty the trashcan
-eg/van/unvanish 34 A program to undo what vanish does
-eg/van/vanexp 36 A program to expire vanished files
-eg/van/vanish 34 A program to put files in a trashcan
-eg/who 36 A sample who program
-emacs/perl-mode.el 21 Emacs major mode for perl
-emacs/perldb.el 17 Emacs debugging
-emacs/perldb.pl 15 Emacs debugging
-emacs/tedstuff 27 Some optional patches
-eval.c:AA 2 The expression evaluator
-eval.c:AB 20
-form.c 28 Format processing
-form.h 35 Public declarations for the above
-gettest 35 A little script to test the get* routines
-h2ph.SH 11 A thing to turn C .h file into perl .ph files
-h2pl/README 1 How to turn .ph files into .pl files
-h2pl/cbreak.pl 35 cbreak routines using .ph
-h2pl/cbreak2.pl 35 cbreak routines using .pl
-h2pl/eg/sizeof.ph 36 Sample sizeof array initialization
-h2pl/eg/sys/errno.pl 31 Sample translated errno.pl
-h2pl/eg/sys/ioctl.pl 31 Sample translated ioctl.pl
-h2pl/eg/sysexits.pl 36 Sample translated sysexits.pl
-h2pl/getioctlsizes 36 Program to extract types from ioctl.h
-h2pl/mksizes 35 Program to make %sizeof array.
-h2pl/mkvars 35 Program to make .pl from .ph files
-h2pl/tcbreak 36 cbreak test routine using .ph
-h2pl/tcbreak2 14 cbreak test routine using .pl
-handy.h 32 Handy definitions
-hash.c 26 Associative arrays
-hash.h 34 Public declarations for the above
-installperl 31 Perl script to do "make install" dirty work
-ioctl.pl 31 Sample ioctl.pl
-lib/abbrev.pl 35 An abbreviation table builder
-lib/bigfloat.pl 26 An arbitrary precision floating point package
-lib/bigint.pl 29 An arbitrary precision integer arithmetic package
-lib/bigrat.pl 31 An arbitrary precision rational arithmetic package
-lib/cacheout.pl 35 Manages output filehandles when you need too many
-lib/complete.pl 33 A command completion subroutine
-lib/ctime.pl 29 A ctime workalike
-lib/dumpvar.pl 35 A variable dumper
-lib/flush.pl 36 Routines to do single flush
-lib/getopt.pl 34 Perl library supporting option parsing
-lib/getopts.pl 35 Perl library supporting option parsing
-lib/importenv.pl 36 Perl routine to get environment into variables
-lib/look.pl 34 A "look" equivalent
-lib/perldb.pl 25 Perl debugging routines
-lib/pwd.pl 34 Routines to keep track of PWD environment variable
-lib/stat.pl 35 Perl library supporting stat function
-lib/syslog.pl 29 Perl library supporting syslogging
-lib/termcap.pl 32 Perl library supporting termcap usage
-lib/timelocal.pl 33 Perl library supporting inverse of localtime, gmtime
-lib/validate.pl 32 Perl library supporting wholesale file mode validation
-makedepend.SH 31 Precursor to makedepend
-makedir.SH 34 Precursor to makedir
-malloc.c 12 A version of malloc you might not want
-msdos/Changes.dds 33 Expanation of MS-DOS patches by Diomidis Spinellis
-msdos/Makefile 33 MS-DOS makefile
-msdos/README.msdos 1 Compiling and usage information
-msdos/Wishlist.dds 18 My wishlist
-msdos/chdir.c 33 A chdir that can change drives
-msdos/config.h 22 Definitions for msdos
-msdos/dir.h 34 MS-DOS header for directory access functions
-msdos/directory.c 31 MS-DOS directory access functions.
-msdos/eg/crlf.bat 35 Convert files from unix to MS-DOS line termination
-msdos/eg/drives.bat 34 List the system drives and their characteristics
-msdos/eg/lf.bat 35 Convert files from MS-DOS to Unix line termination
-msdos/glob.c 36 A command equivalent to csh glob
-msdos/msdos.c 30 MS-DOS ioctl, sleep, gete?[gu]if, spawn, aspawn
-msdos/popen.c 32 My_popen and my_pclose for MS-DOS
-msdos/usage.c 34 How to invoke perl under MS-DOS
-os2/Makefile 32 Makefile for OS/2
-os2/README.OS2 1 Notes for OS/2
-os2/a2p.cs 13 Compiler script for a2p
-os2/a2p.def 36 Linker defs for a2p
-os2/alarm.c 31 An implementation of alarm()
-os2/alarm.h 36 Header file for same
-os2/config.h 18 Configuration file for OS/2
-os2/dir.h 33 Directory header
-os2/director.c 30 Directory routines
-os2/eg/alarm.pl 36 Example of alarm code
-os2/eg/os2.pl 33 Sample script for OS/2
-os2/eg/syscalls.pl 36 Example of syscall on OS/2
-os2/glob.c 36 Globbing routines
-os2/makefile 32 Make file
-os2/mktemp.c 36 Mktemp() using TMP
-os2/os2.c 29 Unix compatibility functions
-os2/perl.bad 36 names of protect-only API calls for BIND
-os2/perl.cs 35 Compiler script for perl
-os2/perl.def 19 Linker defs for perl
-os2/perldb.dif 34 Changes to make the debugger work
-os2/perlglob.bad 36 names of protect-only API calls for BIND
-os2/perlglob.cs 36 Compiler script for perlglob
-os2/perlglob.def 36 Linker defs for perlglob
-os2/perlsh.cmd 36 Poor man's shell for os2
-os2/popen.c 29 Code for opening pipes
-os2/s2p.cmd 27 s2p as command file
-os2/selfrun.bat 36 A self running perl script for DOS
-os2/selfrun.cmd 26 Example of extproc feature
-os2/suffix.c 31 Code for creating backup filenames
-patchlevel.h 36 The current patch level of perl
-perl.c 15 main()
-perl.h 24 Global declarations
-perl.man:AA 6 The manual page(s)
-perl.man:AB 7
-perl.man:AC 8
-perl.man:AD 10
-perlsh 36 A poor man's perl shell
-perly.fixer 34 A program to remove yacc stack limitations
-perly.y 22 Yacc grammar for perl
-regcomp.c 17 Regular expression compiler
-regcomp.h 29 Private declarations for above
-regexec.c 21 Regular expression evaluator
-regexp.h 35 Public declarations for the above
-server 35 A server to test sockets
-spat.h 34 Search pattern declarations
-stab.c 23 Symbol table stuff
-stab.h 31 Public declarations for the above
-str.c 14 String handling package
-str.h 30 Public declarations for the above
-t/README 1 Instructions for regression tests
-t/TEST 34 The regression tester
-t/base/cond.t 36 See if conditionals work
-t/base/if.t 36 See if if works
-t/base/lex.t 34 See if lexical items work
-t/base/pat.t 36 See if pattern matching works
-t/base/term.t 17 See if various terms work
-t/cmd/elsif.t 35 See if else-if works
-t/cmd/for.t 35 See if for loops work
-t/cmd/mod.t 35 See if statement modifiers work
-t/cmd/subval.t 32 See if subroutine values work
-t/cmd/switch.t 34 See if switch optimizations work
-t/cmd/while.t 1 See if while loops work
-t/comp/cmdopt.t 33 See if command optimization works
-t/comp/cpp.t 35 See if C preprocessor works
-t/comp/decl.t 36 See if declarations work
-t/comp/multiline.t 35 See if multiline strings work
-t/comp/package.t 35 See if packages work
-t/comp/script.t 35 See if script invokation works
-t/comp/term.t 34 See if more terms work
-t/io/argv.t 35 See if ARGV stuff works
-t/io/dup.t 35 See if >& works right
-t/io/fs.t 32 See if directory manipulations work
-t/io/inplace.t 12 See if inplace editing works
-t/io/pipe.t 35 See if secure pipes work
-t/io/print.t 36 See if print commands work
-t/io/tell.t 34 See if file seeking works
-t/lib/big.t 31 See if lib/bigint.pl works
-t/op/append.t 36 See if . works
-t/op/array.t 31 See if array operations work
-t/op/auto.t 23 See if autoincrement et all work
-t/op/chop.t 35 See if chop works
-t/op/cond.t 36 See if conditional expressions work
-t/op/dbm.t 33 See if dbm binding works
-t/op/delete.t 16 See if delete works
-t/op/do.t 27 See if subroutines work
-t/op/each.t 34 See if associative iterators work
-t/op/eval.t 21 See if eval operator works
-t/op/exec.t 35 See if exec and system work
-t/op/exp.t 35 See if math functions work
-t/op/flip.t 35 See if range operator works
-t/op/fork.t 36 See if fork works
-t/op/glob.t 36 See if <*> works
-t/op/goto.t 35 See if goto works
-t/op/groups.t 35 See if $( works
-t/op/index.t 34 See if index works
-t/op/int.t 36 See if int works
-t/op/join.t 36 See if join works
-t/op/list.t 33 See if array lists work
-t/op/local.t 35 See if local works
-t/op/magic.t 35 See if magic variables work
-t/op/mkdir.t 36 See if mkdir works
-t/op/oct.t 36 See if oct and hex work
-t/op/ord.t 36 See if ord works
-t/op/pack.t 35 See if pack and unpack work
-t/op/pat.t 28 See if esoteric patterns work
-t/op/push.t 34 See if push and pop work
-t/op/range.t 35 See if .. works
-t/op/re_tests 32 Input file for op.regexp
-t/op/read.t 36 See if read() works
-t/op/regexp.t 35 See if regular expressions work
-t/op/repeat.t 34 See if x operator works
-t/op/s.t 30 See if substitutions work
-t/op/sleep.t 36 See if sleep works
-t/op/sort.t 35 See if sort works
-t/op/split.t 34 See if split works
-t/op/sprintf.t 34 See if sprintf works
-t/op/stat.t 30 See if stat works
-t/op/study.t 30 See if study works
-t/op/substr.t 32 See if substr works
-t/op/time.t 35 See if time functions work
-t/op/undef.t 34 See if undef works
-t/op/unshift.t 36 See if unshift works
-t/op/vec.t 35 See if vectors work
-t/op/write.t 33 See if write works
-toke.c:AA 4 The tokener
-toke.c:AB 28
-usersub.c 32 User supplied (possibly proprietary) subroutines
-usub/Makefile 36 Makefile for curseperl
-usub/README 1 Instructions for user supplied subroutines
-usub/curses.mus 26 Glue routines for BSD curses
-usub/man2mus 34 A manual page to .mus translator
-usub/mus 33 A .mus to .c translator
-usub/pager 32 A sample pager in curseperl
-usub/usersub.c 36 An initialization file to call curses glue routines
-util.c 16 Utility routines
-util.h 35 Public declarations for the above
-x2p/EXTERN.h 36 Same as above
-x2p/INTERN.h 36 Same as above
-x2p/Makefile.SH 32 Precursor to Makefile
-x2p/a2p.h 29 Global declarations
-x2p/a2p.man 29 Manual page for awk to perl translator
-x2p/a2p.y 28 A yacc grammer for awk
-x2p/a2py.c 23 Awk compiler, sort of
-x2p/find2perl.SH 14 A find to perl translator
-x2p/handy.h 35 Handy definitions
-x2p/hash.c 30 Associative arrays again
-x2p/hash.h 34 Public declarations for the above
-x2p/s2p.SH 27 Sed to perl translator
-x2p/s2p.man 33 Manual page for sed to perl translator
-x2p/str.c 27 String handling package
-x2p/str.h 34 Public declarations for the above
-x2p/util.c 24 Utility routines
-x2p/util.h 35 Public declarations for the above
-x2p/walk.c 9 Parse tree walker
--- /dev/null
+After all the perl kits are run you should have the following files:
+
+Filename Kit Description
+-------- --- -----------
+Artistic 37 The "Artistic License"
+Configure:AA 8 Run this first
+Configure:AB 14
+Copying 33 The GNU General Public License
+EXTERN.h 44 Included before foreign .h files
+INTERN.h 44 Included before domestic .h files
+MANIFEST 31 This list of files
+Makefile.SH 15 Precursor to Makefile
+PACKINGLIST 19 Which files came from which kits
+README 1 The Instructions
+README.ncr 2 Special instructions for NCR
+README.uport 2 Special instructions for Microports
+README.xenix 2 Special instructions for Xenix
+Wishlist 44 Some things that may or may not happen
+arg.h 22 Public declarations for the above
+array.c 27 Numerically subscripted arrays
+array.h 43 Public declarations for the above
+atarist/FILES 42
+atarist/README.ST 1
+atarist/RESULTS 40
+atarist/atarist.c 36
+atarist/config.h 23
+atarist/echo.c 41
+atarist/explain 40
+atarist/makefile.sm 34
+atarist/makefile.st 34
+atarist/osbind.pl 36
+atarist/perldb.diff 37
+atarist/perlglob.c 43
+atarist/test/binhandl 44
+atarist/test/ccon 44
+atarist/test/dbm 40
+atarist/test/err 44
+atarist/test/gdbm 44
+atarist/test/gdbm.t 40
+atarist/test/glob 44
+atarist/test/osexample.pl44
+atarist/test/pi.pl 39
+atarist/test/printenv 20
+atarist/test/readme 35
+atarist/test/sig 44
+atarist/test/tbinmode 44
+atarist/usersub.c 44
+atarist/usub/README.ATARI 2
+atarist/usub/acurses.mus32
+atarist/usub/makefile.st43
+atarist/usub/usersub.c 43
+atarist/wildmat.c 34
+c2ph.SH 25 program to translate dbx stabs to perl
+c2ph.doc 33 documentation for c2ph
+cflags.SH 40 A script that emits C compilation flags per file
+client 43 A client to test sockets
+cmd.c 19 Command interpreter
+cmd.h 37 Public declarations for the above
+config.H 26 Sample config.h
+config_h.SH 22 Produces config.h
+cons.c 17 Routines to construct cmd nodes of a parse tree
+consarg.c 20 Routines to construct arg nodes of a parse tree
+doSH 43 Script to run all the *.SH files
+doarg.c 13 Scalar expression evaluation
+doio.c:AA 4 I/O operations
+doio.c:AB 25
+dolist.c 12 Array expression evaluation
+dump.c 35 Debugging output
+eg/ADB 27 An adb wrapper to put in your crash dir
+eg/README 1 Intro to example perl scripts
+eg/changes 43 A program to list recently changed files
+eg/down 44 A program to do things to subdirectories
+eg/dus 43 A program to do du -s on non-mounted dirs
+eg/findcp 42 A find wrapper that implements a -cp switch
+eg/findtar 44 A find wrapper that pumps out a tar file
+eg/g/gcp 40 A program to do a global rcp
+eg/g/gcp.man 41 Manual page for gcp
+eg/g/ged 28 A program to do a global edit
+eg/g/ghosts 43 A sample /etc/ghosts file
+eg/g/gsh 39 A program to do a global rsh
+eg/g/gsh.man 41 Manual page for gsh
+eg/muck 39 A program to find missing make dependencies
+eg/muck.man 43 Manual page for muck
+eg/myrup 43 A program to find lightly loaded machines
+eg/nih 44 Script to insert #! workaround
+eg/relink 40 A program to change symbolic links
+eg/rename 41 A program to rename files
+eg/rmfrom 44 A program to feed doomed filenames to
+eg/scan/scan_df 42 Scan for filesystem anomalies
+eg/scan/scan_last 42 Scan for login anomalies
+eg/scan/scan_messages 37 Scan for console message anomalies
+eg/scan/scan_passwd 43 Scan for passwd file anomalies
+eg/scan/scan_ps 43 Scan for process anomalies
+eg/scan/scan_sudo 42 Scan for sudo anomalies
+eg/scan/scan_suid 40 Scan for setuid anomalies
+eg/scan/scanner 41 An anomaly reporter
+eg/shmkill 43 A program to remove unused shared memory
+eg/sysvipc/README 2 Intro to Sys V IPC examples
+eg/sysvipc/ipcmsg 17 Example of SYS V IPC message queues
+eg/sysvipc/ipcsem 43 Example of Sys V IPC semaphores
+eg/sysvipc/ipcshm 42 Example of Sys V IPC shared memory
+eg/travesty 43 A program to print travesties of its input text
+eg/van/empty 43 A program to empty the trashcan
+eg/van/unvanish 42 A program to undo what vanish does
+eg/van/vanexp 44 A program to expire vanished files
+eg/van/vanish 41 A program to put files in a trashcan
+eg/who 44 A sample who program
+emacs/perl-mode.el 27 Emacs major mode for perl
+emacs/perldb.el 24 Emacs debugging
+emacs/perldb.pl 27 Emacs debugging
+emacs/tedstuff 33 Some optional patches
+eval.c:AA 7 The expression evaluator
+eval.c:AB 30
+form.c 34 Format processing
+form.h 43 Public declarations for the above
+gettest 43 A little script to test the get* routines
+h2ph.SH 36 A thing to turn C .h file into perl .ph files
+h2pl/README 2 How to turn .ph files into .pl files
+h2pl/cbreak.pl 43 cbreak routines using .ph
+h2pl/cbreak2.pl 43 cbreak routines using .pl
+h2pl/eg/sizeof.ph 44 Sample sizeof array initialization
+h2pl/eg/sys/errno.pl 41 Sample translated errno.pl
+h2pl/eg/sys/ioctl.pl 38 Sample translated ioctl.pl
+h2pl/eg/sysexits.pl 44 Sample translated sysexits.pl
+h2pl/getioctlsizes 44 Program to extract types from ioctl.h
+h2pl/mksizes 43 Program to make %sizeof array.
+h2pl/mkvars 43 Program to make .pl from .ph files
+h2pl/tcbreak 29 cbreak test routine using .ph
+h2pl/tcbreak2 22 cbreak test routine using .pl
+handy.h 38 Handy definitions
+hash.c 26 Associative arrays
+hash.h 41 Public declarations for the above
+hints/3b1.sh 44
+hints/3b1cc 41
+hints/3b2.sh 44
+hints/aix_rs.sh 44
+hints/aix_rt.sh 44
+hints/altos486.sh 44
+hints/apollo_C6_7.sh 32
+hints/apollo_C6_8.sh 43
+hints/aux.sh 44
+hints/cray.sh 44
+hints/dgux.sh 44
+hints/dnix.sh 44
+hints/dynix.sh 44
+hints/fps.sh 24
+hints/genix.sh 44
+hints/greenhills.sh 44
+hints/hp9000_300.sh 44
+hints/hp9000_400.sh 44
+hints/hp9000_700.sh 44
+hints/hp9000_800.sh 44
+hints/hpux.sh 44
+hints/i386.sh 44
+hints/isc_3_2_2.sh 44
+hints/isc_3_2_3.sh 44
+hints/mc6000.sh 44
+hints/mips.sh 44
+hints/mpc.sh 44
+hints/ncr_tower.sh 44
+hints/next.sh 44
+hints/opus.sh 44
+hints/osf1.sh 44
+hints/sco_2_3_0.sh 44
+hints/sco_2_3_1.sh 1
+hints/sco_2_3_2.sh 44
+hints/sco_2_3_3.sh 44
+hints/sco_2_3_4.sh 44
+hints/sco_3.sh 44
+hints/sgi.sh 44
+hints/solaris_2_0.sh 44
+hints/stellar.sh 44
+hints/sunos_3_4.sh 44
+hints/sunos_3_5.sh 44
+hints/sunos_4_0_1.sh 44
+hints/sunos_4_0_2.sh 44
+hints/svr4.sh 15
+hints/ti1500.sh 44
+hints/titan.sh 42
+hints/ultrix_1.sh 44
+hints/ultrix_3.sh 44
+hints/ultrix_4.sh 16
+hints/unisysdynix.sh 44
+hints/utekv.sh 43
+hints/uts.sh 44
+hints/vax.sh 33
+installperl 37 Perl script to do "make install" dirty work
+ioctl.pl 39 Sample ioctl.pl
+lib/abbrev.pl 43 An abbreviation table builder
+lib/assert.pl 42 assertion and panic with stack trace
+lib/bigfloat.pl 36 An arbitrary precision floating point package
+lib/bigint.pl 34 An arbitrary precision integer arithmetic package
+lib/bigrat.pl 31 An arbitrary precision rational arithmetic package
+lib/cacheout.pl 43 Manages output filehandles when you need too many
+lib/chat2.pl 35 Randal's famous expect-ish routines
+lib/complete.pl 40 A command completion subroutine
+lib/ctime.pl 41 A ctime workalike
+lib/dumpvar.pl 43 A variable dumper
+lib/exceptions.pl 36 catch and throw routines
+lib/fastcwd.pl 43 a faster but more dangerous getcwd
+lib/find.pl 40 A find emulator--used by find2perl
+lib/finddepth.pl 40 A depth-first find emulator--used by find2perl
+lib/flush.pl 44 Routines to do single flush
+lib/getcwd.pl 42 a getcwd() emulator
+lib/getopt.pl 42 Perl library supporting option parsing
+lib/getopts.pl 42 Perl library supporting option parsing
+lib/importenv.pl 44 Perl routine to get environment into variables
+lib/look.pl 42 A "look" equivalent
+lib/newgetopt.pl 35 A perl library supporting long option parsing
+lib/open2.pl 41
+lib/perldb.pl 23 Perl debugging routines
+lib/pwd.pl 42 Routines to keep track of PWD environment variable
+lib/shellwords.pl 43 Perl library to split into words with shell quoting
+lib/stat.pl 43 Perl library supporting stat function
+lib/syslog.pl 35 Perl library supporting syslogging
+lib/termcap.pl 39 Perl library supporting termcap usage
+lib/timelocal.pl 40 Perl library supporting inverse of localtime, gmtime
+lib/validate.pl 39 Perl library supporting wholesale file mode validation
+makedepend.SH 37 Precursor to makedepend
+makedir.SH 42 Precursor to makedir
+malloc.c 32 A version of malloc you might not want
+msdos/Changes.dds 41 Expanation of MS-DOS patches by Diomidis Spinellis
+msdos/Makefile 40 MS-DOS makefile
+msdos/README.msdos 1 Compiling and usage information
+msdos/Wishlist.dds 43 My wishlist
+msdos/chdir.c 41 A chdir that can change drives
+msdos/config.h 21 Definitions for msdos
+msdos/dir.h 42 MS-DOS header for directory access functions
+msdos/directory.c 38 MS-DOS directory access functions.
+msdos/eg/crlf.bat 43 Convert files from unix to MS-DOS line termination
+msdos/eg/drives.bat 42 List the system drives and their characteristics
+msdos/eg/lf.bat 43 Convert files from MS-DOS to Unix line termination
+msdos/glob.c 44 A command equivalent to csh glob
+msdos/msdos.c 37 MS-DOS ioctl, sleep, gete?[gu]if, spawn, aspawn
+msdos/popen.c 39 My_popen and my_pclose for MS-DOS
+msdos/usage.c 41 How to invoke perl under MS-DOS
+os2/Makefile 42 Makefile for OS/2
+os2/README.OS2 1 Notes for OS/2
+os2/a2p.cs 42 Compiler script for a2p
+os2/a2p.def 44 Linker defs for a2p
+os2/alarm.c 38 An implementation of alarm()
+os2/alarm.h 44 Header file for same
+os2/config.h 24 Configuration file for OS/2
+os2/crypt.c 35
+os2/dir.h 41 Directory header
+os2/director.c 38 Directory routines
+os2/eg/alarm.pl 44 Example of alarm code
+os2/eg/os2.pl 41 Sample script for OS/2
+os2/eg/syscalls.pl 19 Example of syscall on OS/2
+os2/glob.c 44 Globbing routines
+os2/makefile 39 Make file
+os2/mktemp.c 44 Mktemp() using TMP
+os2/os2.c 36 Unix compatibility functions
+os2/perl.bad 44 names of protect-only API calls for BIND
+os2/perl.cs 43 Compiler script for perl
+os2/perl.def 23 Linker defs for perl
+os2/perldb.dif 30 Changes to make the debugger work
+os2/perlglob.bad 44 names of protect-only API calls for BIND
+os2/perlglob.cs 44 Compiler script for perlglob
+os2/perlglob.def 44 Linker defs for perlglob
+os2/perlsh.cmd 44 Poor man's shell for os2
+os2/popen.c 26 Code for opening pipes
+os2/s2p.cmd 18 s2p as command file
+os2/selfrun.bat 44 A self running perl script for DOS
+os2/selfrun.cmd 44 Example of extproc feature
+os2/suffix.c 38 Code for creating backup filenames
+os2/tests.dif 20
+patchlevel.h 44 The current patch level of perl
+perl.c 15 main()
+perl.h 29 Global declarations
+perl.man:AA 9 The manual page(s)
+perl.man:AB 10
+perl.man:AC 6
+perl.man:AD 11
+perl.man:AE 41
+perlsh 44 A poor man's perl shell
+perly.fixer 24 A program to remove yacc stack limitations
+perly.y 30 Yacc grammar for perl
+regcomp.c 2 Regular expression compiler
+regcomp.h 35 Private declarations for above
+regexec.c 28 Regular expression evaluator
+regexp.h 39 Public declarations for the above
+server 43 A server to test sockets
+spat.h 38 Search pattern declarations
+stab.c 29 Symbol table stuff
+stab.h 25 Public declarations for the above
+str.c 18 String handling package
+str.h 36 Public declarations for the above
+t/README 1 Instructions for regression tests
+t/TEST 41 The regression tester
+t/base/cond.t 44 See if conditionals work
+t/base/if.t 44 See if if works
+t/base/lex.t 40 See if lexical items work
+t/base/pat.t 44 See if pattern matching works
+t/base/term.t 43 See if various terms work
+t/cmd/elsif.t 43 See if else-if works
+t/cmd/for.t 43 See if for loops work
+t/cmd/mod.t 43 See if statement modifiers work
+t/cmd/subval.t 13 See if subroutine values work
+t/cmd/switch.t 41 See if switch optimizations work
+t/cmd/while.t 40 See if while loops work
+t/comp/cmdopt.t 39 See if command optimization works
+t/comp/cpp.t 43 See if C preprocessor works
+t/comp/decl.t 44 See if declarations work
+t/comp/multiline.t 43 See if multiline strings work
+t/comp/package.t 43 See if packages work
+t/comp/script.t 44 See if script invokation works
+t/comp/term.t 42 See if more terms work
+t/io/argv.t 43 See if ARGV stuff works
+t/io/dup.t 43 See if >& works right
+t/io/fs.t 39 See if directory manipulations work
+t/io/inplace.t 44 See if inplace editing works
+t/io/pipe.t 43 See if secure pipes work
+t/io/print.t 44 See if print commands work
+t/io/tell.t 42 See if file seeking works
+t/lib/big.t 38 See if lib/bigint.pl works
+t/op/append.t 44 See if . works
+t/op/array.t 39 See if array operations work
+t/op/auto.t 21 See if autoincrement et all work
+t/op/chop.t 43 See if chop works
+t/op/cond.t 44 See if conditional expressions work
+t/op/dbm.t 40 See if dbm binding works
+t/op/delete.t 43 See if delete works
+t/op/do.t 42 See if subroutines work
+t/op/each.t 42 See if associative iterators work
+t/op/eval.t 42 See if eval operator works
+t/op/exec.t 43 See if exec and system work
+t/op/exp.t 43 See if math functions work
+t/op/flip.t 43 See if range operator works
+t/op/fork.t 44 See if fork works
+t/op/glob.t 44 See if <*> works
+t/op/goto.t 43 See if goto works
+t/op/groups.t 43 See if $( works
+t/op/index.t 12 See if index works
+t/op/int.t 44 See if int works
+t/op/join.t 44 See if join works
+t/op/list.t 40 See if array lists work
+t/op/local.t 43 See if local works
+t/op/magic.t 42 See if magic variables work
+t/op/mkdir.t 44 See if mkdir works
+t/op/oct.t 44 See if oct and hex work
+t/op/ord.t 44 See if ord works
+t/op/pack.t 43 See if pack and unpack work
+t/op/pat.t 38 See if esoteric patterns work
+t/op/push.t 42 See if push and pop work
+t/op/range.t 43 See if .. works
+t/op/re_tests 32 Input file for op.regexp
+t/op/read.t 44 See if read() works
+t/op/readdir.t 44 See if readdir() works
+t/op/regexp.t 43 See if regular expressions work
+t/op/repeat.t 42 See if x operator works
+t/op/s.t 38 See if substitutions work
+t/op/sleep.t 44 See if sleep works
+t/op/sort.t 42 See if sort works
+t/op/split.t 41 See if split works
+t/op/sprintf.t 44 See if sprintf works
+t/op/stat.t 37 See if stat works
+t/op/study.t 41 See if study works
+t/op/substr.t 2 See if substr works
+t/op/time.t 42 See if time functions work
+t/op/undef.t 42 See if undef works
+t/op/unshift.t 44 See if unshift works
+t/op/vec.t 43 See if vectors work
+t/op/write.t 41 See if write works
+toke.c:AA 3 The tokener
+toke.c:AB 31
+usersub.c 39 User supplied (possibly proprietary) subroutines
+usub/Makefile 44 Makefile for curseperl
+usub/README 1 Instructions for user supplied subroutines
+usub/bsdcurses.mus 32 what used to be curses.mus
+usub/curses.mus 21 Glue routines for BSD curses
+usub/man2mus 42 A manual page to .mus translator
+usub/mus 40 A .mus to .c translator
+usub/pager 39 A sample pager in curseperl
+usub/usersub.c 41 An initialization file to call curses glue routines
+util.c 16 Utility routines
+util.h 42 Public declarations for the above
+x2p/EXTERN.h 44 Same as above
+x2p/INTERN.h 44 Same as above
+x2p/Makefile.SH 23 Precursor to Makefile
+x2p/a2p.h 14 Global declarations
+x2p/a2p.man 36 Manual page for awk to perl translator
+x2p/a2p.y 17 A yacc grammer for awk
+x2p/a2py.c 28 Awk compiler, sort of
+x2p/cflags.SH 41 A script that emits C compilation flags per file
+x2p/find2perl.SH 33 A find to perl translator
+x2p/handy.h 42 Handy definitions
+x2p/hash.c 38 Associative arrays again
+x2p/hash.h 42 Public declarations for the above
+x2p/s2p.SH 31 Sed to perl translator
+x2p/s2p.man 40 Manual page for sed to perl translator
+x2p/str.c 16 String handling package
+x2p/str.h 42 Public declarations for the above
+x2p/util.c 37 Utility routines
+x2p/util.h 42 Public declarations for the above
+x2p/walk.c:AA 5 Parse tree walker
+x2p/walk.c:AB 42
+[This is an unsupported, pre-release version of Perl 5.0. It is expected
+to work only on a Sparc architecture machine. No Configure support is
+provided. In fact, if you succeed in configuring and making a new
+makefile, you'll probably overwrite the only makefile that works. Note
+that a Sparc executable comes with the kit, so you may not need to
+compile at all. There is no list of new features yet, but if you look
+at t/op/ref.t you'll see some of them in use. perl -Dxst is also fun.]
- Perl Kit, Version 4.0
+ Perl Kit, Version 5.0
- Copyright (c) 1989,1990,1991, Larry Wall
- All rights reserved.
+ Copyright (c) 1989,1990,1991,1992,1993, Larry Wall
+ All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the terms of either:
--------------------------------------------------------------------------
-Perl is a language that combines some of the features of C, sed, awk and shell.
-See the manual page for more hype. There's also a Nutshell Handbook published
-by O'Reilly & Assoc. Their U.S. number is 1-800-338-6887 (dev-nuts) and
-their international number is 1-707-829-0515. E-mail to nuts@ora.com.
-
-Perl will probably not run on machines with a small address space.
+Perl is a language that combines some of the features of C, sed, awk
+and shell. See the manual page for more hype. There's also a Nutshell
+Handbook published by O'Reilly & Assoc. Their U.S. number is
+1-800-998-9938 and their international number is 1-707-829-0515.
+E-mail to nuts@ora.com.
Please read all the directions below before you proceed any further, and
then follow them carefully.
X /* " @(#)time.h (TWG) 2.2 88/05/17 " */
X
X! /*
-X HDEF( "@(#)$RCSfile: README.ncr,v $$Revision: 4.0.1.1 $$Date: 92/06/08 11:41:41 $" )
+X HDEF( "@(#)$RCSfile: README.ncr,v $$Revision: 4.1 $$Date: 92/08/07 17:18:12 $" )
X- */
X
X /*
X! # include <sys/twg_config.h>
X! #endif
X!
-X HDEF( "@(#)$RCSfile: README.ncr,v $$Revision: 4.0.1.1 $$Date: 92/06/08 11:41:41 $" )
+X HDEF( "@(#)$RCSfile: README.ncr,v $$Revision: 4.1 $$Date: 92/08/07 17:18:12 $" )
X
X /*
X * Structure returned by gettimeofday(2) system call,
--- /dev/null
+Article 1475 of comp.lang.tcl:
+Path: netlabs!news!usc!cs.utexas.edu!sun-barr!ames!agate!sprite.Berkeley.EDU!ouster
+From: ouster@sprite.Berkeley.EDU (John Ousterhout)
+Newsgroups: comp.lang.tcl
+Subject: Planning for Tcl 7.0
+Message-ID: <1avu22INN5ao@agate.berkeley.edu>
+Date: 8 Oct 92 00:06:26 GMT
+Organization: U.C. Berkeley Sprite Project
+Lines: 156
+NNTP-Posting-Host: tyranny.berkeley.edu
+
+
+For the last year I've made only small changes to Tcl while focussing
+on the canvas and text widgets for Tk. I'm now making plans to catch
+up on a bunch of much-needed bug fixes and enhancements to Tcl. Some
+of the changes I'm considering are not backwards-compatible. The
+purpose of this message is to let know know what changes I'm considering
+for Tcl 7.0 and to solicit feedback. I'm particularly interested in
+comments on the changes that are incompatible: I'll probably drop
+the changes for which I get lots of negative feedback and not much
+positive feedback. If there are other changes that you think are
+important but aren't contained on this list, let me know and I may add
+them.
+
+Incompatible changes:
+---------------------
+
+The changes listed below are likely to require changes to existing
+scripts and/or C code. Each change includes an explanation of why the
+change might be useful. I'd like to know whether or not you think the change
+is useful enough to justify the incompatibility.
+
+1. Eliminate the "|" option in the "open" command. Instead, add a
+"popen" command that does the same thing. Rationale: in the current
+implementation you can't open a file whose name begins with "|".
+Also, I think the "popen" command would be more logical.
+
+2. Eliminate the Tcl_WaitPids procedure and use the waitpid POSIX call
+instead. Also change the wait code to periodically poll for dead
+child processes so that zombie processes don't get left around forever.
+Rationale: the current code tends to leave zombies around in some
+situations. Switching to waitpid should solve this problem in a
+relatively portable fashion. The only incompatibility will be for
+C procedures that call Tcl_WaitPids; they'll have to switch to call
+waitpid instead. I'll provide a compatibility version of waitpid for
+use on systems that don't have it yet.
+
+3. Clean up backslash processing in several ways:
+ - Change backslash-newline to eat up all the whitespace following the
+ newline and replace the sequence with a single whitespace character.
+ Right now it only eats up the newline character and replaces it
+ with an empty string. Rationale: this would be more consistent
+ with other programs that process backslash-newline sequences.
+ - Eliminate the sequences \Mxx, \Cxxx, and \e.
+ Rationale: these sequences are left around from ancient times.
+ They're not particular compatible with any other program. I
+ should have removed them in Tcl 6.0 but didn't. They did get
+ removed from the documentation, however, so no-one should be
+ using them (?).
+ - Change \x (where x is not one of the characters that gets special
+ backslash treatment) to expand to x, not \x.
+ Rationale: the current behavior is inconsistent with all other
+ programs I know of that handle backslashes, and I think it's
+ confusing.
+ - Change "format" so it doesn't do an additional layer of backslash
+ processing on its format string.
+ Rationale: I don't know why it currently behaves as it does, and
+ I think it's confusing.
+
+4. Change "regsub" so that when no match occurs it sets the result
+variable to the original string, rather than leaving it unmodified.
+Rationale: the current behavior results in extra tests of the regsub
+result that could sometimes be avoided with the proposed new behavior.
+I doubt that there's much code that will break with the change (this
+would have to be code that depends on the result variable *not* being
+modified).
+
+5. Change the name "UNIX" in the "errorCode" variable to "POSIX".
+Rationale: I suspect that I'm eventually going to get a call from the
+USL lawyers on this one if I don't change it. Better to change it now
+in an orderly fashion so I don't have change it hastily in the future.
+
+6. Change glob to return only the names of existing files.
+Rationale: at present "glob */foo" expands * and generates a result
+without checking to see if each directory has a "foo" file in it. This
+makes the current behavior incompatible with csh, for example. One
+question is whether constructs like "glob {a,b}.c" should also check for
+the existence of each of the files. At present they don't (i.e. a.c and
+b.c will be returned even if they don't exist), but neither does csh. My
+inclination is to make the behavior match csh (names containing *?[] are
+checked for existence, others aren't). I'd be interested to hear
+opinions on this one: check all names for existence, check only names
+including *?[] (for csh compatibility), or keep it as it is?
+
+7. Change "gets" so it returns 1 for success and 0 for failure. At present
+it returns the line length for success and -1 for failure.
+Rationale: this would allow slightly simple Tcl scripts: you could just
+say
+ while [gets $f line] {...}
+instead of
+ while {[gets $f line] >= 0} {...}
+I'm not really convinced that this one is important enough to justify the
+incompatibility, so it won't take much negative feedback to kill it.
+
+Other changes:
+--------------
+
+The changes listed below shouldn't introduce substantial compatibility
+problems. Of course, any change can potentially cause scripts to stop
+working (e.g. almost any change will break the test suite), but very
+few if any people should be affected by these changes.
+
+8. Implement Tcl_CreateExternVar() procedure along lines proposed by
+Andreas Stolcke to tie a C variable to a Tcl variable with automatic
+updates between them.
+
+9. Changes to exec:
+ - Allow redirection to an existing file descriptor in "exec",
+ with a mechanism like >&1 or >& stdout.
+ - Allow file names immediately after ">" and "<" without
+ intervening spaces.
+
+10. Changes related to files:
+ - Fix Scott Bolte bug (closing stdin and stdout).
+ - Move TclGetOpenFile and OpenFile stuff to tcl.h so that they're
+ accessible to applications.
+ - Extend access modes in open to include the complete set of POSIX
+ access modes (such as O_EXCL and O_NONBLOCK).
+
+11. Re-instate Tcl_WatchInterp to notify application when an interpreter
+is deleted.
+
+12. Add "elseif" mechanism to "if" command for chaining "else {if ..."
+constructs more cleanly. Require exact matches on "then" and "else"
+keywords.
+
+13. Remove UNIX system call declarations from tclUnix.h. Use them from
+unistd.h instead, and provide a default version of unistd.h for systems
+that don't have one.
+
+14. Changes in the expr command, mostly following suggestions made by
+George Howlett a long time ago:
+ - Increase precision of floating-point results.
+ - Make floating-point numbers always print with a point.
+ - Add transcendental functions like sin and exp.
+ - Add explicit integer and floating conversion operations.
+ - Don't promote large integers to floating-point automatically.
+ - Allow multiple arguments to expr command.
+
+15. Extend lsort to allow alternate sorting mechanisms, like numeric,
+or client-supplied.
+
+16. Allow alternate pattern-matching forms (e.g. exact or regexp) for
+lsearch and case.
+
+17. Add XPG/3 positional argument specifiers to format (code contributed
+by Mark Diekhans).
+
+18. Change "file readlink" to return an error on systems that don't
+support it rather than removing the option entirely.
+
+19. Add a mechanism for scheduling a Tcl command to be executed when the
+interpreter reaches a clean point. This is needed for things like
+signal support.
+
+20. Change upvar so that you can refer to an element of an array as
+well as a whole array.
+
+
--- /dev/null
+Set KEEP on constant split
+Optimize foreach on array.
+Execute all BEGINs and ENDs.
+Make a good way to determine if *.pl is being executed directly.
+Make specialized allocators.
+Optimize switches.
+Do debugger
+Cache eval tree
+Implement eval once
+Cache m//g state
+rcatmaybe
+Fix length($&)
+eval {} coredump
+
+make tr/// return histogram in list context?
+Do anything with "hint"?
+When does split() go to @_?
+undef wantarray in void context?
rewrite regexp parser for better integrated optimization
add structured types and objects
allow for lexical scoping
+delete current sub
+++ /dev/null
-/* $RCSfile: arg.h,v $$Revision: 4.0.1.3 $$Date: 92/06/08 11:44:06 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: arg.h,v $
- * Revision 4.0.1.3 92/06/08 11:44:06 lwall
- * patch20: O_PIPE conflicted with Atari
- * patch20: clarified debugging output for literals and double-quoted strings
- *
- * Revision 4.0.1.2 91/11/05 15:51:05 lwall
- * patch11: added eval {}
- * patch11: added sort {} LIST
- *
- * Revision 4.0.1.1 91/06/07 10:18:30 lwall
- * patch4: length($`), length($&), length($') now optimized to avoid string copy
- * patch4: new copyright notice
- * patch4: many, many itty-bitty portability fixes
- *
- * Revision 4.0 91/03/20 01:03:09 lwall
- * 4.0 baseline.
- *
- */
-
-#define O_NULL 0
-#define O_RCAT 1
-#define O_ITEM 2
-#define O_SCALAR 3
-#define O_ITEM2 4
-#define O_ITEM3 5
-#define O_CONCAT 6
-#define O_REPEAT 7
-#define O_MATCH 8
-#define O_NMATCH 9
-#define O_SUBST 10
-#define O_NSUBST 11
-#define O_ASSIGN 12
-#define O_LOCAL 13
-#define O_AASSIGN 14
-#define O_SASSIGN 15
-#define O_CHOP 16
-#define O_DEFINED 17
-#define O_UNDEF 18
-#define O_STUDY 19
-#define O_POW 20
-#define O_MULTIPLY 21
-#define O_DIVIDE 22
-#define O_MODULO 23
-#define O_ADD 24
-#define O_SUBTRACT 25
-#define O_LEFT_SHIFT 26
-#define O_RIGHT_SHIFT 27
-#define O_LT 28
-#define O_GT 29
-#define O_LE 30
-#define O_GE 31
-#define O_EQ 32
-#define O_NE 33
-#define O_NCMP 34
-#define O_BIT_AND 35
-#define O_XOR 36
-#define O_BIT_OR 37
-#define O_AND 38
-#define O_OR 39
-#define O_COND_EXPR 40
-#define O_COMMA 41
-#define O_NEGATE 42
-#define O_NOT 43
-#define O_COMPLEMENT 44
-#define O_SELECT 45
-#define O_WRITE 46
-#define O_DBMOPEN 47
-#define O_DBMCLOSE 48
-#define O_OPEN 49
-#define O_TRANS 50
-#define O_NTRANS 51
-#define O_CLOSE 52
-#define O_EACH 53
-#define O_VALUES 54
-#define O_KEYS 55
-#define O_LARRAY 56
-#define O_ARRAY 57
-#define O_AELEM 58
-#define O_DELETE 59
-#define O_LHASH 60
-#define O_HASH 61
-#define O_HELEM 62
-#define O_LAELEM 63
-#define O_LHELEM 64
-#define O_LSLICE 65
-#define O_ASLICE 66
-#define O_HSLICE 67
-#define O_LASLICE 68
-#define O_LHSLICE 69
-#define O_SPLICE 70
-#define O_PUSH 71
-#define O_POP 72
-#define O_SHIFT 73
-#define O_UNPACK 74
-#define O_SPLIT 75
-#define O_LENGTH 76
-#define O_SPRINTF 77
-#define O_SUBSTR 78
-#define O_PACK 79
-#define O_GREP 80
-#define O_JOIN 81
-#define O_SLT 82
-#define O_SGT 83
-#define O_SLE 84
-#define O_SGE 85
-#define O_SEQ 86
-#define O_SNE 87
-#define O_SCMP 88
-#define O_SUBR 89
-#define O_DBSUBR 90
-#define O_CALLER 91
-#define O_SORT 92
-#define O_REVERSE 93
-#define O_WARN 94
-#define O_DIE 95
-#define O_PRTF 96
-#define O_PRINT 97
-#define O_CHDIR 98
-#define O_EXIT 99
-#define O_RESET 100
-#define O_LIST 101
-#define O_EOF 102
-#define O_GETC 103
-#define O_TELL 104
-#define O_RECV 105
-#define O_READ 106
-#define O_SYSREAD 107
-#define O_SYSWRITE 108
-#define O_SEND 109
-#define O_SEEK 110
-#define O_RETURN 111
-#define O_REDO 112
-#define O_NEXT 113
-#define O_LAST 114
-#define O_DUMP 115
-#define O_GOTO 116
-#define O_INDEX 117
-#define O_RINDEX 118
-#define O_TIME 119
-#define O_TMS 120
-#define O_LOCALTIME 121
-#define O_GMTIME 122
-#define O_TRUNCATE 123
-#define O_LSTAT 124
-#define O_STAT 125
-#define O_CRYPT 126
-#define O_ATAN2 127
-#define O_SIN 128
-#define O_COS 129
-#define O_RAND 130
-#define O_SRAND 131
-#define O_EXP 132
-#define O_LOG 133
-#define O_SQRT 134
-#define O_INT 135
-#define O_ORD 136
-#define O_ALARM 137
-#define O_SLEEP 138
-#define O_RANGE 139
-#define O_F_OR_R 140
-#define O_FLIP 141
-#define O_FLOP 142
-#define O_FORK 143
-#define O_WAIT 144
-#define O_WAITPID 145
-#define O_SYSTEM 146
-#define O_EXEC_OP 147
-#define O_HEX 148
-#define O_OCT 149
-#define O_CHOWN 150
-#define O_KILL 151
-#define O_UNLINK 152
-#define O_CHMOD 153
-#define O_UTIME 154
-#define O_UMASK 155
-#define O_MSGGET 156
-#define O_SHMGET 157
-#define O_SEMGET 158
-#define O_MSGCTL 159
-#define O_SHMCTL 160
-#define O_SEMCTL 161
-#define O_MSGSND 162
-#define O_MSGRCV 163
-#define O_SEMOP 164
-#define O_SHMREAD 165
-#define O_SHMWRITE 166
-#define O_RENAME 167
-#define O_LINK 168
-#define O_MKDIR 169
-#define O_RMDIR 170
-#define O_GETPPID 171
-#define O_GETPGRP 172
-#define O_SETPGRP 173
-#define O_GETPRIORITY 174
-#define O_SETPRIORITY 175
-#define O_CHROOT 176
-#define O_FCNTL 177
-#define O_IOCTL 178
-#define O_FLOCK 179
-#define O_UNSHIFT 180
-#define O_REQUIRE 181
-#define O_DOFILE 182
-#define O_EVAL 183
-#define O_FTRREAD 184
-#define O_FTRWRITE 185
-#define O_FTREXEC 186
-#define O_FTEREAD 187
-#define O_FTEWRITE 188
-#define O_FTEEXEC 189
-#define O_FTIS 190
-#define O_FTEOWNED 191
-#define O_FTROWNED 192
-#define O_FTZERO 193
-#define O_FTSIZE 194
-#define O_FTMTIME 195
-#define O_FTATIME 196
-#define O_FTCTIME 197
-#define O_FTSOCK 198
-#define O_FTCHR 199
-#define O_FTBLK 200
-#define O_FTFILE 201
-#define O_FTDIR 202
-#define O_FTPIPE 203
-#define O_FTLINK 204
-#define O_SYMLINK 205
-#define O_READLINK 206
-#define O_FTSUID 207
-#define O_FTSGID 208
-#define O_FTSVTX 209
-#define O_FTTTY 210
-#define O_FTTEXT 211
-#define O_FTBINARY 212
-#define O_SOCKET 213
-#define O_BIND 214
-#define O_CONNECT 215
-#define O_LISTEN 216
-#define O_ACCEPT 217
-#define O_GHBYNAME 218
-#define O_GHBYADDR 219
-#define O_GHOSTENT 220
-#define O_GNBYNAME 221
-#define O_GNBYADDR 222
-#define O_GNETENT 223
-#define O_GPBYNAME 224
-#define O_GPBYNUMBER 225
-#define O_GPROTOENT 226
-#define O_GSBYNAME 227
-#define O_GSBYPORT 228
-#define O_GSERVENT 229
-#define O_SHOSTENT 230
-#define O_SNETENT 231
-#define O_SPROTOENT 232
-#define O_SSERVENT 233
-#define O_EHOSTENT 234
-#define O_ENETENT 235
-#define O_EPROTOENT 236
-#define O_ESERVENT 237
-#define O_SOCKPAIR 238
-#define O_SHUTDOWN 239
-#define O_GSOCKOPT 240
-#define O_SSOCKOPT 241
-#define O_GETSOCKNAME 242
-#define O_GETPEERNAME 243
-#define O_SSELECT 244
-#define O_FILENO 245
-#define O_BINMODE 246
-#define O_VEC 247
-#define O_GPWNAM 248
-#define O_GPWUID 249
-#define O_GPWENT 250
-#define O_SPWENT 251
-#define O_EPWENT 252
-#define O_GGRNAM 253
-#define O_GGRGID 254
-#define O_GGRENT 255
-#define O_SGRENT 256
-#define O_EGRENT 257
-#define O_GETLOGIN 258
-#define O_OPEN_DIR 259
-#define O_READDIR 260
-#define O_TELLDIR 261
-#define O_SEEKDIR 262
-#define O_REWINDDIR 263
-#define O_CLOSEDIR 264
-#define O_SYSCALL 265
-#define O_PIPE_OP 266
-#define O_TRY 267
-#define O_EVALONCE 268
-#define MAXO 269
-
-#ifndef DOINIT
-extern char *opname[];
-#else
-char *opname[] = {
- "NULL",
- "RCAT",
- "ITEM",
- "SCALAR",
- "ITEM2",
- "ITEM3",
- "CONCAT",
- "REPEAT",
- "MATCH",
- "NMATCH",
- "SUBST",
- "NSUBST",
- "ASSIGN",
- "LOCAL",
- "AASSIGN",
- "SASSIGN",
- "CHOP",
- "DEFINED",
- "UNDEF",
- "STUDY",
- "POW",
- "MULTIPLY",
- "DIVIDE",
- "MODULO",
- "ADD",
- "SUBTRACT",
- "LEFT_SHIFT",
- "RIGHT_SHIFT",
- "LT",
- "GT",
- "LE",
- "GE",
- "EQ",
- "NE",
- "NCMP",
- "BIT_AND",
- "XOR",
- "BIT_OR",
- "AND",
- "OR",
- "COND_EXPR",
- "COMMA",
- "NEGATE",
- "NOT",
- "COMPLEMENT",
- "SELECT",
- "WRITE",
- "DBMOPEN",
- "DBMCLOSE",
- "OPEN",
- "TRANS",
- "NTRANS",
- "CLOSE",
- "EACH",
- "VALUES",
- "KEYS",
- "LARRAY",
- "ARRAY",
- "AELEM",
- "DELETE",
- "LHASH",
- "HASH",
- "HELEM",
- "LAELEM",
- "LHELEM",
- "LSLICE",
- "ASLICE",
- "HSLICE",
- "LASLICE",
- "LHSLICE",
- "SPLICE",
- "PUSH",
- "POP",
- "SHIFT",
- "UNPACK",
- "SPLIT",
- "LENGTH",
- "SPRINTF",
- "SUBSTR",
- "PACK",
- "GREP",
- "JOIN",
- "SLT",
- "SGT",
- "SLE",
- "SGE",
- "SEQ",
- "SNE",
- "SCMP",
- "SUBR",
- "DBSUBR",
- "CALLER",
- "SORT",
- "REVERSE",
- "WARN",
- "DIE",
- "PRINTF",
- "PRINT",
- "CHDIR",
- "EXIT",
- "RESET",
- "LIST",
- "EOF",
- "GETC",
- "TELL",
- "RECV",
- "READ",
- "SYSREAD",
- "SYSWRITE",
- "SEND",
- "SEEK",
- "RETURN",
- "REDO",
- "NEXT",
- "LAST",
- "DUMP",
- "GOTO",/* shudder */
- "INDEX",
- "RINDEX",
- "TIME",
- "TIMES",
- "LOCALTIME",
- "GMTIME",
- "TRUNCATE",
- "LSTAT",
- "STAT",
- "CRYPT",
- "ATAN2",
- "SIN",
- "COS",
- "RAND",
- "SRAND",
- "EXP",
- "LOG",
- "SQRT",
- "INT",
- "ORD",
- "ALARM",
- "SLEEP",
- "RANGE",
- "FLIP_OR_RANGE",
- "FLIP",
- "FLOP",
- "FORK",
- "WAIT",
- "WAITPID",
- "SYSTEM",
- "EXEC",
- "HEX",
- "OCT",
- "CHOWN",
- "KILL",
- "UNLINK",
- "CHMOD",
- "UTIME",
- "UMASK",
- "MSGGET",
- "SHMGET",
- "SEMGET",
- "MSGCTL",
- "SHMCTL",
- "SEMCTL",
- "MSGSND",
- "MSGRCV",
- "SEMOP",
- "SHMREAD",
- "SHMWRITE",
- "RENAME",
- "LINK",
- "MKDIR",
- "RMDIR",
- "GETPPID",
- "GETPGRP",
- "SETPGRP",
- "GETPRIORITY",
- "SETPRIORITY",
- "CHROOT",
- "FCNTL",
- "SYSIOCTL",
- "FLOCK",
- "UNSHIFT",
- "REQUIRE",
- "DOFILE",
- "EVAL",
- "FTRREAD",
- "FTRWRITE",
- "FTREXEC",
- "FTEREAD",
- "FTEWRITE",
- "FTEEXEC",
- "FTIS",
- "FTEOWNED",
- "FTROWNED",
- "FTZERO",
- "FTSIZE",
- "FTMTIME",
- "FTATIME",
- "FTCTIME",
- "FTSOCK",
- "FTCHR",
- "FTBLK",
- "FTFILE",
- "FTDIR",
- "FTPIPE",
- "FTLINK",
- "SYMLINK",
- "READLINK",
- "FTSUID",
- "FTSGID",
- "FTSVTX",
- "FTTTY",
- "FTTEXT",
- "FTBINARY",
- "SOCKET",
- "BIND",
- "CONNECT",
- "LISTEN",
- "ACCEPT",
- "GHBYNAME",
- "GHBYADDR",
- "GHOSTENT",
- "GNBYNAME",
- "GNBYADDR",
- "GNETENT",
- "GPBYNAME",
- "GPBYNUMBER",
- "GPROTOENT",
- "GSBYNAME",
- "GSBYPORT",
- "GSERVENT",
- "SHOSTENT",
- "SNETENT",
- "SPROTOENT",
- "SSERVENT",
- "EHOSTENT",
- "ENETENT",
- "EPROTOENT",
- "ESERVENT",
- "SOCKPAIR",
- "SHUTDOWN",
- "GSOCKOPT",
- "SSOCKOPT",
- "GETSOCKNAME",
- "GETPEERNAME",
- "SSELECT",
- "FILENO",
- "BINMODE",
- "VEC",
- "GPWNAM",
- "GPWUID",
- "GPWENT",
- "SPWENT",
- "EPWENT",
- "GGRNAM",
- "GGRGID",
- "GGRENT",
- "SGRENT",
- "EGRENT",
- "GETLOGIN",
- "OPENDIR",
- "READDIR",
- "TELLDIR",
- "SEEKDIR",
- "REWINDDIR",
- "CLOSEDIR",
- "SYSCALL",
- "PIPE",
- "TRY",
- "EVALONCE",
- "269"
-};
-#endif
-
-#define A_NULL 0
-#define A_EXPR 1
-#define A_CMD 2
-#define A_STAB 3
-#define A_LVAL 4
-#define A_SINGLE 5
-#define A_DOUBLE 6
-#define A_BACKTICK 7
-#define A_READ 8
-#define A_SPAT 9
-#define A_LEXPR 10
-#define A_ARYLEN 11
-#define A_ARYSTAB 12
-#define A_LARYLEN 13
-#define A_GLOB 14
-#define A_WORD 15
-#define A_INDREAD 16
-#define A_LARYSTAB 17
-#define A_STAR 18
-#define A_LSTAR 19
-#define A_WANTARRAY 20
-#define A_LENSTAB 21
-
-#define A_MASK 31
-#define A_DONT 32 /* or this into type to suppress evaluation */
-
-#ifndef DOINIT
-extern char *argname[];
-#else
-char *argname[] = {
- "A_NULL",
- "EXPR",
- "CMD",
- "STAB",
- "LVAL",
- "LITERAL",
- "DOUBLEQUOTE",
- "BACKTICK",
- "READ",
- "SPAT",
- "LEXPR",
- "ARYLEN",
- "ARYSTAB",
- "LARYLEN",
- "GLOB",
- "WORD",
- "INDREAD",
- "LARYSTAB",
- "STAR",
- "LSTAR",
- "WANTARRAY",
- "LENSTAB",
- "22"
-};
-#endif
-
-#ifndef DOINIT
-extern bool hoistable[];
-#else
-bool hoistable[] =
- {0, /* A_NULL */
- 0, /* EXPR */
- 1, /* CMD */
- 1, /* STAB */
- 0, /* LVAL */
- 1, /* SINGLE */
- 0, /* DOUBLE */
- 0, /* BACKTICK */
- 0, /* READ */
- 0, /* SPAT */
- 0, /* LEXPR */
- 1, /* ARYLEN */
- 1, /* ARYSTAB */
- 0, /* LARYLEN */
- 0, /* GLOB */
- 1, /* WORD */
- 0, /* INDREAD */
- 0, /* LARYSTAB */
- 1, /* STAR */
- 1, /* LSTAR */
- 1, /* WANTARRAY */
- 0, /* LENSTAB */
- 0, /* 21 */
-};
-#endif
-
-union argptr {
- ARG *arg_arg;
- char *arg_cval;
- STAB *arg_stab;
- SPAT *arg_spat;
- CMD *arg_cmd;
- STR *arg_str;
- HASH *arg_hash;
-};
-
-struct arg {
- union argptr arg_ptr;
- short arg_len;
- unsigned short arg_type;
- unsigned short arg_flags;
-};
-
-#define AF_ARYOK 1 /* op can handle multiple values here */
-#define AF_POST 2 /* post *crement this item */
-#define AF_PRE 4 /* pre *crement this item */
-#define AF_UP 8 /* increment rather than decrement */
-#define AF_COMMON 16 /* left and right have symbols in common */
-#define AF_DEPR 32 /* an older form of the construct */
-#define AF_LISTISH 64 /* turn into list if important */
-#define AF_LOCAL 128 /* list of local variables */
-
-/*
- * Most of the ARG pointers are used as pointers to arrays of ARG. When
- * so used, the 0th element is special, and represents the operator to
- * use on the list of arguments following. The arg_len in the 0th element
- * gives the maximum argument number, and the arg_str is used to store
- * the return value in a more-or-less static location. Sorry it's not
- * re-entrant (yet), but it sure makes it efficient. The arg_type of the
- * 0th element is an operator (O_*) rather than an argument type (A_*).
- */
-
-#define Nullarg Null(ARG*)
-
-#ifndef DOINIT
-EXT unsigned short opargs[MAXO+1];
-#else
-#define A(e1,e2,e3) (e1+(e2<<2)+(e3<<4))
-#define A5(e1,e2,e3,e4,e5) (e1+(e2<<2)+(e3<<4)+(e4<<6)+(e5<<8))
-unsigned short opargs[MAXO+1] = {
- A(0,0,0), /* NULL */
- A(1,1,0), /* RCAT */
- A(1,0,0), /* ITEM */
- A(1,0,0), /* SCALAR */
- A(0,0,0), /* ITEM2 */
- A(0,0,0), /* ITEM3 */
- A(1,1,0), /* CONCAT */
- A(3,1,0), /* REPEAT */
- A(1,0,0), /* MATCH */
- A(1,0,0), /* NMATCH */
- A(1,0,0), /* SUBST */
- A(1,0,0), /* NSUBST */
- A(1,1,0), /* ASSIGN */
- A(1,0,0), /* LOCAL */
- A(3,3,0), /* AASSIGN */
- A(0,0,0), /* SASSIGN */
- A(3,0,0), /* CHOP */
- A(1,0,0), /* DEFINED */
- A(1,0,0), /* UNDEF */
- A(1,0,0), /* STUDY */
- A(1,1,0), /* POW */
- A(1,1,0), /* MULTIPLY */
- A(1,1,0), /* DIVIDE */
- A(1,1,0), /* MODULO */
- A(1,1,0), /* ADD */
- A(1,1,0), /* SUBTRACT */
- A(1,1,0), /* LEFT_SHIFT */
- A(1,1,0), /* RIGHT_SHIFT */
- A(1,1,0), /* LT */
- A(1,1,0), /* GT */
- A(1,1,0), /* LE */
- A(1,1,0), /* GE */
- A(1,1,0), /* EQ */
- A(1,1,0), /* NE */
- A(1,1,0), /* NCMP */
- A(1,1,0), /* BIT_AND */
- A(1,1,0), /* XOR */
- A(1,1,0), /* BIT_OR */
- A(1,0,0), /* AND */
- A(1,0,0), /* OR */
- A(1,0,0), /* COND_EXPR */
- A(1,1,0), /* COMMA */
- A(1,0,0), /* NEGATE */
- A(1,0,0), /* NOT */
- A(1,0,0), /* COMPLEMENT */
- A(1,0,0), /* SELECT */
- A(1,0,0), /* WRITE */
- A(1,1,1), /* DBMOPEN */
- A(1,0,0), /* DBMCLOSE */
- A(1,1,0), /* OPEN */
- A(1,0,0), /* TRANS */
- A(1,0,0), /* NTRANS */
- A(1,0,0), /* CLOSE */
- A(0,0,0), /* EACH */
- A(0,0,0), /* VALUES */
- A(0,0,0), /* KEYS */
- A(0,0,0), /* LARRAY */
- A(0,0,0), /* ARRAY */
- A(0,1,0), /* AELEM */
- A(0,1,0), /* DELETE */
- A(0,0,0), /* LHASH */
- A(0,0,0), /* HASH */
- A(0,1,0), /* HELEM */
- A(0,1,0), /* LAELEM */
- A(0,1,0), /* LHELEM */
- A(0,3,3), /* LSLICE */
- A(0,3,0), /* ASLICE */
- A(0,3,0), /* HSLICE */
- A(0,3,0), /* LASLICE */
- A(0,3,0), /* LHSLICE */
- A(0,3,1), /* SPLICE */
- A(0,3,0), /* PUSH */
- A(0,0,0), /* POP */
- A(0,0,0), /* SHIFT */
- A(1,1,0), /* UNPACK */
- A(1,0,1), /* SPLIT */
- A(1,0,0), /* LENGTH */
- A(3,0,0), /* SPRINTF */
- A(1,1,1), /* SUBSTR */
- A(1,3,0), /* PACK */
- A(0,3,0), /* GREP */
- A(1,3,0), /* JOIN */
- A(1,1,0), /* SLT */
- A(1,1,0), /* SGT */
- A(1,1,0), /* SLE */
- A(1,1,0), /* SGE */
- A(1,1,0), /* SEQ */
- A(1,1,0), /* SNE */
- A(1,1,0), /* SCMP */
- A(0,3,0), /* SUBR */
- A(0,3,0), /* DBSUBR */
- A(1,0,0), /* CALLER */
- A(1,3,0), /* SORT */
- A(0,3,0), /* REVERSE */
- A(0,3,0), /* WARN */
- A(0,3,0), /* DIE */
- A(1,3,0), /* PRINTF */
- A(1,3,0), /* PRINT */
- A(1,0,0), /* CHDIR */
- A(1,0,0), /* EXIT */
- A(1,0,0), /* RESET */
- A(3,0,0), /* LIST */
- A(1,0,0), /* EOF */
- A(1,0,0), /* GETC */
- A(1,0,0), /* TELL */
- A5(1,1,1,1,0), /* RECV */
- A(1,1,3), /* READ */
- A(1,1,3), /* SYSREAD */
- A(1,1,3), /* SYSWRITE */
- A(1,1,3), /* SEND */
- A(1,1,1), /* SEEK */
- A(0,3,0), /* RETURN */
- A(0,0,0), /* REDO */
- A(0,0,0), /* NEXT */
- A(0,0,0), /* LAST */
- A(0,0,0), /* DUMP */
- A(0,0,0), /* GOTO */
- A(1,1,1), /* INDEX */
- A(1,1,1), /* RINDEX */
- A(0,0,0), /* TIME */
- A(0,0,0), /* TIMES */
- A(1,0,0), /* LOCALTIME */
- A(1,0,0), /* GMTIME */
- A(1,1,0), /* TRUNCATE */
- A(1,0,0), /* LSTAT */
- A(1,0,0), /* STAT */
- A(1,1,0), /* CRYPT */
- A(1,1,0), /* ATAN2 */
- A(1,0,0), /* SIN */
- A(1,0,0), /* COS */
- A(1,0,0), /* RAND */
- A(1,0,0), /* SRAND */
- A(1,0,0), /* EXP */
- A(1,0,0), /* LOG */
- A(1,0,0), /* SQRT */
- A(1,0,0), /* INT */
- A(1,0,0), /* ORD */
- A(1,0,0), /* ALARM */
- A(1,0,0), /* SLEEP */
- A(1,1,0), /* RANGE */
- A(1,0,0), /* F_OR_R */
- A(1,0,0), /* FLIP */
- A(0,1,0), /* FLOP */
- A(0,0,0), /* FORK */
- A(0,0,0), /* WAIT */
- A(1,1,0), /* WAITPID */
- A(1,3,0), /* SYSTEM */
- A(1,3,0), /* EXEC */
- A(1,0,0), /* HEX */
- A(1,0,0), /* OCT */
- A(0,3,0), /* CHOWN */
- A(0,3,0), /* KILL */
- A(0,3,0), /* UNLINK */
- A(0,3,0), /* CHMOD */
- A(0,3,0), /* UTIME */
- A(1,0,0), /* UMASK */
- A(1,1,0), /* MSGGET */
- A(1,1,1), /* SHMGET */
- A(1,1,1), /* SEMGET */
- A(1,1,1), /* MSGCTL */
- A(1,1,1), /* SHMCTL */
- A5(1,1,1,1,0), /* SEMCTL */
- A(1,1,1), /* MSGSND */
- A5(1,1,1,1,1), /* MSGRCV */
- A(1,1,1), /* SEMOP */
- A5(1,1,1,1,0), /* SHMREAD */
- A5(1,1,1,1,0), /* SHMWRITE */
- A(1,1,0), /* RENAME */
- A(1,1,0), /* LINK */
- A(1,1,0), /* MKDIR */
- A(1,0,0), /* RMDIR */
- A(0,0,0), /* GETPPID */
- A(1,0,0), /* GETPGRP */
- A(1,1,0), /* SETPGRP */
- A(1,1,0), /* GETPRIORITY */
- A(1,1,1), /* SETPRIORITY */
- A(1,0,0), /* CHROOT */
- A(1,1,1), /* FCNTL */
- A(1,1,1), /* SYSIOCTL */
- A(1,1,0), /* FLOCK */
- A(0,3,0), /* UNSHIFT */
- A(1,0,0), /* REQUIRE */
- A(1,0,0), /* DOFILE */
- A(1,0,0), /* EVAL */
- A(1,0,0), /* FTRREAD */
- A(1,0,0), /* FTRWRITE */
- A(1,0,0), /* FTREXEC */
- A(1,0,0), /* FTEREAD */
- A(1,0,0), /* FTEWRITE */
- A(1,0,0), /* FTEEXEC */
- A(1,0,0), /* FTIS */
- A(1,0,0), /* FTEOWNED */
- A(1,0,0), /* FTROWNED */
- A(1,0,0), /* FTZERO */
- A(1,0,0), /* FTSIZE */
- A(1,0,0), /* FTMTIME */
- A(1,0,0), /* FTATIME */
- A(1,0,0), /* FTCTIME */
- A(1,0,0), /* FTSOCK */
- A(1,0,0), /* FTCHR */
- A(1,0,0), /* FTBLK */
- A(1,0,0), /* FTFILE */
- A(1,0,0), /* FTDIR */
- A(1,0,0), /* FTPIPE */
- A(1,0,0), /* FTLINK */
- A(1,1,0), /* SYMLINK */
- A(1,0,0), /* READLINK */
- A(1,0,0), /* FTSUID */
- A(1,0,0), /* FTSGID */
- A(1,0,0), /* FTSVTX */
- A(1,0,0), /* FTTTY */
- A(1,0,0), /* FTTEXT */
- A(1,0,0), /* FTBINARY */
- A5(1,1,1,1,0), /* SOCKET */
- A(1,1,0), /* BIND */
- A(1,1,0), /* CONNECT */
- A(1,1,0), /* LISTEN */
- A(1,1,0), /* ACCEPT */
- A(1,0,0), /* GHBYNAME */
- A(1,1,0), /* GHBYADDR */
- A(0,0,0), /* GHOSTENT */
- A(1,0,0), /* GNBYNAME */
- A(1,1,0), /* GNBYADDR */
- A(0,0,0), /* GNETENT */
- A(1,0,0), /* GPBYNAME */
- A(1,0,0), /* GPBYNUMBER */
- A(0,0,0), /* GPROTOENT */
- A(1,1,0), /* GSBYNAME */
- A(1,1,0), /* GSBYPORT */
- A(0,0,0), /* GSERVENT */
- A(1,0,0), /* SHOSTENT */
- A(1,0,0), /* SNETENT */
- A(1,0,0), /* SPROTOENT */
- A(1,0,0), /* SSERVENT */
- A(0,0,0), /* EHOSTENT */
- A(0,0,0), /* ENETENT */
- A(0,0,0), /* EPROTOENT */
- A(0,0,0), /* ESERVENT */
- A5(1,1,1,1,1), /* SOCKPAIR */
- A(1,1,0), /* SHUTDOWN */
- A(1,1,1), /* GSOCKOPT */
- A5(1,1,1,1,0), /* SSOCKOPT */
- A(1,0,0), /* GETSOCKNAME */
- A(1,0,0), /* GETPEERNAME */
- A5(1,1,1,1,0), /* SSELECT */
- A(1,0,0), /* FILENO */
- A(1,0,0), /* BINMODE */
- A(1,1,1), /* VEC */
- A(1,0,0), /* GPWNAM */
- A(1,0,0), /* GPWUID */
- A(0,0,0), /* GPWENT */
- A(0,0,0), /* SPWENT */
- A(0,0,0), /* EPWENT */
- A(1,0,0), /* GGRNAM */
- A(1,0,0), /* GGRGID */
- A(0,0,0), /* GGRENT */
- A(0,0,0), /* SGRENT */
- A(0,0,0), /* EGRENT */
- A(0,0,0), /* GETLOGIN */
- A(1,1,0), /* OPENDIR */
- A(1,0,0), /* READDIR */
- A(1,0,0), /* TELLDIR */
- A(1,1,0), /* SEEKDIR */
- A(1,0,0), /* REWINDDIR */
- A(1,0,0), /* CLOSEDIR */
- A(1,3,0), /* SYSCALL */
- A(1,1,0), /* PIPE */
- A(0,0,0), /* TRY */
- A(1,0,0), /* EVALONCE */
- 0
-};
-#undef A
-#undef A5
-#endif
-
-int do_trans();
-int do_split();
-bool do_eof();
-long do_tell();
-bool do_seek();
-int do_tms();
-int do_time();
-int do_stat();
-STR *do_push();
-FILE *nextargv();
-STR *do_fttext();
-int do_slice();
+++ /dev/null
-/* $RCSfile: array.c,v $$Revision: 4.0.1.3 $$Date: 92/06/08 11:45:05 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: array.c,v $
- * Revision 4.0.1.3 92/06/08 11:45:05 lwall
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- *
- * Revision 4.0.1.2 91/11/05 16:00:14 lwall
- * patch11: random cleanup
- * patch11: passing non-existend array elements to subrouting caused core dump
- *
- * Revision 4.0.1.1 91/06/07 10:19:08 lwall
- * patch4: new copyright notice
- *
- * Revision 4.0 91/03/20 01:03:32 lwall
- * 4.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_mortal(&str_undef);
- (void)astore(ar,key,str);
- return str;
- }
- else
- return &str_undef;
- }
- if (!ar->ary_array[key]) {
- if (lval) {
- str = Str_new(6,0);
- (void)astore(ar,key,str);
- return str;
- }
- return &str_undef;
- }
- 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;
- Move(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 {
- if (ar->ary_alloc) {
- 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*);
- }
- else {
- newmax = key < 4 ? 4 : key;
- Newz(2,ar->ary_alloc, newmax+1, STR*);
- }
- ar->ary_array = ar->ary_alloc;
- ar->ary_max = newmax;
- }
- }
- if (ar->ary_flags & ARF_REAL) {
- if (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)
- str_free(ar->ary_array[key]);
- }
- else
- retval = 0;
- ar->ary_array[key] = val;
- return retval;
-}
-
-ARRAY *
-anew(stab)
-STAB *stab;
-{
- register ARRAY *ar;
-
- New(1,ar,1,ARRAY);
- ar->ary_magic = Str_new(7,0);
- ar->ary_alloc = ar->ary_array = 0;
- str_magic(ar->ary_magic, stab, '#', Nullch, 0);
- ar->ary_max = ar->ary_fill = -1;
- ar->ary_flags = ARF_REAL;
- return ar;
-}
-
-ARRAY *
-afake(stab,size,strp)
-STAB *stab;
-register int size;
-register 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;
- while (size--) {
- if (*strp)
- (*strp)->str_pok &= ~SP_TEMP;
- strp++;
- }
- return ar;
-}
-
-void
-aclear(ar)
-register ARRAY *ar;
-{
- register int key;
-
- if (!ar || !(ar->ary_flags & ARF_REAL) || ar->ary_max < 0)
- return;
- /*SUPPRESS 560*/
- 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;
- /*SUPPRESS 560*/
- 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;
-}
-
-void
-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;
-#ifdef BUGGY_MSC5
- # pragma loop_opt(off) /* don't loop-optimize the following code */
-#endif /* BUGGY_MSC5 */
- for (i = ar->ary_fill - num; i >= 0; i--) {
- *dstr-- = *sstr--;
-#ifdef BUGGY_MSC5
- # pragma loop_opt() /* loop-optimization back to command-line setting */
-#endif /* BUGGY_MSC5 */
- }
- 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;
-}
-
-void
-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);
-}
+++ /dev/null
-/* $RCSfile: array.h,v $$Revision: 4.0.1.2 $$Date: 92/06/08 11:45:57 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: array.h,v $
- * Revision 4.0.1.2 92/06/08 11:45:57 lwall
- * patch20: removed implicit int declarations on funcions
- *
- * Revision 4.0.1.1 91/06/07 10:19:20 lwall
- * patch4: new copyright notice
- *
- * Revision 4.0 91/03/20 01:03:44 lwall
- * 4.0 baseline.
- *
- */
-
-struct atbl {
- STR **ary_array;
- STR **ary_alloc;
- STR *ary_magic;
- int ary_max;
- int ary_fill;
- char ary_flags;
-};
-
-#define ARF_REAL 1 /* free old entries */
-
-STR *afetch();
-bool astore();
-STR *apop();
-STR *ashift();
-void afree();
-void aclear();
-bool apush();
-int alen();
-ARRAY *anew();
-ARRAY *afake();
-void aunshift();
-void afill();
# : Makefile.SH,v 9820Revision: 4.0.1.2 9820Date: 91/06/07 10:14:43 $
#
# $Log: makefile.sm,v $
+# Revision 4.1 92/08/07 17:18:37 lwall
+# Stage 6 Snapshot
+#
# Revision 4.0.1.1 92/06/08 11:50:00 lwall
# Initial revision
#
# : Makefile.SH,v 9820Revision: 4.0.1.2 9820Date: 91/06/07 10:14:43 $
#
# $Log: makefile.st,v $
+# Revision 4.1 92/08/07 17:18:40 lwall
+# Stage 6 Snapshot
+#
# Revision 4.0.1.1 92/06/08 11:50:13 lwall
# Initial revision
#
! # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
! # Johan Vromans -- upgrade to 4.0 pl 10
!
-! $header = '$RCSfile: perldb.diff,v $$Revision: 4.0.1.1 $$Date: 92/06/08 11:50:28 $';
+! $header = '$RCSfile: perldb.diff,v $$Revision: 4.1 $$Date: 92/08/07 17:18:44 $';
#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
--- 1,6 ----
package DB;
-! $header = '$RCSfile: perldb.diff,v $$Revision: 4.0.1.1 $$Date: 92/06/08 11:50:28 $';
+! $header = '$RCSfile: perldb.diff,v $$Revision: 4.1 $$Date: 92/08/07 17:18:44 $';
#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
#
# $Log: perldb.diff,v $
+ # Revision 4.1 92/08/07 17:18:44 lwall
+ # Stage 6 Snapshot
+ #
# Revision 4.0.1.1 92/06/08 11:50:28 lwall
# Initial revision
#
-/* $RCSfile: acurses.mus,v $$Revision: 4.0.1.1 $$Date: 92/06/08 11:54:30 $
+/* $RCSfile: acurses.mus,v $$Revision: 4.1 $$Date: 92/08/07 17:19:04 $
*
* $Log: acurses.mus,v $
+ * Revision 4.1 92/08/07 17:19:04 lwall
+ * Stage 6 Snapshot
+ *
* Revision 4.0.1.1 92/06/08 11:54:30 lwall
* Initial revision
*
-/* $RCSfile: usersub.c,v $$Revision: 4.0.1.1 $$Date: 92/06/08 11:54:52 $
+/* $RCSfile: usersub.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:07 $
*
* $Log: usersub.c,v $
+ * Revision 4.1 92/08/07 17:19:07 lwall
+ * Stage 6 Snapshot
+ *
* Revision 4.0.1.1 92/06/08 11:54:52 lwall
* Initial revision
*
-/* $Revision: 4.0.1.1 $
+/* $Revision: 4.1 $
**
** Do shell-style pattern matching for ?, \, [], and * characters.
** Might not be robust in face of malformed patterns; e.g., "foo[a-"
--- /dev/null
+/* $RCSfile: array.c,v $$Revision: 4.1 $$Date: 92/08/07 17:18:22 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: array.c,v $
+ * Revision 4.1 92/08/07 17:18:22 lwall
+ * Stage 6 Snapshot
+ *
+ * Revision 4.0.1.3 92/06/08 11:45:05 lwall
+ * patch20: Perl now distinguishes overlapped copies from non-overlapped
+ *
+ * Revision 4.0.1.2 91/11/05 16:00:14 lwall
+ * patch11: random cleanup
+ * patch11: passing non-existend array elements to subrouting caused core dump
+ *
+ * Revision 4.0.1.1 91/06/07 10:19:08 lwall
+ * patch4: new copyright notice
+ *
+ * Revision 4.0 91/03/20 01:03:32 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+SV**
+av_fetch(ar,key,lval)
+register AV *ar;
+I32 key;
+I32 lval;
+{
+ SV *sv;
+
+ if (key < 0 || key > AvFILL(ar)) {
+ if (lval && key >= 0) {
+ if (AvREAL(ar))
+ sv = NEWSV(5,0);
+ else
+ sv = sv_mortalcopy(&sv_undef);
+ return av_store(ar,key,sv);
+ }
+ else
+ return 0;
+ }
+ if (!AvARRAY(ar)[key]) {
+ if (lval) {
+ sv = NEWSV(6,0);
+ return av_store(ar,key,sv);
+ }
+ return 0;
+ }
+ return &AvARRAY(ar)[key];
+}
+
+SV**
+av_store(ar,key,val)
+register AV *ar;
+I32 key;
+SV *val;
+{
+ I32 tmp;
+ SV** ary;
+
+ if (key < 0)
+ return 0;
+ if (key > AvMAX(ar)) {
+ I32 newmax;
+
+ if (AvALLOC(ar) != AvARRAY(ar)) {
+ tmp = AvARRAY(ar) - AvALLOC(ar);
+ Move(AvARRAY(ar), AvALLOC(ar), AvMAX(ar)+1, SV*);
+ Zero(AvALLOC(ar)+AvMAX(ar)+1, tmp, SV*);
+ AvMAX(ar) += tmp;
+ AvARRAY(ar) -= tmp;
+ if (key > AvMAX(ar) - 10) {
+ newmax = key + AvMAX(ar);
+ goto resize;
+ }
+ }
+ else {
+ if (AvALLOC(ar)) {
+ newmax = key + AvMAX(ar) / 5;
+ resize:
+ Renew(AvALLOC(ar),newmax+1, SV*);
+ Zero(&AvALLOC(ar)[AvMAX(ar)+1], newmax - AvMAX(ar), SV*);
+ }
+ else {
+ newmax = key < 4 ? 4 : key;
+ Newz(2,AvALLOC(ar), newmax+1, SV*);
+ }
+ AvARRAY(ar) = AvALLOC(ar);
+ AvMAX(ar) = newmax;
+ }
+ }
+ ary = AvARRAY(ar);
+ if (AvREAL(ar)) {
+ if (AvFILL(ar) < key) {
+ while (++AvFILL(ar) < key) {
+ if (ary[AvFILL(ar)] != Nullsv) {
+ sv_free(ary[AvFILL(ar)]);
+ ary[AvFILL(ar)] = Nullsv;
+ }
+ }
+ }
+ if (ary[key])
+ sv_free(ary[key]);
+ }
+ ary[key] = val;
+ return &ary[key];
+}
+
+AV *
+newAV()
+{
+ register AV *ar;
+
+ Newz(1,ar,1,AV);
+ SvREFCNT(ar) = 1;
+ sv_upgrade(ar,SVt_PVAV);
+ AvREAL_on(ar);
+ AvALLOC(ar) = AvARRAY(ar) = 0;
+ AvMAX(ar) = AvFILL(ar) = -1;
+ return ar;
+}
+
+AV *
+av_make(size,strp)
+register I32 size;
+register SV **strp;
+{
+ register AV *ar;
+ register I32 i;
+ register SV** ary;
+
+ Newz(3,ar,1,AV);
+ sv_upgrade(ar,SVt_PVAV);
+ New(4,ary,size+1,SV*);
+ AvALLOC(ar) = ary;
+ Zero(ary,size,SV*);
+ AvREAL_on(ar);
+ AvARRAY(ar) = ary;
+ AvFILL(ar) = size - 1;
+ AvMAX(ar) = size - 1;
+ for (i = 0; i < size; i++) {
+ if (*strp) {
+ ary[i] = NEWSV(7,0);
+ sv_setsv(ary[i], *strp);
+ }
+ strp++;
+ }
+ return ar;
+}
+
+AV *
+av_fake(size,strp)
+register I32 size;
+register SV **strp;
+{
+ register AV *ar;
+ register SV** ary;
+
+ Newz(3,ar,1,AV);
+ SvREFCNT(ar) = 1;
+ sv_upgrade(ar,SVt_PVAV);
+ New(4,ary,size+1,SV*);
+ AvALLOC(ar) = ary;
+ Copy(strp,ary,size,SV*);
+ AvREAL_off(ar);
+ AvARRAY(ar) = ary;
+ AvFILL(ar) = size - 1;
+ AvMAX(ar) = size - 1;
+ while (size--) {
+ if (*strp)
+ SvTEMP_off(*strp);
+ strp++;
+ }
+ return ar;
+}
+
+void
+av_clear(ar)
+register AV *ar;
+{
+ register I32 key;
+
+ if (!ar || !AvREAL(ar) || AvMAX(ar) < 0)
+ return;
+ /*SUPPRESS 560*/
+ if (key = AvARRAY(ar) - AvALLOC(ar)) {
+ AvMAX(ar) += key;
+ AvARRAY(ar) -= key;
+ }
+ for (key = 0; key <= AvMAX(ar); key++)
+ sv_free(AvARRAY(ar)[key]);
+ AvFILL(ar) = -1;
+ Zero(AvARRAY(ar), AvMAX(ar)+1, SV*);
+}
+
+void
+av_undef(ar)
+register AV *ar;
+{
+ register I32 key;
+
+ if (!ar)
+ return;
+ /*SUPPRESS 560*/
+ if (key = AvARRAY(ar) - AvALLOC(ar)) {
+ AvMAX(ar) += key;
+ AvARRAY(ar) -= key;
+ }
+ if (AvREAL(ar)) {
+ for (key = 0; key <= AvMAX(ar); key++)
+ sv_free(AvARRAY(ar)[key]);
+ }
+ Safefree(AvALLOC(ar));
+ AvALLOC(ar) = AvARRAY(ar) = 0;
+ AvMAX(ar) = AvFILL(ar) = -1;
+}
+
+void
+av_free(ar)
+AV *ar;
+{
+ av_undef(ar);
+ Safefree(ar);
+}
+
+bool
+av_push(ar,val)
+register AV *ar;
+SV *val;
+{
+ return av_store(ar,++(AvFILL(ar)),val) != 0;
+}
+
+SV *
+av_pop(ar)
+register AV *ar;
+{
+ SV *retval;
+
+ if (AvFILL(ar) < 0)
+ return Nullsv;
+ retval = AvARRAY(ar)[AvFILL(ar)];
+ AvARRAY(ar)[AvFILL(ar)--] = Nullsv;
+ return retval;
+}
+
+void
+av_popnulls(ar)
+register AV *ar;
+{
+ register I32 fill = AvFILL(ar);
+
+ while (fill >= 0 && !AvARRAY(ar)[fill])
+ fill--;
+ AvFILL(ar) = fill;
+}
+
+void
+av_unshift(ar,num)
+register AV *ar;
+register I32 num;
+{
+ register I32 i;
+ register SV **sstr,**dstr;
+
+ if (num <= 0)
+ return;
+ if (AvARRAY(ar) - AvALLOC(ar) >= num) {
+ AvMAX(ar) += num;
+ AvFILL(ar) += num;
+ while (num--)
+ *--AvARRAY(ar) = Nullsv;
+ }
+ else {
+ (void)av_store(ar,AvFILL(ar)+num,(SV*)0); /* maybe extend array */
+ dstr = AvARRAY(ar) + AvFILL(ar);
+ sstr = dstr - num;
+#ifdef BUGGY_MSC5
+ # pragma loop_opt(off) /* don't loop-optimize the following code */
+#endif /* BUGGY_MSC5 */
+ for (i = AvFILL(ar) - num; i >= 0; i--) {
+ *dstr-- = *sstr--;
+#ifdef BUGGY_MSC5
+ # pragma loop_opt() /* loop-optimization back to command-line setting */
+#endif /* BUGGY_MSC5 */
+ }
+ Zero(AvARRAY(ar), num, SV*);
+ }
+}
+
+SV *
+av_shift(ar)
+register AV *ar;
+{
+ SV *retval;
+
+ if (AvFILL(ar) < 0)
+ return Nullsv;
+ retval = *AvARRAY(ar);
+ *(AvARRAY(ar)++) = Nullsv;
+ AvMAX(ar)--;
+ AvFILL(ar)--;
+ return retval;
+}
+
+I32
+av_len(ar)
+register AV *ar;
+{
+ return AvFILL(ar);
+}
+
+void
+av_fill(ar, fill)
+register AV *ar;
+I32 fill;
+{
+ if (fill < 0)
+ fill = -1;
+ if (fill <= AvMAX(ar))
+ AvFILL(ar) = fill;
+ else {
+ AvFILL(ar) = fill - 1; /* don't clobber in-between values */
+ (void)av_store(ar,fill,Nullsv);
+ }
+}
--- /dev/null
+/* $RCSfile: array.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:24 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: array.h,v $
+ * Revision 4.1 92/08/07 17:18:24 lwall
+ * Stage 6 Snapshot
+ *
+ * Revision 4.0.1.2 92/06/08 11:45:57 lwall
+ * patch20: removed implicit int declarations on funcions
+ *
+ * Revision 4.0.1.1 91/06/07 10:19:20 lwall
+ * patch4: new copyright notice
+ *
+ * Revision 4.0 91/03/20 01:03:44 lwall
+ * 4.0 baseline.
+ *
+ */
+
+struct xpvav {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xp_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ STRLEN xof_off; /* ptr is incremented by offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* magic for scalar array */
+ HV* xmg_stash; /* class package */
+
+ MAGIC* xav_magic; /* magic for elements */
+
+ SV** xav_array;
+ SV** xav_alloc;
+ SV* xav_arylen;
+ I32 xav_max;
+ I32 xav_fill;
+ U8 xav_flags;
+};
+
+#define AVf_REAL 1 /* free old entries */
+
+#define Nullav Null(AV*)
+
+#define AvMAGIC(av) ((XPVAV*) SvANY(av))->xav_magic
+#define AvARRAY(av) ((XPVAV*) SvANY(av))->xav_array
+#define AvALLOC(av) ((XPVAV*) SvANY(av))->xav_alloc
+#define AvMAX(av) ((XPVAV*) SvANY(av))->xav_max
+#define AvFILL(av) ((XPVAV*) SvANY(av))->xav_fill
+#define AvARYLEN(av) ((XPVAV*) SvANY(av))->xav_arylen
+#define AvFLAGS(av) ((XPVAV*) SvANY(av))->xav_flags
+
+#define AvREAL(av) (((XPVAV*) SvANY(av))->xav_flags & AVf_REAL)
+#define AvREAL_on(av) (((XPVAV*) SvANY(av))->xav_flags |= AVf_REAL)
+#define AvREAL_off(av) (((XPVAV*) SvANY(av))->xav_flags &= ~AVf_REAL)
--- /dev/null
+###############################################################################
--- /dev/null
+#!/usr/local/bin/perl
+#
+#
+# c2ph (aka pstruct)
+# Tom Christiansen, <tchrist@convex.com>
+#
+# As pstruct, dump C structures as generated from 'cc -g -S' stabs.
+# As c2ph, do this PLUS generate perl code for getting at the structures.
+#
+# See the usage message for more. If this isn't enough, read the code.
+#
+
+$RCSID = '$RCSfile: c2ph.SH,v $$Revision: 4.1 $$Date: 92/08/07 17:19:10 $';
+
+
+######################################################################
+
+# some handy data definitions. many of these can be reset later.
+
+$bitorder = 'b'; # ascending; set to B for descending bit fields
+
+%intrinsics =
+%template = (
+ 'char', 'c',
+ 'unsigned char', 'C',
+ 'short', 's',
+ 'short int', 's',
+ 'unsigned short', 'S',
+ 'unsigned short int', 'S',
+ 'short unsigned int', 'S',
+ 'int', 'i',
+ 'unsigned int', 'I',
+ 'long', 'l',
+ 'long int', 'l',
+ 'unsigned long', 'L',
+ 'unsigned long', 'L',
+ 'long unsigned int', 'L',
+ 'unsigned long int', 'L',
+ 'long long', 'q',
+ 'long long int', 'q',
+ 'unsigned long long', 'Q',
+ 'unsigned long long int', 'Q',
+ 'float', 'f',
+ 'double', 'd',
+ 'pointer', 'p',
+ 'null', 'x',
+ 'neganull', 'X',
+ 'bit', $bitorder,
+);
+
+&buildscrunchlist;
+delete $intrinsics{'neganull'};
+delete $intrinsics{'bit'};
+delete $intrinsics{'null'};
+
+# use -s to recompute sizes
+%sizeof = (
+ 'char', '1',
+ 'unsigned char', '1',
+ 'short', '2',
+ 'short int', '2',
+ 'unsigned short', '2',
+ 'unsigned short int', '2',
+ 'short unsigned int', '2',
+ 'int', '4',
+ 'unsigned int', '4',
+ 'long', '4',
+ 'long int', '4',
+ 'unsigned long', '4',
+ 'unsigned long int', '4',
+ 'long unsigned int', '4',
+ 'long long', '8',
+ 'long long int', '8',
+ 'unsigned long long', '8',
+ 'unsigned long long int', '8',
+ 'float', '4',
+ 'double', '8',
+ 'pointer', '4',
+);
+
+($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
+
+($offset_fmt, $size_fmt) = ('d', 'd');
+
+$indent = 2;
+
+$CC = 'cc';
+$CFLAGS = '-g -S';
+$DEFINES = '';
+
+$perl++ if $0 =~ m#/?c2ph$#;
+
+require 'getopts.pl';
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+&Getopts('aixdpvtnws:') || &usage(0);
+
+$opt_d && $debug++;
+$opt_t && $trace++;
+$opt_p && $perl++;
+$opt_v && $verbose++;
+$opt_n && ($perl = 0);
+
+if ($opt_w) {
+ ($type_width, $member_width, $offset_width) = (45, 35, 8);
+}
+if ($opt_x) {
+ ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
+}
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+sub PLUMBER {
+ select(STDERR);
+ print "oops, apperent pager foulup\n";
+ $isatty++;
+ &usage(1);
+}
+
+sub usage {
+ local($oops) = @_;
+ unless (-t STDOUT) {
+ select(STDERR);
+ } elsif (!$oops) {
+ $isatty++;
+ $| = 1;
+ print "hit <RETURN> for further explanation: ";
+ <STDIN>;
+ open (PIPE, "|". ($ENV{PAGER} || 'more'));
+ $SIG{PIPE} = PLUMBER;
+ select(PIPE);
+ }
+
+ print "usage: $0 [-dpnP] [var=val] [files ...]\n";
+
+ exit unless $isatty;
+
+ print <<EOF;
+
+Options:
+
+-w wide; short for: type_width=45 member_width=35 offset_width=8
+-x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+-n do not generate perl code (default when invoked as pstruct)
+-p generate perl code (default when invoked as c2ph)
+-v generate perl code, with C decls as comments
+
+-i do NOT recompute sizes for intrinsic datatypes
+-a dump information on intrinsics also
+
+-t trace execution
+-d spew reams of debugging output
+
+-slist give comma-separated list a structures to dump
+
+
+Var Name Default Value Meaning
+
+EOF
+
+ &defvar('CC', 'which_compiler to call');
+ &defvar('CFLAGS', 'how to generate *.s files with stabs');
+ &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
+
+ print "\n";
+
+ &defvar('type_width', 'width of type field (column 1)');
+ &defvar('member_width', 'width of member field (column 2)');
+ &defvar('offset_width', 'width of offset field (column 3)');
+ &defvar('size_width', 'width of size field (column 4)');
+
+ print "\n";
+
+ &defvar('offset_fmt', 'sprintf format type for offset');
+ &defvar('size_fmt', 'sprintf format type for size');
+
+ print "\n";
+
+ &defvar('indent', 'how far to indent each nesting level');
+
+ print <<'EOF';
+
+ If any *.[ch] files are given, these will be catted together into
+ a temporary *.c file and sent through:
+ $CC $CFLAGS $DEFINES
+ and the resulting *.s groped for stab information. If no files are
+ supplied, then stdin is read directly with the assumption that it
+ contains stab information. All other liens will be ignored. At
+ most one *.s file should be supplied.
+
+EOF
+ close PIPE;
+ exit 1;
+}
+
+sub defvar {
+ local($var, $msg) = @_;
+ printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
+}
+
+$recurse = 1;
+
+if (@ARGV) {
+ if (grep(!/\.[csh]$/,@ARGV)) {
+ warn "Only *.[csh] files expected!\n";
+ &usage;
+ }
+ elsif (grep(/\.s$/,@ARGV)) {
+ if (@ARGV > 1) {
+ warn "Only one *.s file allowed!\n";
+ &usage;
+ }
+ }
+ elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
+ local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
+ $chdir = "cd $dir; " if $dir;
+ &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
+ $ARGV[0] =~ s/\.c$/.s/;
+ }
+ else {
+ $TMP = "/tmp/c2ph.$$.c";
+ &system("cat @ARGV > $TMP") && exit 1;
+ &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
+ unlink $TMP;
+ $TMP =~ s/\.c$/.s/;
+ @ARGV = ($TMP);
+ }
+}
+
+if ($opt_s) {
+ for (split(/[\s,]+/, $opt_s)) {
+ $interested{$_}++;
+ }
+}
+
+
+$| = 1 if $debug;
+
+main: {
+
+ if ($trace) {
+ if (-t && !@ARGV) {
+ print STDERR "reading from your keyboard: ";
+ } else {
+ print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
+ }
+ }
+
+STAB: while (<>) {
+ if ($trace && !($. % 10)) {
+ $lineno = $..'';
+ print STDERR $lineno, "\b" x length($lineno);
+ }
+ next unless /^\s*\.stabs\s+/;
+ $line = $_;
+ s/^\s*\.stabs\s+//;
+ &stab;
+ }
+ print STDERR "$.\n" if $trace;
+ unlink $TMP if $TMP;
+
+ &compute_intrinsics if $perl && !$opt_i;
+
+ print STDERR "resolving types\n" if $trace;
+
+ &resolve_types;
+ &adjust_start_addrs;
+
+ $sum = 2 + $type_width + $member_width;
+ $pmask1 = "%-${type_width}s %-${member_width}s";
+ $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
+
+ if ($perl) {
+ # resolve template -- should be in stab define order, but even this isn't enough.
+ print STDERR "\nbuilding type templates: " if $trace;
+ for $i (reverse 0..$#type) {
+ next unless defined($name = $type[$i]);
+ next unless defined $struct{$name};
+ $build_recursed = 0;
+ &build_template($name) unless defined $template{&psou($name)} ||
+ $opt_s && !$interested{$name};
+ }
+ print STDERR "\n\n" if $trace;
+ }
+
+ print STDERR "dumping structs: " if $trace;
+
+
+ foreach $name (sort keys %struct) {
+ next if $opt_s && !$interested{$name};
+ print STDERR "$name " if $trace;
+
+ undef @sizeof;
+ undef @typedef;
+ undef @offsetof;
+ undef @indices;
+ undef @typeof;
+
+ $mname = &munge($name);
+
+ $fname = &psou($name);
+
+ print "# " if $perl && $verbose;
+ $pcode = '';
+ print "$fname {\n" if !$perl || $verbose;
+ $template{$fname} = &scrunch($template{$fname}) if $perl;
+ &pstruct($name,$name,0);
+ print "# " if $perl && $verbose;
+ print "}\n" if !$perl || $verbose;
+ print "\n" if $perl && $verbose;
+
+ if ($perl) {
+ print "$pcode";
+
+ printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
+
+ print <<EOF;
+sub ${mname}'typedef {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'typedef[\$${mname}'index]
+ : \$${mname}'typedef;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'sizeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'sizeof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'offsetof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'offsetof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'typeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'typeof[\$${mname}'index]
+ : '$name';
+}
+EOF
+
+
+ print "\$${mname}'typedef = '" . &scrunch($template{$fname})
+ . "';\n";
+
+ print "\$${mname}'sizeof = $sizeof{$name};\n\n";
+
+
+ print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
+
+ print "\n";
+
+ print "\@${mname}'typedef[\@${mname}'indices] = (",
+ join("\n\t", '', @typedef), "\n );\n\n";
+ print "\@${mname}'sizeof[\@${mname}'indices] = (",
+ join("\n\t", '', @sizeof), "\n );\n\n";
+ print "\@${mname}'offsetof[\@${mname}'indices] = (",
+ join("\n\t", '', @offsetof), "\n );\n\n";
+ print "\@${mname}'typeof[\@${mname}'indices] = (",
+ join("\n\t", '', @typeof), "\n );\n\n";
+
+ $template_printed{$fname}++;
+ $size_printed{$fname}++;
+ }
+ print "\n";
+ }
+
+ print STDERR "\n" if $trace;
+
+ unless ($perl && $opt_a) {
+ print "\n1;\n";
+ exit;
+ }
+
+
+
+ foreach $name (sort bysizevalue keys %intrinsics) {
+ next if $size_printed{$name};
+ print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
+ }
+
+ print "\n";
+
+ sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
+
+
+ foreach $name (sort keys %intrinsics) {
+ print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
+ }
+
+ print "\n1;\n";
+
+ exit;
+}
+
+########################################################################################
+
+
+sub stab {
+ next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
+ s/"// || next;
+ s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
+
+ next if /^\s*$/;
+
+ $size = $3 if $3;
+
+
+ $line = $_;
+
+ if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
+ print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
+ &pdecl($pdecl);
+ next;
+ }
+
+
+
+ if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
+ local($ident) = $2;
+ push(@intrinsics, $ident);
+ $typeno = &typeno($3);
+ $type[$typeno] = $ident;
+ print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
+ next;
+ }
+
+ if (($name, $typeordef, $typeno, $extra, $struct, $_)
+ = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
+ {
+ $typeno = &typeno($typeno); # sun foolery
+ }
+ elsif (/^[\$\w]+:/) {
+ next; # variable
+ }
+ else {
+ warn "can't grok stab: <$_> in: $line " if $_;
+ next;
+ }
+
+ #warn "got size $size for $name\n";
+ $sizeof{$name} = $size if $size;
+
+ s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
+
+ $typenos{$name} = $typeno;
+
+ unless (defined $type[$typeno]) {
+ &panic("type 0??") unless $typeno;
+ $type[$typeno] = $name unless defined $type[$typeno];
+ printf "new type $typeno is $name" if $debug;
+ if ($extra =~ /\*/ && defined $type[$struct]) {
+ print ", a typedef for a pointer to " , $type[$struct] if $debug;
+ }
+ } else {
+ printf "%s is type %d", $name, $typeno if $debug;
+ print ", a typedef for " , $type[$typeno] if $debug;
+ }
+ print "\n" if $debug;
+ #next unless $extra =~ /[su*]/;
+
+ #$type[$struct] = $name;
+
+ if ($extra =~ /[us*]/) {
+ &sou($name, $extra);
+ $_ = &sdecl($name, $_, 0);
+ }
+ elsif (/^=ar/) {
+ print "it's a bare array typedef -- that's pretty sick\n" if $debug;
+ $_ = "$typeno$_";
+ $scripts = '';
+ $_ = &adecl($_,1);
+
+ }
+ elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
+ push(@intrinsics, $2);
+ $typeno = &typeno($3);
+ $type[$typeno] = $2;
+ print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
+ }
+ elsif (s/^=e//) { # blessed by thy compiler; mine won't do this
+ &edecl;
+ }
+ else {
+ warn "Funny remainder for $name on line $_ left in $line " if $_;
+ }
+}
+
+sub typeno { # sun thinks types are (0,27) instead of just 27
+ local($_) = @_;
+ s/\(\d+,(\d+)\)/$1/;
+ $_;
+}
+
+sub pstruct {
+ local($what,$prefix,$base) = @_;
+ local($field, $fieldname, $typeno, $count, $offset, $entry);
+ local($fieldtype);
+ local($type, $tname);
+ local($mytype, $mycount, $entry2);
+ local($struct_count) = 0;
+ local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
+ local($bits,$bytes);
+ local($template);
+
+
+ local($mname) = &munge($name);
+
+ sub munge {
+ local($_) = @_;
+ s/[\s\$\.]/_/g;
+ $_;
+ }
+
+ local($sname) = &psou($what);
+
+ $nesting++;
+
+ for $field (split(/;/, $struct{$what})) {
+ $pad = $prepad = 0;
+ $entry = '';
+ ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
+
+ $type = $type[$typeno];
+
+ $type =~ /([^[]*)(\[.*\])?/;
+ $mytype = $1;
+ $count .= $2;
+ $fieldtype = &psou($mytype);
+
+ local($fname) = &psou($name);
+
+ if ($build_templates) {
+
+ $pad = ($offset - ($lastoffset + $lastlength))/8
+ if defined $lastoffset;
+
+ if (! $finished_template{$sname}) {
+ if ($isaunion{$what}) {
+ $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
+ } else {
+ $template{$sname} .= 'x' x $pad . ' ' if $pad;
+ }
+ }
+
+ $template = &fetch_template($type) x
+ ($count ? &scripts2count($count) : 1);
+
+ if (! $finished_template{$sname}) {
+ $template{$sname} .= $template;
+ }
+
+ $revpad = $length/8 if $isaunion{$what};
+
+ ($lastoffset, $lastlength) = ($offset, $length);
+
+ } else {
+ print '# ' if $perl && $verbose;
+ $entry = sprintf($pmask1,
+ ' ' x ($nesting * $indent) . $fieldtype,
+ "$prefix.$fieldname" . $count);
+
+ $entry =~ s/(\*+)( )/$2$1/;
+
+ printf $pmask2,
+ $entry,
+ ($base+$offset)/8,
+ ($bits = ($base+$offset)%8) ? ".$bits" : " ",
+ $length/8,
+ ($bits = $length % 8) ? ".$bits": ""
+ if !$perl || $verbose;
+
+
+ if ($perl && $nesting == 1) {
+ $template = &scrunch(&fetch_template($type) x
+ ($count ? &scripts2count($count) : 1));
+ push(@sizeof, int($length/8) .",\t# $fieldname");
+ push(@offsetof, int($offset/8) .",\t# $fieldname");
+ push(@typedef, "'$template', \t# $fieldname");
+ $type =~ s/(struct|union) //;
+ push(@typeof, "'$type" . ($count ? $count : '') .
+ "',\t# $fieldname");
+ }
+
+ print ' ', ' ' x $indent x $nesting, $template
+ if $perl && $verbose;
+
+ print "\n" if !$perl || $verbose;
+
+ }
+ if ($perl) {
+ local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
+ $mycount *= &scripts2count($count) if $count;
+ if ($nesting==1 && !$build_templates) {
+ $pcode .= sprintf("sub %-32s { %4d; }\n",
+ "${mname}'${fieldname}", $struct_count);
+ push(@indices, $struct_count);
+ }
+ $struct_count += $mycount;
+ }
+
+
+ &pstruct($type, "$prefix.$fieldname", $base+$offset)
+ if $recurse && defined $struct{$type};
+ }
+
+ $countof{$what} = $struct_count unless defined $countof{$whati};
+
+ $template{$sname} .= '$' if $build_templates;
+ $finished_template{$sname}++;
+
+ if ($build_templates && !defined $sizeof{$name}) {
+ local($fmt) = &scrunch($template{$sname});
+ print STDERR "no size for $name, punting with $fmt..." if $debug;
+ eval '$sizeof{$name} = length(pack($fmt, ()))';
+ if ($@) {
+ chop $@;
+ warn "couldn't get size for \$name: $@";
+ } else {
+ print STDERR $sizeof{$name}, "\n" if $debUg;
+ }
+ }
+
+ --$nesting;
+}
+
+
+sub psize {
+ local($me) = @_;
+ local($amstruct) = $struct{$me} ? 'struct ' : '';
+
+ print '$sizeof{\'', $amstruct, $me, '\'} = ';
+ printf "%d;\n", $sizeof{$me};
+}
+
+sub pdecl {
+ local($pdecl) = @_;
+ local(@pdecls);
+ local($tname);
+
+ warn "pdecl: $pdecl\n" if $debug;
+
+ $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
+ $pdecl =~ s/\*//g;
+ @pdecls = split(/=/, $pdecl);
+ $typeno = $pdecls[0];
+ $tname = pop @pdecls;
+
+ if ($tname =~ s/^f//) { $tname = "$tname&"; }
+ #else { $tname = "$tname*"; }
+
+ for (reverse @pdecls) {
+ $tname .= s/^f// ? "&" : "*";
+ #$tname =~ s/^f(.*)/$1&/;
+ print "type[$_] is $tname\n" if $debug;
+ $type[$_] = $tname unless defined $type[$_];
+ }
+}
+
+
+
+sub adecl {
+ ($arraytype, $unknown, $lower, $upper) = ();
+ #local($typeno);
+ # global $typeno, @type
+ local($_, $typedef) = @_;
+
+ while (s/^((\d+)=)?ar(\d+);//) {
+ ($arraytype, $unknown) = ($2, $3);
+ if (s/^(\d+);(\d+);//) {
+ ($lower, $upper) = ($1, $2);
+ $scripts .= '[' . ($upper+1) . ']';
+ } else {
+ warn "can't find array bounds: $_";
+ }
+ }
+ if (s/^([\d*f=]*),(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ local($whatis) = $1;
+ if ($whatis =~ /^(\d+)=/) {
+ $typeno = $1;
+ &pdecl($whatis);
+ } else {
+ $typeno = $whatis;
+ }
+ } elsif (s/^(\d+)(=[*suf]\d*)//) {
+ local($whatis) = $2;
+
+ if ($whatis =~ /[f*]/) {
+ &pdecl($whatis);
+ } elsif ($whatis =~ /[su]/) { #
+ print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
+ if $debug;
+ #$type[$typeno] = $name unless defined $type[$typeno];
+ ##printf "new type $typeno is $name" if $debug;
+ $typeno = $1;
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = $type[$typeno];
+ &sou($name, $whatis);
+ $_ = &sdecl($name, $_, $start+$offset);
+ 1;
+ $start = $start{$name};
+ $offset = $sizeof{$name};
+ $length = $offset;
+ } else {
+ warn "what's this? $whatis in $line ";
+ }
+ } elsif (/^\d+$/) {
+ $typeno = $_;
+ } else {
+ warn "bad array stab: $_ in $line ";
+ next STAB;
+ }
+ #local($wasdef) = defined($type[$typeno]) && $debug;
+ #if ($typedef) {
+ #print "redefining $type[$typeno] to " if $wasdef;
+ #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
+ #print "$type[$typeno]\n" if $wasdef;
+ #} else {
+ #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
+ #}
+ $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
+ print "type[$arraytype] is $type[$arraytype]\n" if $debug;
+ print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
+ $_;
+}
+
+
+
+sub sdecl {
+ local($prefix, $_, $offset) = @_;
+
+ local($fieldname, $scripts, $type, $arraytype, $unknown,
+ $whatis, $pdecl, $upper,$lower, $start,$length) = ();
+ local($typeno,$sou);
+
+
+SFIELD:
+ while (/^([^;]+);/) {
+ $scripts = '';
+ warn "sdecl $_\n" if $debug;
+ if (s/^([\$\w]+)://) {
+ $fieldname = $1;
+ } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
+ $typeno = &typeno($1);
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$2);
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $offset += $sizeof{$name};
+ #print "done with anon, start is $start, offset is $offset\n";
+ #next SFIELD;
+ } else {
+ warn "weird field $_ of $line" if $debug;
+ next STAB;
+ #$fieldname = &gensym;
+ #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ }
+
+ if (/^\d+=ar/) {
+ $_ = &adecl($_);
+ }
+ elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
+ ($pdecl, $start, $length) = ($1,$5,$6);
+ &pdecl($pdecl);
+ }
+ elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
+ ($typeno, $sou) = ($1, $2);
+ $typeno = &typeno($typeno);
+ if (defined($type[$typeno])) {
+ warn "now how did we get type $1 in $fieldname of $line?";
+ } else {
+ print "anon type $typeno is $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
+ };
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$sou);
+ print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname";
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $length = $sizeof{$name};
+ }
+ else {
+ warn "can't grok stab for $name ($_) in line $line ";
+ next STAB;
+ }
+
+ &panic("no length for $prefix.$fieldname") unless $length;
+ $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
+ }
+ if (s/;\d*,(\d+),(\d+);//) {
+ local($start, $size) = ($1, $2);
+ $sizeof{$prefix} = $size;
+ print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
+ $start{$prefix} = $start;
+ }
+ $_;
+}
+
+sub edecl {
+ s/;$//;
+ $enum{$name} = $_;
+ $_ = '';
+}
+
+sub resolve_types {
+ local($sou);
+ for $i (0 .. $#type) {
+ next unless defined $type[$i];
+ $_ = $type[$i];
+ unless (/\d/) {
+ print "type[$i] $type[$i]\n" if $debug;
+ next;
+ }
+ print "type[$i] $_ ==> " if $debug;
+ s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
+ s/^(\d+)\&/&type($1)/e;
+ s/^(\d+)/&type($1)/e;
+ s/(\*+)([^*]+)(\*+)/$1$3$2/;
+ s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
+ s/^(\d+)([\*\[].*)/&type($1).$2/e;
+ #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
+ $type[$i] = $_;
+ print "$_\n" if $debug;
+ }
+}
+sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
+
+sub adjust_start_addrs {
+ for (sort keys %start) {
+ ($basename = $_) =~ s/\.[^.]+$//;
+ $start{$_} += $start{$basename};
+ print "start: $_ @ $start{$_}\n" if $debug;
+ }
+}
+
+sub sou {
+ local($what, $_) = @_;
+ /u/ && $isaunion{$what}++;
+ /s/ && $isastruct{$what}++;
+}
+
+sub psou {
+ local($what) = @_;
+ local($prefix) = '';
+ if ($isaunion{$what}) {
+ $prefix = 'union ';
+ } elsif ($isastruct{$what}) {
+ $prefix = 'struct ';
+ }
+ $prefix . $what;
+}
+
+sub scrunch {
+ local($_) = @_;
+
+ study;
+
+ s/\$//g;
+ s/ / /g;
+ 1 while s/(\w) \1/$1$1/g;
+
+ # i wanna say this, but perl resists my efforts:
+ # s/(\w)(\1+)/$2 . length($1)/ge;
+
+ &quick_scrunch;
+
+ s/ $//;
+
+ $_;
+}
+
+sub buildscrunchlist {
+ $scrunch_code = "sub quick_scrunch {\n";
+ for (values %intrinsics) {
+ $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n";
+ }
+ $scrunch_code .= "}\n";
+ print "$scrunch_code" if $debug;
+ eval $scrunch_code;
+ &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
+}
+
+sub fetch_template {
+ local($mytype) = @_;
+ local($fmt);
+ local($count) = 1;
+
+ &panic("why do you care?") unless $perl;
+
+ if ($mytype =~ s/(\[\d+\])+$//) {
+ $count .= $1;
+ }
+
+ if ($mytype =~ /\*/) {
+ $fmt = $template{'pointer'};
+ }
+ elsif (defined $template{$mytype}) {
+ $fmt = $template{$mytype};
+ }
+ elsif (defined $struct{$mytype}) {
+ if (!defined $template{&psou($mytype)}) {
+ &build_template($mytype) unless $mytype eq $name;
+ }
+ elsif ($template{&psou($mytype)} !~ /\$$/) {
+ #warn "incomplete template for $mytype\n";
+ }
+ $fmt = $template{&psou($mytype)} || '?';
+ }
+ else {
+ warn "unknown fmt for $mytype\n";
+ $fmt = '?';
+ }
+
+ $fmt x $count . ' ';
+}
+
+sub compute_intrinsics {
+ local($TMP) = "/tmp/c2ph-i.$$.c";
+ open (TMP, ">$TMP") || die "can't open $TMP: $!";
+ select(TMP);
+
+ print STDERR "computing intrinsic sizes: " if $trace;
+
+ undef %intrinsics;
+
+ print <<'EOF';
+main() {
+ char *mask = "%d %s\n";
+EOF
+
+ for $type (@intrinsics) {
+ next if $type eq 'void';
+ print <<"EOF";
+ printf(mask,sizeof($type), "$type");
+EOF
+ }
+
+ print <<'EOF';
+ printf(mask,sizeof(char *), "pointer");
+ exit(0);
+}
+EOF
+ close TMP;
+
+ select(STDOUT);
+ open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
+ while (<PIPE>) {
+ chop;
+ split(' ',$_,2);;
+ print "intrinsic $_[1] is size $_[0]\n" if $debug;
+ $sizeof{$_[1]} = $_[0];
+ $intrinsics{$_[1]} = $template{$_[0]};
+ }
+ close(PIPE) || die "couldn't read intrinsics!";
+ unlink($TMP, '/tmp/a.out');
+ print STDERR "done\n" if $trace;
+}
+
+sub scripts2count {
+ local($_) = @_;
+
+ s/^\[//;
+ s/\]$//;
+ s/\]\[/*/g;
+ $_ = eval;
+ &panic("$_: $@") if $@;
+ $_;
+}
+
+sub system {
+ print STDERR "@_\n" if $trace;
+ system @_;
+}
+
+sub build_template {
+ local($name) = @_;
+
+ &panic("already got a template for $name") if defined $template{$name};
+
+ local($build_templates) = 1;
+
+ local($lparen) = '(' x $build_recursed;
+ local($rparen) = ')' x $build_recursed;
+
+ print STDERR "$lparen$name$rparen " if $trace;
+ $build_recursed++;
+ &pstruct($name,$name,0);
+ print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
+ --$build_recursed;
+}
+
+
+sub panic {
+
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ local($i,$_);
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @DB'args;
+ for (@a) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+ $_ = sprintf("%s",$_);
+ }
+ else {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ push(@sub, "$w&$s$a from file $f line $l\n");
+ last if $signal;
+ }
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ print $sub[$i];
+ }
+ exit 1;
+}
+
+sub squishseq {
+ local($num);
+ local($last) = -1e8;
+ local($string);
+ local($seq) = '..';
+
+ while (defined($num = shift)) {
+ if ($num == ($last + 1)) {
+ $string .= $seq unless $inseq++;
+ $last = $num;
+ next;
+ } elsif ($inseq) {
+ $string .= $last unless $last == -1e8;
+ }
+
+ $string .= ',' if defined $string;
+ $string .= $num;
+ $last = $num;
+ $inseq = 0;
+ }
+ $string .= $last if $inseq && $last != -e18;
+ $string;
+}
# See the usage message for more. If this isn't enough, read the code.
#
-$RCSID = '$RCSfile: c2ph.SH,v $$Revision: 4.0.1.2 $$Date: 92/06/08 11:56:08 $';
+$RCSID = '$RCSfile: c2ph.SH,v $$Revision: 4.1 $$Date: 92/08/07 17:19:10 $';
######################################################################
--- /dev/null
+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 2>/dev/null
+ . ./config.sh
+ ;;
+esac
+
+also=': '
+case $# in
+1) also='echo 1>&2 " CCCMD = "'
+esac
+
+case $# in
+0) set *.c; echo "The current C flags are:" ;;
+esac
+
+set `echo "$* " | sed 's/\.[oc] / /g'`
+
+for file do
+
+ case "$#" in
+ 1) ;;
+ *) echo $n " $file.c $c" ;;
+ esac
+
+ : allow variables like toke_cflags to be evaluated
+
+ eval 'eval ${'"${file}_cflags"'-""}'
+
+ : or customize here
+
+ case "$file" in
+ array) ;;
+ cmd) ;;
+ cons) ;;
+ consarg) ;;
+ doarg) ;;
+ doio) ;;
+ dolist) ;;
+ dump) ;;
+ eval) ;;
+ form) ;;
+ hash) ;;
+ malloc) ;;
+ perl) ;;
+ perly) ;;
+ regcomp) ;;
+ regexec) ;;
+ stab) ;;
+ str) ;;
+ toke) ;;
+ usersub) ;;
+ util) ;;
+ tarray) ;;
+ tcmd) ;;
+ tcons) ;;
+ tconsarg) ;;
+ tdoarg) ;;
+ tdoio) ;;
+ tdolist) ;;
+ tdump) ;;
+ teval) ;;
+ tform) ;;
+ thash) ;;
+ tmalloc) ;;
+ tperl) ;;
+ tperly) ;;
+ tregcomp) ;;
+ tregexec) ;;
+ tstab) ;;
+ tstr) ;;
+ ttoke) ;;
+ tusersub) ;;
+ tutil) ;;
+ *) ;;
+ esac
+
+ echo "$cc -c $ccflags $optimize $large $split"
+ eval "$also "'"$cc -c $ccflags $optimize $large $split"'
+
+ . ./config.sh
+
+done
+++ /dev/null
-/* $RCSfile: cmd.c,v $$Revision: 4.0.1.5 $$Date: 92/06/08 12:00:39 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: cmd.c,v $
- * Revision 4.0.1.5 92/06/08 12:00:39 lwall
- * patch20: the switch optimizer didn't do anything in subroutines
- * patch20: removed implicit int declarations on funcions
- *
- * Revision 4.0.1.4 91/11/11 16:29:33 lwall
- * patch19: do {$foo ne "bar";} returned wrong value
- * patch19: some earlier patches weren't propagated to alternate 286 code
- *
- * Revision 4.0.1.3 91/11/05 16:07:43 lwall
- * patch11: random cleanup
- * patch11: "foo\0" eq "foo" was sometimes optimized to true
- * patch11: foreach on null list could spring memory leak
- *
- * Revision 4.0.1.2 91/06/07 10:26:45 lwall
- * patch4: new copyright notice
- * patch4: made some allowances for "semi-standard" C
- *
- * Revision 4.0.1.1 91/04/11 17:36:16 lwall
- * patch1: you may now use "die" and "caller" in a signal handler
- *
- * Revision 4.0 91/03/20 01:04:18 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-#ifdef I_VARARGS
-# include <varargs.h>
-#endif
-
-static STR strchop;
-
-void grow_dlevel();
-
-/* do longjmps() clobber register variables? */
-
-#if defined(cray) || defined(STANDARD_C)
-#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;
- FILE *VOLATILE fp;
- ARRAY *VOLATILE ar;
-
- lastsize = 0;
-#ifdef DEBUGGING
- entdlevel = dlevel;
-#endif
-tail_recursion_entry:
-#ifdef DEBUGGING
- dlevel = entdlevel;
- if (debug & 4)
- deb("mortals = (%d/%d) stack, = (%d/%d)\n",
- tmps_max, tmps_base,
- savestack->ary_fill, firstsave);
-#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 && (cmdflags & CF_TERM),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 && (cmdflags & CF_TERM),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
- match = setjmp(loop_stack[loop_ptr].loop_env);
- if (match) {
- 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 && (cmdflags & CF_TERM),sp);
- st = stack->ary_array; /* possibly reallocated */
- if (newsp >= 0)
- 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 && (cmdflags & CF_TERM),sp);
- st = stack->ary_array; /* possibly reallocated */
- if (newsp >= 0)
- 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 */
-
- curcmd = cmd;
-
-#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 */
- }
- match = 0;
- goto strop;
-
- case CFT_STROP: /* string op optimization */
- match = 1;
- strop:
- retstr = STAB_STR(cmd->c_stab);
- newsp = -2;
-#ifndef I286
- if (*cmd->c_short->str_ptr == *str_get(retstr) &&
- (match ? retstr->str_cur == cmd->c_slen - 1 :
- retstr->str_cur >= cmd->c_slen) &&
- bcmp(cmd->c_short->str_ptr, str_get(retstr),
- cmd->c_slen) == 0 ) {
- if (cmdflags & CF_EQSURE) {
- if (sawampersand && (cmdflags & CF_OPTIMIZE) != CFT_STROP) {
- curspat = Nullspat;
- if (leftstab)
- str_nset(stab_val(leftstab),"",0);
- if (amperstab)
- str_sset(stab_val(amperstab),cmd->c_short);
- if (rightstab)
- str_nset(stab_val(rightstab),
- retstr->str_ptr + cmd->c_slen,
- retstr->str_cur - cmd->c_slen);
- }
- if (cmd->c_spat)
- lastspat = cmd->c_spat;
- match = !(cmdflags & CF_FIRSTNEG);
- retstr = match ? &str_yes : &str_no;
- goto flipmaybe;
- }
- }
- else if (cmdflags & CF_NESURE) {
- match = cmdflags & CF_FIRSTNEG;
- retstr = match ? &str_yes : &str_no;
- goto flipmaybe;
- }
-#else
- {
- char *zap1, *zap2, zap1c, zap2c;
- int zaplen;
- int lenok;
-
- zap1 = cmd->c_short->str_ptr;
- zap2 = str_get(retstr);
- zap1c = *zap1;
- zap2c = *zap2;
- zaplen = cmd->c_slen;
- if (match)
- lenok = (retstr->str_cur == cmd->c_slen - 1);
- else
- lenok = (retstr->str_cur >= cmd->c_slen);
- if ((zap1c == zap2c) && lenok && (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);
- }
- if (cmd->c_spat)
- lastspat = cmd->c_spat;
- match = !(cmdflags & CF_FIRSTNEG);
- retstr = match ? &str_yes : &str_no;
- goto flipmaybe;
- }
- }
- else if (cmdflags & CF_NESURE) {
- match = cmdflags & CF_FIRSTNEG;
- retstr = match ? &str_yes : &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_nset(stab_val(amperstab),
- tmps, cmd->c_short->str_cur);
- 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);
- }
- lastspat = cmd->c_spat;
- match = !(cmdflags & CF_FIRSTNEG);
- retstr = match ? &str_yes : &str_no;
- goto flipmaybe;
- }
- else
- hint = tmps;
- }
- else {
- if (cmdflags & CF_NESURE) {
- ++cmd->c_short->str_u.str_useful;
- match = cmdflags & CF_FIRSTNEG;
- retstr = match ? &str_yes : &str_no;
- goto flipmaybe;
- }
- }
- if (--cmd->c_short->str_u.str_useful < 0) {
- cmdflags &= ~CF_OPTIMIZE;
- cmdflags |= CFT_EVAL; /* never try this optimization again */
- cmd->c_flags = (cmdflags & ~CF_ONCE);
- }
- 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 (<file>) */
- 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]);
- tmps_list[tmps_max--] = Nullstr;
- }
- 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(&strchop,tmps,match);
- *tmps = '\0';
- retstr->str_nok = 0;
- retstr->str_cur = tmps - retstr->str_ptr;
- STABSET(retstr);
- retstr = &strchop;
- 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 */
- if (match < 0 && /* er, probably not... */
- savestack->ary_fill > aryoptsave)
- restorelist(aryoptsave);
- retstr = &str_undef;
- cmd->c_short->str_u.str_useful = -1; /* actually redundant */
- match = FALSE;
- }
- else {
- match++;
- if (!(retstr = ar->ary_array[match]))
- retstr = afetch(ar,match,TRUE);
- stab_val(cmd->c_stab) = retstr;
- cmd->c_short->str_u.str_useful = match;
- match = TRUE;
- }
- newsp = -2;
- goto maybe;
- case CFT_D1:
- break;
- case CFT_D0:
- if (DBsingle->str_u.str_nval != 0)
- break;
- if (DBsignal->str_u.str_nval != 0)
- break;
- if (DBtrace->str_u.str_nval != 0)
- break;
- goto next_cmd;
- }
-
- /* we have tried to make this normal case as abnormal as possible */
-
- doeval:
- if (gimme == G_ARRAY) {
- lastretstr = Nullstr;
- lastspbase = sp;
- lastsize = newsp - sp;
- if (lastsize < 0)
- lastsize = 0;
- }
- else
- lastretstr = retstr;
- while (tmps_max > tmps_base) { /* clean up after last eval */
- str_free(tmps_list[tmps_max]);
- tmps_list[tmps_max--] = Nullstr;
- }
- newsp = eval(cmd->c_expr,
- gimme && (cmdflags & CF_TERM) && cmd->c_type == C_EXPR &&
- !cmd->ucmd.acmd.ac_expr,
- 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]);
- tmps_list[tmps_max--] = Nullstr;
- }
- 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;
- if (lastsize < 0)
- lastsize = 0;
- }
- else
- lastretstr = retstr;
- while (tmps_max > tmps_base) { /* clean up after last eval */
- str_free(tmps_list[tmps_max]);
- tmps_list[tmps_max--] = Nullstr;
- }
- 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:
- {
- double value = str_gnum(STAB_STR(cmd->c_stab));
-
- match = (int)value;
- if (value < 0.0) {
- if (((double)match) > value)
- --match; /* was fractional--truncate other way */
- }
- }
- goto doswitch;
- case C_CSWITCH:
- if (multiline) {
- cmd = cmd->c_next; /* can't assume anything */
- goto tail_recursion_entry;
- }
- 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->ucmd.scmd.sc_max;
- 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 && (cmdflags & CF_TERM),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 && (cmdflags & CF_TERM),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
- match = setjmp(loop_stack[loop_ptr].loop_env);
- if (match) {
- 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 && (cmdflags & CF_TERM),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 && (cmdflags & CF_TERM),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_mortal(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 I_VARARGS
-/*VARARGS1*/
-void deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
-char *pat;
-{
- register int i;
-
- fprintf(stderr,"%-4ld",(long)curcmd->c_line);
- for (i=0; i<dlevel; i++)
- fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
- fprintf(stderr,pat,a1,a2,a3,a4,a5,a6,a7,a8);
-}
-# else
-/*VARARGS1*/
-void deb(va_alist)
-va_dcl
-{
- va_list args;
- char *pat;
- register int i;
-
- va_start(args);
- fprintf(stderr,"%-4ld",(long)curcmd->c_line);
- for (i=0; i<dlevel; i++)
- fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
-
- pat = va_arg(args, char *);
- (void) vfprintf(stderr,pat,args);
- va_end( args );
-}
-# endif
-#endif
-
-int
-copyopt(cmd,which)
-register CMD *cmd;
-register CMD *which;
-{
- cmd->c_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_ptr = Nullch;
- 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_ptr = Nullch;
- 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
-saveaptr(aptr)
-ARRAY **aptr;
-{
- register STR *str;
-
- str = Str_new(17,0);
- str->str_state = SS_SAPTR;
- str->str_u.str_array = *aptr; /* remember value */
- if (str->str_ptr) {
- Safefree(str->str_ptr);
- str->str_len = 0;
- }
- str->str_ptr = (char*)aptr; /* 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), FALSE);
- 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_SAPTR: /* ARRAY* reference */
- *((ARRAY**)value->str_ptr) = value->str_u.str_array;
- 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;
- case SS_SCSV: /* callsave structure */
- {
- CSV *csv = (CSV*) value->str_ptr;
-
- curcmd = csv->curcmd;
- curcsv = csv->curcsv;
- csv->sub->depth = csv->depth;
- if (csv->hasargs) { /* put back old @_ */
- afree(csv->argarray);
- stab_xarray(defstab) = csv->savearray;
- }
- 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
+++ /dev/null
-/* $RCSfile: cmd.h,v $$Revision: 4.0.1.2 $$Date: 92/06/08 12:01:02 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: cmd.h,v $
- * Revision 4.0.1.2 92/06/08 12:01:02 lwall
- * patch20: removed implicit int declarations on funcions
- *
- * Revision 4.0.1.1 91/06/07 10:28:50 lwall
- * patch4: new copyright notice
- * patch4: length($`), length($&), length($') now optimized to avoid string copy
- *
- * Revision 4.0 91/03/20 01:04:34 lwall
- * 4.0 baseline.
- *
- */
-
-#define C_NULL 0
-#define C_IF 1
-#define C_ELSE 2
-#define C_WHILE 3
-#define C_BLOCK 4
-#define C_EXPR 5
-#define C_NEXT 6
-#define C_ELSIF 7 /* temporary--turns into an IF + ELSE */
-#define C_CSWITCH 8 /* created by switch optimization in block_head() */
-#define C_NSWITCH 9 /* likewise */
-
-#ifdef DEBUGGING
-#ifndef DOINIT
-extern char *cmdname[];
-#else
-char *cmdname[] = {
- "NULL",
- "IF",
- "ELSE",
- "WHILE",
- "BLOCK",
- "EXPR",
- "NEXT",
- "ELSIF",
- "CSWITCH",
- "NSWITCH",
- "10"
-};
-#endif
-#endif /* DEBUGGING */
-
-#define CF_OPTIMIZE 077 /* type of optimization */
-#define CF_FIRSTNEG 0100/* conditional is ($register NE 'string') */
-#define CF_NESURE 0200 /* if short doesn't match we're sure */
-#define CF_EQSURE 0400 /* if short does match we're sure */
-#define CF_COND 01000 /* test c_expr as conditional first, if not null. */
- /* Set for everything except do {} while currently */
-#define CF_LOOP 02000 /* loop on the c_expr conditional (loop modifiers) */
-#define CF_INVERT 04000 /* it's an "unless" or an "until" */
-#define CF_ONCE 010000 /* we've already pushed the label on the stack */
-#define CF_FLIP 020000 /* on a match do flipflop */
-#define CF_TERM 040000 /* value of this cmd might be returned */
-#define CF_DBSUB 0100000 /* this is an inserted cmd for debugging */
-
-#define CFT_FALSE 0 /* c_expr is always false */
-#define CFT_TRUE 1 /* c_expr is always true */
-#define CFT_REG 2 /* c_expr is a simple register */
-#define CFT_ANCHOR 3 /* c_expr is an anchored search /^.../ */
-#define CFT_STROP 4 /* c_expr is a string comparison */
-#define CFT_SCAN 5 /* c_expr is an unanchored search /.../ */
-#define CFT_GETS 6 /* c_expr is <filehandle> */
-#define CFT_EVAL 7 /* c_expr is not optimized, so call eval() */
-#define CFT_UNFLIP 8 /* 2nd half of range not optimized */
-#define CFT_CHOP 9 /* c_expr is a chop on a register */
-#define CFT_ARRAY 10 /* this is a foreach loop */
-#define CFT_INDGETS 11 /* c_expr is <$variable> */
-#define CFT_NUMOP 12 /* c_expr is a numeric comparison */
-#define CFT_CCLASS 13 /* c_expr must start with one of these characters */
-#define CFT_D0 14 /* no special breakpoint at this line */
-#define CFT_D1 15 /* possible special breakpoint at this line */
-
-#ifdef DEBUGGING
-#ifndef DOINIT
-extern char *cmdopt[];
-#else
-char *cmdopt[] = {
- "FALSE",
- "TRUE",
- "REG",
- "ANCHOR",
- "STROP",
- "SCAN",
- "GETS",
- "EVAL",
- "UNFLIP",
- "CHOP",
- "ARRAY",
- "INDGETS",
- "NUMOP",
- "CCLASS",
- "14"
-};
-#endif
-#endif /* DEBUGGING */
-
-struct acmd {
- STAB *ac_stab; /* a symbol table entry */
- ARG *ac_expr; /* any associated expression */
-};
-
-struct ccmd {
- CMD *cc_true; /* normal code to do on if and while */
- CMD *cc_alt; /* else cmd ptr or continue code */
-};
-
-struct scmd {
- CMD **sc_next; /* array of pointers to commands */
- short sc_offset; /* first value - 1 */
- short sc_max; /* last value + 1 */
-};
-
-struct cmd {
- CMD *c_next; /* the next command at this level */
- ARG *c_expr; /* conditional expression */
- CMD *c_head; /* head of this command list */
- STR *c_short; /* string to match as shortcut */
- STAB *c_stab; /* a symbol table entry, mostly for fp */
- SPAT *c_spat; /* pattern used by optimization */
- char *c_label; /* label for this construct */
- union ucmd {
- struct acmd acmd; /* normal command */
- struct ccmd ccmd; /* compound command */
- struct scmd scmd; /* switch command */
- } ucmd;
- short c_slen; /* len of c_short, if not null */
- VOLATILE short c_flags; /* optimization flags--see above */
- HASH *c_stash; /* package line was compiled in */
- STAB *c_filestab; /* file the following line # is from */
- line_t c_line; /* line # of this command */
- char c_type; /* what this command does */
-};
-
-#define Nullcmd Null(CMD*)
-#define Nullcsv Null(CSV*)
-
-EXT CMD * VOLATILE main_root INIT(Nullcmd);
-EXT CMD * VOLATILE eval_root INIT(Nullcmd);
-
-EXT CMD compiling;
-EXT CMD * VOLATILE curcmd INIT(&compiling);
-EXT CSV * VOLATILE curcsv INIT(Nullcsv);
-
-struct callsave {
- SUBR *sub;
- STAB *stab;
- CSV *curcsv;
- CMD *curcmd;
- ARRAY *savearray;
- ARRAY *argarray;
- long depth;
- int wantarray;
- char hasargs;
-};
-
-struct compcmd {
- CMD *comp_true;
- CMD *comp_alt;
-};
-
-void opt_arg();
-ARG* evalstatic();
-int cmd_exec();
-#ifdef DEBUGGING
-void deb();
-#endif
-int copyopt();
--- /dev/null
+#ifndef config_h
+#define config_h
+/* config.h
+ * This file was produced by running the config.h.SH script, which
+ * gets its values from config.sh, which is generally produced by
+ * running Configure.
+ *
+ * Feel free to modify any of this as the need arises. Note, however,
+ * that running config.h.SH again will wipe out any changes you've made.
+ * For a more permanent change edit config.sh and rerun config.h.SH.
+ */
+ /*SUPPRESS 460*/
+
+
+/* EUNICE
+ * This symbol, if defined, indicates that the program is being compiled
+ * under the EUNICE package under VMS. The program will need to handle
+ * things like files that don't go away the first time you unlink them,
+ * due to version numbering. It will also need to compensate for lack
+ * of a respectable link() command.
+ */
+/* VMS
+ * This symbol, if defined, indicates that the program is running under
+ * VMS. It is currently only set in conjunction with the EUNICE symbol.
+ */
+/*#undef EUNICE /**/
+/*#undef VMS /**/
+
+/* LOC_SED
+ * This symbol holds the complete pathname to the sed program.
+ */
+#define LOC_SED "/bin/sed" /**/
+
+/* ALIGNBYTES
+ * This symbol contains the number of bytes required to align a double.
+ * Usual values are 2, 4, and 8.
+ */
+#define ALIGNBYTES 8 /**/
+
+/* BIN
+ * This symbol holds the name of the directory in which the user wants
+ * to keep publicly executable images for the package in question. It
+ * is most often a local directory such as /usr/local/bin.
+ */
+#define BIN "/usr/local/bin" /**/
+
+/* BYTEORDER
+ * This symbol contains an encoding of the order of bytes in a long.
+ * Usual values (in hex) are 0x1234, 0x4321, 0x2143, 0x3412...
+ */
+#define BYTEORDER 0x4321 /**/
+
+/* CPPSTDIN
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp".
+ */
+/* CPPMINUS
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+#define CPPSTDIN "/usr/lib/cpp"
+#define CPPMINUS ""
+
+/* HAS_BCMP
+ * This symbol, if defined, indicates that the bcmp routine is available
+ * to compare blocks of memory. If undefined, use memcmp. If that's
+ * not available, roll your own.
+ */
+#define HAS_BCMP /**/
+
+/* HAS_BCOPY
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy blocks of memory. Otherwise you should probably use memcpy().
+ * If neither is defined, roll your own.
+ */
+/* SAFE_BCOPY
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping copy blocks of bcopy. Otherwise you
+ * should probably use memmove() or memcpy(). If neither is defined,
+ * roll your own.
+ */
+#define HAS_BCOPY /**/
+#define SAFE_BCOPY /**/
+
+/* HAS_BZERO
+ * This symbol, if defined, indicates that the bzero routine is available
+ * to zero blocks of memory. Otherwise you should probably use memset()
+ * or roll your own.
+ */
+#define HAS_BZERO /**/
+
+/* CASTNEGFLOAT
+ * This symbol, if defined, indicates that this C compiler knows how to
+ * cast negative or large floating point numbers to unsigned longs, ints
+ * and shorts.
+ */
+/* CASTFLAGS
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ */
+#define CASTNEGFLOAT /**/
+#define CASTFLAGS 0 /**/
+
+/* CHARSPRINTF
+ * This symbol is defined if this system declares "char *sprintf()" in
+ * stdio.h. The trend seems to be to declare it as "int sprintf()". It
+ * is up to the package author to declare sprintf correctly based on the
+ * symbol.
+ */
+#define CHARSPRINTF /**/
+
+/* HAS_CHSIZE
+ * This symbol, if defined, indicates that the chsize routine is available
+ * to truncate files. You might need a -lx to get this routine.
+ */
+/*#undef HAS_CHSIZE /**/
+
+/* HAS_CRYPT
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+#define HAS_CRYPT /**/
+
+/* CSH
+ * This symbol, if defined, indicates that the C-shell exists.
+ * If defined, contains the full pathname of csh.
+ */
+#define CSH "/bin/csh" /**/
+
+/* DOSUID
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+/*#undef DOSUID /**/
+
+/* HAS_DUP2
+ * This symbol, if defined, indicates that the dup2 routine is available
+ * to dup file descriptors. Otherwise you should use dup().
+ */
+#define HAS_DUP2 /**/
+
+/* HAS_FCHMOD
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+#define HAS_FCHMOD /**/
+
+/* HAS_FCHOWN
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+#define HAS_FCHOWN /**/
+
+/* HAS_FCNTL
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
+ */
+#define HAS_FCNTL /**/
+
+/* FLEXFILENAMES
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+#define FLEXFILENAMES /**/
+
+/* HAS_FLOCK
+ * This symbol, if defined, indicates that the flock() routine is
+ * available to do file locking.
+ */
+#define HAS_FLOCK /**/
+
+/* HAS_GETGROUPS
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+#define HAS_GETGROUPS /**/
+
+/* HAS_GETHOSTENT
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to lookup host names in some data base or other.
+ */
+/*#undef HAS_GETHOSTENT /**/
+
+/* HAS_GETPGRP
+ * This symbol, if defined, indicates that the getpgrp() routine is
+ * available to get the current process group.
+ */
+#define HAS_GETPGRP /**/
+
+/* HAS_GETPGRP2
+ * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
+ * routine is available to get the current process group.
+ */
+/*#undef HAS_GETPGRP2 /**/
+
+/* HAS_GETPRIORITY
+ * This symbol, if defined, indicates that the getpriority() routine is
+ * available to get a process's priority.
+ */
+#define HAS_GETPRIORITY /**/
+
+/* HAS_HTONS
+ * This symbol, if defined, indicates that the htons routine (and friends)
+ * are available to do network order byte swapping.
+ */
+/* HAS_HTONL
+ * This symbol, if defined, indicates that the htonl routine (and friends)
+ * are available to do network order byte swapping.
+ */
+/* HAS_NTOHS
+ * This symbol, if defined, indicates that the ntohs routine (and friends)
+ * are available to do network order byte swapping.
+ */
+/* HAS_NTOHL
+ * This symbol, if defined, indicates that the ntohl routine (and friends)
+ * are available to do network order byte swapping.
+ */
+#define HAS_HTONS /**/
+#define HAS_HTONL /**/
+#define HAS_NTOHS /**/
+#define HAS_NTOHL /**/
+
+/* index
+ * This preprocessor symbol is defined, along with rindex, if the system
+ * uses the strchr and strrchr routines instead.
+ */
+/* rindex
+ * This preprocessor symbol is defined, along with index, if the system
+ * uses the strchr and strrchr routines instead.
+ */
+/*#undef index strchr /* cultural */
+/*#undef rindex strrchr /* differences? */
+
+/* HAS_ISASCII
+ * This symbol, if defined, indicates that the isascii routine is available
+ * to test characters for asciiness.
+ */
+#define HAS_ISASCII /**/
+
+/* HAS_KILLPG
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+#define HAS_KILLPG /**/
+
+/* HAS_LSTAT
+ * This symbol, if defined, indicates that the lstat() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_LSTAT /**/
+
+/* HAS_MEMCMP
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * to compare blocks of memory. If undefined, roll your own.
+ */
+#define HAS_MEMCMP /**/
+
+/* HAS_MEMCPY
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy blocks of memory. Otherwise you should probably use bcopy().
+ * If neither is defined, roll your own.
+ */
+/* SAFE_MEMCPY
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping copy blocks of memory. Otherwise you
+ * should probably use memmove() or bcopy(). If neither is defined,
+ * roll your own.
+ */
+#define HAS_MEMCPY /**/
+/*#undef SAFE_MEMCPY /**/
+
+/* HAS_MEMMOVE
+ * This symbol, if defined, indicates that the memmove routine is available
+ * to move potentially overlapping blocks of memory. Otherwise you
+ * should use bcopy() or roll your own.
+ */
+/*#undef HAS_MEMMOVE /**/
+
+/* HAS_MEMSET
+ * This symbol, if defined, indicates that the memset routine is available
+ * to set a block of memory to a character. If undefined, roll your own.
+ */
+#define HAS_MEMSET /**/
+
+/* HAS_MKDIR
+ * This symbol, if defined, indicates that the mkdir routine is available
+ * to create directories. Otherwise you should fork off a new process to
+ * exec /bin/mkdir.
+ */
+#define HAS_MKDIR /**/
+
+/* HAS_MSG
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported.
+ */
+#define HAS_MSG /**/
+
+/* HAS_MSGCTL
+ * This symbol, if defined, indicates that the msgctl() routine is
+ * available to control message passing.
+ */
+#define HAS_MSGCTL /**/
+
+/* HAS_MSGGET
+ * This symbol, if defined, indicates that the msgget() routine is
+ * available to get messages.
+ */
+#define HAS_MSGGET /**/
+
+/* HAS_MSGRCV
+ * This symbol, if defined, indicates that the msgrcv() routine is
+ * available to receive messages.
+ */
+#define HAS_MSGRCV /**/
+
+/* HAS_MSGSND
+ * This symbol, if defined, indicates that the msgsnd() routine is
+ * available to send messages.
+ */
+#define HAS_MSGSND /**/
+
+/* HAS_NDBM
+ * This symbol, if defined, indicates that ndbm.h exists and should
+ * be included.
+ */
+#define HAS_NDBM /**/
+
+/* HAS_ODBM
+ * This symbol, if defined, indicates that dbm.h exists and should
+ * be included.
+ */
+#define HAS_ODBM /**/
+
+/* HAS_OPEN3
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+#define HAS_OPEN3 /**/
+
+/* HAS_READDIR
+ * This symbol, if defined, indicates that the readdir routine is available
+ * from the C library to read directories.
+ */
+#define HAS_READDIR /**/
+
+/* HAS_RENAME
+ * This symbol, if defined, indicates that the rename routine is available
+ * to rename files. Otherwise you should do the unlink(), link(), unlink()
+ * trick.
+ */
+#define HAS_RENAME /**/
+
+/* HAS_REWINDDIR
+ * This symbol, if defined, indicates that the rewindir routine is
+ * available to rewind directories.
+ */
+/*#undef HAS_REWINDDIR /**/
+
+/* HAS_RMDIR
+ * This symbol, if defined, indicates that the rmdir routine is available
+ * to remove directories. Otherwise you should fork off a new process to
+ * exec /bin/rmdir.
+ */
+#define HAS_RMDIR /**/
+
+/* HAS_SEEKDIR
+ * This symbol, if defined, indicates that the seekdir routine is
+ * available to seek into directories.
+ */
+#define HAS_SEEKDIR /**/
+
+/* HAS_SELECT
+ * This symbol, if defined, indicates that the select() subroutine
+ * exists.
+ */
+#define HAS_SELECT /**/
+
+/* HAS_SEM
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+#define HAS_SEM /**/
+
+/* HAS_SEMCTL
+ * This symbol, if defined, indicates that the semctl() routine is
+ * available to control semaphores.
+ */
+#define HAS_SEMCTL /**/
+
+/* HAS_SEMGET
+ * This symbol, if defined, indicates that the semget() routine is
+ * available to get semaphores ids.
+ */
+#define HAS_SEMGET /**/
+
+/* HAS_SEMOP
+ * This symbol, if defined, indicates that the semop() routine is
+ * available to perform semaphore operations.
+ */
+#define HAS_SEMOP /**/
+
+/* HAS_SETEGID
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+#define HAS_SETEGID /**/
+
+/* HAS_SETEUID
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+#define HAS_SETEUID /**/
+
+/* HAS_SETPGRP
+ * This symbol, if defined, indicates that the setpgrp() routine is
+ * available to set the current process group.
+ */
+#define HAS_SETPGRP /**/
+
+/* HAS_SETPGRP2
+ * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
+ * routine is available to set the current process group.
+ */
+/*#undef HAS_SETPGRP2 /**/
+
+/* HAS_SETPRIORITY
+ * This symbol, if defined, indicates that the setpriority() routine is
+ * available to set a process's priority.
+ */
+#define HAS_SETPRIORITY /**/
+
+/* HAS_SETREGID
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current program.
+ */
+/* HAS_SETRESGID
+ * This symbol, if defined, indicates that the setresgid routine is
+ * available to change the real, effective and saved gid of the current
+ * program.
+ */
+#define HAS_SETREGID /**/
+/*#undef HAS_SETRESGID /**/
+
+/* HAS_SETREUID
+ * This symbol, if defined, indicates that the setreuid routine is
+ * available to change the real and effective uid of the current program.
+ */
+/* HAS_SETRESUID
+ * This symbol, if defined, indicates that the setresuid routine is
+ * available to change the real, effective and saved uid of the current
+ * program.
+ */
+#define HAS_SETREUID /**/
+/*#undef HAS_SETRESUID /**/
+
+/* HAS_SETRGID
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+#define HAS_SETRGID /**/
+
+/* HAS_SETRUID
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+#define HAS_SETRUID /**/
+
+/* HAS_SHM
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+#define HAS_SHM /**/
+
+/* HAS_SHMAT
+ * This symbol, if defined, indicates that the shmat() routine is
+ * available to attach a shared memory segment.
+ */
+/* VOID_SHMAT
+ * This symbol, if defined, indicates that the shmat() routine
+ * returns a pointer of type void*.
+ */
+#define HAS_SHMAT /**/
+
+/*#undef VOIDSHMAT /**/
+
+/* HAS_SHMCTL
+ * This symbol, if defined, indicates that the shmctl() routine is
+ * available to control a shared memory segment.
+ */
+#define HAS_SHMCTL /**/
+
+/* HAS_SHMDT
+ * This symbol, if defined, indicates that the shmdt() routine is
+ * available to detach a shared memory segment.
+ */
+#define HAS_SHMDT /**/
+
+/* HAS_SHMGET
+ * This symbol, if defined, indicates that the shmget() routine is
+ * available to get a shared memory segment id.
+ */
+#define HAS_SHMGET /**/
+
+/* HAS_SOCKET
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+/* HAS_SOCKETPAIR
+ * This symbol, if defined, indicates that the BSD socketpair call is
+ * supported.
+ */
+/* OLDSOCKET
+ * This symbol, if defined, indicates that the 4.1c BSD socket interface
+ * is supported instead of the 4.2/4.3 BSD socket interface.
+ */
+#define HAS_SOCKET /**/
+
+#define HAS_SOCKETPAIR /**/
+
+/*#undef OLDSOCKET /**/
+
+/* STATBLOCKS
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+#define STATBLOCKS /**/
+
+/* STDSTDIO
+ * This symbol is defined if this system has a FILE structure declaring
+ * _ptr and _cnt in stdio.h.
+ */
+#define STDSTDIO /**/
+
+/* STRUCTCOPY
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+#define STRUCTCOPY /**/
+
+/* HAS_STRERROR
+ * This symbol, if defined, indicates that the strerror() routine is
+ * available to translate error numbers to strings.
+ */
+/*#undef HAS_STRERROR /**/
+
+/* HAS_SYMLINK
+ * This symbol, if defined, indicates that the symlink routine is available
+ * to create symbolic links.
+ */
+#define HAS_SYMLINK /**/
+
+/* HAS_SYSCALL
+ * This symbol, if defined, indicates that the syscall routine is available
+ * to call arbitrary system calls. If undefined, that's tough.
+ */
+#define HAS_SYSCALL /**/
+
+/* HAS_TELLDIR
+ * This symbol, if defined, indicates that the telldir routine is
+ * available to tell your location in directories.
+ */
+#define HAS_TELLDIR /**/
+
+/* HAS_TRUNCATE
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+#define HAS_TRUNCATE /**/
+
+/* HAS_VFORK
+ * This symbol, if defined, indicates that vfork() exists.
+ */
+#define HAS_VFORK /**/
+
+/* VOIDSIG
+ * This symbol is defined if this system declares "void (*signal())()" in
+ * signal.h. The old way was to declare it as "int (*signal())()". It
+ * is up to the package author to declare things correctly based on the
+ * symbol.
+ */
+/* TO_SIGNAL
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return "type" of a signal handler. Thus, one can declare
+ * a signal handler using "TO_SIGNAL (*handler())()", and define the
+ * handler using "TO_SIGNAL handler(sig)".
+ */
+#define VOIDSIG /**/
+#define TO_SIGNAL int /**/
+
+/* HASVOLATILE
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+/*#undef HASVOLATILE /**/
+
+/* HAS_VPRINTF
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* CHARVSPRINTF
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#define HAS_VPRINTF /**/
+#define CHARVSPRINTF /**/
+
+/* HAS_WAIT4
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+#define HAS_WAIT4 /**/
+
+/* HAS_WAITPID
+ * This symbol, if defined, indicates that waitpid() exists.
+ */
+#define HAS_WAITPID /**/
+
+/* GIDTYPE
+ * This symbol has a value like gid_t, int, ushort, or whatever type is
+ * used to declare group ids in the kernel.
+ */
+#define GIDTYPE gid_t /**/
+
+/* GROUPSTYPE
+ * This symbol has a value like gid_t, int, ushort, or whatever type is
+ * used in the return value of getgroups().
+ */
+#define GROUPSTYPE int /**/
+
+/* I_FCNTL
+ * This manifest constant tells the C program to include <fcntl.h>.
+ */
+/*#undef I_FCNTL /**/
+
+/* I_GDBM
+ * This symbol, if defined, indicates that gdbm.h exists and should
+ * be included.
+ */
+/*#undef I_GDBM /**/
+
+/* I_GRP
+ * This symbol, if defined, indicates to the C program that it should
+ * include grp.h.
+ */
+#define I_GRP /**/
+
+/* I_NETINET_IN
+ * This symbol, if defined, indicates to the C program that it should
+ * include netinet/in.h.
+ */
+/* I_SYS_IN
+ * This symbol, if defined, indicates to the C program that it should
+ * include sys/in.h.
+ */
+#define I_NETINET_IN /**/
+/*#undef I_SYS_IN /**/
+
+/* I_PWD
+ * This symbol, if defined, indicates to the C program that it should
+ * include pwd.h.
+ */
+/* PWQUOTA
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_quota.
+ */
+/* PWAGE
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_age.
+ */
+/* PWCHANGE
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_change.
+ */
+/* PWCLASS
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_class.
+ */
+/* PWEXPIRE
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_expire.
+ */
+/* PWCOMMENT
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_comment.
+ */
+#define I_PWD /**/
+/*#undef PWQUOTA /**/
+#define PWAGE /**/
+/*#undef PWCHANGE /**/
+/*#undef PWCLASS /**/
+/*#undef PWEXPIRE /**/
+#define PWCOMMENT /**/
+
+/* I_SYS_FILE
+ * This manifest constant tells the C program to include <sys/file.h>.
+ */
+#define I_SYS_FILE /**/
+
+/* I_SYSIOCTL
+ * This symbol, if defined, indicates that sys/ioctl.h exists and should
+ * be included.
+ */
+#define I_SYSIOCTL /**/
+
+/* I_TIME
+ * This symbol is defined if the program should include <time.h>.
+ */
+/* I_SYS_TIME
+ * This symbol is defined if the program should include <sys/time.h>.
+ */
+/* SYSTIMEKERNEL
+ * This symbol is defined if the program should include <sys/time.h>
+ * with KERNEL defined.
+ */
+/* I_SYS_SELECT
+ * This symbol is defined if the program should include <sys/select.h>.
+ */
+/*#undef I_TIME /**/
+#define I_SYS_TIME /**/
+/*#undef SYSTIMEKERNEL /**/
+/*#undef I_SYS_SELECT /**/
+
+/* I_UTIME
+ * This symbol, if defined, indicates to the C program that it should
+ * include utime.h.
+ */
+#define I_UTIME /**/
+
+/* I_VARARGS
+ * This symbol, if defined, indicates to the C program that it should
+ * include varargs.h.
+ */
+#define I_VARARGS /**/
+
+/* I_VFORK
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+#define I_VFORK /**/
+
+/* INTSIZE
+ * This symbol contains the size of an int, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define INTSIZE 4 /**/
+
+/* I_DIRENT
+ * This symbol, if defined, indicates that the program should use the
+ * P1003-style directory routines, and include <dirent.h>.
+ */
+/* I_SYS_DIR
+ * This symbol, if defined, indicates that the program should use the
+ * directory functions by including <sys/dir.h>.
+ */
+/* I_NDIR
+ * This symbol, if defined, indicates that the program should include the
+ * system's version of ndir.h, rather than the one with this package.
+ */
+/* I_SYS_NDIR
+ * This symbol, if defined, indicates that the program should include the
+ * system's version of sys/ndir.h, rather than the one with this package.
+ */
+/* I_MY_DIR
+ * This symbol, if defined, indicates that the program should compile
+ * the ndir.c code provided with the package.
+ */
+/* DIRNAMLEN
+ * This symbol, if defined, indicates to the C program that the length
+ * of directory entry names is provided by a d_namlen field. Otherwise
+ * you need to do strlen() on the d_name field.
+ */
+#define I_DIRENT /**/
+/*#undef I_SYS_DIR /**/
+/*#undef I_NDIR /**/
+/*#undef I_SYS_NDIR /**/
+/*#undef I_MY_DIR /**/
+/*#undef DIRNAMLEN /**/
+
+/* MYMALLOC
+ * This symbol, if defined, indicates that we're using our own malloc.
+ */
+/* MALLOCPTRTYPE
+ * This symbol defines the kind of ptr returned by malloc and realloc.
+ */
+#define MYMALLOC /**/
+
+#define MALLOCPTRTYPE char /**/
+
+
+/* RANDBITS
+ * This symbol contains the number of bits of random number the rand()
+ * function produces. Usual values are 15, 16, and 31.
+ */
+#define RANDBITS 31 /**/
+
+/* SCRIPTDIR
+ * This symbol holds the name of the directory in which the user wants
+ * to keep publicly executable scripts for the package in question. It
+ * is often a directory that is mounted across diverse architectures.
+ */
+#define SCRIPTDIR "/usr/local/bin" /**/
+
+/* SIG_NAME
+ * This symbol contains an list of signal names in order.
+ */
+#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","LOST","USR1","USR2" /**/
+
+/* STDCHAR
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+#define STDCHAR unsigned char /**/
+
+/* UIDTYPE
+ * This symbol has a value like uid_t, int, ushort, or whatever type is
+ * used to declare user ids in the kernel.
+ */
+#define UIDTYPE uid_t /**/
+
+/* VOIDHAVE
+ * This symbol indicates how much support of the void type is given by this
+ * compiler. What various bits mean:
+ *
+ * 1 = supports declaration of void
+ * 2 = supports arrays of pointers to functions returning void
+ * 4 = supports comparisons between pointers to void functions and
+ * addresses of void functions
+ *
+ * The package designer should define VOIDWANT to indicate the requirements
+ * of the package. This can be done either by #defining VOIDWANT before
+ * including config.h, or by defining voidwant in Myinit.U. If the level
+ * of void support necessary is not present, config.h defines void to "int",
+ * VOID to the empty string, and VOIDP to "char *".
+ */
+/* void
+ * This symbol is used for void casts. On implementations which support
+ * void appropriately, its value is "void". Otherwise, its value maps
+ * to "int".
+ */
+/* VOID
+ * This symbol's value is "void" if the implementation supports void
+ * appropriately. Otherwise, its value is the empty string. The primary
+ * use of this symbol is in specifying void parameter lists for function
+ * prototypes.
+ */
+/* VOIDP
+ * This symbol is used for casting generic pointers. On implementations
+ * which support void appropriately, its value is "void *". Otherwise,
+ * its value is "char *".
+ */
+#ifndef VOIDWANT
+#define VOIDWANT 7
+#endif
+#define VOIDHAVE 7
+#if (VOIDHAVE & VOIDWANT) != VOIDWANT
+#define void int /* is void to be avoided? */
+#define VOID
+#define VOIDP (char *)
+#define M_VOID /* Xenix strikes again */
+#else
+#define VOID void
+#define VOIDP (void *)
+#endif
+
+/* PRIVLIB
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ */
+#define PRIVLIB "/usr/local/lib/perl" /**/
+
+#endif
--- /dev/null
+#!/bin/sh
+# config.sh
+# This file was produced by running the Configure script.
+d_eunice='undef'
+define='define'
+eunicefix=':'
+loclist='
+cat
+cp
+echo
+expr
+grep
+mkdir
+mv
+rm
+sed
+sort
+tr
+uniq
+'
+expr='/bin/expr'
+sed='/bin/sed'
+echo='/bin/echo'
+cat='/bin/cat'
+rm='/bin/rm'
+mv='/bin/mv'
+cp='/bin/cp'
+tail=''
+tr='/bin/tr'
+mkdir='/bin/mkdir'
+sort='/bin/sort'
+uniq='/bin/uniq'
+grep='/bin/grep'
+trylist='
+Mcc
+bison
+cpp
+csh
+egrep
+line
+nroff
+perl
+test
+uname
+yacc
+'
+test='test'
+inews=''
+egrep='/bin/egrep'
+more=''
+pg=''
+Mcc='Mcc'
+vi=''
+mailx=''
+mail=''
+cpp='/usr/lib/cpp'
+perl='/home/netlabs1/lwall/pl/perl'
+emacs=''
+ls=''
+rmail=''
+sendmail=''
+shar=''
+smail=''
+tbl=''
+troff=''
+nroff='/bin/nroff'
+uname='/bin/uname'
+uuname=''
+line='/bin/line'
+chgrp=''
+chmod=''
+lint=''
+sleep=''
+pr=''
+tar=''
+ln=''
+lpr=''
+lp=''
+touch=''
+make=''
+date=''
+csh='/bin/csh'
+bash=''
+ksh=''
+lex=''
+flex=''
+bison='/usr/local/bin/bison'
+Log='$Log'
+Header='$Header'
+Id='$Id'
+lastuname='SunOS scalpel 4.1.2 1 sun4c'
+alignbytes='8'
+bin='/usr/local/bin'
+installbin='/usr/local/bin'
+byteorder='4321'
+contains='grep'
+cppstdin='/usr/lib/cpp'
+cppminus=''
+d_bcmp='define'
+d_bcopy='define'
+d_safebcpy='define'
+d_bzero='define'
+d_castneg='define'
+castflags='0'
+d_charsprf='define'
+d_chsize='undef'
+d_crypt='define'
+cryptlib=''
+d_csh='define'
+d_dosuid='undef'
+d_dup2='define'
+d_fchmod='define'
+d_fchown='define'
+d_fcntl='define'
+d_flexfnam='define'
+d_flock='define'
+d_getgrps='define'
+d_gethent='undef'
+d_getpgrp='define'
+d_getpgrp2='undef'
+d_getprior='define'
+d_htonl='define'
+d_index='undef'
+d_isascii='define'
+d_killpg='define'
+d_lstat='define'
+d_memcmp='define'
+d_memcpy='define'
+d_safemcpy='undef'
+d_memmove='undef'
+d_memset='define'
+d_mkdir='define'
+d_msg='define'
+d_msgctl='define'
+d_msgget='define'
+d_msgrcv='define'
+d_msgsnd='define'
+d_ndbm='define'
+d_odbm='define'
+d_open3='define'
+d_readdir='define'
+d_rename='define'
+d_rewindir='undef'
+d_rmdir='define'
+d_seekdir='define'
+d_select='define'
+d_sem='define'
+d_semctl='define'
+d_semget='define'
+d_semop='define'
+d_setegid='define'
+d_seteuid='define'
+d_setpgrp='define'
+d_setpgrp2='undef'
+d_setprior='define'
+d_setregid='define'
+d_setresgid='undef'
+d_setreuid='define'
+d_setresuid='undef'
+d_setrgid='define'
+d_setruid='define'
+d_shm='define'
+d_shmat='define'
+d_voidshmat='undef'
+d_shmctl='define'
+d_shmdt='define'
+d_shmget='define'
+d_socket='define'
+d_sockpair='define'
+d_oldsock='undef'
+socketlib=''
+d_statblks='define'
+d_stdstdio='define'
+d_strctcpy='define'
+d_strerror='undef'
+d_symlink='define'
+d_syscall='define'
+d_telldir='define'
+d_truncate='define'
+d_vfork='define'
+d_voidsig='define'
+d_tosignal='int'
+d_volatile='undef'
+d_vprintf='define'
+d_charvspr='define'
+d_wait4='define'
+d_waitpid='define'
+gidtype='gid_t'
+groupstype='int'
+i_fcntl='undef'
+i_gdbm='undef'
+i_grp='define'
+i_niin='define'
+i_sysin='undef'
+i_pwd='define'
+d_pwquota='undef'
+d_pwage='define'
+d_pwchange='undef'
+d_pwclass='undef'
+d_pwexpire='undef'
+d_pwcomment='define'
+i_sys_file='define'
+i_sysioctl='define'
+i_time='undef'
+i_sys_time='define'
+i_sys_select='undef'
+d_systimekernel='undef'
+i_utime='define'
+i_varargs='define'
+i_vfork='define'
+intsize='4'
+libc='/usr/lib/libc.so.1.7'
+nm_opts=''
+libndir=''
+i_my_dir='undef'
+i_ndir='undef'
+i_sys_ndir='undef'
+i_dirent='define'
+i_sys_dir='undef'
+d_dirnamlen='undef'
+ndirc=''
+ndiro=''
+mallocsrc='malloc.c'
+mallocobj='malloc.o'
+d_mymalloc='define'
+mallocptrtype='char'
+mansrc='/usr/man/manl'
+manext='l'
+models='none'
+split=''
+small=''
+medium=''
+large=''
+huge=''
+optimize='-g'
+ccflags=' -I/usr/include/sun -I/usr/ucbinclude -DDEBUGGING'
+cppflags=' -I/usr/include/sun -I/usr/ucbinclude -DDEBUGGING'
+ldflags=''
+cc='cc'
+nativegcc=''
+libs='-ldbm -lm -lposix'
+n='-n'
+c=''
+package='perl'
+randbits='31'
+scriptdir='/usr/local/bin'
+installscr='/usr/local/bin'
+sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH LOST USR1 USR2'
+spitshell='cat'
+shsharp='true'
+sharpbang='#!'
+startsh='#!/bin/sh'
+stdchar='unsigned char'
+uidtype='uid_t'
+usrinclude='/usr/include'
+inclPath=''
+void=''
+voidhave='7'
+voidwant='7'
+w_localtim='1'
+w_s_timevl='1'
+w_s_tm='1'
+yacc='/bin/yacc'
+lib=''
+privlib='/usr/local/lib/perl'
+installprivlib='/usr/local/lib/perl'
+PATCHLEVEL=34
+CONFIG=true
--- /dev/null
+#ifndef config_h
+#define config_h
+/* config.h
+ * This file was produced by running the config.h.SH script, which
+ * gets its values from config.sh, which is generally produced by
+ * running Configure.
+ *
+ * Feel free to modify any of this as the need arises. Note, however,
+ * that running config.h.SH again will wipe out any changes you've made.
+ * For a more permanent change edit config.sh and rerun config.h.SH.
+ */
+ /*SUPPRESS 460*/
+
+
+/* EUNICE
+ * This symbol, if defined, indicates that the program is being compiled
+ * under the EUNICE package under VMS. The program will need to handle
+ * things like files that don't go away the first time you unlink them,
+ * due to version numbering. It will also need to compensate for lack
+ * of a respectable link() command.
+ */
+/* VMS
+ * This symbol, if defined, indicates that the program is running under
+ * VMS. It is currently only set in conjunction with the EUNICE symbol.
+ */
+/*#undef EUNICE */
+/*#undef VMS */
+
+/* LOC_SED
+ * This symbol holds the complete pathname to the sed program.
+ */
+#define LOC_SED "/bin/sed" /**/
+
+/* ALIGNBYTES
+ * This symbol contains the number of bytes required to align a double.
+ * Usual values are 2, 4, and 8.
+ */
+#define ALIGNBYTES 8 /**/
+
+/* BIN
+ * This symbol holds the name of the directory in which the user wants
+ * to keep publicly executable images for the package in question. It
+ * is most often a local directory such as /usr/local/bin.
+ */
+#define BIN "/usr/local/bin" /**/
+
+/* BYTEORDER
+ * This symbol contains an encoding of the order of bytes in a long.
+ * Usual values (in hex) are 0x1234, 0x4321, 0x2143, 0x3412...
+ */
+#define BYTEORDER 0x4321 /**/
+
+/* CPPSTDIN
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp".
+ */
+/* CPPMINUS
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+#define CPPSTDIN "/usr/lib/cpp"
+#define CPPMINUS ""
+
+/* HAS_BCMP
+ * This symbol, if defined, indicates that the bcmp routine is available
+ * to compare blocks of memory. If undefined, use memcmp. If that's
+ * not available, roll your own.
+ */
+#define HAS_BCMP /**/
+
+/* HAS_BCOPY
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy blocks of memory. Otherwise you should probably use memcpy().
+ * If neither is defined, roll your own.
+ */
+/* SAFE_BCOPY
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping copy blocks of bcopy. Otherwise you
+ * should probably use memmove() or memcpy(). If neither is defined,
+ * roll your own.
+ */
+#define HAS_BCOPY /**/
+#define SAFE_BCOPY /**/
+
+/* HAS_BZERO
+ * This symbol, if defined, indicates that the bzero routine is available
+ * to zero blocks of memory. Otherwise you should probably use memset()
+ * or roll your own.
+ */
+#define HAS_BZERO /**/
+
+/* CASTNEGFLOAT
+ * This symbol, if defined, indicates that this C compiler knows how to
+ * cast negative or large floating point numbers to unsigned longs, ints
+ * and shorts.
+ */
+/* CASTFLAGS
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ */
+#define CASTNEGFLOAT /**/
+#define CASTFLAGS 0 /**/
+
+/* CHARSPRINTF
+ * This symbol is defined if this system declares "char *sprintf()" in
+ * stdio.h. The trend seems to be to declare it as "int sprintf()". It
+ * is up to the package author to declare sprintf correctly based on the
+ * symbol.
+ */
+#define CHARSPRINTF /**/
+
+/* HAS_CHSIZE
+ * This symbol, if defined, indicates that the chsize routine is available
+ * to truncate files. You might need a -lx to get this routine.
+ */
+/*#undef HAS_CHSIZE */
+
+/* HAS_CRYPT
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+#define HAS_CRYPT /**/
+
+/* CSH
+ * This symbol, if defined, indicates that the C-shell exists.
+ * If defined, contains the full pathname of csh.
+ */
+#define CSH "/bin/csh" /**/
+
+/* DOSUID
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+/*#undef DOSUID */
+
+/* HAS_DUP2
+ * This symbol, if defined, indicates that the dup2 routine is available
+ * to dup file descriptors. Otherwise you should use dup().
+ */
+#define HAS_DUP2 /**/
+
+/* HAS_FCHMOD
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+#define HAS_FCHMOD /**/
+
+/* HAS_FCHOWN
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+#define HAS_FCHOWN /**/
+
+/* HAS_FCNTL
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
+ */
+#define HAS_FCNTL /**/
+
+/* FLEXFILENAMES
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+#define FLEXFILENAMES /**/
+
+/* HAS_FLOCK
+ * This symbol, if defined, indicates that the flock() routine is
+ * available to do file locking.
+ */
+#define HAS_FLOCK /**/
+
+/* HAS_GETGROUPS
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+#define HAS_GETGROUPS /**/
+
+/* HAS_GETHOSTENT
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to lookup host names in some data base or other.
+ */
+/*#undef HAS_GETHOSTENT */
+
+/* HAS_GETPGRP
+ * This symbol, if defined, indicates that the getpgrp() routine is
+ * available to get the current process group.
+ */
+#define HAS_GETPGRP /**/
+
+/* HAS_GETPGRP2
+ * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
+ * routine is available to get the current process group.
+ */
+/*#undef HAS_GETPGRP2 */
+
+/* HAS_GETPRIORITY
+ * This symbol, if defined, indicates that the getpriority() routine is
+ * available to get a process's priority.
+ */
+#define HAS_GETPRIORITY /**/
+
+/* HAS_HTONS
+ * This symbol, if defined, indicates that the htons routine (and friends)
+ * are available to do network order byte swapping.
+ */
+/* HAS_HTONL
+ * This symbol, if defined, indicates that the htonl routine (and friends)
+ * are available to do network order byte swapping.
+ */
+/* HAS_NTOHS
+ * This symbol, if defined, indicates that the ntohs routine (and friends)
+ * are available to do network order byte swapping.
+ */
+/* HAS_NTOHL
+ * This symbol, if defined, indicates that the ntohl routine (and friends)
+ * are available to do network order byte swapping.
+ */
+#define HAS_HTONS /**/
+#define HAS_HTONL /**/
+#define HAS_NTOHS /**/
+#define HAS_NTOHL /**/
+
+/* index
+ * This preprocessor symbol is defined, along with rindex, if the system
+ * uses the strchr and strrchr routines instead.
+ */
+/* rindex
+ * This preprocessor symbol is defined, along with index, if the system
+ * uses the strchr and strrchr routines instead.
+ */
+/*#undef index strchr cultural */
+/*#undef rindex strrchr differences? */
+
+/* HAS_ISASCII
+ * This symbol, if defined, indicates that the isascii routine is available
+ * to test characters for asciiness.
+ */
+#define HAS_ISASCII /**/
+
+/* HAS_KILLPG
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+#define HAS_KILLPG /**/
+
+/* HAS_LSTAT
+ * This symbol, if defined, indicates that the lstat() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_LSTAT /**/
+
+/* HAS_MEMCMP
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * to compare blocks of memory. If undefined, roll your own.
+ */
+#define HAS_MEMCMP /**/
+
+/* HAS_MEMCPY
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy blocks of memory. Otherwise you should probably use bcopy().
+ * If neither is defined, roll your own.
+ */
+/* SAFE_MEMCPY
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping copy blocks of memory. Otherwise you
+ * should probably use memmove() or bcopy(). If neither is defined,
+ * roll your own.
+ */
+#define HAS_MEMCPY /**/
+/*#undef SAFE_MEMCPY */
+
+/* HAS_MEMMOVE
+ * This symbol, if defined, indicates that the memmove routine is available
+ * to move potentially overlapping blocks of memory. Otherwise you
+ * should use bcopy() or roll your own.
+ */
+/*#undef HAS_MEMMOVE */
+
+/* HAS_MEMSET
+ * This symbol, if defined, indicates that the memset routine is available
+ * to set a block of memory to a character. If undefined, roll your own.
+ */
+#define HAS_MEMSET /**/
+
+/* HAS_MKDIR
+ * This symbol, if defined, indicates that the mkdir routine is available
+ * to create directories. Otherwise you should fork off a new process to
+ * exec /bin/mkdir.
+ */
+#define HAS_MKDIR /**/
+
+/* HAS_MSG
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported.
+ */
+#define HAS_MSG /**/
+
+/* HAS_MSGCTL
+ * This symbol, if defined, indicates that the msgctl() routine is
+ * available to control message passing.
+ */
+#define HAS_MSGCTL /**/
+
+/* HAS_MSGGET
+ * This symbol, if defined, indicates that the msgget() routine is
+ * available to get messages.
+ */
+#define HAS_MSGGET /**/
+
+/* HAS_MSGRCV
+ * This symbol, if defined, indicates that the msgrcv() routine is
+ * available to receive messages.
+ */
+#define HAS_MSGRCV /**/
+
+/* HAS_MSGSND
+ * This symbol, if defined, indicates that the msgsnd() routine is
+ * available to send messages.
+ */
+#define HAS_MSGSND /**/
+
+/* HAS_NDBM
+ * This symbol, if defined, indicates that ndbm.h exists and should
+ * be included.
+ */
+#define HAS_NDBM /**/
+
+/* HAS_ODBM
+ * This symbol, if defined, indicates that dbm.h exists and should
+ * be included.
+ */
+#define HAS_ODBM /**/
+
+/* HAS_OPEN3
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+#define HAS_OPEN3 /**/
+
+/* HAS_READDIR
+ * This symbol, if defined, indicates that the readdir routine is available
+ * from the C library to read directories.
+ */
+#define HAS_READDIR /**/
+
+/* HAS_RENAME
+ * This symbol, if defined, indicates that the rename routine is available
+ * to rename files. Otherwise you should do the unlink(), link(), unlink()
+ * trick.
+ */
+#define HAS_RENAME /**/
+
+/* HAS_REWINDDIR
+ * This symbol, if defined, indicates that the rewindir routine is
+ * available to rewind directories.
+ */
+/*#undef HAS_REWINDDIR */
+
+/* HAS_RMDIR
+ * This symbol, if defined, indicates that the rmdir routine is available
+ * to remove directories. Otherwise you should fork off a new process to
+ * exec /bin/rmdir.
+ */
+#define HAS_RMDIR /**/
+
+/* HAS_SEEKDIR
+ * This symbol, if defined, indicates that the seekdir routine is
+ * available to seek into directories.
+ */
+#define HAS_SEEKDIR /**/
+
+/* HAS_SELECT
+ * This symbol, if defined, indicates that the select() subroutine
+ * exists.
+ */
+#define HAS_SELECT /**/
+
+/* HAS_SEM
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+#define HAS_SEM /**/
+
+/* HAS_SEMCTL
+ * This symbol, if defined, indicates that the semctl() routine is
+ * available to control semaphores.
+ */
+#define HAS_SEMCTL /**/
+
+/* HAS_SEMGET
+ * This symbol, if defined, indicates that the semget() routine is
+ * available to get semaphores ids.
+ */
+#define HAS_SEMGET /**/
+
+/* HAS_SEMOP
+ * This symbol, if defined, indicates that the semop() routine is
+ * available to perform semaphore operations.
+ */
+#define HAS_SEMOP /**/
+
+/* HAS_SETEGID
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+#define HAS_SETEGID /**/
+
+/* HAS_SETEUID
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+#define HAS_SETEUID /**/
+
+/* HAS_SETPGRP
+ * This symbol, if defined, indicates that the setpgrp() routine is
+ * available to set the current process group.
+ */
+#define HAS_SETPGRP /**/
+
+/* HAS_SETPGRP2
+ * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
+ * routine is available to set the current process group.
+ */
+/*#undef HAS_SETPGRP2 */
+
+/* HAS_SETPRIORITY
+ * This symbol, if defined, indicates that the setpriority() routine is
+ * available to set a process's priority.
+ */
+#define HAS_SETPRIORITY /**/
+
+/* HAS_SETREGID
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current program.
+ */
+/* HAS_SETRESGID
+ * This symbol, if defined, indicates that the setresgid routine is
+ * available to change the real, effective and saved gid of the current
+ * program.
+ */
+#define HAS_SETREGID /**/
+/*#undef HAS_SETRESGID */
+
+/* HAS_SETREUID
+ * This symbol, if defined, indicates that the setreuid routine is
+ * available to change the real and effective uid of the current program.
+ */
+/* HAS_SETRESUID
+ * This symbol, if defined, indicates that the setresuid routine is
+ * available to change the real, effective and saved uid of the current
+ * program.
+ */
+#define HAS_SETREUID /**/
+/*#undef HAS_SETRESUID */
+
+/* HAS_SETRGID
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+#define HAS_SETRGID /**/
+
+/* HAS_SETRUID
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+#define HAS_SETRUID /**/
+
+/* HAS_SHM
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+#define HAS_SHM /**/
+
+/* HAS_SHMAT
+ * This symbol, if defined, indicates that the shmat() routine is
+ * available to attach a shared memory segment.
+ */
+/* VOID_SHMAT
+ * This symbol, if defined, indicates that the shmat() routine
+ * returns a pointer of type void*.
+ */
+#define HAS_SHMAT /**/
+
+/*#undef VOIDSHMAT */
+
+/* HAS_SHMCTL
+ * This symbol, if defined, indicates that the shmctl() routine is
+ * available to control a shared memory segment.
+ */
+#define HAS_SHMCTL /**/
+
+/* HAS_SHMDT
+ * This symbol, if defined, indicates that the shmdt() routine is
+ * available to detach a shared memory segment.
+ */
+#define HAS_SHMDT /**/
+
+/* HAS_SHMGET
+ * This symbol, if defined, indicates that the shmget() routine is
+ * available to get a shared memory segment id.
+ */
+#define HAS_SHMGET /**/
+
+/* HAS_SOCKET
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+/* HAS_SOCKETPAIR
+ * This symbol, if defined, indicates that the BSD socketpair call is
+ * supported.
+ */
+/* OLDSOCKET
+ * This symbol, if defined, indicates that the 4.1c BSD socket interface
+ * is supported instead of the 4.2/4.3 BSD socket interface.
+ */
+#define HAS_SOCKET /**/
+
+#define HAS_SOCKETPAIR /**/
+
+/*#undef OLDSOCKET */
+
+/* STATBLOCKS
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+#define STATBLOCKS /**/
+
+/* STDSTDIO
+ * This symbol is defined if this system has a FILE structure declaring
+ * _ptr and _cnt in stdio.h.
+ */
+#define STDSTDIO /**/
+
+/* STRUCTCOPY
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+#define STRUCTCOPY /**/
+
+/* HAS_STRERROR
+ * This symbol, if defined, indicates that the strerror() routine is
+ * available to translate error numbers to strings.
+ */
+/*#undef HAS_STRERROR */
+
+/* HAS_SYMLINK
+ * This symbol, if defined, indicates that the symlink routine is available
+ * to create symbolic links.
+ */
+#define HAS_SYMLINK /**/
+
+/* HAS_SYSCALL
+ * This symbol, if defined, indicates that the syscall routine is available
+ * to call arbitrary system calls. If undefined, that's tough.
+ */
+#define HAS_SYSCALL /**/
+
+/* HAS_TELLDIR
+ * This symbol, if defined, indicates that the telldir routine is
+ * available to tell your location in directories.
+ */
+#define HAS_TELLDIR /**/
+
+/* HAS_TRUNCATE
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+#define HAS_TRUNCATE /**/
+
+/* HAS_VFORK
+ * This symbol, if defined, indicates that vfork() exists.
+ */
+#define HAS_VFORK /**/
+
+/* VOIDSIG
+ * This symbol is defined if this system declares "void (*signal())()" in
+ * signal.h. The old way was to declare it as "int (*signal())()". It
+ * is up to the package author to declare things correctly based on the
+ * symbol.
+ */
+/* TO_SIGNAL
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return "type" of a signal handler. Thus, one can declare
+ * a signal handler using "TO_SIGNAL (*handler())()", and define the
+ * handler using "TO_SIGNAL handler(sig)".
+ */
+#define VOIDSIG /**/
+#define TO_SIGNAL int /**/
+
+/* HASVOLATILE
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+/*#undef HASVOLATILE */
+
+/* HAS_VPRINTF
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* CHARVSPRINTF
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#define HAS_VPRINTF /**/
+#define CHARVSPRINTF /**/
+
+/* HAS_WAIT4
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+#define HAS_WAIT4 /**/
+
+/* HAS_WAITPID
+ * This symbol, if defined, indicates that waitpid() exists.
+ */
+#define HAS_WAITPID /**/
+
+/* GIDTYPE
+ * This symbol has a value like gid_t, int, ushort, or whatever type is
+ * used to declare group ids in the kernel.
+ */
+#define GIDTYPE int /**/
+
+/* GROUPSTYPE
+ * This symbol has a value like gid_t, int, ushort, or whatever type is
+ * used in the return value of getgroups().
+ */
+#define GROUPSTYPE int /**/
+
+/* I_FCNTL
+ * This manifest constant tells the C program to include <fcntl.h>.
+ */
+/*#undef I_FCNTL */
+
+/* I_GDBM
+ * This symbol, if defined, indicates that gdbm.h exists and should
+ * be included.
+ */
+/*#undef I_GDBM */
+
+/* I_GRP
+ * This symbol, if defined, indicates to the C program that it should
+ * include grp.h.
+ */
+#define I_GRP /**/
+
+/* I_NETINET_IN
+ * This symbol, if defined, indicates to the C program that it should
+ * include netinet/in.h.
+ */
+/* I_SYS_IN
+ * This symbol, if defined, indicates to the C program that it should
+ * include sys/in.h.
+ */
+#define I_NETINET_IN /**/
+/*#undef I_SYS_IN */
+
+/* I_PWD
+ * This symbol, if defined, indicates to the C program that it should
+ * include pwd.h.
+ */
+/* PWQUOTA
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_quota.
+ */
+/* PWAGE
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_age.
+ */
+/* PWCHANGE
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_change.
+ */
+/* PWCLASS
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_class.
+ */
+/* PWEXPIRE
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_expire.
+ */
+/* PWCOMMENT
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_comment.
+ */
+#define I_PWD /**/
+/*#undef PWQUOTA */
+#define PWAGE /**/
+/*#undef PWCHANGE */
+/*#undef PWCLASS */
+/*#undef PWEXPIRE */
+#define PWCOMMENT /**/
+
+/* I_SYS_FILE
+ * This manifest constant tells the C program to include <sys/file.h>.
+ */
+#define I_SYS_FILE /**/
+
+/* I_SYSIOCTL
+ * This symbol, if defined, indicates that sys/ioctl.h exists and should
+ * be included.
+ */
+#define I_SYSIOCTL /**/
+
+/* I_TIME
+ * This symbol is defined if the program should include <time.h>.
+ */
+/* I_SYS_TIME
+ * This symbol is defined if the program should include <sys/time.h>.
+ */
+/* SYSTIMEKERNEL
+ * This symbol is defined if the program should include <sys/time.h>
+ * with KERNEL defined.
+ */
+/* I_SYS_SELECT
+ * This symbol is defined if the program should include <sys/select.h>.
+ */
+/*#undef I_TIME */
+#define I_SYS_TIME /**/
+/*#undef SYSTIMEKERNEL */
+/*#undef I_SYS_SELECT */
+
+/* I_UTIME
+ * This symbol, if defined, indicates to the C program that it should
+ * include utime.h.
+ */
+#define I_UTIME /**/
+
+/* I_VARARGS
+ * This symbol, if defined, indicates to the C program that it should
+ * include varargs.h.
+ */
+#define I_VARARGS /**/
+
+/* I_VFORK
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+#define I_VFORK /**/
+
+/* INTSIZE
+ * This symbol contains the size of an int, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define INTSIZE 4 /**/
+
+/* I_DIRENT
+ * This symbol, if defined, indicates that the program should use the
+ * P1003-style directory routines, and include <dirent.h>.
+ */
+/* I_SYS_DIR
+ * This symbol, if defined, indicates that the program should use the
+ * directory functions by including <sys/dir.h>.
+ */
+/* I_NDIR
+ * This symbol, if defined, indicates that the program should include the
+ * system's version of ndir.h, rather than the one with this package.
+ */
+/* I_SYS_NDIR
+ * This symbol, if defined, indicates that the program should include the
+ * system's version of sys/ndir.h, rather than the one with this package.
+ */
+/* I_MY_DIR
+ * This symbol, if defined, indicates that the program should compile
+ * the ndir.c code provided with the package.
+ */
+/* DIRNAMLEN
+ * This symbol, if defined, indicates to the C program that the length
+ * of directory entry names is provided by a d_namlen field. Otherwise
+ * you need to do strlen() on the d_name field.
+ */
+#define I_DIRENT /**/
+/*#undef I_SYS_DIR */
+/*#undef I_NDIR */
+/*#undef I_SYS_NDIR */
+/*#undef I_MY_DIR */
+/*#undef DIRNAMLEN */
+
+/* MYMALLOC
+ * This symbol, if defined, indicates that we're using our own malloc.
+ */
+/* MALLOCPTRTYPE
+ * This symbol defines the kind of ptr returned by malloc and realloc.
+ */
+#define MYMALLOC /**/
+
+#define MALLOCPTRTYPE char /**/
+
+
+/* RANDBITS
+ * This symbol contains the number of bits of random number the rand()
+ * function produces. Usual values are 15, 16, and 31.
+ */
+#define RANDBITS 31 /**/
+
+/* SCRIPTDIR
+ * This symbol holds the name of the directory in which the user wants
+ * to keep publicly executable scripts for the package in question. It
+ * is often a directory that is mounted across diverse architectures.
+ */
+#define SCRIPTDIR "/usr/local/bin" /**/
+
+/* SIG_NAME
+ * This symbol contains an list of signal names in order.
+ */
+#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","LOST","USR1","USR2" /**/
+
+/* STDCHAR
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+#define STDCHAR unsigned char /**/
+
+/* UIDTYPE
+ * This symbol has a value like uid_t, int, ushort, or whatever type is
+ * used to declare user ids in the kernel.
+ */
+#define UIDTYPE int /**/
+
+/* VOIDHAVE
+ * This symbol indicates how much support of the void type is given by this
+ * compiler. What various bits mean:
+ *
+ * 1 = supports declaration of void
+ * 2 = supports arrays of pointers to functions returning void
+ * 4 = supports comparisons between pointers to void functions and
+ * addresses of void functions
+ *
+ * The package designer should define VOIDWANT to indicate the requirements
+ * of the package. This can be done either by #defining VOIDWANT before
+ * including config.h, or by defining voidwant in Myinit.U. If the level
+ * of void support necessary is not present, config.h defines void to "int",
+ * VOID to the empty string, and VOIDP to "char *".
+ */
+/* void
+ * This symbol is used for void casts. On implementations which support
+ * void appropriately, its value is "void". Otherwise, its value maps
+ * to "int".
+ */
+/* VOID
+ * This symbol's value is "void" if the implementation supports void
+ * appropriately. Otherwise, its value is the empty string. The primary
+ * use of this symbol is in specifying void parameter lists for function
+ * prototypes.
+ */
+/* VOIDP
+ * This symbol is used for casting generic pointers. On implementations
+ * which support void appropriately, its value is "void *". Otherwise,
+ * its value is "char *".
+ */
+#ifndef VOIDWANT
+#define VOIDWANT 7
+#endif
+#define VOIDHAVE 7
+#if (VOIDHAVE & VOIDWANT) != VOIDWANT
+#define void int /* is void to be avoided? */
+#define VOID
+#define VOIDP (char *)
+#define M_VOID /* Xenix strikes again */
+#else
+#define VOID void
+#define VOIDP (void *)
+#endif
+
+/* PRIVLIB
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ */
+#define PRIVLIB "/usr/local/lib/perl" /**/
+
+#define I_MATH
+
+#endif
+
+++ /dev/null
-/* $RCSfile: cons.c,v $$Revision: 4.0.1.3 $$Date: 92/06/08 12:18:35 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: cons.c,v $
- * Revision 4.0.1.3 92/06/08 12:18:35 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: deleted some minor memory leaks
- * patch20: fixed double debug break in foreach with implicit array assignment
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- * patch20: debugger sometimes displayed wrong source line
- * patch20: various error messages have been clarified
- * patch20: an eval block containing a null block or statement could dump core
- *
- * Revision 4.0.1.2 91/11/05 16:15:13 lwall
- * patch11: debugger got confused over nested subroutine definitions
- * patch11: prepared for ctype implementations that don't define isascii()
- *
- * Revision 4.0.1.1 91/06/07 10:31:15 lwall
- * patch4: new copyright notice
- * patch4: added global modifier for pattern matches
- *
- * Revision 4.0 91/03/20 01:05:51 lwall
- * 4.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 void make_cswitch();
-static void make_nswitch();
-
-static bool saw_return;
-
-SUBR *
-make_sub(name,cmd)
-char *name;
-CMD *cmd;
-{
- register SUBR *sub;
- STAB *stab = stabent(name,TRUE);
-
- if (sub = stab_sub(stab)) {
- if (dowarn) {
- CMD *oldcurcmd = curcmd;
-
- if (cmd)
- curcmd = cmd;
- warn("Subroutine %s redefined",name);
- curcmd = oldcurcmd;
- }
- if (!sub->usersub && sub->cmd) {
- cmd_free(sub->cmd);
- sub->cmd = Nullcmd;
- afree(sub->tosave);
- }
- Safefree(sub);
- }
- Newz(101,sub,1,SUBR);
- stab_sub(stab) = sub;
- sub->filestab = curcmd->c_filestab;
- 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,0,
- Nullarg,mycompblock));
- saw_return = FALSE;
- cmd->c_flags |= CF_TERM;
- cmd->c_head = cmd;
- }
- sub->cmd = cmd;
- if (perldb) {
- STR *str;
- STR *tmpstr = str_mortal(&str_undef);
-
- sprintf(buf,"%s:%ld",stab_val(curcmd->c_filestab)->str_ptr, subline);
- str = str_make(buf,0);
- str_cat(str,"-");
- sprintf(buf,"%ld",(long)curcmd->c_line);
- str_cat(str,buf);
- stab_efullname(tmpstr,stab);
- hstore(stab_xhash(DBsub), tmpstr->str_ptr, tmpstr->str_cur, str, 0);
- }
- Safefree(name);
- return sub;
-}
-
-SUBR *
-make_usub(name, ix, subaddr, filename)
-char *name;
-int ix;
-int (*subaddr)();
-char *filename;
-{
- register SUBR *sub;
- STAB *stab = stabent(name,allstabs);
-
- if (!stab) /* unused function */
- return Null(SUBR*);
- if (sub = stab_sub(stab)) {
- if (dowarn)
- warn("Subroutine %s redefined",name);
- if (!sub->usersub && sub->cmd) {
- cmd_free(sub->cmd);
- sub->cmd = Nullcmd;
- afree(sub->tosave);
- }
- Safefree(sub);
- }
- Newz(101,sub,1,SUBR);
- stab_sub(stab) = sub;
- sub->filestab = fstab(filename);
- sub->usersub = subaddr;
- sub->userindex = ix;
- return sub;
-}
-
-void
-make_form(stab,fcmd)
-STAB *stab;
-FCMD *fcmd;
-{
- if (stab_form(stab)) {
- FCMD *tmpfcmd;
- FCMD *nextfcmd;
-
- for (tmpfcmd = stab_form(stab); tmpfcmd; tmpfcmd = nextfcmd) {
- nextfcmd = tmpfcmd->f_next;
- if (tmpfcmd->f_expr)
- arg_free(tmpfcmd->f_expr);
- if (tmpfcmd->f_unparsed)
- str_free(tmpfcmd->f_unparsed);
- if (tmpfcmd->f_pre)
- Safefree(tmpfcmd->f_pre);
- Safefree(tmpfcmd);
- }
- }
- stab_form(stab) = fcmd;
-}
-
-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:
- 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.
- */
-static void
-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);
- StructCopy(head,cur,CMD);
- Zero(head,1,CMD);
- head->c_head = cur->c_head;
- 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)
- Move(&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;
-}
-
-static void
-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);
- StructCopy(head,cur,CMD);
- Zero(head,1,CMD);
- head->c_head = cur->c_head;
- 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;
- STR *str;
-
- if (!head)
- head = cur;
- if (!head->c_line)
- return cur;
- str = afetch(stab_xarray(curcmd->c_filestab),(int)head->c_line,FALSE);
- if (str == &str_undef || str->str_nok)
- return cur;
- str->str_u.str_nval = (double)head->c_line;
- str->str_nok = 1;
- Newz(106,cmd,1,CMD);
- str_magic(str, curcmd->c_filestab, 0, Nullch, 0);
- str->str_magic->str_u.str_cmd = cmd;
- cmd->c_type = C_EXPR;
- cmd->ucmd.acmd.ac_stab = Nullstab;
- cmd->ucmd.acmd.ac_expr = Nullarg;
- cmd->c_expr = make_op(O_SUBR, 2,
- stab2arg(A_WORD,DBstab),
- Nullarg,
- Nullarg);
- /*SUPPRESS 53*/
- cmd->c_flags |= CF_COND|CF_DBSUB|CFT_D0;
- cmd->c_line = head->c_line;
- cmd->c_label = head->c_label;
- cmd->c_filestab = curcmd->c_filestab;
- cmd->c_stash = curstash;
- 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 = curcmd->c_line;
- else {
- cmd->c_line = cmdline;
- cmdline = NOLINE;
- }
- cmd->c_filestab = curcmd->c_filestab;
- cmd->c_stash = curstash;
- if (perldb)
- cmd = dodb(cmd);
- return cmd;
-}
-
-CMD *
-make_ccmd(type,debuggable,arg,cblock)
-int type;
-int debuggable;
-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 = curcmd->c_line;
- else {
- cmd->c_line = cmdline;
- cmdline = NOLINE;
- }
- cmd->c_filestab = curcmd->c_filestab;
- cmd->c_stash = curstash;
- if (perldb && debuggable)
- 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 = curcmd->c_line;
- else {
- cmd->c_line = cmdline;
- cmdline = NOLINE;
- }
- cmd->c_filestab = curcmd->c_filestab;
- cmd->c_stash = curstash;
- 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,1,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;
- if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM)
- && cmd->c_expr->arg_type == O_ITEM) {
- arg[flp].arg_flags &= ~AF_POST; /* prefer ++$foo to $foo++ */
- arg[flp].arg_flags |= AF_PRE; /* if value not wanted */
- }
- 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;
- if (!context)
- arg[flp].arg_ptr.arg_stab = Nullstab;
- opt = CFT_REG;
- literal:
- if (!context) { /* no && or ||? */
- arg_free(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 &&
- (arg->arg_type == O_SUBST || arg->arg_type == O_NSUBST ||
- (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_GLOBAL) == 0 )) {
- 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) {
- str_free(arg[2].arg_ptr.arg_spat->spat_short);
- 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 */
- }
- else
- cmd->c_spat = arg[2].arg_ptr.arg_spat;
- 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) {
- /*SUPPRESS 594*/
- char *junk = str_get(arg[2].arg_ptr.arg_str);
-
- 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);
- arg[2].arg_ptr.arg_arg = Nullarg;
- 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_flags & AF_DEPR) &&
- (arg->arg_type == O_SUBR || arg->arg_type == O_DBSUBR) )
- 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;
-}
-
-void
-cpy7bit(d,s,l)
-register char *d;
-register char *s;
-register int l;
-{
- while (l--)
- *d++ = *s++ & 127;
- *d = '\0';
-}
-
-int
-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++;
- cpy7bit(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr);
- sprintf(tname,"next 2 tokens \"%s\"",tmp2buf);
- }
- else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
- oldbufptr != bufptr) {
- while (isSPACE(*oldbufptr))
- oldbufptr++;
- cpy7bit(tmp2buf, oldbufptr, bufptr - oldbufptr);
- 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,stab_val(curcmd->c_filestab)->str_ptr,curcmd->c_line,tname);
- if (curcmd->c_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("%s has too many errors.\n",
- stab_val(curcmd->c_filestab)->str_ptr);
-}
-
-void
-while_io(cmd)
-register CMD *cmd;
-{
- register ARG *arg = cmd->c_expr;
- STAB *asgnstab;
-
- /* hoist "while (<channel>)" up into command block */
-
- if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) {
- cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
- cmd->c_flags |= CFT_GETS; /* and set it to do the input */
- cmd->c_stab = arg[1].arg_ptr.arg_stab;
- if (stab_io(arg[1].arg_ptr.arg_stab)->flags & IOF_ARGV) {
- cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */
- stab2arg(A_LVAL,defstab), arg, Nullarg));
- }
- else {
- free_arg(arg);
- cmd->c_expr = Nullarg;
- }
- }
- else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) {
- cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
- cmd->c_flags |= CFT_INDGETS; /* and set it to do the input */
- cmd->c_stab = arg[1].arg_ptr.arg_stab;
- free_arg(arg);
- cmd->c_expr = Nullarg;
- }
- else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) {
- if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY)
- asgnstab = cmd->c_stab;
- else
- asgnstab = defstab;
- cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$foo =" */
- stab2arg(A_LVAL,asgnstab), arg, Nullarg));
- cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
- }
-}
-
-CMD *
-wopt(cmd)
-register CMD *cmd;
-{
- register CMD *tail;
- CMD *newtail;
- register int i;
-
- if (cmd->c_expr && (cmd->c_flags & CF_OPTIMIZE) == CFT_FALSE)
- opt_arg(cmd,1, cmd->c_type == C_EXPR);
-
- while_io(cmd); /* add $_ =, if necessary */
-
- /* First find the end of the true list */
-
- tail = cmd->ucmd.ccmd.cc_true;
- if (tail == Nullcmd)
- return cmd;
- New(112,newtail, 1, CMD); /* guaranteed continue */
- for (;;) {
- /* optimize "next" to point directly to continue block */
- if (tail->c_type == C_EXPR &&
- tail->ucmd.acmd.ac_expr &&
- tail->ucmd.acmd.ac_expr->arg_type == O_NEXT &&
- (tail->ucmd.acmd.ac_expr->arg_len == 0 ||
- (cmd->c_label &&
- strEQ(cmd->c_label,
- tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) )))
- {
- arg_free(tail->ucmd.acmd.ac_expr);
- tail->ucmd.acmd.ac_expr = Nullarg;
- 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->ucmd.acmd.ac_expr = Nullarg;
- 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;
- }
- /*SUPPRESS 530*/
- 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
- Copy((char *)cmd, (char *)tail, 1, 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(23,0); /* just to save a field in struct cmd */
- cmd->c_short->str_u.str_useful = -1;
-
- return cmd;
-}
-
-void
-cmd_free(cmd)
-register CMD *cmd;
-{
- register CMD *tofree;
- register CMD *head = cmd;
-
- if (!cmd)
- return;
- if (cmd->c_head != cmd)
- warn("Malformed cmd links\n");
- while (cmd) {
- if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */
- if (cmd->c_label) {
- Safefree(cmd->c_label);
- cmd->c_label = Nullch;
- }
- if (cmd->c_short) {
- str_free(cmd->c_short);
- cmd->c_short = Nullstr;
- }
- if (cmd->c_expr) {
- arg_free(cmd->c_expr);
- cmd->c_expr = Nullarg;
- }
- }
- 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);
- cmd->ucmd.ccmd.cc_true = Nullcmd;
- }
- break;
- case C_EXPR:
- if (cmd->ucmd.acmd.ac_expr) {
- arg_free(cmd->ucmd.acmd.ac_expr);
- cmd->ucmd.acmd.ac_expr = Nullarg;
- }
- break;
- }
- tofree = cmd;
- cmd = cmd->c_next;
- if (tofree != head) /* to get Saber to shut up */
- Safefree(tofree);
- if (cmd && cmd == head) /* reached end of while loop */
- break;
- }
- Safefree(head);
-}
-
-void
-arg_free(arg)
-register ARG *arg;
-{
- register int i;
-
- if (!arg)
- return;
- for (i = 1; i <= arg->arg_len; i++) {
- switch (arg[i].arg_type & A_MASK) {
- case A_NULL:
- if (arg->arg_type == O_TRANS) {
- Safefree(arg[i].arg_ptr.arg_cval);
- arg[i].arg_ptr.arg_cval = Nullch;
- }
- 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);
- arg[i].arg_ptr.arg_arg = Nullarg;
- break;
- case A_CMD:
- cmd_free(arg[i].arg_ptr.arg_cmd);
- arg[i].arg_ptr.arg_cmd = Nullcmd;
- break;
- case A_WORD:
- case A_STAB:
- case A_LVAL:
- case A_READ:
- case A_GLOB:
- case A_ARYLEN:
- 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);
- arg[i].arg_ptr.arg_str = Nullstr;
- break;
- case A_SPAT:
- spat_free(arg[i].arg_ptr.arg_spat);
- arg[i].arg_ptr.arg_spat = Nullspat;
- break;
- }
- }
- free_arg(arg);
-}
-
-void
-spat_free(spat)
-register SPAT *spat;
-{
- register SPAT *sp;
- HENT *entry;
-
- if (!spat)
- return;
- if (spat->spat_runtime) {
- arg_free(spat->spat_runtime);
- spat->spat_runtime = Nullarg;
- }
- if (spat->spat_repl) {
- arg_free(spat->spat_repl);
- spat->spat_repl = Nullarg;
- }
- if (spat->spat_short) {
- str_free(spat->spat_short);
- spat->spat_short = Nullstr;
- }
- if (spat->spat_regexp) {
- regfree(spat->spat_regexp);
- spat->spat_regexp = Null(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)
- /*SUPPRESS 530*/
- ;
- 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_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->c_expr) {
- ARG *arg = lastcmd->c_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);
- }
- }
-
- /* in any event, save the iterator */
-
- if (cmd->c_short) /* Better safe than sorry */
- (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 && arg->arg_ptr.arg_str)
- (void)apush(tosave,arg->arg_ptr.arg_str);
- return shouldsave;
-}
-
-static int
-spat_tosave(spat)
-register SPAT *spat;
-{
- int shouldsave = FALSE;
-
- if (spat->spat_runtime)
- shouldsave |= arg_tosave(spat->spat_runtime,FALSE);
- if (spat->spat_repl) {
- shouldsave |= arg_tosave(spat->spat_repl,FALSE);
- }
-
- return shouldsave;
-}
-
+++ /dev/null
-/* $RCSfile: cons.c,v $$Revision: 4.0.1.3 $$Date: 92/06/08 12:18:35 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: cons.c,v $
- * Revision 4.0.1.3 92/06/08 12:18:35 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: deleted some minor memory leaks
- * patch20: fixed double debug break in foreach with implicit array assignment
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- * patch20: debugger sometimes displayed wrong source line
- * patch20: various error messages have been clarified
- * patch20: an eval block containing a null block or statement could dump core
- *
- * Revision 4.0.1.2 91/11/05 16:15:13 lwall
- * patch11: debugger got confused over nested subroutine definitions
- * patch11: prepared for ctype implementations that don't define isascii()
- *
- * Revision 4.0.1.1 91/06/07 10:31:15 lwall
- * patch4: new copyright notice
- * patch4: added global modifier for pattern matches
- *
- * Revision 4.0 91/03/20 01:05:51 lwall
- * 4.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 void make_cswitch();
-static void make_nswitch();
-
-static bool saw_return;
-
-SUBR *
-make_sub(name,cmd)
-char *name;
-CMD *cmd;
-{
- register SUBR *sub;
- STAB *stab = stabent(name,TRUE);
-
- if (sub = stab_sub(stab)) {
- if (dowarn) {
- CMD *oldcurcmd = curcmd;
-
- if (cmd)
- curcmd = cmd;
- warn("Subroutine %s redefined",name);
- curcmd = oldcurcmd;
- }
- if (!sub->usersub && sub->cmd) {
- cmd_free(sub->cmd);
- sub->cmd = Nullcmd;
- afree(sub->tosave);
- }
- Safefree(sub);
- }
- Newz(101,sub,1,SUBR);
- stab_sub(stab) = sub;
- sub->filestab = curcmd->c_filestab;
- 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,0,
- Nullarg,mycompblock));
- saw_return = FALSE;
- cmd->c_flags |= CF_TERM;
- }
- sub->cmd = cmd;
- if (perldb) {
- STR *str;
- STR *tmpstr = str_mortal(&str_undef);
-
- sprintf(buf,"%s:%ld",stab_val(curcmd->c_filestab)->str_ptr, subline);
- str = str_make(buf,0);
- str_cat(str,"-");
- sprintf(buf,"%ld",(long)curcmd->c_line);
- str_cat(str,buf);
- stab_efullname(tmpstr,stab);
- hstore(stab_xhash(DBsub), tmpstr->str_ptr, tmpstr->str_cur, str, 0);
- }
- Safefree(name);
- return sub;
-}
-
-SUBR *
-make_usub(name, ix, subaddr, filename)
-char *name;
-int ix;
-int (*subaddr)();
-char *filename;
-{
- register SUBR *sub;
- STAB *stab = stabent(name,allstabs);
-
- if (!stab) /* unused function */
- return Null(SUBR*);
- if (sub = stab_sub(stab)) {
- if (dowarn)
- warn("Subroutine %s redefined",name);
- if (!sub->usersub && sub->cmd) {
- cmd_free(sub->cmd);
- sub->cmd = Nullcmd;
- afree(sub->tosave);
- }
- Safefree(sub);
- }
- Newz(101,sub,1,SUBR);
- stab_sub(stab) = sub;
- sub->filestab = fstab(filename);
- sub->usersub = subaddr;
- sub->userindex = ix;
- return sub;
-}
-
-void
-make_form(stab,fcmd)
-STAB *stab;
-FCMD *fcmd;
-{
- if (stab_form(stab)) {
- FCMD *tmpfcmd;
- FCMD *nextfcmd;
-
- for (tmpfcmd = stab_form(stab); tmpfcmd; tmpfcmd = nextfcmd) {
- nextfcmd = tmpfcmd->f_next;
- if (tmpfcmd->f_expr)
- arg_free(tmpfcmd->f_expr);
- if (tmpfcmd->f_unparsed)
- str_free(tmpfcmd->f_unparsed);
- if (tmpfcmd->f_pre)
- Safefree(tmpfcmd->f_pre);
- Safefree(tmpfcmd);
- }
- }
- stab_form(stab) = fcmd;
-}
-
-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:
- 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.
- */
-static void
-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);
- StructCopy(head,cur,CMD);
- Zero(head,1,CMD);
- head->c_head = cur->c_head;
- 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)
- Move(&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;
-}
-
-static void
-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);
- StructCopy(head,cur,CMD);
- Zero(head,1,CMD);
- head->c_head = cur->c_head;
- 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;
- STR *str;
-
- if (!head)
- head = cur;
- if (!head->c_line)
- return cur;
- str = afetch(stab_xarray(curcmd->c_filestab),(int)head->c_line,FALSE);
- if (str == &str_undef || str->str_nok)
- return cur;
- str->str_u.str_nval = (double)head->c_line;
- str->str_nok = 1;
- Newz(106,cmd,1,CMD);
- str_magic(str, curcmd->c_filestab, 0, Nullch, 0);
- str->str_magic->str_u.str_cmd = cmd;
- cmd->c_type = C_EXPR;
- cmd->ucmd.acmd.ac_stab = Nullstab;
- cmd->ucmd.acmd.ac_expr = Nullarg;
- cmd->c_expr = make_op(O_SUBR, 2,
- stab2arg(A_WORD,DBstab),
- Nullarg,
- Nullarg);
- /*SUPPRESS 53*/
- cmd->c_flags |= CF_COND|CF_DBSUB|CFT_D0;
- cmd->c_line = head->c_line;
- cmd->c_label = head->c_label;
- cmd->c_filestab = curcmd->c_filestab;
- cmd->c_stash = curstash;
- 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 = curcmd->c_line;
- else {
- cmd->c_line = cmdline;
- cmdline = NOLINE;
- }
- cmd->c_filestab = curcmd->c_filestab;
- cmd->c_stash = curstash;
- if (perldb)
- cmd = dodb(cmd);
- return cmd;
-}
-
-CMD *
-make_ccmd(type,debuggable,arg,cblock)
-int type;
-int debuggable;
-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 = curcmd->c_line;
- else {
- cmd->c_line = cmdline;
- cmdline = NOLINE;
- }
- cmd->c_filestab = curcmd->c_filestab;
- cmd->c_stash = curstash;
- if (perldb && debuggable)
- 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 = curcmd->c_line;
- else {
- cmd->c_line = cmdline;
- cmdline = NOLINE;
- }
- cmd->c_filestab = curcmd->c_filestab;
- cmd->c_stash = curstash;
- 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,1,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;
- if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM)
- && cmd->c_expr->arg_type == O_ITEM) {
- arg[flp].arg_flags &= ~AF_POST; /* prefer ++$foo to $foo++ */
- arg[flp].arg_flags |= AF_PRE; /* if value not wanted */
- }
- 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;
- if (!context)
- arg[flp].arg_ptr.arg_stab = Nullstab;
- opt = CFT_REG;
- literal:
- if (!context) { /* no && or ||? */
- arg_free(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 &&
- (arg->arg_type == O_SUBST || arg->arg_type == O_NSUBST ||
- (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_GLOBAL) == 0 )) {
- 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) {
- str_free(arg[2].arg_ptr.arg_spat->spat_short);
- 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 */
- }
- else
- cmd->c_spat = arg[2].arg_ptr.arg_spat;
- 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) {
- /*SUPPRESS 594*/
- char *junk = str_get(arg[2].arg_ptr.arg_str);
-
- 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);
- arg[2].arg_ptr.arg_arg = Nullarg;
- 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_flags & AF_DEPR) &&
- (arg->arg_type == O_SUBR || arg->arg_type == O_DBSUBR) )
- 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;
-}
-
-void
-cpy7bit(d,s,l)
-register char *d;
-register char *s;
-register int l;
-{
- while (l--)
- *d++ = *s++ & 127;
- *d = '\0';
-}
-
-int
-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++;
- cpy7bit(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr);
- sprintf(tname,"next 2 tokens \"%s\"",tmp2buf);
- }
- else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
- oldbufptr != bufptr) {
- while (isSPACE(*oldbufptr))
- oldbufptr++;
- cpy7bit(tmp2buf, oldbufptr, bufptr - oldbufptr);
- 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,stab_val(curcmd->c_filestab)->str_ptr,curcmd->c_line,tname);
- if (curcmd->c_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("%s has too many errors.\n",
- stab_val(curcmd->c_filestab)->str_ptr);
-}
-
-void
-while_io(cmd)
-register CMD *cmd;
-{
- register ARG *arg = cmd->c_expr;
- STAB *asgnstab;
-
- /* hoist "while (<channel>)" up into command block */
-
- if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) {
- cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
- cmd->c_flags |= CFT_GETS; /* and set it to do the input */
- cmd->c_stab = arg[1].arg_ptr.arg_stab;
- if (stab_io(arg[1].arg_ptr.arg_stab)->flags & IOF_ARGV) {
- cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */
- stab2arg(A_LVAL,defstab), arg, Nullarg));
- }
- else {
- free_arg(arg);
- cmd->c_expr = Nullarg;
- }
- }
- else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) {
- cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
- cmd->c_flags |= CFT_INDGETS; /* and set it to do the input */
- cmd->c_stab = arg[1].arg_ptr.arg_stab;
- free_arg(arg);
- cmd->c_expr = Nullarg;
- }
- else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) {
- if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY)
- asgnstab = cmd->c_stab;
- else
- asgnstab = defstab;
- cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$foo =" */
- stab2arg(A_LVAL,asgnstab), arg, Nullarg));
- cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
- }
-}
-
-CMD *
-wopt(cmd)
-register CMD *cmd;
-{
- register CMD *tail;
- CMD *newtail;
- register int i;
-
- if (cmd->c_expr && (cmd->c_flags & CF_OPTIMIZE) == CFT_FALSE)
- opt_arg(cmd,1, cmd->c_type == C_EXPR);
-
- while_io(cmd); /* add $_ =, if necessary */
-
- /* First find the end of the true list */
-
- tail = cmd->ucmd.ccmd.cc_true;
- if (tail == Nullcmd)
- return cmd;
- New(112,newtail, 1, CMD); /* guaranteed continue */
- for (;;) {
- /* optimize "next" to point directly to continue block */
- if (tail->c_type == C_EXPR &&
- tail->ucmd.acmd.ac_expr &&
- tail->ucmd.acmd.ac_expr->arg_type == O_NEXT &&
- (tail->ucmd.acmd.ac_expr->arg_len == 0 ||
- (cmd->c_label &&
- strEQ(cmd->c_label,
- tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) )))
- {
- arg_free(tail->ucmd.acmd.ac_expr);
- tail->ucmd.acmd.ac_expr = Nullarg;
- 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->ucmd.acmd.ac_expr = Nullarg;
- 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;
- }
- /*SUPPRESS 530*/
- 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
- Copy((char *)cmd, (char *)tail, 1, 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(23,0); /* just to save a field in struct cmd */
- cmd->c_short->str_u.str_useful = -1;
-
- return cmd;
-}
-
-void
-cmd_free(cmd)
-register CMD *cmd;
-{
- register CMD *tofree;
- register CMD *head = cmd;
-
- if (!cmd)
- return;
- if (cmd->c_head != cmd)
- warn("Malformed cmd links\n");
- while (cmd) {
- if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */
- if (cmd->c_label) {
- Safefree(cmd->c_label);
- cmd->c_label = Nullch;
- }
- if (cmd->c_short) {
- str_free(cmd->c_short);
- cmd->c_short = Nullstr;
- }
- if (cmd->c_expr) {
- arg_free(cmd->c_expr);
- cmd->c_expr = Nullarg;
- }
- }
- 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);
- cmd->ucmd.ccmd.cc_true = Nullcmd;
- }
- break;
- case C_EXPR:
- if (cmd->ucmd.acmd.ac_expr) {
- arg_free(cmd->ucmd.acmd.ac_expr);
- cmd->ucmd.acmd.ac_expr = Nullarg;
- }
- break;
- }
- tofree = cmd;
- cmd = cmd->c_next;
- if (tofree != head) /* to get Saber to shut up */
- Safefree(tofree);
- if (cmd && cmd == head) /* reached end of while loop */
- break;
- }
- Safefree(head);
-}
-
-void
-arg_free(arg)
-register ARG *arg;
-{
- register int i;
-
- if (!arg)
- return;
- for (i = 1; i <= arg->arg_len; i++) {
- switch (arg[i].arg_type & A_MASK) {
- case A_NULL:
- if (arg->arg_type == O_TRANS) {
- Safefree(arg[i].arg_ptr.arg_cval);
- arg[i].arg_ptr.arg_cval = Nullch;
- }
- 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);
- arg[i].arg_ptr.arg_arg = Nullarg;
- break;
- case A_CMD:
- cmd_free(arg[i].arg_ptr.arg_cmd);
- arg[i].arg_ptr.arg_cmd = Nullcmd;
- break;
- case A_WORD:
- case A_STAB:
- case A_LVAL:
- case A_READ:
- case A_GLOB:
- case A_ARYLEN:
- 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);
- arg[i].arg_ptr.arg_str = Nullstr;
- break;
- case A_SPAT:
- spat_free(arg[i].arg_ptr.arg_spat);
- arg[i].arg_ptr.arg_spat = Nullspat;
- break;
- }
- }
- free_arg(arg);
-}
-
-void
-spat_free(spat)
-register SPAT *spat;
-{
- register SPAT *sp;
- HENT *entry;
-
- if (!spat)
- return;
- if (spat->spat_runtime) {
- arg_free(spat->spat_runtime);
- spat->spat_runtime = Nullarg;
- }
- if (spat->spat_repl) {
- arg_free(spat->spat_repl);
- spat->spat_repl = Nullarg;
- }
- if (spat->spat_short) {
- str_free(spat->spat_short);
- spat->spat_short = Nullstr;
- }
- if (spat->spat_regexp) {
- regfree(spat->spat_regexp);
- spat->spat_regexp = Null(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)
- /*SUPPRESS 530*/
- ;
- 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_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->c_expr) {
- ARG *arg = lastcmd->c_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);
- }
- }
-
- /* 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;
-}
-
+++ /dev/null
-***************
-*** 1,4 ****
-! /* $RCSfile: cons.c,v $$Revision: 4.0.1.3 $$Date: 1992/06/08 12:18:35 $
- *
- * Copyright (c) 1991, Larry Wall
- *
---- 1,4 ----
-! /* $RCSfile: cons.c,v $$Revision: 4.0.1.4 $$Date: 1993/02/05 19:30:15 $
- *
- * Copyright (c) 1991, Larry Wall
- *
-***************
-*** 6,12 ****
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: cons.c,v $
-! * Revision 4.0.1.3 1992/06/08 12:18:35 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: deleted some minor memory leaks
- * patch20: fixed double debug break in foreach with implicit array assignment
---- 6,15 ----
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: cons.c,v $
-! * Revision 4.0.1.4 1993/02/05 19:30:15 lwall
-! * patch36: fixed various little coredump bugs
-! *
-! * Revision 4.0.1.3 92/06/08 12:18:35 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: deleted some minor memory leaks
- * patch20: fixed double debug break in foreach with implicit array assignment
-***************
-*** 15,21 ****
- * patch20: debugger sometimes displayed wrong source line
- * patch20: various error messages have been clarified
- * patch20: an eval block containing a null block or statement could dump core
-! *
- * Revision 4.0.1.2 91/11/05 16:15:13 lwall
- * patch11: debugger got confused over nested subroutine definitions
- * patch11: prepared for ctype implementations that don't define isascii()
---- 18,24 ----
- * patch20: debugger sometimes displayed wrong source line
- * patch20: various error messages have been clarified
- * patch20: an eval block containing a null block or statement could dump core
-! *
- * Revision 4.0.1.2 91/11/05 16:15:13 lwall
- * patch11: debugger got confused over nested subroutine definitions
- * patch11: prepared for ctype implementations that don't define isascii()
+++ /dev/null
-/* $RCSfile: consarg.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 12:26:27 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: consarg.c,v $
- * Revision 4.0.1.4 92/06/08 12:26:27 lwall
- * patch20: new warning for use of x with non-numeric right operand
- * patch20: modulus with highest bit in left operand set didn't always work
- * patch20: illegal lvalue message could be followed by core dump
- * patch20: deleted some minor memory leaks
- *
- * Revision 4.0.1.3 91/11/05 16:21:16 lwall
- * patch11: random cleanup
- * patch11: added eval {}
- * patch11: added sort {} LIST
- * patch11: "foo" x -1 dumped core
- * patch11: substr() and vec() weren't allowed in an lvalue list
- *
- * Revision 4.0.1.2 91/06/07 10:33:12 lwall
- * patch4: new copyright notice
- * patch4: length($`), length($&), length($') now optimized to avoid string copy
- *
- * Revision 4.0.1.1 91/04/11 17:38:34 lwall
- * patch1: fixed "Bad free" error
- *
- * Revision 4.0 91/03/20 01:06:15 lwall
- * 4.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_flags = 0;
- arg[3].arg_len = 0;
- arg[3].arg_type = A_EXPR;
- arg[3].arg_ptr.arg_arg = limarg;
- }
- }
- else {
- arg[3].arg_flags = 0;
- arg[3].arg_len = 0;
- arg[3].arg_type = A_NULL;
- arg[3].arg_ptr.arg_arg = Nullarg;
- }
- 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)
- return Nullarg;
-
- 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_len = pat[2].arg_len;
- 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_len = pat[3].arg_len;
- newarg[3].arg_flags = pat[3].arg_flags;
- }
- }
- free_arg(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 unsigned doarg;
- register int i;
- extern ARG *arg4; /* should be normal arguments, really */
- extern ARG *arg5;
-
- arg = op_new(newlen);
- arg->arg_type = type;
- /*SUPPRESS 560*/
- if (chld = arg1) {
- if (chld->arg_type == O_ITEM &&
- (hoistable[ i = (chld[1].arg_type&A_MASK)] || i == A_LVAL ||
- (i == 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;
- }
- }
- /*SUPPRESS 560*/
- if (chld = arg2) {
- if (chld->arg_type == O_ITEM &&
- (hoistable[chld[1].arg_type&A_MASK] ||
- (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;
- }
- }
- /*SUPPRESS 560*/
- if (chld = arg3) {
- if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
- 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 (newlen >= 4 && (chld = arg4)) {
- if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
- 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&A_MASK]) {
- 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;
- }
- }
- doarg = opargs[type];
- for (i = 1; i <= newlen; ++i) {
- if (!(doarg & 1))
- arg[i].arg_type |= A_DONT;
- if (doarg & 2)
- arg[i].arg_flags |= AF_ARYOK;
- doarg >>= 2;
- }
-#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
- arg = evalstatic(arg); /* see if we can consolidate anything */
- return arg;
-}
-
-ARG *
-evalstatic(arg)
-register ARG *arg;
-{
- static STR *str = Nullstr;
- 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 arg;
-
- if (!str)
- str = Str_new(20,0);
-
- if (arg[1].arg_type == A_SINGLE)
- s1 = arg[1].arg_ptr.arg_str;
- else
- s1 = Nullstr;
- if (arg->arg_len >= 2 && arg[2].arg_type == A_SINGLE)
- s2 = arg[2].arg_ptr.arg_str;
- else
- s2 = Nullstr;
-
-#define CHECK1 if (!s1) return arg
-#define CHECK2 if (!s2) return arg
-#define CHECK12 if (!s1 || !s2) return arg
-
- switch (arg->arg_type) {
- default:
- return arg;
- case O_SORT:
- if (arg[1].arg_type == A_CMD)
- arg[1].arg_type |= A_DONT;
- return arg;
- case O_EVAL:
- if (arg[1].arg_type == A_CMD) {
- arg->arg_type = O_TRY;
- arg[1].arg_type |= A_DONT;
- return arg;
- }
- CHECK1;
- arg->arg_type = O_EVALONCE;
- return arg;
- case O_AELEM:
- CHECK2;
- 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;
- str_free(s2);
- Renew(arg, 2, ARG);
- }
- return arg;
- case O_CONCAT:
- CHECK12;
- str_sset(str,s1);
- str_scat(str,s2);
- break;
- case O_REPEAT:
- CHECK2;
- if (dowarn && !s2->str_nok && !looks_like_number(s2))
- warn("Right operand of x is not numeric");
- CHECK1;
- i = (int)str_gnum(s2);
- tmps = str_get(s1);
- str_nset(str,"",0);
- if (i > 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:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,value * str_gnum(s2));
- break;
- case O_DIVIDE:
- CHECK12;
- value = str_gnum(s2);
- if (value == 0.0)
- yyerror("Illegal division by constant zero");
- else
-#ifdef SLOPPYDIVIDE
- /* insure that 20./5. == 4. */
- {
- double x;
- int k;
- x = str_gnum(s1);
- if ((double)(int)x == x &&
- (double)(int)value == value &&
- (k = (int)x/(int)value)*(int)value == (int)x) {
- value = k;
- } else {
- value = x/value;
- }
- str_numset(str,value);
- }
-#else
- str_numset(str,str_gnum(s1) / value);
-#endif
- break;
- case O_MODULO:
- CHECK12;
- tmplong = (unsigned long)str_gnum(s2);
- if (tmplong == 0L) {
- yyerror("Illegal modulus of constant zero");
- return arg;
- }
- value = str_gnum(s1);
-#ifndef lint
- if (value >= 0.0)
- str_numset(str,(double)(((unsigned long)value) % tmplong));
- else {
- tmp2 = (long)value;
- str_numset(str,(double)((tmplong-((-tmp2 - 1) % tmplong)) - 1));
- }
-#else
- tmp2 = tmp2;
-#endif
- break;
- case O_ADD:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,value + str_gnum(s2));
- break;
- case O_SUBTRACT:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,value - str_gnum(s2));
- break;
- case O_LEFT_SHIFT:
- CHECK12;
- value = str_gnum(s1);
- i = (int)str_gnum(s2);
-#ifndef lint
- str_numset(str,(double)(((long)value) << i));
-#endif
- break;
- case O_RIGHT_SHIFT:
- CHECK12;
- value = str_gnum(s1);
- i = (int)str_gnum(s2);
-#ifndef lint
- str_numset(str,(double)(((long)value) >> i));
-#endif
- break;
- case O_LT:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,(value < str_gnum(s2)) ? 1.0 : 0.0);
- break;
- case O_GT:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,(value > str_gnum(s2)) ? 1.0 : 0.0);
- break;
- case O_LE:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,(value <= str_gnum(s2)) ? 1.0 : 0.0);
- break;
- case O_GE:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,(value >= str_gnum(s2)) ? 1.0 : 0.0);
- break;
- case O_EQ:
- CHECK12;
- 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:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,(value != str_gnum(s2)) ? 1.0 : 0.0);
- break;
- case O_NCMP:
- CHECK12;
- value = str_gnum(s1);
- value -= str_gnum(s2);
- if (value > 0.0)
- value = 1.0;
- else if (value < 0.0)
- value = -1.0;
- str_numset(str,value);
- break;
- case O_BIT_AND:
- CHECK12;
- value = str_gnum(s1);
-#ifndef lint
- str_numset(str,(double)(U_L(value) & U_L(str_gnum(s2))));
-#endif
- break;
- case O_XOR:
- CHECK12;
- value = str_gnum(s1);
-#ifndef lint
- str_numset(str,(double)(U_L(value) ^ U_L(str_gnum(s2))));
-#endif
- break;
- case O_BIT_OR:
- CHECK12;
- value = str_gnum(s1);
-#ifndef lint
- str_numset(str,(double)(U_L(value) | U_L(str_gnum(s2))));
-#endif
- break;
- case O_AND:
- CHECK12;
- if (str_true(s1))
- str_sset(str,s2);
- else
- str_sset(str,s1);
- break;
- case O_OR:
- CHECK12;
- if (str_true(s1))
- str_sset(str,s1);
- else
- str_sset(str,s2);
- break;
- case O_COND_EXPR:
- CHECK12;
- if ((arg[3].arg_type & A_MASK) != A_SINGLE)
- return arg;
- 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);
- Renew(arg, 3, ARG);
- break;
- case O_NEGATE:
- CHECK1;
- str_numset(str,(double)(-str_gnum(s1)));
- break;
- case O_NOT:
- CHECK1;
-#ifdef NOTNOT
- { char xxx = str_true(s1); str_numset(str,(double)!xxx); }
-#else
- str_numset(str,(double)(!str_true(s1)));
-#endif
- break;
- case O_COMPLEMENT:
- CHECK1;
-#ifndef lint
- str_numset(str,(double)(~U_L(str_gnum(s1))));
-#endif
- break;
- case O_SIN:
- CHECK1;
- str_numset(str,sin(str_gnum(s1)));
- break;
- case O_COS:
- CHECK1;
- str_numset(str,cos(str_gnum(s1)));
- break;
- case O_ATAN2:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,atan2(value, str_gnum(s2)));
- break;
- case O_POW:
- CHECK12;
- value = str_gnum(s1);
- str_numset(str,pow(value, str_gnum(s2)));
- break;
- case O_LENGTH:
- if (arg[1].arg_type == A_STAB) {
- arg->arg_type = O_ITEM;
- arg[1].arg_type = A_LENSTAB;
- return arg;
- }
- CHECK1;
- str_numset(str, (double)str_len(s1));
- break;
- case O_SLT:
- CHECK12;
- str_numset(str,(double)(str_cmp(s1,s2) < 0));
- break;
- case O_SGT:
- CHECK12;
- str_numset(str,(double)(str_cmp(s1,s2) > 0));
- break;
- case O_SLE:
- CHECK12;
- str_numset(str,(double)(str_cmp(s1,s2) <= 0));
- break;
- case O_SGE:
- CHECK12;
- str_numset(str,(double)(str_cmp(s1,s2) >= 0));
- break;
- case O_SEQ:
- CHECK12;
- str_numset(str,(double)(str_eq(s1,s2)));
- break;
- case O_SNE:
- CHECK12;
- str_numset(str,(double)(!str_eq(s1,s2)));
- break;
- case O_SCMP:
- CHECK12;
- str_numset(str,(double)(str_cmp(s1,s2)));
- break;
- case O_CRYPT:
- CHECK12;
-#ifdef HAS_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:
- CHECK1;
- str_numset(str,exp(str_gnum(s1)));
- break;
- case O_LOG:
- CHECK1;
- str_numset(str,log(str_gnum(s1)));
- break;
- case O_SQRT:
- CHECK1;
- str_numset(str,sqrt(str_gnum(s1)));
- break;
- case O_INT:
- CHECK1;
- 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:
- CHECK1;
-#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;
- }
- arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */
- str_free(s1);
- arg[1].arg_ptr.arg_str = str;
- if (s2) {
- str_free(s2);
- arg[2].arg_ptr.arg_str = Nullstr;
- arg[2].arg_type = A_NULL;
- }
- str = Nullstr;
-
- return arg;
-}
-
-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;
- case O_SUBSTR: case O_VEC:
- (void)l(arg1[i].arg_ptr.arg_arg);
- Renewc(arg1[i].arg_ptr.arg_arg->arg_ptr.arg_str, 1,
- struct lstring, STR);
- /* grow string struct to hold an lstring struct */
- 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;
- arg1[1].arg_ptr.arg_stab = Nullstab;
- spat->spat_flags |= SPAT_ONCE;
- arg_free(arg1); /* recursive */
- arg[1].arg_ptr.arg_arg = Nullarg;
- 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) {
- dehoist(arg,2);
- 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) {
- dehoist(arg,2);
- 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)
- /*SUPPRESS 530*/
- ;
- else {
- (void)sprintf(tokenbuf,
- "Illegal expression (%s) as lvalue",opname[arg1->arg_type]);
- yyerror(tokenbuf);
- return arg;
- }
- 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);
- return arg;
- }
- 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;
-}
-
-void
-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 */
- 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;
- StructCopy(node, arg, ARG); /* copy everything except the STR */
- arg->arg_ptr.arg_str = tmpstr;
- for (j = i; ; ) {
- StructCopy(node+2, arg+j, ARG);
- arg[j].arg_flags |= AF_ARYOK;
- --j; /* Bug in Xenix compiler */
- if (j < 2) {
- StructCopy(node+1, arg+1, ARG);
- 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;
- str_free(arg->arg_ptr.arg_str);
- arg->arg_ptr.arg_str = Nullstr;
- return arg;
-}
-
-/* turn a single item into a list */
-
-ARG *
-listish(arg)
-ARG *arg;
-{
- if (arg && arg->arg_flags & AF_LISTISH)
- arg = make_op(O_LIST,1,arg,Nullarg,Nullarg);
- return arg;
-}
-
-ARG *
-maybelistish(optype, arg)
-int optype;
-ARG *arg;
-{
- ARG *tmparg = arg;
-
- if (optype == O_RETURN && arg->arg_type == O_ITEM &&
- arg[1].arg_type == A_EXPR && (tmparg = arg[1].arg_ptr.arg_arg) &&
- ((tmparg->arg_flags & AF_LISTISH) || (tmparg->arg_type == O_ARRAY) )) {
- tmparg = listish(tmparg);
- free_arg(arg);
- arg = tmparg;
- }
- else 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 *
-rcatmaybe(arg)
-ARG *arg;
-{
- ARG *arg2;
-
- if (arg->arg_type == O_CONCAT && 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) {
- arg->arg_type = O_RCAT;
- arg[2].arg_type = arg2[1].arg_type;
- arg[2].arg_ptr = arg2[1].arg_ptr;
- free_arg(arg2);
- }
- }
- 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 {} */
- stab_lastexpr(defstab) = thisexpr; /* pretend to hit @_ */
- 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 = scanident(s,send,tokenbuf);
- stab = stabent(tokenbuf,TRUE);
- if (marking)
- stab_lastexpr(stab) = exprnum;
- else if (stab_lastexpr(stab) == exprnum)
- return 1;
- continue;
- }
- else if (*s == '\\' && s[1])
- s++;
- s++;
- }
- }
- break;
- case A_SPAT:
- if (spat_common(arg[i].arg_ptr.arg_spat,exprnum,marking))
- return 1;
- break;
- case A_READ:
- case A_INDREAD:
- case A_GLOB:
- case A_WORD:
- case A_SINGLE:
- break;
- }
- }
- switch (arg->arg_type) {
- case O_ARRAY:
- case O_LARRAY:
- if ((arg[1].arg_type & A_MASK) == A_STAB)
- (void)aadd(arg[1].arg_ptr.arg_stab);
- break;
- case O_HASH:
- case O_LHASH:
- if ((arg[1].arg_type & A_MASK) == A_STAB)
- (void)hadd(arg[1].arg_ptr.arg_stab);
- break;
- case O_EVAL:
- case O_SUBR:
- case O_DBSUBR:
- return 1;
- }
- return 0;
-}
-
-static int
-spat_common(spat,exprnum,marking)
-register SPAT *spat;
-int exprnum;
-int marking;
-{
- if (spat->spat_runtime)
- if (arg_common(spat->spat_runtime,exprnum,marking))
- return 1;
- if (spat->spat_repl) {
- if (arg_common(spat->spat_repl,exprnum,marking))
- return 1;
- }
- return 0;
-}
--- /dev/null
+/* $RCSfile: cmd.h,v $$Revision: 4.1 $$Date: 92/08/07 17:19:19 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: cmd.h,v $
+ * Revision 4.1 92/08/07 17:19:19 lwall
+ * Stage 6 Snapshot
+ *
+ * Revision 4.0.1.2 92/06/08 12:01:02 lwall
+ * patch20: removed implicit int declarations on funcions
+ *
+ * Revision 4.0.1.1 91/06/07 10:28:50 lwall
+ * patch4: new copyright notice
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ *
+ * Revision 4.0 91/03/20 01:04:34 lwall
+ * 4.0 baseline.
+ *
+ */
+
+struct acop {
+ GV *acop_gv; /* a symbol table entry */
+ OP *acop_expr; /* any associated expression */
+};
+
+struct ccop {
+ OP *ccop_true; /* normal code to do on if and while */
+ OP *ccop_alt; /* else cmd ptr or continue code */
+};
+
+struct scop {
+ OP **scop_next; /* array of pointers to commands */
+ short scop_offset; /* first value - 1 */
+ short scop_max; /* last value + 1 */
+};
+
+struct cop {
+ BASEOP
+ OP *cop_expr; /* conditional expression */
+ OP *cop_head; /* head of this command list */
+ SV *cop_short; /* string to match as shortcut */
+ GV *cop_gv; /* a symbol table entry, mostly for fp */
+ char *cop_label; /* label for this construct */
+ union uop {
+ struct acop acop; /* normal command */
+ struct ccop ccop; /* compound command */
+ struct scop scop; /* switch command */
+ } uop;
+ short cop_slen; /* len of cop_short, if not null */
+ VOL short cop_flags; /* optimization flags--see above */
+ HV * cop_stash; /* package line was compiled in */
+ GV * cop_filegv; /* file the following line # is from */
+ line_t cop_line; /* line # of this command */
+ char cop_type; /* what this command does */
+};
+
+#define Nullcop Null(COP*)
+
+/*
+ * Here we have some enormously heavy (or at least ponderous) wizardry.
+ */
+
+/* subroutine context */
+struct block_sub {
+ CV * cv;
+ GV * gv;
+ GV * defgv;
+ AV * savearray;
+ AV * argarray;
+ U16 olddepth;
+ U8 hasargs;
+};
+
+#define PUSHSUB(cx) \
+ cx->blk_sub.cv = cv; \
+ cx->blk_sub.gv = gv; \
+ cx->blk_sub.olddepth = CvDEPTH(cv); \
+ cx->blk_sub.hasargs = hasargs;
+
+#define PUSHFORMAT(cx) \
+ cx->blk_sub.cv = cv; \
+ cx->blk_sub.gv = gv; \
+ cx->blk_sub.defgv = defoutgv; \
+ cx->blk_sub.hasargs = 0;
+
+#define POPSUB(cx) \
+ if (cx->blk_sub.hasargs) { /* put back old @_ */ \
+ av_free(cx->blk_sub.argarray); \
+ GvAV(defgv) = cx->blk_sub.savearray; \
+ } \
+ if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \
+ if (CvDELETED(cx->blk_sub.cv)) \
+ cv_free(cx->blk_sub.cv); \
+ }
+
+#define POPFORMAT(cx) \
+ defoutgv = cx->blk_sub.defgv;
+
+/* eval context */
+struct block_eval {
+ I32 old_in_eval;
+ I32 old_op_type;
+ char * old_name;
+ OP * old_eval_root;
+};
+
+#define PUSHEVAL(cx,n) \
+ cx->blk_eval.old_in_eval = in_eval; \
+ cx->blk_eval.old_op_type = op->op_type; \
+ cx->blk_eval.old_name = n; \
+ cx->blk_eval.old_eval_root = eval_root;
+
+#define POPEVAL(cx) \
+ in_eval = cx->blk_eval.old_in_eval; \
+ optype = cx->blk_eval.old_op_type; \
+ eval_root = cx->blk_eval.old_eval_root;
+
+/* loop context */
+struct block_loop {
+ char * label;
+ I32 resetsp;
+ OP * redo_op;
+ OP * next_op;
+ OP * last_op;
+ SV ** itervar;
+ SV * itersave;
+ AV * iterary;
+ I32 iterix;
+};
+
+#define PUSHLOOP(cx, ivar, s) \
+ cx->blk_loop.label = curcop->cop_label; \
+ cx->blk_loop.resetsp = s - stack_base; \
+ cx->blk_loop.redo_op = cLOOP->op_redoop; \
+ cx->blk_loop.next_op = cLOOP->op_nextop; \
+ cx->blk_loop.last_op = cLOOP->op_lastop; \
+ cx->blk_loop.itervar = ivar; \
+ if (ivar) \
+ cx->blk_loop.itersave = *cx->blk_loop.itervar;
+
+#define POPLOOP(cx) \
+ newsp = stack_base + cx->blk_loop.resetsp; \
+ if (cx->blk_loop.itervar) \
+ *cx->blk_loop.itervar = cx->blk_loop.itersave;
+
+/* context common to subroutines, evals and loops */
+struct block {
+ I32 blku_oldsp; /* stack pointer to copy stuff down to */
+ COP * blku_oldcop; /* old curcop pointer */
+ I32 blku_oldretsp; /* return stack index */
+ I32 blku_oldmarksp; /* mark stack index */
+ I32 blku_oldscopesp; /* scope stack index */
+ PMOP * blku_oldpm; /* values of pattern match vars */
+ U8 blku_gimme; /* is this block running in list context? */
+
+ union {
+ struct block_sub blku_sub;
+ struct block_eval blku_eval;
+ struct block_loop blku_loop;
+ } blk_u;
+};
+#define blk_oldsp cx_u.cx_blk.blku_oldsp
+#define blk_oldcop cx_u.cx_blk.blku_oldcop
+#define blk_oldretsp cx_u.cx_blk.blku_oldretsp
+#define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp
+#define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp
+#define blk_oldpm cx_u.cx_blk.blku_oldpm
+#define blk_gimme cx_u.cx_blk.blku_gimme
+#define blk_sub cx_u.cx_blk.blk_u.blku_sub
+#define blk_eval cx_u.cx_blk.blk_u.blku_eval
+#define blk_loop cx_u.cx_blk.blk_u.blku_loop
+
+/* Enter a block. */
+#define PUSHBLOCK(cx,t,s) CXINC, cx = &cxstack[cxstack_ix], \
+ cx->cx_type = t, \
+ cx->blk_oldsp = s - stack_base, \
+ cx->blk_oldcop = curcop, \
+ cx->blk_oldmarksp = markstack_ptr - markstack, \
+ cx->blk_oldscopesp = scopestack_ix, \
+ cx->blk_oldretsp = retstack_ix, \
+ cx->blk_oldpm = curpm, \
+ cx->blk_gimme = gimme; \
+ if (debug & 4) \
+ fprintf(stderr,"Entering block %d, type %d\n", \
+ cxstack_ix, t);
+
+/* Exit a block (RETURN and LAST). */
+#define POPBLOCK(cx) cx = &cxstack[cxstack_ix--], \
+ newsp = stack_base + cx->blk_oldsp, \
+ curcop = cx->blk_oldcop, \
+ markstack_ptr = markstack + cx->blk_oldmarksp, \
+ scopestack_ix = cx->blk_oldscopesp, \
+ retstack_ix = cx->blk_oldretsp, \
+ curpm = cx->blk_oldpm, \
+ gimme = cx->blk_gimme; \
+ if (debug & 4) \
+ fprintf(stderr,"Leaving block %d, type %d\n", \
+ cxstack_ix+1,cx->cx_type);
+
+/* Continue a block elsewhere (NEXT and REDO). */
+#define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \
+ stack_sp = stack_base + cx->blk_oldsp, \
+ markstack_ptr = markstack + cx->blk_oldmarksp, \
+ scopestack_ix = cx->blk_oldscopesp, \
+ retstack_ix = cx->blk_oldretsp
+
+/* substitution context */
+struct subst {
+ I32 sbu_iters;
+ I32 sbu_maxiters;
+ I32 sbu_safebase;
+ I32 sbu_once;
+ char * sbu_orig;
+ SV * sbu_dstr;
+ SV * sbu_targ;
+ char * sbu_s;
+ char * sbu_m;
+ char * sbu_strend;
+ char * sbu_subbase;
+};
+#define sb_iters cx_u.cx_subst.sbu_iters
+#define sb_maxiters cx_u.cx_subst.sbu_maxiters
+#define sb_safebase cx_u.cx_subst.sbu_safebase
+#define sb_once cx_u.cx_subst.sbu_once
+#define sb_orig cx_u.cx_subst.sbu_orig
+#define sb_dstr cx_u.cx_subst.sbu_dstr
+#define sb_targ cx_u.cx_subst.sbu_targ
+#define sb_s cx_u.cx_subst.sbu_s
+#define sb_m cx_u.cx_subst.sbu_m
+#define sb_strend cx_u.cx_subst.sbu_strend
+#define sb_subbase cx_u.cx_subst.sbu_subbase
+
+#define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
+ cx->sb_iters = iters, \
+ cx->sb_maxiters = maxiters, \
+ cx->sb_safebase = safebase, \
+ cx->sb_once = once, \
+ cx->sb_orig = orig, \
+ cx->sb_dstr = dstr, \
+ cx->sb_targ = targ, \
+ cx->sb_s = s, \
+ cx->sb_m = m, \
+ cx->sb_strend = strend, \
+ cx->cx_type = CXt_SUBST
+
+#define POPSUBST(cx) cxstack_ix--
+
+struct context {
+ I32 cx_type; /* what kind of context this is */
+ union {
+ struct block cx_blk;
+ struct subst cx_subst;
+ } cx_u;
+};
+#define CXt_NULL 0
+#define CXt_SUB 1
+#define CXt_EVAL 2
+#define CXt_LOOP 3
+#define CXt_SUBST 4
+#define CXt_BLOCK 5
+
+#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
+
+/* "gimme" values */
+#define G_SCALAR 0
+#define G_ARRAY 1
+
--- /dev/null
+/* $RCSfile: cv.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:42 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: cv.h,v $
+ */
+
+struct xpvcv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xp_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ STRLEN xof_off; /* ptr is incremented by offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* magic for scalar array */
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ OP * xcv_start;
+ OP * xcv_root;
+ I32 (*xcv_usersub)();
+ I32 xcv_userindex;
+ GV * xcv_filegv;
+ long xcv_depth; /* >= 2 indicates recursive call */
+ AV * xcv_padlist;
+ bool xcv_deleted;
+};
+#define Nullcv Null(CV*)
+#define CvSTASH(sv) ((XPVCV*)SvANY(sv))->xcv_stash
+#define CvSTART(sv) ((XPVCV*)SvANY(sv))->xcv_start
+#define CvROOT(sv) ((XPVCV*)SvANY(sv))->xcv_root
+#define CvUSERSUB(sv) ((XPVCV*)SvANY(sv))->xcv_usersub
+#define CvUSERINDEX(sv) ((XPVCV*)SvANY(sv))->xcv_userindex
+#define CvFILEGV(sv) ((XPVCV*)SvANY(sv))->xcv_filegv
+#define CvDEPTH(sv) ((XPVCV*)SvANY(sv))->xcv_depth
+#define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist
+#define CvDELETED(sv) ((XPVCV*)SvANY(sv))->xcv_deleted
+
--- /dev/null
+/* $RCSfile: op.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:16 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: op.c,v $
+ * Revision 4.1 92/08/07 17:19:16 lwall
+ * Stage 6 Snapshot
+ *
+ * Revision 4.0.1.5 92/06/08 12:00:39 lwall
+ * patch20: the switch optimizer didn't do anything in subroutines
+ * patch20: removed implicit int declarations on funcions
+ *
+ * Revision 4.0.1.4 91/11/11 16:29:33 lwall
+ * patch19: do {$foo ne "bar";} returned wrong value
+ * patch19: some earlier patches weren't propagated to alternate 286 code
+ *
+ * Revision 4.0.1.3 91/11/05 16:07:43 lwall
+ * patch11: random cleanup
+ * patch11: "foo\0" eq "foo" was sometimes optimized to true
+ * patch11: foreach on null list could spring memory leak
+ *
+ * Revision 4.0.1.2 91/06/07 10:26:45 lwall
+ * patch4: new copyright notice
+ * patch4: made some allowances for "semi-standard" C
+ *
+ * Revision 4.0.1.1 91/04/11 17:36:16 lwall
+ * patch1: you may now use "die" and "caller" in a signal handler
+ *
+ * Revision 4.0 91/03/20 01:04:18 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef I_VARARGS
+# include <varargs.h>
+#endif
+
+void deb_growlevel();
+
+# ifndef I_VARARGS
+/*VARARGS1*/
+void deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
+char *pat;
+{
+ register I32 i;
+
+ fprintf(stderr,"%-4ld",(long)curop->cop_line);
+ for (i=0; i<dlevel; i++)
+ fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
+ fprintf(stderr,pat,a1,a2,a3,a4,a5,a6,a7,a8);
+}
+# else
+/*VARARGS1*/
+void deb(va_alist)
+va_dcl
+{
+ va_list args;
+ char *pat;
+ register I32 i;
+
+ va_start(args);
+ fprintf(stderr,"%-4ld",(long)curcop->cop_line);
+ for (i=0; i<dlevel; i++)
+ fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
+
+ pat = va_arg(args, char *);
+ (void) vfprintf(stderr,pat,args);
+ va_end( args );
+}
+# endif
+
+void
+deb_growlevel()
+{
+ dlmax += 128;
+ Renew(debname, dlmax, char);
+ Renew(debdelim, dlmax, char);
+}
+
+I32
+debstackptrs()
+{
+ fprintf(stderr, "%8lx %8lx %8ld %8ld %8ld\n",
+ stack, stack_base, *markstack_ptr, stack_sp-stack_base, stack_max-stack_base);
+ fprintf(stderr, "%8lx %8lx %8ld %l8d %8ld\n",
+ mainstack, AvARRAY(stack), mainstack, AvFILL(stack), AvMAX(stack));
+ return 0;
+}
+
+I32
+debstack()
+{
+ register I32 i;
+ I32 markoff = markstack_ptr > markstack ? *markstack_ptr : -1;
+
+ fprintf(stderr, " =>");
+ if (stack_base[0] || stack_sp < stack_base)
+ fprintf(stderr, " [STACK UNDERFLOW!!!]\n");
+ for (i = 1; i <= 30; i++) {
+ if (stack_sp >= &stack_base[i])
+ {
+ fprintf(stderr, "\t%-4s%s%s", SvPEEK(stack_base[i]),
+ markoff == i ? " [" : "",
+ stack_sp == &stack_base[i] ?
+ (markoff == i ? "]" : " ]") : "");
+ }
+ }
+ fprintf(stderr, "\n");
+ return 0;
+}
--- /dev/null
+ if (debug & 4) {
+/* fprintf(stderr, "%8lx %8lx %8ld %8ld %8ld\n",
+ stack, stack_base, *markstack_ptr, stack_sp-stack_base, stack_max-stack_base);
+ fprintf(stderr, "%8lx %8lx %8ld %l8d %8ld\n",
+ curstack, stack->av_array, curstack, stack->av_fill, stack->av_max);
+*/
+ fprintf(stderr, "STACK");
+ for (i = 0; i <= 30; i++) {
+ if (stack->av_array[i] || stack->av_array[i+1] || stack->av_array[i+2])
+ fprintf(stderr, "\t%s%s", SvPEEK(stack->av_array[i]),
+ stack_sp == &stack->av_array[i] ? " *" : "");
+ }
+ fprintf(stderr, "\n");
+ }
--- /dev/null
+
+# perl
+# - location of uperl.o and include files
+PERL = ../perl-lib
+# - libraries required by perl - from config.sh
+PERL_LIBS = -ldbm -lm -lposix
+
+UPERL = $(PERL)/uperl4.035.o
+UPERL = ../sybperl/uperl2.o
+
+DP_C = \
+ dlperl.c \
+ usersub.c
+
+DP_H =
+
+
+CC = gcc-2.2.2
+CPPFLAGS= -I$(PERL)
+#CFLAGS = -g
+
+ALL = \
+ dlperl
+
+
+all: $(ALL) tags
+
+dlperl: $(UPERL) $(DP_C:.c=.o)
+ $(LINK.c) -o dlperl $(UPERL) $(DP_C:.c=.o) \
+ $(PERL_LIBS) \
+ -ldl -lc.1.6
+ ld-rules -clobber dlperl
+
+dlperl.s: dlperl.c
+ $(COMPILE.c) -S $(OUTPUT_OPTION) dlperl.c
+
+tags: $(DP_C) $(DP_H)
+ ctags $(DP_C) $(DP_H)
+
+lint:
+ $(LINT.c) $(DP_C) $(LINT_LN)
+
+clean:
+ rm -f core *.o
+
+clobber: clean
+ rm -f $(ALL) tags
+
+install:
+
+.KEEP_STATE:
--- /dev/null
+static char sccsid[] = "@(#)dlperl.c 1.2 10/12/92 (DLPERL)";
+
+/*
+ * name: dlperl.c
+ * synopsis: dlperl - perl interface to dynamically linked usubs
+ * sccsid: @(#)dlperl.c 1.2 10/12/92
+ */
+
+/*
+ * NOTE: this code is *not* portable
+ * - uses SPARC assembler with gcc asm extensions
+ * - is SPARC ABI specific
+ * - uses SunOS 4.x dlopen
+ *
+ * NOTE: not all types are currently implemented
+ * - multiple indirections (pointers to pointers, etc.)
+ * - structures
+ * - quad-precison (long double)
+ */
+
+#include <dlfcn.h>
+#include <alloca.h>
+#include <ctype.h>
+
+/* perl */
+#include "EXTERN.h"
+#include "perl.h"
+
+/* globals */
+int Dl_warn = 1;
+int Dl_errno;
+#define DL_ERRSTR_SIZ 256
+char Dl_errstr[DL_ERRSTR_SIZ];
+#define WORD_SIZE (sizeof(int))
+
+static int userval();
+static int userset();
+static int usersub();
+
+
+/*
+ * glue perl subroutines and variables to dlperl functions
+ */
+enum usersubs {
+ US_dl_open,
+ US_dl_sym,
+ US_dl_call,
+ US_dl_close,
+};
+
+enum uservars {
+ UV_DL_VERSION,
+ UV_DL_WARN,
+ UV_dl_errno,
+ UV_dl_errstr,
+};
+
+
+int
+dlperl_init()
+{
+ struct ufuncs uf;
+ char *file = "dlperl.c";
+
+ uf.uf_val = userval;
+ uf.uf_set = userset;
+
+#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
+
+ /* subroutines */
+ make_usub("dl_open", US_dl_open, usersub, file);
+ make_usub("dl_sym", US_dl_sym, usersub, file);
+ make_usub("dl_call", US_dl_call, usersub, file);
+ make_usub("dl_close", US_dl_close, usersub, file);
+
+ /* variables */
+ MAGICVAR("DL_VERSION", (int) UV_DL_VERSION);
+ MAGICVAR("DL_WARN", (int) UV_DL_WARN);
+ MAGICVAR("dl_errno", (int) UV_dl_errno);
+ MAGICVAR("dl_errstr", (int) UV_dl_errstr);
+
+ return 0;
+}
+
+
+/*
+ * USERVAL AND USERSET
+ */
+
+/*
+ * assign dlperl variables to perl variables
+ */
+/*ARGSUSED*/
+static int
+userval(ix, str)
+int ix;
+STR *str;
+{
+ switch(ix) {
+ case UV_DL_VERSION:
+ str_set(str, sccsid);
+ break;
+ case UV_DL_WARN:
+ str_numset(str, (double) Dl_warn);
+ break;
+ case UV_dl_errno:
+ str_numset(str, (double) Dl_errno);
+ break;
+ case UV_dl_errstr:
+ str_set(str, Dl_errstr);
+ break;
+ default:
+ fatal("dlperl: unimplemented userval");
+ break;
+ }
+ return 0;
+}
+
+/*
+ * assign perl variables to dlperl variables
+ */
+static int
+userset(ix, str)
+int ix;
+STR *str;
+{
+ switch(ix) {
+ case UV_DL_WARN:
+ Dl_warn = (int) str_gnum(str);
+ break;
+ default:
+ fatal("dlperl: unimplemented userset");
+ break;
+ }
+ return 0;
+}
+
+
+/*
+ * USERSUBS
+ */
+static int
+usersub(ix, sp, items)
+int ix;
+register int sp;
+register int items;
+{
+ int oldsp = sp;
+ STR **st = stack->ary_array + sp;
+ register STR *Str; /* used in str_get and str_gnum macros */
+
+ Dl_errno = 0;
+ *Dl_errstr = '\0';
+
+ switch(ix) {
+ case US_dl_open:
+ {
+ char *file;
+ void *dl_so;
+
+ if(items != 1) {
+ fatal("Usage: $dl_so = &dl_open($file)");
+ return oldsp;
+ }
+
+ file = str_get(st[1]);
+ dl_so = dlopen(file, 1);
+
+ --sp;
+ if(dl_so == NULL) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_open: %s", dlerror());
+ if(Dl_warn) warn(Dl_errstr);
+
+ astore(stack, ++sp, str_mortal(&str_undef));
+ } else {
+ astore(stack, ++sp, str_2mortal(str_make(
+ (char *) &dl_so, sizeof(void *))));
+ }
+ break;
+ }
+ case US_dl_sym:
+ {
+ void *dl_so;
+ char *symbol;
+ void *dl_func;
+
+ if(items != 2) {
+ fatal("Usage: $dl_func = &dl_sym($dl_so, $symbol)");
+ return oldsp;
+ }
+
+ dl_so = *(void **) str_get(st[1]);
+ symbol = str_get(st[2]);
+ dl_func = dlsym(dl_so, symbol);
+
+ --sp;
+ if(dl_func == NULL) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_sym: %s", dlerror());
+ if(Dl_warn) warn(Dl_errstr);
+
+ astore(stack, ++sp, str_mortal(&str_undef));
+ } else {
+ astore(stack, ++sp, str_2mortal(str_make(
+ (char *) &dl_func, sizeof(void *))));
+ }
+ break;
+ }
+ case US_dl_call:
+ {
+ void *dl_func;
+ char *parms_desc, *return_desc;
+ int nstack, nparm, narr, nlen, nrep;
+ int f_indirect, f_no_parm, f_result;
+ char c, *c_p; int c_pn = 0;
+ unsigned char C, *C_p; int C_pn = 0;
+ short s, *s_p; int s_pn = 0;
+ unsigned short S, *S_p; int S_pn = 0;
+ int i, *i_p; int i_pn = 0;
+ unsigned int I, *I_p; int I_pn = 0;
+ long l, *l_p; int l_pn = 0;
+ unsigned long L, *L_p; int L_pn = 0;
+ float f, *f_p; int f_pn = 0;
+ double d, *d_p; int d_pn = 0;
+ char *a, **a_p; int a_pn = 0;
+ char *p, **p_p; int p_pn = 0;
+ unsigned int *stack_base, *stack_p;
+ unsigned int *xp;
+ void (*func)();
+ unsigned int ret_o;
+ double ret_fd;
+ float ret_f;
+ char *c1;
+ int n1, n2;
+
+ if(items < 3) {
+fatal("Usage: @vals = &dl_call($dl_func, $parms_desc, $return_desc, @parms)");
+ return oldsp;
+ }
+ dl_func = *(void **) str_get(st[1]);
+ parms_desc = str_get(st[2]);
+ return_desc = str_get(st[3]);
+
+ /* determine size of stack and temporaries */
+# define CNT_STK_TMP(PN, SN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ PN += narr; \
+ ++nstack; \
+ if(!f_no_parm) \
+ nparm += narr; \
+ } else { \
+ nstack += SN; \
+ if(!f_no_parm) \
+ ++nparm; \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_no_parm = narr = nrep = 0;
+
+ nstack = 0;
+ nparm = 0;
+ f_indirect = f_no_parm = narr = nrep = 0;
+ for(c1 = parms_desc;*c1;++c1) {
+ switch(*c1) {
+ case ' ':
+ case '\t':
+ break;
+
+ case 'c': /* signed char */
+ CNT_STK_TMP(c_pn, 1);
+ break;
+ case 'C': /* unsigned char */
+ CNT_STK_TMP(C_pn, 1);
+ break;
+ case 's': /* signed short */
+ CNT_STK_TMP(s_pn, 1);
+ break;
+ case 'S': /* unsigned short */
+ CNT_STK_TMP(S_pn, 1);
+ break;
+ case 'i': /* signed int */
+ CNT_STK_TMP(i_pn, 1);
+ break;
+ case 'I': /* unsigned int */
+ CNT_STK_TMP(I_pn, 1);
+ break;
+ case 'l': /* signed long */
+ CNT_STK_TMP(l_pn, 1);
+ break;
+ case 'L': /* unsigned long */
+ CNT_STK_TMP(L_pn, 1);
+ break;
+ case 'f': /* float */
+ CNT_STK_TMP(f_pn, 1);
+ break;
+ case 'd': /* double */
+ CNT_STK_TMP(d_pn, 2);
+ break;
+ case 'a': /* ascii (null-terminated) string */
+ CNT_STK_TMP(a_pn, 1);
+ break;
+ case 'p': /* pointer to <nlen> buffer */
+ CNT_STK_TMP(p_pn, 1);
+ break;
+
+ case '&': /* pointer = [1] */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ narr = 1;
+ break;
+ case '[': /* array */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ narr = narr * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != ']') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected ]",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '<': /* length */
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1))
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != '>') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected >",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '+':
+ break;
+ case '-':
+ f_no_parm = 1;
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ if(nrep) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: too many repeats");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ while(isdigit(*c1)) {
+ nrep = nrep * 10 + (*c1 - '0');
+ ++c1;
+ }
+ --c1;
+ break;
+ default:
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ }
+ /* trailing &[]<>+-0-9 is ignored */
+ if(nparm != items - 3) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: bad parameter count %d, expected %d",
+ items - 3, nparm);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ nparm = 4;
+
+ /* allocate temporaries */
+ if((c_pn && (c_p = (char *)
+ alloca(c_pn * sizeof(char))) == NULL) ||
+ (C_pn && (C_p = (unsigned char *)
+ alloca(C_pn * sizeof(unsigned char))) == NULL) ||
+ (s_pn && (s_p = (short *)
+ alloca(s_pn * sizeof(short))) == NULL) ||
+ (S_pn && (S_p = (unsigned short *)
+ alloca(S_pn * sizeof(unsigned short))) == NULL) ||
+ (i_pn && (i_p = (int *)
+ alloca(i_pn * sizeof(int))) == NULL) ||
+ (I_pn && (I_p = (unsigned int *)
+ alloca(I_pn * sizeof(unsigned int))) == NULL) ||
+ (l_pn && (l_p = (long *)
+ alloca(l_pn * sizeof(long))) == NULL) ||
+ (L_pn && (L_p = (unsigned long *)
+ alloca(L_pn * sizeof(unsigned long))) == NULL) ||
+ (f_pn && (f_p = (float *)
+ alloca(f_pn * sizeof(float))) == NULL) ||
+ (d_pn && (d_p = (double *)
+ alloca(d_pn * sizeof(double))) == NULL) ||
+ (a_pn && (a_p = (char **)
+ alloca(a_pn * sizeof(char *))) == NULL) ||
+ (p_pn && (p_p = (char **)
+ alloca(p_pn * sizeof(char *))) == NULL)) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_call: bad alloca");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+
+ /* grow stack - maintains stack alignment (double word) */
+ /* NOTE: no functions should be called otherwise the stack */
+ /* that is being built will be corrupted */
+ /* NOTE: some of the stack is pre-allocated, but is not */
+ /* reused here */
+ if(alloca(nstack * WORD_SIZE) == NULL) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_call: bad alloca");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+
+ /* stack base */
+#if !defined(lint)
+ asm("add %%sp,68,%%o0;st %%o0,%0" :
+ "=g" (stack_base) : /* input */ : "%%o0");
+#else
+ stack_base = 0;
+#endif
+ stack_p = stack_base;
+
+ /* layout stack */
+# define LAY_STK_NUM(T, P, PN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ *stack_p++ = (unsigned int) &P[PN]; \
+ if(f_no_parm) { \
+ PN += narr; \
+ } else { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ P[PN++] = (T) \
+ str_gnum(st[nparm++]); \
+ } \
+ } \
+ } else { \
+ if(f_no_parm) { \
+ ++stack_p; \
+ } else { \
+ *stack_p++ = (T) \
+ str_gnum(st[nparm++]); \
+ } \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_no_parm = narr = nrep = 0;
+
+# define LAY_STK_DOUBLE(T, P, PN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ *stack_p++ = (unsigned int) &P[PN]; \
+ if(f_no_parm) { \
+ PN += narr; \
+ } else { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ P[PN++] = (T) \
+ str_gnum(st[nparm++]); \
+ } \
+ } \
+ } else { \
+ if(f_no_parm) { \
+ stack_p += 2; \
+ } else { \
+ d = (T) str_gnum(st[nparm++]); \
+ xp = (unsigned int *) &d; \
+ *stack_p++ = *xp++; \
+ *stack_p++ = *xp; \
+ } \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_no_parm = narr = nrep = 0;
+
+# define LAY_STK_STR(P, PN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ *stack_p++ = (unsigned int) &P[PN]; \
+ if(f_no_parm) { \
+ PN += narr; \
+ } else { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ P[PN++] = \
+ str_get(st[nparm++]); \
+ } \
+ } \
+ } else { \
+ if(f_no_parm) { \
+ ++stack_p; \
+ } else { \
+ *stack_p++ = (unsigned int) \
+ str_get(st[nparm++]); \
+ } \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_no_parm = narr = nrep = 0;
+
+ c_pn = C_pn = s_pn = S_pn = i_pn = I_pn = l_pn = L_pn = 0;
+ f_pn = d_pn = a_pn = p_pn = 0;
+ f_indirect = f_no_parm = narr = nrep = 0;
+ for(c1 = parms_desc;*c1;++c1) {
+ switch(*c1) {
+ case ' ':
+ case '\t':
+ break;
+
+ case 'c': /* signed char */
+ LAY_STK_NUM(char, c_p, c_pn);
+ break;
+ case 'C': /* unsigned char */
+ LAY_STK_NUM(unsigned char, C_p, C_pn);
+ break;
+ case 's': /* signed short */
+ LAY_STK_NUM(short, s_p, s_pn);
+ break;
+ case 'S': /* unsigned short */
+ LAY_STK_NUM(unsigned short, S_p, S_pn);
+ break;
+ case 'i': /* signed int */
+ LAY_STK_NUM(int, i_p, i_pn);
+ break;
+ case 'I': /* unsigned int */
+ LAY_STK_NUM(unsigned int, I_p, I_pn);
+ break;
+ case 'l': /* signed long */
+ LAY_STK_NUM(long, l_p, l_pn);
+ break;
+ case 'L': /* unsigned long */
+ LAY_STK_NUM(unsigned long, L_p, L_pn);
+ break;
+ case 'f': /* float */
+ LAY_STK_NUM(float, f_p, f_pn);
+ break;
+ case 'd': /* double */
+ LAY_STK_DOUBLE(double, d_p, d_pn);
+ break;
+ case 'a': /* ascii (null-terminated) string */
+ LAY_STK_STR(a_p, a_pn);
+ break;
+ case 'p': /* pointer to <nlen> buffer */
+ LAY_STK_STR(p_p, p_pn);
+ break;
+
+ case '&': /* pointer = [1] */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ narr = 1;
+ break;
+ case '[': /* array */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ narr = narr * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != ']') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected ]",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '<': /* length */
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1))
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != '>') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected >",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '+':
+ break;
+ case '-':
+ f_no_parm = 1;
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ if(nrep) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: too many repeats");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ while(isdigit(*c1)) {
+ nrep = nrep * 10 + (*c1 - '0');
+ ++c1;
+ }
+ --c1;
+ break;
+ default:
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ }
+ /* trailing &[]<>+-0-9 is ignored */
+
+ /* call function */
+ /* NOTE: the first 6 words are passed in registers %o0 - %o5 */
+ /* %sp+68 to %sp+92 are vacant, but allocated */
+ /* and shadow %o0 - %o5 */
+ /* above stack_base starts at %sp+68 and the function */
+ /* call below sets up %o0 - %o5 from stack_base */
+ func = (void (*)()) dl_func;
+ (*func)(stack_base[0], stack_base[1], stack_base[2],
+ stack_base[3], stack_base[4], stack_base[5]);
+
+ /* save return value */
+ /* NOTE: return values are either in %o0 or %f0 */
+#if !defined(lint)
+ asm("st %%o0,%0" : "=g" (ret_o) : /* input */);
+ asm("std %%f0,%0" : "=g" (ret_fd) : /* input */);
+ asm("st %%f0,%0" : "=g" (ret_f) : /* input */);
+#else
+ ret_o = 0; ret_fd = 0.0; ret_f = 0.0;
+#endif
+
+ /* parameter results */
+# define RES_NUM(P, PN, SN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ ++nstack; \
+ if(f_result) { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ astore(stack, ++sp, str_2mortal( \
+ str_nmake((double) P[PN++]))); \
+ } \
+ } else { \
+ PN += narr; \
+ } \
+ } else { \
+ nstack += SN; \
+ if(f_result) { \
+ astore(stack, ++sp, \
+ str_mortal(&str_undef));\
+ } \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_result = narr = nlen = nrep = 0;
+
+# define RES_STR(P, PN, L, SN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ ++nstack; \
+ if(f_result) { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ astore(stack, ++sp, str_2mortal( \
+ str_make(P[PN++], L))); \
+ } \
+ } else { \
+ PN += narr; \
+ } \
+ } else { \
+ if(f_result) { \
+ astore(stack, ++sp, str_2mortal(\
+ str_make((char *) \
+ stack_base[nstack], L))); \
+ } \
+ nstack += SN; \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_result = narr = nlen = nrep = 0;
+
+ --sp;
+ nstack = 0;
+ c_pn = C_pn = s_pn = S_pn = i_pn = I_pn = l_pn = L_pn = 0;
+ f_pn = d_pn = a_pn = p_pn = 0;
+ f_indirect = f_result = narr = nlen = nrep = 0;
+ for(c1 = parms_desc;*c1;++c1) {
+ switch(*c1) {
+ case ' ':
+ case '\t':
+ break;
+
+ case 'c': /* signed char */
+ RES_NUM(c_p, c_pn, 1);
+ break;
+ case 'C': /* unsigned char */
+ RES_NUM(C_p, C_pn, 1);
+ break;
+ case 's': /* signed short */
+ RES_NUM(s_p, s_pn, 1);
+ break;
+ case 'S': /* unsigned short */
+ RES_NUM(S_p, S_pn, 1);
+ break;
+ case 'i': /* signed int */
+ RES_NUM(i_p, i_pn, 1);
+ break;
+ case 'I': /* unsigned int */
+ RES_NUM(I_p, I_pn, 1);
+ break;
+ case 'l': /* signed long */
+ RES_NUM(l_p, l_pn, 1);
+ break;
+ case 'L': /* unsigned long */
+ RES_NUM(L_p, L_pn, 1);
+ break;
+ case 'f': /* float */
+ RES_NUM(f_p, f_pn, 1);
+ break;
+ case 'd': /* double */
+ RES_NUM(d_p, d_pn, 2);
+ break;
+ case 'a': /* ascii (null-terminated) string */
+ RES_STR(a_p, a_pn, 0, 1);
+ break;
+ case 'p': /* pointer to <nlen> buffer */
+ RES_STR(p_p, p_pn, nlen, 1);
+ break;
+
+ case '&': /* pointer = [1] */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ narr = 1;
+ break;
+ case '[': /* array */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ narr = narr * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != ']') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected ]",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '<': /* length */
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ nlen = nlen * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != '>') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected >",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '+':
+ f_result = 1;
+ break;
+ case '-':
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ if(nrep) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: too many repeats");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ while(isdigit(*c1)) {
+ nrep = nrep * 10 + (*c1 - '0');
+ ++c1;
+ }
+ --c1;
+ break;
+ default:
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ }
+ /* trailing &[]<>+-0-9 is ignored */
+
+ /* return value */
+# define RET_NUM(T, S, P, R) \
+ if(f_indirect) { \
+ P = (T *) ret_o; \
+ for(n1 = 0;n1 < narr;++n1) { \
+ S = *P++; \
+ astore(stack, ++sp, str_2mortal( \
+ str_nmake((double) S))); \
+ } \
+ } else { \
+ S = (T) R; \
+ astore(stack, ++sp, str_2mortal( \
+ str_nmake((double) S))); \
+ }
+
+# define RET_STR(S, P, L) \
+ if(f_indirect) { \
+ P = (char **) ret_o; \
+ for(n1 = 0;n1 < narr;++n1) { \
+ S = *P++; \
+ astore(stack, ++sp, str_2mortal( \
+ str_make((char *) S, L))); \
+ } \
+ } else { \
+ S = (char *) ret_o; \
+ astore(stack, ++sp, str_2mortal( \
+ str_make((char *) S, L))); \
+ }
+
+ f_indirect = nlen = narr = 0;
+ for(c1 = return_desc;*c1;++c1) {
+ switch(*c1) {
+ case ' ':
+ case '\t':
+ break;
+
+ case 'c': /* signed char */
+ RET_NUM(char, c, c_p, ret_o);
+ goto ret_exit;
+ case 'C': /* unsigned char */
+ RET_NUM(unsigned char, C, C_p, ret_o);
+ goto ret_exit;
+ case 's': /* signed short */
+ RET_NUM(short, s, s_p, ret_o);
+ goto ret_exit;
+ case 'S': /* unsigned short */
+ RET_NUM(unsigned short, S, S_p, ret_o);
+ goto ret_exit;
+ case 'i': /* signed int */
+ RET_NUM(int, i, i_p, ret_o);
+ goto ret_exit;
+ case 'I': /* unsigned int */
+ RET_NUM(unsigned int, I, I_p, ret_o);
+ goto ret_exit;
+ case 'l': /* signed long */
+ RET_NUM(long, l, l_p, ret_o);
+ goto ret_exit;
+ case 'L': /* unsigned long */
+ RET_NUM(unsigned long, L, L_p, ret_o);
+ goto ret_exit;
+ case 'f': /* float */
+ RET_NUM(float, f, f_p, ret_f);
+ break;
+ case 'd': /* double */
+ RET_NUM(double, d, d_p, ret_fd);
+ goto ret_exit;
+ case 'a': /* ascii (null-terminated) string */
+ RET_STR(a, a_p, 0);
+ goto ret_exit;
+ case 'p': /* pointer to <nlen> buffer */
+ RET_STR(p, p_p, nlen);
+ goto ret_exit;
+
+ case '&': /* pointer = [1] */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: too many indirections, with char %c",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ narr = 1;
+ break;
+ case '[': /* array */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: too many indirections, with char %c",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ narr = narr * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != ']') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: bad char %c, expected ]",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '<': /* length */
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ nlen = nlen * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != '>') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: bad char %c, expected >",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ default:
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: bad char %c",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ }
+ret_exit: /* anything beyond first [cCsSiIlLdfap] is ignored */
+ break;
+ }
+ case US_dl_close:
+ {
+ void *dl_so;
+ int dl_err;
+
+ if(items != 1) {
+ fatal("Usage: $dl_err = &dl_close($dl_so)");
+ return oldsp;
+ }
+
+ dl_so = *(void **) str_get(st[1]);
+ dl_err = dlclose(dl_so);
+
+ --sp;
+ if(dl_err) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_close: %s", dlerror());
+ if(Dl_warn) warn(Dl_errstr);
+ }
+ astore(stack, ++sp, str_2mortal(str_nmake((double) dl_err)));
+ break;
+ }
+ default:
+ fatal("dlperl: unimplemented usersub");
+ break;
+ }
+ return sp;
+}
--- /dev/null
+
+
+
+DLPERL(1) USER COMMANDS DLPERL(1)
+
+
+
+NAME
+ dlperl - dynamic link-editor subroutines for perl
+
+SYNOPSIS
+ $dl_so = &dl_open($file)
+ $dl_func = &dl_sym($dl_so, $symbol)
+ @vals = &dl_call($dl_func, $parms_desc, $return_desc, @parms)
+ $dl_err = &dl_close($dl_so)
+
+ $DL_VERSION
+ $DL_WARN
+ $dl_errno
+ $dl_errstr
+
+DESCRIPTION
+ _\bD_\bl_\bp_\be_\br_\bl is _\bp_\be_\br_\bl plus user defined subroutines (_\bu_\bs_\bu_\bb_\bs) that
+ interface to the dynamic link-editor and can call most C and
+ Fortran functions whose object code has been linked into a
+ shared object file.
+
+ Subroutines
+
+ All _\bd_\bl_\bp_\be_\br_\bl subroutines set the two predefined names
+ $dl_errno and $dl_errstr. Only partial descriptions of
+ &dl_open, &dl_sym and &dl_close appear below, see _\bd_\bl_\bo_\bp_\be_\bn(_\b3_\bx)
+ for a complete description. The following subroutines are
+ defined by _\bd_\bl_\bp_\be_\br_\bl:
+
+ &dl_open($file)
+ Adds the shared object $_\bf_\bi_\bl_\be to _\bd_\bl_\bp_\be_\br_\bl's address
+ space. Returns a descriptor that can be used for
+ later reference to the object in calls to &dl_sym
+ and &dl_close. When an error occurs an undef value
+ is returned.
+
+ &dl_sym($dl_so, $symbol)
+ Obtains an address binding for the function $_\bs_\by_\bm_\bb_\bo_\bl
+ as it occurs in the shared object identified by
+ $_\bd_\bl__\bs_\bo. When an error occurs an undef value is
+ returned.
+
+ &dl_call($dl_func, $parms_desc, $return_desc, @parms)
+ Calls the function identified by $_\bd_\bl__\bf_\bu_\bn_\bc. The
+ function's entry parameters are described by
+ $_\bp_\ba_\br_\bm_\bs__\bd_\be_\bs_\bc and assigned values from @_\bp_\ba_\br_\bm_\bs. The
+ function's exit value is described by $_\br_\be_\bt_\bu_\br_\bn__\bd_\be_\bs_\bc.
+ An array is returned that contains the values of any
+ result parameters and the return value. When an
+ error occurs because of a problem parsing the
+ descriptions or because of an incorrect parameter
+ count no values are returned (although the underly-
+ ing function may have been called).
+
+
+
+Sun Release 4.1 Last change: 10/16/92 1
+
+
+
+
+
+
+DLPERL(1) USER COMMANDS DLPERL(1)
+
+
+
+ The descriptions are sequences of characters that
+ give the order and type of parameters:
+
+ c A signed 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.
+ f A single-precision float.
+ d A double-precision float.
+ a An ascii (null-terminated) string.
+ p A pointer to <length> buffer.
+
+ Each letter may optionally be preceded by a number
+ that gives a repeat count. An array is specified by
+ a preceding [_\ba_\br_\br_\ba_\by__\bs_\bi_\bz_\be] (or & as a shorthand for
+ [_\b1]). (Multi-dimension arrays are not currently
+ supported.) Each scalar or array element is ini-
+ tialized from @_\bp_\ba_\br_\bm_\bs. A preceding - leaves the
+ parameter uninitialized. Type _\bp expects a preceding
+ <_\bb_\bu_\bf_\bf_\be_\br__\bl_\be_\bn_\bg_\bt_\bh>. A preceding + specifies that after
+ the function is called that particular parameter's
+ value is to be returned (multiple values are
+ returned for array types, a + with a integral type
+ like _\bi returns an undef value). The $_\br_\be_\bt_\bu_\br_\bn__\bd_\be_\bs_\bc
+ contains only one letter with no repeat count, - or
+ +.
+
+ An undef or zero-length $_\bp_\ba_\br_\bm__\bd_\be_\bs_\bc means the func-
+ tion has no parameters. An undef or a zero-length
+ $_\br_\be_\bt_\bu_\br_\bn__\bd_\be_\bs_\bc means the function returns void.
+ Strings or buffers that must be a specific length
+ (because the values are overwritten) must be pre-
+ extended. Although type _\bf is supported, compilers
+ typically pass floats as doubles.
+
+ &dl_close($dl_so)
+ Removes the shared object identified by $_\bd_\bl__\bs_\bo from
+ _\bd_\bl_\bp_\be_\br_\bl's address space. If successful, a value of
+ zero is returned. When an error occurs a non-zero
+ value is returned.
+
+ Predefined Names
+
+ The following names have special meaning to _\bd_\bl_\bp_\be_\br_\bl.
+
+ $DL_VERSION
+ The version of _\bd_\bl_\bp_\be_\br_\bl. This variable is read-only.
+
+
+
+
+Sun Release 4.1 Last change: 10/16/92 2
+
+
+
+
+
+
+DLPERL(1) USER COMMANDS DLPERL(1)
+
+
+
+ $DL_WARN
+ The current value of the _\bd_\bl_\bp_\be_\br_\bl warning flag.
+ Default is 1. If non-zero, when errors occur warn-
+ ings are sent to standard error. The warning is the
+ same information that is stored in $dl_errstr.
+
+ $dl_errno
+ The error number for the error that occurred. If a
+ _\bd_\bl_\bp_\be_\br_\bl subroutine completes successfully $dl_errno
+ is set to zero. This variable is read-only.
+
+ $dl_errstr
+ The error message for the error that occurred. If a
+ _\bd_\bl_\bp_\be_\br_\bl subroutine completes successfully $dl_errstr
+ is set to a zero length string. This variable is
+ read-only.
+
+EXAMPLES
+ This is an example of calling a simple C function:
+
+ open(OUT, ">example.c");
+ print OUT <<'EOC';
+ void
+ example(a1, a2, i1, d1, a3)
+ char *a1[2];
+ char *a2[2];
+ int i1;
+ double *d1;
+ char *a3[4];
+ {
+ a3[i1 + (int) *d1] = a1[0];
+ a3[i1 * (int) *d1] = a1[1];
+ a3[(int) *d1 - i1] = a2[0];
+ a3[(int) *d1 - 2 * i1] = a2[1];
+ }
+ EOC
+ close(OUT);
+
+ system("cc -c example.c;ld -o example.so example.o");
+
+ $dl_so = &dl_open("example.so");
+ die "$0: $dl_errstr" if($dl_errno);
+
+ $dl_func = &dl_sym($dl_so, "example");
+ die "$0: $dl_errstr" if($dl_errno);
+
+ $dl_func =~ s/(['\\])/\\$1/g;
+ eval <<EOC;
+ sub example {
+ &dl_call('$dl_func', "2[2]a i &d -+[4]a", undef, @_);
+ }
+ EOC
+
+
+
+Sun Release 4.1 Last change: 10/16/92 3
+
+
+
+
+
+
+DLPERL(1) USER COMMANDS DLPERL(1)
+
+
+
+ @vals = &example("hacker,", "Perl", "another", "Just", 1, 2);
+ print "@vals\n";
+
+ &dl_close($dl_so);
+ die "$0: $dl_errstr" if($dl_errno);
+
+ unlink('example.c', 'example.o', 'example.so');
+
+ If a more complicated interface is needed, the dynamically
+ linked function can define _\bu_\bs_\bu_\bb_\bs by calling internal _\bp_\be_\br_\bl
+ functions.
+
+AUTHOR
+ Eric Fifer <egf@sbi.com>
+
+SEE ALSO
+ perl(1), dlopen(3X), ld(1)
+
+BUGS
+ Additional parameter types should be implemented to support
+ structures, multi-dimension arrays, pointers to arrays,
+ pointers to functions, etc.
+
+ Unlike the _\bp_\ba_\bc_\bk operator, the repeat count precedes the
+ letter in the $_\bp_\ba_\br_\bm__\bd_\be_\bs_\bc syntax. The array size preceding
+ the parameter letter is also unconventional.
+
+ All errors set $dl_errno to 1.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Sun Release 4.1 Last change: 10/16/92 4
+
+
+
--- /dev/null
+.\"
+.\" name: dlperl.man
+.\" synopsis: dlperl man page
+.\" sccsid: @(#)dlperl.man 1.4 10/16/92 (DLPERL)
+.\"
+.ds RP 10/16/92
+.rn '' }`
+.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 DLPERL 1 "\*(RP"
+.UC
+.SH NAME
+dlperl \- dynamic link-editor subroutines for perl
+.SH SYNOPSIS
+.nf
+.ft B
+$dl_so = &dl_open($file)
+$dl_func = &dl_sym($dl_so, $symbol)
+@vals = &dl_call($dl_func, $parms_desc, $return_desc, @parms)
+$dl_err = &dl_close($dl_so)
+.ft
+.fi
+.LP
+.nf
+.ft B
+$DL_VERSION
+$DL_WARN
+$dl_errno
+$dl_errstr
+.ft
+.fi
+.SH DESCRIPTION
+.I Dlperl
+is \fIperl\fP plus user defined subroutines (\fIusubs\fP) that
+interface to the dynamic link-editor and can call most C and Fortran
+functions whose object code has been linked into a shared object file.
+.Sh "Subroutines"
+All \fIdlperl\fP subroutines set the two predefined names $dl_errno and
+$dl_errstr. Only partial descriptions of &dl_open, &dl_sym and
+&dl_close appear below, see \fIdlopen(3x)\fP for a complete
+description. The following subroutines are defined by \fIdlperl\fP:
+.Ip "&dl_open($file)" 8 2
+Adds the shared object \fI$file\fP to \fIdlperl\fP's address space.
+Returns a descriptor that can be used for later reference to the object
+in calls to &dl_sym and &dl_close. When an error occurs
+an undef value is returned.
+.Ip "&dl_sym($dl_so, $symbol)" 8 2
+Obtains an address binding for the function \fI$symbol\fP as it occurs
+in the shared object identified by \fI$dl_so\fP. When an error occurs
+an undef value is returned.
+.Ip "&dl_call($dl_func, $parms_desc, $return_desc, @parms)" 8 2
+Calls the function identified by \fI$dl_func\fP. The function's entry
+parameters are described by \fI$parms_desc\fP and assigned values from
+\fI@parms\fP. The function's exit value is described by
+\fI$return_desc\fP. An array is returned that contains the values of
+any result parameters and the return value. When an error occurs
+because of a problem parsing the descriptions or because of an
+incorrect parameter count no values are returned (although the
+underlying function may have been called).
+.Sp
+The descriptions are sequences of characters that give the order and
+type of parameters:
+.nf
+
+ c A signed 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.
+ f A single-precision float.
+ d A double-precision float.
+ a An ascii (null-terminated) string.
+ p A pointer to <length> buffer.
+
+.fi
+Each letter may optionally be preceded by a number that gives a repeat
+count. An array is specified by a preceding \fI[array_size\fP] (or
+\fI&\fP as a shorthand for \fI[1]\fP). (Multi-dimension arrays are not
+currently supported.) Each scalar or array element is initialized from
+\fI@parms\fP. A preceding \fI-\fP leaves the parameter uninitialized.
+Type \fIp\fP expects a preceding \fI<buffer_length>\fP. A preceding
+\fI+\fP specifies that after the function is called that particular
+parameter's value is to be returned (multiple values are returned for
+array types, a \fI+\fP with a integral type like \fIi\fP returns an
+undef value). The \fI$return_desc\fP contains only one letter with no
+repeat count, \fI-\fP or \fI+\fP.
+.Sp
+An undef or zero-length \fI$parm_desc\fP means the function has no
+parameters. An undef or a zero-length \fI$return_desc\fP means the
+function returns void. Strings or buffers that must be a specific
+length (because the values are overwritten) must be pre-extended.
+Although type \fIf\fP is supported, compilers typically pass floats as
+doubles.
+.Ip "&dl_close($dl_so)" 8 2
+Removes the shared object identified by \fI$dl_so\fP from
+\fIdlperl\fP's address space. If successful, a value of zero is
+returned. When an error occurs a non-zero value is returned.
+.Sh "Predefined Names"
+The following names have special meaning to \fIdlperl\fP.
+.Ip $DL_VERSION 8
+The version of \fIdlperl\fP. This variable is read-only.
+.Ip $DL_WARN 8
+The current value of the \fIdlperl\fP warning flag. Default is 1. If
+non-zero, when errors occur warnings are sent to standard error. The
+warning is the same information that is stored in $dl_errstr.
+.Ip $dl_errno 8
+The error number for the error that occurred. If a \fIdlperl\fP
+subroutine completes successfully $dl_errno is set to zero. This variable
+is read-only.
+.Ip $dl_errstr 8
+The error message for the error that occurred. If a \fIdlperl\fP
+subroutine completes successfully $dl_errstr is set to a zero length
+string. This variable is read-only.
+.SH EXAMPLES
+This is an example of calling a simple C function:
+.Sp
+.nf
+ open(OUT, ">example.c");
+ print OUT <<'EOC';
+ void
+ example(a1, a2, i1, d1, a3)
+ char *a1[2];
+ char *a2[2];
+ int i1;
+ double *d1;
+ char *a3[4];
+ {
+ a3[i1 + (int) *d1] = a1[0];
+ a3[i1 * (int) *d1] = a1[1];
+ a3[(int) *d1 - i1] = a2[0];
+ a3[(int) *d1 - 2 * i1] = a2[1];
+ }
+ EOC
+ close(OUT);
+
+ system("cc -c example.c;ld -o example.so example.o");
+
+ $dl_so = &dl_open("example.so");
+ die "$0: $dl_errstr" if($dl_errno);
+
+ $dl_func = &dl_sym($dl_so, "example");
+ die "$0: $dl_errstr" if($dl_errno);
+
+ $dl_func =~ s/(['\e\e])/\e\e$1/g;
+ eval <<EOC;
+ sub example {
+ &dl_call('$dl_func', "2[2]a i &d -+[4]a", undef, @_);
+ }
+ EOC
+
+ @vals = &example("hacker,", "Perl", "another", "Just", 1, 2);
+ print "@vals\en";
+
+ &dl_close($dl_so);
+ die "$0: $dl_errstr" if($dl_errno);
+
+ unlink('example.c', 'example.o', 'example.so');
+.fi
+.LP
+If a more complicated interface is needed, the dynamically linked
+function can define \fIusubs\fP by calling internal \fIperl\fP
+functions.
+.SH AUTHOR
+Eric Fifer <egf@sbi.com>
+.SH SEE ALSO
+.BR perl (1),
+.BR dlopen (3X),
+.BR ld (1)
+.SH BUGS
+Additional parameter types should be implemented to support structures,
+multi-dimension arrays, pointers to arrays, pointers to functions, etc.
+.LP
+Unlike the \fIpack\fP operator, the repeat count precedes the letter in
+the \fI$parm_desc\fP syntax. The array size preceding the parameter
+letter is also unconventional.
+.LP
+All errors set $dl_errno to 1.
+.rn }` ''
--- /dev/null
+/* $RCSfile: usersub.c,v $$Revision: 4.0.1.1 $$Date: 91/11/05 19:07:24 $
+ *
+ * $Log: usersub.c,v $
+ * Revision 4.0.1.1 91/11/05 19:07:24 lwall
+ * patch11: there are now subroutines for calling back from C into Perl
+ *
+ * Revision 4.0 91/03/20 01:56:34 lwall
+ * 4.0 baseline.
+ *
+ * Revision 3.0.1.1 90/08/09 04:06:10 lwall
+ * patch19: Initial revision
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+int
+userinit()
+{
+ dlperl_init();
+}
+
+/* Be sure to refetch the stack pointer after calling these routines. */
+
+int
+callback(subname, sp, gimme, hasargs, numargs)
+char *subname;
+int sp; /* stack pointer after args are pushed */
+int gimme; /* called in array or scalar context */
+int hasargs; /* whether to create a @_ array for routine */
+int numargs; /* how many args are pushed on the stack */
+{
+ static ARG myarg[3]; /* fake syntax tree node */
+ int arglast[3];
+
+ arglast[2] = sp;
+ sp -= numargs;
+ arglast[1] = sp--;
+ arglast[0] = sp;
+
+ if (!myarg[0].arg_ptr.arg_str)
+ myarg[0].arg_ptr.arg_str = str_make("",0);
+
+ myarg[1].arg_type = A_WORD;
+ myarg[1].arg_ptr.arg_stab = stabent(subname, FALSE);
+
+ myarg[2].arg_type = hasargs ? A_EXPR : A_NULL;
+
+ return do_subr(myarg, gimme, arglast);
+}
+
+int
+callv(subname, sp, gimme, argv)
+char *subname;
+register int sp; /* current stack pointer */
+int gimme; /* called in array or scalar context */
+register char **argv; /* null terminated arg list, NULL for no arglist */
+{
+ register int items = 0;
+ int hasargs = (argv != 0);
+
+ astore(stack, ++sp, Nullstr); /* reserve spot for 1st return arg */
+ if (hasargs) {
+ while (*argv) {
+ astore(stack, ++sp, str_2mortal(str_make(*argv,0)));
+ items++;
+ argv++;
+ }
+ }
+ return callback(subname, sp, gimme, hasargs, items);
+}
--- /dev/null
+void
+do_accept(TARG, nstab, gstab)
+STR *TARG;
+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),(struct sockaddr *)buf,&len);
+ if (fd < 0)
+ goto badexit;
+ nstio->ifp = fdopen(fd, "r");
+ nstio->ofp = fdopen(fd, "w");
+ nstio->type = 's';
+ if (!nstio->ifp || !nstio->ofp) {
+ if (nstio->ifp) fclose(nstio->ifp);
+ if (nstio->ofp) fclose(nstio->ofp);
+ if (!nstio->ifp && !nstio->ofp) close(fd);
+ goto badexit;
+ }
+
+ str_nset(TARG, buf, len);
+ return;
+
+nuts:
+ if (dowarn)
+ warn("accept() on closed fd");
+ errno = EBADF;
+badexit:
+ str_sset(TARG,&str_undef);
+ return;
+}
+
--- /dev/null
+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 *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);
+ }
+ do_execfree();
+ return FALSE;
+}
+
--- /dev/null
+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");
+ errno = EBADF;
+ return FALSE;
+ }
+ st += ++sp;
+ if (arg->arg_type == O_PRTF) {
+ do_sprintf(ARGTARG,items,st);
+ retval = do_print(ARGTARG,fp);
+ }
+ else {
+ retval = (items <= 0);
+ for (; items > 0; items--,st++) {
+ if (retval && ofslen) {
+ if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
+ retval = FALSE;
+ break;
+ }
+ }
+ if (!(retval = do_print(*st, fp)))
+ break;
+ }
+ if (retval && orslen)
+ if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp))
+ retval = FALSE;
+ }
+ return retval;
+}
+
--- /dev/null
+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 *TARG;
+ register ARRAY *ary;
+ register int makelocal;
+ HASH *hash;
+ int i;
+
+ makelocal = (arg->arg_flags & AF_LOCAL) != 0;
+ 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++) {
+ /*SUPPRESS 560*/
+ if (TARG = *relem)
+ *relem = str_mortal(TARG);
+ }
+ }
+ relem = firstrelem;
+ lelem = firstlelem;
+ ary = Null(ARRAY*);
+ hash = Null(HASH*);
+ while (lelem <= lastlelem) {
+ TARG = *lelem++;
+ if (TARG->str_state >= SS_HASH) {
+ if (TARG->str_state == SS_ARY) {
+ if (makelocal)
+ ary = saveary(TARG->str_u.str_stab);
+ else {
+ ary = stab_array(TARG->str_u.str_stab);
+ ary->ary_fill = -1;
+ }
+ i = 0;
+ while (relem <= lastrelem) { /* gobble up all the rest */
+ TARG = Str_new(28,0);
+ if (*relem)
+ str_sset(TARG,*relem);
+ *(relem++) = TARG;
+ (void)astore(ary,i++,TARG);
+ }
+ }
+ else if (TARG->str_state == SS_HASH) {
+ char *tmps;
+ STR *tmpstr;
+ int magic = 0;
+ STAB *tmpstab = TARG->str_u.str_stab;
+
+ if (makelocal)
+ hash = savehash(TARG->str_u.str_stab);
+ else {
+ hash = stab_hash(TARG->str_u.str_stab);
+ if (tmpstab == envstab) {
+ magic = 'E';
+ environ[0] = Nullch;
+ }
+ else if (tmpstab == sigstab) {
+ magic = 'S';
+#ifndef NSIG
+#define NSIG 32
+#endif
+ for (i = 1; i < NSIG; i++)
+ signal(i, SIG_DFL); /* crunch, crunch, crunch */
+ }
+#ifdef SOME_DBM
+ else if (hash->tbl_dbm)
+ magic = 'D';
+#endif
+ hclear(hash, magic == 'D'); /* wipe any dbm file too */
+
+ }
+ while (relem < lastrelem) { /* gobble up all the rest */
+ if (*relem)
+ TARG = *(relem++);
+ else
+ TARG = &str_no, relem++;
+ tmps = str_get(TARG);
+ tmpstr = Str_new(29,0);
+ if (*relem)
+ str_sset(tmpstr,*relem); /* value */
+ *(relem++) = tmpstr;
+ (void)hstore(hash,tmps,TARG->str_cur,tmpstr,0);
+ if (magic) {
+ str_magic(tmpstr, tmpstab, magic, tmps, TARG->str_cur);
+ stabset(tmpstr->str_magic, tmpstr);
+ }
+ }
+ }
+ else
+ fatal("panic: do_assign");
+ }
+ else {
+ if (makelocal)
+ saveitem(TARG);
+ if (relem <= lastrelem) {
+ str_sset(TARG, *relem);
+ *(relem++) = TARG;
+ }
+ else {
+ str_sset(TARG, &str_undef);
+ if (gimme == G_ARRAY) {
+ i = ++lastrelem - firstrelem;
+ relem++; /* tacky, I suppose */
+ astore(stack,i,TARG);
+ 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(TARG);
+ }
+ }
+ if (delaymagic & ~DM_DELAY) {
+ if (delaymagic & DM_UID) {
+#ifdef HAS_SETREUID
+ (void)setreuid(uid,euid);
+#else /* not HAS_SETREUID */
+#ifdef HAS_SETRUID
+ if ((delaymagic & DM_UID) == DM_RUID) {
+ (void)setruid(uid);
+ delaymagic =~ DM_RUID;
+ }
+#endif /* HAS_SETRUID */
+#ifdef HAS_SETEUID
+ if ((delaymagic & DM_UID) == DM_EUID) {
+ (void)seteuid(uid);
+ delaymagic =~ DM_EUID;
+ }
+#endif /* HAS_SETEUID */
+ if (delaymagic & DM_UID) {
+ if (uid != euid)
+ fatal("No setreuid available");
+ (void)setuid(uid);
+ }
+#endif /* not HAS_SETREUID */
+ uid = (int)getuid();
+ euid = (int)geteuid();
+ }
+ if (delaymagic & DM_GID) {
+#ifdef HAS_SETREGID
+ (void)setregid(gid,egid);
+#else /* not HAS_SETREGID */
+#ifdef HAS_SETRGID
+ if ((delaymagic & DM_GID) == DM_RGID) {
+ (void)setrgid(gid);
+ delaymagic =~ DM_RGID;
+ }
+#endif /* HAS_SETRGID */
+#ifdef HAS_SETEGID
+ if ((delaymagic & DM_GID) == DM_EGID) {
+ (void)setegid(gid);
+ delaymagic =~ DM_EGID;
+ }
+#endif /* HAS_SETEGID */
+ if (delaymagic & DM_GID) {
+ if (gid != egid)
+ fatal("No setregid available");
+ (void)setgid(gid);
+ }
+#endif /* not HAS_SETREGID */
+ gid = (int)getgid();
+ egid = (int)getegid();
+ }
+ }
+ 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(ARGTARG,(double)(arglast[2] - arglast[1]));
+ *firstlelem = ARGTARG;
+ return arglast[0] + 1;
+ }
+}
+
--- /dev/null
+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");
+ errno = EBADF;
+ return FALSE;
+
+}
+
--- /dev/null
+int
+do_caller(arg,maxarg,gimme,arglast)
+ARG *arg;
+int maxarg;
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ register CSV *csv = curcsv;
+ STR *TARG;
+ int count = 0;
+
+ if (!csv)
+ fatal("There is no caller");
+ if (maxarg)
+ count = (int) str_gnum(st[sp+1]);
+ for (;;) {
+ if (!csv)
+ return sp;
+ if (DBsub && csv->oldcsv && csv->oldcsv->sub == stab_sub(DBsub))
+ count++;
+ if (!count--)
+ break;
+ csv = csv->oldcsv;
+ }
+ if (gimme != G_ARRAY) {
+ STR *TARG = ARGTARG;
+ str_set(TARG,csv->oldcmd->c_stash->tbl_name);
+ STABSET(TARG);
+ st[++sp] = TARG;
+ return sp;
+ }
+
+#ifndef lint
+ (void)astore(stack,++sp,
+ str_2mortal(str_make(csv->oldcmd->c_stash->tbl_name,0)) );
+ (void)astore(stack,++sp,
+ str_2mortal(str_make(stab_val(csv->oldcmd->c_filestab)->str_ptr,0)) );
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake((double)csv->oldcmd->c_line)) );
+ if (!maxarg)
+ return sp;
+ TARG = Str_new(49,0);
+ stab_efullname(TARG, csv->stab);
+ (void)astore(stack,++sp, str_2mortal(TARG));
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake((double)csv->hasargs)) );
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake((double)csv->wantarray)) );
+ if (csv->hasargs) {
+ ARRAY *ary = csv->argarray;
+
+ if (!dbargs)
+ dbargs = stab_xarray(aadd(stabent("DB'args", TRUE)));
+ if (dbargs->ary_max < ary->ary_fill)
+ astore(dbargs,ary->ary_fill,Nullstr);
+ Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
+ dbargs->ary_fill = ary->ary_fill;
+ }
+#else
+ (void)astore(stack,++sp,
+ str_2mortal(str_make("",0)));
+#endif
+ return sp;
+}
+
--- /dev/null
+void
+do_chop(astr,TARG)
+register STR *astr;
+register STR *TARG;
+{
+ register char *tmps;
+ register int i;
+ ARRAY *ary;
+ HASH *hash;
+ HENT *entry;
+
+ if (!TARG)
+ return;
+ if (TARG->str_state == SS_ARY) {
+ ary = stab_array(TARG->str_u.str_stab);
+ for (i = 0; i <= ary->ary_fill; i++)
+ do_chop(astr,ary->ary_array[i]);
+ return;
+ }
+ if (TARG->str_state == SS_HASH) {
+ hash = stab_hash(TARG->str_u.str_stab);
+ (void)hiterinit(hash);
+ /*SUPPRESS 560*/
+ while (entry = hiternext(hash))
+ do_chop(astr,hiterval(hash,entry));
+ return;
+ }
+ tmps = str_get(TARG);
+ if (tmps && TARG->str_cur) {
+ tmps += TARG->str_cur - 1;
+ str_nset(astr,tmps,1); /* remember last char */
+ *tmps = '\0'; /* wipe it out */
+ TARG->str_cur = tmps - TARG->str_ptr;
+ TARG->str_nok = 0;
+ STABSET(TARG);
+ }
+ else
+ str_nset(astr,"",0);
+}
+
--- /dev/null
+bool
+do_close(stab,explicit)
+STAB *stab;
+bool explicit;
+{
+ bool retval = FALSE;
+ register STIO *stio;
+ int status;
+
+ if (!stab)
+ stab = argvstab;
+ if (!stab) {
+ errno = EBADF;
+ return FALSE;
+ }
+ stio = stab_io(stab);
+ if (!stio) { /* never opened */
+ if (dowarn && explicit)
+ warn("Close on unopened file <%s>",stab_ename(stab));
+ return FALSE;
+ }
+ if (stio->ifp) {
+ if (stio->type == '|') {
+ status = mypclose(stio->ifp);
+ retval = (status == 0);
+ statusvalue = (unsigned short)status & 0xffff;
+ }
+ else if (stio->type == '-')
+ retval = TRUE;
+ else {
+ if (stio->ofp && stio->ofp != stio->ifp) { /* a socket */
+ retval = (fclose(stio->ofp) != EOF);
+ fclose(stio->ifp); /* clear stdio, fd already closed */
+ }
+ else
+ retval = (fclose(stio->ifp) != EOF);
+ }
+ stio->ofp = stio->ifp = Nullfp;
+ }
+ if (explicit)
+ stio->lines = 0;
+ stio->type = ' ';
+ return retval;
+}
+
--- /dev/null
+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]);
+ TAINT_PROPER("connect");
+ return connect(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0;
+
+nuts:
+ if (dowarn)
+ warn("connect() on closed fd");
+ errno = EBADF;
+ return FALSE;
+
+}
+
--- /dev/null
+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 || !(stio = stab_io(stab)) || !stio->ifp) {
+ errno = EBADF; /* well, sort of... */
+ 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);
+#ifdef DOSISH
+ s = (char*)(long)retval; /* ouch */
+#else
+ s = (char*)retval; /* ouch */
+#endif
+ }
+
+#ifndef lint
+ if (optype == O_IOCTL)
+ retval = ioctl(fileno(stio->ifp), func, s);
+ else
+#ifdef DOSISH
+ fatal("fcntl is not implemented");
+#else
+#ifdef HAS_FCNTL
+ retval = fcntl(fileno(stio->ifp), func, s);
+#else
+ fatal("fcntl is not implemented");
+#endif
+#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;
+}
+
--- /dev/null
+int /*SUPPRESS 590*/
+do_defined(TARG,arg,gimme,arglast)
+STR *TARG;
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register int type;
+ register int retarg = arglast[0] + 1;
+ int retval;
+ ARRAY *ary;
+ HASH *hash;
+
+ 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_SUBR || type == O_DBSUBR) {
+ if ((arg[1].arg_type & A_MASK) == A_WORD)
+ retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0;
+ else {
+ STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
+
+ retval = tmpstr && stab_sub(stabent(str_get(tmpstr),TRUE)) != 0;
+ }
+ }
+ else if (type == O_ARRAY || type == O_LARRAY ||
+ type == O_ASLICE || type == O_LASLICE )
+ retval = ((ary = stab_xarray(arg[1].arg_ptr.arg_stab)) != 0
+ && ary->ary_max >= 0 );
+ else if (type == O_HASH || type == O_LHASH ||
+ type == O_HSLICE || type == O_LHSLICE )
+ retval = ((hash = stab_xhash(arg[1].arg_ptr.arg_stab)) != 0
+ && hash->tbl_array);
+ else
+ retval = FALSE;
+ str_numset(TARG,(double)retval);
+ stack->ary_array[retarg] = TARG;
+ return retarg;
+}
+
--- /dev/null
+int
+do_dirop(optype,stab,gimme,arglast)
+int optype;
+STAB *stab;
+int gimme;
+int *arglast;
+{
+#if defined(DIRENT) && defined(HAS_READDIR)
+ register ARRAY *ary = stack;
+ register STR **st = ary->ary_array;
+ register int sp = arglast[1];
+ register STIO *stio;
+ long along;
+#ifndef apollo
+ struct DIRENT *readdir();
+#endif
+ register struct DIRENT *dp;
+
+ if (!stab)
+ goto nope;
+ if (!(stio = stab_io(stab)))
+ stio = stab_io(stab) = stio_new();
+ if (!stio->dirp && optype != O_OPEN_DIR)
+ goto nope;
+ st[sp] = &str_yes;
+ switch (optype) {
+ case O_OPEN_DIR:
+ 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;
+ /*SUPPRESS 560*/
+ while (dp = readdir(stio->dirp)) {
+#ifdef DIRNAMLEN
+ (void)astore(ary,++sp,
+ str_2mortal(str_make(dp->d_name,dp->d_namlen)));
+#else
+ (void)astore(ary,++sp,
+ str_2mortal(str_make(dp->d_name,0)));
+#endif
+ }
+ }
+ else {
+ if (!(dp = readdir(stio->dirp)))
+ goto nope;
+ st[sp] = str_mortal(&str_undef);
+#ifdef DIRNAMLEN
+ str_nset(st[sp], dp->d_name, dp->d_namlen);
+#else
+ str_set(st[sp], dp->d_name);
+#endif
+ }
+ break;
+#if defined(HAS_TELLDIR) || defined(telldir)
+ case O_TELLDIR: {
+#ifndef telldir
+ long telldir();
+#endif
+ st[sp] = str_mortal(&str_undef);
+ str_numset(st[sp], (double)telldir(stio->dirp));
+ break;
+ }
+#endif
+#if defined(HAS_SEEKDIR) || defined(seekdir)
+ case O_SEEKDIR:
+ st[sp] = str_mortal(&str_undef);
+ along = (long)str_gnum(st[sp+1]);
+ (void)seekdir(stio->dirp,along);
+ break;
+#endif
+#if defined(HAS_REWINDDIR) || defined(rewinddir)
+ case O_REWINDDIR:
+ st[sp] = str_mortal(&str_undef);
+ (void)rewinddir(stio->dirp);
+ break;
+#endif
+ case O_CLOSEDIR:
+ st[sp] = str_mortal(&str_undef);
+ (void)closedir(stio->dirp);
+ stio->dirp = 0;
+ break;
+ default:
+ goto phooey;
+ }
+ return sp;
+
+nope:
+ st[sp] = &str_undef;
+ if (!errno)
+ errno = EBADF;
+ return sp;
+
+#endif
+phooey:
+ fatal("Unimplemented directory operation");
+}
+
--- /dev/null
+int
+do_each(TARG,hash,gimme,arglast)
+STR *TARG;
+HASH *hash;
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ 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);
+ if (!i)
+ tmps = "";
+ st[++sp] = mystrk = str_make(tmps,i);
+ }
+ st[++sp] = TARG;
+ str_sset(TARG,hiterval(hash,entry));
+ STABSET(TARG);
+ return sp;
+ }
+ else
+ return sp;
+}
--- /dev/null
+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;
+ }
+#ifdef STDSTDIO
+ if (stio->ifp->_cnt < -1)
+ stio->ifp->_cnt = -1;
+#endif
+ 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;
+}
+
--- /dev/null
+bool
+do_exec(cmd)
+char *cmd;
+{
+ register char **a;
+ register char *s;
+ char flags[10];
+
+ /* 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 */
+
+ /*SUPPRESS 530*/
+ for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
+ if (*s == '=')
+ goto doshell;
+ 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*);
+ Cmd = nsavestr(cmd, s-cmd);
+ 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 */
+ do_execfree();
+ goto doshell;
+ }
+ }
+ do_execfree();
+ return FALSE;
+}
+
--- /dev/null
+void
+do_execfree()
+{
+ if (Argv) {
+ Safefree(Argv);
+ Argv = Null(char **);
+ }
+ if (Cmd) {
+ Safefree(Cmd);
+ Cmd = Nullch;
+ }
+}
+
--- /dev/null
+STR *
+do_fttext(arg,TARG)
+register ARG *arg;
+STR *TARG;
+{
+ 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 {
+ TARG = statname;
+ goto really_filename;
+ }
+ }
+ else {
+ statstab = arg[1].arg_ptr.arg_stab;
+ str_set(statname,"");
+ stio = stab_io(statstab);
+ }
+ if (stio && stio->ifp) {
+#if defined(STDSTDIO) || defined(atarist) /* this will work with atariST */
+ fstat(fileno(stio->ifp),&statcache);
+ if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
+ return arg->arg_type == O_FTTEXT ? &str_no : &str_yes;
+ 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");
+#endif
+ }
+ else {
+ if (dowarn)
+ warn("Test on unopened file <%s>",
+ stab_ename(arg[1].arg_ptr.arg_stab));
+ errno = EBADF;
+ return &str_undef;
+ }
+ }
+ else {
+ statstab = Nullstab;
+ str_set(statname,str_get(TARG));
+ really_filename:
+ i = open(str_get(TARG),0);
+ if (i < 0) {
+ if (dowarn && index(str_get(TARG), '\n'))
+ warn(warn_nl, "open");
+ return &str_undef;
+ }
+ fstat(i,&statcache);
+ len = read(i,tbuf,512);
+ (void)close(i);
+ if (len <= 0) {
+ if (S_ISDIR(statcache.st_mode) && arg->arg_type == O_FTTEXT)
+ return &str_no; /* special case NFS directories */
+ return &str_yes; /* null file is anything */
+ }
+ 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;
+}
+
--- /dev/null
+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_2mortal(Str_new(22,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, (int*)&st[sp]->str_cur) < 0)
+ goto nuts2;
+ break;
+ case O_GETPEERNAME:
+ if (getpeername(fd, st[sp]->str_ptr, (int*)&st[sp]->str_cur) < 0)
+ goto nuts2;
+ break;
+ }
+
+ return sp;
+
+nuts:
+ if (dowarn)
+ warn("get{sock,peer}name() on closed fd");
+ errno = EBADF;
+nuts2:
+ st[sp] = &str_undef;
+ return sp;
+
+}
+
--- /dev/null
+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 *TARG;
+ struct group *getgrnam();
+ struct group *getgrgid();
+ struct group *getgrent();
+ struct group *grent;
+
+ 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 (gimme != G_ARRAY) {
+ astore(ary, ++sp, TARG = str_mortal(&str_undef));
+ if (grent) {
+ if (which == O_GGRNAM)
+ str_numset(TARG, (double)grent->gr_gid);
+ else
+ str_set(TARG, grent->gr_name);
+ }
+ return sp;
+ }
+
+ if (grent) {
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, grent->gr_name);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, grent->gr_passwd);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_numset(TARG, (double)grent->gr_gid);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ for (elem = grent->gr_mem; *elem; elem++) {
+ str_cat(TARG, *elem);
+ if (elem[1])
+ str_ncat(TARG," ",1);
+ }
+ }
+
+ return sp;
+#else
+ fatal("group routines not implemented");
+#endif
+}
+
--- /dev/null
+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 *TARG;
+ struct hostent *gethostbyname();
+ struct hostent *gethostbyaddr();
+#ifdef HAS_GETHOSTENT
+ struct hostent *gethostent();
+#endif
+ struct hostent *hent;
+ unsigned long len;
+
+ 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 HAS_GETHOSTENT
+ hent = gethostent();
+#else
+ fatal("gethostent not implemented");
+#endif
+
+#ifdef HOST_NOT_FOUND
+ if (!hent)
+ statusvalue = (unsigned short)h_errno & 0xffff;
+#endif
+
+ if (gimme != G_ARRAY) {
+ astore(ary, ++sp, TARG = str_mortal(&str_undef));
+ if (hent) {
+ if (which == O_GHBYNAME) {
+#ifdef h_addr
+ str_nset(TARG, *hent->h_addr, hent->h_length);
+#else
+ str_nset(TARG, hent->h_addr, hent->h_length);
+#endif
+ }
+ else
+ str_set(TARG, hent->h_name);
+ }
+ return sp;
+ }
+
+ if (hent) {
+#ifndef lint
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, hent->h_name);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ for (elem = hent->h_aliases; *elem; elem++) {
+ str_cat(TARG, *elem);
+ if (elem[1])
+ str_ncat(TARG," ",1);
+ }
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_numset(TARG, (double)hent->h_addrtype);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ len = hent->h_length;
+ str_numset(TARG, (double)len);
+#ifdef h_addr
+ for (elem = hent->h_addr_list; *elem; elem++) {
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_nset(TARG, *elem, len);
+ }
+#else
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_nset(TARG, hent->h_addr, len);
+#endif /* h_addr */
+#else /* lint */
+ elem = Nullch;
+ elem = elem;
+ (void)astore(ary, ++sp, str_mortal(&str_no));
+#endif /* lint */
+ }
+
+ return sp;
+}
+
--- /dev/null
+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 *TARG;
+ struct netent *getnetbyname();
+ struct netent *getnetbyaddr();
+ struct netent *getnetent();
+ struct netent *nent;
+
+ if (which == O_GNBYNAME) {
+ char *name = str_get(ary->ary_array[sp+1]);
+
+ nent = getnetbyname(name);
+ }
+ else if (which == O_GNBYADDR) {
+ unsigned long addr = U_L(str_gnum(ary->ary_array[sp+1]));
+ int addrtype = (int)str_gnum(ary->ary_array[sp+2]);
+
+ nent = getnetbyaddr((long)addr,addrtype);
+ }
+ else
+ nent = getnetent();
+
+ if (gimme != G_ARRAY) {
+ astore(ary, ++sp, TARG = str_mortal(&str_undef));
+ if (nent) {
+ if (which == O_GNBYNAME)
+ str_numset(TARG, (double)nent->n_net);
+ else
+ str_set(TARG, nent->n_name);
+ }
+ return sp;
+ }
+
+ if (nent) {
+#ifndef lint
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, nent->n_name);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ for (elem = nent->n_aliases; *elem; elem++) {
+ str_cat(TARG, *elem);
+ if (elem[1])
+ str_ncat(TARG," ",1);
+ }
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_numset(TARG, (double)nent->n_addrtype);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_numset(TARG, (double)nent->n_net);
+#else /* lint */
+ elem = Nullch;
+ elem = elem;
+ (void)astore(ary, ++sp, str_mortal(&str_no));
+#endif /* lint */
+ }
+
+ return sp;
+}
+
--- /dev/null
+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 *TARG;
+ struct protoent *getprotobyname();
+ struct protoent *getprotobynumber();
+ struct protoent *getprotoent();
+ struct protoent *pent;
+
+ 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 (gimme != G_ARRAY) {
+ astore(ary, ++sp, TARG = str_mortal(&str_undef));
+ if (pent) {
+ if (which == O_GPBYNAME)
+ str_numset(TARG, (double)pent->p_proto);
+ else
+ str_set(TARG, pent->p_name);
+ }
+ return sp;
+ }
+
+ if (pent) {
+#ifndef lint
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, pent->p_name);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ for (elem = pent->p_aliases; *elem; elem++) {
+ str_cat(TARG, *elem);
+ if (elem[1])
+ str_ncat(TARG," ",1);
+ }
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_numset(TARG, (double)pent->p_proto);
+#else /* lint */
+ elem = Nullch;
+ elem = elem;
+ (void)astore(ary, ++sp, str_mortal(&str_no));
+#endif /* lint */
+ }
+
+ return sp;
+}
+
--- /dev/null
+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 STR *TARG;
+ struct passwd *getpwnam();
+ struct passwd *getpwuid();
+ struct passwd *getpwent();
+ struct passwd *pwent;
+
+ 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 (gimme != G_ARRAY) {
+ astore(ary, ++sp, TARG = str_mortal(&str_undef));
+ if (pwent) {
+ if (which == O_GPWNAM)
+ str_numset(TARG, (double)pwent->pw_uid);
+ else
+ str_set(TARG, pwent->pw_name);
+ }
+ return sp;
+ }
+
+ if (pwent) {
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, pwent->pw_name);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, pwent->pw_passwd);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_numset(TARG, (double)pwent->pw_uid);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_numset(TARG, (double)pwent->pw_gid);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+#ifdef PWCHANGE
+ str_numset(TARG, (double)pwent->pw_change);
+#else
+#ifdef PWQUOTA
+ str_numset(TARG, (double)pwent->pw_quota);
+#else
+#ifdef PWAGE
+ str_set(TARG, pwent->pw_age);
+#endif
+#endif
+#endif
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+#ifdef PWCLASS
+ str_set(TARG,pwent->pw_class);
+#else
+#ifdef PWCOMMENT
+ str_set(TARG, pwent->pw_comment);
+#endif
+#endif
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, pwent->pw_gecos);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, pwent->pw_dir);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, pwent->pw_shell);
+#ifdef PWEXPIRE
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_numset(TARG, (double)pwent->pw_expire);
+#endif
+ }
+
+ return sp;
+#else
+ fatal("password routines not implemented");
+#endif
+}
+
--- /dev/null
+int
+do_grep(arg,TARG,gimme,arglast)
+register ARG *arg;
+STR *TARG;
+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;
+ int oldtmps_base = tmps_base;
+
+ savesptr(&stab_val(defstab));
+ tmps_base = tmps_max;
+ 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) {
+ if (st[src]) {
+ st[src]->str_pok &= ~SP_TEMP;
+ stab_val(defstab) = st[src];
+ }
+ else
+ stab_val(defstab) = str_mortal(&str_undef);
+ (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);
+ tmps_base = oldtmps_base;
+ if (gimme != G_ARRAY) {
+ str_numset(TARG,(double)(dst - arglast[1]));
+ STABSET(TARG);
+ st[arglast[0]+1] = TARG;
+ return arglast[0]+1;
+ }
+ return arglast[0] + (dst - arglast[1]);
+}
+
--- /dev/null
+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 *TARG;
+ struct servent *getservbyname();
+ struct servent *getservbynumber();
+ struct servent *getservent();
+ struct servent *sent;
+
+ 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 (gimme != G_ARRAY) {
+ astore(ary, ++sp, TARG = str_mortal(&str_undef));
+ if (sent) {
+ if (which == O_GSBYNAME) {
+#ifdef HAS_NTOHS
+ str_numset(TARG, (double)ntohs(sent->s_port));
+#else
+ str_numset(TARG, (double)(sent->s_port));
+#endif
+ }
+ else
+ str_set(TARG, sent->s_name);
+ }
+ return sp;
+ }
+
+ if (sent) {
+#ifndef lint
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, sent->s_name);
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ for (elem = sent->s_aliases; *elem; elem++) {
+ str_cat(TARG, *elem);
+ if (elem[1])
+ str_ncat(TARG," ",1);
+ }
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+#ifdef HAS_NTOHS
+ str_numset(TARG, (double)ntohs(sent->s_port));
+#else
+ str_numset(TARG, (double)(sent->s_port));
+#endif
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_set(TARG, sent->s_proto);
+#else /* lint */
+ elem = Nullch;
+ elem = elem;
+ (void)astore(ary, ++sp, str_mortal(&str_no));
+#endif /* lint */
+ }
+
+ return sp;
+}
+
--- /dev/null
+int
+do_ipcctl(optype, arglast)
+int optype;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *astr;
+ char *a;
+ int id, n, cmd, infosize, getinfo, ret;
+
+ id = (int)str_gnum(st[++sp]);
+ n = (optype == O_SEMCTL) ? (int)str_gnum(st[++sp]) : 0;
+ cmd = (int)str_gnum(st[++sp]);
+ astr = st[++sp];
+
+ infosize = 0;
+ getinfo = (cmd == IPC_STAT);
+
+ switch (optype)
+ {
+#ifdef HAS_MSG
+ case O_MSGCTL:
+ if (cmd == IPC_STAT || cmd == IPC_SET)
+ infosize = sizeof(struct msqid_ds);
+ break;
+#endif
+#ifdef HAS_SHM
+ case O_SHMCTL:
+ if (cmd == IPC_STAT || cmd == IPC_SET)
+ infosize = sizeof(struct shmid_ds);
+ break;
+#endif
+#ifdef HAS_SEM
+ case O_SEMCTL:
+ if (cmd == IPC_STAT || cmd == IPC_SET)
+ infosize = sizeof(struct semid_ds);
+ else if (cmd == GETALL || cmd == SETALL)
+ {
+ struct semid_ds semds;
+ if (semctl(id, 0, IPC_STAT, &semds) == -1)
+ return -1;
+ getinfo = (cmd == GETALL);
+ infosize = semds.sem_nsems * sizeof(short);
+ /* "short" is technically wrong but much more portable
+ than guessing about u_?short(_t)? */
+ }
+ break;
+#endif
+#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
+ default:
+ fatal("%s not implemented", opname[optype]);
+#endif
+ }
+
+ if (infosize)
+ {
+ if (getinfo)
+ {
+ STR_GROW(astr, infosize+1);
+ a = str_get(astr);
+ }
+ else
+ {
+ a = str_get(astr);
+ if (astr->str_cur != infosize)
+ {
+ errno = EINVAL;
+ return -1;
+ }
+ }
+ }
+ else
+ {
+ int i = (int)str_gnum(astr);
+ a = (char *)i; /* ouch */
+ }
+ errno = 0;
+ switch (optype)
+ {
+#ifdef HAS_MSG
+ case O_MSGCTL:
+ ret = msgctl(id, cmd, (struct msqid_ds *)a);
+ break;
+#endif
+#ifdef HAS_SEM
+ case O_SEMCTL:
+ ret = semctl(id, n, cmd, a);
+ break;
+#endif
+#ifdef HAS_SHM
+ case O_SHMCTL:
+ ret = shmctl(id, cmd, (struct shmid_ds *)a);
+ break;
+#endif
+ }
+ if (getinfo && ret >= 0) {
+ astr->str_cur = infosize;
+ astr->str_ptr[infosize] = '\0';
+ }
+ return ret;
+}
+
--- /dev/null
+int
+do_ipcget(optype, arglast)
+int optype;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ key_t key;
+ int n, flags;
+
+ key = (key_t)str_gnum(st[++sp]);
+ n = (optype == O_MSGGET) ? 0 : (int)str_gnum(st[++sp]);
+ flags = (int)str_gnum(st[++sp]);
+ errno = 0;
+ switch (optype)
+ {
+#ifdef HAS_MSG
+ case O_MSGGET:
+ return msgget(key, flags);
+#endif
+#ifdef HAS_SEM
+ case O_SEMGET:
+ return semget(key, n, flags);
+#endif
+#ifdef HAS_SHM
+ case O_SHMGET:
+ return shmget(key, n, flags);
+#endif
+#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
+ default:
+ fatal("%s not implemented", opname[optype]);
+#endif
+ }
+ return -1; /* should never happen */
+}
+
--- /dev/null
+void
+do_join(TARG,arglast)
+register STR *TARG;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ int sp = arglast[1];
+ register int items = arglast[2] - sp;
+ register char *delim = str_get(st[sp]);
+ register STRLEN len;
+ int delimlen = st[sp]->str_cur;
+
+ st += sp + 1;
+
+ len = (items > 0 ? (delimlen * (items - 1) ) : 0);
+ if (TARG->str_len < len + items) { /* current length is way too short */
+ while (items-- > 0) {
+ if (*st)
+ len += (*st)->str_cur;
+ st++;
+ }
+ STR_GROW(TARG, len + 1); /* so try to pre-extend */
+
+ items = arglast[2] - sp;
+ st -= items;
+ }
+
+ if (items-- > 0)
+ str_sset(TARG, *st++);
+ else
+ str_set(TARG,"");
+ len = delimlen;
+ if (len) {
+ for (; items > 0; items--,st++) {
+ str_ncat(TARG,delim,len);
+ str_scat(TARG,*st);
+ }
+ }
+ else {
+ for (; items > 0; items--,st++)
+ str_scat(TARG,*st);
+ }
+ STABSET(TARG);
+}
+
--- /dev/null
+int
+do_kv(TARG,hash,kv,gimme,arglast)
+STR *TARG;
+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) {
+ i = 0;
+ (void)hiterinit(hash);
+ /*SUPPRESS 560*/
+ while (entry = hiternext(hash)) {
+ i++;
+ }
+ str_numset(TARG,(double)i);
+ STABSET(TARG);
+ st[++sp] = TARG;
+ return sp;
+ }
+ (void)hiterinit(hash);
+ /*SUPPRESS 560*/
+ while (entry = hiternext(hash)) {
+ if (dokeys) {
+ tmps = hiterkey(entry,&i);
+ if (!i)
+ tmps = "";
+ (void)astore(ary,++sp,str_2mortal(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_2mortal(tmpstr));
+ }
+ }
+ return sp;
+}
+
--- /dev/null
+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");
+ errno = EBADF;
+ return FALSE;
+}
+
--- /dev/null
+int
+do_match(TARG,arg,gimme,arglast)
+STR *TARG;
+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;
+ char *myhint = hint;
+ int global;
+ int safebase;
+ char *truebase = s;
+ register REGEXP *rx = spat->spat_regexp;
+
+ hint = Nullch;
+ if (!spat) {
+ if (gimme == G_ARRAY)
+ return --sp;
+ str_set(TARG,Yes);
+ STABSET(TARG);
+ st[sp] = TARG;
+ return sp;
+ }
+ global = spat->spat_flags & SPAT_GLOBAL;
+ safebase = (gimme == G_ARRAY) || global;
+ 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(TARG,No);
+ STABSET(TARG);
+ st[sp] = TARG;
+ 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 (!global && rx)
+ regfree(rx);
+ spat->spat_regexp = Null(REGEXP*); /* crucial if regcomp aborts */
+ spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
+ spat->spat_flags & SPAT_FOLD);
+ if (!spat->spat_regexp->prelen && lastspat)
+ spat = lastspat;
+ if (spat->spat_flags & SPAT_KEEP) {
+ if (!(spat->spat_flags & SPAT_FOLD))
+ scanconst(spat,spat->spat_regexp->precomp,
+ spat->spat_regexp->prelen);
+ if (spat->spat_runtime)
+ arg_free(spat->spat_runtime); /* it won't change, so */
+ spat->spat_runtime = Nullarg; /* no point compiling again */
+ hoistmust(spat);
+ if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
+ curcmd->c_flags &= ~CF_OPTIMIZE;
+ opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
+ }
+ }
+ if (global) {
+ if (rx) {
+ if (rx->startp[0]) {
+ s = rx->endp[0];
+ if (s == rx->startp[0])
+ s++;
+ if (s > strend) {
+ regfree(rx);
+ rx = spat->spat_regexp;
+ goto nope;
+ }
+ }
+ regfree(rx);
+ }
+ }
+ else if (!spat->spat_regexp->nparens)
+ gimme = G_SCALAR; /* accidental array context? */
+ rx = spat->spat_regexp;
+ if (regexec(rx, s, strend, s, 0,
+ srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
+ safebase)) {
+ if (rx->subbase || global)
+ curspat = spat;
+ lastspat = spat;
+ goto gotcha;
+ }
+ else {
+ if (gimme == G_ARRAY)
+ return sp;
+ str_sset(TARG,&str_no);
+ STABSET(TARG);
+ st[++sp] = TARG;
+ 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,rx->precomp,ch);
+ }
+#endif
+ if (!rx->prelen && lastspat) {
+ spat = lastspat;
+ rx = spat->spat_regexp;
+ }
+ t = s;
+ play_it_again:
+ if (global && rx->startp[0]) {
+ t = s = rx->endp[0];
+ if (s == rx->startp[0])
+ s++,t++;
+ if (s > strend)
+ goto nope;
+ }
+ if (myhint) {
+ if (myhint < s || myhint > strend)
+ fatal("panic: hint in do_match");
+ s = myhint;
+ if (rx->regback >= 0) {
+ s -= rx->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 && rx->regback >= 0) {
+ ++spat->spat_short->str_u.str_useful;
+ s -= rx->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 (!rx->nparens && !global) {
+ gimme = G_SCALAR; /* accidental array context? */
+ safebase = FALSE;
+ }
+ if (regexec(rx, s, strend, truebase, 0,
+ srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
+ safebase)) {
+ if (rx->subbase || global)
+ curspat = spat;
+ lastspat = spat;
+ if (spat->spat_flags & SPAT_ONCE)
+ spat->spat_flags |= SPAT_USED;
+ goto gotcha;
+ }
+ else {
+ if (global)
+ rx->startp[0] = Nullch;
+ if (gimme == G_ARRAY)
+ return sp;
+ str_sset(TARG,&str_no);
+ STABSET(TARG);
+ st[++sp] = TARG;
+ return sp;
+ }
+ }
+ /*NOTREACHED*/
+
+ gotcha:
+ if (gimme == G_ARRAY) {
+ int iters, i, len;
+
+ iters = rx->nparens;
+ if (global && !iters)
+ i = 1;
+ else
+ i = 0;
+ if (sp + iters + i >= stack->ary_max) {
+ astore(stack,sp + iters + i, Nullstr);
+ st = stack->ary_array; /* possibly realloced */
+ }
+
+ for (i = !i; i <= iters; i++) {
+ st[++sp] = str_mortal(&str_no);
+ /*SUPPRESS 560*/
+ if (s = rx->startp[i]) {
+ len = rx->endp[i] - s;
+ if (len > 0)
+ str_nset(st[sp],s,len);
+ }
+ }
+ if (global) {
+ truebase = rx->subbeg;
+ goto play_it_again;
+ }
+ return sp;
+ }
+ else {
+ str_sset(TARG,&str_yes);
+ STABSET(TARG);
+ st[++sp] = TARG;
+ return sp;
+ }
+
+yup:
+ ++spat->spat_short->str_u.str_useful;
+ lastspat = spat;
+ if (spat->spat_flags & SPAT_ONCE)
+ spat->spat_flags |= SPAT_USED;
+ if (global) {
+ rx->subbeg = t;
+ rx->subend = strend;
+ rx->startp[0] = s;
+ rx->endp[0] = s + spat->spat_short->str_cur;
+ curspat = spat;
+ goto gotcha;
+ }
+ if (sawampersand) {
+ char *tmps;
+
+ if (rx->subbase)
+ Safefree(rx->subbase);
+ tmps = rx->subbase = nsavestr(t,strend-t);
+ rx->subbeg = tmps;
+ rx->subend = tmps + (strend-t);
+ tmps = rx->startp[0] = tmps + (s - t);
+ rx->endp[0] = tmps + spat->spat_short->str_cur;
+ curspat = spat;
+ }
+ str_sset(TARG,&str_yes);
+ STABSET(TARG);
+ st[++sp] = TARG;
+ return sp;
+
+nope:
+ rx->startp[0] = Nullch;
+ if (spat->spat_short)
+ ++spat->spat_short->str_u.str_useful;
+ if (gimme == G_ARRAY)
+ return sp;
+ str_sset(TARG,&str_no);
+ STABSET(TARG);
+ st[++sp] = TARG;
+ return sp;
+}
+
--- /dev/null
+int
+do_msgrcv(arglast)
+int *arglast;
+{
+#ifdef HAS_MSG
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *mstr;
+ char *mbuf;
+ long mtype;
+ int id, msize, flags, ret;
+
+ id = (int)str_gnum(st[++sp]);
+ mstr = st[++sp];
+ msize = (int)str_gnum(st[++sp]);
+ mtype = (long)str_gnum(st[++sp]);
+ flags = (int)str_gnum(st[++sp]);
+ mbuf = str_get(mstr);
+ if (mstr->str_cur < sizeof(long)+msize+1) {
+ STR_GROW(mstr, sizeof(long)+msize+1);
+ mbuf = str_get(mstr);
+ }
+ errno = 0;
+ ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
+ if (ret >= 0) {
+ mstr->str_cur = sizeof(long)+ret;
+ mstr->str_ptr[sizeof(long)+ret] = '\0';
+ }
+ return ret;
+#else
+ fatal("msgrcv not implemented");
+#endif
+}
+
--- /dev/null
+int
+do_msgsnd(arglast)
+int *arglast;
+{
+#ifdef HAS_MSG
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *mstr;
+ char *mbuf;
+ int id, msize, flags;
+
+ id = (int)str_gnum(st[++sp]);
+ mstr = st[++sp];
+ flags = (int)str_gnum(st[++sp]);
+ mbuf = str_get(mstr);
+ if ((msize = mstr->str_cur - sizeof(long)) < 0) {
+ errno = EINVAL;
+ return -1;
+ }
+ errno = 0;
+ return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
+#else
+ fatal("msgsnd not implemented");
+#endif
+}
+
--- /dev/null
+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") */
+ FILE *saveifp = Nullfp;
+ FILE *saveofp = Nullfp;
+ char savetype = ' ';
+
+ mode[0] = mode[1] = mode[2] = '\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 = 0;
+ else if (fd <= maxsysfd) {
+ saveifp = stio->ifp;
+ saveofp = stio->ofp;
+ savetype = stio->type;
+ result = 0;
+ }
+ else if (stio->type == '|')
+ result = mypclose(stio->ifp);
+ else if (stio->ifp != stio->ofp) {
+ if (stio->ofp) {
+ result = fclose(stio->ofp);
+ fclose(stio->ifp); /* clear stdio, fd already closed */
+ }
+ else
+ result = fclose(stio->ifp);
+ }
+ else
+ result = fclose(stio->ifp);
+ if (result == EOF && fd > maxsysfd)
+ fprintf(stderr,"Warning: unable to close filehandle %s properly.\n",
+ stab_ename(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 == '|') {
+ /*SUPPRESS 530*/
+ for (name++; isSPACE(*name); name++) ;
+ TAINT_ENV();
+ TAINT_PROPER("piped open");
+ fp = mypopen(name,"w");
+ writing = 1;
+ }
+ else if (*name == '>') {
+ TAINT_PROPER("open");
+ 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)) {
+#ifdef EINVAL
+ errno = EINVAL;
+#endif
+ goto say_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;
+ }
+ if (!(fp = fdopen(fd = dup(fd),mode))) {
+ close(fd);
+ }
+ }
+ 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] == '|') {
+ TAINT_ENV();
+ TAINT_PROPER("piped open");
+ name[--len] = '\0';
+ while (len && isSPACE(name[len-1]))
+ name[--len] = '\0';
+ /*SUPPRESS 530*/
+ for (; isSPACE(*name); name++) ;
+ fp = mypopen(name,"r");
+ stio->type = '|';
+ }
+ else {
+ stio->type = '<';
+ /*SUPPRESS 530*/
+ for (; isSPACE(*name); name++) ;
+ if (strEQ(name,"-")) {
+ fp = stdin;
+ stio->type = '-';
+ }
+ else
+ fp = fopen(name,"r");
+ }
+ }
+ if (!fp) {
+ if (dowarn && stio->type == '<' && index(name, '\n'))
+ warn(warn_nl, "open");
+ Safefree(myname);
+ goto say_false;
+ }
+ Safefree(myname);
+ if (stio->type &&
+ stio->type != '|' && stio->type != '-') {
+ if (fstat(fileno(fp),&statbuf) < 0) {
+ (void)fclose(fp);
+ goto say_false;
+ }
+ if (S_ISSOCK(statbuf.st_mode))
+ stio->type = 's'; /* in case a socket was passed in to us */
+#ifdef HAS_SOCKET
+ else if (
+#ifdef S_IFMT
+ !(statbuf.st_mode & S_IFMT)
+#else
+ !statbuf.st_mode
+#endif
+ ) {
+ int buflen = sizeof tokenbuf;
+ if (getsockname(fileno(fp), tokenbuf, &buflen) >= 0
+ || errno != ENOTSOCK)
+ stio->type = 's'; /* some OS's return 0 on fstat()ed socket */
+ /* but some return 0 for streams too, sigh */
+ }
+#endif
+ }
+ if (saveifp) { /* must use old fp? */
+ fd = fileno(saveifp);
+ if (saveofp) {
+ fflush(saveofp); /* emulate fclose() */
+ if (saveofp != saveifp) { /* was a socket? */
+ fclose(saveofp);
+ if (fd > 2)
+ Safefree(saveofp);
+ }
+ }
+ if (fd != fileno(fp)) {
+ int pid;
+ STR *TARG;
+
+ dup2(fileno(fp), fd);
+ TARG = afetch(fdpid,fileno(fp),TRUE);
+ pid = TARG->str_u.str_useful;
+ TARG->str_u.str_useful = 0;
+ TARG = afetch(fdpid,fd,TRUE);
+ TARG->str_u.str_useful = pid;
+ fclose(fp);
+
+ }
+ fp = saveifp;
+ clearerr(fp);
+ }
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fd = fileno(fp);
+ fcntl(fd,F_SETFD,fd > maxsysfd);
+#endif
+ stio->ifp = fp;
+ if (writing) {
+ if (stio->type == 's'
+ || (stio->type == '>' && S_ISCHR(statbuf.st_mode)) ) {
+ if (!(stio->ofp = fdopen(fileno(fp),"w"))) {
+ fclose(fp);
+ stio->ifp = Nullfp;
+ goto say_false;
+ }
+ }
+ else
+ stio->ofp = fp;
+ }
+ return TRUE;
+
+say_false:
+ stio->ifp = saveifp;
+ stio->ofp = saveofp;
+ stio->type = savetype;
+ return FALSE;
+}
+
--- /dev/null
+void
+do_pack(TARG,arglast)
+register STR *TARG;
+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;
+ /*SUPPRESS 442*/
+ 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;
+#ifdef QUAD
+ quad aquad;
+ unsigned quad auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+
+ items = arglast[2] - sp;
+ st += ++sp;
+ str_nset(TARG,"",0);
+ while (pat < patend) {
+#define NEXTFROM (items-- > 0 ? *st++ : &str_no)
+ datumtype = *pat++;
+ if (*pat == '*') {
+ len = index("@Xxu",datumtype) ? 0 : items;
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = 1;
+ switch(datumtype) {
+ default:
+ break;
+ case '%':
+ fatal("% may only be used in unpack");
+ case '@':
+ len -= TARG->str_cur;
+ if (len > 0)
+ goto grow;
+ len = -len;
+ if (len > 0)
+ goto shrink;
+ break;
+ case 'X':
+ shrink:
+ if (TARG->str_cur < len)
+ fatal("X outside of string");
+ TARG->str_cur -= len;
+ TARG->str_ptr[TARG->str_cur] = '\0';
+ break;
+ case 'x':
+ grow:
+ while (len >= 10) {
+ str_ncat(TARG,null10,10);
+ len -= 10;
+ }
+ str_ncat(TARG,null10,len);
+ break;
+ case 'A':
+ case 'a':
+ fromstr = NEXTFROM;
+ aptr = str_get(fromstr);
+ if (pat[-1] == '*')
+ len = fromstr->str_cur;
+ if (fromstr->str_cur > len)
+ str_ncat(TARG,aptr,len);
+ else {
+ str_ncat(TARG,aptr,fromstr->str_cur);
+ len -= fromstr->str_cur;
+ if (datumtype == 'A') {
+ while (len >= 10) {
+ str_ncat(TARG,space10,10);
+ len -= 10;
+ }
+ str_ncat(TARG,space10,len);
+ }
+ else {
+ while (len >= 10) {
+ str_ncat(TARG,null10,10);
+ len -= 10;
+ }
+ str_ncat(TARG,null10,len);
+ }
+ }
+ break;
+ case 'B':
+ case 'b':
+ {
+ char *savepat = pat;
+ int saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = str_get(fromstr);
+ if (pat[-1] == '*')
+ len = fromstr->str_cur;
+ pat = aptr;
+ aint = TARG->str_cur;
+ TARG->str_cur += (len+7)/8;
+ STR_GROW(TARG, TARG->str_cur + 1);
+ aptr = TARG->str_ptr + aint;
+ if (len > fromstr->str_cur)
+ len = fromstr->str_cur;
+ aint = len;
+ items = 0;
+ if (datumtype == 'B') {
+ for (len = 0; len++ < aint;) {
+ items |= *pat++ & 1;
+ if (len & 7)
+ items <<= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (*pat++ & 1)
+ items |= 128;
+ if (len & 7)
+ items >>= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 7) {
+ if (datumtype == 'B')
+ items <<= 7 - (aint & 7);
+ else
+ items >>= 7 - (aint & 7);
+ *aptr++ = items & 0xff;
+ }
+ pat = TARG->str_ptr + TARG->str_cur;
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'H':
+ case 'h':
+ {
+ char *savepat = pat;
+ int saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = str_get(fromstr);
+ if (pat[-1] == '*')
+ len = fromstr->str_cur;
+ pat = aptr;
+ aint = TARG->str_cur;
+ TARG->str_cur += (len+1)/2;
+ STR_GROW(TARG, TARG->str_cur + 1);
+ aptr = TARG->str_ptr + aint;
+ if (len > fromstr->str_cur)
+ len = fromstr->str_cur;
+ aint = len;
+ items = 0;
+ if (datumtype == 'H') {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*pat))
+ items |= ((*pat++ & 15) + 9) & 15;
+ else
+ items |= *pat++ & 15;
+ if (len & 1)
+ items <<= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*pat))
+ items |= (((*pat++ & 15) + 9) & 15) << 4;
+ else
+ items |= (*pat++ & 15) << 4;
+ if (len & 1)
+ items >>= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 1)
+ *aptr++ = items & 0xff;
+ pat = TARG->str_ptr + TARG->str_cur;
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'C':
+ case 'c':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = (int)str_gnum(fromstr);
+ achar = aint;
+ str_ncat(TARG,&achar,sizeof(char));
+ }
+ break;
+ /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ afloat = (float)str_gnum(fromstr);
+ str_ncat(TARG, (char *)&afloat, sizeof (float));
+ }
+ break;
+ case 'd':
+ case 'D':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ adouble = (double)str_gnum(fromstr);
+ str_ncat(TARG, (char *)&adouble, sizeof (double));
+ }
+ break;
+ case 'n':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (short)str_gnum(fromstr);
+#ifdef HAS_HTONS
+ ashort = htons(ashort);
+#endif
+ str_ncat(TARG,(char*)&ashort,sizeof(short));
+ }
+ break;
+ case 'v':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (short)str_gnum(fromstr);
+#ifdef HAS_HTOVS
+ ashort = htovs(ashort);
+#endif
+ str_ncat(TARG,(char*)&ashort,sizeof(short));
+ }
+ break;
+ case 'S':
+ case 's':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (short)str_gnum(fromstr);
+ str_ncat(TARG,(char*)&ashort,sizeof(short));
+ }
+ break;
+ case 'I':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auint = U_I(str_gnum(fromstr));
+ str_ncat(TARG,(char*)&auint,sizeof(unsigned int));
+ }
+ break;
+ case 'i':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = (int)str_gnum(fromstr);
+ str_ncat(TARG,(char*)&aint,sizeof(int));
+ }
+ break;
+ case 'N':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(str_gnum(fromstr));
+#ifdef HAS_HTONL
+ aulong = htonl(aulong);
+#endif
+ str_ncat(TARG,(char*)&aulong,sizeof(unsigned long));
+ }
+ break;
+ case 'V':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(str_gnum(fromstr));
+#ifdef HAS_HTOVL
+ aulong = htovl(aulong);
+#endif
+ str_ncat(TARG,(char*)&aulong,sizeof(unsigned long));
+ }
+ break;
+ case 'L':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(str_gnum(fromstr));
+ str_ncat(TARG,(char*)&aulong,sizeof(unsigned long));
+ }
+ break;
+ case 'l':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = (long)str_gnum(fromstr);
+ str_ncat(TARG,(char*)&along,sizeof(long));
+ }
+ break;
+#ifdef QUAD
+ case 'Q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auquad = (unsigned quad)str_gnum(fromstr);
+ str_ncat(TARG,(char*)&auquad,sizeof(unsigned quad));
+ }
+ break;
+ case 'q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aquad = (quad)str_gnum(fromstr);
+ str_ncat(TARG,(char*)&aquad,sizeof(quad));
+ }
+ break;
+#endif /* QUAD */
+ case 'p':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aptr = str_get(fromstr);
+ str_ncat(TARG,(char*)&aptr,sizeof(char*));
+ }
+ break;
+ case 'u':
+ fromstr = NEXTFROM;
+ aptr = str_get(fromstr);
+ aint = fromstr->str_cur;
+ STR_GROW(TARG,aint * 4 / 3);
+ if (len <= 1)
+ len = 45;
+ else
+ len = len / 3 * 3;
+ while (aint > 0) {
+ int todo;
+
+ if (aint > len)
+ todo = len;
+ else
+ todo = aint;
+ doencodes(TARG, aptr, todo);
+ aint -= todo;
+ aptr += todo;
+ }
+ break;
+ }
+ }
+ STABSET(TARG);
+}
+#undef NEXTFROM
+
+static void
+doencodes(TARG, s, len)
+register STR *TARG;
+register char *s;
+register int len;
+{
+ char hunk[5];
+
+ *hunk = len + ' ';
+ str_ncat(TARG, hunk, 1);
+ hunk[4] = '\0';
+ while (len > 0) {
+ hunk[0] = ' ' + (077 & (*s >> 2));
+ hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
+ hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
+ hunk[3] = ' ' + (077 & (s[2] & 077));
+ str_ncat(TARG, hunk, 4);
+ s += 3;
+ len -= 3;
+ }
+ for (s = TARG->str_ptr; *s; s++) {
+ if (*s == ' ')
+ *s = '`';
+ }
+ str_ncat(TARG, "\n", 1);
+}
+
--- /dev/null
+#ifdef HAS_PIPE
+void
+do_pipe(TARG, rstab, wstab)
+STR *TARG;
+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 = '>';
+ if (!rstio->ifp || !wstio->ofp) {
+ if (rstio->ifp) fclose(rstio->ifp);
+ else close(fd[0]);
+ if (wstio->ofp) fclose(wstio->ofp);
+ else close(fd[1]);
+ goto badexit;
+ }
+
+ str_sset(TARG,&str_yes);
+ return;
+
+badexit:
+ str_sset(TARG,&str_undef);
+ return;
+}
+#endif
+
--- /dev/null
+bool
+do_print(TARG,fp)
+register STR *TARG;
+FILE *fp;
+{
+ register char *tmps;
+
+ if (!fp) {
+ if (dowarn)
+ warn("print to unopened file");
+ errno = EBADF;
+ return FALSE;
+ }
+ if (!TARG)
+ return TRUE;
+ if (ofmt &&
+ ((TARG->str_nok && TARG->str_u.str_nval != 0.0)
+ || (looks_like_number(TARG) && str_gnum(TARG) != 0.0) ) ) {
+ fprintf(fp, ofmt, TARG->str_u.str_nval);
+ return !ferror(fp);
+ }
+ else {
+ tmps = str_get(TARG);
+ if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'B' && tmps[3] == '\0'
+ && TARG->str_cur == sizeof(STBP) && strlen(tmps) < TARG->str_cur) {
+ STR *tmpstr = str_mortal(&str_undef);
+ stab_efullname(tmpstr,((STAB*)TARG));/* a stab value, be nice */
+ TARG = tmpstr;
+ tmps = TARG->str_ptr;
+ putc('*',fp);
+ }
+ if (TARG->str_cur && (fwrite(tmps,1,TARG->str_cur,fp) == 0 || ferror(fp)))
+ return FALSE;
+ }
+ return TRUE;
+}
+
--- /dev/null
+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 *TARG = &str_undef;
+
+ for (st += ++sp; items > 0; items--,st++) {
+ TARG = Str_new(26,0);
+ if (*st)
+ str_sset(TARG,*st);
+ (void)apush(ary,TARG);
+ }
+ return TARG;
+}
+
--- /dev/null
+int
+do_range(gimme,arglast)
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ register int i;
+ register ARRAY *ary = stack;
+ register STR *TARG;
+ int max;
+
+ if (gimme != G_ARRAY)
+ fatal("panic: do_range");
+
+ if (st[sp+1]->str_nok || !st[sp+1]->str_pok ||
+ (looks_like_number(st[sp+1]) && *st[sp+1]->str_ptr != '0') ) {
+ i = (int)str_gnum(st[sp+1]);
+ max = (int)str_gnum(st[sp+2]);
+ if (max > i)
+ (void)astore(ary, sp + max - i + 1, Nullstr);
+ while (i <= max) {
+ (void)astore(ary, ++sp, TARG = str_mortal(&str_no));
+ str_numset(TARG,(double)i++);
+ }
+ }
+ else {
+ STR *final = str_mortal(st[sp+2]);
+ char *tmps = str_get(final);
+
+ TARG = str_mortal(st[sp+1]);
+ while (!TARG->str_nok && TARG->str_cur <= final->str_cur &&
+ strNE(TARG->str_ptr,tmps) ) {
+ (void)astore(ary, ++sp, TARG);
+ TARG = str_2mortal(str_smake(TARG));
+ str_inc(TARG);
+ }
+ if (strEQ(TARG->str_ptr,tmps))
+ (void)astore(ary, ++sp, TARG);
+ }
+ return sp;
+}
+
--- /dev/null
+int
+do_repeatary(ARGS)
+ARGSdecl
+{
+ MSP;
+ register int count = POPi;
+ register int items = sp - mark;
+ register int i;
+ int max;
+
+ max = items * count;
+ MEXTEND(mark,max);
+ if (count > 1) {
+ while (sp > mark) {
+ if (*sp)
+ (*sp)->str_pok &= ~SP_TEMP;
+ }
+ mark++;
+ repeatcpy(mark + items, mark, items * sizeof(STR*), count - 1);
+ }
+ sp += max;
+
+ MRETURN;
+}
+
--- /dev/null
+int
+do_reverse(arglast)
+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];
+
+ while (i-- > 0) {
+ *up++ = *down;
+ if (i-- > 0)
+ *down-- = *up;
+ }
+ i = arglast[2] - arglast[1];
+ Move(down+1,up,i/2,STR*);
+ return arglast[2] - 1;
+}
+
--- /dev/null
+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;
+
+#ifdef ULTRIX_STDIO_BOTCH
+ if (feof(stio->ifp))
+ (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */
+#endif
+
+ return fseek(stio->ifp, pos, whence) >= 0;
+
+nuts:
+ if (dowarn)
+ warn("seek() on unopened file");
+ errno = EBADF;
+ return FALSE;
+}
+
--- /dev/null
+#ifdef HAS_SELECT
+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 *TARG;
+ 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++) {
+ TARG = st[sp+i];
+ j = TARG->str_len;
+ if (j < growsize) {
+ if (TARG->str_pok) {
+ Str_Grow(TARG,growsize);
+ s = str_get(TARG) + j;
+ while (++j <= growsize) {
+ *s++ = '\0';
+ }
+ }
+ else if (TARG->str_ptr) {
+ Safefree(TARG->str_ptr);
+ TARG->str_ptr = Nullch;
+ }
+ }
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ s = TARG->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
+ }
+ TARG = st[sp+4];
+ if (TARG->str_nok || TARG->str_pok) {
+ value = str_gnum(TARG);
+ 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]) {
+ TARG = st[sp+i];
+ s = TARG->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];
+ }
+ Safefree(fd_sets[i]);
+ }
+ }
+#endif
+
+ st[++sp] = str_mortal(&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_mortal(&str_no);
+ str_numset(st[sp], value);
+ }
+ return sp;
+}
+#endif /* SELECT */
+
--- /dev/null
+int
+do_semop(arglast)
+int *arglast;
+{
+#ifdef HAS_SEM
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *opstr;
+ char *opbuf;
+ int id, opsize;
+
+ id = (int)str_gnum(st[++sp]);
+ opstr = st[++sp];
+ opbuf = str_get(opstr);
+ opsize = opstr->str_cur;
+ if (opsize < sizeof(struct sembuf)
+ || (opsize % sizeof(struct sembuf)) != 0) {
+ errno = EINVAL;
+ return -1;
+ }
+ errno = 0;
+ return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
+#else
+ fatal("semop not implemented");
+#endif
+}
+
--- /dev/null
+int
+do_shmio(optype, arglast)
+int optype;
+int *arglast;
+{
+#ifdef HAS_SHM
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *mstr;
+ char *mbuf, *shm;
+ int id, mpos, msize;
+ struct shmid_ds shmds;
+#ifndef VOIDSHMAT
+ extern char *shmat();
+#endif
+
+ id = (int)str_gnum(st[++sp]);
+ mstr = st[++sp];
+ mpos = (int)str_gnum(st[++sp]);
+ msize = (int)str_gnum(st[++sp]);
+ errno = 0;
+ if (shmctl(id, IPC_STAT, &shmds) == -1)
+ return -1;
+ if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
+ errno = EFAULT; /* can't do as caller requested */
+ return -1;
+ }
+ shm = (char*)shmat(id, (char*)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
+ if (shm == (char *)-1) /* I hate System V IPC, I really do */
+ return -1;
+ mbuf = str_get(mstr);
+ if (optype == O_SHMREAD) {
+ if (mstr->str_cur < msize) {
+ STR_GROW(mstr, msize+1);
+ mbuf = str_get(mstr);
+ }
+ Copy(shm + mpos, mbuf, msize, char);
+ mstr->str_cur = msize;
+ mstr->str_ptr[msize] = '\0';
+ }
+ else {
+ int n;
+
+ if ((n = mstr->str_cur) > msize)
+ n = msize;
+ Copy(mbuf, shm + mpos, n, char);
+ if (n < msize)
+ memzero(shm + mpos + n, msize - n);
+ }
+ return shmdt(shm);
+#else
+ fatal("shm I/O not implemented");
+#endif
+}
+
--- /dev/null
+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");
+ errno = EBADF;
+ return FALSE;
+
+}
+
--- /dev/null
+int
+do_slice(stab,TARG,numarray,lval,gimme,arglast)
+STAB *stab;
+STR *TARG;
+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;
+ register ARRAY *ary;
+ register HASH *hash;
+ int oldarybase = arybase;
+
+ if (numarray) {
+ if (numarray == 2) { /* a slice of a LIST */
+ ary = stack;
+ ary->ary_fill = arglast[3];
+ arybase -= max + 1;
+ st[sp] = TARG; /* make stack size available */
+ str_numset(TARG,(double)(sp - 1));
+ }
+ else
+ ary = stab_array(stab); /* a slice of an array */
+ }
+ else {
+ if (lval) {
+ 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 */
+ }
+ hash = stab_hash(stab); /* a slice of an associative array */
+ }
+
+ if (gimme == G_ARRAY) {
+ if (numarray) {
+ while (sp < max) {
+ if (st[++sp]) {
+ st[sp-1] = afetch(ary,
+ ((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(hash,tmps,len, lval);
+ if (magic)
+ str_magic(st[sp-1],stab,magic,tmps,len);
+ }
+ else
+ st[sp-1] = &str_undef;
+ }
+ }
+ sp--;
+ }
+ else {
+ if (sp == max)
+ st[sp] = &str_undef;
+ else if (numarray) {
+ if (st[max])
+ st[sp] = afetch(ary,
+ ((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(hash,tmps,len, lval);
+ if (magic)
+ str_magic(st[sp],stab,magic,tmps,len);
+ }
+ else
+ st[sp] = &str_undef;
+ }
+ }
+ arybase = oldarybase;
+ return sp;
+}
+
--- /dev/null
+#ifdef HAS_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) {
+ errno = EBADF;
+ 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]);
+ TAINT_PROPER("socket");
+ 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';
+ if (!stio->ifp || !stio->ofp) {
+ if (stio->ifp) fclose(stio->ifp);
+ if (stio->ofp) fclose(stio->ofp);
+ if (!stio->ifp && !stio->ofp) close(fd);
+ return FALSE;
+ }
+
+ return TRUE;
+}
+
--- /dev/null
+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;
+ unsigned int lvl;
+ unsigned int optname;
+
+ if (!stab)
+ goto nuts;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto nuts;
+
+ fd = fileno(stio->ifp);
+ lvl = (unsigned int)str_gnum(st[sp+1]);
+ optname = (unsigned int)str_gnum(st[sp+2]);
+ switch (optype) {
+ case O_GSOCKOPT:
+ st[sp] = str_2mortal(Str_new(22,257));
+ st[sp]->str_cur = 256;
+ st[sp]->str_pok = 1;
+ if (getsockopt(fd, lvl, optname, st[sp]->str_ptr,
+ (int*)&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;
+ errno = EBADF;
+ return sp;
+
+}
+
--- /dev/null
+int
+do_sort(TARG,arg,gimme,arglast)
+STR *TARG;
+ARG *arg;
+int gimme;
+int *arglast;
+{
+ register 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;
+ HASH *stash;
+ STR *sortsubvar;
+
+ if (gimme != G_ARRAY) {
+ str_sset(TARG,&str_undef);
+ STABSET(TARG);
+ st[sp] = TARG;
+ return sp;
+ }
+ up = &st[sp];
+ sortsubvar = *up;
+ st += sp; /* temporarily make st point to args */
+ for (i = 1; i <= max; i++) {
+ /*SUPPRESS 560*/
+ if (*up = st[i]) {
+ if (!(*up)->str_pok)
+ (void)str_2ptr(*up);
+ else
+ (*up)->str_pok &= ~SP_TEMP;
+ up++;
+ }
+ }
+ st -= sp;
+ max = up - &st[sp];
+ sp--;
+ if (max > 1) {
+ STAB *stab;
+
+ if (arg[1].arg_type == (A_CMD|A_DONT)) {
+ sortcmd = arg[1].arg_ptr.arg_cmd;
+ stash = curcmd->c_stash;
+ }
+ else {
+ if ((arg[1].arg_type & A_MASK) == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sortsubvar),TRUE);
+
+ if (stab) {
+ if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd))
+ fatal("Undefined subroutine \"%s\" in sort",
+ stab_ename(stab));
+ stash = stab_estash(stab);
+ }
+ else
+ sortcmd = Nullcmd;
+ }
+
+ if (sortcmd) {
+ int oldtmps_base = tmps_base;
+
+ if (!sortstack) {
+ sortstack = anew(Nullstab);
+ astore(sortstack, 0, Nullstr);
+ aclear(sortstack);
+ sortstack->ary_flags = 0;
+ }
+ oldstack = stack;
+ stack = sortstack;
+ tmps_base = tmps_max;
+ if (sortstash != stash) {
+ firststab = stabent("a",TRUE);
+ secondstab = stabent("b",TRUE);
+ sortstash = stash;
+ }
+ 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
+ }
+ return sp+max;
+}
+
--- /dev/null
+#ifdef HAS_SOCKET
+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]);
+TAINT_PROPER("in socketpair");
+#ifdef HAS_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';
+ if (!stio1->ifp || !stio1->ofp || !stio2->ifp || !stio2->ofp) {
+ if (stio1->ifp) fclose(stio1->ifp);
+ if (stio1->ofp) fclose(stio1->ofp);
+ if (!stio1->ifp && !stio1->ofp) close(fd[0]);
+ if (stio2->ifp) fclose(stio2->ifp);
+ if (stio2->ofp) fclose(stio2->ofp);
+ if (!stio2->ifp && !stio2->ofp) close(fd[1]);
+ return FALSE;
+ }
+
+ return TRUE;
+}
+
--- /dev/null
+int
+do_splice(ary,gimme,arglast)
+register ARRAY *ary;
+int gimme;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ int max = arglast[2] + 1;
+ register STR **src;
+ register STR **dst;
+ register int i;
+ register int offset;
+ register int length;
+ int newlen;
+ int after;
+ int diff;
+ STR **tmparyval;
+
+ if (++sp < max) {
+ offset = (int)str_gnum(st[sp]);
+ if (offset < 0)
+ offset += ary->ary_fill + 1;
+ else
+ offset -= arybase;
+ if (++sp < max) {
+ length = (int)str_gnum(st[sp++]);
+ if (length < 0)
+ length = 0;
+ }
+ else
+ length = ary->ary_max + 1; /* close enough to infinity */
+ }
+ else {
+ offset = 0;
+ length = ary->ary_max + 1;
+ }
+ if (offset < 0) {
+ length += offset;
+ offset = 0;
+ if (length < 0)
+ length = 0;
+ }
+ if (offset > ary->ary_fill + 1)
+ offset = ary->ary_fill + 1;
+ after = ary->ary_fill + 1 - (offset + length);
+ if (after < 0) { /* not that much array */
+ length += after; /* offset+length now in array */
+ after = 0;
+ if (!ary->ary_alloc) {
+ afill(ary,0);
+ afill(ary,-1);
+ }
+ }
+
+ /* At this point, sp .. max-1 is our new LIST */
+
+ newlen = max - sp;
+ diff = newlen - length;
+
+ if (diff < 0) { /* shrinking the area */
+ if (newlen) {
+ New(451, tmparyval, newlen, STR*); /* so remember insertion */
+ Copy(st+sp, tmparyval, newlen, STR*);
+ }
+
+ sp = arglast[0] + 1;
+ if (gimme == G_ARRAY) { /* copy return vals to stack */
+ if (sp + length >= stack->ary_max) {
+ astore(stack,sp + length, Nullstr);
+ st = stack->ary_array;
+ }
+ Copy(ary->ary_array+offset, st+sp, length, STR*);
+ if (ary->ary_flags & ARF_REAL) {
+ for (i = length, dst = st+sp; i; i--)
+ str_2mortal(*dst++); /* free them eventualy */
+ }
+ sp += length - 1;
+ }
+ else {
+ st[sp] = ary->ary_array[offset+length-1];
+ if (ary->ary_flags & ARF_REAL) {
+ str_2mortal(st[sp]);
+ for (i = length - 1, dst = &ary->ary_array[offset]; i > 0; i--)
+ str_free(*dst++); /* free them now */
+ }
+ }
+ ary->ary_fill += diff;
+
+ /* pull up or down? */
+
+ if (offset < after) { /* easier to pull up */
+ if (offset) { /* esp. if nothing to pull */
+ src = &ary->ary_array[offset-1];
+ dst = src - diff; /* diff is negative */
+ for (i = offset; i > 0; i--) /* can't trust Copy */
+ *dst-- = *src--;
+ }
+ Zero(ary->ary_array, -diff, STR*);
+ ary->ary_array -= diff; /* diff is negative */
+ ary->ary_max += diff;
+ }
+ else {
+ if (after) { /* anything to pull down? */
+ src = ary->ary_array + offset + length;
+ dst = src + diff; /* diff is negative */
+ Move(src, dst, after, STR*);
+ }
+ Zero(&ary->ary_array[ary->ary_fill+1], -diff, STR*);
+ /* avoid later double free */
+ }
+ if (newlen) {
+ for (src = tmparyval, dst = ary->ary_array + offset;
+ newlen; newlen--) {
+ *dst = Str_new(46,0);
+ str_sset(*dst++,*src++);
+ }
+ Safefree(tmparyval);
+ }
+ }
+ else { /* no, expanding (or same) */
+ if (length) {
+ New(452, tmparyval, length, STR*); /* so remember deletion */
+ Copy(ary->ary_array+offset, tmparyval, length, STR*);
+ }
+
+ if (diff > 0) { /* expanding */
+
+ /* push up or down? */
+
+ if (offset < after && diff <= ary->ary_array - ary->ary_alloc) {
+ if (offset) {
+ src = ary->ary_array;
+ dst = src - diff;
+ Move(src, dst, offset, STR*);
+ }
+ ary->ary_array -= diff; /* diff is positive */
+ ary->ary_max += diff;
+ ary->ary_fill += diff;
+ }
+ else {
+ if (ary->ary_fill + diff >= ary->ary_max) /* oh, well */
+ astore(ary, ary->ary_fill + diff, Nullstr);
+ else
+ ary->ary_fill += diff;
+ dst = ary->ary_array + ary->ary_fill;
+ for (i = diff; i > 0; i--) {
+ if (*dst) /* TARG was hanging around */
+ str_free(*dst); /* after $#foo */
+ dst--;
+ }
+ if (after) {
+ dst = ary->ary_array + ary->ary_fill;
+ src = dst - diff;
+ for (i = after; i; i--) {
+ *dst-- = *src--;
+ }
+ }
+ }
+ }
+
+ for (src = st+sp, dst = ary->ary_array + offset; newlen; newlen--) {
+ *dst = Str_new(46,0);
+ str_sset(*dst++,*src++);
+ }
+ sp = arglast[0] + 1;
+ if (gimme == G_ARRAY) { /* copy return vals to stack */
+ if (length) {
+ Copy(tmparyval, st+sp, length, STR*);
+ if (ary->ary_flags & ARF_REAL) {
+ for (i = length, dst = st+sp; i; i--)
+ str_2mortal(*dst++); /* free them eventualy */
+ }
+ Safefree(tmparyval);
+ }
+ sp += length - 1;
+ }
+ else if (length--) {
+ st[sp] = tmparyval[length];
+ if (ary->ary_flags & ARF_REAL) {
+ str_2mortal(st[sp]);
+ while (length-- > 0)
+ str_free(tmparyval[length]);
+ }
+ Safefree(tmparyval);
+ }
+ else
+ st[sp] = &str_undef;
+ }
+ return sp;
+}
+
--- /dev/null
+int
+do_split(TARG,spat,limit,gimme,arglast)
+STR *TARG;
+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 (*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 = Null(REGEXP*); /* avoid possible double free */
+ }
+ spat->spat_regexp = regcomp(m,m+dstr->str_cur,
+ spat->spat_flags & SPAT_FOLD);
+ 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 (strEQ("\\s+",spat->spat_regexp->precomp)) {
+ while (--limit) {
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && !isSPACE(*m); m++) ;
+ if (m >= strend)
+ break;
+ dstr = Str_new(30,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ /*SUPPRESS 530*/
+ for (s = m + 1; s < strend && isSPACE(*s); s++) ;
+ }
+ }
+ else if (strEQ("^",spat->spat_regexp->precomp)) {
+ while (--limit) {
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != '\n'; m++) ;
+ m++;
+ if (m >= strend)
+ break;
+ dstr = Str_new(30,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ s = m;
+ }
+ }
+ else if (spat->spat_short) {
+ i = spat->spat_short->str_cur;
+ if (i == 1) {
+ int fold = (spat->spat_flags & SPAT_FOLD);
+
+ i = *spat->spat_short->str_ptr;
+ if (fold && isUPPER(i))
+ i = tolower(i);
+ while (--limit) {
+ if (fold) {
+ for ( m = s;
+ m < strend && *m != i &&
+ (!isUPPER(*m) || tolower(*m) != i);
+ m++) /*SUPPRESS 530*/
+ ;
+ }
+ else /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != i; m++) ;
+ if (m >= strend)
+ break;
+ dstr = Str_new(30,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (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
+ {
+ dstr = Str_new(31,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (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];
+ dstr = Str_new(32,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (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];
+ dstr = Str_new(33,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (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? */
+ dstr = Str_new(34,strend-s);
+ str_nset(dstr,s,strend-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ iters++;
+ }
+ else {
+#ifndef I286x
+ 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(TARG,(double)iters);
+ STABSET(TARG);
+ st[sp] = TARG;
+ return sp;
+}
+
--- /dev/null
+void
+do_sprintf(TARG,len,sarg)
+register STR *TARG;
+register int len;
+register STR **sarg;
+{
+ register char *s;
+ register char *t;
+ register char *f;
+ bool dolong;
+#ifdef QUAD
+ bool doquad;
+#endif /* QUAD */
+ char ch;
+ register char *send;
+ register STR *arg;
+ char *xs;
+ int xlen;
+ int pre;
+ int post;
+ double value;
+
+ str_set(TARG,"");
+ len--; /* don't count pattern string */
+ t = s = str_get(*sarg);
+ send = s + (*sarg)->str_cur;
+ sarg++;
+ for ( ; ; len--) {
+
+ /*SUPPRESS 560*/
+ if (len <= 0 || !(arg = *sarg++))
+ arg = &str_no;
+
+ /*SUPPRESS 530*/
+ for ( ; t < send && *t != '%'; t++) ;
+ if (t >= send)
+ break; /* end of format string, ignore extra args */
+ f = t;
+ *buf = '\0';
+ xs = buf;
+#ifdef QUAD
+ doquad =
+#endif /* QUAD */
+ dolong = FALSE;
+ pre = post = 0;
+ for (t++; t < send; t++) {
+ switch (*t) {
+ default:
+ ch = *(++t);
+ *t = '\0';
+ (void)sprintf(xs,f);
+ len++, sarg--;
+ xlen = strlen(xs);
+ 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 '+': case ' ':
+ continue;
+ case 'l':
+#ifdef QUAD
+ if (dolong) {
+ dolong = FALSE;
+ doquad = TRUE;
+ } else
+#endif
+ dolong = TRUE;
+ continue;
+ case 'c':
+ ch = *(++t);
+ *t = '\0';
+ xlen = (int)str_gnum(arg);
+ if (strEQ(f,"%c")) { /* some printfs fail on null chars */
+ *xs = xlen;
+ xs[1] = '\0';
+ xlen = 1;
+ }
+ else {
+ (void)sprintf(xs,f,xlen);
+ xlen = strlen(xs);
+ }
+ break;
+ case 'D':
+ dolong = TRUE;
+ /* FALL THROUGH */
+ case 'd':
+ ch = *(++t);
+ *t = '\0';
+#ifdef QUAD
+ if (doquad)
+ (void)sprintf(buf,s,(quad)str_gnum(arg));
+ else
+#endif
+ if (dolong)
+ (void)sprintf(xs,f,(long)str_gnum(arg));
+ else
+ (void)sprintf(xs,f,(int)str_gnum(arg));
+ xlen = strlen(xs);
+ break;
+ case 'X': case 'O':
+ dolong = TRUE;
+ /* FALL THROUGH */
+ case 'x': case 'o': case 'u':
+ ch = *(++t);
+ *t = '\0';
+ value = str_gnum(arg);
+#ifdef QUAD
+ if (doquad)
+ (void)sprintf(buf,s,(unsigned quad)value);
+ else
+#endif
+ if (dolong)
+ (void)sprintf(xs,f,U_L(value));
+ else
+ (void)sprintf(xs,f,U_I(value));
+ xlen = strlen(xs);
+ break;
+ case 'E': case 'e': case 'f': case 'G': case 'g':
+ ch = *(++t);
+ *t = '\0';
+ (void)sprintf(xs,f,str_gnum(arg));
+ xlen = strlen(xs);
+ break;
+ case 's':
+ ch = *(++t);
+ *t = '\0';
+ xs = str_get(arg);
+ xlen = arg->str_cur;
+ if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xs[3] == '\0'
+ && xlen == sizeof(STBP)) {
+ STR *tmpstr = Str_new(24,0);
+
+ stab_efullname(tmpstr, ((STAB*)arg)); /* a stab value! */
+ sprintf(tokenbuf,"*%s",tmpstr->str_ptr);
+ /* reformat to non-binary */
+ xs = tokenbuf;
+ xlen = strlen(tokenbuf);
+ str_free(tmpstr);
+ }
+ if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
+ break; /* so handle simple cases */
+ }
+ else if (f[1] == '-') {
+ char *mp = index(f, '.');
+ int min = atoi(f+2);
+
+ if (mp) {
+ int max = atoi(mp+1);
+
+ if (xlen > max)
+ xlen = max;
+ }
+ if (xlen < min)
+ post = min - xlen;
+ break;
+ }
+ else if (isDIGIT(f[1])) {
+ char *mp = index(f, '.');
+ int min = atoi(f+1);
+
+ if (mp) {
+ int max = atoi(mp+1);
+
+ if (xlen > max)
+ xlen = max;
+ }
+ if (xlen < min)
+ pre = min - xlen;
+ break;
+ }
+ strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
+ *t = ch;
+ (void)sprintf(buf,tokenbuf+64,xs);
+ xs = buf;
+ xlen = strlen(xs);
+ break;
+ }
+ /* end of switch, copy results */
+ *t = ch;
+ STR_GROW(TARG, TARG->str_cur + (f - s) + xlen + 1 + pre + post);
+ str_ncat(TARG, s, f - s);
+ if (pre) {
+ repeatcpy(TARG->str_ptr + TARG->str_cur, " ", 1, pre);
+ TARG->str_cur += pre;
+ }
+ str_ncat(TARG, xs, xlen);
+ if (post) {
+ repeatcpy(TARG->str_ptr + TARG->str_cur, " ", 1, post);
+ TARG->str_cur += post;
+ }
+ s = t;
+ break; /* break from for loop */
+ }
+ }
+ str_ncat(TARG, s, t - s);
+ STABSET(TARG);
+}
+
--- /dev/null
+int
+do_sreverse(TARG,arglast)
+STR *TARG;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register char *up;
+ register char *down;
+ register int tmp;
+
+ str_sset(TARG,st[arglast[2]]);
+ up = str_get(TARG);
+ if (TARG->str_cur > 1) {
+ down = TARG->str_ptr + TARG->str_cur - 1;
+ while (down > up) {
+ tmp = *up;
+ *up++ = *down;
+ *down-- = tmp;
+ }
+ }
+ STABSET(TARG);
+ st[arglast[0]+1] = TARG;
+ return arglast[0]+1;
+}
+
--- /dev/null
+int
+do_stat(TARG,arg,gimme,arglast)
+STR *TARG;
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ register int sp = arglast[0] + 1;
+ int max = 13;
+
+ if ((arg[1].arg_type & A_MASK) == A_WORD) {
+ tmpstab = arg[1].arg_ptr.arg_stab;
+ if (tmpstab != defstab) {
+ laststype = O_STAT;
+ statstab = tmpstab;
+ str_set(statname,"");
+ if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
+ fstat(fileno(stab_io(tmpstab)->ifp),&statcache) < 0) {
+ max = 0;
+ laststatval = -1;
+ }
+ }
+ else if (laststatval < 0)
+ max = 0;
+ }
+ else {
+ str_set(statname,str_get(ary->ary_array[sp]));
+ statstab = Nullstab;
+#ifdef HAS_LSTAT
+ laststype = arg->arg_type;
+ if (arg->arg_type == O_LSTAT)
+ laststatval = lstat(str_get(statname),&statcache);
+ else
+#endif
+ laststatval = stat(str_get(statname),&statcache);
+ if (laststatval < 0) {
+ if (dowarn && index(str_get(statname), '\n'))
+ warn(warn_nl, "stat");
+ max = 0;
+ }
+ }
+
+ if (gimme != G_ARRAY) {
+ if (max)
+ str_sset(TARG,&str_yes);
+ else
+ str_sset(TARG,&str_undef);
+ STABSET(TARG);
+ ary->ary_array[sp] = TARG;
+ return sp;
+ }
+ sp--;
+ if (max) {
+#ifndef lint
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_dev)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_ino)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_mode)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_nlink)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_uid)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_gid)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_rdev)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_size)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_atime)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_mtime)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_ctime)));
+#ifdef STATBLOCKS
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_blksize)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_blocks)));
+#else
+ (void)astore(ary,++sp,
+ str_2mortal(str_make("",0)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_make("",0)));
+#endif
+#else /* lint */
+ (void)astore(ary,++sp,str_nmake(0.0));
+#endif /* lint */
+ }
+ return sp;
+}
+
--- /dev/null
+int /*SUPPRESS 590*/
+do_study(TARG,arg,gimme,arglast)
+STR *TARG;
+ARG *arg;
+int gimme;
+int *arglast;
+{
+ register unsigned char *s;
+ register int pos = TARG->str_cur;
+ register int ch;
+ register int *sfirst;
+ register int *snext;
+ int retval;
+ int retarg = arglast[0] + 1;
+
+#ifndef lint
+ s = (unsigned char*)(str_get(TARG));
+#else
+ s = Null(unsigned char*);
+#endif
+ if (lastscream)
+ lastscream->str_pok &= ~SP_STUDIED;
+ lastscream = TARG;
+ 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;
+ }
+
+ TARG->str_pok |= SP_STUDIED;
+ retval = 1;
+ ret:
+ str_numset(ARGTARG,(double)retval);
+ stack->ary_array[retarg] = ARGTARG;
+ return retarg;
+}
+
--- /dev/null
+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;
+ SPAT * VOL oldspat = curspat;
+ STR *TARG;
+ STAB *stab;
+ int oldsave = savestack->ary_fill;
+ int oldtmps_base = tmps_base;
+ int hasargs = ((arg[2].arg_type & A_MASK) != A_NULL);
+ register CSV *csv;
+
+ if ((arg[1].arg_type & A_MASK) == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else {
+ STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
+
+ if (tmpstr)
+ stab = stabent(str_get(tmpstr),TRUE);
+ else
+ stab = Nullstab;
+ }
+ if (!stab)
+ fatal("Undefined subroutine called");
+ if (!(sub = stab_sub(stab))) {
+ STR *tmpstr = arg[0].arg_ptr.arg_str;
+
+ stab_efullname(tmpstr, stab);
+ fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr);
+ }
+ if (arg->arg_type == O_DBSUBR && !sub->usersub) {
+ TARG = stab_val(DBsub);
+ saveitem(TARG);
+ stab_efullname(TARG,stab);
+ sub = stab_sub(DBsub);
+ if (!sub)
+ fatal("No DBsub routine");
+ }
+ TARG = Str_new(15, sizeof(CSV));
+ TARG->str_state = SS_SCSV;
+ (void)apush(savestack,TARG);
+ csv = (CSV*)TARG->str_ptr;
+ csv->sub = sub;
+ csv->stab = stab;
+ csv->oldcsv = curcsv;
+ csv->oldcmd = curcmd;
+ csv->depth = sub->depth;
+ csv->wantarray = gimme;
+ csv->hasargs = hasargs;
+ curcsv = csv;
+ tmps_base = tmps_max;
+ if (sub->usersub) {
+ csv->hasargs = 0;
+ csv->savearray = Null(ARRAY*);;
+ csv->argarray = Null(ARRAY*);
+ st[sp] = ARGTARG;
+ if (!hasargs)
+ items = 0;
+ sp = (*sub->usersub)(sub->userindex,sp,items);
+ }
+ else {
+ if (hasargs) {
+ csv->savearray = stab_xarray(defstab);
+ csv->argarray = afake(defstab, items, &st[sp+1]);
+ stab_xarray(defstab) = csv->argarray;
+ }
+ sub->depth++;
+ if (sub->depth >= 2) { /* save temporaries on recursion? */
+ if (sub->depth == 100 && dowarn)
+ warn("Deep recursion on subroutine \"%s\"",stab_ename(stab));
+ savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
+ }
+ sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */
+ }
+
+ st = stack->ary_array;
+ tmps_base = oldtmps_base;
+ for (items = arglast[0] + 1; items <= sp; items++)
+ st[items] = str_mortal(st[items]);
+ /* in case restore wipes old TARG */
+ restorelist(oldsave);
+ curspat = oldspat;
+ return sp;
+}
+
--- /dev/null
+int
+do_subst(TARG,arg,sp)
+STR *TARG;
+ARG *arg;
+int sp;
+{
+ register SPAT *spat;
+ SPAT *rspat;
+ register STR *dstr;
+ register char *s = str_get(TARG);
+ char *strend = s + TARG->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 = Null(REGEXP*); /* required if regcomp pukes */
+ }
+ spat->spat_regexp = regcomp(m,m+dstr->str_cur,
+ spat->spat_flags & SPAT_FOLD);
+ if (spat->spat_flags & SPAT_KEEP) {
+ if (!(spat->spat_flags & SPAT_FOLD))
+ scanconst(spat, m, dstr->str_cur);
+ arg_free(spat->spat_runtime); /* it won't change, so */
+ spat->spat_runtime = Nullarg; /* no point compiling again */
+ hoistmust(spat);
+ if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
+ curcmd->c_flags &= ~CF_OPTIMIZE;
+ opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
+ }
+ }
+ }
+#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->prelen && 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 (TARG->str_pok & SP_STUDIED) {
+ if (screamfirst[spat->spat_short->str_rare] < 0)
+ goto nope;
+ else if (!(s = screaminstr(TARG,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_GLOBAL);
+ 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_regexp->minlen) {
+ /* can do inplace substitution */
+ if (regexec(spat->spat_regexp, s, strend, orig, 0,
+ TARG->str_pok & SP_STUDIED ? TARG : Nullstr, safebase)) {
+ if (spat->spat_regexp->subbase) /* oops, no we can't */
+ goto long_way;
+ d = s;
+ lastspat = spat;
+ TARG->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) {
+ Copy(c, m, clen, char);
+ m += clen;
+ }
+ i = strend - d;
+ if (i > 0) {
+ Move(d, m, i, char);
+ m += i;
+ }
+ *m = '\0';
+ TARG->str_cur = m - s;
+ STABSET(TARG);
+ str_numset(ARGTARG, 1.0);
+ stack->ary_array[++sp] = ARGTARG;
+ return sp;
+ }
+ /*SUPPRESS 560*/
+ else if (i = m - s) { /* faster from front */
+ d -= clen;
+ m = d;
+ str_chop(TARG,d-i);
+ s += i;
+ while (i--)
+ *--d = *--s;
+ if (clen)
+ Copy(c, m, clen, char);
+ STABSET(TARG);
+ str_numset(ARGTARG, 1.0);
+ stack->ary_array[++sp] = ARGTARG;
+ return sp;
+ }
+ else if (clen) {
+ d -= clen;
+ str_chop(TARG,d);
+ Copy(c,d,clen,char);
+ STABSET(TARG);
+ str_numset(ARGTARG, 1.0);
+ stack->ary_array[++sp] = ARGTARG;
+ return sp;
+ }
+ else {
+ str_chop(TARG,d);
+ STABSET(TARG);
+ str_numset(ARGTARG, 1.0);
+ stack->ary_array[++sp] = ARGTARG;
+ return sp;
+ }
+ /* NOTREACHED */
+ }
+ do {
+ if (iters++ > maxiters)
+ fatal("Substitution loop");
+ m = spat->spat_regexp->startp[0];
+ /*SUPPRESS 560*/
+ if (i = m - s) {
+ if (s != d)
+ Move(s,d,i,char);
+ d += i;
+ }
+ if (clen) {
+ Copy(c,d,clen,char);
+ 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;
+ TARG->str_cur = d - TARG->str_ptr + i;
+ Move(s,d,i+1,char); /* include the Null */
+ }
+ STABSET(TARG);
+ str_numset(ARGTARG, (double)iters);
+ stack->ary_array[++sp] = ARGTARG;
+ return sp;
+ }
+ str_numset(ARGTARG, 0.0);
+ stack->ary_array[++sp] = ARGTARG;
+ return sp;
+ }
+ }
+ else
+ c = Nullch;
+ if (regexec(spat->spat_regexp, s, strend, orig, 0,
+ TARG->str_pok & SP_STUDIED ? TARG : Nullstr, safebase)) {
+ long_way:
+ dstr = Str_new(25,str_len(TARG));
+ 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 {
+ char *mysubbase = spat->spat_regexp->subbase;
+
+ spat->spat_regexp->subbase = Nullch; /* so recursion works */
+ (void)eval(rspat->spat_repl,G_SCALAR,sp);
+ str_scat(dstr,stack->ary_array[sp+1]);
+ if (spat->spat_regexp->subbase)
+ Safefree(spat->spat_regexp->subbase);
+ spat->spat_regexp->subbase = mysubbase;
+ }
+ if (once)
+ break;
+ } while (regexec(spat->spat_regexp, s, strend, orig, s == m, Nullstr,
+ safebase));
+ str_ncat(dstr,s,strend - s);
+ str_replace(TARG,dstr);
+ STABSET(TARG);
+ str_numset(ARGTARG, (double)iters);
+ stack->ary_array[++sp] = ARGTARG;
+ return sp;
+ }
+ str_numset(ARGTARG, 0.0);
+ stack->ary_array[++sp] = ARGTARG;
+ return sp;
+
+nope:
+ ++spat->spat_short->str_u.str_useful;
+ str_numset(ARGTARG, 0.0);
+ stack->ary_array[++sp] = ARGTARG;
+ return sp;
+}
+#ifdef BUGGY_MSC
+ #pragma intrinsic(memcmp)
+#endif /* BUGGY_MSC */
+
--- /dev/null
+int
+do_syscall(arglast)
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int items = arglast[2] - sp;
+#ifdef atarist
+ unsigned long arg[14]; /* yes, we really need that many ! */
+#else
+ unsigned long arg[8];
+#endif
+ register int i = 0;
+ int retval = -1;
+
+#ifdef HAS_SYSCALL
+#ifdef TAINT
+ for (st += ++sp; items--; st++)
+ tainted |= (*st)->str_tainted;
+ st = stack->ary_array;
+ sp = arglast[1];
+ items = arglast[2] - sp;
+#endif
+ TAINT_PROPER("syscall");
+ /* 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++] = (unsigned long)str_gnum(st[sp]);
+#ifndef lint
+ else
+ arg[i++] = (unsigned 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;
+#ifdef atarist
+ case 9:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
+ arg[7], arg[8]);
+ break;
+ case 10:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
+ arg[7], arg[8], arg[9]);
+ break;
+ case 11:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
+ arg[7], arg[8], arg[9], arg[10]);
+ break;
+ case 12:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
+ arg[7], arg[8], arg[9], arg[10], arg[11]);
+ break;
+ case 13:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
+ arg[7], arg[8], arg[9], arg[10], arg[11], arg[12]);
+ break;
+ case 14:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
+ arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13]);
+ break;
+#endif /* atarist */
+ }
+ return retval;
+#else
+ fatal("syscall() unimplemented");
+#endif
+}
+
--- /dev/null
+long
+do_tell(stab)
+STAB *stab;
+{
+ register STIO *stio;
+
+ if (!stab)
+ goto phooey;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto phooey;
+
+#ifdef ULTRIX_STDIO_BOTCH
+ if (feof(stio->ifp))
+ (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */
+#endif
+
+ return ftell(stio->ifp);
+
+phooey:
+ if (dowarn)
+ warn("tell() on unopened file");
+ errno = EBADF;
+ return -1L;
+}
+
--- /dev/null
+int
+do_time(TARG,tmbuf,gimme,arglast)
+STR *TARG;
+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(TARG,&str_undef);
+ STABSET(TARG);
+ st[++sp] = TARG;
+ return sp;
+ }
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_sec)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_min)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_hour)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mday)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mon)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_year)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_wday)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_yday)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_isdst)));
+ return sp;
+}
+
--- /dev/null
+int
+do_tms(TARG,gimme,arglast)
+STR *TARG;
+int gimme;
+int *arglast;
+{
+#ifdef MSDOS
+ return -1;
+#else
+ STR **st = stack->ary_array;
+ register int sp = arglast[0];
+
+ if (gimme != G_ARRAY) {
+ str_sset(TARG,&str_undef);
+ STABSET(TARG);
+ st[++sp] = TARG;
+ return sp;
+ }
+ (void)times(×buf);
+
+#ifndef HZ
+#define HZ 60
+#endif
+
+#ifndef lint
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(((double)timesbuf.tms_utime)/HZ)));
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(((double)timesbuf.tms_stime)/HZ)));
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(((double)timesbuf.tms_cutime)/HZ)));
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(((double)timesbuf.tms_cstime)/HZ)));
+#else
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(0.0)));
+#endif
+ return sp;
+#endif
+}
+
--- /dev/null
+int
+do_trans(TARG,arg)
+STR *TARG;
+ARG *arg;
+{
+ register short *tbl;
+ register char *s;
+ register int matches = 0;
+ register int ch;
+ register char *send;
+ register char *d;
+ register int squash = arg[2].arg_len & 1;
+
+ tbl = (short*) arg[2].arg_ptr.arg_cval;
+ s = str_get(TARG);
+ send = s + TARG->str_cur;
+ if (!tbl || !s)
+ fatal("panic: do_trans");
+#ifdef DEBUGGING
+ if (debug & 8) {
+ deb("2.TBL\n");
+ }
+#endif
+ if (!arg[2].arg_len) {
+ while (s < send) {
+ if ((ch = tbl[*s & 0377]) >= 0) {
+ matches++;
+ *s = ch;
+ }
+ s++;
+ }
+ }
+ else {
+ d = s;
+ while (s < send) {
+ if ((ch = tbl[*s & 0377]) >= 0) {
+ *d = ch;
+ if (matches++ && squash) {
+ if (d[-1] == *d)
+ matches--;
+ else
+ d++;
+ }
+ else
+ d++;
+ }
+ else if (ch == -1) /* -1 is unmapped character */
+ *d++ = *s; /* -2 is delete character */
+ s++;
+ }
+ matches += send - d; /* account for disappeared chars */
+ *d = '\0';
+ TARG->str_cur = d - TARG->str_ptr;
+ }
+ STABSET(TARG);
+ return matches;
+}
+
--- /dev/null
+int /*SUPPRESS 590*/
+do_truncate(TARG,arg,gimme,arglast)
+STR *TARG;
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ register int sp = arglast[0] + 1;
+ off_t len = (off_t)str_gnum(ary->ary_array[sp+1]);
+ int result = 1;
+ STAB *tmpstab;
+
+#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE)
+#ifdef HAS_TRUNCATE
+ if ((arg[1].arg_type & A_MASK) == A_WORD) {
+ tmpstab = arg[1].arg_ptr.arg_stab;
+ if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
+ ftruncate(fileno(stab_io(tmpstab)->ifp), len) < 0)
+ result = 0;
+ }
+ else if (truncate(str_get(ary->ary_array[sp]), len) < 0)
+ result = 0;
+#else
+ if ((arg[1].arg_type & A_MASK) == A_WORD) {
+ tmpstab = arg[1].arg_ptr.arg_stab;
+ if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
+ chsize(fileno(stab_io(tmpstab)->ifp), len) < 0)
+ result = 0;
+ }
+ else {
+ int tmpfd;
+
+ if ((tmpfd = open(str_get(ary->ary_array[sp]), 0)) < 0)
+ result = 0;
+ else {
+ if (chsize(tmpfd, len) < 0)
+ result = 0;
+ close(tmpfd);
+ }
+ }
+#endif
+
+ if (result)
+ str_sset(TARG,&str_yes);
+ else
+ str_sset(TARG,&str_undef);
+ STABSET(TARG);
+ ary->ary_array[sp] = TARG;
+ return sp;
+#else
+ fatal("truncate not implemented");
+#endif
+}
+
--- /dev/null
+int /*SUPPRESS 590*/
+do_undef(TARG,arg,gimme,arglast)
+STR *TARG;
+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) = anew(stab); /* so "@array" still works */
+ }
+ else if (type == O_HASH || type == O_LHASH) {
+ stab = arg[1].arg_ptr.arg_stab;
+ if (stab == envstab)
+ environ[0] = Nullch;
+ else if (stab == sigstab) {
+ int i;
+
+ for (i = 1; i < NSIG; i++)
+ signal(i, SIG_DFL); /* munch, munch, munch */
+ }
+ (void)hfree(stab_xhash(stab), TRUE);
+ stab_xhash(stab) = Null(HASH*);
+ }
+ else if (type == O_SUBR || type == O_DBSUBR) {
+ stab = arg[1].arg_ptr.arg_stab;
+ if ((arg[1].arg_type & A_MASK) != A_WORD) {
+ STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
+
+ if (tmpstr)
+ stab = stabent(str_get(tmpstr),TRUE);
+ else
+ stab = Nullstab;
+ }
+ if (stab && stab_sub(stab)) {
+ cmd_free(stab_sub(stab)->cmd);
+ stab_sub(stab)->cmd = Nullcmd;
+ 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(TARG,0.0);
+ stack->ary_array[retarg] = TARG;
+ return retarg;
+}
+
--- /dev/null
+int
+do_unpack(TARG,gimme,arglast)
+STR *TARG;
+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;
+ char *strbeg = s;
+ register char *patend = pat + st[sp]->str_cur;
+ int datumtype;
+ register int len;
+ register int bits;
+
+ /* These must not be in registers: */
+ short ashort;
+ int aint;
+ long along;
+#ifdef QUAD
+ quad aquad;
+#endif
+ unsigned short aushort;
+ unsigned int auint;
+ unsigned long aulong;
+#ifdef QUAD
+ unsigned quad auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+ int checksum = 0;
+ unsigned long culong;
+ double cdouble;
+
+ if (gimme != G_ARRAY) { /* arrange to do first one only */
+ /*SUPPRESS 530*/
+ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
+ if (index("aAbBhH", *patend) || *pat == '%') {
+ patend++;
+ while (isDIGIT(*patend) || *patend == '*')
+ patend++;
+ }
+ else
+ patend++;
+ }
+ sp--;
+ while (pat < patend) {
+ reparse:
+ datumtype = *pat++;
+ if (pat >= patend)
+ len = 1;
+ else if (*pat == '*') {
+ len = strend - strbeg; /* long enough */
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = (datumtype != '@');
+ switch(datumtype) {
+ default:
+ break;
+ case '%':
+ if (len == 1 && pat[-1] != '1')
+ len = 16;
+ checksum = len;
+ culong = 0;
+ cdouble = 0;
+ if (pat < patend)
+ goto reparse;
+ break;
+ case '@':
+ if (len > strend - strbeg)
+ fatal("@ outside of string");
+ s = strbeg + len;
+ break;
+ case 'X':
+ if (len > s - strbeg)
+ fatal("X outside of string");
+ s -= len;
+ break;
+ case 'x':
+ if (len > strend - s)
+ fatal("x outside of string");
+ s += len;
+ break;
+ case 'A':
+ case 'a':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum)
+ goto uchar_checksum;
+ TARG = Str_new(35,len);
+ str_nset(TARG,s,len);
+ s += len;
+ if (datumtype == 'A') {
+ aptr = s; /* borrow register */
+ s = TARG->str_ptr + len - 1;
+ while (s >= TARG->str_ptr && (!*s || isSPACE(*s)))
+ s--;
+ *++s = '\0';
+ TARG->str_cur = s - TARG->str_ptr;
+ s = aptr; /* unborrow register */
+ }
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ break;
+ case 'B':
+ case 'b':
+ if (pat[-1] == '*' || len > (strend - s) * 8)
+ len = (strend - s) * 8;
+ TARG = Str_new(35, len + 1);
+ TARG->str_cur = len;
+ TARG->str_pok = 1;
+ aptr = pat; /* borrow register */
+ pat = TARG->str_ptr;
+ if (datumtype == 'b') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7) /*SUPPRESS 595*/
+ bits >>= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + (bits & 1);
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7)
+ bits <<= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + ((bits & 128) != 0);
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ break;
+ case 'H':
+ case 'h':
+ if (pat[-1] == '*' || len > (strend - s) * 2)
+ len = (strend - s) * 2;
+ TARG = Str_new(35, len + 1);
+ TARG->str_cur = len;
+ TARG->str_pok = 1;
+ aptr = pat; /* borrow register */
+ pat = TARG->str_ptr;
+ if (datumtype == 'h') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits >>= 4;
+ else
+ bits = *s++;
+ *pat++ = hexdigit[bits & 15];
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits <<= 4;
+ else
+ bits = *s++;
+ *pat++ = hexdigit[(bits >> 4) & 15];
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ break;
+ case 'c':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ culong += aint;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ TARG = Str_new(36,0);
+ str_numset(TARG,(double)aint);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 'C':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ uchar_checksum:
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ culong += auint;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ TARG = Str_new(37,0);
+ str_numset(TARG,(double)auint);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 's':
+ along = (strend - s) / sizeof(short);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s,&ashort,1,short);
+ s += sizeof(short);
+ culong += ashort;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ Copy(s,&ashort,1,short);
+ s += sizeof(short);
+ TARG = Str_new(38,0);
+ str_numset(TARG,(double)ashort);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 'v':
+ case 'n':
+ case 'S':
+ along = (strend - s) / sizeof(unsigned short);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s,&aushort,1,unsigned short);
+ s += sizeof(unsigned short);
+#ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = ntohs(aushort);
+#endif
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ culong += aushort;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ Copy(s,&aushort,1,unsigned short);
+ s += sizeof(unsigned short);
+ TARG = Str_new(39,0);
+#ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = ntohs(aushort);
+#endif
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ str_numset(TARG,(double)aushort);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 'i':
+ along = (strend - s) / sizeof(int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s,&aint,1,int);
+ s += sizeof(int);
+ if (checksum > 32)
+ cdouble += (double)aint;
+ else
+ culong += aint;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ Copy(s,&aint,1,int);
+ s += sizeof(int);
+ TARG = Str_new(40,0);
+ str_numset(TARG,(double)aint);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 'I':
+ along = (strend - s) / sizeof(unsigned int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s,&auint,1,unsigned int);
+ s += sizeof(unsigned int);
+ if (checksum > 32)
+ cdouble += (double)auint;
+ else
+ culong += auint;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ Copy(s,&auint,1,unsigned int);
+ s += sizeof(unsigned int);
+ TARG = Str_new(41,0);
+ str_numset(TARG,(double)auint);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 'l':
+ along = (strend - s) / sizeof(long);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s,&along,1,long);
+ s += sizeof(long);
+ if (checksum > 32)
+ cdouble += (double)along;
+ else
+ culong += along;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ Copy(s,&along,1,long);
+ s += sizeof(long);
+ TARG = Str_new(42,0);
+ str_numset(TARG,(double)along);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 'V':
+ case 'N':
+ case 'L':
+ along = (strend - s) / sizeof(unsigned long);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s,&aulong,1,unsigned long);
+ s += sizeof(unsigned long);
+#ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = ntohl(aulong);
+#endif
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+#endif
+ if (checksum > 32)
+ cdouble += (double)aulong;
+ else
+ culong += aulong;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ Copy(s,&aulong,1,unsigned long);
+ s += sizeof(unsigned long);
+ TARG = Str_new(43,0);
+#ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = ntohl(aulong);
+#endif
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+#endif
+ str_numset(TARG,(double)aulong);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 'p':
+ along = (strend - s) / sizeof(char*);
+ if (len > along)
+ len = along;
+ while (len-- > 0) {
+ if (sizeof(char*) > strend - s)
+ break;
+ else {
+ Copy(s,&aptr,1,char*);
+ s += sizeof(char*);
+ }
+ TARG = Str_new(44,0);
+ if (aptr)
+ str_set(TARG,aptr);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ break;
+#ifdef QUAD
+ case 'q':
+ while (len-- > 0) {
+ if (s + sizeof(quad) > strend)
+ aquad = 0;
+ else {
+ Copy(s,&aquad,1,quad);
+ s += sizeof(quad);
+ }
+ TARG = Str_new(42,0);
+ str_numset(TARG,(double)aquad);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ break;
+ case 'Q':
+ while (len-- > 0) {
+ if (s + sizeof(unsigned quad) > strend)
+ auquad = 0;
+ else {
+ Copy(s,&auquad,1,unsigned quad);
+ s += sizeof(unsigned quad);
+ }
+ TARG = Str_new(43,0);
+ str_numset(TARG,(double)auquad);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ break;
+#endif
+ /* float and double added gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ along = (strend - s) / sizeof(float);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &afloat,1, float);
+ s += sizeof(float);
+ cdouble += afloat;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ Copy(s, &afloat,1, float);
+ s += sizeof(float);
+ TARG = Str_new(47, 0);
+ str_numset(TARG, (double)afloat);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 'd':
+ case 'D':
+ along = (strend - s) / sizeof(double);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &adouble,1, double);
+ s += sizeof(double);
+ cdouble += adouble;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ Copy(s, &adouble,1, double);
+ s += sizeof(double);
+ TARG = Str_new(48, 0);
+ str_numset(TARG, (double)adouble);
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ }
+ }
+ break;
+ case 'u':
+ along = (strend - s) * 3 / 4;
+ TARG = Str_new(42,along);
+ while (s < strend && *s > ' ' && *s < 'a') {
+ int a,b,c,d;
+ char hunk[4];
+
+ hunk[3] = '\0';
+ len = (*s++ - ' ') & 077;
+ while (len > 0) {
+ if (s < strend && *s >= ' ')
+ a = (*s++ - ' ') & 077;
+ else
+ a = 0;
+ if (s < strend && *s >= ' ')
+ b = (*s++ - ' ') & 077;
+ else
+ b = 0;
+ if (s < strend && *s >= ' ')
+ c = (*s++ - ' ') & 077;
+ else
+ c = 0;
+ if (s < strend && *s >= ' ')
+ d = (*s++ - ' ') & 077;
+ else
+ d = 0;
+ hunk[0] = a << 2 | b >> 4;
+ hunk[1] = b << 4 | c >> 2;
+ hunk[2] = c << 6 | d;
+ str_ncat(TARG,hunk, len > 3 ? 3 : len);
+ len -= 3;
+ }
+ if (*s == '\n')
+ s++;
+ else if (s[1] == '\n') /* possible checksum byte */
+ s += 2;
+ }
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ break;
+ }
+ if (checksum) {
+ TARG = Str_new(42,0);
+ if (index("fFdD", datumtype) ||
+ (checksum > 32 && index("iIlLN", datumtype)) ) {
+ double modf();
+ double trouble;
+
+ adouble = 1.0;
+ while (checksum >= 16) {
+ checksum -= 16;
+ adouble *= 65536.0;
+ }
+ while (checksum >= 4) {
+ checksum -= 4;
+ adouble *= 16.0;
+ }
+ while (checksum--)
+ adouble *= 2.0;
+ along = (1 << checksum) - 1;
+ while (cdouble < 0.0)
+ cdouble += adouble;
+ cdouble = modf(cdouble / adouble, &trouble) * adouble;
+ str_numset(TARG,cdouble);
+ }
+ else {
+ if (checksum < 32) {
+ along = (1 << checksum) - 1;
+ culong &= (unsigned long)along;
+ }
+ str_numset(TARG,(double)culong);
+ }
+ (void)astore(stack, ++sp, str_2mortal(TARG));
+ checksum = 0;
+ }
+ }
+ return sp;
+}
+
--- /dev/null
+void
+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 *TARG;
+ register int i;
+
+ aunshift(ary,items);
+ i = 0;
+ for (st += ++sp; i < items; i++,st++) {
+ TARG = Str_new(27,0);
+ str_sset(TARG,*st);
+ (void)astore(ary,i,TARG);
+ }
+}
+
--- /dev/null
+int
+do_vec(lvalue,astr,arglast)
+int lvalue;
+STR *astr;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ int sp = arglast[0];
+ register STR *TARG = 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(TARG);
+ 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 > TARG->str_cur)
+ retnum = 0;
+ else {
+ if (len > TARG->str_cur) {
+ STR_GROW(TARG,len);
+ (void)memzero(TARG->str_ptr + TARG->str_cur, len - TARG->str_cur);
+ TARG->str_cur = len;
+ }
+ s = (unsigned char*)str_get(TARG);
+ 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 = ((unsigned long) s[offset] << 8) + s[offset+1];
+ else if (size == 32)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) 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 = TARG;
+ st[sp]->str_rare = 'v';
+ lstr->lstr_offset = offset;
+ lstr->lstr_len = size;
+ }
+ }
+
+ str_numset(astr,(double)retnum);
+ st[sp] = astr;
+ return sp;
+}
+
--- /dev/null
+void
+do_vecset(mstr,TARG)
+STR *mstr;
+STR *TARG;
+{
+ struct lstring *lstr = (struct lstring*)TARG;
+ register int offset;
+ register int size;
+ register unsigned char *s = (unsigned char*)mstr->str_ptr;
+ register unsigned long lval = U_L(str_gnum(TARG));
+ int mask;
+
+ mstr->str_rare = 0;
+ TARG->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;
+ }
+ }
+}
+
--- /dev/null
+void
+do_vop(optype,TARG,left,right)
+STR *TARG;
+STR *left;
+STR *right;
+{
+ register char *s;
+ 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 (TARG->str_cur > len)
+ TARG->str_cur = len;
+ else if (TARG->str_cur < len) {
+ STR_GROW(TARG,len);
+ (void)memzero(TARG->str_ptr + TARG->str_cur, len - TARG->str_cur);
+ TARG->str_cur = len;
+ }
+ TARG->str_pok = 1;
+ TARG->str_nok = 0;
+ s = TARG->str_ptr;
+ if (!s) {
+ str_nset(TARG,"",0);
+ s = TARG->str_ptr;
+ }
+ 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 = TARG->str_cur;
+ if (right->str_cur > len)
+ str_ncat(TARG,right->str_ptr+len,right->str_cur - len);
+ else if (left->str_cur > len)
+ str_ncat(TARG,left->str_ptr+len,left->str_cur - len);
+ break;
+ }
+}
+
: if this fails, just run all the .SH files by hand
. ./config.sh
-rm -f x2p/config.sh
+(
+ cd x2p
+ rm -f config.sh
+ case "$d_symlink" in
+ *define*) ln -s ../config.sh . || ln ../config.sh .;;
+ *) ln ../config.sh . || ln -s ../config.sh .
+ esac
+)
+
cp cppstdin x2p
echo " "
+++ /dev/null
-/* $RCSfile: doarg.c,v $$Revision: 4.0.1.7 $$Date: 92/06/11 21:07:11 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: doarg.c,v $
- * Revision 4.0.1.7 92/06/11 21:07:11 lwall
- * patch34: join with null list attempted negative allocation
- * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd "
- *
- * Revision 4.0.1.6 92/06/08 12:34:30 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: pattern modifiers i and o didn't interact right
- * patch20: join() now pre-extends target string to avoid excessive copying
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly
- * patch20: usersub routines didn't reclaim temp values soon enough
- * patch20: ($<,$>) = ... didn't work on some architectures
- * patch20: added Atari ST portability
- *
- * Revision 4.0.1.5 91/11/11 16:31:58 lwall
- * patch19: added little-endian pack/unpack options
- *
- * Revision 4.0.1.4 91/11/05 16:35:06 lwall
- * patch11: /$foo/o optimizer could access deallocated data
- * patch11: minimum match length calculation in regexp is now cumulative
- * patch11: added some support for 64-bit integers
- * patch11: prepared for ctype implementations that don't define isascii()
- * patch11: sprintf() now supports any length of s field
- * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work
- * patch11: defined(&$foo) and undef(&$foo) didn't work
- *
- * Revision 4.0.1.3 91/06/10 01:18:41 lwall
- * patch10: pack(hh,1) dumped core
- *
- * Revision 4.0.1.2 91/06/07 10:42:17 lwall
- * patch4: new copyright notice
- * patch4: // wouldn't use previous pattern if it started with a null character
- * patch4: //o and s///o now optimize themselves fully at runtime
- * patch4: added global modifier for pattern matches
- * patch4: undef @array disabled "@array" interpolation
- * patch4: chop("") was returning "\0" rather than ""
- * patch4: vector logical operations &, | and ^ sometimes returned null string
- * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
- *
- * Revision 4.0.1.1 91/04/11 17:40:14 lwall
- * patch1: fixed undefined environ problem
- * patch1: fixed debugger coredump on subroutines
- *
- * Revision 4.0 91/03/20 01:06:42 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
-#include <signal.h>
-#endif
-
-extern unsigned char fold[];
-
-#ifdef BUGGY_MSC
- #pragma function(memcmp)
-#endif /* BUGGY_MSC */
-
-static void doencodes();
-
-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 = Null(REGEXP*); /* required if regcomp pukes */
- }
- spat->spat_regexp = regcomp(m,m+dstr->str_cur,
- spat->spat_flags & SPAT_FOLD);
- if (spat->spat_flags & SPAT_KEEP) {
- if (!(spat->spat_flags & SPAT_FOLD))
- scanconst(spat, m, dstr->str_cur);
- arg_free(spat->spat_runtime); /* it won't change, so */
- spat->spat_runtime = Nullarg; /* no point compiling again */
- hoistmust(spat);
- if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
- curcmd->c_flags &= ~CF_OPTIMIZE;
- opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
- }
- }
- }
-#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->prelen && 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_GLOBAL);
- 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_regexp->minlen) {
- /* 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) {
- Copy(c, m, clen, char);
- m += clen;
- }
- i = strend - d;
- if (i > 0) {
- Move(d, m, i, char);
- 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;
- str->str_nok = 0;
- return sp;
- }
- /*SUPPRESS 560*/
- 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)
- Copy(c, m, clen, char);
- STABSET(str);
- str_numset(arg->arg_ptr.arg_str, 1.0);
- stack->ary_array[++sp] = arg->arg_ptr.arg_str;
- str->str_nok = 0;
- return sp;
- }
- else if (clen) {
- d -= clen;
- str_chop(str,d);
- Copy(c,d,clen,char);
- STABSET(str);
- str_numset(arg->arg_ptr.arg_str, 1.0);
- stack->ary_array[++sp] = arg->arg_ptr.arg_str;
- str->str_nok = 0;
- 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;
- str->str_nok = 0;
- return sp;
- }
- /* NOTREACHED */
- }
- do {
- if (iters++ > maxiters)
- fatal("Substitution loop");
- m = spat->spat_regexp->startp[0];
- /*SUPPRESS 560*/
- if (i = m - s) {
- if (s != d)
- Move(s,d,i,char);
- d += i;
- }
- if (clen) {
- Copy(c,d,clen,char);
- 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;
- Move(s,d,i+1,char); /* include the Null */
- }
- STABSET(str);
- str_numset(arg->arg_ptr.arg_str, (double)iters);
- stack->ary_array[++sp] = arg->arg_ptr.arg_str;
- str->str_nok = 0;
- 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 {
- char *mysubbase = spat->spat_regexp->subbase;
-
- spat->spat_regexp->subbase = Nullch; /* so recursion works */
- (void)eval(rspat->spat_repl,G_SCALAR,sp);
- str_scat(dstr,stack->ary_array[sp+1]);
- if (spat->spat_regexp->subbase)
- Safefree(spat->spat_regexp->subbase);
- spat->spat_regexp->subbase = mysubbase;
- }
- 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;
- str->str_nok = 0;
- 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;
-}
-#ifdef BUGGY_MSC
- #pragma intrinsic(memcmp)
-#endif /* BUGGY_MSC */
-
-int
-do_trans(str,arg)
-STR *str;
-ARG *arg;
-{
- register short *tbl;
- register char *s;
- register int matches = 0;
- register int ch;
- register char *send;
- register char *d;
- register int squash = arg[2].arg_len & 1;
-
- tbl = (short*) 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
- if (!arg[2].arg_len) {
- while (s < send) {
- if ((ch = tbl[*s & 0377]) >= 0) {
- matches++;
- *s = ch;
- }
- s++;
- }
- }
- else {
- d = s;
- while (s < send) {
- if ((ch = tbl[*s & 0377]) >= 0) {
- *d = ch;
- if (matches++ && squash) {
- if (d[-1] == *d)
- matches--;
- else
- d++;
- }
- else
- d++;
- }
- else if (ch == -1) /* -1 is unmapped character */
- *d++ = *s; /* -2 is delete character */
- s++;
- }
- matches += send - d; /* account for disappeared chars */
- *d = '\0';
- str->str_cur = d - str->str_ptr;
- }
- STABSET(str);
- return matches;
-}
-
-void
-do_join(str,arglast)
-register STR *str;
-int *arglast;
-{
- register STR **st = stack->ary_array;
- int sp = arglast[1];
- register int items = arglast[2] - sp;
- register char *delim = str_get(st[sp]);
- register STRLEN len;
- int delimlen = st[sp]->str_cur;
-
- st += sp + 1;
-
- len = (items > 0 ? (delimlen * (items - 1) ) : 0);
- if (str->str_len < len + items) { /* current length is way too short */
- while (items-- > 0) {
- if (*st)
- len += (*st)->str_cur;
- st++;
- }
- STR_GROW(str, len + 1); /* so try to pre-extend */
-
- items = arglast[2] - sp;
- st -= items;
- }
-
- if (items-- > 0)
- str_sset(str, *st++);
- else
- str_set(str,"");
- len = delimlen;
- if (len) {
- for (; items > 0; items--,st++) {
- str_ncat(str,delim,len);
- str_scat(str,*st);
- }
- }
- else {
- for (; items > 0; items--,st++)
- 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;
- /*SUPPRESS 442*/
- 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;
-#ifdef QUAD
- quad aquad;
- unsigned quad auquad;
-#endif
- char *aptr;
- float afloat;
- double adouble;
-
- items = arglast[2] - sp;
- st += ++sp;
- str_nset(str,"",0);
- while (pat < patend) {
-#define NEXTFROM (items-- > 0 ? *st++ : &str_no)
- datumtype = *pat++;
- if (*pat == '*') {
- len = index("@Xxu",datumtype) ? 0 : items;
- pat++;
- }
- else if (isDIGIT(*pat)) {
- len = *pat++ - '0';
- while (isDIGIT(*pat))
- len = (len * 10) + (*pat++ - '0');
- }
- else
- len = 1;
- switch(datumtype) {
- default:
- break;
- case '%':
- fatal("% may only be used in unpack");
- case '@':
- len -= str->str_cur;
- if (len > 0)
- goto grow;
- len = -len;
- if (len > 0)
- goto shrink;
- break;
- case 'X':
- shrink:
- if (str->str_cur < len)
- fatal("X outside of string");
- str->str_cur -= len;
- str->str_ptr[str->str_cur] = '\0';
- break;
- case 'x':
- grow:
- 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 (pat[-1] == '*')
- len = fromstr->str_cur;
- 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 'B':
- case 'b':
- {
- char *savepat = pat;
- int saveitems;
-
- fromstr = NEXTFROM;
- saveitems = items;
- aptr = str_get(fromstr);
- if (pat[-1] == '*')
- len = fromstr->str_cur;
- pat = aptr;
- aint = str->str_cur;
- str->str_cur += (len+7)/8;
- STR_GROW(str, str->str_cur + 1);
- aptr = str->str_ptr + aint;
- if (len > fromstr->str_cur)
- len = fromstr->str_cur;
- aint = len;
- items = 0;
- if (datumtype == 'B') {
- for (len = 0; len++ < aint;) {
- items |= *pat++ & 1;
- if (len & 7)
- items <<= 1;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- else {
- for (len = 0; len++ < aint;) {
- if (*pat++ & 1)
- items |= 128;
- if (len & 7)
- items >>= 1;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- if (aint & 7) {
- if (datumtype == 'B')
- items <<= 7 - (aint & 7);
- else
- items >>= 7 - (aint & 7);
- *aptr++ = items & 0xff;
- }
- pat = str->str_ptr + str->str_cur;
- while (aptr <= pat)
- *aptr++ = '\0';
-
- pat = savepat;
- items = saveitems;
- }
- break;
- case 'H':
- case 'h':
- {
- char *savepat = pat;
- int saveitems;
-
- fromstr = NEXTFROM;
- saveitems = items;
- aptr = str_get(fromstr);
- if (pat[-1] == '*')
- len = fromstr->str_cur;
- pat = aptr;
- aint = str->str_cur;
- str->str_cur += (len+1)/2;
- STR_GROW(str, str->str_cur + 1);
- aptr = str->str_ptr + aint;
- if (len > fromstr->str_cur)
- len = fromstr->str_cur;
- aint = len;
- items = 0;
- if (datumtype == 'H') {
- for (len = 0; len++ < aint;) {
- if (isALPHA(*pat))
- items |= ((*pat++ & 15) + 9) & 15;
- else
- items |= *pat++ & 15;
- if (len & 1)
- items <<= 4;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- else {
- for (len = 0; len++ < aint;) {
- if (isALPHA(*pat))
- items |= (((*pat++ & 15) + 9) & 15) << 4;
- else
- items |= (*pat++ & 15) << 4;
- if (len & 1)
- items >>= 4;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- if (aint & 1)
- *aptr++ = items & 0xff;
- pat = str->str_ptr + str->str_cur;
- while (aptr <= pat)
- *aptr++ = '\0';
-
- pat = savepat;
- items = saveitems;
- }
- break;
- case 'C':
- case 'c':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aint = (int)str_gnum(fromstr);
- achar = aint;
- str_ncat(str,&achar,sizeof(char));
- }
- break;
- /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
- case 'f':
- case 'F':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- afloat = (float)str_gnum(fromstr);
- str_ncat(str, (char *)&afloat, sizeof (float));
- }
- break;
- case 'd':
- case 'D':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- adouble = (double)str_gnum(fromstr);
- str_ncat(str, (char *)&adouble, sizeof (double));
- }
- break;
- case 'n':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (short)str_gnum(fromstr);
-#ifdef HAS_HTONS
- ashort = htons(ashort);
-#endif
- str_ncat(str,(char*)&ashort,sizeof(short));
- }
- break;
- case 'v':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (short)str_gnum(fromstr);
-#ifdef HAS_HTOVS
- ashort = htovs(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 = U_I(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;
- aulong = U_L(str_gnum(fromstr));
-#ifdef HAS_HTONL
- aulong = htonl(aulong);
-#endif
- str_ncat(str,(char*)&aulong,sizeof(unsigned long));
- }
- break;
- case 'V':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = U_L(str_gnum(fromstr));
-#ifdef HAS_HTOVL
- aulong = htovl(aulong);
-#endif
- str_ncat(str,(char*)&aulong,sizeof(unsigned long));
- }
- break;
- case 'L':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = U_L(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;
-#ifdef QUAD
- case 'Q':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auquad = (unsigned quad)str_gnum(fromstr);
- str_ncat(str,(char*)&auquad,sizeof(unsigned quad));
- }
- break;
- case 'q':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aquad = (quad)str_gnum(fromstr);
- str_ncat(str,(char*)&aquad,sizeof(quad));
- }
- break;
-#endif /* QUAD */
- case 'p':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aptr = str_get(fromstr);
- str_ncat(str,(char*)&aptr,sizeof(char*));
- }
- break;
- case 'u':
- fromstr = NEXTFROM;
- aptr = str_get(fromstr);
- aint = fromstr->str_cur;
- STR_GROW(str,aint * 4 / 3);
- if (len <= 1)
- len = 45;
- else
- len = len / 3 * 3;
- while (aint > 0) {
- int todo;
-
- if (aint > len)
- todo = len;
- else
- todo = aint;
- doencodes(str, aptr, todo);
- aint -= todo;
- aptr += todo;
- }
- break;
- }
- }
- STABSET(str);
-}
-#undef NEXTFROM
-
-static void
-doencodes(str, s, len)
-register STR *str;
-register char *s;
-register int len;
-{
- char hunk[5];
-
- *hunk = len + ' ';
- str_ncat(str, hunk, 1);
- hunk[4] = '\0';
- while (len > 0) {
- hunk[0] = ' ' + (077 & (*s >> 2));
- hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
- hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
- hunk[3] = ' ' + (077 & (s[2] & 077));
- str_ncat(str, hunk, 4);
- s += 3;
- len -= 3;
- }
- for (s = str->str_ptr; *s; s++) {
- if (*s == ' ')
- *s = '`';
- }
- str_ncat(str, "\n", 1);
-}
-
-void
-do_sprintf(str,len,sarg)
-register STR *str;
-register int len;
-register STR **sarg;
-{
- register char *s;
- register char *t;
- register char *f;
- bool dolong;
-#ifdef QUAD
- bool doquad;
-#endif /* QUAD */
- char ch;
- static STR *sargnull = &str_no;
- register char *send;
- register STR *arg;
- char *xs;
- int xlen;
- int pre;
- int post;
- double value;
-
- str_set(str,"");
- len--; /* don't count pattern string */
- t = s = str_get(*sarg);
- send = s + (*sarg)->str_cur;
- sarg++;
- for ( ; ; len--) {
-
- /*SUPPRESS 560*/
- if (len <= 0 || !(arg = *sarg++))
- arg = sargnull;
-
- /*SUPPRESS 530*/
- for ( ; t < send && *t != '%'; t++) ;
- if (t >= send)
- break; /* end of format string, ignore extra args */
- f = t;
- *buf = '\0';
- xs = buf;
-#ifdef QUAD
- doquad =
-#endif /* QUAD */
- dolong = FALSE;
- pre = post = 0;
- for (t++; t < send; t++) {
- switch (*t) {
- default:
- ch = *(++t);
- *t = '\0';
- (void)sprintf(xs,f);
- len++, sarg--;
- xlen = strlen(xs);
- 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 '+': case ' ':
- continue;
- case 'l':
-#ifdef QUAD
- if (dolong) {
- dolong = FALSE;
- doquad = TRUE;
- } else
-#endif
- dolong = TRUE;
- continue;
- case 'c':
- ch = *(++t);
- *t = '\0';
- xlen = (int)str_gnum(arg);
- if (strEQ(f,"%c")) { /* some printfs fail on null chars */
- *xs = xlen;
- xs[1] = '\0';
- xlen = 1;
- }
- else {
- (void)sprintf(xs,f,xlen);
- xlen = strlen(xs);
- }
- break;
- case 'D':
- dolong = TRUE;
- /* FALL THROUGH */
- case 'd':
- ch = *(++t);
- *t = '\0';
-#ifdef QUAD
- if (doquad)
- (void)sprintf(buf,s,(quad)str_gnum(arg));
- else
-#endif
- if (dolong)
- (void)sprintf(xs,f,(long)str_gnum(arg));
- else
- (void)sprintf(xs,f,(int)str_gnum(arg));
- xlen = strlen(xs);
- break;
- case 'X': case 'O':
- dolong = TRUE;
- /* FALL THROUGH */
- case 'x': case 'o': case 'u':
- ch = *(++t);
- *t = '\0';
- value = str_gnum(arg);
-#ifdef QUAD
- if (doquad)
- (void)sprintf(buf,s,(unsigned quad)value);
- else
-#endif
- if (dolong)
- (void)sprintf(xs,f,U_L(value));
- else
- (void)sprintf(xs,f,U_I(value));
- xlen = strlen(xs);
- break;
- case 'E': case 'e': case 'f': case 'G': case 'g':
- ch = *(++t);
- *t = '\0';
- (void)sprintf(xs,f,str_gnum(arg));
- xlen = strlen(xs);
- break;
- case 's':
- ch = *(++t);
- *t = '\0';
- xs = str_get(arg);
- xlen = arg->str_cur;
- if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xs[3] == '\0'
- && xlen == sizeof(STBP)) {
- STR *tmpstr = Str_new(24,0);
-
- stab_efullname(tmpstr, ((STAB*)arg)); /* a stab value! */
- sprintf(tokenbuf,"*%s",tmpstr->str_ptr);
- /* reformat to non-binary */
- xs = tokenbuf;
- xlen = strlen(tokenbuf);
- str_free(tmpstr);
- }
- if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
- break; /* so handle simple cases */
- }
- else if (f[1] == '-') {
- char *mp = index(f, '.');
- int min = atoi(f+2);
-
- if (mp) {
- int max = atoi(mp+1);
-
- if (xlen > max)
- xlen = max;
- }
- if (xlen < min)
- post = min - xlen;
- break;
- }
- else if (isDIGIT(f[1])) {
- char *mp = index(f, '.');
- int min = atoi(f+1);
-
- if (mp) {
- int max = atoi(mp+1);
-
- if (xlen > max)
- xlen = max;
- }
- if (xlen < min)
- pre = min - xlen;
- break;
- }
- strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
- *t = ch;
- (void)sprintf(buf,tokenbuf+64,xs);
- xs = buf;
- xlen = strlen(xs);
- break;
- }
- /* end of switch, copy results */
- *t = ch;
- STR_GROW(str, str->str_cur + (f - s) + xlen + 1 + pre + post);
- str_ncat(str, s, f - s);
- if (pre) {
- repeatcpy(str->str_ptr + str->str_cur, " ", 1, pre);
- str->str_cur += pre;
- }
- str_ncat(str, xs, xlen);
- if (post) {
- repeatcpy(str->str_ptr + str->str_cur, " ", 1, post);
- str->str_cur += post;
- }
- s = t;
- break; /* break from for loop */
- }
- }
- str_ncat(str, s, t - s);
- 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;
-}
-
-void
-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;
- SPAT * VOLATILE oldspat = curspat;
- STR *str;
- STAB *stab;
- int oldsave = savestack->ary_fill;
- int oldtmps_base = tmps_base;
- int hasargs = ((arg[2].arg_type & A_MASK) != A_NULL);
- register CSV *csv;
-
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else {
- STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
-
- if (tmpstr)
- stab = stabent(str_get(tmpstr),TRUE);
- else
- stab = Nullstab;
- }
- if (!stab)
- fatal("Undefined subroutine called");
- if (!(sub = stab_sub(stab))) {
- STR *tmpstr = arg[0].arg_ptr.arg_str;
-
- stab_efullname(tmpstr, stab);
- fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr);
- }
- if (arg->arg_type == O_DBSUBR && !sub->usersub) {
- str = stab_val(DBsub);
- saveitem(str);
- stab_efullname(str,stab);
- sub = stab_sub(DBsub);
- if (!sub)
- fatal("No DBsub routine");
- }
- str = Str_new(15, sizeof(CSV));
- str->str_state = SS_SCSV;
- (void)apush(savestack,str);
- csv = (CSV*)str->str_ptr;
- csv->sub = sub;
- csv->stab = stab;
- csv->curcsv = curcsv;
- csv->curcmd = curcmd;
- csv->depth = sub->depth;
- csv->wantarray = gimme;
- csv->hasargs = hasargs;
- curcsv = csv;
- tmps_base = tmps_max;
- if (sub->usersub) {
- csv->hasargs = 0;
- csv->savearray = Null(ARRAY*);;
- csv->argarray = Null(ARRAY*);
- st[sp] = arg->arg_ptr.arg_str;
- if (!hasargs)
- items = 0;
- sp = (*sub->usersub)(sub->userindex,sp,items);
- }
- else {
- if (hasargs) {
- csv->savearray = stab_xarray(defstab);
- csv->argarray = afake(defstab, items, &st[sp+1]);
- stab_xarray(defstab) = csv->argarray;
- }
- sub->depth++;
- if (sub->depth >= 2) { /* save temporaries on recursion? */
- if (sub->depth == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",stab_ename(stab));
- savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
- }
- sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */
- }
-
- st = stack->ary_array;
- tmps_base = oldtmps_base;
- for (items = arglast[0] + 1; items <= sp; items++)
- st[items] = str_mortal(st[items]);
- /* in case restore wipes old str */
- restorelist(oldsave);
- curspat = oldspat;
- 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) != 0;
- 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++) {
- /*SUPPRESS 560*/
- if (str = *relem)
- *relem = str_mortal(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;
- int magic = 0;
- STAB *tmpstab = str->str_u.str_stab;
-
- if (makelocal)
- hash = savehash(str->str_u.str_stab);
- else {
- hash = stab_hash(str->str_u.str_stab);
- if (tmpstab == envstab) {
- magic = 'E';
- environ[0] = Nullch;
- }
- else if (tmpstab == sigstab) {
- magic = 'S';
-#ifndef NSIG
-#define NSIG 32
-#endif
- for (i = 1; i < NSIG; i++)
- signal(i, SIG_DFL); /* crunch, crunch, crunch */
- }
-#ifdef SOME_DBM
- else if (hash->tbl_dbm)
- magic = 'D';
-#endif
- hclear(hash, magic == 'D'); /* wipe any dbm file too */
-
- }
- 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);
- if (magic) {
- str_magic(tmpstr, tmpstab, magic, tmps, str->str_cur);
- stabset(tmpstr->str_magic, tmpstr);
- }
- }
- }
- else
- fatal("panic: do_assign");
- }
- else {
- if (makelocal)
- saveitem(str);
- if (relem <= lastrelem) {
- str_sset(str, *relem);
- *(relem++) = str;
- }
- else {
- str_sset(str, &str_undef);
- 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 & ~DM_DELAY) {
- if (delaymagic & DM_UID) {
-#ifdef HAS_SETREUID
- (void)setreuid(uid,euid);
-#else /* not HAS_SETREUID */
-#ifdef HAS_SETRUID
- if ((delaymagic & DM_UID) == DM_RUID) {
- (void)setruid(uid);
- delaymagic =~ DM_RUID;
- }
-#endif /* HAS_SETRUID */
-#ifdef HAS_SETEUID
- if ((delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(uid);
- delaymagic =~ DM_EUID;
- }
-#endif /* HAS_SETEUID */
- if (delaymagic & DM_UID) {
- if (uid != euid)
- fatal("No setreuid available");
- (void)setuid(uid);
- }
-#endif /* not HAS_SETREUID */
- uid = (int)getuid();
- euid = (int)geteuid();
- }
- if (delaymagic & DM_GID) {
-#ifdef HAS_SETREGID
- (void)setregid(gid,egid);
-#else /* not HAS_SETREGID */
-#ifdef HAS_SETRGID
- if ((delaymagic & DM_GID) == DM_RGID) {
- (void)setrgid(gid);
- delaymagic =~ DM_RGID;
- }
-#endif /* HAS_SETRGID */
-#ifdef HAS_SETEGID
- if ((delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(gid);
- delaymagic =~ DM_EGID;
- }
-#endif /* HAS_SETEGID */
- if (delaymagic & DM_GID) {
- if (gid != egid)
- fatal("No setregid available");
- (void)setgid(gid);
- }
-#endif /* not HAS_SETREGID */
- gid = (int)getgid();
- egid = (int)getegid();
- }
- }
- 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 /*SUPPRESS 590*/
-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 /*SUPPRESS 590*/
-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;
- ARRAY *ary;
- HASH *hash;
-
- 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_SUBR || type == O_DBSUBR) {
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0;
- else {
- STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
-
- retval = tmpstr && stab_sub(stabent(str_get(tmpstr),TRUE)) != 0;
- }
- }
- else if (type == O_ARRAY || type == O_LARRAY ||
- type == O_ASLICE || type == O_LASLICE )
- retval = ((ary = stab_xarray(arg[1].arg_ptr.arg_stab)) != 0
- && ary->ary_max >= 0 );
- else if (type == O_HASH || type == O_LHASH ||
- type == O_HSLICE || type == O_LHSLICE )
- retval = ((hash = stab_xhash(arg[1].arg_ptr.arg_stab)) != 0
- && hash->tbl_array);
- else
- retval = FALSE;
- str_numset(str,(double)retval);
- stack->ary_array[retarg] = str;
- return retarg;
-}
-
-int /*SUPPRESS 590*/
-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) = anew(stab); /* so "@array" still works */
- }
- else if (type == O_HASH || type == O_LHASH) {
- stab = arg[1].arg_ptr.arg_stab;
- if (stab == envstab)
- environ[0] = Nullch;
- else if (stab == sigstab) {
- int i;
-
- for (i = 1; i < NSIG; i++)
- signal(i, SIG_DFL); /* munch, munch, munch */
- }
- (void)hfree(stab_xhash(stab), TRUE);
- stab_xhash(stab) = Null(HASH*);
- }
- else if (type == O_SUBR || type == O_DBSUBR) {
- stab = arg[1].arg_ptr.arg_stab;
- if ((arg[1].arg_type & A_MASK) != A_WORD) {
- STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
-
- if (tmpstr)
- stab = stabent(str_get(tmpstr),TRUE);
- else
- stab = Nullstab;
- }
- if (stab && stab_sub(stab)) {
- cmd_free(stab_sub(stab)->cmd);
- stab_sub(stab)->cmd = Nullcmd;
- 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)memzero(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 = ((unsigned long) s[offset] << 8) + s[offset+1];
- else if (size == 32)
- retnum = ((unsigned long) s[offset] << 24) +
- ((unsigned long) 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 = U_L(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;
- }
- }
-}
-
-void
-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);
- /*SUPPRESS 560*/
- while (entry = hiternext(hash))
- do_chop(astr,hiterval(hash,entry));
- return;
- }
- tmps = str_get(str);
- if (tmps && str->str_cur) {
- tmps += str->str_cur - 1;
- str_nset(astr,tmps,1); /* remember last char */
- *tmps = '\0'; /* wipe it out */
- str->str_cur = tmps - str->str_ptr;
- str->str_nok = 0;
- STABSET(str);
- }
- else
- str_nset(astr,"",0);
-}
-
-void
-do_vop(optype,str,left,right)
-STR *str;
-STR *left;
-STR *right;
-{
- register char *s;
- 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)memzero(str->str_ptr + str->str_cur, len - str->str_cur);
- str->str_cur = len;
- }
- str->str_pok = 1;
- str->str_nok = 0;
- s = str->str_ptr;
- if (!s) {
- str_nset(str,"",0);
- s = str->str_ptr;
- }
- 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;
-#ifdef atarist
- unsigned long arg[14]; /* yes, we really need that many ! */
-#else
- unsigned long arg[8];
-#endif
- register int i = 0;
- int retval = -1;
-
-#ifdef HAS_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++] = (unsigned long)str_gnum(st[sp]);
-#ifndef lint
- else
- arg[i++] = (unsigned 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;
-#ifdef atarist
- case 9:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8]);
- break;
- case 10:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9]);
- break;
- case 11:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9], arg[10]);
- break;
- case 12:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9], arg[10], arg[11]);
- break;
- case 13:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9], arg[10], arg[11], arg[12]);
- break;
- case 14:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13]);
- break;
-#endif /* atarist */
- }
- return retval;
-#else
- fatal("syscall() unimplemented");
-#endif
-}
-
-
+++ /dev/null
-/* $RCSfile: doarg.c,v $$Revision: 4.0.1.7 $$Date: 92/06/11 21:07:11 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: doarg.c,v $
- * Revision 4.0.1.7 92/06/11 21:07:11 lwall
- * patch34: join with null list attempted negative allocation
- * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd "
- *
- * Revision 4.0.1.6 92/06/08 12:34:30 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: pattern modifiers i and o didn't interact right
- * patch20: join() now pre-extends target string to avoid excessive copying
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly
- * patch20: usersub routines didn't reclaim temp values soon enough
- * patch20: ($<,$>) = ... didn't work on some architectures
- * patch20: added Atari ST portability
- *
- * Revision 4.0.1.5 91/11/11 16:31:58 lwall
- * patch19: added little-endian pack/unpack options
- *
- * Revision 4.0.1.4 91/11/05 16:35:06 lwall
- * patch11: /$foo/o optimizer could access deallocated data
- * patch11: minimum match length calculation in regexp is now cumulative
- * patch11: added some support for 64-bit integers
- * patch11: prepared for ctype implementations that don't define isascii()
- * patch11: sprintf() now supports any length of s field
- * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work
- * patch11: defined(&$foo) and undef(&$foo) didn't work
- *
- * Revision 4.0.1.3 91/06/10 01:18:41 lwall
- * patch10: pack(hh,1) dumped core
- *
- * Revision 4.0.1.2 91/06/07 10:42:17 lwall
- * patch4: new copyright notice
- * patch4: // wouldn't use previous pattern if it started with a null character
- * patch4: //o and s///o now optimize themselves fully at runtime
- * patch4: added global modifier for pattern matches
- * patch4: undef @array disabled "@array" interpolation
- * patch4: chop("") was returning "\0" rather than ""
- * patch4: vector logical operations &, | and ^ sometimes returned null string
- * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
- *
- * Revision 4.0.1.1 91/04/11 17:40:14 lwall
- * patch1: fixed undefined environ problem
- * patch1: fixed debugger coredump on subroutines
- *
- * Revision 4.0 91/03/20 01:06:42 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
-#include <signal.h>
-#endif
-
-extern unsigned char fold[];
-
-#ifdef BUGGY_MSC
- #pragma function(memcmp)
-#endif /* BUGGY_MSC */
-
-static void doencodes();
-
-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 = Null(REGEXP*); /* required if regcomp pukes */
- }
- spat->spat_regexp = regcomp(m,m+dstr->str_cur,
- spat->spat_flags & SPAT_FOLD);
- if (spat->spat_flags & SPAT_KEEP) {
- if (!(spat->spat_flags & SPAT_FOLD))
- scanconst(spat, m, dstr->str_cur);
- arg_free(spat->spat_runtime); /* it won't change, so */
- spat->spat_runtime = Nullarg; /* no point compiling again */
- hoistmust(spat);
- if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
- curcmd->c_flags &= ~CF_OPTIMIZE;
- opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
- }
- }
- }
-#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->prelen && 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_GLOBAL);
- 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_regexp->minlen) {
- /* 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) {
- Copy(c, m, clen, char);
- m += clen;
- }
- i = strend - d;
- if (i > 0) {
- Move(d, m, i, char);
- 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;
- }
- /*SUPPRESS 560*/
- 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)
- Copy(c, m, clen, char);
- 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);
- Copy(c,d,clen,char);
- 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];
- /*SUPPRESS 560*/
- if (i = m - s) {
- if (s != d)
- Move(s,d,i,char);
- d += i;
- }
- if (clen) {
- Copy(c,d,clen,char);
- 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;
- Move(s,d,i+1,char); /* 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 {
- char *mysubbase = spat->spat_regexp->subbase;
-
- spat->spat_regexp->subbase = Nullch; /* so recursion works */
- (void)eval(rspat->spat_repl,G_SCALAR,sp);
- str_scat(dstr,stack->ary_array[sp+1]);
- if (spat->spat_regexp->subbase)
- Safefree(spat->spat_regexp->subbase);
- spat->spat_regexp->subbase = mysubbase;
- }
- 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;
-}
-#ifdef BUGGY_MSC
- #pragma intrinsic(memcmp)
-#endif /* BUGGY_MSC */
-
-int
-do_trans(str,arg)
-STR *str;
-ARG *arg;
-{
- register short *tbl;
- register char *s;
- register int matches = 0;
- register int ch;
- register char *send;
- register char *d;
- register int squash = arg[2].arg_len & 1;
-
- tbl = (short*) 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
- if (!arg[2].arg_len) {
- while (s < send) {
- if ((ch = tbl[*s & 0377]) >= 0) {
- matches++;
- *s = ch;
- }
- s++;
- }
- }
- else {
- d = s;
- while (s < send) {
- if ((ch = tbl[*s & 0377]) >= 0) {
- *d = ch;
- if (matches++ && squash) {
- if (d[-1] == *d)
- matches--;
- else
- d++;
- }
- else
- d++;
- }
- else if (ch == -1) /* -1 is unmapped character */
- *d++ = *s; /* -2 is delete character */
- s++;
- }
- matches += send - d; /* account for disappeared chars */
- *d = '\0';
- str->str_cur = d - str->str_ptr;
- }
- STABSET(str);
- return matches;
-}
-
-void
-do_join(str,arglast)
-register STR *str;
-int *arglast;
-{
- register STR **st = stack->ary_array;
- int sp = arglast[1];
- register int items = arglast[2] - sp;
- register char *delim = str_get(st[sp]);
- register STRLEN len;
- int delimlen = st[sp]->str_cur;
-
- st += sp + 1;
-
- len = (items > 0 ? (delimlen * (items - 1) ) : 0);
- if (str->str_len < len + items) { /* current length is way too short */
- while (items-- > 0) {
- if (*st)
- len += (*st)->str_cur;
- st++;
- }
- STR_GROW(str, len + 1); /* so try to pre-extend */
-
- items = arglast[2] - sp;
- st -= items;
- }
-
- if (items-- > 0)
- str_sset(str, *st++);
- else
- str_set(str,"");
- len = delimlen;
- if (len) {
- for (; items > 0; items--,st++) {
- str_ncat(str,delim,len);
- str_scat(str,*st);
- }
- }
- else {
- for (; items > 0; items--,st++)
- 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;
- /*SUPPRESS 442*/
- 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;
-#ifdef QUAD
- quad aquad;
- unsigned quad auquad;
-#endif
- char *aptr;
- float afloat;
- double adouble;
-
- items = arglast[2] - sp;
- st += ++sp;
- str_nset(str,"",0);
- while (pat < patend) {
-#define NEXTFROM (items-- > 0 ? *st++ : &str_no)
- datumtype = *pat++;
- if (*pat == '*') {
- len = index("@Xxu",datumtype) ? 0 : items;
- pat++;
- }
- else if (isDIGIT(*pat)) {
- len = *pat++ - '0';
- while (isDIGIT(*pat))
- len = (len * 10) + (*pat++ - '0');
- }
- else
- len = 1;
- switch(datumtype) {
- default:
- break;
- case '%':
- fatal("% may only be used in unpack");
- case '@':
- len -= str->str_cur;
- if (len > 0)
- goto grow;
- len = -len;
- if (len > 0)
- goto shrink;
- break;
- case 'X':
- shrink:
- if (str->str_cur < len)
- fatal("X outside of string");
- str->str_cur -= len;
- str->str_ptr[str->str_cur] = '\0';
- break;
- case 'x':
- grow:
- 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 (pat[-1] == '*')
- len = fromstr->str_cur;
- 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 'B':
- case 'b':
- {
- char *savepat = pat;
- int saveitems;
-
- fromstr = NEXTFROM;
- saveitems = items;
- aptr = str_get(fromstr);
- if (pat[-1] == '*')
- len = fromstr->str_cur;
- pat = aptr;
- aint = str->str_cur;
- str->str_cur += (len+7)/8;
- STR_GROW(str, str->str_cur + 1);
- aptr = str->str_ptr + aint;
- if (len > fromstr->str_cur)
- len = fromstr->str_cur;
- aint = len;
- items = 0;
- if (datumtype == 'B') {
- for (len = 0; len++ < aint;) {
- items |= *pat++ & 1;
- if (len & 7)
- items <<= 1;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- else {
- for (len = 0; len++ < aint;) {
- if (*pat++ & 1)
- items |= 128;
- if (len & 7)
- items >>= 1;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- if (aint & 7) {
- if (datumtype == 'B')
- items <<= 7 - (aint & 7);
- else
- items >>= 7 - (aint & 7);
- *aptr++ = items & 0xff;
- }
- pat = str->str_ptr + str->str_cur;
- while (aptr <= pat)
- *aptr++ = '\0';
-
- pat = savepat;
- items = saveitems;
- }
- break;
- case 'H':
- case 'h':
- {
- char *savepat = pat;
- int saveitems;
-
- fromstr = NEXTFROM;
- saveitems = items;
- aptr = str_get(fromstr);
- if (pat[-1] == '*')
- len = fromstr->str_cur;
- pat = aptr;
- aint = str->str_cur;
- str->str_cur += (len+1)/2;
- STR_GROW(str, str->str_cur + 1);
- aptr = str->str_ptr + aint;
- if (len > fromstr->str_cur)
- len = fromstr->str_cur;
- aint = len;
- items = 0;
- if (datumtype == 'H') {
- for (len = 0; len++ < aint;) {
- if (isALPHA(*pat))
- items |= ((*pat++ & 15) + 9) & 15;
- else
- items |= *pat++ & 15;
- if (len & 1)
- items <<= 4;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- else {
- for (len = 0; len++ < aint;) {
- if (isALPHA(*pat))
- items |= (((*pat++ & 15) + 9) & 15) << 4;
- else
- items |= (*pat++ & 15) << 4;
- if (len & 1)
- items >>= 4;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- if (aint & 1)
- *aptr++ = items & 0xff;
- pat = str->str_ptr + str->str_cur;
- while (aptr <= pat)
- *aptr++ = '\0';
-
- pat = savepat;
- items = saveitems;
- }
- break;
- case 'C':
- case 'c':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aint = (int)str_gnum(fromstr);
- achar = aint;
- str_ncat(str,&achar,sizeof(char));
- }
- break;
- /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
- case 'f':
- case 'F':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- afloat = (float)str_gnum(fromstr);
- str_ncat(str, (char *)&afloat, sizeof (float));
- }
- break;
- case 'd':
- case 'D':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- adouble = (double)str_gnum(fromstr);
- str_ncat(str, (char *)&adouble, sizeof (double));
- }
- break;
- case 'n':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (short)str_gnum(fromstr);
-#ifdef HAS_HTONS
- ashort = htons(ashort);
-#endif
- str_ncat(str,(char*)&ashort,sizeof(short));
- }
- break;
- case 'v':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (short)str_gnum(fromstr);
-#ifdef HAS_HTOVS
- ashort = htovs(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 = U_I(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;
- aulong = U_L(str_gnum(fromstr));
-#ifdef HAS_HTONL
- aulong = htonl(aulong);
-#endif
- str_ncat(str,(char*)&aulong,sizeof(unsigned long));
- }
- break;
- case 'V':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = U_L(str_gnum(fromstr));
-#ifdef HAS_HTOVL
- aulong = htovl(aulong);
-#endif
- str_ncat(str,(char*)&aulong,sizeof(unsigned long));
- }
- break;
- case 'L':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = U_L(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;
-#ifdef QUAD
- case 'Q':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auquad = (unsigned quad)str_gnum(fromstr);
- str_ncat(str,(char*)&auquad,sizeof(unsigned quad));
- }
- break;
- case 'q':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aquad = (quad)str_gnum(fromstr);
- str_ncat(str,(char*)&aquad,sizeof(quad));
- }
- break;
-#endif /* QUAD */
- case 'p':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aptr = str_get(fromstr);
- str_ncat(str,(char*)&aptr,sizeof(char*));
- }
- break;
- case 'u':
- fromstr = NEXTFROM;
- aptr = str_get(fromstr);
- aint = fromstr->str_cur;
- STR_GROW(str,aint * 4 / 3);
- if (len <= 1)
- len = 45;
- else
- len = len / 3 * 3;
- while (aint > 0) {
- int todo;
-
- if (aint > len)
- todo = len;
- else
- todo = aint;
- doencodes(str, aptr, todo);
- aint -= todo;
- aptr += todo;
- }
- break;
- }
- }
- STABSET(str);
-}
-#undef NEXTFROM
-
-static void
-doencodes(str, s, len)
-register STR *str;
-register char *s;
-register int len;
-{
- char hunk[5];
-
- *hunk = len + ' ';
- str_ncat(str, hunk, 1);
- hunk[4] = '\0';
- while (len > 0) {
- hunk[0] = ' ' + (077 & (*s >> 2));
- hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
- hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
- hunk[3] = ' ' + (077 & (s[2] & 077));
- str_ncat(str, hunk, 4);
- s += 3;
- len -= 3;
- }
- for (s = str->str_ptr; *s; s++) {
- if (*s == ' ')
- *s = '`';
- }
- str_ncat(str, "\n", 1);
-}
-
-void
-do_sprintf(str,len,sarg)
-register STR *str;
-register int len;
-register STR **sarg;
-{
- register char *s;
- register char *t;
- register char *f;
- bool dolong;
-#ifdef QUAD
- bool doquad;
-#endif /* QUAD */
- char ch;
- static STR *sargnull = &str_no;
- register char *send;
- register STR *arg;
- char *xs;
- int xlen;
- int pre;
- int post;
- double value;
-
- str_set(str,"");
- len--; /* don't count pattern string */
- t = s = str_get(*sarg);
- send = s + (*sarg)->str_cur;
- sarg++;
- for ( ; ; len--) {
-
- /*SUPPRESS 560*/
- if (len <= 0 || !(arg = *sarg++))
- arg = sargnull;
-
- /*SUPPRESS 530*/
- for ( ; t < send && *t != '%'; t++) ;
- if (t >= send)
- break; /* end of format string, ignore extra args */
- f = t;
- *buf = '\0';
- xs = buf;
-#ifdef QUAD
- doquad =
-#endif /* QUAD */
- dolong = FALSE;
- pre = post = 0;
- for (t++; t < send; t++) {
- switch (*t) {
- default:
- ch = *(++t);
- *t = '\0';
- (void)sprintf(xs,f);
- len++, sarg--;
- xlen = strlen(xs);
- 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 '+': case ' ':
- continue;
- case 'l':
-#ifdef QUAD
- if (dolong) {
- dolong = FALSE;
- doquad = TRUE;
- } else
-#endif
- dolong = TRUE;
- continue;
- case 'c':
- ch = *(++t);
- *t = '\0';
- xlen = (int)str_gnum(arg);
- if (strEQ(f,"%c")) { /* some printfs fail on null chars */
- *xs = xlen;
- xs[1] = '\0';
- xlen = 1;
- }
- else {
- (void)sprintf(xs,f,xlen);
- xlen = strlen(xs);
- }
- break;
- case 'D':
- dolong = TRUE;
- /* FALL THROUGH */
- case 'd':
- ch = *(++t);
- *t = '\0';
-#ifdef QUAD
- if (doquad)
- (void)sprintf(buf,s,(quad)str_gnum(arg));
- else
-#endif
- if (dolong)
- (void)sprintf(xs,f,(long)str_gnum(arg));
- else
- (void)sprintf(xs,f,(int)str_gnum(arg));
- xlen = strlen(xs);
- break;
- case 'X': case 'O':
- dolong = TRUE;
- /* FALL THROUGH */
- case 'x': case 'o': case 'u':
- ch = *(++t);
- *t = '\0';
- value = str_gnum(arg);
-#ifdef QUAD
- if (doquad)
- (void)sprintf(buf,s,(unsigned quad)value);
- else
-#endif
- if (dolong)
- (void)sprintf(xs,f,U_L(value));
- else
- (void)sprintf(xs,f,U_I(value));
- xlen = strlen(xs);
- break;
- case 'E': case 'e': case 'f': case 'G': case 'g':
- ch = *(++t);
- *t = '\0';
- (void)sprintf(xs,f,str_gnum(arg));
- xlen = strlen(xs);
- break;
- case 's':
- ch = *(++t);
- *t = '\0';
- xs = str_get(arg);
- xlen = arg->str_cur;
- if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xs[3] == '\0'
- && xlen == sizeof(STBP)) {
- STR *tmpstr = Str_new(24,0);
-
- stab_efullname(tmpstr, ((STAB*)arg)); /* a stab value! */
- sprintf(tokenbuf,"*%s",tmpstr->str_ptr);
- /* reformat to non-binary */
- xs = tokenbuf;
- xlen = strlen(tokenbuf);
- str_free(tmpstr);
- }
- if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
- break; /* so handle simple cases */
- }
- else if (f[1] == '-') {
- char *mp = index(f, '.');
- int min = atoi(f+2);
-
- if (mp) {
- int max = atoi(mp+1);
-
- if (xlen > max)
- xlen = max;
- }
- if (xlen < min)
- post = min - xlen;
- break;
- }
- else if (isDIGIT(f[1])) {
- char *mp = index(f, '.');
- int min = atoi(f+1);
-
- if (mp) {
- int max = atoi(mp+1);
-
- if (xlen > max)
- xlen = max;
- }
- if (xlen < min)
- pre = min - xlen;
- break;
- }
- strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
- *t = ch;
- (void)sprintf(buf,tokenbuf+64,xs);
- xs = buf;
- xlen = strlen(xs);
- break;
- }
- /* end of switch, copy results */
- *t = ch;
- STR_GROW(str, str->str_cur + (f - s) + xlen + 1 + pre + post);
- str_ncat(str, s, f - s);
- if (pre) {
- repeatcpy(str->str_ptr + str->str_cur, " ", 1, pre);
- str->str_cur += pre;
- }
- str_ncat(str, xs, xlen);
- if (post) {
- repeatcpy(str->str_ptr + str->str_cur, " ", 1, post);
- str->str_cur += post;
- }
- s = t;
- break; /* break from for loop */
- }
- }
- str_ncat(str, s, t - s);
- 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;
-}
-
-void
-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;
- SPAT * VOLATILE oldspat = curspat;
- STR *str;
- STAB *stab;
- int oldsave = savestack->ary_fill;
- int oldtmps_base = tmps_base;
- int hasargs = ((arg[2].arg_type & A_MASK) != A_NULL);
- register CSV *csv;
-
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else {
- STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
-
- if (tmpstr)
- stab = stabent(str_get(tmpstr),TRUE);
- else
- stab = Nullstab;
- }
- if (!stab)
- fatal("Undefined subroutine called");
- if (!(sub = stab_sub(stab))) {
- STR *tmpstr = arg[0].arg_ptr.arg_str;
-
- stab_efullname(tmpstr, stab);
- fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr);
- }
- if (arg->arg_type == O_DBSUBR && !sub->usersub) {
- str = stab_val(DBsub);
- saveitem(str);
- stab_efullname(str,stab);
- sub = stab_sub(DBsub);
- if (!sub)
- fatal("No DBsub routine");
- }
- str = Str_new(15, sizeof(CSV));
- str->str_state = SS_SCSV;
- (void)apush(savestack,str);
- csv = (CSV*)str->str_ptr;
- csv->sub = sub;
- csv->stab = stab;
- csv->curcsv = curcsv;
- csv->curcmd = curcmd;
- csv->depth = sub->depth;
- csv->wantarray = gimme;
- csv->hasargs = hasargs;
- curcsv = csv;
- tmps_base = tmps_max;
- if (sub->usersub) {
- csv->hasargs = 0;
- csv->savearray = Null(ARRAY*);;
- csv->argarray = Null(ARRAY*);
- st[sp] = arg->arg_ptr.arg_str;
- if (!hasargs)
- items = 0;
- sp = (*sub->usersub)(sub->userindex,sp,items);
- }
- else {
- if (hasargs) {
- csv->savearray = stab_xarray(defstab);
- csv->argarray = afake(defstab, items, &st[sp+1]);
- stab_xarray(defstab) = csv->argarray;
- }
- sub->depth++;
- if (sub->depth >= 2) { /* save temporaries on recursion? */
- if (sub->depth == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",stab_ename(stab));
- savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
- }
- sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */
- }
-
- st = stack->ary_array;
- tmps_base = oldtmps_base;
- for (items = arglast[0] + 1; items <= sp; items++)
- st[items] = str_mortal(st[items]);
- /* in case restore wipes old str */
- restorelist(oldsave);
- curspat = oldspat;
- 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) != 0;
- 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++) {
- /*SUPPRESS 560*/
- if (str = *relem)
- *relem = str_mortal(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;
- int magic = 0;
- STAB *tmpstab = str->str_u.str_stab;
-
- if (makelocal)
- hash = savehash(str->str_u.str_stab);
- else {
- hash = stab_hash(str->str_u.str_stab);
- if (tmpstab == envstab) {
- magic = 'E';
- environ[0] = Nullch;
- }
- else if (tmpstab == sigstab) {
- magic = 'S';
-#ifndef NSIG
-#define NSIG 32
-#endif
- for (i = 1; i < NSIG; i++)
- signal(i, SIG_DFL); /* crunch, crunch, crunch */
- }
-#ifdef SOME_DBM
- else if (hash->tbl_dbm)
- magic = 'D';
-#endif
- hclear(hash, magic == 'D'); /* wipe any dbm file too */
-
- }
- 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);
- if (magic) {
- str_magic(tmpstr, tmpstab, magic, tmps, str->str_cur);
- stabset(tmpstr->str_magic, tmpstr);
- }
- }
- }
- else
- fatal("panic: do_assign");
- }
- else {
- if (makelocal)
- saveitem(str);
- if (relem <= lastrelem) {
- str_sset(str, *relem);
- *(relem++) = str;
- }
- else {
- str_sset(str, &str_undef);
- 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 & ~DM_DELAY) {
- if (delaymagic & DM_UID) {
-#ifdef HAS_SETREUID
- (void)setreuid(uid,euid);
-#else /* not HAS_SETREUID */
-#ifdef HAS_SETRUID
- if ((delaymagic & DM_UID) == DM_RUID) {
- (void)setruid(uid);
- delaymagic =~ DM_RUID;
- }
-#endif /* HAS_SETRUID */
-#ifdef HAS_SETEUID
- if ((delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(uid);
- delaymagic =~ DM_EUID;
- }
-#endif /* HAS_SETEUID */
- if (delaymagic & DM_UID) {
- if (uid != euid)
- fatal("No setreuid available");
- (void)setuid(uid);
- }
-#endif /* not HAS_SETREUID */
- uid = (int)getuid();
- euid = (int)geteuid();
- }
- if (delaymagic & DM_GID) {
-#ifdef HAS_SETREGID
- (void)setregid(gid,egid);
-#else /* not HAS_SETREGID */
-#ifdef HAS_SETRGID
- if ((delaymagic & DM_GID) == DM_RGID) {
- (void)setrgid(gid);
- delaymagic =~ DM_RGID;
- }
-#endif /* HAS_SETRGID */
-#ifdef HAS_SETEGID
- if ((delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(gid);
- delaymagic =~ DM_EGID;
- }
-#endif /* HAS_SETEGID */
- if (delaymagic & DM_GID) {
- if (gid != egid)
- fatal("No setregid available");
- (void)setgid(gid);
- }
-#endif /* not HAS_SETREGID */
- gid = (int)getgid();
- egid = (int)getegid();
- }
- }
- 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 /*SUPPRESS 590*/
-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 /*SUPPRESS 590*/
-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;
- ARRAY *ary;
- HASH *hash;
-
- 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_SUBR || type == O_DBSUBR) {
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0;
- else {
- STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
-
- retval = tmpstr && stab_sub(stabent(str_get(tmpstr),TRUE)) != 0;
- }
- }
- else if (type == O_ARRAY || type == O_LARRAY ||
- type == O_ASLICE || type == O_LASLICE )
- retval = ((ary = stab_xarray(arg[1].arg_ptr.arg_stab)) != 0
- && ary->ary_max >= 0 );
- else if (type == O_HASH || type == O_LHASH ||
- type == O_HSLICE || type == O_LHSLICE )
- retval = ((hash = stab_xhash(arg[1].arg_ptr.arg_stab)) != 0
- && hash->tbl_array);
- else
- retval = FALSE;
- str_numset(str,(double)retval);
- stack->ary_array[retarg] = str;
- return retarg;
-}
-
-int /*SUPPRESS 590*/
-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) = anew(stab); /* so "@array" still works */
- }
- else if (type == O_HASH || type == O_LHASH) {
- stab = arg[1].arg_ptr.arg_stab;
- if (stab == envstab)
- environ[0] = Nullch;
- else if (stab == sigstab) {
- int i;
-
- for (i = 1; i < NSIG; i++)
- signal(i, SIG_DFL); /* munch, munch, munch */
- }
- (void)hfree(stab_xhash(stab), TRUE);
- stab_xhash(stab) = Null(HASH*);
- }
- else if (type == O_SUBR || type == O_DBSUBR) {
- stab = arg[1].arg_ptr.arg_stab;
- if ((arg[1].arg_type & A_MASK) != A_WORD) {
- STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
-
- if (tmpstr)
- stab = stabent(str_get(tmpstr),TRUE);
- else
- stab = Nullstab;
- }
- if (stab && stab_sub(stab)) {
- cmd_free(stab_sub(stab)->cmd);
- stab_sub(stab)->cmd = Nullcmd;
- 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)memzero(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 = ((unsigned long) s[offset] << 8) + s[offset+1];
- else if (size == 32)
- retnum = ((unsigned long) s[offset] << 24) +
- ((unsigned long) 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 = U_L(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;
- }
- }
-}
-
-void
-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);
- /*SUPPRESS 560*/
- while (entry = hiternext(hash))
- do_chop(astr,hiterval(hash,entry));
- return;
- }
- tmps = str_get(str);
- if (tmps && str->str_cur) {
- tmps += str->str_cur - 1;
- str_nset(astr,tmps,1); /* remember last char */
- *tmps = '\0'; /* wipe it out */
- str->str_cur = tmps - str->str_ptr;
- str->str_nok = 0;
- STABSET(str);
- }
- else
- str_nset(astr,"",0);
-}
-
-void
-do_vop(optype,str,left,right)
-STR *str;
-STR *left;
-STR *right;
-{
- register char *s;
- 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)memzero(str->str_ptr + str->str_cur, len - str->str_cur);
- str->str_cur = len;
- }
- str->str_pok = 1;
- str->str_nok = 0;
- s = str->str_ptr;
- if (!s) {
- str_nset(str,"",0);
- s = str->str_ptr;
- }
- 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;
-#ifdef atarist
- unsigned long arg[14]; /* yes, we really need that many ! */
-#else
- unsigned long arg[8];
-#endif
- register int i = 0;
- int retval = -1;
-
-#ifdef HAS_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++] = (unsigned long)str_gnum(st[sp]);
-#ifndef lint
- else
- arg[i++] = (unsigned 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;
-#ifdef atarist
- case 9:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8]);
- break;
- case 10:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9]);
- break;
- case 11:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9], arg[10]);
- break;
- case 12:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9], arg[10], arg[11]);
- break;
- case 13:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9], arg[10], arg[11], arg[12]);
- break;
- case 14:
- retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
- arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13]);
- break;
-#endif /* atarist */
- }
- return retval;
-#else
- fatal("syscall() unimplemented");
-#endif
-}
-
-
+++ /dev/null
-***************
-*** 1,4 ****
-! /* $RCSfile: doarg.c,v $$Revision: 4.0.1.7 $$Date: 1992/06/11 21:07:11 $
- *
- * Copyright (c) 1991, Larry Wall
- *
---- 1,4 ----
-! /* $RCSfile: doarg.c,v $$Revision: 4.0.1.8 $$Date: 1993/02/05 19:32:27 $
- *
- * Copyright (c) 1991, Larry Wall
- *
-***************
-*** 6,15 ****
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: doarg.c,v $
-! * Revision 4.0.1.7 1992/06/11 21:07:11 lwall
- * patch34: join with null list attempted negative allocation
- * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd "
-! *
- * Revision 4.0.1.6 92/06/08 12:34:30 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: pattern modifiers i and o didn't interact right
---- 6,18 ----
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: doarg.c,v $
-! * Revision 4.0.1.8 1993/02/05 19:32:27 lwall
-! * patch36: substitution didn't always invalidate numericity
-! *
-! * Revision 4.0.1.7 92/06/11 21:07:11 lwall
- * patch34: join with null list attempted negative allocation
- * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd "
-! *
- * Revision 4.0.1.6 92/06/08 12:34:30 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: pattern modifiers i and o didn't interact right
-/* $RCSfile: doio.c,v $$Revision: 4.0.1.6 $$Date: 92/06/11 21:08:16 $
+/* $RCSfile: doio.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:42 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: doio.c,v $
+ * Revision 4.1 92/08/07 17:19:42 lwall
+ * Stage 6 Snapshot
+ *
* Revision 4.0.1.6 92/06/11 21:08:16 lwall
* patch34: some systems don't declare h_errno extern in header files
*
#include "EXTERN.h"
#include "perl.h"
-#ifdef HAS_SOCKET
-#include <sys/socket.h>
-#include <netdb.h>
-#ifndef ENOTSOCK
-#include <net/errno.h>
-#endif
-#endif
-
-#ifdef HAS_SELECT
-#ifdef I_SYS_SELECT
-#ifndef I_SYS_TIME
-#include <sys/select.h>
-#endif
-#endif
-#endif
-
-#ifdef HOST_NOT_FOUND
-extern int h_errno;
-#endif
-
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
#include <sys/ipc.h>
#ifdef HAS_MSG
#endif
#endif
-#ifdef I_PWD
-#include <pwd.h>
-#endif
-#ifdef I_GRP
-#include <grp.h>
-#endif
#ifdef I_UTIME
#include <utime.h>
#endif
#include <sys/file.h>
#endif
-int laststatval = -1;
-int laststype = O_STAT;
-
-static char* warn_nl = "Unsuccessful %s on filename containing newline";
-
bool
-do_open(stab,name,len)
-STAB *stab;
+do_open(gv,name,len)
+GV *gv;
register char *name;
-int len;
+I32 len;
{
FILE *fp;
- register STIO *stio = stab_io(stab);
+ register IO *io = GvIO(gv);
char *myname = savestr(name);
int result;
int fd;
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 == '-')
+ if (!io)
+ io = GvIO(gv) = newIO();
+ else if (io->ifp) {
+ fd = fileno(io->ifp);
+ if (io->type == '-')
result = 0;
else if (fd <= maxsysfd) {
- saveifp = stio->ifp;
- saveofp = stio->ofp;
- savetype = stio->type;
+ saveifp = io->ifp;
+ saveofp = io->ofp;
+ savetype = io->type;
result = 0;
}
- else if (stio->type == '|')
- result = mypclose(stio->ifp);
- else if (stio->ifp != stio->ofp) {
- if (stio->ofp) {
- result = fclose(stio->ofp);
- fclose(stio->ifp); /* clear stdio, fd already closed */
+ else if (io->type == '|')
+ result = my_pclose(io->ifp);
+ else if (io->ifp != io->ofp) {
+ if (io->ofp) {
+ result = fclose(io->ofp);
+ fclose(io->ifp); /* clear stdio, fd already closed */
}
else
- result = fclose(stio->ifp);
+ result = fclose(io->ifp);
}
else
- result = fclose(stio->ifp);
+ result = fclose(io->ifp);
if (result == EOF && fd > maxsysfd)
fprintf(stderr,"Warning: unable to close filehandle %s properly.\n",
- stab_ename(stab));
- stio->ofp = stio->ifp = Nullfp;
+ GvENAME(gv));
+ io->ofp = io->ifp = Nullfp;
}
if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
mode[1] = *name++;
else {
mode[1] = '\0';
}
- stio->type = *name;
+ io->type = *name;
if (*name == '|') {
/*SUPPRESS 530*/
for (name++; isSPACE(*name); name++) ;
-#ifdef TAINT
- taintenv();
- taintproper("Insecure dependency in piped open");
-#endif
- fp = mypopen(name,"w");
+ if (strNE(name,"-"))
+ TAINT_ENV();
+ TAINT_PROPER("piped open");
+ fp = my_popen(name,"w");
writing = 1;
}
else if (*name == '>') {
-#ifdef TAINT
- taintproper("Insecure dependency in open");
-#endif
+ TAINT_PROPER("open");
name++;
if (*name == '>') {
- mode[0] = stio->type = 'a';
+ mode[0] = io->type = 'a';
name++;
}
else
if (isDIGIT(*name))
fd = atoi(name);
else {
- stab = stabent(name,FALSE);
- if (!stab || !stab_io(stab)) {
+ gv = gv_fetchpv(name,FALSE);
+ if (!gv || !GvIO(gv)) {
#ifdef EINVAL
errno = EINVAL;
#endif
goto say_false;
}
- if (stab_io(stab) && stab_io(stab)->ifp) {
- fd = fileno(stab_io(stab)->ifp);
- if (stab_io(stab)->type == 's')
- stio->type = 's';
+ if (GvIO(gv) && GvIO(gv)->ifp) {
+ fd = fileno(GvIO(gv)->ifp);
+ if (GvIO(gv)->type == 's')
+ io->type = 's';
}
else
fd = -1;
name++;
if (strEQ(name,"-")) {
fp = stdout;
- stio->type = '-';
+ io->type = '-';
}
else {
fp = fopen(name,mode);
goto duplicity;
if (strEQ(name,"-")) {
fp = stdin;
- stio->type = '-';
+ io->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';
/*SUPPRESS 530*/
for (; isSPACE(*name); name++) ;
- fp = mypopen(name,"r");
- stio->type = '|';
+ if (strNE(name,"-"))
+ TAINT_ENV();
+ TAINT_PROPER("piped open");
+ fp = my_popen(name,"r");
+ io->type = '|';
}
else {
- stio->type = '<';
+ io->type = '<';
/*SUPPRESS 530*/
for (; isSPACE(*name); name++) ;
if (strEQ(name,"-")) {
fp = stdin;
- stio->type = '-';
+ io->type = '-';
}
else
fp = fopen(name,"r");
}
}
if (!fp) {
- if (dowarn && stio->type == '<' && index(name, '\n'))
+ if (dowarn && io->type == '<' && index(name, '\n'))
warn(warn_nl, "open");
Safefree(myname);
goto say_false;
}
Safefree(myname);
- if (stio->type &&
- stio->type != '|' && stio->type != '-') {
+ if (io->type &&
+ io->type != '|' && io->type != '-') {
if (fstat(fileno(fp),&statbuf) < 0) {
(void)fclose(fp);
goto say_false;
}
if (S_ISSOCK(statbuf.st_mode))
- stio->type = 's'; /* in case a socket was passed in to us */
+ io->type = 's'; /* in case a socket was passed in to us */
#ifdef HAS_SOCKET
else if (
#ifdef S_IFMT
!statbuf.st_mode
#endif
) {
- int buflen = sizeof tokenbuf;
+ I32 buflen = sizeof tokenbuf;
if (getsockname(fileno(fp), tokenbuf, &buflen) >= 0
|| errno != ENOTSOCK)
- stio->type = 's'; /* some OS's return 0 on fstat()ed socket */
+ io->type = 's'; /* some OS's return 0 on fstat()ed socket */
/* but some return 0 for streams too, sigh */
}
#endif
}
if (fd != fileno(fp)) {
int pid;
- STR *str;
+ SV *sv;
dup2(fileno(fp), fd);
- str = afetch(fdpid,fileno(fp),TRUE);
- pid = str->str_u.str_useful;
- str->str_u.str_useful = 0;
- str = afetch(fdpid,fd,TRUE);
- str->str_u.str_useful = pid;
+ sv = *av_fetch(fdpid,fileno(fp),TRUE);
+ SvUPGRADE(sv, SVt_IV);
+ pid = SvIV(sv);
+ SvIV(sv) = 0;
+ sv = *av_fetch(fdpid,fd,TRUE);
+ SvUPGRADE(sv, SVt_IV);
+ SvIV(sv) = pid;
fclose(fp);
}
fp = saveifp;
clearerr(fp);
}
-#if defined(HAS_FCNTL) && defined(F_SETFD)
+#if defined(HAS_FCNTL) && defined(FFt_SETFD)
fd = fileno(fp);
- fcntl(fd,F_SETFD,fd > maxsysfd);
+ fcntl(fd,FFt_SETFD,fd > maxsysfd);
#endif
- stio->ifp = fp;
+ io->ifp = fp;
if (writing) {
- if (stio->type == 's'
- || (stio->type == '>' && S_ISCHR(statbuf.st_mode)) ) {
- if (!(stio->ofp = fdopen(fileno(fp),"w"))) {
+ if (io->type == 's'
+ || (io->type == '>' && S_ISCHR(statbuf.st_mode)) ) {
+ if (!(io->ofp = fdopen(fileno(fp),"w"))) {
fclose(fp);
- stio->ifp = Nullfp;
+ io->ifp = Nullfp;
goto say_false;
}
}
else
- stio->ofp = fp;
+ io->ofp = fp;
}
return TRUE;
say_false:
- stio->ifp = saveifp;
- stio->ofp = saveofp;
- stio->type = savetype;
+ io->ifp = saveifp;
+ io->ofp = saveofp;
+ io->type = savetype;
return FALSE;
}
FILE *
-nextargv(stab)
-register STAB *stab;
+nextargv(gv)
+register GV *gv;
{
- register STR *str;
+ register SV *sv;
#ifndef FLEXFILENAMES
int filedev;
int fileino;
#endif
int fileuid;
int filegid;
- static int filemode = 0;
- static int lastfd;
- static char *oldname;
- if (!argvoutstab)
- argvoutstab = stabent("ARGVOUT",TRUE);
+ if (!argvoutgv)
+ argvoutgv = gv_fetchpv("ARGVOUT",TRUE);
if (filemode & (S_ISUID|S_ISGID)) {
- fflush(stab_io(argvoutstab)->ifp); /* chmod must follow last write */
+ fflush(GvIO(argvoutgv)->ifp); /* chmod must follow last write */
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#else
#endif
}
filemode = 0;
- 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)) {
+ while (av_len(GvAV(gv)) >= 0) {
+ sv = av_shift(GvAV(gv));
+ sv_setsv(GvSV(gv),sv);
+ SvSETMAGIC(GvSV(gv));
+ oldname = SvPVnx(GvSV(gv));
+ if (do_open(gv,oldname,SvCUR(GvSV(gv)))) {
if (inplace) {
-#ifdef TAINT
- taintproper("Insecure dependency in inplace open");
-#endif
+ TAINT_PROPER("inplace open");
if (strEQ(oldname,"-")) {
- str_free(str);
- defoutstab = stabent("STDOUT",TRUE);
- return stab_io(stab)->ifp;
+ sv_free(sv);
+ defoutgv = gv_fetchpv("STDOUT",TRUE);
+ return GvIO(gv)->ifp;
}
#ifndef FLEXFILENAMES
filedev = statbuf.st_dev;
if (!S_ISREG(filemode)) {
warn("Can't do inplace edit: %s is not a regular file",
oldname );
- do_close(stab,FALSE);
- str_free(str);
+ do_close(gv,FALSE);
+ sv_free(sv);
continue;
}
if (*inplace) {
#ifdef SUFFIX
- add_suffix(str,inplace);
+ add_suffix(sv,inplace);
#else
- str_cat(str,inplace);
+ sv_catpv(sv,inplace);
#endif
#ifndef FLEXFILENAMES
- if (stat(str->str_ptr,&statbuf) >= 0
+ if (stat(SvPV(sv),&statbuf) >= 0
&& statbuf.st_dev == filedev
&& statbuf.st_ino == fileino ) {
warn("Can't do inplace edit: %s > 14 characters",
- str->str_ptr );
- do_close(stab,FALSE);
- str_free(str);
+ SvPV(sv) );
+ do_close(gv,FALSE);
+ sv_free(sv);
continue;
}
#endif
#ifdef HAS_RENAME
#ifndef DOSISH
- if (rename(oldname,str->str_ptr) < 0) {
+ if (rename(oldname,SvPV(sv)) < 0) {
warn("Can't rename %s to %s: %s, skipping file",
- oldname, str->str_ptr, strerror(errno) );
- do_close(stab,FALSE);
- str_free(str);
+ oldname, SvPV(sv), strerror(errno) );
+ do_close(gv,FALSE);
+ sv_free(sv);
continue;
}
#else
- do_close(stab,FALSE);
- (void)unlink(str->str_ptr);
- (void)rename(oldname,str->str_ptr);
- do_open(stab,str->str_ptr,stab_val(stab)->str_cur);
+ do_close(gv,FALSE);
+ (void)unlink(SvPV(sv));
+ (void)rename(oldname,SvPV(sv));
+ do_open(gv,SvPV(sv),SvCUR(GvSV(gv)));
#endif /* MSDOS */
#else
- (void)UNLINK(str->str_ptr);
- if (link(oldname,str->str_ptr) < 0) {
+ (void)UNLINK(SvPV(sv));
+ if (link(oldname,SvPV(sv)) < 0) {
warn("Can't rename %s to %s: %s, skipping file",
- oldname, str->str_ptr, strerror(errno) );
- do_close(stab,FALSE);
- str_free(str);
+ oldname, SvPV(sv), strerror(errno) );
+ do_close(gv,FALSE);
+ sv_free(sv);
continue;
}
(void)UNLINK(oldname);
#ifndef DOSISH
if (UNLINK(oldname) < 0) {
warn("Can't rename %s to %s: %s, skipping file",
- oldname, str->str_ptr, strerror(errno) );
- do_close(stab,FALSE);
- str_free(str);
+ oldname, SvPV(sv), strerror(errno) );
+ do_close(gv,FALSE);
+ sv_free(sv);
continue;
}
#else
#endif
}
- str_nset(str,">",1);
- str_cat(str,oldname);
+ sv_setpvn(sv,">",1);
+ sv_catpv(sv,oldname);
errno = 0; /* in case sprintf set errno */
- if (!do_open(argvoutstab,str->str_ptr,str->str_cur)) {
+ if (!do_open(argvoutgv,SvPV(sv),SvCUR(sv))) {
warn("Can't do inplace edit on %s: %s",
oldname, strerror(errno) );
- do_close(stab,FALSE);
- str_free(str);
+ do_close(gv,FALSE);
+ sv_free(sv);
continue;
}
- defoutstab = argvoutstab;
- lastfd = fileno(stab_io(argvoutstab)->ifp);
+ defoutgv = argvoutgv;
+ lastfd = fileno(GvIO(argvoutgv)->ifp);
(void)fstat(lastfd,&statbuf);
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#endif
}
}
- str_free(str);
- return stab_io(stab)->ifp;
+ sv_free(sv);
+ return GvIO(gv)->ifp;
}
else
- fprintf(stderr,"Can't open %s: %s\n",str_get(str), strerror(errno));
- str_free(str);
+ fprintf(stderr,"Can't open %s: %s\n",SvPVn(sv), strerror(errno));
+ sv_free(sv);
}
if (inplace) {
- (void)do_close(argvoutstab,FALSE);
- defoutstab = stabent("STDOUT",TRUE);
+ (void)do_close(argvoutgv,FALSE);
+ defoutgv = gv_fetchpv("STDOUT",TRUE);
}
return Nullfp;
}
#ifdef HAS_PIPE
void
-do_pipe(str, rstab, wstab)
-STR *str;
-STAB *rstab;
-STAB *wstab;
+do_pipe(sv, rgv, wgv)
+SV *sv;
+GV *rgv;
+GV *wgv;
{
- register STIO *rstio;
- register STIO *wstio;
+ register IO *rstio;
+ register IO *wstio;
int fd[2];
- if (!rstab)
+ if (!rgv)
goto badexit;
- if (!wstab)
+ if (!wgv)
goto badexit;
- rstio = stab_io(rstab);
- wstio = stab_io(wstab);
+ rstio = GvIO(rgv);
+ wstio = GvIO(wgv);
if (!rstio)
- rstio = stab_io(rstab) = stio_new();
+ rstio = GvIO(rgv) = newIO();
else if (rstio->ifp)
- do_close(rstab,FALSE);
+ do_close(rgv,FALSE);
if (!wstio)
- wstio = stab_io(wstab) = stio_new();
+ wstio = GvIO(wgv) = newIO();
else if (wstio->ifp)
- do_close(wstab,FALSE);
+ do_close(wgv,FALSE);
if (pipe(fd) < 0)
goto badexit;
goto badexit;
}
- str_sset(str,&str_yes);
+ sv_setsv(sv,&sv_yes);
return;
badexit:
- str_sset(str,&str_undef);
+ sv_setsv(sv,&sv_undef);
return;
}
#endif
bool
-do_close(stab,explicit)
-STAB *stab;
+do_close(gv,explicit)
+GV *gv;
bool explicit;
{
bool retval = FALSE;
- register STIO *stio;
+ register IO *io;
int status;
- if (!stab)
- stab = argvstab;
- if (!stab) {
+ if (!gv)
+ gv = argvgv;
+ if (!gv) {
errno = EBADF;
return FALSE;
}
- stio = stab_io(stab);
- if (!stio) { /* never opened */
+ io = GvIO(gv);
+ if (!io) { /* never opened */
if (dowarn && explicit)
- warn("Close on unopened file <%s>",stab_ename(stab));
+ warn("Close on unopened file <%s>",GvENAME(gv));
return FALSE;
}
- if (stio->ifp) {
- if (stio->type == '|') {
- status = mypclose(stio->ifp);
+ if (io->ifp) {
+ if (io->type == '|') {
+ status = my_pclose(io->ifp);
retval = (status == 0);
statusvalue = (unsigned short)status & 0xffff;
}
- else if (stio->type == '-')
+ else if (io->type == '-')
retval = TRUE;
else {
- if (stio->ofp && stio->ofp != stio->ifp) { /* a socket */
- retval = (fclose(stio->ofp) != EOF);
- fclose(stio->ifp); /* clear stdio, fd already closed */
+ if (io->ofp && io->ofp != io->ifp) { /* a socket */
+ retval = (fclose(io->ofp) != EOF);
+ fclose(io->ifp); /* clear stdio, fd already closed */
}
else
- retval = (fclose(stio->ifp) != EOF);
+ retval = (fclose(io->ifp) != EOF);
}
- stio->ofp = stio->ifp = Nullfp;
+ io->ofp = io->ifp = Nullfp;
+ }
+ if (explicit) {
+ io->lines = 0;
+ io->page = 0;
+ io->lines_left = io->page_len;
}
- if (explicit)
- stio->lines = 0;
- stio->type = ' ';
+ io->type = ' ';
return retval;
}
bool
-do_eof(stab)
-STAB *stab;
+do_eof(gv)
+GV *gv;
{
- register STIO *stio;
+ register IO *io;
int ch;
- if (!stab) { /* eof() */
- if (argvstab)
- stio = stab_io(argvstab);
- else
- return TRUE;
- }
- else
- stio = stab_io(stab);
+ io = GvIO(gv);
- if (!stio)
+ if (!io)
return TRUE;
- while (stio->ifp) {
+ while (io->ifp) {
#ifdef STDSTDIO /* (the code works without this) */
- if (stio->ifp->_cnt > 0) /* cheat a little, since */
+ if (io->ifp->_cnt > 0) /* cheat a little, since */
return FALSE; /* this is the most usual case */
#endif
- ch = getc(stio->ifp);
+ ch = getc(io->ifp);
if (ch != EOF) {
- (void)ungetc(ch, stio->ifp);
+ (void)ungetc(ch, io->ifp);
return FALSE;
}
#ifdef STDSTDIO
- if (stio->ifp->_cnt < -1)
- stio->ifp->_cnt = -1;
+ if (io->ifp->_cnt < -1)
+ io->ifp->_cnt = -1;
#endif
- if (!stab) { /* not necessarily a real EOF yet? */
- if (!nextargv(argvstab)) /* get another fp handy */
+ if (gv == argvgv) { /* not necessarily a real EOF yet? */
+ if (!nextargv(argvgv)) /* get another fp handy */
return TRUE;
}
else
}
long
-do_tell(stab)
-STAB *stab;
+do_tell(gv)
+GV *gv;
{
- register STIO *stio;
+ register IO *io;
- if (!stab)
+ if (!gv)
goto phooey;
- stio = stab_io(stab);
- if (!stio || !stio->ifp)
+ io = GvIO(gv);
+ if (!io || !io->ifp)
goto phooey;
#ifdef ULTRIX_STDIO_BOTCH
- if (feof(stio->ifp))
- (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */
+ if (feof(io->ifp))
+ (void)fseek (io->ifp, 0L, 2); /* ultrix 1.2 workaround */
#endif
- return ftell(stio->ifp);
+ return ftell(io->ifp);
phooey:
if (dowarn)
}
bool
-do_seek(stab, pos, whence)
-STAB *stab;
+do_seek(gv, pos, whence)
+GV *gv;
long pos;
int whence;
{
- register STIO *stio;
+ register IO *io;
- if (!stab)
+ if (!gv)
goto nuts;
- stio = stab_io(stab);
- if (!stio || !stio->ifp)
+ io = GvIO(gv);
+ if (!io || !io->ifp)
goto nuts;
#ifdef ULTRIX_STDIO_BOTCH
- if (feof(stio->ifp))
- (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */
+ if (feof(io->ifp))
+ (void)fseek (io->ifp, 0L, 2); /* ultrix 1.2 workaround */
#endif
- return fseek(stio->ifp, pos, whence) >= 0;
+ return fseek(io->ifp, pos, whence) >= 0;
nuts:
if (dowarn)
return FALSE;
}
-int
-do_ctl(optype,stab,func,argstr)
-int optype;
-STAB *stab;
-int func;
-STR *argstr;
+I32
+do_ctl(optype,gv,func,argstr)
+I32 optype;
+GV *gv;
+I32 func;
+SV *argstr;
{
- register STIO *stio;
+ register IO *io;
register char *s;
- int retval;
+ I32 retval;
- if (!stab || !argstr || !(stio = stab_io(stab)) || !stio->ifp) {
+ if (!gv || !argstr || !(io = GvIO(gv)) || !io->ifp) {
errno = EBADF; /* well, sort of... */
return -1;
}
- if (argstr->str_pok || !argstr->str_nok) {
- if (!argstr->str_pok)
- s = str_get(argstr);
+ if (SvPOK(argstr) || !SvNIOK(argstr)) {
+ if (!SvPOK(argstr))
+ s = SvPVn(argstr);
#ifdef IOCPARM_MASK
#ifndef IOCPARM_LEN
#else
retval = 256; /* otherwise guess at what's safe */
#endif
- if (argstr->str_cur < retval) {
- Str_Grow(argstr,retval+1);
- argstr->str_cur = retval;
+ if (SvCUR(argstr) < retval) {
+ Sv_Grow(argstr,retval+1);
+ SvCUR_set(argstr, retval);
}
- s = argstr->str_ptr;
- s[argstr->str_cur] = 17; /* a little sanity check here */
+ s = SvPV(argstr);
+ s[SvCUR(argstr)] = 17; /* a little sanity check here */
}
else {
- retval = (int)str_gnum(argstr);
+ retval = SvIVn(argstr);
#ifdef DOSISH
s = (char*)(long)retval; /* ouch */
#else
}
#ifndef lint
- if (optype == O_IOCTL)
- retval = ioctl(fileno(stio->ifp), func, s);
+ if (optype == OP_IOCTL)
+ retval = ioctl(fileno(io->ifp), func, s);
else
#ifdef DOSISH
fatal("fcntl is not implemented");
#else
#ifdef HAS_FCNTL
- retval = fcntl(fileno(stio->ifp), func, s);
+ retval = fcntl(fileno(io->ifp), func, s);
#else
fatal("fcntl is not implemented");
#endif
retval = 0;
#endif /* lint */
- if (argstr->str_pok) {
- if (s[argstr->str_cur] != 17)
+ if (SvPOK(argstr)) {
+ if (s[SvCUR(argstr)] != 17)
fatal("Return value overflowed string");
- s[argstr->str_cur] = 0; /* put our null back */
+ s[SvCUR(argstr)] = 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;
-
- if ((arg[1].arg_type & A_MASK) == A_WORD) {
- tmpstab = arg[1].arg_ptr.arg_stab;
- if (tmpstab != defstab) {
- laststype = O_STAT;
- statstab = tmpstab;
- str_set(statname,"");
- if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
- fstat(fileno(stab_io(tmpstab)->ifp),&statcache) < 0) {
- max = 0;
- laststatval = -1;
- }
- }
- else if (laststatval < 0)
- max = 0;
- }
- else {
- str_set(statname,str_get(ary->ary_array[sp]));
- statstab = Nullstab;
-#ifdef HAS_LSTAT
- laststype = arg->arg_type;
- if (arg->arg_type == O_LSTAT)
- laststatval = lstat(str_get(statname),&statcache);
- else
-#endif
- laststatval = stat(str_get(statname),&statcache);
- if (laststatval < 0) {
- if (dowarn && index(str_get(statname), '\n'))
- warn(warn_nl, "stat");
- 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_2mortal(str_nmake((double)statcache.st_dev)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_ino)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_mode)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_nlink)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_uid)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_gid)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_rdev)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_size)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_atime)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_mtime)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_ctime)));
-#ifdef STATBLOCKS
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_blksize)));
- (void)astore(ary,++sp,
- str_2mortal(str_nmake((double)statcache.st_blocks)));
-#else
- (void)astore(ary,++sp,
- str_2mortal(str_make("",0)));
- (void)astore(ary,++sp,
- str_2mortal(str_make("",0)));
-#endif
-#else /* lint */
- (void)astore(ary,++sp,str_nmake(0.0));
-#endif /* lint */
- }
- return sp;
-}
-
-#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
+#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(FFt_FREESP)
/* code courtesy of William Kucharski */
#define HAS_CHSIZE
-int chsize(fd, length)
-int fd; /* file descriptor */
+I32 chsize(fd, length)
+I32 fd; /* file descriptor */
off_t length; /* length to set file to */
{
extern long lseek();
fl.l_whence = 0;
fl.l_len = 0;
fl.l_start = length;
- fl.l_type = F_WRLCK; /* write lock on file space */
+ fl.l_type = FFt_WRLCK; /* write lock on file space */
/*
- * This relies on the UNDOCUMENTED F_FREESP argument to
+ * This relies on the UNDOCUMENTED FFt_FREESP argument to
* fcntl(2), which truncates the file so that it ends at the
* position indicated by fl.l_start.
*
* Will minor miracles never cease?
*/
- if (fcntl(fd, F_FREESP, &fl) < 0)
+ if (fcntl(fd, FFt_FREESP, &fl) < 0)
return -1;
}
return 0;
}
-#endif /* F_FREESP */
-
-int /*SUPPRESS 590*/
-do_truncate(str,arg,gimme,arglast)
-STR *str;
-register ARG *arg;
-int gimme;
-int *arglast;
-{
- register ARRAY *ary = stack;
- register int sp = arglast[0] + 1;
- off_t len = (off_t)str_gnum(ary->ary_array[sp+1]);
- int result = 1;
- STAB *tmpstab;
-
-#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE)
-#ifdef HAS_TRUNCATE
- if ((arg[1].arg_type & A_MASK) == A_WORD) {
- tmpstab = arg[1].arg_ptr.arg_stab;
- if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
- ftruncate(fileno(stab_io(tmpstab)->ifp), len) < 0)
- result = 0;
- }
- else if (truncate(str_get(ary->ary_array[sp]), len) < 0)
- result = 0;
-#else
- if ((arg[1].arg_type & A_MASK) == A_WORD) {
- tmpstab = arg[1].arg_ptr.arg_stab;
- if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
- chsize(fileno(stab_io(tmpstab)->ifp), len) < 0)
- result = 0;
- }
- else {
- int tmpfd;
+#endif /* FFt_FREESP */
- if ((tmpfd = open(str_get(ary->ary_array[sp]), 0)) < 0)
- result = 0;
- else {
- if (chsize(tmpfd, len) < 0)
- result = 0;
- close(tmpfd);
- }
- }
-#endif
-
- if (result)
- str_sset(str,&str_yes);
- else
- str_sset(str,&str_undef);
- STABSET(str);
- ary->ary_array[sp] = str;
- return sp;
-#else
- fatal("truncate not implemented");
-#endif
-}
-
-int
-looks_like_number(str)
-STR *str;
+I32
+looks_like_number(sv)
+SV *sv;
{
register char *s;
register char *send;
- if (!str->str_pok)
+ if (!SvPOK(sv))
return TRUE;
- s = str->str_ptr;
- send = s + str->str_cur;
+ s = SvPV(sv);
+ send = s + SvCUR(sv);
while (isSPACE(*s))
s++;
if (s >= send)
return TRUE;
if (*s == '.')
s++;
- else if (s == str->str_ptr)
+ else if (s == SvPV(sv))
return FALSE;
while (isDIGIT(*s))
s++;
}
bool
-do_print(str,fp)
-register STR *str;
+do_print(sv,fp)
+register SV *sv;
FILE *fp;
{
register char *tmps;
+ SV* tmpstr;
- if (!fp) {
- if (dowarn)
- warn("print to unopened file");
- errno = EBADF;
- return FALSE;
+ /* assuming fp is checked earlier */
+ if (!sv)
+ return TRUE;
+ if (ofmt) {
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if (SvIOK(sv) && SvIV(sv) != 0) {
+ fprintf(fp, ofmt, (double)SvIV(sv));
+ return !ferror(fp);
+ }
+ if ( (SvNOK(sv) && SvNV(sv) != 0.0)
+ || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
+ fprintf(fp, ofmt, SvNV(sv));
+ return !ferror(fp);
+ }
}
- if (!str)
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
return TRUE;
- 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);
+ case SVt_REF:
+ fprintf(fp, "%s", sv_2pv(sv));
return !ferror(fp);
+ case SVt_IV:
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ fprintf(fp, "%d", SvIV(sv));
+ return !ferror(fp);
+ default:
+ tmps = SvPVn(sv);
+ break;
}
- else {
- tmps = str_get(str);
- if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'B' && tmps[3] == '\0'
- && str->str_cur == sizeof(STBP) && strlen(tmps) < str->str_cur) {
- STR *tmpstr = str_mortal(&str_undef);
- stab_efullname(tmpstr,((STAB*)str));/* a stab value, be nice */
- str = tmpstr;
- tmps = str->str_ptr;
- putc('*',fp);
- }
- if (str->str_cur && (fwrite(tmps,1,str->str_cur,fp) == 0 || ferror(fp)))
- 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");
- errno = EBADF;
+ if (SvCUR(sv) && (fwrite(tmps,1,SvCUR(sv),fp) == 0 || ferror(fp)))
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 || ferror(fp)) {
- retval = FALSE;
- break;
- }
- }
- if (!(retval = do_print(*st, fp)))
- break;
- }
- if (retval && orslen)
- if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp))
- retval = FALSE;
- }
- return retval;
+ return TRUE;
}
-int
-mystat(arg,str)
-ARG *arg;
-STR *str;
+I32
+my_stat(ARGS)
+dARGS
{
- 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,"");
- laststype = O_STAT;
- return (laststatval = fstat(fileno(stio->ifp), &statcache));
+ dSP;
+ IO *io;
+
+ if (op->op_flags & OPf_SPECIAL) {
+ EXTEND(sp,1);
+ io = GvIO(cGVOP->op_gv);
+ if (io && io->ifp) {
+ statgv = cGVOP->op_gv;
+ sv_setpv(statname,"");
+ laststype = OP_STAT;
+ return (laststatval = fstat(fileno(io->ifp), &statcache));
}
else {
- if (arg[1].arg_ptr.arg_stab == defstab)
+ if (cGVOP->op_gv == defgv)
return laststatval;
if (dowarn)
warn("Stat on unopened file <%s>",
- stab_ename(arg[1].arg_ptr.arg_stab));
- statstab = Nullstab;
- str_set(statname,"");
+ GvENAME(cGVOP->op_gv));
+ statgv = Nullgv;
+ sv_setpv(statname,"");
return (laststatval = -1);
}
}
else {
- statstab = Nullstab;
- str_set(statname,str_get(str));
- laststype = O_STAT;
- laststatval = stat(str_get(str),&statcache);
- if (laststatval < 0 && dowarn && index(str_get(str), '\n'))
+ dPOPss;
+ PUTBACK;
+ statgv = Nullgv;
+ sv_setpv(statname,SvPVn(sv));
+ laststype = OP_STAT;
+ laststatval = stat(SvPVn(sv),&statcache);
+ if (laststatval < 0 && dowarn && index(SvPVn(sv), '\n'))
warn(warn_nl, "stat");
return laststatval;
}
}
-int
-mylstat(arg,str)
-ARG *arg;
-STR *str;
+I32
+my_lstat(ARGS)
+dARGS
{
- if (arg[1].arg_type & A_DONT) {
- if (arg[1].arg_ptr.arg_stab == defstab) {
- if (laststype != O_LSTAT)
+ dSP;
+ SV *sv;
+ if (op->op_flags & OPf_SPECIAL) {
+ EXTEND(sp,1);
+ if (cGVOP->op_gv == defgv) {
+ if (laststype != OP_LSTAT)
fatal("The stat preceding -l _ wasn't an lstat");
return laststatval;
}
fatal("You can't use -l on a filehandle");
}
- laststype = O_LSTAT;
- statstab = Nullstab;
- str_set(statname,str_get(str));
+ laststype = OP_LSTAT;
+ statgv = Nullgv;
+ sv = POPs;
+ PUTBACK;
+ sv_setpv(statname,SvPVn(sv));
#ifdef HAS_LSTAT
- laststatval = lstat(str_get(str),&statcache);
+ laststatval = lstat(SvPVn(sv),&statcache);
#else
- laststatval = stat(str_get(str),&statcache);
+ laststatval = stat(SvPVn(sv),&statcache);
#endif
- if (laststatval < 0 && dowarn && index(str_get(str), '\n'))
+ if (laststatval < 0 && dowarn && index(SvPVn(sv), '\n'))
warn(warn_nl, "lstat");
return laststatval;
}
-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) {
-#if defined(STDSTDIO) || defined(atarist) /* this will work with atariST */
- fstat(fileno(stio->ifp),&statcache);
- if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
- return arg->arg_type == O_FTTEXT ? &str_no : &str_yes;
- 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");
-#endif
- }
- else {
- if (dowarn)
- warn("Test on unopened file <%s>",
- stab_ename(arg[1].arg_ptr.arg_stab));
- errno = EBADF;
- return &str_undef;
- }
- }
- else {
- statstab = Nullstab;
- str_set(statname,str_get(str));
- really_filename:
- i = open(str_get(str),0);
- if (i < 0) {
- if (dowarn && index(str_get(str), '\n'))
- warn(warn_nl, "open");
- return &str_undef;
- }
- fstat(i,&statcache);
- len = read(i,tbuf,512);
- (void)close(i);
- if (len <= 0) {
- if (S_ISDIR(statcache.st_mode) && arg->arg_type == O_FTTEXT)
- return &str_no; /* special case NFS directories */
- return &str_yes; /* null file is anything */
- }
- 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;
-}
-
-static char **Argv = Null(char **);
-static char *Cmd = Nullch;
-
bool
-do_aexec(really,arglast)
-STR *really;
-int *arglast;
+do_aexec(really,mark,sp)
+SV *really;
+register SV **mark;
+register SV **sp;
{
- register STR **st = stack->ary_array;
- register int sp = arglast[1];
- register int items = arglast[2] - sp;
register char **a;
char *tmps;
- if (items) {
- New(401,Argv, items+1, char*);
+ if (sp > mark) {
+ New(401,Argv, sp - mark + 1, char*);
a = Argv;
- for (st += ++sp; items > 0; items--,st++) {
- if (*st)
- *a++ = str_get(*st);
+ while (++mark <= sp) {
+ if (*mark)
+ *a++ = SvPVnx(*mark);
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)))
+ TAINT_ENV(); /* testing IFS here is overkill, probably */
+ if (really && *(tmps = SvPVn(really)))
execvp(tmps,Argv);
else
execvp(Argv[0],Argv);
return FALSE;
}
-#ifdef HAS_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) {
- errno = EBADF;
- 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';
- if (!stio->ifp || !stio->ofp) {
- if (stio->ifp) fclose(stio->ifp);
- if (stio->ofp) fclose(stio->ofp);
- if (!stio->ifp && !stio->ofp) close(fd);
- return FALSE;
- }
-
- return TRUE;
-}
-
-int
-do_bind(stab, arglast)
-STAB *stab;
-int *arglast;
+I32
+apply(type,mark,sp)
+I32 type;
+register SV **mark;
+register SV **sp;
{
- 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");
- errno = EBADF;
- 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");
- errno = EBADF;
- 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");
- errno = EBADF;
- 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),(struct sockaddr *)buf,&len);
- if (fd < 0)
- goto badexit;
- nstio->ifp = fdopen(fd, "r");
- nstio->ofp = fdopen(fd, "w");
- nstio->type = 's';
- if (!nstio->ifp || !nstio->ofp) {
- if (nstio->ifp) fclose(nstio->ifp);
- if (nstio->ofp) fclose(nstio->ofp);
- if (!nstio->ifp && !nstio->ofp) close(fd);
- goto badexit;
- }
-
- str_nset(str, buf, len);
- return;
-
-nuts:
- if (dowarn)
- warn("accept() on closed fd");
- errno = EBADF;
-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");
- errno = EBADF;
- 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;
- unsigned int lvl;
- unsigned int optname;
-
- if (!stab)
- goto nuts;
-
- stio = stab_io(stab);
- if (!stio || !stio->ifp)
- goto nuts;
-
- fd = fileno(stio->ifp);
- lvl = (unsigned int)str_gnum(st[sp+1]);
- optname = (unsigned int)str_gnum(st[sp+2]);
- switch (optype) {
- case O_GSOCKOPT:
- st[sp] = str_2mortal(Str_new(22,257));
- st[sp]->str_cur = 256;
- st[sp]->str_pok = 1;
- if (getsockopt(fd, lvl, optname, st[sp]->str_ptr,
- (int*)&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;
- errno = EBADF;
- 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_2mortal(Str_new(22,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, (int*)&st[sp]->str_cur) < 0)
- goto nuts2;
- break;
- case O_GETPEERNAME:
- if (getpeername(fd, st[sp]->str_ptr, (int*)&st[sp]->str_cur) < 0)
- goto nuts2;
- break;
- }
-
- return sp;
-
-nuts:
- if (dowarn)
- warn("get{sock,peer}name() on closed fd");
- errno = EBADF;
-nuts2:
- 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 HAS_GETHOSTENT
- struct hostent *gethostent();
-#endif
- struct hostent *hent;
- unsigned long len;
-
- 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 HAS_GETHOSTENT
- hent = gethostent();
-#else
- fatal("gethostent not implemented");
-#endif
-
-#ifdef HOST_NOT_FOUND
- if (!hent)
- statusvalue = (unsigned short)h_errno & 0xffff;
-#endif
-
- if (gimme != G_ARRAY) {
- astore(ary, ++sp, str = str_mortal(&str_undef));
- if (hent) {
- if (which == O_GHBYNAME) {
-#ifdef h_addr
- str_nset(str, *hent->h_addr, hent->h_length);
-#else
- str_nset(str, hent->h_addr, hent->h_length);
-#endif
- }
- else
- str_set(str, hent->h_name);
- }
- return sp;
- }
-
- if (hent) {
-#ifndef lint
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, hent->h_name);
- (void)astore(ary, ++sp, str = str_mortal(&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_mortal(&str_no));
- str_numset(str, (double)hent->h_addrtype);
- (void)astore(ary, ++sp, str = str_mortal(&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_mortal(&str_no));
- str_nset(str, *elem, len);
- }
-#else
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_nset(str, hent->h_addr, len);
-#endif /* h_addr */
-#else /* lint */
- elem = Nullch;
- elem = elem;
- (void)astore(ary, ++sp, str_mortal(&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 (which == O_GNBYNAME) {
- char *name = str_get(ary->ary_array[sp+1]);
-
- nent = getnetbyname(name);
- }
- else if (which == O_GNBYADDR) {
- unsigned long addr = U_L(str_gnum(ary->ary_array[sp+1]));
- int addrtype = (int)str_gnum(ary->ary_array[sp+2]);
-
- nent = getnetbyaddr((long)addr,addrtype);
- }
- else
- nent = getnetent();
-
- if (gimme != G_ARRAY) {
- astore(ary, ++sp, str = str_mortal(&str_undef));
- if (nent) {
- if (which == O_GNBYNAME)
- str_numset(str, (double)nent->n_net);
- else
- str_set(str, nent->n_name);
- }
- return sp;
- }
-
- if (nent) {
-#ifndef lint
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, nent->n_name);
- (void)astore(ary, ++sp, str = str_mortal(&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_mortal(&str_no));
- str_numset(str, (double)nent->n_addrtype);
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_numset(str, (double)nent->n_net);
-#else /* lint */
- elem = Nullch;
- elem = elem;
- (void)astore(ary, ++sp, str_mortal(&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 (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 (gimme != G_ARRAY) {
- astore(ary, ++sp, str = str_mortal(&str_undef));
- if (pent) {
- if (which == O_GPBYNAME)
- str_numset(str, (double)pent->p_proto);
- else
- str_set(str, pent->p_name);
- }
- return sp;
- }
-
- if (pent) {
-#ifndef lint
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, pent->p_name);
- (void)astore(ary, ++sp, str = str_mortal(&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_mortal(&str_no));
- str_numset(str, (double)pent->p_proto);
-#else /* lint */
- elem = Nullch;
- elem = elem;
- (void)astore(ary, ++sp, str_mortal(&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 (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 (gimme != G_ARRAY) {
- astore(ary, ++sp, str = str_mortal(&str_undef));
- if (sent) {
- if (which == O_GSBYNAME) {
-#ifdef HAS_NTOHS
- str_numset(str, (double)ntohs(sent->s_port));
-#else
- str_numset(str, (double)(sent->s_port));
-#endif
- }
- else
- str_set(str, sent->s_name);
- }
- return sp;
- }
-
- if (sent) {
-#ifndef lint
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, sent->s_name);
- (void)astore(ary, ++sp, str = str_mortal(&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_mortal(&str_no));
-#ifdef HAS_NTOHS
- str_numset(str, (double)ntohs(sent->s_port));
-#else
- str_numset(str, (double)(sent->s_port));
-#endif
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, sent->s_proto);
-#else /* lint */
- elem = Nullch;
- elem = elem;
- (void)astore(ary, ++sp, str_mortal(&str_no));
-#endif /* lint */
- }
-
- return sp;
-}
-
-#endif /* HAS_SOCKET */
-
-#ifdef HAS_SELECT
-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];
- }
- Safefree(fd_sets[i]);
- }
- }
-#endif
-
- st[++sp] = str_mortal(&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_mortal(&str_no);
- str_numset(st[sp], value);
- }
- return sp;
-}
-#endif /* SELECT */
-
-#ifdef HAS_SOCKET
-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 HAS_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';
- if (!stio1->ifp || !stio1->ofp || !stio2->ifp || !stio2->ofp) {
- if (stio1->ifp) fclose(stio1->ifp);
- if (stio1->ofp) fclose(stio1->ofp);
- if (!stio1->ifp && !stio1->ofp) close(fd[0]);
- if (stio2->ifp) fclose(stio2->ifp);
- if (stio2->ofp) fclose(stio2->ofp);
- if (!stio2->ifp && !stio2->ofp) close(fd[1]);
- return FALSE;
- }
-
- return TRUE;
-}
-
-#endif /* HAS_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 STR *str;
- struct passwd *getpwnam();
- struct passwd *getpwuid();
- struct passwd *getpwent();
- struct passwd *pwent;
-
- 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 (gimme != G_ARRAY) {
- astore(ary, ++sp, str = str_mortal(&str_undef));
- if (pwent) {
- if (which == O_GPWNAM)
- str_numset(str, (double)pwent->pw_uid);
- else
- str_set(str, pwent->pw_name);
- }
- return sp;
- }
-
- if (pwent) {
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, pwent->pw_name);
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, pwent->pw_passwd);
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_numset(str, (double)pwent->pw_uid);
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_numset(str, (double)pwent->pw_gid);
- (void)astore(ary, ++sp, str = str_mortal(&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_mortal(&str_no));
-#ifdef PWCLASS
- str_set(str,pwent->pw_class);
-#else
-#ifdef PWCOMMENT
- str_set(str, pwent->pw_comment);
-#endif
-#endif
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, pwent->pw_gecos);
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, pwent->pw_dir);
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, pwent->pw_shell);
-#ifdef PWEXPIRE
- (void)astore(ary, ++sp, str = str_mortal(&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;
-
- 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 (gimme != G_ARRAY) {
- astore(ary, ++sp, str = str_mortal(&str_undef));
- if (grent) {
- if (which == O_GGRNAM)
- str_numset(str, (double)grent->gr_gid);
- else
- str_set(str, grent->gr_name);
- }
- return sp;
- }
-
- if (grent) {
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, grent->gr_name);
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_set(str, grent->gr_passwd);
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_numset(str, (double)grent->gr_gid);
- (void)astore(ary, ++sp, str = str_mortal(&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(HAS_READDIR)
- register ARRAY *ary = stack;
- register STR **st = ary->ary_array;
- register int sp = arglast[1];
- register STIO *stio;
- long along;
-#ifndef apollo
- struct DIRENT *readdir();
-#endif
- register struct DIRENT *dp;
-
- if (!stab)
- goto nope;
- if (!(stio = stab_io(stab)))
- stio = stab_io(stab) = stio_new();
- if (!stio->dirp && optype != O_OPEN_DIR)
- goto nope;
- st[sp] = &str_yes;
- switch (optype) {
- case O_OPEN_DIR:
- 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;
- /*SUPPRESS 560*/
- while (dp = readdir(stio->dirp)) {
-#ifdef DIRNAMLEN
- (void)astore(ary,++sp,
- str_2mortal(str_make(dp->d_name,dp->d_namlen)));
-#else
- (void)astore(ary,++sp,
- str_2mortal(str_make(dp->d_name,0)));
-#endif
- }
- }
- else {
- if (!(dp = readdir(stio->dirp)))
- goto nope;
- st[sp] = str_mortal(&str_undef);
-#ifdef DIRNAMLEN
- str_nset(st[sp], dp->d_name, dp->d_namlen);
-#else
- str_set(st[sp], dp->d_name);
-#endif
- }
- break;
-#if defined(HAS_TELLDIR) || defined(telldir)
- case O_TELLDIR: {
-#ifndef telldir
- long telldir();
-#endif
- st[sp] = str_mortal(&str_undef);
- str_numset(st[sp], (double)telldir(stio->dirp));
- break;
- }
-#endif
-#if defined(HAS_SEEKDIR) || defined(seekdir)
- case O_SEEKDIR:
- st[sp] = str_mortal(&str_undef);
- along = (long)str_gnum(st[sp+1]);
- (void)seekdir(stio->dirp,along);
- break;
-#endif
-#if defined(HAS_REWINDDIR) || defined(rewinddir)
- case O_REWINDDIR:
- st[sp] = str_mortal(&str_undef);
- (void)rewinddir(stio->dirp);
- break;
-#endif
- case O_CLOSEDIR:
- st[sp] = str_mortal(&str_undef);
- (void)closedir(stio->dirp);
- stio->dirp = 0;
- break;
- default:
- goto phooey;
- }
- return sp;
-
-nope:
- st[sp] = &str_undef;
- if (!errno)
- errno = EBADF;
- return sp;
-
-#endif
-phooey:
- fatal("Unimplemented directory operation");
-}
-
-int
-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;
+ register I32 val;
+ register I32 val2;
+ register I32 tot = 0;
char *s;
+ SV **oldmark = mark;
#ifdef TAINT
- for (st += ++sp; items--; st++)
- tainted |= (*st)->str_tainted;
- st = stack->ary_array;
- sp = arglast[1];
- items = arglast[2] - sp;
+ while (++mark <= sp)
+ TAINT_IF((*mark)->sv_tainted);
+ mark = oldmark;
#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))
+ case OP_CHMOD:
+ TAINT_PROPER("chmod");
+ if (++mark <= sp) {
+ tot = sp - mark;
+ val = SvIVnx(*mark);
+ while (++mark <= sp) {
+ if (chmod(SvPVnx(*mark),val))
tot--;
}
}
break;
#ifdef HAS_CHOWN
- 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))
+ case OP_CHOWN:
+ TAINT_PROPER("chown");
+ if (sp - mark > 2) {
+ tot = sp - mark;
+ val = SvIVnx(*++mark);
+ val2 = SvIVnx(*++mark);
+ while (++mark <= sp) {
+ if (chown(SvPVnx(*mark),val,val2))
tot--;
}
}
break;
#endif
#ifdef HAS_KILL
- 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]);
+ case OP_KILL:
+ TAINT_PROPER("kill");
+ s = SvPVnx(*++mark);
+ tot = sp - mark;
+ 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 = SvIVnx(*mark);
+ if (val < 0) {
+ val = -val;
+ while (++mark <= sp) {
+ I32 proc = SvIVnx(*mark);
#ifdef HAS_KILLPG
- if (killpg(proc,val)) /* BSD */
+ if (killpg(proc,val)) /* BSD */
#else
- if (kill(-proc,val)) /* SYSV */
+ if (kill(-proc,val)) /* SYSV */
#endif
- tot--;
- }
+ tot--;
}
- else {
- while (items--) {
- if (kill((int)(str_gnum(st[++sp])),val))
- tot--;
- }
+ }
+ else {
+ while (++mark <= sp) {
+ if (kill(SvIVnx(*mark),val))
+ tot--;
}
}
break;
#endif
- case O_UNLINK:
-#ifdef TAINT
- taintproper("Insecure dependency in unlink");
-#endif
- tot = items;
- while (items--) {
- s = str_get(st[++sp]);
+ case OP_UNLINK:
+ TAINT_PROPER("unlink");
+ tot = sp - mark;
+ while (++mark <= sp) {
+ s = SvPVnx(*mark);
if (euid || unsafe) {
if (UNLINK(s))
tot--;
}
}
break;
- case O_UTIME:
-#ifdef TAINT
- taintproper("Insecure dependency in utime");
-#endif
- if (items > 2) {
+ case OP_UTIME:
+ TAINT_PROPER("utime");
+ if (sp - mark > 2) {
#ifdef I_UTIME
struct utimbuf utbuf;
#else
#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))
+ utbuf.actime = SvIVnx(*++mark); /* time accessed */
+ utbuf.modtime = SvIVnx(*++mark); /* time modified */
+ tot = sp - mark;
+ while (++mark <= sp) {
+ if (utime(SvPVnx(*mark),&utbuf))
tot--;
}
-#endif
}
else
- items = 0;
+ tot = 0;
break;
}
return tot;
/* Do the permissions allow some operation? Assumes statcache already set. */
-int
+I32
cando(bit, effective, statbufp)
-int bit;
-int effective;
+I32 bit;
+I32 effective;
register struct stat *statbufp;
{
#ifdef DOSISH
if (statbufp->st_mode & bit)
return TRUE; /* ok as "user" */
}
- else if (ingroup((int)statbufp->st_gid,effective)) {
+ else if (ingroup((I32)statbufp->st_gid,effective)) {
if (statbufp->st_mode & bit >> 3)
return TRUE; /* ok as "group" */
}
#endif /* ! MSDOS */
}
-int
+I32
ingroup(testgid,effective)
-int testgid;
-int effective;
+I32 testgid;
+I32 effective;
{
if (testgid == (effective ? egid : gid))
return TRUE;
#endif
{
GROUPSTYPE gary[NGROUPS];
- int anum;
+ I32 anum;
anum = getgroups(NGROUPS,gary);
while (--anum >= 0)
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
-int
-do_ipcget(optype, arglast)
-int optype;
-int *arglast;
+I32
+do_ipcget(optype, mark, sp)
+I32 optype;
+SV **mark;
+SV **sp;
{
- register STR **st = stack->ary_array;
- register int sp = arglast[0];
key_t key;
- int n, flags;
+ I32 n, flags;
- key = (key_t)str_gnum(st[++sp]);
- n = (optype == O_MSGGET) ? 0 : (int)str_gnum(st[++sp]);
- flags = (int)str_gnum(st[++sp]);
+ key = (key_t)SvNVnx(*++mark);
+ n = (optype == OP_MSGGET) ? 0 : SvIVnx(*++mark);
+ flags = SvIVnx(*++mark);
errno = 0;
switch (optype)
{
#ifdef HAS_MSG
- case O_MSGGET:
+ case OP_MSGGET:
return msgget(key, flags);
#endif
#ifdef HAS_SEM
- case O_SEMGET:
+ case OP_SEMGET:
return semget(key, n, flags);
#endif
#ifdef HAS_SHM
- case O_SHMGET:
+ case OP_SHMGET:
return shmget(key, n, flags);
#endif
#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
default:
- fatal("%s not implemented", opname[optype]);
+ fatal("%s not implemented", op_name[optype]);
#endif
}
return -1; /* should never happen */
}
-int
-do_ipcctl(optype, arglast)
-int optype;
-int *arglast;
+I32
+do_ipcctl(optype, mark, sp)
+I32 optype;
+SV **mark;
+SV **sp;
{
- register STR **st = stack->ary_array;
- register int sp = arglast[0];
- STR *astr;
+ SV *astr;
char *a;
- int id, n, cmd, infosize, getinfo, ret;
-
- id = (int)str_gnum(st[++sp]);
- n = (optype == O_SEMCTL) ? (int)str_gnum(st[++sp]) : 0;
- cmd = (int)str_gnum(st[++sp]);
- astr = st[++sp];
+ I32 id, n, cmd, infosize, getinfo, ret;
+ id = SvIVnx(*++mark);
+ n = (optype == OP_SEMCTL) ? SvIVnx(*++mark) : 0;
+ cmd = SvIVnx(*++mark);
+ astr = *++mark;
infosize = 0;
getinfo = (cmd == IPC_STAT);
switch (optype)
{
#ifdef HAS_MSG
- case O_MSGCTL:
+ case OP_MSGCTL:
if (cmd == IPC_STAT || cmd == IPC_SET)
infosize = sizeof(struct msqid_ds);
break;
#endif
#ifdef HAS_SHM
- case O_SHMCTL:
+ case OP_SHMCTL:
if (cmd == IPC_STAT || cmd == IPC_SET)
infosize = sizeof(struct shmid_ds);
break;
#endif
#ifdef HAS_SEM
- case O_SEMCTL:
+ case OP_SEMCTL:
if (cmd == IPC_STAT || cmd == IPC_SET)
infosize = sizeof(struct semid_ds);
else if (cmd == GETALL || cmd == SETALL)
#endif
#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
default:
- fatal("%s not implemented", opname[optype]);
+ fatal("%s not implemented", op_name[optype]);
#endif
}
{
if (getinfo)
{
- STR_GROW(astr, infosize+1);
- a = str_get(astr);
+ SvGROW(astr, infosize+1);
+ a = SvPVn(astr);
}
else
{
- a = str_get(astr);
- if (astr->str_cur != infosize)
+ a = SvPVn(astr);
+ if (SvCUR(astr) != infosize)
{
errno = EINVAL;
return -1;
}
else
{
- int i = (int)str_gnum(astr);
+ I32 i = SvIVn(astr);
a = (char *)i; /* ouch */
}
errno = 0;
switch (optype)
{
#ifdef HAS_MSG
- case O_MSGCTL:
+ case OP_MSGCTL:
ret = msgctl(id, cmd, (struct msqid_ds *)a);
break;
#endif
#ifdef HAS_SEM
- case O_SEMCTL:
- ret = semctl(id, n, cmd, a);
+ case OP_SEMCTL:
+ ret = semctl(id, n, cmd, (struct semid_ds *)a);
break;
#endif
#ifdef HAS_SHM
- case O_SHMCTL:
+ case OP_SHMCTL:
ret = shmctl(id, cmd, (struct shmid_ds *)a);
break;
#endif
}
if (getinfo && ret >= 0) {
- astr->str_cur = infosize;
- astr->str_ptr[infosize] = '\0';
+ SvCUR_set(astr, infosize);
+ *SvEND(astr) = '\0';
}
return ret;
}
-int
-do_msgsnd(arglast)
-int *arglast;
+I32
+do_msgsnd(mark, sp)
+SV **mark;
+SV **sp;
{
#ifdef HAS_MSG
- register STR **st = stack->ary_array;
- register int sp = arglast[0];
- STR *mstr;
+ SV *mstr;
char *mbuf;
- int id, msize, flags;
+ I32 id, msize, flags;
- id = (int)str_gnum(st[++sp]);
- mstr = st[++sp];
- flags = (int)str_gnum(st[++sp]);
- mbuf = str_get(mstr);
- if ((msize = mstr->str_cur - sizeof(long)) < 0) {
+ id = SvIVnx(*++mark);
+ mstr = *++mark;
+ flags = SvIVnx(*++mark);
+ mbuf = SvPVn(mstr);
+ if ((msize = SvCUR(mstr) - sizeof(long)) < 0) {
errno = EINVAL;
return -1;
}
#endif
}
-int
-do_msgrcv(arglast)
-int *arglast;
+I32
+do_msgrcv(mark, sp)
+SV **mark;
+SV **sp;
{
#ifdef HAS_MSG
- register STR **st = stack->ary_array;
- register int sp = arglast[0];
- STR *mstr;
+ SV *mstr;
char *mbuf;
long mtype;
- int id, msize, flags, ret;
-
- id = (int)str_gnum(st[++sp]);
- mstr = st[++sp];
- msize = (int)str_gnum(st[++sp]);
- mtype = (long)str_gnum(st[++sp]);
- flags = (int)str_gnum(st[++sp]);
- mbuf = str_get(mstr);
- if (mstr->str_cur < sizeof(long)+msize+1) {
- STR_GROW(mstr, sizeof(long)+msize+1);
- mbuf = str_get(mstr);
+ I32 id, msize, flags, ret;
+
+ id = SvIVnx(*++mark);
+ mstr = *++mark;
+ msize = SvIVnx(*++mark);
+ mtype = (long)SvIVnx(*++mark);
+ flags = SvIVnx(*++mark);
+ mbuf = SvPVn(mstr);
+ if (SvCUR(mstr) < sizeof(long)+msize+1) {
+ SvGROW(mstr, sizeof(long)+msize+1);
+ mbuf = SvPVn(mstr);
}
errno = 0;
ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
if (ret >= 0) {
- mstr->str_cur = sizeof(long)+ret;
- mstr->str_ptr[sizeof(long)+ret] = '\0';
+ SvCUR_set(mstr, sizeof(long)+ret);
+ *SvEND(mstr) = '\0';
}
return ret;
#else
#endif
}
-int
-do_semop(arglast)
-int *arglast;
+I32
+do_semop(mark, sp)
+SV **mark;
+SV **sp;
{
#ifdef HAS_SEM
- register STR **st = stack->ary_array;
- register int sp = arglast[0];
- STR *opstr;
+ SV *opstr;
char *opbuf;
- int id, opsize;
+ I32 id, opsize;
- id = (int)str_gnum(st[++sp]);
- opstr = st[++sp];
- opbuf = str_get(opstr);
- opsize = opstr->str_cur;
+ id = SvIVnx(*++mark);
+ opstr = *++mark;
+ opbuf = SvPVn(opstr);
+ opsize = SvCUR(opstr);
if (opsize < sizeof(struct sembuf)
|| (opsize % sizeof(struct sembuf)) != 0) {
errno = EINVAL;
#endif
}
-int
-do_shmio(optype, arglast)
-int optype;
-int *arglast;
+I32
+do_shmio(optype, mark, sp)
+I32 optype;
+SV **mark;
+SV **sp;
{
#ifdef HAS_SHM
- register STR **st = stack->ary_array;
- register int sp = arglast[0];
- STR *mstr;
+ SV *mstr;
char *mbuf, *shm;
- int id, mpos, msize;
+ I32 id, mpos, msize;
struct shmid_ds shmds;
#ifndef VOIDSHMAT
extern char *shmat();
#endif
- id = (int)str_gnum(st[++sp]);
- mstr = st[++sp];
- mpos = (int)str_gnum(st[++sp]);
- msize = (int)str_gnum(st[++sp]);
+ id = SvIVnx(*++mark);
+ mstr = *++mark;
+ mpos = SvIVnx(*++mark);
+ msize = SvIVnx(*++mark);
errno = 0;
if (shmctl(id, IPC_STAT, &shmds) == -1)
return -1;
errno = EFAULT; /* can't do as caller requested */
return -1;
}
- shm = (char*)shmat(id, (char*)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
+ shm = (char*)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
if (shm == (char *)-1) /* I hate System V IPC, I really do */
return -1;
- mbuf = str_get(mstr);
- if (optype == O_SHMREAD) {
- if (mstr->str_cur < msize) {
- STR_GROW(mstr, msize+1);
- mbuf = str_get(mstr);
+ mbuf = SvPVn(mstr);
+ if (optype == OP_SHMREAD) {
+ if (SvCUR(mstr) < msize) {
+ SvGROW(mstr, msize+1);
+ mbuf = SvPVn(mstr);
}
Copy(shm + mpos, mbuf, msize, char);
- mstr->str_cur = msize;
- mstr->str_ptr[msize] = '\0';
+ SvCUR_set(mstr, msize);
+ *SvEND(mstr) = '\0';
}
else {
- int n;
+ I32 n;
- if ((n = mstr->str_cur) > msize)
+ if ((n = SvCUR(mstr)) > msize)
n = msize;
Copy(mbuf, shm + mpos, n, char);
if (n < msize)
-/* $RCSfile: dolist.c,v $$Revision: 4.0.1.5 $$Date: 92/06/08 13:13:27 $
+/* $RCSfile: dolist.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:51 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: dolist.c,v $
+ * Revision 4.1 92/08/07 17:19:51 lwall
+ * Stage 6 Snapshot
+ *
* Revision 4.0.1.5 92/06/08 13:13:27 lwall
* patch20: g pattern modifer sometimes returned extra values
* patch20: m/$pattern/g didn't work
#include "EXTERN.h"
#include "perl.h"
-static int sortcmp();
-static int sortsub();
-
#ifdef BUGGY_MSC
#pragma function(memcmp)
#endif /* BUGGY_MSC */
-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;
- char *myhint = hint;
- int global;
- int safebase;
- char *truebase = s;
- register REGEXP *rx = spat->spat_regexp;
-
- hint = Nullch;
- if (!spat) {
- if (gimme == G_ARRAY)
- return --sp;
- str_set(str,Yes);
- STABSET(str);
- st[sp] = str;
- return sp;
- }
- global = spat->spat_flags & SPAT_GLOBAL;
- safebase = (gimme == G_ARRAY) || global;
- 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 (!global && rx)
- regfree(rx);
- spat->spat_regexp = Null(REGEXP*); /* crucial if regcomp aborts */
- spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
- spat->spat_flags & SPAT_FOLD);
- if (!spat->spat_regexp->prelen && lastspat)
- spat = lastspat;
- if (spat->spat_flags & SPAT_KEEP) {
- if (!(spat->spat_flags & SPAT_FOLD))
- scanconst(spat,spat->spat_regexp->precomp,
- spat->spat_regexp->prelen);
- if (spat->spat_runtime)
- arg_free(spat->spat_runtime); /* it won't change, so */
- spat->spat_runtime = Nullarg; /* no point compiling again */
- hoistmust(spat);
- if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
- curcmd->c_flags &= ~CF_OPTIMIZE;
- opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
- }
- }
- if (global) {
- if (rx) {
- if (rx->startp[0]) {
- s = rx->endp[0];
- if (s == rx->startp[0])
- s++;
- if (s > strend) {
- regfree(rx);
- rx = spat->spat_regexp;
- goto nope;
- }
- }
- regfree(rx);
- }
- }
- else if (!spat->spat_regexp->nparens)
- gimme = G_SCALAR; /* accidental array context? */
- rx = spat->spat_regexp;
- if (regexec(rx, s, strend, s, 0,
- srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
- safebase)) {
- if (rx->subbase || global)
- 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,rx->precomp,ch);
- }
-#endif
- if (!rx->prelen && lastspat) {
- spat = lastspat;
- rx = spat->spat_regexp;
- }
- t = s;
- play_it_again:
- if (global && rx->startp[0]) {
- t = s = rx->endp[0];
- if (s == rx->startp[0])
- s++,t++;
- if (s > strend)
- goto nope;
- }
- if (myhint) {
- if (myhint < s || myhint > strend)
- fatal("panic: hint in do_match");
- s = myhint;
- if (rx->regback >= 0) {
- s -= rx->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 && rx->regback >= 0) {
- ++spat->spat_short->str_u.str_useful;
- s -= rx->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 (!rx->nparens && !global) {
- gimme = G_SCALAR; /* accidental array context? */
- safebase = FALSE;
- }
- if (regexec(rx, s, strend, truebase, 0,
- srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
- safebase)) {
- if (rx->subbase || global)
- curspat = spat;
- lastspat = spat;
- if (spat->spat_flags & SPAT_ONCE)
- spat->spat_flags |= SPAT_USED;
- goto gotcha;
- }
- else {
- if (global)
- rx->startp[0] = Nullch;
- 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 = rx->nparens;
- if (global && !iters)
- i = 1;
- else
- i = 0;
- if (sp + iters + i >= stack->ary_max) {
- astore(stack,sp + iters + i, Nullstr);
- st = stack->ary_array; /* possibly realloced */
- }
-
- for (i = !i; i <= iters; i++) {
- st[++sp] = str_mortal(&str_no);
- /*SUPPRESS 560*/
- if (s = rx->startp[i]) {
- len = rx->endp[i] - s;
- if (len > 0)
- str_nset(st[sp],s,len);
- }
- }
- if (global) {
- truebase = rx->subbeg;
- goto play_it_again;
- }
- 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 (global) {
- rx->subbeg = t;
- rx->subend = strend;
- rx->startp[0] = s;
- rx->endp[0] = s + spat->spat_short->str_cur;
- curspat = spat;
- goto gotcha;
- }
- if (sawampersand) {
- char *tmps;
-
- if (rx->subbase)
- Safefree(rx->subbase);
- tmps = rx->subbase = nsavestr(t,strend-t);
- rx->subbeg = tmps;
- rx->subend = tmps + (strend-t);
- tmps = rx->startp[0] = tmps + (s - t);
- rx->endp[0] = tmps + spat->spat_short->str_cur;
- curspat = spat;
- }
- str_sset(str,&str_yes);
- STABSET(str);
- st[++sp] = str;
- return sp;
-
-nope:
- rx->startp[0] = Nullch;
- if (spat->spat_short)
- ++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;
-}
-
#ifdef BUGGY_MSC
#pragma intrinsic(memcmp)
#endif /* BUGGY_MSC */
-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 (*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 = Null(REGEXP*); /* avoid possible double free */
- }
- spat->spat_regexp = regcomp(m,m+dstr->str_cur,
- spat->spat_flags & SPAT_FOLD);
- 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 (strEQ("\\s+",spat->spat_regexp->precomp)) {
- while (--limit) {
- /*SUPPRESS 530*/
- for (m = s; m < strend && !isSPACE(*m); m++) ;
- if (m >= strend)
- break;
- dstr = Str_new(30,m-s);
- str_nset(dstr,s,m-s);
- if (!realarray)
- str_2mortal(dstr);
- (void)astore(ary, ++sp, dstr);
- /*SUPPRESS 530*/
- for (s = m + 1; s < strend && isSPACE(*s); s++) ;
- }
- }
- else if (strEQ("^",spat->spat_regexp->precomp)) {
- while (--limit) {
- /*SUPPRESS 530*/
- for (m = s; m < strend && *m != '\n'; m++) ;
- m++;
- if (m >= strend)
- break;
- dstr = Str_new(30,m-s);
- str_nset(dstr,s,m-s);
- if (!realarray)
- str_2mortal(dstr);
- (void)astore(ary, ++sp, dstr);
- s = m;
- }
- }
- else if (spat->spat_short) {
- i = spat->spat_short->str_cur;
- if (i == 1) {
- int fold = (spat->spat_flags & SPAT_FOLD);
-
- i = *spat->spat_short->str_ptr;
- if (fold && isUPPER(i))
- i = tolower(i);
- while (--limit) {
- if (fold) {
- for ( m = s;
- m < strend && *m != i &&
- (!isUPPER(*m) || tolower(*m) != i);
- m++) /*SUPPRESS 530*/
- ;
- }
- else /*SUPPRESS 530*/
- for (m = s; m < strend && *m != i; m++) ;
- if (m >= strend)
- break;
- dstr = Str_new(30,m-s);
- str_nset(dstr,s,m-s);
- if (!realarray)
- str_2mortal(dstr);
- (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
- {
- dstr = Str_new(31,m-s);
- str_nset(dstr,s,m-s);
- if (!realarray)
- str_2mortal(dstr);
- (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];
- dstr = Str_new(32,m-s);
- str_nset(dstr,s,m-s);
- if (!realarray)
- str_2mortal(dstr);
- (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];
- dstr = Str_new(33,m-s);
- str_nset(dstr,s,m-s);
- if (!realarray)
- str_2mortal(dstr);
- (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? */
- dstr = Str_new(34,strend-s);
- str_nset(dstr,s,strend-s);
- if (!realarray)
- str_2mortal(dstr);
- (void)astore(ary, ++sp, dstr);
- iters++;
- }
- else {
-#ifndef I286x
- 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;
- char *strbeg = s;
- register char *patend = pat + st[sp]->str_cur;
- int datumtype;
- register int len;
- register int bits;
-
- /* These must not be in registers: */
- short ashort;
- int aint;
- long along;
-#ifdef QUAD
- quad aquad;
-#endif
- unsigned short aushort;
- unsigned int auint;
- unsigned long aulong;
-#ifdef QUAD
- unsigned quad auquad;
-#endif
- char *aptr;
- float afloat;
- double adouble;
- int checksum = 0;
- unsigned long culong;
- double cdouble;
-
- if (gimme != G_ARRAY) { /* arrange to do first one only */
- /*SUPPRESS 530*/
- for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
- if (index("aAbBhH", *patend) || *pat == '%') {
- patend++;
- while (isDIGIT(*patend) || *patend == '*')
- patend++;
- }
- else
- patend++;
- }
- sp--;
- while (pat < patend) {
- reparse:
- datumtype = *pat++;
- if (pat >= patend)
- len = 1;
- else if (*pat == '*') {
- len = strend - strbeg; /* long enough */
- pat++;
- }
- else if (isDIGIT(*pat)) {
- len = *pat++ - '0';
- while (isDIGIT(*pat))
- len = (len * 10) + (*pat++ - '0');
- }
- else
- len = (datumtype != '@');
- switch(datumtype) {
- default:
- break;
- case '%':
- if (len == 1 && pat[-1] != '1')
- len = 16;
- checksum = len;
- culong = 0;
- cdouble = 0;
- if (pat < patend)
- goto reparse;
- break;
- case '@':
- if (len > strend - strbeg)
- fatal("@ outside of string");
- s = strbeg + len;
- break;
- case 'X':
- if (len > s - strbeg)
- fatal("X outside of string");
- s -= len;
- break;
- case 'x':
- if (len > strend - s)
- fatal("x outside of string");
- s += len;
- break;
- case 'A':
- case 'a':
- if (len > strend - s)
- len = strend - s;
- if (checksum)
- goto uchar_checksum;
- 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_2mortal(str));
- break;
- case 'B':
- case 'b':
- if (pat[-1] == '*' || len > (strend - s) * 8)
- len = (strend - s) * 8;
- str = Str_new(35, len + 1);
- str->str_cur = len;
- str->str_pok = 1;
- aptr = pat; /* borrow register */
- pat = str->str_ptr;
- if (datumtype == 'b') {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 7) /*SUPPRESS 595*/
- bits >>= 1;
- else
- bits = *s++;
- *pat++ = '0' + (bits & 1);
- }
- }
- else {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 7)
- bits <<= 1;
- else
- bits = *s++;
- *pat++ = '0' + ((bits & 128) != 0);
- }
- }
- *pat = '\0';
- pat = aptr; /* unborrow register */
- (void)astore(stack, ++sp, str_2mortal(str));
- break;
- case 'H':
- case 'h':
- if (pat[-1] == '*' || len > (strend - s) * 2)
- len = (strend - s) * 2;
- str = Str_new(35, len + 1);
- str->str_cur = len;
- str->str_pok = 1;
- aptr = pat; /* borrow register */
- pat = str->str_ptr;
- if (datumtype == 'h') {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 1)
- bits >>= 4;
- else
- bits = *s++;
- *pat++ = hexdigit[bits & 15];
- }
- }
- else {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 1)
- bits <<= 4;
- else
- bits = *s++;
- *pat++ = hexdigit[(bits >> 4) & 15];
- }
- }
- *pat = '\0';
- pat = aptr; /* unborrow register */
- (void)astore(stack, ++sp, str_2mortal(str));
- break;
- case 'c':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- while (len-- > 0) {
- aint = *s++;
- if (aint >= 128) /* fake up signed chars */
- aint -= 256;
- culong += aint;
- }
- }
- else {
- while (len-- > 0) {
- aint = *s++;
- if (aint >= 128) /* fake up signed chars */
- aint -= 256;
- str = Str_new(36,0);
- str_numset(str,(double)aint);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 'C':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- uchar_checksum:
- while (len-- > 0) {
- auint = *s++ & 255;
- culong += auint;
- }
- }
- else {
- while (len-- > 0) {
- auint = *s++ & 255;
- str = Str_new(37,0);
- str_numset(str,(double)auint);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 's':
- along = (strend - s) / sizeof(short);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s,&ashort,1,short);
- s += sizeof(short);
- culong += ashort;
- }
- }
- else {
- while (len-- > 0) {
- Copy(s,&ashort,1,short);
- s += sizeof(short);
- str = Str_new(38,0);
- str_numset(str,(double)ashort);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 'v':
- case 'n':
- case 'S':
- along = (strend - s) / sizeof(unsigned short);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s,&aushort,1,unsigned short);
- s += sizeof(unsigned short);
-#ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = ntohs(aushort);
-#endif
-#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
-#endif
- culong += aushort;
- }
- }
- else {
- while (len-- > 0) {
- Copy(s,&aushort,1,unsigned short);
- s += sizeof(unsigned short);
- str = Str_new(39,0);
-#ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = ntohs(aushort);
-#endif
-#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
-#endif
- str_numset(str,(double)aushort);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 'i':
- along = (strend - s) / sizeof(int);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s,&aint,1,int);
- s += sizeof(int);
- if (checksum > 32)
- cdouble += (double)aint;
- else
- culong += aint;
- }
- }
- else {
- while (len-- > 0) {
- Copy(s,&aint,1,int);
- s += sizeof(int);
- str = Str_new(40,0);
- str_numset(str,(double)aint);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 'I':
- along = (strend - s) / sizeof(unsigned int);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s,&auint,1,unsigned int);
- s += sizeof(unsigned int);
- if (checksum > 32)
- cdouble += (double)auint;
- else
- culong += auint;
- }
- }
- else {
- while (len-- > 0) {
- Copy(s,&auint,1,unsigned int);
- s += sizeof(unsigned int);
- str = Str_new(41,0);
- str_numset(str,(double)auint);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 'l':
- along = (strend - s) / sizeof(long);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s,&along,1,long);
- s += sizeof(long);
- if (checksum > 32)
- cdouble += (double)along;
- else
- culong += along;
- }
- }
- else {
- while (len-- > 0) {
- Copy(s,&along,1,long);
- s += sizeof(long);
- str = Str_new(42,0);
- str_numset(str,(double)along);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 'V':
- case 'N':
- case 'L':
- along = (strend - s) / sizeof(unsigned long);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s,&aulong,1,unsigned long);
- s += sizeof(unsigned long);
-#ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = ntohl(aulong);
-#endif
-#ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
-#endif
- if (checksum > 32)
- cdouble += (double)aulong;
- else
- culong += aulong;
- }
- }
- else {
- while (len-- > 0) {
- Copy(s,&aulong,1,unsigned long);
- s += sizeof(unsigned long);
- str = Str_new(43,0);
-#ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = ntohl(aulong);
-#endif
-#ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
-#endif
- str_numset(str,(double)aulong);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 'p':
- along = (strend - s) / sizeof(char*);
- if (len > along)
- len = along;
- while (len-- > 0) {
- if (sizeof(char*) > strend - s)
- break;
- else {
- Copy(s,&aptr,1,char*);
- s += sizeof(char*);
- }
- str = Str_new(44,0);
- if (aptr)
- str_set(str,aptr);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- break;
-#ifdef QUAD
- case 'q':
- while (len-- > 0) {
- if (s + sizeof(quad) > strend)
- aquad = 0;
- else {
- Copy(s,&aquad,1,quad);
- s += sizeof(quad);
- }
- str = Str_new(42,0);
- str_numset(str,(double)aquad);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- break;
- case 'Q':
- while (len-- > 0) {
- if (s + sizeof(unsigned quad) > strend)
- auquad = 0;
- else {
- Copy(s,&auquad,1,unsigned quad);
- s += sizeof(unsigned quad);
- }
- str = Str_new(43,0);
- str_numset(str,(double)auquad);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- break;
-#endif
- /* float and double added gnb@melba.bby.oz.au 22/11/89 */
- case 'f':
- case 'F':
- along = (strend - s) / sizeof(float);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &afloat,1, float);
- s += sizeof(float);
- cdouble += afloat;
- }
- }
- else {
- while (len-- > 0) {
- Copy(s, &afloat,1, float);
- s += sizeof(float);
- str = Str_new(47, 0);
- str_numset(str, (double)afloat);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 'd':
- case 'D':
- along = (strend - s) / sizeof(double);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &adouble,1, double);
- s += sizeof(double);
- cdouble += adouble;
- }
- }
- else {
- while (len-- > 0) {
- Copy(s, &adouble,1, double);
- s += sizeof(double);
- str = Str_new(48, 0);
- str_numset(str, (double)adouble);
- (void)astore(stack, ++sp, str_2mortal(str));
- }
- }
- break;
- case 'u':
- along = (strend - s) * 3 / 4;
- str = Str_new(42,along);
- while (s < strend && *s > ' ' && *s < 'a') {
- int a,b,c,d;
- char hunk[4];
-
- hunk[3] = '\0';
- len = (*s++ - ' ') & 077;
- while (len > 0) {
- if (s < strend && *s >= ' ')
- a = (*s++ - ' ') & 077;
- else
- a = 0;
- if (s < strend && *s >= ' ')
- b = (*s++ - ' ') & 077;
- else
- b = 0;
- if (s < strend && *s >= ' ')
- c = (*s++ - ' ') & 077;
- else
- c = 0;
- if (s < strend && *s >= ' ')
- d = (*s++ - ' ') & 077;
- else
- d = 0;
- hunk[0] = a << 2 | b >> 4;
- hunk[1] = b << 4 | c >> 2;
- hunk[2] = c << 6 | d;
- str_ncat(str,hunk, len > 3 ? 3 : len);
- len -= 3;
- }
- if (*s == '\n')
- s++;
- else if (s[1] == '\n') /* possible checksum byte */
- s += 2;
- }
- (void)astore(stack, ++sp, str_2mortal(str));
- break;
- }
- if (checksum) {
- str = Str_new(42,0);
- if (index("fFdD", datumtype) ||
- (checksum > 32 && index("iIlLN", datumtype)) ) {
- double modf();
- double trouble;
-
- adouble = 1.0;
- while (checksum >= 16) {
- checksum -= 16;
- adouble *= 65536.0;
- }
- while (checksum >= 4) {
- checksum -= 4;
- adouble *= 16.0;
- }
- while (checksum--)
- adouble *= 2.0;
- along = (1 << checksum) - 1;
- while (cdouble < 0.0)
- cdouble += adouble;
- cdouble = modf(cdouble / adouble, &trouble) * adouble;
- str_numset(str,cdouble);
- }
- else {
- if (checksum < 32) {
- along = (1 << checksum) - 1;
- culong &= (unsigned long)along;
- }
- str_numset(str,(double)culong);
- }
- (void)astore(stack, ++sp, str_2mortal(str));
- checksum = 0;
- }
- }
- return sp;
-}
-
-int
-do_slice(stab,str,numarray,lval,gimme,arglast)
-STAB *stab;
-STR *str;
-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;
- register ARRAY *ary;
- register HASH *hash;
- int oldarybase = arybase;
-
- if (numarray) {
- if (numarray == 2) { /* a slice of a LIST */
- ary = stack;
- ary->ary_fill = arglast[3];
- arybase -= max + 1;
- st[sp] = str; /* make stack size available */
- str_numset(str,(double)(sp - 1));
- }
- else
- ary = stab_array(stab); /* a slice of an array */
- }
- else {
- if (lval) {
- 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 */
- }
- hash = stab_hash(stab); /* a slice of an associative array */
- }
-
- if (gimme == G_ARRAY) {
- if (numarray) {
- while (sp < max) {
- if (st[++sp]) {
- st[sp-1] = afetch(ary,
- ((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(hash,tmps,len, lval);
- if (magic)
- str_magic(st[sp-1],stab,magic,tmps,len);
- }
- else
- st[sp-1] = &str_undef;
- }
- }
- sp--;
- }
- else {
- if (sp == max)
- st[sp] = &str_undef;
- else if (numarray) {
- if (st[max])
- st[sp] = afetch(ary,
- ((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(hash,tmps,len, lval);
- if (magic)
- str_magic(st[sp],stab,magic,tmps,len);
- }
- else
- st[sp] = &str_undef;
- }
- }
- arybase = oldarybase;
- return sp;
-}
-
-int
-do_splice(ary,gimme,arglast)
-register ARRAY *ary;
-int gimme;
-int *arglast;
+OP *
+do_kv(ARGS)
+dARGS
{
- register STR **st = stack->ary_array;
- register int sp = arglast[1];
- int max = arglast[2] + 1;
- register STR **src;
- register STR **dst;
- register int i;
- register int offset;
- register int length;
- int newlen;
- int after;
- int diff;
- STR **tmparyval;
-
- if (++sp < max) {
- offset = (int)str_gnum(st[sp]);
- if (offset < 0)
- offset += ary->ary_fill + 1;
- else
- offset -= arybase;
- if (++sp < max) {
- length = (int)str_gnum(st[sp++]);
- if (length < 0)
- length = 0;
- }
- else
- length = ary->ary_max + 1; /* close enough to infinity */
- }
- else {
- offset = 0;
- length = ary->ary_max + 1;
- }
- if (offset < 0) {
- length += offset;
- offset = 0;
- if (length < 0)
- length = 0;
- }
- if (offset > ary->ary_fill + 1)
- offset = ary->ary_fill + 1;
- after = ary->ary_fill + 1 - (offset + length);
- if (after < 0) { /* not that much array */
- length += after; /* offset+length now in array */
- after = 0;
- if (!ary->ary_alloc) {
- afill(ary,0);
- afill(ary,-1);
- }
- }
-
- /* At this point, sp .. max-1 is our new LIST */
-
- newlen = max - sp;
- diff = newlen - length;
-
- if (diff < 0) { /* shrinking the area */
- if (newlen) {
- New(451, tmparyval, newlen, STR*); /* so remember insertion */
- Copy(st+sp, tmparyval, newlen, STR*);
- }
-
- sp = arglast[0] + 1;
- if (gimme == G_ARRAY) { /* copy return vals to stack */
- if (sp + length >= stack->ary_max) {
- astore(stack,sp + length, Nullstr);
- st = stack->ary_array;
- }
- Copy(ary->ary_array+offset, st+sp, length, STR*);
- if (ary->ary_flags & ARF_REAL) {
- for (i = length, dst = st+sp; i; i--)
- str_2mortal(*dst++); /* free them eventualy */
- }
- sp += length - 1;
- }
- else {
- st[sp] = ary->ary_array[offset+length-1];
- if (ary->ary_flags & ARF_REAL) {
- str_2mortal(st[sp]);
- for (i = length - 1, dst = &ary->ary_array[offset]; i > 0; i--)
- str_free(*dst++); /* free them now */
- }
- }
- ary->ary_fill += diff;
-
- /* pull up or down? */
-
- if (offset < after) { /* easier to pull up */
- if (offset) { /* esp. if nothing to pull */
- src = &ary->ary_array[offset-1];
- dst = src - diff; /* diff is negative */
- for (i = offset; i > 0; i--) /* can't trust Copy */
- *dst-- = *src--;
- }
- Zero(ary->ary_array, -diff, STR*);
- ary->ary_array -= diff; /* diff is negative */
- ary->ary_max += diff;
- }
- else {
- if (after) { /* anything to pull down? */
- src = ary->ary_array + offset + length;
- dst = src + diff; /* diff is negative */
- Move(src, dst, after, STR*);
- }
- Zero(&ary->ary_array[ary->ary_fill+1], -diff, STR*);
- /* avoid later double free */
- }
- if (newlen) {
- for (src = tmparyval, dst = ary->ary_array + offset;
- newlen; newlen--) {
- *dst = Str_new(46,0);
- str_sset(*dst++,*src++);
- }
- Safefree(tmparyval);
- }
- }
- else { /* no, expanding (or same) */
- if (length) {
- New(452, tmparyval, length, STR*); /* so remember deletion */
- Copy(ary->ary_array+offset, tmparyval, length, STR*);
- }
-
- if (diff > 0) { /* expanding */
-
- /* push up or down? */
-
- if (offset < after && diff <= ary->ary_array - ary->ary_alloc) {
- if (offset) {
- src = ary->ary_array;
- dst = src - diff;
- Move(src, dst, offset, STR*);
- }
- ary->ary_array -= diff; /* diff is positive */
- ary->ary_max += diff;
- ary->ary_fill += diff;
- }
- else {
- if (ary->ary_fill + diff >= ary->ary_max) /* oh, well */
- astore(ary, ary->ary_fill + diff, Nullstr);
- else
- ary->ary_fill += diff;
- dst = ary->ary_array + ary->ary_fill;
- for (i = diff; i > 0; i--) {
- if (*dst) /* str was hanging around */
- str_free(*dst); /* after $#foo */
- dst--;
- }
- if (after) {
- dst = ary->ary_array + ary->ary_fill;
- src = dst - diff;
- for (i = after; i; i--) {
- *dst-- = *src--;
- }
- }
- }
- }
-
- for (src = st+sp, dst = ary->ary_array + offset; newlen; newlen--) {
- *dst = Str_new(46,0);
- str_sset(*dst++,*src++);
- }
- sp = arglast[0] + 1;
- if (gimme == G_ARRAY) { /* copy return vals to stack */
- if (length) {
- Copy(tmparyval, st+sp, length, STR*);
- if (ary->ary_flags & ARF_REAL) {
- for (i = length, dst = st+sp; i; i--)
- str_2mortal(*dst++); /* free them eventualy */
- }
- Safefree(tmparyval);
- }
- sp += length - 1;
- }
- else if (length--) {
- st[sp] = tmparyval[length];
- if (ary->ary_flags & ARF_REAL) {
- str_2mortal(st[sp]);
- while (length-- > 0)
- str_free(tmparyval[length]);
- }
- Safefree(tmparyval);
- }
- 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;
- int oldtmps_base = tmps_base;
-
- savesptr(&stab_val(defstab));
- tmps_base = tmps_max;
- 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) {
- if (st[src]) {
- st[src]->str_pok &= ~SP_TEMP;
- stab_val(defstab) = st[src];
- }
- else
- stab_val(defstab) = str_mortal(&str_undef);
- (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);
- tmps_base = oldtmps_base;
- 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(arglast)
-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];
-
- while (i-- > 0) {
- *up++ = *down;
- if (i-- > 0)
- *down-- = *up;
- }
- i = arglast[2] - arglast[1];
- Move(down+1,up,i/2,STR*);
- return arglast[2] - 1;
-}
-
-int
-do_sreverse(str,arglast)
-STR *str;
-int *arglast;
-{
- STR **st = stack->ary_array;
- register char *up;
- register char *down;
- register int tmp;
-
- str_sset(str,st[arglast[2]]);
- up = str_get(str);
- if (str->str_cur > 1) {
- down = str->str_ptr + str->str_cur - 1;
- while (down > up) {
- tmp = *up;
- *up++ = *down;
- *down-- = tmp;
- }
- }
- STABSET(str);
- st[arglast[0]+1] = str;
- return arglast[0]+1;
-}
-
-static CMD *sortcmd;
-static HASH *sortstash = Null(HASH*);
-static STAB *firststab = Nullstab;
-static STAB *secondstab = Nullstab;
-
-int
-do_sort(str,arg,gimme,arglast)
-STR *str;
-ARG *arg;
-int gimme;
-int *arglast;
-{
- register 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;
- HASH *stash;
- STR *sortsubvar;
- static ARRAY *sortstack = Null(ARRAY*);
-
- if (gimme != G_ARRAY) {
- str_sset(str,&str_undef);
- STABSET(str);
- st[sp] = str;
- return sp;
- }
- up = &st[sp];
- sortsubvar = *up;
- st += sp; /* temporarily make st point to args */
- for (i = 1; i <= max; i++) {
- /*SUPPRESS 560*/
- if (*up = st[i]) {
- if (!(*up)->str_pok)
- (void)str_2ptr(*up);
- else
- (*up)->str_pok &= ~SP_TEMP;
- up++;
- }
- }
- st -= sp;
- max = up - &st[sp];
- sp--;
- if (max > 1) {
- STAB *stab;
-
- if (arg[1].arg_type == (A_CMD|A_DONT)) {
- sortcmd = arg[1].arg_ptr.arg_cmd;
- stash = curcmd->c_stash;
- }
- else {
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(sortsubvar),TRUE);
-
- if (stab) {
- if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd))
- fatal("Undefined subroutine \"%s\" in sort",
- stab_ename(stab));
- stash = stab_estash(stab);
- }
- else
- sortcmd = Nullcmd;
- }
-
- if (sortcmd) {
- int oldtmps_base = tmps_base;
-
- if (!sortstack) {
- sortstack = anew(Nullstab);
- astore(sortstack, 0, Nullstr);
- aclear(sortstack);
- sortstack->ary_flags = 0;
- }
- oldstack = stack;
- stack = sortstack;
- tmps_base = tmps_max;
- if (sortstash != stash) {
- firststab = stabent("a",TRUE);
- secondstab = stabent("b",TRUE);
- sortstash = stash;
- }
- 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
- }
- return sp+max;
-}
-
-static int
-sortsub(str1,str2)
-STR **str1;
-STR **str2;
-{
- stab_val(firststab) = *str1;
- stab_val(secondstab) = *str2;
- cmd_exec(sortcmd,G_SCALAR,-1);
- return (int)str_gnum(*stack->ary_array);
-}
-
-static int
-sortcmp(strp1,strp2)
-STR **strp1;
-STR **strp2;
-{
- register STR *str1 = *strp1;
- register STR *str2 = *strp2;
- int retval;
-
- if (str1->str_cur < str2->str_cur) {
- /*SUPPRESS 560*/
- if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
- return retval;
- else
- return -1;
- }
- /*SUPPRESS 560*/
- 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;
- register ARRAY *ary = stack;
- register STR *str;
- int max;
-
- if (gimme != G_ARRAY)
- fatal("panic: do_range");
-
- if (st[sp+1]->str_nok || !st[sp+1]->str_pok ||
- (looks_like_number(st[sp+1]) && *st[sp+1]->str_ptr != '0') ) {
- i = (int)str_gnum(st[sp+1]);
- max = (int)str_gnum(st[sp+2]);
- if (max > i)
- (void)astore(ary, sp + max - i + 1, Nullstr);
- while (i <= max) {
- (void)astore(ary, ++sp, str = str_mortal(&str_no));
- str_numset(str,(double)i++);
- }
- }
- else {
- STR *final = str_mortal(st[sp+2]);
- char *tmps = str_get(final);
-
- str = str_mortal(st[sp+1]);
- while (!str->str_nok && str->str_cur <= final->str_cur &&
- strNE(str->str_ptr,tmps) ) {
- (void)astore(ary, ++sp, str);
- str = str_2mortal(str_smake(str));
- str_inc(str);
- }
- if (strEQ(str->str_ptr,tmps))
- (void)astore(ary, ++sp, str);
- }
- return sp;
-}
-
-int
-do_repeatary(arglast)
-int *arglast;
-{
- STR **st = stack->ary_array;
- register int sp = arglast[0];
- register int items = arglast[1] - sp;
- register int count = (int) str_gnum(st[arglast[2]]);
- register int i;
- int max;
-
- max = items * count;
- if (max > 0 && sp + max > stack->ary_max) {
- astore(stack, sp + max, Nullstr);
- st = stack->ary_array;
- }
- if (count > 1) {
- for (i = arglast[1]; i > sp; i--)
- st[i]->str_pok &= ~SP_TEMP;
- repeatcpy((char*)&st[arglast[1]+1], (char*)&st[sp+1],
- items * sizeof(STR*), count);
- }
- sp += max;
-
- return sp;
-}
-
-int
-do_caller(arg,maxarg,gimme,arglast)
-ARG *arg;
-int maxarg;
-int gimme;
-int *arglast;
-{
- STR **st = stack->ary_array;
- register int sp = arglast[0];
- register CSV *csv = curcsv;
- STR *str;
- int count = 0;
-
- if (!csv)
- fatal("There is no caller");
- if (maxarg)
- count = (int) str_gnum(st[sp+1]);
- for (;;) {
- if (!csv)
- return sp;
- if (DBsub && csv->curcsv && csv->curcsv->sub == stab_sub(DBsub))
- count++;
- if (!count--)
- break;
- csv = csv->curcsv;
- }
- if (gimme != G_ARRAY) {
- STR *str = arg->arg_ptr.arg_str;
- str_set(str,csv->curcmd->c_stash->tbl_name);
- STABSET(str);
- st[++sp] = str;
- return sp;
- }
-
-#ifndef lint
- (void)astore(stack,++sp,
- str_2mortal(str_make(csv->curcmd->c_stash->tbl_name,0)) );
- (void)astore(stack,++sp,
- str_2mortal(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) );
- (void)astore(stack,++sp,
- str_2mortal(str_nmake((double)csv->curcmd->c_line)) );
- if (!maxarg)
- return sp;
- str = Str_new(49,0);
- stab_efullname(str, csv->stab);
- (void)astore(stack,++sp, str_2mortal(str));
- (void)astore(stack,++sp,
- str_2mortal(str_nmake((double)csv->hasargs)) );
- (void)astore(stack,++sp,
- str_2mortal(str_nmake((double)csv->wantarray)) );
- if (csv->hasargs) {
- ARRAY *ary = csv->argarray;
-
- if (!dbargs)
- dbargs = stab_xarray(aadd(stabent("DB'args", TRUE)));
- if (dbargs->ary_max < ary->ary_fill)
- astore(dbargs,ary->ary_fill,Nullstr);
- Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
- dbargs->ary_fill = ary->ary_fill;
- }
-#else
- (void)astore(stack,++sp,
- str_2mortal(str_make("",0)));
-#endif
- return sp;
-}
-
-int
-do_tms(str,gimme,arglast)
-STR *str;
-int gimme;
-int *arglast;
-{
-#ifdef MSDOS
- return -1;
-#else
- 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_2mortal(str_nmake(((double)timesbuf.tms_utime)/HZ)));
- (void)astore(stack,++sp,
- str_2mortal(str_nmake(((double)timesbuf.tms_stime)/HZ)));
- (void)astore(stack,++sp,
- str_2mortal(str_nmake(((double)timesbuf.tms_cutime)/HZ)));
- (void)astore(stack,++sp,
- str_2mortal(str_nmake(((double)timesbuf.tms_cstime)/HZ)));
-#else
- (void)astore(stack,++sp,
- str_2mortal(str_nmake(0.0)));
-#endif
- return sp;
-#endif
-}
-
-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_2mortal(str_nmake((double)tmbuf->tm_sec)));
- (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_min)));
- (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_hour)));
- (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mday)));
- (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mon)));
- (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_year)));
- (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_wday)));
- (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_yday)));
- (void)astore(ary,++sp,str_2mortal(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;
+ dSP;
+ HV *hash = (HV*)POPs;
+ register AV *ary = stack;
+ I32 i;
+ register HE *entry;
char *tmps;
- STR *tmpstr;
- int dokeys = (kv == O_KEYS || kv == O_HASH);
- int dovalues = (kv == O_VALUES || kv == O_HASH);
+ SV *tmpstr;
+ I32 dokeys = (op->op_type == OP_KEYS || op->op_type == OP_RV2HV);
+ I32 dovalues = (op->op_type == OP_VALUES || op->op_type == OP_RV2HV);
+
+ if (!hash)
+ RETURN;
+ if (GIMME != G_ARRAY) {
+ dTARGET;
- if (gimme != G_ARRAY) {
i = 0;
- (void)hiterinit(hash);
+ (void)hv_iterinit(hash);
/*SUPPRESS 560*/
- while (entry = hiternext(hash)) {
+ while (entry = hv_iternext(hash)) {
i++;
}
- str_numset(str,(double)i);
- STABSET(str);
- st[++sp] = str;
- return sp;
+ PUSHn( (double)i );
+ RETURN;
}
- (void)hiterinit(hash);
+ /* Guess how much room we need. hv_max may be a few too many. Oh well. */
+ EXTEND(sp, HvMAX(hash) * (dokeys + dovalues));
+ (void)hv_iterinit(hash);
/*SUPPRESS 560*/
- while (entry = hiternext(hash)) {
+ while (entry = hv_iternext(hash)) {
if (dokeys) {
- tmps = hiterkey(entry,&i);
+ tmps = hv_iterkey(entry,&i);
if (!i)
tmps = "";
- (void)astore(ary,++sp,str_2mortal(str_make(tmps,i)));
+ XPUSHs(sv_2mortal(newSVpv(tmps,i)));
}
if (dovalues) {
- tmpstr = Str_new(45,0);
-#ifdef DEBUGGING
- if (debug & 8192) {
+ tmpstr = NEWSV(45,0);
+ sv_setsv(tmpstr,hv_iterval(hash,entry));
+ DEBUG_H( {
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_2mortal(tmpstr));
+ HvMAX(hash)+1,entry->hent_hash & HvMAX(hash));
+ sv_setpv(tmpstr,buf);
+ } )
+ XPUSHs(sv_2mortal(tmpstr));
}
}
- return sp;
+ RETURN;
}
-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);
- if (!i)
- tmps = "";
- st[++sp] = mystrk = str_make(tmps,i);
- }
- st[++sp] = str;
- str_sset(str,hiterval(hash,entry));
- STABSET(str);
- return sp;
- }
- else
- return sp;
-}
--- /dev/null
+/* $RCSfile: doarg.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:37 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: doarg.c,v $
+ * Revision 4.1 92/08/07 17:19:37 lwall
+ * Stage 6 Snapshot
+ *
+ * Revision 4.0.1.7 92/06/11 21:07:11 lwall
+ * patch34: join with null list attempted negative allocation
+ * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd "
+ *
+ * Revision 4.0.1.6 92/06/08 12:34:30 lwall
+ * patch20: removed implicit int declarations on funcions
+ * patch20: pattern modifiers i and o didn't interact right
+ * patch20: join() now pre-extends target string to avoid excessive copying
+ * patch20: fixed confusion between a *var's real name and its effective name
+ * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly
+ * patch20: usersub routines didn't reclaim temp values soon enough
+ * patch20: ($<,$>) = ... didn't work on some architectures
+ * patch20: added Atari ST portability
+ *
+ * Revision 4.0.1.5 91/11/11 16:31:58 lwall
+ * patch19: added little-endian pack/unpack options
+ *
+ * Revision 4.0.1.4 91/11/05 16:35:06 lwall
+ * patch11: /$foo/o optimizer could access deallocated data
+ * patch11: minimum match length calculation in regexp is now cumulative
+ * patch11: added some support for 64-bit integers
+ * patch11: prepared for ctype implementations that don't define isascii()
+ * patch11: sprintf() now supports any length of s field
+ * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work
+ * patch11: defined(&$foo) and undef(&$foo) didn't work
+ *
+ * Revision 4.0.1.3 91/06/10 01:18:41 lwall
+ * patch10: pack(hh,1) dumped core
+ *
+ * Revision 4.0.1.2 91/06/07 10:42:17 lwall
+ * patch4: new copyright notice
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * patch4: //o and s///o now optimize themselves fully at runtime
+ * patch4: added global modifier for pattern matches
+ * patch4: undef @array disabled "@array" interpolation
+ * patch4: chop("") was returning "\0" rather than ""
+ * patch4: vector logical operations &, | and ^ sometimes returned null string
+ * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
+ *
+ * Revision 4.0.1.1 91/04/11 17:40:14 lwall
+ * patch1: fixed undefined environ problem
+ * patch1: fixed debugger coredump on subroutines
+ *
+ * Revision 4.0 91/03/20 01:06:42 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+#include <signal.h>
+#endif
+
+#ifdef BUGGY_MSC
+ #pragma function(memcmp)
+#endif /* BUGGY_MSC */
+
+static void doencodes();
+
+#ifdef BUGGY_MSC
+ #pragma intrinsic(memcmp)
+#endif /* BUGGY_MSC */
+
+I32
+do_trans(sv,arg)
+SV *sv;
+OP *arg;
+{
+ register short *tbl;
+ register char *s;
+ register I32 matches = 0;
+ register I32 ch;
+ register char *send;
+ register char *d;
+ register I32 squash = op->op_private & OPpTRANS_SQUASH;
+
+ tbl = (short*) cPVOP->op_pv;
+ s = SvPVn(sv);
+ send = s + SvCUR(sv);
+ if (!tbl || !s)
+ fatal("panic: do_trans");
+ DEBUG_t( deb("2.TBL\n"));
+ if (!op->op_private) {
+ while (s < send) {
+ if ((ch = tbl[*s & 0377]) >= 0) {
+ matches++;
+ *s = ch;
+ }
+ s++;
+ }
+ }
+ else {
+ d = s;
+ while (s < send) {
+ if ((ch = tbl[*s & 0377]) >= 0) {
+ *d = ch;
+ if (matches++ && squash) {
+ if (d[-1] == *d)
+ matches--;
+ else
+ d++;
+ }
+ else
+ d++;
+ }
+ else if (ch == -1) /* -1 is unmapped character */
+ *d++ = *s; /* -2 is delete character */
+ s++;
+ }
+ matches += send - d; /* account for disappeared chars */
+ *d = '\0';
+ SvCUR_set(sv, d - SvPV(sv));
+ }
+ SvSETMAGIC(sv);
+ return matches;
+}
+
+void
+do_join(sv,del,mark,sp)
+register SV *sv;
+SV *del;
+register SV **mark;
+register SV **sp;
+{
+ SV **oldmark = mark;
+ register I32 items = sp - mark;
+ register char *delim = SvPVn(del);
+ register STRLEN len;
+ I32 delimlen = SvCUR(del);
+
+ mark++;
+ len = (items > 0 ? (delimlen * (items - 1) ) : 0);
+ if (SvTYPE(sv) < SVt_PV)
+ sv_upgrade(sv, SVt_PV);
+ if (SvLEN(sv) < len + items) { /* current length is way too short */
+ while (items-- > 0) {
+ if (*mark) {
+ if (!SvPOK(*mark)) {
+ sv_2pv(*mark);
+ if (!SvPOK(*mark))
+ *mark = &sv_no;
+ }
+ len += SvCUR((*mark));
+ }
+ mark++;
+ }
+ SvGROW(sv, len + 1); /* so try to pre-extend */
+
+ mark = oldmark;
+ items = sp - mark;;
+ ++mark;
+ }
+
+ if (items-- > 0)
+ sv_setsv(sv, *mark++);
+ else
+ sv_setpv(sv,"");
+ len = delimlen;
+ if (len) {
+ for (; items > 0; items--,mark++) {
+ sv_catpvn(sv,delim,len);
+ sv_catsv(sv,*mark);
+ }
+ }
+ else {
+ for (; items > 0; items--,mark++)
+ sv_catsv(sv,*mark);
+ }
+ SvSETMAGIC(sv);
+}
+
+void
+do_sprintf(sv,len,sarg)
+register SV *sv;
+register I32 len;
+register SV **sarg;
+{
+ register char *s;
+ register char *t;
+ register char *f;
+ bool dolong;
+#ifdef QUAD
+ bool doquad;
+#endif /* QUAD */
+ char ch;
+ register char *send;
+ register SV *arg;
+ char *xs;
+ I32 xlen;
+ I32 pre;
+ I32 post;
+ double value;
+
+ sv_setpv(sv,"");
+ len--; /* don't count pattern string */
+ t = s = SvPVn(*sarg);
+ send = s + SvCUR(*sarg);
+ sarg++;
+ for ( ; ; len--) {
+
+ /*SUPPRESS 560*/
+ if (len <= 0 || !(arg = *sarg++))
+ arg = &sv_no;
+
+ /*SUPPRESS 530*/
+ for ( ; t < send && *t != '%'; t++) ;
+ if (t >= send)
+ break; /* end of run_format string, ignore extra args */
+ f = t;
+ *buf = '\0';
+ xs = buf;
+#ifdef QUAD
+ doquad =
+#endif /* QUAD */
+ dolong = FALSE;
+ pre = post = 0;
+ for (t++; t < send; t++) {
+ switch (*t) {
+ default:
+ ch = *(++t);
+ *t = '\0';
+ (void)sprintf(xs,f);
+ len++, sarg--;
+ xlen = strlen(xs);
+ 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 '+': case ' ':
+ continue;
+ case 'lXXX':
+#ifdef QUAD
+ if (dolong) {
+ dolong = FALSE;
+ doquad = TRUE;
+ } else
+#endif
+ dolong = TRUE;
+ continue;
+ case 'c':
+ ch = *(++t);
+ *t = '\0';
+ xlen = SvIVn(arg);
+ if (strEQ(f,"%c")) { /* some printfs fail on null chars */
+ *xs = xlen;
+ xs[1] = '\0';
+ xlen = 1;
+ }
+ else {
+ (void)sprintf(xs,f,xlen);
+ xlen = strlen(xs);
+ }
+ break;
+ case 'D':
+ dolong = TRUE;
+ /* FALL THROUGH */
+ case 'd':
+ ch = *(++t);
+ *t = '\0';
+#ifdef QUAD
+ if (doquad)
+ (void)sprintf(buf,s,(quad)SvNVn(arg));
+ else
+#endif
+ if (dolong)
+ (void)sprintf(xs,f,(long)SvNVn(arg));
+ else
+ (void)sprintf(xs,f,SvIVn(arg));
+ xlen = strlen(xs);
+ break;
+ case 'X': case 'O':
+ dolong = TRUE;
+ /* FALL THROUGH */
+ case 'x': case 'o': case 'u':
+ ch = *(++t);
+ *t = '\0';
+ value = SvNVn(arg);
+#ifdef QUAD
+ if (doquad)
+ (void)sprintf(buf,s,(unsigned quad)value);
+ else
+#endif
+ if (dolong)
+ (void)sprintf(xs,f,U_L(value));
+ else
+ (void)sprintf(xs,f,U_I(value));
+ xlen = strlen(xs);
+ break;
+ case 'E': case 'e': case 'f': case 'G': case 'g':
+ ch = *(++t);
+ *t = '\0';
+ (void)sprintf(xs,f,SvNVn(arg));
+ xlen = strlen(xs);
+ break;
+ case 's':
+ ch = *(++t);
+ *t = '\0';
+ xs = SvPVn(arg);
+ if (SvPOK(arg))
+ xlen = SvCUR(arg);
+ else
+ xlen = strlen(xs);
+ if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
+ break; /* so handle simple cases */
+ }
+ else if (f[1] == '-') {
+ char *mp = index(f, '.');
+ I32 min = atoi(f+2);
+
+ if (mp) {
+ I32 max = atoi(mp+1);
+
+ if (xlen > max)
+ xlen = max;
+ }
+ if (xlen < min)
+ post = min - xlen;
+ break;
+ }
+ else if (isDIGIT(f[1])) {
+ char *mp = index(f, '.');
+ I32 min = atoi(f+1);
+
+ if (mp) {
+ I32 max = atoi(mp+1);
+
+ if (xlen > max)
+ xlen = max;
+ }
+ if (xlen < min)
+ pre = min - xlen;
+ break;
+ }
+ strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
+ *t = ch;
+ (void)sprintf(buf,tokenbuf+64,xs);
+ xs = buf;
+ xlen = strlen(xs);
+ break;
+ }
+ /* end of switch, copy results */
+ *t = ch;
+ SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
+ sv_catpvn(sv, s, f - s);
+ if (pre) {
+ repeatcpy(SvPV(sv) + SvCUR(sv), " ", 1, pre);
+ SvCUR(sv) += pre;
+ }
+ sv_catpvn(sv, xs, xlen);
+ if (post) {
+ repeatcpy(SvPV(sv) + SvCUR(sv), " ", 1, post);
+ SvCUR(sv) += post;
+ }
+ s = t;
+ break; /* break from for loop */
+ }
+ }
+ sv_catpvn(sv, s, t - s);
+ SvSETMAGIC(sv);
+}
+
+void
+do_vecset(sv)
+SV *sv;
+{
+ SV *targ = LvTARG(sv);
+ register I32 offset;
+ register I32 size;
+ register unsigned char *s = (unsigned char*)SvPV(targ);
+ register unsigned long lval = U_L(SvNVn(sv));
+ I32 mask;
+
+ offset = LvTARGOFF(sv);
+ size = LvTARGLEN(sv);
+ 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;
+ }
+ }
+}
+
+void
+do_chop(astr,sv)
+register SV *astr;
+register SV *sv;
+{
+ register char *tmps;
+ register I32 i;
+ AV *ary;
+ HV *hash;
+ HE *entry;
+
+ if (!sv)
+ return;
+ if (SvTYPE(sv) == SVt_PVAV) {
+ I32 max;
+ SV **array = AvARRAY(sv);
+ max = AvFILL(sv);
+ for (i = 0; i <= max; i++)
+ do_chop(astr,array[i]);
+ return;
+ }
+ if (SvTYPE(sv) == SVt_PVHV) {
+ hash = (HV*)sv;
+ (void)hv_iterinit(hash);
+ /*SUPPRESS 560*/
+ while (entry = hv_iternext(hash))
+ do_chop(astr,hv_iterval(hash,entry));
+ return;
+ }
+ tmps = SvPVn(sv);
+ if (tmps && SvCUR(sv)) {
+ tmps += SvCUR(sv) - 1;
+ sv_setpvn(astr,tmps,1); /* remember last char */
+ *tmps = '\0'; /* wipe it out */
+ SvCUR_set(sv, tmps - SvPV(sv));
+ SvNOK_off(sv);
+ SvSETMAGIC(sv);
+ }
+ else
+ sv_setpvn(astr,"",0);
+}
+
+void
+do_vop(optype,sv,left,right)
+I32 optype;
+SV *sv;
+SV *left;
+SV *right;
+{
+#ifdef LIBERAL
+ register long *dl;
+ register long *ll;
+ register long *rl;
+#endif
+ register char *dc;
+ register char *lc = SvPVn(left);
+ register char *rc = SvPVn(right);
+ register I32 len;
+
+ len = SvCUR(left);
+ if (len > SvCUR(right))
+ len = SvCUR(right);
+ if (SvTYPE(sv) < SVt_PV)
+ sv_upgrade(sv, SVt_PV);
+ if (SvCUR(sv) > len)
+ SvCUR_set(sv, len);
+ else if (SvCUR(sv) < len) {
+ SvGROW(sv,len);
+ (void)memzero(SvPV(sv) + SvCUR(sv), len - SvCUR(sv));
+ SvCUR_set(sv, len);
+ }
+ SvPOK_only(sv);
+ dc = SvPV(sv);
+ if (!dc) {
+ sv_setpvn(sv,"",0);
+ dc = SvPV(sv);
+ }
+#ifdef LIBERAL
+ if (len >= sizeof(long)*4 &&
+ !((long)dc % sizeof(long)) &&
+ !((long)lc % sizeof(long)) &&
+ !((long)rc % sizeof(long))) /* It's almost always aligned... */
+ {
+ I32 remainder = len % (sizeof(long)*4);
+ len /= (sizeof(long)*4);
+
+ dl = (long*)dc;
+ ll = (long*)lc;
+ rl = (long*)rc;
+
+ switch (optype) {
+ case OP_BIT_AND:
+ while (len--) {
+ *dl++ = *ll++ & *rl++;
+ *dl++ = *ll++ & *rl++;
+ *dl++ = *ll++ & *rl++;
+ *dl++ = *ll++ & *rl++;
+ }
+ break;
+ case OP_XOR:
+ while (len--) {
+ *dl++ = *ll++ ^ *rl++;
+ *dl++ = *ll++ ^ *rl++;
+ *dl++ = *ll++ ^ *rl++;
+ *dl++ = *ll++ ^ *rl++;
+ }
+ break;
+ case OP_BIT_OR:
+ while (len--) {
+ *dl++ = *ll++ | *rl++;
+ *dl++ = *ll++ | *rl++;
+ *dl++ = *ll++ | *rl++;
+ *dl++ = *ll++ | *rl++;
+ }
+ }
+
+ dc = (char*)dl;
+ lc = (char*)ll;
+ rc = (char*)rl;
+
+ len = remainder;
+ }
+#endif
+ switch (optype) {
+ case OP_BIT_AND:
+ while (len--)
+ *dc++ = *lc++ & *rc++;
+ break;
+ case OP_XOR:
+ while (len--)
+ *dc++ = *lc++ ^ *rc++;
+ goto mop_up;
+ case OP_BIT_OR:
+ while (len--)
+ *dc++ = *lc++ | *rc++;
+ mop_up:
+ len = SvCUR(sv);
+ if (SvCUR(right) > len)
+ sv_catpvn(sv,SvPV(right)+len,SvCUR(right) - len);
+ else if (SvCUR(left) > len)
+ sv_catpvn(sv,SvPV(left)+len,SvCUR(left) - len);
+ break;
+ }
+}
--- /dev/null
+/* $RCSfile: doarg.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:37 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: doarg.c,v $
+ * Revision 4.1 92/08/07 17:19:37 lwall
+ * Stage 6 Snapshot
+ *
+ * Revision 4.0.1.7 92/06/11 21:07:11 lwall
+ * patch34: join with null list attempted negative allocation
+ * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd "
+ *
+ * Revision 4.0.1.6 92/06/08 12:34:30 lwall
+ * patch20: removed implicit int declarations on funcions
+ * patch20: pattern modifiers i and o didn't interact right
+ * patch20: join() now pre-extends target string to avoid excessive copying
+ * patch20: fixed confusion between a *var's real name and its effective name
+ * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly
+ * patch20: usersub routines didn't reclaim temp values soon enough
+ * patch20: ($<,$>) = ... didn't work on some architectures
+ * patch20: added Atari ST portability
+ *
+ * Revision 4.0.1.5 91/11/11 16:31:58 lwall
+ * patch19: added little-endian pack/unpack options
+ *
+ * Revision 4.0.1.4 91/11/05 16:35:06 lwall
+ * patch11: /$foo/o optimizer could access deallocated data
+ * patch11: minimum match length calculation in regexp is now cumulative
+ * patch11: added some support for 64-bit integers
+ * patch11: prepared for ctype implementations that don't define isascii()
+ * patch11: sprintf() now supports any length of s field
+ * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work
+ * patch11: defined(&$foo) and undef(&$foo) didn't work
+ *
+ * Revision 4.0.1.3 91/06/10 01:18:41 lwall
+ * patch10: pack(hh,1) dumped core
+ *
+ * Revision 4.0.1.2 91/06/07 10:42:17 lwall
+ * patch4: new copyright notice
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * patch4: //o and s///o now optimize themselves fully at runtime
+ * patch4: added global modifier for pattern matches
+ * patch4: undef @array disabled "@array" interpolation
+ * patch4: chop("") was returning "\0" rather than ""
+ * patch4: vector logical operations &, | and ^ sometimes returned null string
+ * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
+ *
+ * Revision 4.0.1.1 91/04/11 17:40:14 lwall
+ * patch1: fixed undefined environ problem
+ * patch1: fixed debugger coredump on subroutines
+ *
+ * Revision 4.0 91/03/20 01:06:42 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+#include <signal.h>
+#endif
+
+#ifdef BUGGY_MSC
+ #pragma function(memcmp)
+#endif /* BUGGY_MSC */
+
+static void doencodes();
+
+#ifdef BUGGY_MSC
+ #pragma intrinsic(memcmp)
+#endif /* BUGGY_MSC */
+
+int
+do_trans(sv,arg)
+SV *sv;
+OP *arg;
+{
+ register short *tbl;
+ register char *s;
+ register int matches = 0;
+ register int ch;
+ register char *send;
+ register char *d;
+ register int squash = op->op_private & OPpTRANS_SQUASH;
+
+ tbl = (short*) cPVOP->op_pv;
+ s = SvPV(sv);
+ send = s + sv->sv_cur;
+ if (!tbl || !s)
+ fatal("panic: do_trans");
+#ifdef DEBUGGING
+ if (debug & 8) {
+ deb("2.TBL\n");
+ }
+#endif
+ if (!op->op_private) {
+ while (s < send) {
+ if ((ch = tbl[*s & 0377]) >= 0) {
+ matches++;
+ *s = ch;
+ }
+ s++;
+ }
+ }
+ else {
+ d = s;
+ while (s < send) {
+ if ((ch = tbl[*s & 0377]) >= 0) {
+ *d = ch;
+ if (matches++ && squash) {
+ if (d[-1] == *d)
+ matches--;
+ else
+ d++;
+ }
+ else
+ d++;
+ }
+ else if (ch == -1) /* -1 is unmapped character */
+ *d++ = *s; /* -2 is delete character */
+ s++;
+ }
+ matches += send - d; /* account for disappeared chars */
+ *d = '\0';
+ sv->sv_cur = d - sv->sv_ptr;
+ }
+ SvSETMAGIC(sv);
+ return matches;
+}
+
+void
+do_join(sv,del,mark,sp)
+register SV *sv;
+SV *del;
+register SV **mark;
+register SV **sp;
+{
+ SV **oldmark = mark;
+ register int items = sp - mark;
+ register char *delim = SvPV(del);
+ register STRLEN len;
+ int delimlen = del->sv_cur;
+
+ mark++;
+ len = (items > 0 ? (delimlen * (items - 1) ) : 0);
+ if (sv->sv_len < len + items) { /* current length is way too short */
+ while (items-- > 0) {
+ if (*mark)
+ len += (*mark)->sv_cur;
+ mark++;
+ }
+ SvGROW(sv, len + 1); /* so try to pre-extend */
+
+ mark = oldmark;
+ items = sp - mark;;
+ ++mark;
+ }
+
+ if (items-- > 0)
+ sv_setsv(sv, *mark++);
+ else
+ sv_setpv(sv,"");
+ len = delimlen;
+ if (len) {
+ for (; items > 0; items--,mark++) {
+ sv_catpvn(sv,delim,len);
+ sv_catsv(sv,*mark);
+ }
+ }
+ else {
+ for (; items > 0; items--,mark++)
+ sv_catsv(sv,*mark);
+ }
+ SvSETMAGIC(sv);
+}
+
+void
+do_sprintf(sv,numargs,firstarg)
+register SV *sv;
+int numargs;
+SV **firstarg;
+{
+ register char *s;
+ register char *t;
+ register char *f;
+ register int argix = 0;
+ register SV **sarg = firstarg;
+ bool dolong;
+#ifdef QUAD
+ bool doquad;
+#endif /* QUAD */
+ char ch;
+ register char *send;
+ register SV *arg;
+ char *xs;
+ int xlen;
+ int pre;
+ int post;
+ double value;
+
+ sv_setpv(sv,"");
+ len--; /* don't count pattern string */
+ t = s = SvPV(*sarg);
+ send = s + (*sarg)->sv_cur;
+ sarg++;
+ for ( ; ; argix++) {
+
+ /*SUPPRESS 530*/
+ for ( ; t < send && *t != '%'; t++) ;
+ if (t >= send)
+ break; /* end of run_format string, ignore extra args */
+ f = t;
+ if (t[2] == '$' && isDIGIT(t[1])) {
+ ch = *(++t);
+ *t = '\0';
+ (void)sprintf(xs,t);
+ sv_catpvn(sv, xs, xlen);
+ argix = atoi(t+1);
+ sarg = firstarg + argix;
+ t[2] = '%';
+ f += 2;
+
+ }
+ /*SUPPRESS 560*/
+ if (argix > numargs || !(arg = *sarg++))
+ arg = &sv_no;
+
+ *buf = '\0';
+ xs = buf;
+#ifdef QUAD
+ doquad =
+#endif /* QUAD */
+ dolong = FALSE;
+ pre = post = 0;
+ for (t++; t < send; t++) {
+ switch (*t) {
+ default:
+ ch = *(++t);
+ *t = '\0';
+ (void)sprintf(xs,f);
+ argix--, sarg--;
+ xlen = strlen(xs);
+ 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 '+': case ' ':
+ continue;
+ case 'l':
+#ifdef QUAD
+ if (dolong) {
+ dolong = FALSE;
+ doquad = TRUE;
+ } else
+#endif
+ dolong = TRUE;
+ continue;
+ case 'c':
+ ch = *(++t);
+ *t = '\0';
+ xlen = (int)SvNV(arg);
+ if (strEQ(f,"%c")) { /* some printfs fail on null chars */
+ *xs = xlen;
+ xs[1] = '\0';
+ xlen = 1;
+ }
+ else {
+ (void)sprintf(xs,f,xlen);
+ xlen = strlen(xs);
+ }
+ break;
+ case 'D':
+ dolong = TRUE;
+ /* FALL THROUGH */
+ case 'd':
+ ch = *(++t);
+ *t = '\0';
+#ifdef QUAD
+ if (doquad)
+ (void)sprintf(buf,s,(quad)SvNV(arg));
+ else
+#endif
+ if (dolong)
+ (void)sprintf(xs,f,(long)SvNV(arg));
+ else
+ (void)sprintf(xs,f,(int)SvNV(arg));
+ xlen = strlen(xs);
+ break;
+ case 'X': case 'O':
+ dolong = TRUE;
+ /* FALL THROUGH */
+ case 'x': case 'o': case 'u':
+ ch = *(++t);
+ *t = '\0';
+ value = SvNV(arg);
+#ifdef QUAD
+ if (doquad)
+ (void)sprintf(buf,s,(unsigned quad)value);
+ else
+#endif
+ if (dolong)
+ (void)sprintf(xs,f,U_L(value));
+ else
+ (void)sprintf(xs,f,U_I(value));
+ xlen = strlen(xs);
+ break;
+ case 'E': case 'e': case 'f': case 'G': case 'g':
+ ch = *(++t);
+ *t = '\0';
+ (void)sprintf(xs,f,SvNV(arg));
+ xlen = strlen(xs);
+ break;
+ case 's':
+ ch = *(++t);
+ *t = '\0';
+ xs = SvPV(arg);
+ xlen = arg->sv_cur;
+ if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xs[3] == '\0'
+ && xlen == sizeof(GP)) {
+ SV *tmpstr = NEWSV(24,0);
+
+ gv_efullname(tmpstr, ((GV*)arg)); /* a gv value! */
+ sprintf(tokenbuf,"*%s",tmpstr->sv_ptr);
+ /* reformat to non-binary */
+ xs = tokenbuf;
+ xlen = strlen(tokenbuf);
+ sv_free(tmpstr);
+ }
+ if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
+ break; /* so handle simple cases */
+ }
+ else if (f[1] == '-') {
+ char *mp = index(f, '.');
+ int min = atoi(f+2);
+
+ if (mp) {
+ int max = atoi(mp+1);
+
+ if (xlen > max)
+ xlen = max;
+ }
+ if (xlen < min)
+ post = min - xlen;
+ break;
+ }
+ else if (isDIGIT(f[1])) {
+ char *mp = index(f, '.');
+ int min = atoi(f+1);
+
+ if (mp) {
+ int max = atoi(mp+1);
+
+ if (xlen > max)
+ xlen = max;
+ }
+ if (xlen < min)
+ pre = min - xlen;
+ break;
+ }
+ strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
+ *t = ch;
+ (void)sprintf(buf,tokenbuf+64,xs);
+ xs = buf;
+ xlen = strlen(xs);
+ break;
+ }
+ /* end of switch, copy results */
+ *t = ch;
+ SvGROW(sv, sv->sv_cur + (f - s) + xlen + 1 + pre + post);
+ sv_catpvn(sv, s, f - s);
+ if (pre) {
+ repeatcpy(sv->sv_ptr + sv->sv_cur, " ", 1, pre);
+ sv->sv_cur += pre;
+ }
+ sv_catpvn(sv, xs, xlen);
+ if (post) {
+ repeatcpy(sv->sv_ptr + sv->sv_cur, " ", 1, post);
+ sv->sv_cur += post;
+ }
+ s = t;
+ break; /* break from for loop */
+ }
+ }
+ sv_catpvn(sv, s, t - s);
+ SvSETMAGIC(sv);
+}
+
+void
+do_vecset(mstr,sv)
+SV *mstr;
+SV *sv;
+{
+ struct lstring *lstr = (struct lstring*)sv;
+ register int offset;
+ register int size;
+ register unsigned char *s = (unsigned char*)mstr->sv_ptr;
+ register unsigned long lval = U_L(SvNV(sv));
+ int mask;
+
+ mstr->sv_rare = 0;
+ sv->sv_magic = Nullsv;
+ 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;
+ }
+ }
+}
+
+void
+do_chop(astr,sv)
+register SV *astr;
+register SV *sv;
+{
+ register char *tmps;
+ register int i;
+ AV *ary;
+ HV *hash;
+ HE *entry;
+
+ if (!sv)
+ return;
+ if (sv->sv_state == SVs_AV) {
+ ary = (AV*)sv;
+ for (i = 0; i <= ary->av_fill; i++)
+ do_chop(astr,ary->av_array[i]);
+ return;
+ }
+ if (sv->sv_state == SVs_HV) {
+ hash = (HV*)sv;
+ (void)hv_iterinit(hash);
+ /*SUPPRESS 560*/
+ while (entry = hv_iternext(hash))
+ do_chop(astr,hv_iterval(hash,entry));
+ return;
+ }
+ tmps = SvPV(sv);
+ if (tmps && sv->sv_cur) {
+ tmps += sv->sv_cur - 1;
+ sv_setpvn(astr,tmps,1); /* remember last char */
+ *tmps = '\0'; /* wipe it out */
+ sv->sv_cur = tmps - sv->sv_ptr;
+ sv->sv_nok = 0;
+ SvSETMAGIC(sv);
+ }
+ else
+ sv_setpvn(astr,"",0);
+}
+
+void
+do_vop(optype,sv,left,right)
+int optype;
+SV *sv;
+SV *left;
+SV *right;
+{
+#ifdef LIBERAL
+ register long *dl;
+ register long *ll;
+ register long *rl;
+#endif
+ register char *dc;
+ register char *lc = SvPV(left);
+ register char *rc = SvPV(right);
+ register int len;
+
+ len = left->sv_cur;
+ if (len > right->sv_cur)
+ len = right->sv_cur;
+ if (sv->sv_cur > len)
+ sv->sv_cur = len;
+ else if (sv->sv_cur < len) {
+ SvGROW(sv,len);
+ (void)memzero(sv->sv_ptr + sv->sv_cur, len - sv->sv_cur);
+ sv->sv_cur = len;
+ }
+ sv->sv_pok = 1;
+ sv->sv_nok = 0;
+ dc = sv->sv_ptr;
+ if (!dc) {
+ sv_setpvn(sv,"",0);
+ dc = sv->sv_ptr;
+ }
+#ifdef LIBERAL
+ if (len >= sizeof(long)*4 &&
+ !((long)dc % sizeof(long)) &&
+ !((long)lc % sizeof(long)) &&
+ !((long)rc % sizeof(long))) /* It's almost always aligned... */
+ {
+ int remainder = len % (sizeof(long)*4);
+ len /= (sizeof(long)*4);
+
+ dl = (long*)dc;
+ ll = (long*)lc;
+ rl = (long*)rc;
+
+ switch (optype) {
+ case OP_BIT_AND:
+ while (len--) {
+ *dl++ = *ll++ & *rl++;
+ *dl++ = *ll++ & *rl++;
+ *dl++ = *ll++ & *rl++;
+ *dl++ = *ll++ & *rl++;
+ }
+ break;
+ case OP_XOR:
+ while (len--) {
+ *dl++ = *ll++ ^ *rl++;
+ *dl++ = *ll++ ^ *rl++;
+ *dl++ = *ll++ ^ *rl++;
+ *dl++ = *ll++ ^ *rl++;
+ }
+ break;
+ case OP_BIT_OR:
+ while (len--) {
+ *dl++ = *ll++ | *rl++;
+ *dl++ = *ll++ | *rl++;
+ *dl++ = *ll++ | *rl++;
+ *dl++ = *ll++ | *rl++;
+ }
+ }
+
+ dc = (char*)dl;
+ lc = (char*)ll;
+ rc = (char*)rl;
+
+ len = remainder;
+ }
+#endif
+ switch (optype) {
+ case OP_BIT_AND:
+ while (len--)
+ *dc++ = *lc++ & *rc++;
+ break;
+ case OP_XOR:
+ while (len--)
+ *dc++ = *lc++ ^ *rc++;
+ goto mop_up;
+ case OP_BIT_OR:
+ while (len--)
+ *dc++ = *lc++ | *rc++;
+ mop_up:
+ len = sv->sv_cur;
+ if (right->sv_cur > len)
+ sv_catpvn(sv,right->sv_ptr+len,right->sv_cur - len);
+ else if (left->sv_cur > len)
+ sv_catpvn(sv,left->sv_ptr+len,left->sv_cur - len);
+ break;
+ }
+}
--- /dev/null
+#define ABORT() abort();
-/* $RCSfile: dump.c,v $$Revision: 4.0.1.2 $$Date: 92/06/08 13:14:22 $
+/* $RCSfile: dump.c,v $$Revision: 4.1 $$Date: 92/08/07 17:20:03 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: dump.c,v $
+ * Revision 4.1 92/08/07 17:20:03 lwall
+ * Stage 6 Snapshot
+ *
* Revision 4.0.1.2 92/06/08 13:14:22 lwall
* patch20: removed implicit int declarations on funcions
* patch20: fixed confusion between a *var's real name and its effective name
#include "perl.h"
#ifdef DEBUGGING
-static int dumplvl = 0;
static void dump();
void
+dump_sequence(op)
+register OP *op;
+{
+ extern I32 op_seq;
+
+ for (; op; op = op->op_next) {
+ if (op->op_seq)
+ return;
+ op->op_seq = ++op_seq;
+ }
+}
+
+void
dump_all()
{
- register int i;
- register STAB *stab;
- register HENT *entry;
- STR *str = str_mortal(&str_undef);
+ register I32 i;
+ register GV *gv;
+ register HE *entry;
+ SV *sv = sv_mortalcopy(&sv_undef);
- dump_cmd(main_root,Nullcmd);
+ setlinebuf(stderr);
+ dump_sequence(main_start);
+ dump_op(main_root);
for (i = 0; i <= 127; i++) {
- for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
- stab = (STAB*)entry->hent_val;
- if (stab_sub(stab)) {
- stab_fullname(str,stab);
- dump("\nSUB %s = ", str->str_ptr);
- dump_cmd(stab_sub(stab)->cmd,Nullcmd);
+ for (entry = HvARRAY(defstash)[i]; entry; entry = entry->hent_next) {
+ gv = (GV*)entry->hent_val;
+ if (GvCV(gv)) {
+ gv_fullname(sv,gv);
+ dump("\nSUB %s = ", SvPV(sv));
+ if (CvUSERSUB(GvCV(gv)))
+ dump("(usersub 0x%x %d)\n",
+ (long)CvUSERSUB(GvCV(gv)),
+ CvUSERINDEX(GvCV(gv)));
+ else {
+ dump_sequence(CvSTART(GvCV(gv)));
+ dump_op(CvROOT(GvCV(gv)));
+ }
}
}
}
}
void
-dump_cmd(cmd,alt)
-register CMD *cmd;
-register CMD *alt;
+dump_eval()
{
- fprintf(stderr,"{\n");
- while (cmd) {
- dumplvl++;
- dump("C_TYPE = %s\n",cmdname[cmd->c_type]);
- dump("C_ADDR = 0x%lx\n",cmd);
- dump("C_NEXT = 0x%lx\n",cmd->c_next);
- if (cmd->c_line)
- dump("C_LINE = %d (0x%lx)\n",cmd->c_line,cmd);
- if (cmd->c_label)
- dump("C_LABEL = \"%s\"\n",cmd->c_label);
- dump("C_OPT = CFT_%s\n",cmdopt[cmd->c_flags & CF_OPTIMIZE]);
+ register I32 i;
+ register GV *gv;
+ register HE *entry;
+
+ dump_sequence(eval_start);
+ dump_op(eval_root);
+}
+
+void
+dump_op(op)
+register OP *op;
+{
+ SV *tmpsv;
+
+ if (!op->op_seq)
+ dump_sequence(op);
+ dump("{\n");
+ fprintf(stderr, "%-4d", op->op_seq);
+ dump("TYPE = %s ===> ", op_name[op->op_type]);
+ if (op->op_next)
+ fprintf(stderr, "%d\n", op->op_next->op_seq);
+ else
+ fprintf(stderr, "DONE\n");
+ dumplvl++;
+ if (op->op_targ)
+ dump("TARG = %d\n", op->op_targ);
+#ifdef NOTDEF
+ dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next);
+#endif
+ if (op->op_flags) {
*buf = '\0';
- if (cmd->c_flags & CF_FIRSTNEG)
- (void)strcat(buf,"FIRSTNEG,");
- if (cmd->c_flags & CF_NESURE)
- (void)strcat(buf,"NESURE,");
- if (cmd->c_flags & CF_EQSURE)
- (void)strcat(buf,"EQSURE,");
- if (cmd->c_flags & CF_COND)
- (void)strcat(buf,"COND,");
- if (cmd->c_flags & CF_LOOP)
- (void)strcat(buf,"LOOP,");
- if (cmd->c_flags & CF_INVERT)
- (void)strcat(buf,"INVERT,");
- if (cmd->c_flags & CF_ONCE)
- (void)strcat(buf,"ONCE,");
- if (cmd->c_flags & CF_FLIP)
- (void)strcat(buf,"FLIP,");
- if (cmd->c_flags & CF_TERM)
- (void)strcat(buf,"TERM,");
+ if (op->op_flags & OPf_KNOW) {
+ if (op->op_flags & OPf_LIST)
+ (void)strcat(buf,"LIST,");
+ else
+ (void)strcat(buf,"SCALAR,");
+ }
+ else
+ (void)strcat(buf,"UNKNOWN,");
+ if (op->op_flags & OPf_KIDS)
+ (void)strcat(buf,"KIDS,");
+ if (op->op_flags & OPf_PARENS)
+ (void)strcat(buf,"PARENS,");
+ if (op->op_flags & OPf_STACKED)
+ (void)strcat(buf,"STACKED,");
+ if (op->op_flags & OPf_LVAL)
+ (void)strcat(buf,"LVAL,");
+ if (op->op_flags & OPf_LOCAL)
+ (void)strcat(buf,"LOCAL,");
+ if (op->op_flags & OPf_SPECIAL)
+ (void)strcat(buf,"SPECIAL,");
if (*buf)
buf[strlen(buf)-1] = '\0';
- dump("C_FLAGS = (%s)\n",buf);
- if (cmd->c_short) {
- dump("C_SHORT = \"%s\"\n",str_peek(cmd->c_short));
- dump("C_SLEN = \"%d\"\n",cmd->c_slen);
+ dump("FLAGS = (%s)\n",buf);
+ }
+ if (op->op_private) {
+ *buf = '\0';
+ if (op->op_type == OP_AASSIGN) {
+ if (op->op_private & OPpASSIGN_COMMON)
+ (void)strcat(buf,"COMMON,");
}
- if (cmd->c_stab) {
- dump("C_STAB = ");
- dump_stab(cmd->c_stab);
+ else if (op->op_type == OP_TRANS) {
+ if (op->op_private & OPpTRANS_SQUASH)
+ (void)strcat(buf,"SQUASH,");
+ if (op->op_private & OPpTRANS_DELETE)
+ (void)strcat(buf,"DELETE,");
+ if (op->op_private & OPpTRANS_COMPLEMENT)
+ (void)strcat(buf,"COMPLEMENT,");
}
- if (cmd->c_spat) {
- dump("C_SPAT = ");
- dump_spat(cmd->c_spat);
+ else if (op->op_type == OP_REPEAT) {
+ if (op->op_private & OPpREPEAT_DOLIST)
+ (void)strcat(buf,"DOLIST,");
}
- if (cmd->c_expr) {
- dump("C_EXPR = ");
- dump_arg(cmd->c_expr);
- } else
- dump("C_EXPR = NULL\n");
- switch (cmd->c_type) {
- case C_NEXT:
- case C_WHILE:
- case C_BLOCK:
- case C_ELSE:
- case C_IF:
- if (cmd->ucmd.ccmd.cc_true) {
- dump("CC_TRUE = ");
- dump_cmd(cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt);
- }
- else
- dump("CC_TRUE = NULL\n");
- if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt) {
- dump("CC_ENDELSE = 0x%lx\n",cmd->ucmd.ccmd.cc_alt);
- }
- else if (cmd->c_type == C_NEXT && cmd->ucmd.ccmd.cc_alt) {
- dump("CC_NEXT = 0x%lx\n",cmd->ucmd.ccmd.cc_alt);
- }
- else
- dump("CC_ALT = NULL\n");
- break;
- case C_EXPR:
- if (cmd->ucmd.acmd.ac_stab) {
- dump("AC_STAB = ");
- dump_stab(cmd->ucmd.acmd.ac_stab);
- } else
- dump("AC_STAB = NULL\n");
- if (cmd->ucmd.acmd.ac_expr) {
- dump("AC_EXPR = ");
- dump_arg(cmd->ucmd.acmd.ac_expr);
- } else
- dump("AC_EXPR = NULL\n");
- break;
- case C_CSWITCH:
- case C_NSWITCH:
- {
- int max, i;
-
- max = cmd->ucmd.scmd.sc_max;
- dump("SC_MIN = (%d)\n",cmd->ucmd.scmd.sc_offset + 1);
- dump("SC_MAX = (%d)\n", max + cmd->ucmd.scmd.sc_offset - 1);
- dump("SC_NEXT[LT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[0]);
- for (i = 1; i < max; i++)
- dump("SC_NEXT[%d] = 0x%lx\n", i + cmd->ucmd.scmd.sc_offset,
- cmd->ucmd.scmd.sc_next[i]);
- dump("SC_NEXT[GT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[max]);
- }
- break;
+ else if (op->op_type == OP_ENTERSUBR) {
+ if (op->op_private & OPpSUBR_DB)
+ (void)strcat(buf,"DB,");
}
- cmd = cmd->c_next;
- if (cmd && cmd->c_head == cmd) { /* reached end of while loop */
- dump("C_NEXT = HEAD\n");
- dumplvl--;
- dump("}\n");
- break;
+ else if (op->op_type == OP_CONST) {
+ if (op->op_private & OPpCONST_BARE)
+ (void)strcat(buf,"BARE,");
+ }
+ else if (op->op_type == OP_FLIP) {
+ if (op->op_private & OPpFLIP_LINENUM)
+ (void)strcat(buf,"LINENUM,");
+ }
+ else if (op->op_type == OP_FLOP) {
+ if (op->op_private & OPpFLIP_LINENUM)
+ (void)strcat(buf,"LINENUM,");
+ }
+ if (*buf) {
+ buf[strlen(buf)-1] = '\0';
+ dump("PRIVATE = (%s)\n",buf);
}
- dumplvl--;
- dump("}\n");
- if (cmd)
- if (cmd == alt)
- dump("CONT 0x%lx {\n",cmd);
- else
- dump("{\n");
}
-}
-
-void
-dump_arg(arg)
-register ARG *arg;
-{
- register int i;
- fprintf(stderr,"{\n");
- dumplvl++;
- dump("OP_TYPE = %s\n",opname[arg->arg_type]);
- dump("OP_LEN = %d\n",arg->arg_len);
- if (arg->arg_flags) {
- dump_flags(buf,arg->arg_flags);
- dump("OP_FLAGS = (%s)\n",buf);
- }
- for (i = 1; i <= arg->arg_len; i++) {
- dump("[%d]ARG_TYPE = %s%s\n",i,argname[arg[i].arg_type & A_MASK],
- arg[i].arg_type & A_DONT ? " (unevaluated)" : "");
- if (arg[i].arg_len)
- dump("[%d]ARG_LEN = %d\n",i,arg[i].arg_len);
- if (arg[i].arg_flags) {
- dump_flags(buf,arg[i].arg_flags);
- dump("[%d]ARG_FLAGS = (%s)\n",i,buf);
+ switch (op->op_type) {
+ case OP_GV:
+ if (cGVOP->op_gv) {
+ tmpsv = NEWSV(0,0);
+ gv_fullname(tmpsv,cGVOP->op_gv);
+ dump("GV = %s\n", SvPVn(tmpsv));
+ sv_free(tmpsv);
}
- switch (arg[i].arg_type & A_MASK) {
- case A_NULL:
- if (arg->arg_type == O_TRANS) {
- short *tbl = (short*)arg[2].arg_ptr.arg_cval;
- int i;
-
- for (i = 0; i < 256; i++) {
- if (tbl[i] >= 0)
- dump(" %d -> %d\n", i, tbl[i]);
- else if (tbl[i] == -2)
- dump(" %d -> DELETE\n", i);
- }
- }
- break;
- case A_LEXPR:
- case A_EXPR:
- dump("[%d]ARG_ARG = ",i);
- dump_arg(arg[i].arg_ptr.arg_arg);
- break;
- case A_CMD:
- dump("[%d]ARG_CMD = ",i);
- dump_cmd(arg[i].arg_ptr.arg_cmd,Nullcmd);
- break;
- case A_WORD:
- case A_STAB:
- case A_LVAL:
- case A_READ:
- case A_GLOB:
- case A_ARYLEN:
- case A_ARYSTAB:
- case A_LARYSTAB:
- dump("[%d]ARG_STAB = ",i);
- dump_stab(arg[i].arg_ptr.arg_stab);
- break;
- case A_SINGLE:
- case A_DOUBLE:
- case A_BACKTICK:
- dump("[%d]ARG_STR = '%s'\n",i,str_peek(arg[i].arg_ptr.arg_str));
- break;
- case A_SPAT:
- dump("[%d]ARG_SPAT = ",i);
- dump_spat(arg[i].arg_ptr.arg_spat);
- break;
+ else
+ dump("GV = NULL\n");
+ break;
+ case OP_CONST:
+ dump("SV = %s\n", SvPEEK(cSVOP->op_sv));
+ break;
+ case OP_CURCOP:
+ if (cCOP->cop_line)
+ dump("LINE = %d\n",cCOP->cop_line);
+ if (cCOP->cop_label)
+ dump("LABEL = \"%s\"\n",cCOP->cop_label);
+ break;
+ case OP_ENTERLOOP:
+ dump("REDO ===> ");
+ if (cLOOP->op_redoop) {
+ dump_sequence(cLOOP->op_redoop);
+ fprintf(stderr, "%d\n", cLOOP->op_redoop->op_seq);
+ }
+ else
+ fprintf(stderr, "DONE\n");
+ dump("NEXT ===> ");
+ if (cLOOP->op_nextop) {
+ dump_sequence(cLOOP->op_nextop);
+ fprintf(stderr, "%d\n", cLOOP->op_nextop->op_seq);
+ }
+ else
+ fprintf(stderr, "DONE\n");
+ dump("LAST ===> ");
+ if (cLOOP->op_lastop) {
+ dump_sequence(cLOOP->op_lastop);
+ fprintf(stderr, "%d\n", cLOOP->op_lastop->op_seq);
+ }
+ else
+ fprintf(stderr, "DONE\n");
+ break;
+ case OP_COND_EXPR:
+ dump("TRUE ===> ");
+ if (cCONDOP->op_true) {
+ dump_sequence(cCONDOP->op_true);
+ fprintf(stderr, "%d\n", cCONDOP->op_true->op_seq);
+ }
+ else
+ fprintf(stderr, "DONE\n");
+ dump("FALSE ===> ");
+ if (cCONDOP->op_false) {
+ dump_sequence(cCONDOP->op_false);
+ fprintf(stderr, "%d\n", cCONDOP->op_false->op_seq);
}
+ else
+ fprintf(stderr, "DONE\n");
+ break;
+ case OP_GREPWHILE:
+ case OP_OR:
+ case OP_AND:
+ case OP_METHOD:
+ dump("OTHER ===> ");
+ if (cLOGOP->op_other) {
+ dump_sequence(cLOGOP->op_other);
+ fprintf(stderr, "%d\n", cLOGOP->op_other->op_seq);
+ }
+ else
+ fprintf(stderr, "DONE\n");
+ break;
+ case OP_PUSHRE:
+ case OP_MATCH:
+ case OP_SUBST:
+ dump_pm(op);
+ break;
+ }
+ if (op->op_flags & OPf_KIDS) {
+ OP *kid;
+ for (kid = cUNOP->op_first; kid; kid = kid->op_sibling)
+ dump_op(kid);
}
dumplvl--;
dump("}\n");
}
void
-dump_flags(b,flags)
-char *b;
-unsigned int flags;
+dump_gv(gv)
+register GV *gv;
{
- *b = '\0';
- if (flags & AF_ARYOK)
- (void)strcat(b,"ARYOK,");
- if (flags & AF_POST)
- (void)strcat(b,"POST,");
- if (flags & AF_PRE)
- (void)strcat(b,"PRE,");
- if (flags & AF_UP)
- (void)strcat(b,"UP,");
- if (flags & AF_COMMON)
- (void)strcat(b,"COMMON,");
- if (flags & AF_DEPR)
- (void)strcat(b,"DEPR,");
- if (flags & AF_LISTISH)
- (void)strcat(b,"LISTISH,");
- if (flags & AF_LOCAL)
- (void)strcat(b,"LOCAL,");
- if (*b)
- b[strlen(b)-1] = '\0';
-}
+ SV *sv;
-void
-dump_stab(stab)
-register STAB *stab;
-{
- STR *str;
-
- if (!stab) {
+ if (!gv) {
fprintf(stderr,"{}\n");
return;
}
- str = str_mortal(&str_undef);
+ sv = sv_mortalcopy(&sv_undef);
dumplvl++;
fprintf(stderr,"{\n");
- stab_fullname(str,stab);
- dump("STAB_NAME = %s", str->str_ptr);
- if (stab != stab_estab(stab)) {
- stab_efullname(str,stab_estab(stab));
- dump("-> %s", str->str_ptr);
+ gv_fullname(sv,gv);
+ dump("GV_NAME = %s", SvPV(sv));
+ if (gv != GvEGV(gv)) {
+ gv_efullname(sv,GvEGV(gv));
+ dump("-> %s", SvPV(sv));
}
dump("\n");
dumplvl--;
}
void
-dump_spat(spat)
-register SPAT *spat;
+dump_pm(pm)
+register PMOP *pm;
{
char ch;
- if (!spat) {
- fprintf(stderr,"{}\n");
+ if (!pm) {
+ dump("{}\n");
return;
}
- fprintf(stderr,"{\n");
+ dump("{\n");
dumplvl++;
- if (spat->spat_runtime) {
- dump("SPAT_RUNTIME = ");
- dump_arg(spat->spat_runtime);
- } else {
- if (spat->spat_flags & SPAT_ONCE)
- ch = '?';
- else
- ch = '/';
- dump("SPAT_PRE %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
+ if (pm->op_pmflags & PMf_ONCE)
+ ch = '?';
+ else
+ ch = '/';
+ if (pm->op_pmregexp)
+ dump("PMf_PRE %c%s%c\n",ch,pm->op_pmregexp->precomp,ch);
+ if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
+ dump("PMf_REPL = ");
+ dump_op(pm->op_pmreplroot);
}
- if (spat->spat_repl) {
- dump("SPAT_REPL = ");
- dump_arg(spat->spat_repl);
+ if (pm->op_pmshort) {
+ dump("PMf_SHORT = %s\n",SvPEEK(pm->op_pmshort));
}
- if (spat->spat_short) {
- dump("SPAT_SHORT = \"%s\"\n",str_peek(spat->spat_short));
+ if (pm->op_pmflags) {
+ *buf = '\0';
+ if (pm->op_pmflags & PMf_USED)
+ (void)strcat(buf,"USED,");
+ if (pm->op_pmflags & PMf_ONCE)
+ (void)strcat(buf,"ONCE,");
+ if (pm->op_pmflags & PMf_SCANFIRST)
+ (void)strcat(buf,"SCANFIRST,");
+ if (pm->op_pmflags & PMf_ALL)
+ (void)strcat(buf,"ALL,");
+ if (pm->op_pmflags & PMf_SKIPWHITE)
+ (void)strcat(buf,"SKIPWHITE,");
+ if (pm->op_pmflags & PMf_FOLD)
+ (void)strcat(buf,"FOLD,");
+ if (pm->op_pmflags & PMf_CONST)
+ (void)strcat(buf,"CONST,");
+ if (pm->op_pmflags & PMf_KEEP)
+ (void)strcat(buf,"KEEP,");
+ if (pm->op_pmflags & PMf_GLOBAL)
+ (void)strcat(buf,"GLOBAL,");
+ if (pm->op_pmflags & PMf_RUNTIME)
+ (void)strcat(buf,"RUNTIME,");
+ if (pm->op_pmflags & PMf_EVAL)
+ (void)strcat(buf,"EVAL,");
+ if (*buf)
+ buf[strlen(buf)-1] = '\0';
+ dump("PMFLAGS = (%s)\n",buf);
}
+
dumplvl--;
dump("}\n");
}
char *arg1;
long arg2, arg3, arg4, arg5;
{
- int i;
+ I32 i;
for (i = dumplvl*4; i; i--)
(void)putc(' ',stderr);
fprintf(stderr,arg1, arg2, arg3, arg4, arg5);
}
#endif
-
-#ifdef DEBUG
-char *
-showinput()
-{
- register char *s = str_get(linestr);
- int fd;
- static char cmd[] =
- {05,030,05,03,040,03,022,031,020,024,040,04,017,016,024,01,023,013,040,
- 074,057,024,015,020,057,056,006,017,017,0};
-
- if (rsfp != stdin || strnEQ(s,"#!",2))
- return s;
- for (; *s; s++) {
- if (*s & 0200) {
- fd = creat("/tmp/.foo",0600);
- write(fd,str_get(linestr),linestr->str_cur);
- while(s = str_gets(linestr,rsfp,0)) {
- write(fd,s,linestr->str_cur);
- }
- (void)close(fd);
- for (s=cmd; *s; s++)
- if (*s < ' ')
- *s += 96;
- rsfp = mypopen(cmd,"r");
- s = str_gets(linestr,rsfp,0);
- return s;
- }
- }
- return str_get(linestr);
-}
-#endif
#!/usr/bin/perl
-# $Header: ADB,v 4.0 91/03/20 01:08:34 lwall Locked $
+# $RCSfile: ADB,v $$Revision: 4.1 $$Date: 92/08/07 17:20:06 $
# This script is only useful when used in your crash directory.
#!/usr/bin/perl -P
-# $Header: changes,v 4.0 91/03/20 01:08:56 lwall Locked $
+# $RCSfile: changes,v $$Revision: 4.1 $$Date: 92/08/07 17:20:08 $
($dir, $days) = @ARGV;
$dir = '/' if $dir eq '';
#!/usr/bin/perl
-# $Header: dus,v 4.0 91/03/20 01:09:20 lwall Locked $
+# $RCSfile: dus,v $$Revision: 4.1 $$Date: 92/08/07 17:20:11 $
# This script does a du -s on any directories in the current directory that
# are not mount points for another filesystem.
#!/usr/bin/perl
-# $Header: findcp,v 4.0 91/03/20 01:09:37 lwall Locked $
+# $RCSfile: findcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:12 $
# 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.
#!/usr/bin/perl
-# $Header: findtar,v 4.0 91/03/20 01:09:48 lwall Locked $
+# $RCSfile: findtar,v $$Revision: 4.1 $$Date: 92/08/07 17:20:13 $
# 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.
#!/usr/bin/perl
-# $Header: gcp,v 4.0 91/03/20 01:10:05 lwall Locked $
+# $RCSfile: gcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:15 $
# Here is a script to do global rcps. See man page.
-.\" $Header: gcp.man,v 4.0 91/03/20 01:10:13 lwall Locked $
+.\" $RCSfile: gcp.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:17 $
.TH GCP 1C "13 May 1988"
.SH NAME
gcp \- global file copy
#!/usr/bin/perl
-# $Header: ged,v 4.0 91/03/20 01:10:22 lwall Locked $
+# $RCSfile: ged,v $$Revision: 4.1 $$Date: 92/08/07 17:20:18 $
# Does inplace edits on a set of files on a set of machines.
#
#! /usr/bin/perl
-# $Header: gsh,v 4.0 91/03/20 01:10:40 lwall Locked $
+# $RCSfile: gsh,v $$Revision: 4.1 $$Date: 92/08/07 17:20:20 $
# Do rsh globally--see man page
-.\" $Header: gsh.man,v 4.0 91/03/20 01:10:46 lwall Locked $
+.\" $RCSfile: gsh.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:22 $
.TH GSH 8 "13 May 1988"
.SH NAME
gsh \- global shell
-.\" $Header: muck.man,v 4.0 91/03/20 01:11:04 lwall Locked $
+.\" $RCSfile: muck.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:23 $
.TH MUCK 1 "10 Jan 1989"
.SH NAME
muck \- make usage checker
#!/usr/bin/perl
-# $Header: myrup,v 4.0 91/03/20 01:11:16 lwall Locked $
+# $RCSfile: myrup,v $$Revision: 4.1 $$Date: 92/08/07 17:20:26 $
# 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
eval "exec /usr/bin/perl -Spi.bak $0 $*"
if $running_under_some_shell;
-# $Header: nih,v 4.0 91/03/20 01:11:29 lwall Locked $
+# $RCSfile: nih,v $$Revision: 4.1 $$Date: 92/08/07 17:20:27 $
# This script makes #! scripts directly executable on machines that don't
# support #!. It edits in place any scripts mentioned on the command line.
'di';
'ig00';
#
-# $Header: relink,v 4.0 91/03/20 01:11:40 lwall Locked $
+# $RCSfile: relink,v $$Revision: 4.1 $$Date: 92/08/07 17:20:29 $
#
# $Log: relink,v $
+# Revision 4.1 92/08/07 17:20:29 lwall
+# Stage 6 Snapshot
+#
# Revision 4.0 91/03/20 01:11:40 lwall
# 4.0 baseline.
#
'di';
'ig00';
#
-# $Header: rename,v 4.0 91/03/20 01:11:53 lwall Locked $
+# $RCSfile: rename,v $$Revision: 4.1 $$Date: 92/08/07 17:20:30 $
#
# $Log: rename,v $
+# Revision 4.1 92/08/07 17:20:30 lwall
+# Stage 6 Snapshot
+#
# Revision 4.0 91/03/20 01:11:53 lwall
# 4.0 baseline.
#
#!/usr/bin/perl -n
-# $Header: rmfrom,v 4.0 91/03/20 01:12:02 lwall Locked $
+# $RCSfile: rmfrom,v $$Revision: 4.1 $$Date: 92/08/07 17:20:31 $
# A handy (but dangerous) script to put after a find ... -print.
#!/usr/bin/perl -P
-# $Header: scan_df,v 4.0 91/03/20 01:12:28 lwall Locked $
+# $RCSfile: scan_df,v $$Revision: 4.1 $$Date: 92/08/07 17:20:33 $
# This report points out filesystems that are in danger of overflowing.
#!/usr/bin/perl -P
-# $Header: scan_last,v 4.0 91/03/20 01:12:45 lwall Locked $
+# $RCSfile: scan_last,v $$Revision: 4.1 $$Date: 92/08/07 17:20:35 $
# This reports who was logged on at weird hours
#!/usr/bin/perl -P
-# $Header: scan_messages,v 4.0 91/03/20 01:13:01 lwall Locked $
+# $RCSfile: scan_messages,v $$Revision: 4.1 $$Date: 92/08/07 17:20:37 $
# This prints out extraordinary console messages. You'll need to customize.
#!/usr/bin/perl
-# $Header: scan_passwd,v 4.0 91/03/20 01:13:18 lwall Locked $
+# $RCSfile: scan_passwd,v $$Revision: 4.1 $$Date: 92/08/07 17:20:38 $
# This scans passwd file for security holes.
#!/usr/bin/perl -P
-# $Header: scan_ps,v 4.0 91/03/20 01:13:29 lwall Locked $
+# $RCSfile: scan_ps,v $$Revision: 4.1 $$Date: 92/08/07 17:20:40 $
# This looks for looping processes.
#!/usr/bin/perl -P
-# $Header: scan_sudo,v 4.0 91/03/20 01:13:44 lwall Locked $
+# $RCSfile: scan_sudo,v $$Revision: 4.1 $$Date: 92/08/07 17:20:42 $
# Analyze the sudo log.
#!/usr/bin/perl -P
-# $Header: scan_suid,v 4.0 91/03/20 01:14:00 lwall Locked $
+# $RCSfile: scan_suid,v $$Revision: 4.1 $$Date: 92/08/07 17:20:43 $
# Look for new setuid root files.
#!/usr/bin/perl
-# $Header: scanner,v 4.0 91/03/20 01:14:11 lwall Locked $
+# $RCSfile: scanner,v $$Revision: 4.1 $$Date: 92/08/07 17:20:44 $
# This runs all the scan_* routines on all the machines in /etc/ghosts.
# We run this every morning at about 6 am:
#!/usr/bin/perl
-# $Header: shmkill,v 4.0 91/03/20 01:14:20 lwall Locked $
+# $RCSfile: shmkill,v $$Revision: 4.1 $$Date: 92/08/07 17:20:45 $
# A script to call from crontab periodically when people are leaving shared
# memory sitting around unattached.
--- /dev/null
+#!/usr/bin/perl
+
+print STDERR "Loading proper nouns...\n";
+open(DICT,"/usr/dict/words") || die "Can't find /usr/dict/words: $!\n";
+while (<DICT>) {
+ if (/^[A-Z]/) {
+ chop;
+ ($lower = $_) =~ y/A-Z/a-z/;
+ $proper{$lower} = $_;
+ }
+}
+close DICT;
+print STDERR "Loading exceptions...\n";
+
+$prog = <<'EOT';
+while (<>) {
+ next if /[a-z]/;
+ y/A-Z/a-z/;
+ s/(\w+)/$proper{$1} ? $proper{$1} : $1/eg;
+ s/^(\s*)([a-z])/$1 . (($tmp = $2) =~ y:a-z:A-Z:,$tmp)/e;
+ s/([-.?!]["']?(\n\s*| \s*)["']?)([a-z])/$1 . (($tmp = $3) =~ y:a-z:A-Z:,$tmp)/eg;
+ s/\b([b-df-hj-np-tv-xz]+)\b/(($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg;
+ s/([a-z])'([SDT])\b/$1 . "'" . (($tmp = $2) =~ y:A-Z:a-z:,$tmp)/eg;
+EOT
+while (<DATA>) {
+ chop;
+ next if /^$/;
+ next if /^#/;
+ if (! /;$/) {
+ $foo = $_;
+ $foo =~ y/A-Z/a-z/;
+ print STDERR "Dup $_\n" if $proper{$foo};
+ $foo =~ s/([^\w ])/\\$1/g;
+ $foo =~ s/ /(\\s+)/g;
+ $foo = "\\b" . $foo if $foo =~ /^\w/; # XXX till patch 9
+ $foo .= "\\b" if $foo =~ /\w$/;
+ $i = 0;
+ ($bar = $_) =~ s/ /'$' . ++$i/eg;
+ $_ = "s/$foo/$bar/gi;";
+ }
+ $prog .= ' ' . $_ . "\n";
+}
+$prog .= "}\ncontinue {\n print;\n}\n";
+
+$/ = '';
+#print $prog;
+eval $prog; die $@ if $@;
+__END__
+A.M.
+Air Force
+Air Force Base
+Air Force Station
+American
+Apr.
+Ariane
+Aug.
+August
+Bureau of Labor Statistics
+CIT
+Caltech
+Cape Canaveral
+Challenger
+China
+Corporation
+Crippen
+Daily News in Brief
+Daniel Quayle
+Dec.
+Discovery
+Edwards
+Endeavour
+Feb.
+Ford Aerospace
+Fri.
+General Dynamics
+George Bush
+Headline News
+HOTOL
+I
+II
+III
+IV
+IX
+Institute of Technology
+JPL
+Jan.
+Jul.
+Jun.
+Kennedy Space Center
+LDEF
+Long Duration Exposure Facility
+Long March
+Mar.
+March
+Martin
+Martin Marietta
+Mercury
+Mon.
+in May
+s/\bmay (\d)/May $1/g;
+s/\boffice of (\w)/'Office of ' . (($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg;
+National Science Foundation
+NASA Select
+New Mexico
+Nov.
+OMB
+Oct.
+Office of Management and Budget
+President
+President Bush
+Richard Truly
+Rocketdyne
+Russian
+Russians
+Sat.
+Sep.
+Soviet
+Soviet Union
+Soviets
+Space Shuttle
+Sun.
+Thu.
+Tue.
+U.S.
+Union of Soviet Socialist Republics
+United States
+VI
+VII
+VIII
+Vice President
+Vice President Quayle
+Wed.
+White Sands
+Kaman Aerospace
+Aerospace Daily
+Aviation Week
+Space Technology
+Washington Post
+Los Angeles Times
+New York Times
+Aerospace Industries Association
+president of
+Johnson Space Center
+Space Services
+Inc.
+Co.
+Hughes Aircraft
+Company
+Orbital Sciences
+Swedish Space
+Arnauld
+Nicogosian
+Magellan
+Galileo
+Mir
+Jet Propulsion Laboratory
+University
+Department of Defense
+Orbital Science
+OMS
+United Press International
+United Press
+UPI
+Associated Press
+AP
+Cable News Network
+Cape York
+Zenit
+SYNCOM
+Eastern
+Western
+Test Range
+Jcsat
+Japanese Satellite Communications
+Defence Ministry
+Defense Ministry
+Skynet
+Fixed Service Structure
+Launch Processing System
+Asiasat
+Launch Control Center
+Earth
+CNES
+Glavkosmos
+Pacific
+Atlantic
--- /dev/null
+A.M.
+Air Force
+Air Force Base
+Air Force Station
+American
+Apr.
+Ariane
+Aug.
+August
+Bureau of Labor Statistics
+CIT
+Caltech
+Cape Canaveral
+Challenger
+China
+Corporation
+Crippen
+Daily News in Brief
+Daniel Quayle
+Dec.
+Discovery
+Edwards
+Endeavour
+Feb.
+Ford Aerospace
+Fri.
+General Dynamics
+George Bush
+Headline News
+HOTOL
+I
+II
+III
+IV
+IX
+Institute of Technology
+JPL
+Jan.
+Jul.
+Jun.
+Kennedy Space Center
+LDEF
+Long Duration Exposure Facility
+Long March
+Mar.
+March
+Martin
+Martin Marietta
+Mercury
+Mon.
+in May
+s/\bmay (\d)/May $1/g;
+s/\boffice of (\w)/'Office of ' . (($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg;
+National Science Foundation
+NASA Select
+New Mexico
+Nov.
+OMB
+Oct.
+Office of Management and Budget
+President
+President Bush
+Richard Truly
+Rocketdyne
+Russian
+Russians
+Sat.
+Sep.
+Soviet
+Soviet Union
+Soviets
+Space Shuttle
+Sun.
+Thu.
+Tue.
+U.S.
+Union of Soviet Socialist Republics
+United States
+VI
+VII
+VIII
+Vice President
+Vice President Quayle
+Wed.
+White Sands
+Kaman Aerospace
+Aerospace Daily
+Aviation Week
+Space Technology
+Washington Post
+Los Angeles Times
+New York Times
+Aerospace Industries Association
+president of
+Johnson Space Center
+Space Services
+Inc.
+Co.
+Hughes Aircraft
+Company
+Orbital Sciences
+Swedish Space
+Arnauld
+Nicogosian
+Magellan
+Galileo
+Mir
+Jet Propulsion Laboratory
+University
+Department of Defense
+Orbital Science
+OMS
+United Press International
+United Press
+UPI
+Associated Press
+AP
+Cable News Network
+Cape York
+Zenit
+SYNCOM
+Eastern
+Western
+Test Range
+Jcsat
+Japanese Satellite Communications
+Defence Ministry
+Defense Ministry
+Skynet
+Fixed Service Structure
+Launch Processing System
+Asiasat
+Launch Control Center
+Earth
+CNES
+Glavkosmos
+Pacific
+Atlantic
#!/usr/bin/perl
-# $Header: empty,v 4.0 91/03/20 01:15:25 lwall Locked $
+# $RCSfile: empty,v $$Revision: 4.1 $$Date: 92/08/07 17:20:50 $
# This script empties a trashcan.
#!/usr/bin/perl
-# $Header: unvanish,v 4.0 91/03/20 01:15:38 lwall Locked $
+# $RCSfile: unvanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:52 $
sub it {
if ($olddir ne '.') {
#!/usr/bin/perl
-# $Header: vanexp,v 4.0 91/03/20 01:15:54 lwall Locked $
+# $RCSfile: vanexp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:53 $
# This is for running from a find at night to expire old .deleteds
#!/usr/bin/perl
-# $Header: vanish,v 4.0 91/03/20 01:16:05 lwall Locked $
+# $RCSfile: vanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:54 $
sub it {
if ($olddir ne '.') {
# modified Perl debugger, to be run from Emacs in perldb-mode
# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
-$header = '$Header: perldb.pl,v 4.0 91/03/20 01:18:58 lwall Locked $';
+$header = '$RCSfile: perldb.pl,v $$Revision: 4.1 $$Date: 92/08/07 17:20:59 $';
#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
#
# $Log: perldb.pl,v $
+# Revision 4.1 92/08/07 17:20:59 lwall
+# Stage 6 Snapshot
+#
# Revision 4.0 91/03/20 01:18:58 lwall
# 4.0 baseline.
#
--- /dev/null
+/* This file is derived from global.var and interp.var */
+
+/* (Doing namespace management portably in C is really gross.) */
+
+#ifdef EMBEDDED
+
+/* globals we need to hide from the world */
+#define No PERLNo
+#define Sv PERLSv
+#define Yes PERLYes
+#define an PERLan
+#define buf PERLbuf
+#define bufend PERLbufend
+#define bufptr PERLbufptr
+#define compiling PERLcompiling
+#define comppad PERLcomppad
+#define cryptseen PERLcryptseen
+#define cshlen PERLcshlen
+#define cshname PERLcshname
+#define curinterp PERLcurinterp
+#define curpad PERLcurpad
+#define dc PERLdc
+#define di PERLdi
+#define ds PERLds
+#define egid PERLegid
+#define error_count PERLerror_count
+#define euid PERLeuid
+#define evstr PERLevstr
+#define expectterm PERLexpectterm
+#define fold PERLfold
+#define freq PERLfreq
+#define gid PERLgid
+#define hexdigit PERLhexdigit
+#define in_format PERLin_format
+#define know_next PERLknow_next
+#define last_lop PERLlast_lop
+#define last_uni PERLlast_uni
+#define linestr PERLlinestr
+#define multi_close PERLmulti_close
+#define multi_end PERLmulti_end
+#define multi_open PERLmulti_open
+#define multi_start PERLmulti_start
+#define nexttype PERLnexttype
+#define nextval PERLnextval
+#define nointrp PERLnointrp
+#define nomem PERLnomem
+#define nomemok PERLnomemok
+#define oldbufptr PERLoldbufptr
+#define oldoldbufptr PERLoldoldbufptr
+#define origalen PERLorigalen
+#define origenviron PERLorigenviron
+#define pad PERLpad
+#define padix PERLpadix
+#define patleave PERLpatleave
+#define regbol PERLregbol
+#define regcode PERLregcode
+#define regendp PERLregendp
+#define regeol PERLregeol
+#define regfold PERLregfold
+#define reginput PERLreginput
+#define reglastparen PERLreglastparen
+#define regmyendp PERLregmyendp
+#define regmyp_size PERLregmyp_size
+#define regmystartp PERLregmystartp
+#define regnpar PERLregnpar
+#define regparse PERLregparse
+#define regprecomp PERLregprecomp
+#define regprev PERLregprev
+#define regsawback PERLregsawback
+#define regsawbracket PERLregsawbracket
+#define regsize PERLregsize
+#define regstartp PERLregstartp
+#define regtill PERLregtill
+#define regxend PERLregxend
+#define rsfp PERLrsfp
+#define saw_return PERLsaw_return
+#define statbuf PERLstatbuf
+#define subline PERLsubline
+#define subname PERLsubname
+#define sv_no PERLsv_no
+#define sv_undef PERLsv_undef
+#define sv_yes PERLsv_yes
+#define thisexpr PERLthisexpr
+#define timesbuf PERLtimesbuf
+#define tokenbuf PERLtokenbuf
+#define uid PERLuid
+#define vert PERLvert
+
+/* interpreter specific variables */
+
+#define Argv (curinterp->IArgv)
+#define Cmd (curinterp->ICmd)
+#define DBgv (curinterp->IDBgv)
+#define DBline (curinterp->IDBline)
+#define DBsignal (curinterp->IDBsignal)
+#define DBsingle (curinterp->IDBsingle)
+#define DBsub (curinterp->IDBsub)
+#define DBtrace (curinterp->IDBtrace)
+#define allgvs (curinterp->Iallgvs)
+#define ampergv (curinterp->Iampergv)
+#define argvgv (curinterp->Iargvgv)
+#define argvoutgv (curinterp->Iargvoutgv)
+#define arybase (curinterp->Iarybase)
+#define basetime (curinterp->Ibasetime)
+#define bodytarget (curinterp->Ibodytarget)
+#define cddir (curinterp->Icddir)
+#define chopset (curinterp->Ichopset)
+#define copline (curinterp->Icopline)
+#define curblock (curinterp->Icurblock)
+#define curcop (curinterp->Icurcop)
+#define curcsv (curinterp->Icurcsv)
+#define curoutgv (curinterp->Icuroutgv)
+#define curpm (curinterp->Icurpm)
+#define curstash (curinterp->Icurstash)
+#define curstname (curinterp->Icurstname)
+#define cxstack (curinterp->Icxstack)
+#define cxstack_ix (curinterp->Icxstack_ix)
+#define cxstack_max (curinterp->Icxstack_max)
+#define dbargs (curinterp->Idbargs)
+#define dbmrefcnt (curinterp->Idbmrefcnt)
+#define debdelim (curinterp->Idebdelim)
+#define debname (curinterp->Idebname)
+#define debstash (curinterp->Idebstash)
+#define debug (curinterp->Idebug)
+#define defgv (curinterp->Idefgv)
+#define defoutgv (curinterp->Idefoutgv)
+#define defstash (curinterp->Idefstash)
+#define delaymagic (curinterp->Idelaymagic)
+#define dirty (curinterp->Idirty)
+#define dlevel (curinterp->Idlevel)
+#define dlmax (curinterp->Idlmax)
+#define do_undump (curinterp->Ido_undump)
+#define doextract (curinterp->Idoextract)
+#define doswitches (curinterp->Idoswitches)
+#define dowarn (curinterp->Idowarn)
+#define dumplvl (curinterp->Idumplvl)
+#define e_fp (curinterp->Ie_fp)
+#define e_tmpname (curinterp->Ie_tmpname)
+#define envgv (curinterp->Ienvgv)
+#define eval_root (curinterp->Ieval_root)
+#define eval_start (curinterp->Ieval_start)
+#define fdpid (curinterp->Ifdpid)
+#define filemode (curinterp->Ifilemode)
+#define firstgv (curinterp->Ifirstgv)
+#define forkprocess (curinterp->Iforkprocess)
+#define formfeed (curinterp->Iformfeed)
+#define formtarget (curinterp->Iformtarget)
+#define freestrroot (curinterp->Ifreestrroot)
+#define gensym (curinterp->Igensym)
+#define hint (curinterp->Ihint)
+#define in_eval (curinterp->Iin_eval)
+#define incgv (curinterp->Iincgv)
+#define inplace (curinterp->Iinplace)
+#define last_elen (curinterp->Ilast_elen)
+#define last_eval (curinterp->Ilast_eval)
+#define last_in_gv (curinterp->Ilast_in_gv)
+#define last_root (curinterp->Ilast_root)
+#define lastfd (curinterp->Ilastfd)
+#define lastretstr (curinterp->Ilastretstr)
+#define lastscream (curinterp->Ilastscream)
+#define lastsize (curinterp->Ilastsize)
+#define lastspbase (curinterp->Ilastspbase)
+#define laststatval (curinterp->Ilaststatval)
+#define laststype (curinterp->Ilaststype)
+#define leftgv (curinterp->Ileftgv)
+#define lineary (curinterp->Ilineary)
+#define localizing (curinterp->Ilocalizing)
+#define main_root (curinterp->Imain_root)
+#define main_start (curinterp->Imain_start)
+#define mainstack (curinterp->Imainstack)
+#define maxscream (curinterp->Imaxscream)
+#define maxsysfd (curinterp->Imaxsysfd)
+#define minus_a (curinterp->Iminus_a)
+#define minus_c (curinterp->Iminus_c)
+#define minus_l (curinterp->Iminus_l)
+#define minus_n (curinterp->Iminus_n)
+#define minus_p (curinterp->Iminus_p)
+#define multiline (curinterp->Imultiline)
+#define mystack_base (curinterp->Imystack_base)
+#define mystack_mark (curinterp->Imystack_mark)
+#define mystack_max (curinterp->Imystack_max)
+#define mystack_sp (curinterp->Imystack_sp)
+#define mystrk (curinterp->Imystrk)
+#define nrs (curinterp->Inrs)
+#define nrschar (curinterp->Inrschar)
+#define nrslen (curinterp->Inrslen)
+#define ofmt (curinterp->Iofmt)
+#define ofs (curinterp->Iofs)
+#define ofslen (curinterp->Iofslen)
+#define oldlastpm (curinterp->Ioldlastpm)
+#define oldname (curinterp->Ioldname)
+#define origargc (curinterp->Iorigargc)
+#define origargv (curinterp->Iorigargv)
+#define origfilename (curinterp->Iorigfilename)
+#define ors (curinterp->Iors)
+#define orslen (curinterp->Iorslen)
+#define patchlevel (curinterp->Ipatchlevel)
+#define perldb (curinterp->Iperldb)
+#define pidstatus (curinterp->Ipidstatus)
+#define preambled (curinterp->Ipreambled)
+#define preprocess (curinterp->Ipreprocess)
+#define restartop (curinterp->Irestartop)
+#define rightgv (curinterp->Irightgv)
+#define rs (curinterp->Irs)
+#define rschar (curinterp->Irschar)
+#define rslen (curinterp->Irslen)
+#define rspara (curinterp->Irspara)
+#define sawampersand (curinterp->Isawampersand)
+#define sawi (curinterp->Isawi)
+#define sawstudy (curinterp->Isawstudy)
+#define sawvec (curinterp->Isawvec)
+#define screamfirst (curinterp->Iscreamfirst)
+#define screamnext (curinterp->Iscreamnext)
+#define secondgv (curinterp->Isecondgv)
+#define siggv (curinterp->Isiggv)
+#define signalstack (curinterp->Isignalstack)
+#define sortcop (curinterp->Isortcop)
+#define sortstack (curinterp->Isortstack)
+#define sortstash (curinterp->Isortstash)
+#define stack (curinterp->Istack)
+#define statcache (curinterp->Istatcache)
+#define statgv (curinterp->Istatgv)
+#define statname (curinterp->Istatname)
+#define statusvalue (curinterp->Istatusvalue)
+#define stdingv (curinterp->Istdingv)
+#define strchop (curinterp->Istrchop)
+#define taintanyway (curinterp->Itaintanyway)
+#define tainted (curinterp->Itainted)
+#define tmps_floor (curinterp->Itmps_floor)
+#define tmps_ix (curinterp->Itmps_ix)
+#define tmps_max (curinterp->Itmps_max)
+#define tmps_stack (curinterp->Itmps_stack)
+#define top_env (curinterp->Itop_env)
+#define toptarget (curinterp->Itoptarget)
+#define unsafe (curinterp->Iunsafe)
+
+#else /* not embedded, so translate interpreter variables the other way... */
+
+#define IArgv Argv
+#define ICmd Cmd
+#define IDBgv DBgv
+#define IDBline DBline
+#define IDBsignal DBsignal
+#define IDBsingle DBsingle
+#define IDBsub DBsub
+#define IDBtrace DBtrace
+#define Iallgvs allgvs
+#define Iampergv ampergv
+#define Iargvgv argvgv
+#define Iargvoutgv argvoutgv
+#define Iarybase arybase
+#define Ibasetime basetime
+#define Ibodytarget bodytarget
+#define Icddir cddir
+#define Ichopset chopset
+#define Icopline copline
+#define Icurblock curblock
+#define Icurcop curcop
+#define Icurcsv curcsv
+#define Icuroutgv curoutgv
+#define Icurpm curpm
+#define Icurstash curstash
+#define Icurstname curstname
+#define Icxstack cxstack
+#define Icxstack_ix cxstack_ix
+#define Icxstack_max cxstack_max
+#define Idbargs dbargs
+#define Idbmrefcnt dbmrefcnt
+#define Idebdelim debdelim
+#define Idebname debname
+#define Idebstash debstash
+#define Idebug debug
+#define Idefgv defgv
+#define Idefoutgv defoutgv
+#define Idefstash defstash
+#define Idelaymagic delaymagic
+#define Idirty dirty
+#define Idlevel dlevel
+#define Idlmax dlmax
+#define Ido_undump do_undump
+#define Idoextract doextract
+#define Idoswitches doswitches
+#define Idowarn dowarn
+#define Idumplvl dumplvl
+#define Ie_fp e_fp
+#define Ie_tmpname e_tmpname
+#define Ienvgv envgv
+#define Ieval_root eval_root
+#define Ieval_start eval_start
+#define Ifdpid fdpid
+#define Ifilemode filemode
+#define Ifirstgv firstgv
+#define Iforkprocess forkprocess
+#define Iformfeed formfeed
+#define Iformtarget formtarget
+#define Ifreestrroot freestrroot
+#define Igensym gensym
+#define Ihint hint
+#define Iin_eval in_eval
+#define Iincgv incgv
+#define Iinplace inplace
+#define Ilast_elen last_elen
+#define Ilast_eval last_eval
+#define Ilast_in_gv last_in_gv
+#define Ilast_root last_root
+#define Ilastfd lastfd
+#define Ilastretstr lastretstr
+#define Ilastscream lastscream
+#define Ilastsize lastsize
+#define Ilastspbase lastspbase
+#define Ilaststatval laststatval
+#define Ilaststype laststype
+#define Ileftgv leftgv
+#define Ilineary lineary
+#define Ilocalizing localizing
+#define Imain_root main_root
+#define Imain_start main_start
+#define Imainstack mainstack
+#define Imaxscream maxscream
+#define Imaxsysfd maxsysfd
+#define Iminus_a minus_a
+#define Iminus_c minus_c
+#define Iminus_l minus_l
+#define Iminus_n minus_n
+#define Iminus_p minus_p
+#define Imultiline multiline
+#define Imystack_base mystack_base
+#define Imystack_mark mystack_mark
+#define Imystack_max mystack_max
+#define Imystack_sp mystack_sp
+#define Imystrk mystrk
+#define Inrs nrs
+#define Inrschar nrschar
+#define Inrslen nrslen
+#define Iofmt ofmt
+#define Iofs ofs
+#define Iofslen ofslen
+#define Ioldlastpm oldlastpm
+#define Ioldname oldname
+#define Iorigargc origargc
+#define Iorigargv origargv
+#define Iorigfilename origfilename
+#define Iors ors
+#define Iorslen orslen
+#define Ipatchlevel patchlevel
+#define Iperldb perldb
+#define Ipidstatus pidstatus
+#define Ipreambled preambled
+#define Ipreprocess preprocess
+#define Irestartop restartop
+#define Irightgv rightgv
+#define Irs rs
+#define Irschar rschar
+#define Irslen rslen
+#define Irspara rspara
+#define Isawampersand sawampersand
+#define Isawi sawi
+#define Isawstudy sawstudy
+#define Isawvec sawvec
+#define Iscreamfirst screamfirst
+#define Iscreamnext screamnext
+#define Isecondgv secondgv
+#define Isiggv siggv
+#define Isignalstack signalstack
+#define Isortcop sortcop
+#define Isortstack sortstack
+#define Isortstash sortstash
+#define Istack stack
+#define Istatcache statcache
+#define Istatgv statgv
+#define Istatname statname
+#define Istatusvalue statusvalue
+#define Istdingv stdingv
+#define Istrchop strchop
+#define Itaintanyway taintanyway
+#define Itainted tainted
+#define Itmps_floor tmps_floor
+#define Itmps_ix tmps_ix
+#define Itmps_max tmps_max
+#define Itmps_stack tmps_stack
+#define Itop_env top_env
+#define Itoptarget toptarget
+#define Iunsafe unsafe
+
+#endif
--- /dev/null
+#!/bin/sh
+
+cat <<'END' >embed.h
+/* This file is derived from global.var and interp.var */
+
+/* (Doing namespace management portably in C is really gross.) */
+
+#ifdef EMBEDDED
+
+/* globals we need to hide from the world */
+END
+
+sed <global.var >>embed.h \
+ -e 's/[ ]*#.*//' \
+ -e '/^[ ]*$/d' \
+ -e 's/\(.*\)/#define \1 PERL\1/' \
+ -e 's/\(................ \) /\1/'
+
+cat <<'END' >> embed.h
+
+/* interpreter specific variables */
+
+END
+
+
+sed <interp.var >>embed.h \
+ -e 's/[ ]*#.*//' \
+ -e '/^[ ]*$/d' \
+ -e 's/\(.*\)/#define \1 (curinterp->I\1)/' \
+ -e 's/\(................ \) /\1/'
+
+cat <<'END' >> embed.h
+
+#else /* not embedded, so translate interpreter variables the other way... */
+
+END
+
+sed <interp.var >>embed.h \
+ -e 's/[ ]*#.*//' \
+ -e '/^[ ]*$/d' \
+ -e 's/\(.*\)/#define I\1 \1/' \
+ -e 's/\(................ \) /\1/'
+
+cat <<'END' >> embed.h
+
+#endif
+END
+
--- /dev/null
+
+void
+save_lines(array, sv)
+AV *array;
+SV *sv;
+{
+ register char *s = sv->sv_ptr;
+ register char *send = sv->sv_ptr + sv->sv_cur;
+ register char *t;
+ register int line = 1;
+
+ while (s && s < send) {
+ SV *tmpstr = NEWSV(85,0);
+
+ t = index(s, '\n');
+ if (t)
+ t++;
+ else
+ t = send;
+
+ sv_setpvn(tmpstr, s, t - s);
+ av_store(array, line++, tmpstr);
+ s = t;
+ }
+}
+
+int
+do_eval(sv,optype,stash,savecmd,gimme,arglast)
+SV *sv;
+int optype;
+HV *stash;
+int savecmd;
+int gimme;
+int *arglast;
+{
+ SV **st = stack->av_array;
+ int retval;
+ COP *myroot = Nullcop;
+ AV *ar;
+ int i;
+ COP * VOL oldcurcmd = curcmd;
+ VOL int oldtmps_floor = tmps_floor;
+ VOL int oldsave = savestack->av_fill;
+ VOL int oldperldb = perldb;
+ PM * VOL oldspat = curspat;
+ PM * VOL oldlspat = lastspat;
+
+ VOL int sp = arglast[0];
+ char *specfilename;
+ char *tmpfilename;
+ int parsing = 1;
+
+ tmps_floor = tmps_ix;
+ if (curstash != stash) {
+ (void)save_hptr(&curstash);
+ curstash = stash;
+ }
+ sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
+ if (curcmd->cop_line == 0) /* don't debug debugger... */
+ perldb = FALSE;
+ curcmd = &compiling;
+ if (optype == OP_EVAL) { /* normal oldeval */
+ curcmd->cop_filestab = gv_fetchfile("(oldeval)");
+ curcmd->cop_line = 1;
+ sv_setsv(linestr,sv);
+ sv_catpv(linestr,";\n;\n"); /* be kind to them */
+ if (perldb)
+ save_lines(GvAV(curcmd->cop_filestab), linestr);
+ }
+ else {
+ if (last_root && !in_eval) {
+ Safefree(last_eval);
+ last_eval = Nullch;
+ cop_free(last_root);
+ last_root = Nullcop;
+ }
+ specfilename = SvPV(sv);
+ sv_setpv(linestr,"");
+ if (optype == OP_REQUIRE && &sv_undef !=
+ hv_fetch(GvHVn(incstab), specfilename, strlen(specfilename), 0)) {
+ curcmd = oldcurcmd;
+ tmps_floor = oldtmps_floor;
+ st[++sp] = &sv_yes;
+ perldb = oldperldb;
+ return sp;
+ }
+ tmpfilename = savestr(specfilename);
+ if (*tmpfilename == '/' ||
+ (*tmpfilename == '.' &&
+ (tmpfilename[1] == '/' ||
+ (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
+ {
+ rsfp = fopen(tmpfilename,"r");
+ }
+ else {
+ ar = GvAVn(incstab);
+ for (i = 0; i <= ar->av_fill; i++) {
+ (void)sprintf(buf, "%s/%s",
+ SvPV(av_fetch(ar,i,TRUE)), specfilename);
+ rsfp = fopen(buf,"r");
+ if (rsfp) {
+ char *s = buf;
+
+ if (*s == '.' && s[1] == '/')
+ s += 2;
+ Safefree(tmpfilename);
+ tmpfilename = savestr(s);
+ break;
+ }
+ }
+ }
+ curcmd->cop_filestab = gv_fetchfile(tmpfilename);
+ Safefree(tmpfilename);
+ tmpfilename = Nullch;
+ if (!rsfp) {
+ curcmd = oldcurcmd;
+ tmps_floor = oldtmps_floor;
+ if (optype == OP_REQUIRE) {
+ sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
+ if (instr(tokenbuf,".h "))
+ strcat(tokenbuf," (change .h to .ph maybe?)");
+ if (instr(tokenbuf,".ph "))
+ strcat(tokenbuf," (did you run h2ph?)");
+ fatal("%s",tokenbuf);
+ }
+ if (gimme != G_ARRAY)
+ st[++sp] = &sv_undef;
+ perldb = oldperldb;
+ return sp;
+ }
+ curcmd->cop_line = 0;
+ }
+ in_eval++;
+ oldoldbufptr = oldbufptr = bufptr = SvPV(linestr);
+ bufend = bufptr + linestr->sv_cur;
+ if (++cxstack_ix >= block_max) {
+ block_max += 128;
+ Renew(block_stack, block_max, struct loop);
+ }
+ block_stack[cxstack_ix].block_label = "_EVAL_";
+ block_stack[cxstack_ix].block_sp = sp;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d _EVAL_)\n", cxstack_ix);
+ }
+#endif
+ eval_root = Nullcop;
+ if (setjmp(block_stack[cxstack_ix].block_env)) {
+ retval = 1;
+ }
+ else {
+ error_count = 0;
+ if (rsfp) {
+ retval = yyparse();
+ retval |= error_count;
+ }
+ else if (last_root && last_elen == bufend - bufptr
+ && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
+ retval = 0;
+ eval_root = last_root; /* no point in reparsing */
+ }
+ else if (in_eval == 1 && !savecmd) {
+ if (last_root) {
+ Safefree(last_eval);
+ last_eval = Nullch;
+ cop_free(last_root);
+ }
+ last_root = Nullcop;
+ last_elen = bufend - bufptr;
+ last_eval = nsavestr(bufptr, last_elen);
+ retval = yyparse();
+ retval |= error_count;
+ if (!retval)
+ last_root = eval_root;
+ if (!last_root) {
+ Safefree(last_eval);
+ last_eval = Nullch;
+ }
+ }
+ else
+ retval = yyparse();
+ }
+ myroot = eval_root; /* in case cop_exec does another oldeval! */
+
+ if (retval || error_count) {
+ st = stack->av_array;
+ sp = arglast[0];
+ if (gimme != G_ARRAY)
+ st[++sp] = &sv_undef;
+ if (parsing) {
+#ifndef MANGLEDPARSE
+#ifdef DEBUGGING
+ if (debug & 128)
+ fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
+#endif
+ cop_free(eval_root);
+#endif
+ /*SUPPRESS 29*/ /*SUPPRESS 30*/
+ if ((COP*)eval_root == last_root)
+ last_root = Nullcop;
+ eval_root = myroot = Nullcop;
+ }
+ if (rsfp) {
+ fclose(rsfp);
+ rsfp = 0;
+ }
+ }
+ else {
+ parsing = 0;
+ sp = cop_exec(eval_root,gimme,sp);
+ st = stack->av_array;
+ for (i = arglast[0] + 1; i <= sp; i++)
+ st[i] = sv_mortalcopy(st[i]);
+ /* if we don't save result, free zaps it */
+ if (savecmd)
+ eval_root = myroot;
+ else if (in_eval != 1 && myroot != last_root)
+ cop_free(myroot);
+ }
+
+ perldb = oldperldb;
+ in_eval--;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ char *tmps = block_stack[cxstack_ix].block_label;
+ deb("(Popping label #%d %s)\n",cxstack_ix,
+ tmps ? tmps : "" );
+ }
+#endif
+ cxstack_ix--;
+ tmps_floor = oldtmps_floor;
+ curspat = oldspat;
+ lastspat = oldlspat;
+ if (savestack->av_fill > oldsave) /* let them use local() */
+ leave_scope(oldsave);
+
+ if (optype != OP_EVAL) {
+ if (retval) {
+ if (optype == OP_REQUIRE)
+ fatal("%s", SvPV(GvSV(gv_fetchpv("@",TRUE))));
+ }
+ else {
+ curcmd = oldcurcmd;
+ if (gimme == G_SCALAR ? SvTRUE(st[sp]) : sp > arglast[0]) {
+ (void)hv_store(GvHVn(incstab), specfilename,
+ strlen(specfilename), newSVsv(GvSV(curcmd->cop_filestab)),
+ 0 );
+ }
+ else if (optype == OP_REQUIRE)
+ fatal("%s did not return a true value", specfilename);
+ }
+ }
+ curcmd = oldcurcmd;
+ return sp;
+}
+
+int
+do_try(cmd,gimme,arglast)
+COP *cmd;
+int gimme;
+int *arglast;
+{
+ SV **st = stack->av_array;
+
+ COP * VOL oldcurcmd = curcmd;
+ VOL int oldtmps_floor = tmps_floor;
+ VOL int oldsave = savestack->av_fill;
+ PM * VOL oldspat = curspat;
+ PM * VOL oldlspat = lastspat;
+ VOL int sp = arglast[0];
+
+ tmps_floor = tmps_ix;
+ sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
+ in_eval++;
+ if (++cxstack_ix >= block_max) {
+ block_max += 128;
+ Renew(block_stack, block_max, struct loop);
+ }
+ block_stack[cxstack_ix].block_label = "_EVAL_";
+ block_stack[cxstack_ix].block_sp = sp;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d _EVAL_)\n", cxstack_ix);
+ }
+#endif
+ if (setjmp(block_stack[cxstack_ix].block_env)) {
+ st = stack->av_array;
+ sp = arglast[0];
+ if (gimme != G_ARRAY)
+ st[++sp] = &sv_undef;
+ }
+ else {
+ sp = cop_exec(cmd,gimme,sp);
+ st = stack->av_array;
+/* for (i = arglast[0] + 1; i <= sp; i++)
+ st[i] = sv_mortalcopy(st[i]); not needed, I think */
+ /* if we don't save result, free zaps it */
+ }
+
+ in_eval--;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ char *tmps = block_stack[cxstack_ix].block_label;
+ deb("(Popping label #%d %s)\n",cxstack_ix,
+ tmps ? tmps : "" );
+ }
+#endif
+ cxstack_ix--;
+ tmps_floor = oldtmps_floor;
+ curspat = oldspat;
+ lastspat = oldlspat;
+ curcmd = oldcurcmd;
+ if (savestack->av_fill > oldsave) /* let them use local() */
+ leave_scope(oldsave);
+
+ return sp;
+}
+
-/* $RCSfile: eval.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 13:20:20 $
+/* $RCSfile: eval.c,v $$Revision: 4.1 $$Date: 92/08/07 18:20:29 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: eval.c,v $
+ * Revision 4.1 92/08/07 18:20:29 lwall
+ *
* Revision 4.0.1.4 92/06/08 13:20:20 lwall
* patch20: added explicit time_t support
* patch20: fixed confusion between a *var's real name and its effective name
#include "EXTERN.h"
#include "perl.h"
+extern int (*ppaddr[])();
+extern int mark[];
+
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
#endif
# include <vfork.h>
#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 int old_rschar;
-static int old_rslen;
-
double sin(), cos(), atan2(), pow();
char *getlogin();
STR *tmpstr;
FCMD *form;
STAB *stab;
+ STAB *stab2;
+ STIO *stio;
ARRAY *ary;
+ int old_rslen;
+ int old_rschar;
+ VOIDRET (*ihand)(); /* place to save signal during system() */
+ VOIDRET (*qhand)(); /* place to save signal during system() */
bool assigning = FALSE;
- double exp(), log(), sqrt(), modf();
- char *crypt(), *getenv();
- extern void grow_dlevel();
+ int mymarkbase = savestack->ary_fill;
if (!arg)
goto say_undef;
}
#endif
+ if (mark[optype]) {
+ saveint(&markbase);
+ markbase = mymarkbase;
+ saveint(&stack_mark);
+ stack_mark = sp;
+ }
for (anum = 1; anum <= maxarg; anum++) {
argflags = arg[anum].arg_flags;
argtype = arg[anum].arg_type;
re_eval:
switch (argtype) {
default:
- st[++sp] = &str_undef;
+ if (!ppaddr[optype] || optype == O_SUBR || optype == O_DBSUBR) {
+ st[++sp] = &str_undef;
+ }
#ifdef DEBUGGING
tmps = "NULL";
#endif
tmps = str_get(interp(str,argptr.arg_str,sp));
st = stack->ary_array;
#ifdef TAINT
- taintproper("Insecure dependency in ``");
+ TAINT_PROPER("``");
#endif
fp = mypopen(tmps,"r");
str_set(str,"");
break;
}
#ifdef DEBUGGING
- if (debug & 8)
- deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp]));
+ if (debug & 8) {
+ if (strEQ(tmps, "NULL"))
+ deb("%d.%s\n",anum,tmps);
+ else
+ deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp]));
+ }
#endif
if (anum < 8)
arglast[anum] = sp;
}
+ if (ppaddr[optype]) {
+ int status;
+
+ /* pretend like we've been maintaining stack_* all along */
+ stack_ary = stack->ary_array;
+ stack_sp = stack_ary + sp;
+ if (mark[optype] && stack_mark != arglast[0])
+ warn("Inconsistent stack mark %d != %d", stack_mark, arglast[0]);
+ stack_max = stack_ary + stack->ary_max;
+
+ status = (*ppaddr[optype])(str, arg, gimme);
+
+ if (savestack->ary_fill > mymarkbase) {
+ warn("Inconsistent stack base");
+ restorelist(mymarkbase);
+ }
+ sp = stack_sp - stack_ary;
+ if (sp < arglast[0])
+ warn("TOO MANY POPS");
+ st += arglast[0];
+ goto array_return;
+ }
+
st += arglast[0];
+
#ifdef SMALLSWITCHES
if (optype < O_CHOWN)
#endif
}
curoutstab = stab;
fp = stab_io(stab)->ofp;
- debarg = arg;
if (stab_io(stab)->fmt_stab)
form = stab_form(stab_io(stab)->fmt_stab);
else
anum = optype;
str_nset(str, tmps, anum);
if (argtype) { /* it's an lvalue! */
- lstr = (struct lstring*)str;
+ Lstring *lstr = (Lstring*)str;
+
str->str_magic = st[1];
st[1]->str_rare = 's';
lstr->lstr_offset = tmps - str_get(st[1]);
tmps = str_get(tmpstr);
}
#ifdef TAINT
- taintproper("Insecure dependency in chdir");
+ TAINT_PROPER("chdir");
#endif
value = (double)(chdir(tmps) >= 0);
goto donumset;
anum = 0;
else
anum = (int)str_gnum(st[1]);
- exit(anum);
+ my_exit(anum);
goto say_zero;
case O_RESET:
if (maxarg < 1)
if (!*goto_targ)
goto_targ = Nullch; /* just restart from top */
if (optype == O_DUMP) {
- do_undump = 1;
+ do_undump = TRUE;
my_unexec();
}
longjmp(top_env, 1);
if (arglast[2] - arglast[1] == 1) {
taintenv();
tainted |= st[2]->str_tainted;
- taintproper("Insecure dependency in system");
+ TAINT_PROPER("system");
}
#endif
while ((anum = vfork()) == -1) {
#ifdef TAINT
taintenv();
tainted |= st[2]->str_tainted;
- taintproper("Insecure dependency in exec");
+ TAINT_PROPER("exec");
#endif
value = (double)do_exec(str_get(str_mortal(st[2])));
}
}
}
#endif
+ stack_ary = stack->ary_array;
+ stack_max = stack_ary + stack->ary_max;
+ stack_sp = stack_ary + sp;
return sp;
say_yes:
deb("%s RETURNS \"%f\"\n",opname[optype],value);
}
#endif
+ stack_ary = stack->ary_array;
+ stack_max = stack_ary + stack->ary_max;
+ stack_sp = stack_ary + arglast[0] + 1;
return arglast[0] + 1;
#ifdef SMALLSWITCHES
}
anum = umask((int)str_gnum(st[1]));
value = (double)anum;
#ifdef TAINT
- taintproper("Insecure dependency in umask");
+ TAINT_PROPER("umask");
#endif
goto donumset;
#else
tmps = str_get(st[1]);
tmps2 = str_get(st[2]);
#ifdef TAINT
- taintproper("Insecure dependency in rename");
+ TAINT_PROPER("rename");
#endif
#ifdef HAS_RENAME
value = (double)(rename(tmps,tmps2) >= 0);
tmps = str_get(st[1]);
tmps2 = str_get(st[2]);
#ifdef TAINT
- taintproper("Insecure dependency in link");
+ TAINT_PROPER("link");
#endif
value = (double)(link(tmps,tmps2) >= 0);
goto donumset;
tmps = str_get(st[1]);
anum = (int)str_gnum(st[2]);
#ifdef TAINT
- taintproper("Insecure dependency in mkdir");
+ TAINT_PROPER("mkdir");
#endif
#ifdef HAS_MKDIR
value = (double)(mkdir(tmps,anum) >= 0);
else
tmps = str_get(st[1]);
#ifdef TAINT
- taintproper("Insecure dependency in rmdir");
+ TAINT_PROPER("rmdir");
#endif
#ifdef HAS_RMDIR
value = (double)(rmdir(tmps) >= 0);
argtype = (int)str_gnum(st[1]);
anum = (int)str_gnum(st[2]);
#ifdef TAINT
- taintproper("Insecure dependency in setpgrp");
+ TAINT_PROPER("setpgrp");
#endif
value = (double)(setpgrp(argtype,anum) >= 0);
goto donumset;
anum = (int)str_gnum(st[2]);
optype = (int)str_gnum(st[3]);
#ifdef TAINT
- taintproper("Insecure dependency in setpriority");
+ TAINT_PROPER("setpriority");
#endif
value = (double)(setpriority(argtype,anum,optype) >= 0);
goto donumset;
else
tmps = str_get(st[1]);
#ifdef TAINT
- taintproper("Insecure dependency in chroot");
+ TAINT_PROPER("chroot");
#endif
value = (double)(chroot(tmps) >= 0);
goto donumset;
stab = stabent(str_get(st[1]),TRUE);
argtype = U_I(str_gnum(st[2]));
#ifdef TAINT
- taintproper("Insecure dependency in ioctl");
+ TAINT_PROPER("ioctl");
#endif
anum = do_ctl(optype,stab,argtype,st[3]);
if (anum == -1)
(arg[1].arg_type & A_MASK) != A_NULL ? st[1] : stab_val(defstab);
#ifdef TAINT
tainted |= tmpstr->str_tainted;
- taintproper("Insecure dependency in eval");
+ TAINT_PROPER("eval");
#endif
sp = do_eval(tmpstr, optype, curcmd->c_stash, FALSE,
gimme,arglast);
tmps = str_get(st[1]);
tmps2 = str_get(st[2]);
#ifdef TAINT
- taintproper("Insecure dependency in symlink");
+ TAINT_PROPER("symlink");
#endif
value = (double)(symlink(tmps,tmps2) >= 0);
goto donumset;
deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str));
}
#endif
+ stack_ary = stack->ary_array;
+ stack_max = stack_ary + stack->ary_max;
+ stack_sp = stack_ary + arglast[0] + 1;
return arglast[0] + 1;
}
--- /dev/null
+Archive-name: perl-faq/part0
+Version: $Id: faq,v 1.1 92/11/30 05:12:22 tchrist Exp Locker: tchrist $
+
+This article contains the table of contents to some of the most
+frequently asked questions in comp.lang.perl, a newsgroup devoted to
+the Perl programming language. There are two pieces following
+this, the general information questions in part1 and the largely
+technical opnes in part2.
+
+They're all good questions, but they come up often enough that
+substantial net bandwidth can be saved by looking here first before
+asking. Before posting a question, you really should consult the Perl
+man page; there's a lot of information packed in there.
+
+Some questions in this group aren't really about Perl, but rather
+about system-specific issues. You might also consult the Most
+Frequently Asked Questions list in comp.unix.questions for answers
+to this type of question.
+
+The current version of perl is 4.035 (version 4, patchlevel 35).
+There haven't actually been 35 updates to perl4; rather, the context
+diffs posted to the net have been broken up into 35 news-digestable
+chunks.
+
+This list is maintained by Tom Christiansen, and is archived on
+convex.com [130.168.1.1] in the file pub/perl/info/faq. If you
+have any suggested additions or corrections to this article, please
+send them to Tom at either <tchrist@convex.com> or <convex!tchrist>.
+Special thanks to Larry Wall for initially reviewing this list for
+accuracy and especially for writing and releasing Perl in the first place.
+
+
+1.1) What is Perl?
+1.2) Is Perl hard to learn?
+1.3) Should I program everything in Perl?
+1.4) Where can I get Perl over the Internet?
+1.5) Where can I get Perl via Email?
+1.6) How can I get Perl via UUCP?
+1.7) Where can I get more information on Perl?
+1.8) Can people who aren't on USENET receive comp.lang.perl as a digest?
+1.9) Are archives of comp.lang.perl available?
+1.10) How do I get Perl to run on machine FOO?
+1.11) Where can I get (info|inter|ora|sql|syb)perl?
+1.12) There's an a2p and an s2p; why isn't there a p2c (perl-to-C)?
+1.13) Where can I get undump for my machine?
+1.14) Where can I get a perl-mode for emacs?
+1.15) How can I use Perl interactively?
+1.16) Is there a Perl shell?
+1.17) Is there a Perl profiler?
+1.18) Is there a yacc for Perl?
+1.19) How can I use curses with perl?
+1.20) How can I use X with Perl?
+1.21) What is perl4? What is perl5?
+1.22) How does Perl compare with languages like REXX or TCL?
+1.23) Is it a Perl program or a Perl script?
+1.24) What's the difference between "Perl" and "perl"?
+1.25) What companies use or ship Perl?
+1.26) Is there commercial, 3rd-party support for Perl?
+1.27) Where can I get a list of the JAPH signature quotes?
+1.28) Where can I get a list of Larry Wall witticisms?
+
+2.1) What are all these $@*%<> signs and how do I know when to use them?
+2.2) Why don't backticks work as they do in shells?
+2.3) How come Perl operators have different precedence than C operators?
+2.4) How come my converted awk/sed/sh script runs more slowly in Perl?
+2.5) How can I call my system's unique C functions from Perl?
+2.6) Where do I get the include files to do ioctl() or syscall()?
+2.7) Why doesn't "local($foo) = <FILE>;" work right?
+2.8) How can I detect keyboard input without reading it?
+2.9) How can I make an array of arrays or other recursive data types?
+2.10) How can I quote a variable to use in a regexp?
+2.11) Why do setuid Perl scripts complain about kernel problems?
+2.12) How do I open a pipe both to and from a command?
+2.13) How can I change the first N letters of a string?
+2.14) How can I manipulate fixed-record-length files?
+2.15) How can I make a file handle local to a subroutine?
+2.16) How can I extract just the unique elements of an array?
+2.17) How can I call alarm() or usleep() from Perl?
+2.18) How can I test whether an array contains a certain element?
+2.19) How can I do an atexit() or setjmp()/longjmp() in Perl?
+2.20) Why doesn't Perl interpret my octal data octally?
+2.21) How do I sort an associative array by value instead of by key?
+2.22) How can I capture STDERR from an external command?
+2.23) Why doesn't open return an error when a pipe open fails?
+2.24) How can I compare two date strings?
+2.25) What's the fastest way to code up a given task in perl?
+2.26) How can I know how many entries are in an associative array?
+2.27) Why can't my perl program read from STDIN after I gave it ^D (EOF) ?
+2.28) Do I always/never have to quote my strings or use semicolons?
+2.29) How can I translate tildes in a filename?
+2.30) How can I convert my shell script to Perl?
+2.31) What is variable suicide and how can I prevent it?
+2.32) Can I use Perl regular expressions to match balanced text?
+2.33) Can I use Perl to run a telnet or ftp session?
+2.34) What does "Malformed command links" mean?
+
+
+
+1.1) What is Perl?
+
+ A programming language, by Larry Wall <lwall@netlabs.com>.
+
+ Here's the beginning of the description from the man page:
+
+ Perl is an interpreted language optimized for scanning arbitrary text
+ files, extracting information from those text files, and printing reports
+ based on that information. It's also a good language for many system
+ management tasks. The language is intended to be practical (easy to use,
+ efficient, complete) rather than beautiful (tiny, elegant, minimal). It
+ combines (in the author's opinion, anyway) some of the best features of C,
+ sed, awk, and sh, so people familiar with those languages should have
+ little difficulty with it. (Language historians will also note some
+ vestiges of csh, Pascal, and even BASIC-PLUS.) Expression syntax
+ corresponds quite closely to C expression syntax. Unlike most Unix
+ utilities, Perl does not arbitrarily limit the size of your data--if
+ you've got the memory, Perl can slurp in your whole file as a single
+ string. Recursion is of unlimited depth. And the hash tables used by
+ associative arrays grow as necessary to prevent degraded performance.
+ Perl uses sophisticated pattern matching techniques to scan large amounts
+ of data very quickly. Although optimized for scanning text, Perl can also
+ deal with binary data, and can make dbm files look like associative arrays
+ (where dbm is available). Setuid Perl scripts are safer than C programs
+ through a dataflow tracing mechanism which prevents many stupid security
+ holes. If you have a problem that would ordinarily use sed or awk or sh,
+ but it exceeds their capabilities or must run a little faster, and you
+ don't want to write the silly thing in C, then Perl may be for you. There
+ are also translators to turn your sed and awk scripts into Perl scripts.
+
+
+1.2) Is Perl hard to learn?
+
+ No, Perl is easy to learn for two reasons.
+
+ The first reason is that most of Perl is derived from existing tools
+ and languages, ones that many people who turn to Perl already have
+ some familiarity with. These include the C programming language, the
+ UNIX C library, the UNIX shell, sed, and awk. If you already know
+ these somewhat, Perl should be very easy for you.
+
+ The second reason that Perl is easy to learn is that you don't have to
+ know every thing there is to know about it in order to get good use
+ out of it. In fact, just a very small subset, mostly borrowed from C,
+ the shell, and sed, will be enough for most tasks. As you feel the
+ need or desire to use more sophisticated features (such as C
+ structures or networking), you can learn these as you go. The
+ learning curve for Perl is not a steep one, especially if you have
+ the headstart of having a background in UNIX. Rather, its learning
+ curve is gentle and gradual, but it *is* admittedly rather long.
+
+ If you don't know C or UNIX at all, it'll be a steeper learning curve,
+ but what you then learn from Perl will carry over into other areas,
+ like using the C library, UNIX system call, regular expressions, and
+ associative arrays, just to name a few. To know Perl is to know
+ UNIX, and vice versa.
+
+
+1.3) Should I program everything in Perl?
+
+ Of course not. You should choose the appropriate tool for the task at
+ hand. While it's true that the answer to the question "Can I do (some
+ arbitrary task) in Perl?" is almost always "yes", that doesn't mean
+ this is necessarily a good thing to do. For many people, Perl serves
+ as a great replacement for shell programming. For a few people, it
+ also serves as a replacement for most of what they'd do in C. But
+ for some things, Perl just isn't the optimal choice, such as tasks
+ requiring very complex data structures.
+
+
+1.4) Where can I get Perl over the Internet?
+
+ From any comp.sources.misc archive. Initial sources were posted to
+ Volume 18, Issues 19-54 at patchlevel 3. The Patches 4-10 were posted
+ to Volume 20, Issues 56-62. You can use the archie server
+ (see the alt.sources FAQ in news.answers) for ways to find these.
+
+ These machines, at the very least, definitely have it available for
+ anonymous FTP:
+
+ ftp.uu.net 137.39.1.2
+ archive.cis.ohio-state.edu 128.146.8.52
+ jpl-devvax.jpl.nasa.gov 128.149.1.143
+ ftp.netlabs.com 192.94.48.152
+ prep.ai.mit.edu 18.71.0.38
+ archive.cs.ruu.nl 131.211.80.5 (Europe)
+
+
+
+
+1.5) Where can I get Perl via Email?
+
+ If you are in Europe, you might using the following site. (I'm still
+ looking for a domestic site.) This information thanks to "Henk P.
+ Penning" <henkp@cs.ruu.nl>: One automated fashion is as follows:
+
+ Email: Send a message to 'mail-server@cs.ruu.nl' containing:
+ begin
+ path your_email_address
+ send help
+ send PERL/INDEX
+ end
+ The path-line may be omitted if your message contains a normal From:-line.
+ You will receive a help-file and an index of the directory that contains
+ the Perl stuff.
+
+ If all else fails, mail to Larry usually suffices.
+
+
+1.6) How can I get Perl via UUCP?
+
+ You can get it from the site osu-cis; here is the appropriate info,
+ thanks to J Greely <jgreely@cis.ohio-state.edu> or <osu-cis!jgreely>.
+
+ E-mail contact:
+ osu-cis!uucp
+ Get these two files first:
+ osu-cis!~/GNU.how-to-get.
+ osu-cis!~/ls-lR.Z
+ Current Perl distribution:
+ osu-cis!~/perl/4.0/kits@10/perl.kitXX.Z (XX=01-37)
+ How to reach osu-cis via uucp(L.sys/Systems file lines):
+ #
+ # Direct Trailblazer
+ #
+ osu-cis Any ACU 19200 1-614-292-5112 in:--in:--in: Uanon
+ #
+ # Direct V.32 (MNP 4)
+ # dead, dead, dead...sigh.
+ #
+ #osu-cis Any ACU 9600 1-614-292-1153 in:--in:--in: Uanon
+ #
+ # Micom port selector, at 1200, 2400, or 9600 bps.
+ # Replace ##'s below with 12, 24, or 96 (both speed and phone number).
+ #
+ osu-cis Any ACU ##00 1-614-292-31## "" \r\c Name? osu-cis nected \c GO \d\r\d\r\d\r in:--in:--in:
+ Uanon
+
+ Modify as appropriate for your site, of course, to deal with your
+ local telephone system. There are no limitations concerning the hours
+ of the day you may call.
+
+ Another possibility is to use UUNET, although they charge you
+ for it. You have been duly warned. Here's the advert:
+
+ Anonymous Access to UUNET's Source Archives
+
+ 1-900-GOT-SRCS
+
+ UUNET now provides access to its extensive collection of UNIX
+ related sources to non- subscribers. By calling 1-900-468-7727
+ and using the login "uucp" with no password, anyone may uucp any
+ of UUNET's on line source collection. Callers will be charged 40
+ cents per minute. The charges will appear on their next tele-
+ phone bill.
+
+ The file uunet!/info/help contains instructions. The file
+ uunet!/index//ls-lR.Z contains a complete list of the files available
+ and is updated daily. Files ending in Z need to be uncompressed
+ before being used. The file uunet!~/compress.tar is a tar
+ archive containing the C sources for the uncompress program.
+
+ This service provides a cost effective way of obtaining
+ current releases of sources without having to maintain accounts
+ with UUNET or some other service. All modems connected to the
+ 900 number are Telebit T2500 modems. These modems support all
+ standard modem speeds including PEP, V.32 (9600), V.22bis (2400),
+ Bell 212a (1200), and Bell 103 (300). Using PEP or V.32, a 1.5
+ megabyte file such as the GNU C compiler would cost $10 in con-
+ nect charges. The entire 55 megabyte X Window system V11 R4
+ would cost only $370 in connect time. These costs are less than
+ the official tape distribution fees and they are available now
+ via modem.
+
+ UUNET Communications Services
+ 3110 Fairview Park Drive, Suite 570
+ Falls Church, VA 22042
+ +1 703 876 5050 (voice)
+ +1 703 876 5059 (fax)
+ info@uunet.uu.net
+
+
+
+1.7) Where can I get more information on Perl?
+
+ We'll cover five areas here: USENET (where you're probably reading
+ this), publications, the reference guide, examples on the Internet,
+ and Perl instructional courses.
+
+ A. USENET
+
+ You should definitely read the USENET comp.lang.perl newsgrouor
+ mailing list for all sorts of discussions regarding the language,
+ bugs, features, history, humor, and trivia. In this respect, it
+ functions both as a comp.lang.* style newsgroup and also as a user
+ group for the language; in fact, there's a mailing list called
+ ``perl-users'' that is bidirectionally gatewayed to the newsgroup; see
+ question #38 for details. Larry Wall is a very frequent poster here,
+ as well as many (if not most) of the other seasoned Perl programmers.
+ It's the best place for the very latest information on Perl.
+
+ B. PUBLICATIONS
+
+ If you've been dismayed by the ~80-page troffed Perl man page (or is
+ that man treatise?) you should look to ``the Camel Book'', written by
+ Larry and Randal L. Schwartz <merlyn@ora.com>, published as a Nutshell
+ Handbook by O'Reilly & Associates and entitled _Programming Perl_.
+ Besides serving as a reference guide for Perl, it also contains
+ tutorial material and is a great source of examples and cookbook
+ procedures, as well as wit and wisdom, tricks and traps, pranks and
+ pitfalls. The code examples contained therein are available via
+ anonymous FTP from ftp.uu.net in
+ /published/oreilly/nutshell/perl/perl.tar.Z for your retrieval.
+ Corrections and additions to the book can be found in the Perl man
+ page right before the BUGS section under the heading ERRATA AND
+ ADDENDA.
+
+ If you can't find the book in your local technical bookstore, the book
+ may be ordered directly from O'Reilly by calling 1-800-998-9938 if in
+ North America and 1-707-829-0515. Autographed copies are available
+ from TECHbooks by calling 1-503-646-8257 or mailing info@techbook.com.
+ Cost is ~30$US for the regular version, 40$US for the autographed one.
+ The book's ISBN is 0-937175-64-1.
+
+ Reasonably substantiated rumor has it that there will be another Perl
+ book out pretty soon, this one aimed more at beginners. Look for it
+ from ORA towards the beginning of 93.
+
+ Larry Wall has published a 3-part article on perl in Unix World
+ (August through October of 1991), and Rob Kolstad also had a 3-parter
+ in Unix Review (May through July of 1990). Tom Christiansen also has
+ a brief overview article in the trade newsletter Unix Technology
+ Advisor from November of 1989. You might also investigate "The Wisdom
+ of Perl" by Gordon Galligher from SunExpert magazine; April 1991
+ Volume 2 Number 4.
+
+ The USENIX LISA (Large Installations Systems Adminstration) Conference
+ have for several years now included many papers of tools written in
+ Perl. Old proceedings of these conferences are available; look in
+ your current issue of ";login:" or send mail to office@usenix.org
+ for futher information.
+
+ C. INTERNET
+
+ For other examples of Perl scripts, look in the Perl source directory in
+ the eg subdirectory. You can also find a good deal of them on
+ tut.cis.ohio-state.edu in the pub/perl/scripts/ subdirectory.
+
+ Another source for examples, currently only for anonymous FTP, is on
+ convex.com [130.168.1.1]. This contains, amongst other things,
+ a copy of the newsgroup up through Aug 91, a text retrieval database
+ for the newsgroup, a rather old and short troff version of Tom Christiansen's
+ perl tutorial (this was the version presented at Washington DC USENIX),
+ and quite a few of Tom's scripts. You can look at the INDEX file
+ in /pub/perl/INDEX for a list of what's in that directory.
+
+ The Convex and Ohio State archives are mirrored on uunet
+ in /languages/perl/scripts-{convex,osu}.
+
+ D. REFERENCE GUIDE
+
+ A nice reference guide by Johan Vromans <jv@mh.nl> is also available;
+ It is distributed in LaTeX (source) and PostScript (ready to
+ print) forms. Obsolete versions may still be available in TeX and troff
+ forms, although these don't print as nicely. The official kit
+ includes both LaTeX and PostScript forms, and can be FTP'd from
+ archive.cs.ruu.nl [131.211.80.5], file /pub/DOC/perlref-4.035.tar.Z.
+ The reference guide comes with the O'Reilly book in a nice, glossy
+ card format.
+
+ E. PERL COURSES
+
+ Various technical conferences, including USENIX, SUG, WCSAS, AUUG,
+ FedUnix, and Europen have been sponsoring tutorials of varying lengths
+ on Perl at their system administration and general conferences. You
+ might consider attending one of these. These classes are typically
+ taught by Tom Christiansen <tchrist@usenix.com>, although both Rob
+ Kolstad <kolstad@usenix.org> and Randal Schwartz <merlyn@ora.com> also
+ teach Perl on occasion. Special appearances by Tom, Rob, and/or
+ Randal may also be negotiated. Classes can run from one day up to a
+ week ranging over a wide range of subject matter (most are two or
+ three days), and can include lab time if you want; having lab time
+ with exercises is generally of great benefit. Send us mail if your
+ organization is interested in having a Perl class taught at your site.
+
+
+1.8) Can people who aren't on USENET receive comp.lang.perl as a digest?
+
+ "Perl-Users" is the mailing list version of the comp.lang.perl
+ newsgroup. If you're not lucky enough to be on USENET you can post to
+ comp.lang.perl by sending to one of the following addresses. Which one
+ will work best for you depends on which nets your site is hooked into.
+ Ask your local network guru if you're not certain.
+
+ Internet: PERL-USERS@VIRGINIA.EDU
+ Perl-Users@UVAARPA.VIRGINIA.EDU
+
+ BitNet: Perl@Virginia
+
+ uucp: ...!uunet!virginia!perl-users
+
+ The Perl-Users list is bidirectionally gatewayed with the USENET
+ newsgroup comp.lang.perl. This means that VIRGINIA functions as a
+ reflector. All traffic coming in from the non-USENET side is
+ immediately posted to the newsgroup. Postings from the USENET side are
+ periodically digested and mailed out to the Perl-Users mailing list. A
+ digest is created and distributed at least once per day, more often if
+ traffic warrants.
+
+ All requests to be added to or deleted from this list, problems,
+ questions, etc., should be sent to:
+
+ Internet: Perl-Users-Request@Virginia.EDU
+ Perl-Users-Request@uvaarpa.Virginia.EDU
+
+ BitNet: Perl-Req@Virginia
+
+ uucp: ...!uunet!virginia!perl-users-request
+
+ Coordinator: Marc Rouleau <mer6g@VIRGINIA.EDU>
+
+1.9) Are archives of comp.lang.perl available?
+
+ Yes, although they're poorly organized. You can get them from
+ the host betwixt.cs.caltech.edu (131.215.128.4) in the directory
+ /pub/comp.lang.perl. They are also to uunet in
+ /languages/perl/comp.lang.perl . It contains these things:
+
+ comp.lang.perl.tar.Z -- the 5M tarchive in MH/news format
+ archives/ -- the unpacked 5M tarchive
+ unviewed/ -- new comp.lang.perl messages
+
+ These are currently stored in news- or MH-style format; there are
+ subdirectories named things like "arrays", "programs", "taint", and
+ "emacs". Unfortunately, only the first ~1600 or so messages have been
+ so categorized, and we're now up to almost 15000. Furthermore, even
+ this categorization was haphazardly done and contains errors.
+
+ A more sophisticated query and retrieval mechanism is desirable.
+ Preferably one that allows you to retrieve article using a fast-access
+ indices, keyed on at least author, date, subject, thread (as in "trn")
+ and probably keywords. Right now, the MH pick command works for this,
+ but it is very slow to select on 15000 articles.
+
+ If you're serious about this, your best bet is probably to retrieve
+ the compressed tarchive and play with what you get. Any suggestions
+ how to better sort this all out are extremely welcome.
+
+ Currently the comp.lang.perl archives on convex.com are nearly a year
+ behind. That's because I no longer have room to store them there. I
+ do have them all on-line still, but they are not publicly accessible.
+ If you have a special request for a query on the old newsgroup
+ postings, and make nice noises in my direction, I can run the query
+ and send them to you. Algebraic queries are like "find me anything
+ about this and that and the other thing but not this or whozits". I
+ hope to put this in the form of a mailserver. Donated software would
+ be fine. :-)
+
+ The fast text-retrieval query system for this I'm currently using is
+ Liam Quin's excellent lqtext system, available from ftp.toronto.edu
+ in /pub/lq-text* .
+
+ Rumor has it that there are WAIS servers out there for comp.lang.perl
+ these days, but I haven't used them.
+
+
+1.10) How do I get Perl to run on machine FOO?
+
+ Perl comes with an elaborate auto-configuration script that allows Perl
+ to be painlessly ported to a wide variety of platforms, including many
+ non-UNIX ones. Amiga and MS-DOS binaries are available on
+ jpl-devvax.jpl.nasa.gov [128.149.1.143] for anonymous FTP. Try to bring
+ Perl up on your machine, and if you have problems, examine the README
+ file carefully, and if all else fails, post to comp.lang.perl;
+ probably someone out there has run into your problem and will be able
+ to help you.
+
+ In particular, since they're so often asked about, here's some information
+ for the MacIntosh from Matthias Ulrich Neeracher <neeri@iis.ethz.ch>:
+
+ A port of Perl to the Apple Macintosh is available by anonymous
+ ftp to rascal.ics.utexas.edu from the file
+ ~ftp/mac/programming/Perl_402_MPW_CPT_bin .
+
+ The file is 1.1M and must be transferred in BINARY mode. Please
+ be considerate of RASCAL's users during CDT working hours.
+ (And, no, there is no way to get it by email).
+
+ For European users, the file should soon appear on lth.se.
+
+ To make optimal use of all the features of this port, you
+ should have MPW, ToolServer, and 5M of memory. There is also a
+ standalone version included, but it's currently of very limited
+ usefulness.
+
+ This package contains all of the sources for compilation with
+ MPW C 3.2
+
+ And here's some VMS information from Rao V. Akella
+ <rao@moose.cccs.umn.edu>: (this appears to be an old port)
+
+ You can pick up Perl for VMS (version 3.0.1.1 patchlevel 4) via
+ anonymous ftp from ftp.pitt.edu [130.49.253.1] in the
+ software/vms/perl subdirectory (there are two files there:
+ perl-pl18.bck and perl-pl4.bck).
+
+ There is also a v3.018 on info.rz.uni-ulm.de [134.60.1.125] or
+ vms.huji.ac.il [128.139.4.3] in /pub/VMS/misc (information courtesy
+ of Anders Rolff <rolff@scotty.eurokom.ie>).
+
+ And here is a recent version for MS-DOS from Budi Rahard
+ <rahard@ee.UManitoba.CA>, who says:
+
+ I am collecting MS-DOS Perl(s) in ftp.ee.umanitoba.ca directory
+ /pub/msdos/perl. Currently I received three versions of Perl v4.019
+ and one of 4.010. (Tommy Thorn <tthorn@daimi.aau.dk> and Len Reed
+ <holos0!lbr@gatech.edu>)
+
+ There is now a 4.035 for 386 [DOS], Hitoshi Doi <doi@jrd.december.com>
+ port, is available ftp.ee.umanitoba.ca as /pub/msdos/perl/perl386.zoo .
+
+ Please contact the porters directly in case of questions about
+ these ports.
+
+
+1.11) Where can I get (info|inter|ora|sql|syb)perl?
+
+ Numerous database-oriented extensions to Perl have been written.
+ These amount to using the usub mechanism (see the usub/ subdirectory
+ in the distribution tree) to link in a database library, allowing
+ embedded calls to Informix, Interbase, Oracle, Ingres, and Sybase.
+ There is currently a project underway, organized by Buzz Moschetti
+ <buzz@toxicavenger.bear.com>, to create a higher level interface
+ (DBperl) that will allow you to write your queries in a
+ database-independent fashion. Meanwhile, here are the authors of the
+ various extensions:
+
+ What Target DB Who
+ -------- ----------- ----------------------------------------
+ Infoperl Informix Kurt Andersen (kurt@hpsdid.sdd.hp.com)
+ Interperl Interbase Buzz Moschetti (buzz@fsrg.bear.com)
+ Oraperl Oracle Kevin Stock (kstock@encore.com)
+ Sqlperl Ingres Ted Lemon (mellon@ncd.com)
+ Sybperl Sybase Michael Peppler (mpeppler@itf.ch)
+
+
+1.12) There's an a2p and an s2p; why isn't there a p2c (perl-to-C)?
+
+ Because the Pascal people would be upset that we stole their name. :-)
+
+ The dynamic nature of Perl's do and eval operators (and remember that
+ constructs like s/$mac_donald/$mac_gregor/eieio count as an eval) would
+ make this very difficult. To fully support them, you would have to put
+ the whole Perl interpreter into each compiled version for those scripts
+ using them. This is what undump does right now, if your machine has it.
+ If what you're doing will be faster in C than in Perl, maybe it should
+ have been written in C in the first place. For things that ought to be
+ written in Perl, the interpreter will be just about as fast, because the
+ pattern matching routines won't work any faster linked into a C program.
+ Even in the case of simple Perl programs that don't do any fancy evals, the
+ major gain would be in compiling the control flow tests, with the rest
+ still being a maze of twisty, turny subroutine calls. Since these are not
+ usually the major bottleneck in the program, there's not as much to be
+ gained via compilation as one might think.
+
+
+1.13) Where can I get undump for my machine?
+
+ The undump program comes from the TeX distribution. If you have TeX, then
+ you may have a working undump. If you don't, and you can't get one,
+ *AND* you have a GNU emacs working on your machine that can clone itself,
+ then you might try taking its unexec() function and compiling Perl with
+ -DUNEXEC, which will make Perl call unexec() instead of abort(). You'll
+ have to add unexec.o to the objects line in the Makefile. If you succeed,
+ post to comp.lang.perl about your experience so others can benefit from it.
+
+
+1.14) Where can I get a perl-mode for emacs?
+
+ In the perl4.0 source directory, you'll find a directory called
+ "emacs", which contains several files that should help you.
+
+
+1.15) How can I use Perl interactively?
+
+ The easiest way to do this is to run Perl under its debugger.
+ If you have no program to debug, you can invoke the debugger
+ on an `empty' program like this:
+
+ perl -de 0
+
+ (The more positive amongst us prefer "perl -de 1". :-)
+
+ Now you can type in any legal Perl code, and it will be immediately
+ evaluated. You can also examine the symbol table, get stack
+ backtraces, check variable Values, and if you want to, set
+ breakpoints and do the other things you can do in a symbolic debugger.
+
+
+1.16) Is there a Perl shell?
+
+ Not really. Perl is a programming language, not a command
+ interpreter. There is a very simple one called "perlsh"
+ included in the Perl source distribution. It just does this:
+
+ $/ = ''; # set paragraph mode
+ $SHlinesep = "\n";
+ while ($SHcmd = <>) {
+ $/ = $SHlinesep;
+ eval $SHcmd; print $@ || "\n";
+ $SHlinesep = $/; $/ = '';
+ }
+
+ Not very interesting, eh?
+
+ Daniel Smith <dansmith@autodesk.com> is working on an interactive Perl
+ shell called SoftList. It's currently at version 3.0beta. SoftList
+ 3.0 has tcsh-like command line editing, can let you define a file of
+ aliases so that you can run chunks of perl or UNIX commands, and so
+ on. You can send mail to him for further information and availability.
+
+
+1.17) Is there a Perl profiler?
+
+ While there isn't one included with the perl source distribution,
+ various folks have written packages that allow you to do at least some
+ sort of profiling. The strategy usually includes modifying the perl
+ debugger to handle profiling. Authors of these packages include
+
+ Wayne Thompson <me@anywhere.EBay.Sun.COM>
+ Ray Lischner <lisch@sysserver1.mentor.com>
+ Kresten Krab Thorup <krab@iesd.auc.dk>
+
+ The original articles by these folks containing their
+ profilers are available on convex.com in
+ /pub/perl/information/profiling.shar via anon ftp.
+
+
+1.18) Is there a yacc for Perl?
+
+ Yes!! It's a version of Berkeley yacc that outputs Perl code instead
+ of C code! You can get this from ftp.sterling.com [192.124.9.1] in
+ /local/perl-byacc1.8.1.tar.Z, or send the author mail for details.
+
+
+1.19) How can I use curses with perl?
+
+ One way is to build a curseperl binary by linking in your C curses
+ library as described in the usub subdirectory of the perl sources.
+ This requires a modicum of work, but it will be reasonably fast
+ since it's all in C (assuming you consider curses reasonably fast. :-)
+ Programs written using this method require the modified curseperl,
+ not vanilla perl, to run. While this is something of a disadvantage,
+ experience indicates that it's better to use curseperl than to
+ try to roll your own using termcap directly.
+
+ Another possibility is to use Henk Penning's cterm package, a curses
+ emulation library written in perl. cterm is actually a separate
+ program with which you communicate via a pipe. It is available from
+ archive.cs.ruu.nl [131.211.80.5] via anonymous ftp in the directory
+ pub/PERL. You may also acquire the package via email in compressed,
+ uuencoded form by sending a message to mail-server@cs.ruu.nl
+ containing these lines:
+
+ begin
+ send PERL/cterm.shar.Z
+ end
+
+ See the question on retrieving perl via mail for more information on
+ how to get retrieve other items of interest from the mail server
+ there.
+
+
+1.20) How can I use X with Perl?
+
+ Right now, you have several choices. You can wait for perl5, use
+ the WAFE or STDWIN packages, or try to make your own usub bindings.
+
+ Perl5 is anticipated to be released with bindings for X, called
+ guiperl. An exciting prototype for this, written by Jon Biggar
+ <jon@netlabs.com>, Larry's *other* brother-in-law and officemate,
+ is already up and running inside of Netlabs. This program addresses
+ the same dynamic gui-building problem space as does tcl/tk.
+
+ If you can't wait or don't think that guiperl will do what you want,
+ a stab at Motif bindings was begun by Theodore C. Law
+ <TEDLAW@TOROLAB6.VNET.IBM.COM> area. His article about this is
+ on convex.com in /pub/perl/info/motif for anon ftp.
+
+ STDWIN is a library written by Guido van Rossum <guido@cwi.nl>
+ (author of the Python programming language) that is portable
+ between Mac, Dos and X11. One could write a Perl agent to
+ speak to this STDIN server.
+
+ WAFE is a package that implements a symbolic interface to the Athena
+ widgets (X11R5). A typical Wafe application consists in our framework
+ of two parts: the front-end (we call it Wafe for Widget[Athena]front
+ end) and an application program running typically as separate process.
+ The application program can be implemented in an arbitrary programming
+ language and talks to the front-end via stdio. Since Wafe (the
+ front-end) was developed using the extensible TCL shell (cite John
+ Ousterhout), an application program can dynamically submit requests to
+ the front-end to build up the graphical user interface; the
+ application can even down-load application specific procedures into
+ the front-end. The distribution contains sample application programs
+ in Perl, GAWK, Prolog, TCL, and C talking to the same Wafe binary.
+ Many of the demo applications are implemented in Perl. Wafe 0.9 can
+ be obtained via anonymous ftp from
+ ftp.wu-wien.ac.at:pub/src/X11/wafe-0.9.tar.Z
+ (for people without name server: the ip address is 137.208.3.5)
+
+
+1.21) What is perl4? What is perl5?
+
+ The answer to what is perl4 is nearly anything you might otherwise
+ program in shell or C. The answer to what is perl5 is basically
+ Perl: the Next Generation. In fact, it's essentially a complete
+ rewrite of perl from the bottom up, and back again.
+
+ Larry gave a talk on perl5 at a Bay LISA meeting as well as at the
+ most recent USENIX LISA conference in Long Beach in which he timorously
+ admitted that perl5 might possibly be beta released in early 1993.
+ He enumerated some of the following features. Note that not only have
+ not all these been implemented yet, the ones further down the list
+ might well not get done at all.
+
+ a faster, tighter, more flexible interpreter
+ very easy GUI Perl applications using X bindings ("guiperl")
+ embeddable Perl code in C code: cc prog.c -lperl
+ multiple coresident perl interpreters:
+ perhaps threading and/or coroutines
+ named argument passing:
+ some_func( OC => $red, TOF => "\f");
+ recursive lists:
+ [a, b, [c, d], e] has 4 elts, the 3rd being itself a list
+ typed pointers and generalized indirection:
+ like @{$aptr} or &{$fptr} or &{ $table[$index] . "func" }().
+ merging of list operator and function calling syntax:
+ split /pat/, $string;
+ subroutines without &'s: myfunc($arg);
+ generalization of dbm binding for assoc arrays to handle
+ any generic fetch/store/open/close/flush package.
+ (thus allowing both dbm and gdbm at once)
+ object oriented programming:
+ STDOUT->flush(1);
+ give dog $bone;
+ lexical scoping
+ dynamic loading of C libraries for systems that can
+ byte-compiled code for speed and maybe security
+
+ It's tempting to want this stuff soon, since the sooner it comes
+ out the sooner we can all build really cool applications. But the
+ longer Larry works on it, the more items from this list will actually
+ get done, and the more robust the release will be. So let's not
+ ask him about it too often.
+
+
+1.22) How does Perl compare with languages like REXX or TCL?
+
+ REXX is an interpreted programming language first seen on IBM systems,
+ and TCL is John Ousterhout's embeddable command language. TCL's most
+ intriguing feature for many people is the tcl/tk toolset that allows
+ for interpreted X-based tools.
+
+ To avoid any flamage, if you really want to know the answer to this
+ question, probably the best thing to do is try to write equivalent
+ code to do a set of tasks. All three have their own newsgroups in
+ which you can learn about (but hopefully not argue about) these
+ languages.
+
+ To find out more about these or other languages, you might also check
+ out David Muir Sharnoff <muir@tfs.com>'s posting on "Catalog of
+ compilers, interpreters, and other language tools" which he posts to
+ comp.lang.misc, comp.sources.d, comp.archives.admin, and the
+ news.answers newsgroups. It's a comprehensive treatment of many
+ different languages. (Caveat lector: he considers Perl's syntax
+ "unappealing".) This list is archived on convex.com in
+ /pub/perl/info/lang-survey.shar .
+
+
+1.23) Is it a Perl program or a Perl script?
+
+ Certainly. :-)
+
+ Current UNIX parlance holds that anything interpreted
+ is a script, and anything compiled into native machine
+ code is a program. However, others hold that a program
+ is a program is a program: after all, one seldom discusses
+ scripts written in BASIC or LISP. Larry considers it
+ a program if it's set in stone and you can't change it,
+ whereas if you go in and hack on it, then it's a script.
+
+ But doesn't really matter. The terms are generally
+ interchangeable today.
+
+
+1.24) What's the difference between "Perl" and "perl"?
+
+ 32 :-) [ ord('p') - ord('P') ]
+
+ Larry now uses "Perl" to signify the language proper and "perl" the
+ implementation of it, i.e. the current interpreter. Hence my quip
+ that "Nothing but perl can parse Perl."
+
+ On the other hand, the aesthetic value of casewise parallelism
+ in "awk", "sed", and "perl" as much require the lower-case
+ version as "C", "Pascal", and "Perl" require the
+ upper-case version. It's also easier to type "Perl" in
+ typeset print than to be constantly switching in Courier. :-)
+
+ In other words, it doesn't matter much, especially if all
+ you're doing is hearing someone talk about the language;
+ case is hard to distingish aurally.
+
+
+1.25) What companies use or ship Perl?
+
+ At this time, the known list includes at least the following: Convex,
+ Netlabs, BSDI, Integraph, Dell, and Kubota Pacific, although the
+ latter is in /usr/contrib only. Many other companies use Perl
+ internally for purposes of tools development, systems administration,
+ installation scripts, and test suites. Rumor has it that the large
+ workstation vendors (the TLA set) are seriously looking into shipping
+ Perl with their standard systems "soon".
+
+ People with support contracts with their vendors are actively
+ encouraged to submit enhancement requests that Perl be shipped
+ as part of their standard system. It would, at the very least,
+ reduce the FTP load on the Internet. :-)
+
+1.26) Is there commercial, 3rd-party support for Perl?
+
+ No. Although perl is included in the GNU distribution, at last check,
+ Cygnus does not offer support for it. However, it's unclear whether
+ they've ever been offered sufficient financial incentive to do so.
+
+ On the other hand, you do have comp.lang.perl as a totally gratis
+ support mechanism. As long as you ask "interesting" questions,
+ you'll probably get plenty of help. :-)
+
+1.27) Where can I get a list of the JAPH signature quotes?
+
+ These are the "just another perl hacker" signatures that
+ some people sign their postings with. About 100 of the
+ of the earlier ones are on convex.com in /pib/perl/info/japh.
+
+1.28) Where can I get a list of Larry Wall witticisms?
+
+ Over a hundred quips by Larry, from postings of his or source code,
+ can be found on convex.com in /pub/perl/info/lwall-quotes.
+
+
+
+
+2.1) What are all these $@*%<> signs and how do I know when to use them?
+
+ Those are type specifiers: $ for scalar values, @ for indexed arrays,
+ and % for hashed arrays. The * means all types of that symbol name
+ and are sometimes used like pointers; the <> are used for inputting
+ a record from a filehandle. See the question on arrays of arrays
+ for more about Perl pointers.
+
+ Always make sure to use a $ for single values and @ for multiple ones.
+ Thus element 2 of the @foo array is accessed as $foo[2], not @foo[2],
+ which is a list of length one (not a scalar), and is a fairly common
+ novice mistake. Sometimes you can get by with @foo[2], but it's
+ not really doing what you think it's doing for the reason you think
+ it's doing it, which means one of these days, you'll shoot yourself
+ in the foot; ponder for a moment what these will really do:
+ @foo[0] = `cmd args`;
+ @foo[2] = <FILE>;
+ Just always say $foo[2] and you'll be happier.
+
+ This may seem confusing, but try to think of it this way: you use the
+ character of the type which you *want back*. You could use @foo[1..3] for
+ a slice of three elements of @foo, or even @foo{A,B,C} for a slice of
+ of %foo. This is the same as using ($foo[1], $foo[2], $foo[3]) and
+ ($foo{A}, $foo{B}, $foo{C}) respectively. In fact, you can even use
+ lists to subscript arrays and pull out more lists, like @foo[@bar] or
+ @foo{@bar}, where @bar is in both cases presumably a list of subscripts.
+
+ While there are a few places where you don't actually need these type
+ specifiers, except for files, you should always use them. Note that
+ <FILE> is NOT the type specifier for files; it's the equivalent of awk's
+ getline function, that is, it reads a line from the handle FILE. When
+ doing open, close, and other operations besides the getline function on
+ files, do NOT use the brackets.
+
+ Beware of saying:
+ $foo = BAR;
+ Which wil be interpreted as
+ $foo = 'BAR';
+ and not as
+ $foo = <BAR>;
+ If you always quote your strings, you'll avoid this trap.
+
+ Normally, files are manipulated something like this (with appropriate
+ error checking added if it were production code):
+
+ open (FILE, ">/tmp/foo.$$");
+ print FILE "string\n";
+ close FILE;
+
+ If instead of a filehandle, you use a normal scalar variable with file
+ manipulation functions, this is considered an indirect reference to a
+ filehandle. For example,
+
+ $foo = "TEST01";
+ open($foo, "file");
+
+ After the open, these two while loops are equivalent:
+
+ while (<$foo>) {}
+ while (<TEST01>) {}
+
+ as are these two statements:
+
+ close $foo;
+ close TEST01;
+
+ but NOT to this:
+
+ while (<$TEST01>) {} # error
+ ^
+ ^ note spurious dollar sign
+
+ This is another common novice mistake; often it's assumed that
+
+ open($foo, "output.$$");
+
+ will fill in the value of $foo, which was previously undefined.
+ This just isn't so -- you must set $foo to be the name of a valid
+ filehandle before you attempt to open it.
+
+
+2.2) Why don't backticks work as they do in shells?
+
+ Several reason. One is because backticks do not interpolate within
+ double quotes in Perl as they do in shells.
+
+ Let's look at two common mistakes:
+
+ $foo = "$bar is `wc $file`"; # WRONG
+
+ This should have been:
+
+ $foo = "$bar is " . `wc $file`;
+
+ But you'll have an extra newline you might not expect. This
+ does not work as expected:
+
+ $back = `pwd`; chdir($somewhere); chdir($back); # WRONG
+
+ Because backticks do not automatically eat trailing or embedded
+ newlines. The chop() function will remove the last character from
+ a string. This should have been:
+
+ chop($back = `pwd`); chdir($somewhere); chdir($back);
+
+ You should also be aware that while in the shells, embedding
+ single quotes will protect variables, in Perl, you'll need
+ to escape the dollar signs.
+
+ Shell: foo=`cmd 'safe $dollar'`
+ Perl: $foo=`cmd 'safe \$dollar'`;
+
+
+2.3) How come Perl operators have different precedence than C operators?
+
+ Actually, they don't; all C operators have the same precedence in Perl as
+ they do in C. The problem is with a class of functions called list
+ operators, e.g. print, chdir, exec, system, and so on. These are somewhat
+ bizarre in that they have different precedence depending on whether you
+ look on the left or right of them. Basically, they gobble up all things
+ on their right. For example,
+
+ unlink $foo, "bar", @names, "others";
+
+ will unlink all those file names. A common mistake is to write:
+
+ unlink "a_file" || die "snafu";
+
+ The problem is that this gets interpreted as
+
+ unlink("a_file" || die "snafu");
+
+ To avoid this problem, you can always make them look like function calls
+ or use an extra level of parentheses:
+
+ (unlink "a_file") || die "snafu";
+ unlink("a_file") || die "snafu";
+
+ Sometimes you actually do care about the return value:
+
+ unless ($io_ok = print("some", "list")) { }
+
+ Yes, print() return I/O success. That means
+
+ $io_ok = print(2+4) * 5;
+
+ reutrns 5 times whether printing (2+4) succeeded, and
+ print(2+4) * 5;
+ returns the same 5*io_success value and tosses it.
+
+ See the Perl man page's section on Precedence for more gory details,
+ and be sure to use the -w flag to catch things like this.
+
+
+2.4) How come my converted awk/sed/sh script runs more slowly in Perl?
+
+ The natural way to program in those languages may not make for the fastest
+ Perl code. Notably, the awk-to-perl translator produces sub-optimal code;
+ see the a2p man page for tweaks you can make.
+
+ Two of Perl's strongest points are its associative arrays and its regular
+ expressions. They can dramatically speed up your code when applied
+ properly. Recasting your code to use them can help alot.
+
+ How complex are your regexps? Deeply nested sub-expressions with {n,m} or
+ * operators can take a very long time to compute. Don't use ()'s unless
+ you really need them. Anchor your string to the front if you can.
+
+ Something like this:
+ next unless /^.*%.*$/;
+ runs more slowly than the equivalent:
+ next unless /%/;
+
+ Note that this:
+ next if /Mon/;
+ next if /Tue/;
+ next if /Wed/;
+ next if /Thu/;
+ next if /Fri/;
+ runs faster than this:
+ next if /Mon/ || /Tue/ || /Wed/ || /Thu/ || /Fri/;
+ which in turn runs faster than this:
+ next if /Mon|Tue|Wed|Thu|Fri/;
+ which runs *much* faster than:
+ next if /(Mon|Tue|Wed|Thu|Fri)/;
+
+ There's no need to use /^.*foo.*$/ when /foo/ will do.
+
+ Remember that a printf costs more than a simple print.
+
+ Don't split() every line if you don't have to.
+
+ Another thing to look at is your loops. Are you iterating through
+ indexed arrays rather than just putting everything into a hashed
+ array? For example,
+
+ @list = ('abc', 'def', 'ghi', 'jkl', 'mno', 'pqr', 'stv');
+
+ for $i ($[ .. $#list) {
+ if ($pattern eq $list[$i]) { $found++; }
+ }
+
+ First of all, it would be faster to use Perl's foreach mechanism
+ instead of using subscripts:
+
+ foreach $elt (@list) {
+ if ($pattern eq $elt) { $found++; }
+ }
+
+ Better yet, this could be sped up dramatically by placing the whole
+ thing in an associative array like this:
+
+ %list = ('abc', 1, 'def', 1, 'ghi', 1, 'jkl', 1,
+ 'mno', 1, 'pqr', 1, 'stv', 1 );
+ $found += $list{$pattern};
+
+ (but put the %list assignment outside of your input loop.)
+
+ You should also look at variables in regular expressions, which is
+ expensive. If the variable to be interpolated doesn't change over the
+ life of the process, use the /o modifier to tell Perl to compile the
+ regexp only once, like this:
+
+ for $i (1..100) {
+ if (/$foo/o) {
+ &some_func($i);
+ }
+ }
+
+ Finally, if you have a bunch of patterns in a list that you'd like to
+ compare against, instead of doing this:
+
+ @pats = ('_get.*', 'bogus', '_read', '.*exit', '_write');
+ foreach $pat (@pats) {
+ if ( $name =~ /^$pat$/ ) {
+ &some_func();
+ last;
+ }
+ }
+
+ If you build your code and then eval it, it will be much faster.
+ For example:
+
+ @pats = ('_get.*', 'bogus', '_read', '.*exit', '_write');
+ $code = <<EOS
+ while () {
+ study;
+EOS
+ foreach $pat (@pats) {
+ $code .= <<EOS
+ if ( /^$pat\$/ ) {
+ &some_func();
+ next;
+ }
+EOS
+ }
+ $code .= "}\n";
+ print $code if $debugging;
+ eval $code;
+
+
+
+2.5) How can I call my system's unique C functions from Perl?
+
+ If these are system calls and you have the syscall() function, then
+ you're probably in luck -- see the next question. For arbitrary
+ library functions, it's not quite so straight-forward. While you
+ can't have a C main and link in Perl routines, if you're
+ determined, you can extend Perl by linking in your own C routines.
+ See the usub/ subdirectory in the Perl distribution kit for an example
+ of doing this to build a Perl that understands curses functions. It's
+ neither particularly easy nor overly-documented, but it is feasible.
+
+
+2.6) Where do I get the include files to do ioctl() or syscall()?
+
+ These are generated from your system's C include files using the h2ph
+ script (once called makelib) from the Perl source directory. This will
+ make files containing subroutine definitions, like &SYS_getitimer, which
+ you can use as arguments to your function.
+
+ You might also look at the h2pl subdirectory in the Perl source for how to
+ convert these to forms like $SYS_getitimer; there are both advantages and
+ disadvantages to this. Read the notes in that directory for details.
+
+ In both cases, you may well have to fiddle with it to make these work; it
+ depends how funny-looking your system's C include files happen to be.
+
+ If you're trying to get at C structures, then you should take a look
+ at using c2ph, which uses debugger "stab" entries generated by your
+ BSD or GNU C compiler to produce machine-independent perl definitions
+ for the data structures. This allows to you avoid hardcoding
+ structure layouts, types, padding, or sizes, greatly enhancing
+ portability. c2ph comes with the perl distribution. On an SCO
+ system, GCC only has COFF debugging support by default, so you'll have
+ to build GCC 2.1 with DBX_DEBUGGING_INFO defined, and use -gstabs to
+ get c2ph to work there.
+
+ See the file /pub/perl/info/ch2ph on convex.com via anon ftp
+ for more traps and tips on this process.
+
+
+2.7) Why doesn't "local($foo) = <FILE>;" work right?
+
+ Well, it does. The thing to remember is that local() provides an array
+ context, an that the <FILE> syntax in an array context will read all the
+ lines in a file. To work around this, use:
+
+ local($foo);
+ $foo = <FILE>;
+
+ You can use the scalar() operator to cast the expression into a scalar
+ context:
+
+ local($foo) = scalar(<FILE>);
+
+
+2.8) How can I detect keyboard input without reading it?
+
+ You should check out the Frequently Asked Questions list in
+ comp.unix.* for things like this: the answer is essentially the same.
+ It's very system dependent. Here's one solution that works on BSD
+ systems:
+
+ sub key_ready {
+ local($rin, $nfd);
+ vec($rin, fileno(STDIN), 1) = 1;
+ return $nfd = select($rin,undef,undef,0);
+ }
+
+ A closely related question is how to input a single character from the
+ keyboard. Again, this is a system dependent operation. The following
+ code that may or may not help you:
+
+ $BSD = -f '/vmunix';
+ if ($BSD) {
+ system "stty cbreak </dev/tty >/dev/tty 2>&1";
+ }
+ else {
+ system "stty", 'cbreak',
+ system "stty", 'eol', "\001";
+ }
+
+ $key = getc(STDIN);
+
+ if ($BSD) {
+ system "stty -cbreak </dev/tty >/dev/tty 2>&1";
+ }
+ else {
+ system "stty", 'icanon';
+ system "stty", 'eol', '^@'; # ascii null
+ }
+ print "\n";
+
+ You could also handle the stty operations yourself for speed if you're
+ going to be doing a lot of them. This code works to toggle cbreak
+ and echo modes on a BSD system:
+
+ sub set_cbreak { # &set_cbreak(1) or &set_cbreak(0)
+ local($on) = $_[0];
+ local($sgttyb,@ary);
+ require 'sys/ioctl.ph';
+ $sgttyb_t = 'C4 S' unless $sgttyb_t; # c2ph: &sgttyb'typedef()
+
+ ioctl(STDIN,&TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!";
+
+ @ary = unpack($sgttyb_t,$sgttyb);
+ if ($on) {
+ $ary[4] |= &CBREAK;
+ $ary[4] &= ~&ECHO;
+ } else {
+ $ary[4] &= ~&CBREAK;
+ $ary[4] |= &ECHO;
+ }
+ $sgttyb = pack($sgttyb_t,@ary);
+
+ ioctl(STDIN,&TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!";
+ }
+
+ Note that this is one of the few times you actually want to use the
+ getc() function; it's in general way too expensive to call for normal
+ I/O. Normally, you just use the <FILE> syntax, or perhaps the read()
+ or sysread() functions.
+
+ For perspectives on more portable solutions, use anon ftp to retrieve
+ the file /pub/perl/info/keypress from convex.com.
+
+
+2.9) How can I make an array of arrays or other recursive data types?
+
+ Remember that Perl isn't about nested data structures (actually,
+ perl0 .. perl4 weren't, but maybe perl5 will be, at least
+ somewhat). It's about flat ones, so if you're trying to do this, you
+ may be going about it the wrong way or using the wrong tools. You
+ might try parallel arrays with common subscripts.
+
+ But if you're bound and determined, you can use the multi-dimensional
+ array emulation of $a{'x','y','z'}, or you can make an array of names
+ of arrays and eval it.
+
+ For example, if @name contains a list of names of arrays, you can
+ get at a the j-th element of the i-th array like so:
+
+ $ary = $name[$i];
+ $val = eval "\$$ary[$j]";
+
+ or in one line
+
+ $val = eval "\$$name[$i][\$j]";
+
+ You could also use the type-globbing syntax to make an array of *name
+ values, which will be more efficient than eval. Here @name hold
+ a list of pointers, which we'll have to dereference through a temporary
+ variable.
+
+ For example:
+
+ { local(*ary) = $name[$i]; $val = $ary[$j]; }
+
+ In fact, you can use this method to make arbitrarily nested data
+ structures. You really have to want to do this kind of thing
+ badly to go this far, however, as it is notationally cumbersome.
+
+ Let's assume you just simply *have* to have an array of arrays of
+ arrays. What you do is make an array of pointers to arrays of
+ pointers, where pointers are *name values described above. You
+ initialize the outermost array normally, and then you build up your
+ pointers from there. For example:
+
+ @w = ( 'ww' .. 'xx' );
+ @x = ( 'xx' .. 'yy' );
+ @y = ( 'yy' .. 'zz' );
+ @z = ( 'zz' .. 'zzz' );
+
+ @ww = reverse @w;
+ @xx = reverse @x;
+ @yy = reverse @y;
+ @zz = reverse @z;
+
+ Now make a couple of array of pointers to these:
+
+ @A = ( *w, *x, *y, *z );
+ @B = ( *ww, *xx, *yy, *zz );
+
+ And finally make an array of pointers to these arrays:
+
+ @AAA = ( *A, *B );
+
+ To access an element, such as AAA[i][j][k], you must do this:
+
+ local(*foo) = $AAA[$i];
+ local(*bar) = $foo[$j];
+ $answer = $bar[$k];
+
+ Similar manipulations on associative arrays are also feasible.
+
+ You could take a look at recurse.pl package posted by Felix Lee
+ <flee@cs.psu.edu>, which lets you simulate vectors and tables (lists and
+ associative arrays) by using type glob references and some pretty serious
+ wizardry.
+
+ In C, you're used to creating recursive datatypes for operations
+ like recursive decent parsing or tree traversal. In Perl, these
+ algorithms are best implemented using associative arrays. Take an
+ array called %parent, and build up pointers such that $parent{$person}
+ is the name of that person's parent. Make sure you remember that
+ $parent{'adam'} is 'adam'. :-) With a little care, this approach can
+ be used to implement general graph traversal algorithms as well.
+
+
+2.10) How can I quote a variable to use in a regexp?
+
+ From the manual:
+
+ $pattern =~ s/(\W)/\\$1/g;
+
+ Now you can freely use /$pattern/ without fear of any unexpected
+ meta-characters in it throwing off the search. If you don't know
+ whether a pattern is valid or not, enclose it in an eval to avoid
+ a fatal run-time error.
+
+
+2.11) Why do setuid Perl scripts complain about kernel problems?
+
+ This message:
+
+ YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!
+ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!
+
+ is triggered because setuid scripts are inherently insecure due to a
+ kernel bug. If your system has fixed this bug, you can compile Perl
+ so that it knows this. Otherwise, create a setuid C program that just
+ execs Perl with the full name of the script.
+
+
+2.12) How do I open a pipe both to and from a command?
+
+ In general, this is a dangerous move because you can find yourself in a
+ deadlock situation. It's better to put one end of the pipe to a file.
+ For example:
+
+ # first write some_cmd's input into a_file, then
+ open(CMD, "some_cmd its_args < a_file |");
+ while (<CMD>) {
+
+ # or else the other way; run the cmd
+ open(CMD, "| some_cmd its_args > a_file");
+ while ($condition) {
+ print CMD "some output\n";
+ # other code deleted
+ }
+ close CMD || warn "cmd exited $?";
+
+ # now read the file
+ open(FILE,"a_file");
+ while (<FILE>) {
+
+ If you have ptys, you could arrange to run the command on a pty and
+ avoid the deadlock problem. See the chat2.pl package in the
+ distributed library for ways to do this.
+
+ At the risk of deadlock, it is theoretically possible to use a
+ fork, two pipe calls, and an exec to manually set up the two-way
+ pipe. (BSD system may use socketpair() in place of the two pipes,
+ but this is not as portable.) The open2 library function distributed
+ with the current perl release will do this for you.
+
+ It assumes it's going to talk to something like adb, both writing to
+ it and reading from it. This is presumably safe because you "know"
+ that commands like adb will read a line at a time and output a line at
+ a time. Programs like sort that read their entire input stream first,
+ however, are quite apt to cause deadlock.
+
+
+2.13) How can I change the first N letters of a string?
+
+ Remember that the substr() function produces an lvalue, that is, it may be
+ assigned to. Therefore, to change the first character to an S, you could
+ do this:
+
+ substr($var,0,1) = 'S';
+
+ This assumes that $[ is 0; for a library routine where you can't know $[,
+ you should use this instead:
+
+ substr($var,$[,1) = 'S';
+
+ While it would be slower, you could in this case use a substitute:
+
+ $var =~ s/^./S/;
+
+ But this won't work if the string is empty or its first character is a
+ newline, which "." will never match. So you could use this instead:
+
+ $var =~ s/^[^\0]?/S/;
+
+ To do things like translation of the first part of a string, use substr,
+ as in:
+
+ substr($var, $[, 10) =~ tr/a-z/A-Z/;
+
+ If you don't know then length of what to translate, something like
+ this works:
+
+ /^(\S+)/ && substr($_,$[,length($1)) =~ tr/a-z/A-Z/;
+
+ For some things it's convenient to use the /e switch of the
+ substitute operator:
+
+ s/^(\S+)/($tmp = $1) =~ tr#a-z#A-Z#, $tmp/e
+
+ although in this case, it runs more slowly than does the previous example.
+
+
+2.14) How can I manipulate fixed-record-length files?
+
+ The most efficient way is using pack and unpack. This is faster than
+ using substr. Here is a sample chunk of code to break up and put back
+ together again some fixed-format input lines, in this case, from ps.
+
+ # sample input line:
+ # 15158 p5 T 0:00 perl /mnt/tchrist/scripts/now-what
+ $ps_t = 'A6 A4 A7 A5 A*';
+ open(PS, "ps|");
+ $_ = <PS>; print;
+ while (<PS>) {
+ ($pid, $tt, $stat, $time, $command) = unpack($ps_t, $_);
+ for $var ('pid', 'tt', 'stat', 'time', 'command' ) {
+ print "$var: <", eval "\$$var", ">\n";
+ }
+ print 'line=', pack($ps_t, $pid, $tt, $stat, $time, $command), "\n";
+ }
+
+
+2.15) How can I make a file handle local to a subroutine?
+
+ You must use the type-globbing *VAR notation. Here is some code to
+ cat an include file, calling itself recursively on nested local
+ include files (i.e. those with #include "file", not #include <file>):
+
+ sub cat_include {
+ local($name) = @_;
+ local(*FILE);
+ local($_);
+
+ warn "<INCLUDING $name>\n";
+ if (!open (FILE, $name)) {
+ warn "can't open $name: $!\n";
+ return;
+ }
+ while (<FILE>) {
+ if (/^#\s*include "([^"]*)"/) {
+ &cat_include($1);
+ } else {
+ print;
+ }
+ }
+ close FILE;
+ }
+
+
+2.16) How can I extract just the unique elements of an array?
+
+ There are several possible ways, depending on whether the
+ array is ordered and you wish to preserve the ordering.
+
+ a) If @in is sorted, and you want @out to be sorted:
+
+ $prev = 'nonesuch';
+ @out = grep($_ ne $prev && (($prev) = $_), @in);
+
+ This is nice in that it doesn't use much extra memory,
+ simulating uniq's behavior of removing only adjacent
+ duplicates.
+
+ b) If you don't know whether @in is sorted:
+
+ undef %saw;
+ @out = grep(!$saw{$_}++, @in);
+
+ c) Like (b), but @in contains only small integers:
+
+ @out = grep(!$saw[$_]++, @in);
+
+ d) A way to do (b) without any loops or greps:
+
+ undef %saw;
+ @saw{@in} = ();
+ @out = sort keys %saw; # remove sort if undesired
+
+ e) Like (d), but @in contains only small positive integers:
+
+ undef @ary;
+ @ary[@in] = @in;
+ @out = sort @ary;
+
+
+2.17) How can I call alarm() or usleep() from Perl?
+
+ It's available as a built-in as of version 3.038. If you want finer
+ granularity than 1 second (as usleep() provides) and have itimers and
+ syscall() on your system, you can use the following. You could also
+ use select().
+
+ It takes a floating-point number representing how long to delay until
+ you get the SIGALRM, and returns a floating- point number representing
+ how much time was left in the old timer, if any. Note that the C
+ function uses integers, but this one doesn't mind fractional numbers.
+
+ # alarm; send me a SIGALRM in this many seconds (fractions ok)
+ # tom christiansen <tchrist@convex.com>
+ sub alarm {
+ require 'syscall.ph';
+ require 'sys/time.ph';
+
+ local($ticks) = @_;
+ local($in_timer,$out_timer);
+ local($isecs, $iusecs, $secs, $usecs);
+
+ local($itimer_t) = 'L4'; # should be &itimer'typedef()
+
+ $secs = int($ticks);
+ $usecs = ($ticks - $secs) * 1e6;
+
+ $out_timer = pack($itimer_t,0,0,0,0);
+ $in_timer = pack($itimer_t,0,0,$secs,$usecs);
+
+ syscall(&SYS_setitimer, &ITIMER_REAL, $in_timer, $out_timer)
+ && die "alarm: setitimer syscall failed: $!";
+
+ ($isecs, $iusecs, $secs, $usecs) = unpack($itimer_t,$out_timer);
+ return $secs + ($usecs/1e6);
+ }
+
+
+2.18) How can I test whether an array contains a certain element?
+
+ There are several ways to approach this. If you are going to make
+ this query many times and the values are arbitrary strings, the
+ fastest way is probably to invert the original array and keep an
+ associative array lying about whose keys are the first array's values.
+
+ @blues = ('turquoise', 'teal', 'lapis lazuli');
+ undef %is_blue;
+ for (@blues) { $is_blue{$_} = 1; }
+
+ Now you can check whether $is_blue{$some_color}. It might have been
+ a good idea to keep the blues all in an assoc array in the first place.
+
+ If the values are all small integers, you could use a simple
+ indexed array. This kind of an array will take up less space:
+
+ @primes = (2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31);
+ undef @is_tiny_prime;
+ for (@primes) { $is_tiny_prime[$_] = 1; }
+
+ Now you check whether $is_tiny_prime[$some_number].
+
+ If the values in question are integers, but instead of strings,
+ you can save quite a lot of space by using bit strings instead:
+
+ @articles = ( 1..10, 150..2000, 2017 );
+ undef $read;
+ grep (vec($read,$_,1) = 1, @articles);
+
+ Now check whether vec($read,$n,1) is true for some $n.
+
+
+2.19) How can I do an atexit() or setjmp()/longjmp() in Perl?
+
+ Perl's exception-handling mechanism is its eval operator. You
+ can use eval as setjmp and die as longjmp. Here's an example
+ of Larry's for timed-out input, which in C is often implemented
+ using setjmp and longjmp:
+
+ $SIG{ALRM} = TIMEOUT;
+ sub TIMEOUT { die "restart input\n" }
+
+ do { eval { &realcode } } while $@ =~ /^restart input/;
+
+ sub realcode {
+ alarm 15;
+ $ans = <STDIN>;
+ alarm 0;
+ }
+
+ Here's an example of Tom's for doing atexit() handling:
+
+ sub atexit { push(@_exit_subs, @_) }
+
+ sub _cleanup { unlink $tmp }
+
+ &atexit('_cleanup');
+
+ eval <<'End_Of_Eval'; $here = __LINE__;
+ # as much code here as you want
+ End_Of_Eval
+
+ $oops = $@; # save error message
+
+ # now call his stuff
+ for (@_exit_subs) { &$_() }
+
+ $oops && ($oops =~ s/\(eval\) line (\d+)/$0 .
+ " line " . ($1+$here)/e, die $oops);
+
+ You can register your own routines via the &atexit function now. You
+ might also want to use the &realcode method of Larry's rather than
+ embedding all your code in the here-is document. Make sure to leave
+ via die rather than exit, or write your own &exit routine and call
+ that instead. In general, it's better for nested routines to exit
+ via die rather than exit for just this reason.
+
+ Eval is also quite useful for testing for system dependent features,
+ like symlinks, or using a user-input regexp that might otherwise
+ blowup on you.
+
+
+2.20) Why doesn't Perl interpret my octal data octally?
+
+ Perl only understands octal and hex numbers as such when they occur
+ as constants in your program. If they are read in from somewhere
+ and assigned, then no automatic conversion takes place. You must
+ explicitly use oct() or hex() if you want this kind of thing to happen.
+ Actually, oct() knows to interpret both hex and octal numbers, while
+ hex only converts hexadecimal ones. For example:
+
+ {
+ print "What mode would you like? ";
+ $mode = <STDIN>;
+ $mode = oct($mode);
+ unless ($mode) {
+ print "You can't really want mode 0!\n";
+ redo;
+ }
+ chmod $mode, $file;
+ }
+
+ Without the octal conversion, a requested mode of 755 would turn
+ into 01363, yielding bizarre file permissions of --wxrw--wt.
+
+ If you want something that handles decimal, octal and hex input,
+ you could follow the suggestion in the man page and use:
+
+ $val = oct($val) if $val =~ /^0/;
+
+2.21) How do I sort an associative array by value instead of by key?
+
+ You have to declare a sort subroutine to do this. Let's assume
+ you want an ASCII sort on the values of the associative array %ary.
+ You could do so this way:
+
+ foreach $key (sort by_value keys %ary) {
+ print $key, '=', $ary{$key}, "\n";
+ }
+ sub by_value { $ary{$a} cmp $ary{$b}; }
+
+ If you wanted a descending numeric sort, you could do this:
+
+ sub by_value { $ary{$b} <=> $ary{$a}; }
+
+ You can also inline your sort function, like this:
+
+ foreach $key ( sort { $x{$b} <=> $a{$a} } keys %ary ) {
+ print $key, '=', $ary{$key}, "\n";
+ }
+
+ If you wanted a function that didn't have the array name hard-wired
+ into it, you could so this:
+
+ foreach $key (&sort_by_value(*ary)) {
+ print $key, '=', $ary{$key}, "\n";
+ }
+ sub sort_by_value {
+ local(*x) = @_;
+ sub _by_value { $x{$a} cmp $x{$b}; }
+ sort _by_value keys %x;
+ }
+
+ If you want neither an alphabetic nor a numeric sort, then you'll
+ have to code in your own logic instead of relying on the built-in
+ signed comparison operators "cmp" and "<=>".
+
+ Note that if you're sorting on just a part of the value, such as a
+ piece you might extract via split, unpack, pattern-matching, or
+ substr, then rather than performing that operation inside your sort
+ routine on each call to it, it is significantly more efficient to
+ build a parallel array of just those portions you're sorting on, sort
+ the indices of this parallel array, and then to subscript your original
+ array using the newly sorted indices. This method works on both
+ regular and associative arrays, since both @ary[@idx] and @ary{@idx}
+ make sense. See page 245 in the Camel Book on "Sorting an Array by a
+ Computable Field" for a simple example of this.
+
+
+2.22) How can I capture STDERR from an external command?
+
+ There are three basic ways of running external commands:
+
+ system $cmd;
+ $output = `$cmd`;
+ open (PIPE, "cmd |");
+
+ In the first case, both STDOUT and STDERR will go the same place as
+ the script's versions of these, unless redirected. You can always put
+ them where you want them and then read them back when the system
+ returns. In the second and third cases, you are reading the STDOUT
+ *only* of your command. If you would like to have merged STDOUT and
+ STDERR, you can use shell file-descriptor redirection to dup STDERR to
+ STDOUT:
+
+ $output = `$cmd 2>&1`;
+ open (PIPE, "cmd 2>&1 |");
+
+ Another possibility is to run STDERR into a file and read the file
+ later, as in
+
+ $output = `$cmd 2>some_file`;
+ open (PIPE, "cmd 2>some_file |");
+
+ Here's a way to read from both of them and know which descriptor
+ you got each line from. The trick is to pipe only STDERR through
+ sed, which then marks each of its lines, and then sends that
+ back into a merged STDOUT/STDERR stream, from which your Perl program
+ then reads a line at a time:
+
+ open (CMD,
+ "3>&1 (cmd args 2>&1 1>&3 3>&- | sed 's/^/STDERR:/' 3>&-) 3>&- |");
+
+ while (<CMD>) {
+ if (s/^STDERR://) {
+ print "line from stderr: ", $_;
+ } else {
+ print "line from stdout: ", $_;
+ }
+ }
+
+ Be apprised that you *must* use Bourne shell redirection syntax
+ here, not csh! In fact, you can't even do these things with csh.
+ For details on how lucky you are that perl's system() and backtick
+ and pipe opens all use Bourne shell, fetch the file from convex.com
+ called /pub/csh.whynot -- and you'll be glad that perl's shell
+ interface is the Bourne shell.
+
+
+2.23) Why doesn't open return an error when a pipe open fails?
+
+ These statements:
+
+ open(TOPIPE, "|bogus_command") || die ...
+ open(FROMPIPE, "bogus_command|") || die ...
+
+ will not fail just for lack of the bogus_command. They'll only
+ fail if the fork to run them fails, which is seldom the problem.
+
+ If you're writing to the TOPIPE, you'll get a SIGPIPE if the child
+ exits prematurely or doesn't run. If you are reading from the
+ FROMPIPE, you need to check the close() to see what happened.
+
+ If you want an answer sooner than pipe buffering might otherwise
+ afford you, you can do something like this:
+
+ $kid = open (PIPE, "bogus_command |"); # XXX: check defined($kid)
+ (kill 0, $kid) || die "bogus_command failed";
+
+ This works fine if bogus_command doesn't have shell metas in it, but
+ if it does, the shell may well not have exited before the kill 0. You
+ could always introduce a delay:
+
+ $kid = open (PIPE, "bogus_command </dev/null |");
+ sleep 1;
+ (kill 0, $kid) || die "bogus_command failed";
+
+ but this is sometimes undesirable, and in any event does not guarantee
+ correct behavior. But it seems slightly better than nothing.
+
+ Similar tricks can be played with writable pipes if you don't wish to
+ catch the SIGPIPE.
+
+
+2.24) How can I compare two date strings?
+
+ If the dates are in an easily parsed, predetermined format, then you
+ can break them up into their component parts and call &timelocal from
+ the distributed perl library. If the date strings are in arbitrary
+ formats, however, it's probably easier to use the getdate program
+ from the Cnews distribution, since it accepts a wide variety of dates.
+ Note that in either case the return values you will really be
+ comparing will be the total time in seconds as return by time().
+
+ Here's a getdate function for perl that's not very efficient; you
+ can do better this by sending it many dates at once or modifying
+ getdate to behave better on a pipe. Beware the hardcoded pathname.
+
+ sub getdate {
+ local($_) = shift;
+
+ s/-(\d{4})$/+$1/ || s/\+(\d{4})$/-$1/;
+ # getdate has broken timezone sign reversal!
+
+ $_ = `/usr/local/lib/news/newsbin/getdate '$_'`;
+ chop;
+ $_;
+ }
+
+ Richard Ohnemus <rick@IMD.Sterling.COM> actually has a getdate.y
+ for use with the Perl yacc. You can get this from ftp.sterling.com
+ [192.124.9.1] in /local/perl-byacc1.8.1.tar.Z, or send the author
+ mail for details.
+
+
+2.25) What's the fastest way to code up a given task in perl?
+
+ Because Perl so lends itself to a variety of different approaches
+ for any given task, a common question is which is the fastest way
+ to code a given task. Since some approaches can be dramatically
+ more efficient that others, it's sometimes worth knowing which is
+ best. Unfortunately, the implementation that first comes to mind,
+ perhaps as a direct translation from C or the shell, often yields
+ suboptimal performance. Not all approaches have the same results
+ across different hardware and software platforms. Furthermore,
+ legibility must sometimes be sacrificed for speed.
+
+ While an experienced perl programmer can sometimes eye-ball the code
+ and make an educated guess regarding which way would be fastest,
+ surprises can still occur. So, in the spirit of perl programming
+ being an empirical science, the best way to find out which of several
+ different methods runs the fastest is simply to code them all up and
+ time them. For example:
+
+ $COUNT = 10_000; $| = 1;
+
+ print "method 1: ";
+
+ ($u, $s) = times;
+ for ($i = 0; $i < $COUNT; $i++) {
+ # code for method 1
+ }
+ ($nu, $ns) = times;
+ printf "%8.4fu %8.4fs\n", ($nu - $u), ($ns - $s);
+
+ print "method 2: ";
+
+ ($u, $s) = times;
+ for ($i = 0; $i < $COUNT; $i++) {
+ # code for method 2
+ }
+ ($nu, $ns) = times;
+ printf "%8.4fu %8.4fs\n", ($nu - $u), ($ns - $s);
+
+ For more specific tips, see the section on Efficiency in the
+ ``Other Oddments'' chapter at the end of the Camel Book.
+
+
+2.26) How can I know how many entries are in an associative array?
+
+ While the number of elements in a @foobar array is simply @foobar when
+ used in a scalar, you can't figure out how many elements are in an
+ associative array in an analagous fashion. That's because %foobar in
+ a scalar context returns the ratio (as a string) of number of buckets
+ filled versus the number allocated. For example, scalar(%ENV) might
+ return "20/32". While perl could in theory keep a count, this would
+ break down on associative arrays that have been bound to dbm files.
+
+ However, while you can't get a count this way, one thing you *can* use
+ it for is to determine whether there are any elements whatsoever in
+ the array, since "if (%table)" is guaranteed to be false if nothing
+ has ever been stored in it.
+
+ So you either have to keep your own count around and increments
+ it every time you store a new key in the array, or else do it
+ on the fly when you really care, perhaps like this:
+
+ $count++ while each %ENV;
+
+ This preceding method will be faster than extracting the
+ keys into a temporary array to count them.
+
+ As of a very recent patch, you can say
+
+ $count = keys %ENV;
+
+
+
+2.27) Why can't my perl program read from STDIN after I gave it ^D (EOF) ?
+
+ Because some stdio's set error and eof flags that need clearing.
+
+ Try keeping around the seekpointer and go there, like this:
+ $where = tell(LOG);
+ seek(LOG, $where, 0);
+
+ If that doesn't work, try seeking to a different part of the file and
+ then back. If that doesn't work, try seeking to a different part of
+ the file, reading something, and then seeking back. If that doesn't
+ work, give up on your stdio package and use sysread. You can't call
+ stdio's clearerr() from Perl, so if you get EINTR from a signal
+ handler, you're out of luck. Best to just use sysread() from the
+ start for the tty.
+
+
+2.28) Do I always/never have to quote my strings or use semicolons?
+
+ You don't have to quote strings that can't mean anything else
+ in the language, like identifiers with any upper-case letters
+ in them. Therefore, it's fine to do this:
+
+ $SIG{INT} = Timeout_Routine;
+ or
+
+ @Days = (Sun, Mon, Tue, Wed, Thu, Fri, Sat, Sun);
+
+ but you can't get away with this:
+
+ $foo{while} = until;
+
+ in place of
+
+ $foo{'while'} = 'until';
+
+ The requirements on semicolons have been increasingly relaxed. You no
+ longer need one at the end of a block, but stylistically, you're
+ better to use them if you don't put the curly brace on the same line:
+
+ for (1..10) { print }
+
+ is ok, as is
+
+ @nlist = sort { $a <=> $b } @olist;
+
+ but you probably shouldn't do this:
+
+ for ($i = 0; $i < @a; $i++) {
+ print "i is $i\n" # <-- oops!
+ }
+
+ because you might want to add lines later, and anyway,
+ it looks funny. :-)
+
+
+2.29) How can I translate tildes in a filename?
+
+ Perl doesn't expand tildes -- the shell (ok, some shells) do.
+ The classic request is to be able to do something like:
+
+ open(FILE, "~/dir1/file1");
+ open(FILE, "~tchrist/dir1/file1");
+
+ which doesn't work. (And you don't know it, because you
+ did a system call without an "|| die" clause! :-)
+
+ If you *know* you're on a system with the csh, and you *know*
+ that Larry hasn't internalized file globbing, then you could
+ get away with
+
+ $filename = <~tchrist/dir1/file1>;
+
+ but that's pretty iffy.
+
+ A better way is to do the translation yourself, as in:
+
+ $filename =~ s#^~(\w+)(/.*)?$#(getpwnam($1))[7].$2#e;
+
+ More robust and efficient versions that checked for error conditions,
+ handed simple ~/blah notation, and cached lookups are all reasonable
+ enhancements.
+
+
+2.30) How can I convert my shell script to Perl?
+
+ Larry's standard answer for this is to send your script to me (Tom
+ Christiansen) with appropriate supplications and offerings. :-(
+ That's because there's no automatic machine translator. Even if you
+ were, you wouldn't gain a lot, as most of the external programs would
+ still get called. It's the same problem as blind translation into C:
+ you're still apt to be bogged down by exec()s. You have to analize
+ the dataflow and algorithm and rethink it for optimal speedup. It's
+ not uncommon to see one, two, or even three orders of magnitude of
+ speed difference between the brute-force and the recoded approaches.
+
+
+2.31) What is variable suicide and how can I prevent it?
+
+ Variable suicide is a nasty sideeffect of dynamic scoping and
+ the way variables are passed by reference. If you say
+
+ $x = 17;
+ &munge($x);
+ sub munge {
+ local($x);
+ local($myvar) = $_[0];
+ ...
+ }
+
+ Then you have just clubbered $_[0]! Why this is occurring
+ is pretty heavy wizardry: the reference to $x stored in
+ $_[0] was temporarily occluded by the previous local($x)
+ statement (which, you're recall, occurs at run-time, not
+ compile-time). The work around is simple, however: declare
+ your formal parameters first:
+
+ sub munge {
+ local($myvar) = $_[0];
+ local($x);
+ ...
+ }
+
+ That doesn't help you if you're going to be trying to access
+ @_ directly after the local()s. In this case, careful use
+ of the package facility is your only recourse.
+
+ Another manifestation of this problem occurs due to the
+ magical nature of the index variable in a foreach() loop.
+
+ @num = 0 .. 4;
+ print "num begin @num\n";
+ foreach $m (@num) { &ug }
+ print "num finish @num\n";
+ sub ug {
+ local($m) = 42;
+ print "m=$m $num[0],$num[1],$num[2],$num[3]\n";
+ }
+
+ Which prints out the mysterious:
+
+ num begin 0 1 2 3 4
+ m=42 42,1,2,3
+ m=42 0,42,2,3
+ m=42 0,1,42,3
+ m=42 0,1,2,42
+ m=42 0,1,2,3
+ num finish 0 1 2 3 4
+
+ What's happening here is that $m is an alias for each
+ element of @num. Inside &ug, you temporarily change
+ $m. Well, that means that you've also temporarily
+ changed whatever $m is an alias to!! The only workaround
+ is to be careful with global variables, using packages,
+ and/or just be aware of this potential in foreach() loops.
+
+
+2.32) Can I use Perl regular expressions to match balanced text?
+
+ No, or at least, not by the themselves.
+
+ Regexps just aren't powerful enough. Although Perl's patterns aren't
+ strictly regular because they do backtracking (the \1 notation), you
+ still can't do it. You need to employ auxiliary logic. A simple
+ approach would involve keeping a bit of state around, something
+ vaguely like this (although we don't handle patterns on the same line):
+
+ while(<>) {
+ if (/pat1/) {
+ if ($inpat++ > 0) { warn "already saw pat1" }
+ redo;
+ }
+ if (/pat2/) {
+ if (--$inpat < 0) { warn "never saw pat1" }
+ redo;
+ }
+ }
+
+ A rather more elaborate subroutine to pull out balanced and possibly
+ nested single chars, like ` and ', { and }, or ( and ) can be found
+ on convex.com in /pub/perl/scripts/pull_quotes.
+
+
+2.33) Can I use Perl to run a telnet or ftp session?
+
+ Sure, you can connect directly to them using sockets, or you can run a
+ session on a pty. In either case, Randal's chat2 package, which is
+ distributed with the perl source, will come in handly. It address
+ much the same problem space as Don Libes's expect package does. Two
+ examples of using managing an ftp session using chat2 can be found on
+ convex.com in /pub/perl/scripts/ftp-chat2.shar .
+
+ Caveat lector: chat2 is documented only by example, may not run on
+ System V systems, and is subtly machine dependent both in its ideas
+ of networking and in pseudottys.
+
+
+2.34) What does "Malformed command links" mean?
+
+ This is a bug in 4.035. While in general it's merely a cosmetic
+ problem, it often comanifests with a highly undesirable coredumping
+ problem. Programs known to be affected by the fatal coredump include
+ plum and pcops. Since perl5 is prety much a total rewrite, we can
+ count on it being fixed then, but if anyone tracks down the coredump
+ problem before then, a signifcant portion of the perl world would
+ rejoice. [Fixed in 4.036--lwall]
--- /dev/null
+#!/usr/bin/perl
+
+@lines = <>;
+for (@lines) {
+ $line++;
+
+ if (/^PP\(pp_(\w+)/) { $newname = $1; $fixed = 1; $mark = 0; next; }
+ if (/^}/) { $fixed{$newname} = $fixed; $mark{$newname} = $mark; $newname=''}
+
+ next unless $fixed;
+
+ if (/^#ifdef NOTDEF/) { $fixed = 0; }
+ if (/MSP;/) { $mark = 1; }
+
+ if (/\bMEXTEND/ && $mark == 0) { warn "Inconsistent mark line $line\n"; }
+ if (/\bMXPUSH/ && $mark == 0) { warn "Inconsistent mark line $line\n"; }
+ if (/\bMRETURN/ && $mark == 0) { warn "Inconsistent mark line $line\n"; }
+
+ if (/\bEXTEND/ && $mark == 1) { warn "Inconsistent mark line $line\n"; }
+ if (/\bXPUSH/ && $mark == 1) { warn "Inconsistent mark line $line\n"; }
+ if (/\bRETURN/ && $mark == 1) { warn "Inconsistent mark line $line\n"; }
+
+}
+
+for (@lines) {
+ if (m#^ 0, /\* pp_(\w+)#) {
+ $_ = " pp_$1,\n" if $fixed{$1};
+ }
+ elsif (m#^ [01], /\* (\w+)[^,]#) {
+ s/\d/$mark{$1} + 0/e;
+ }
+ last if /^PP/;
+}
+
+print @lines;
--- /dev/null
+sharpbang='#!'
+++ /dev/null
-/* $RCSfile: form.c,v $$Revision: 4.0.1.3 $$Date: 92/06/08 13:21:42 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: form.c,v $
- * Revision 4.0.1.3 92/06/08 13:21:42 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: form feed for formats is now specifiable via $^L
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- *
- * Revision 4.0.1.2 91/11/05 17:18:43 lwall
- * patch11: formats didn't fill their fields as well as they could
- * patch11: ^ fields chopped hyphens on line break
- * patch11: # fields could write outside allocated memory
- *
- * Revision 4.0.1.1 91/06/07 11:07:59 lwall
- * patch4: new copyright notice
- * patch4: default top-of-form format is now FILEHANDLE_TOP
- *
- * Revision 4.0 91/03/20 01:19:23 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-/* Forms stuff */
-
-static int countlines();
-
-void
-form_parseargs(fcmd)
-register FCMD *fcmd;
-{
- register int i;
- register ARG *arg;
- register int items;
- STR *str;
- ARG *parselist();
- line_t oldline = curcmd->c_line;
- int oldsave = savestack->ary_fill;
-
- str = fcmd->f_unparsed;
- curcmd->c_line = fcmd->f_line;
- fcmd->f_unparsed = Nullstr;
- (void)savehptr(&curstash);
- curstash = str->str_u.str_hash;
- arg = parselist(str);
- restorelist(oldsave);
-
- items = arg->arg_len - 1; /* ignore $$ on end */
- for (i = 1; i <= items; i++) {
- if (!fcmd || fcmd->f_type == F_NULL)
- fatal("Too many field values");
- dehoist(arg,i);
- fcmd->f_expr = make_op(O_ITEM,1,
- arg[i].arg_ptr.arg_arg,Nullarg,Nullarg);
- if (fcmd->f_flags & FC_CHOP) {
- if ((fcmd->f_expr[1].arg_type & A_MASK) == A_STAB)
- fcmd->f_expr[1].arg_type = A_LVAL;
- else if ((fcmd->f_expr[1].arg_type & A_MASK) == A_EXPR)
- fcmd->f_expr[1].arg_type = A_LEXPR;
- else
- fatal("^ field requires scalar lvalue");
- }
- fcmd = fcmd->f_next;
- }
- if (fcmd && fcmd->f_type)
- fatal("Not enough field values");
- curcmd->c_line = oldline;
- Safefree(arg);
- str_free(str);
-}
-
-int newsize;
-
-#define CHKLEN(allow) \
-newsize = (d - orec->o_str) + (allow); \
-if (newsize >= curlen) { \
- curlen = d - orec->o_str; \
- GROWSTR(&orec->o_str,&orec->o_len,orec->o_len + (allow)); \
- d = orec->o_str + curlen; /* in case it moves */ \
- curlen = orec->o_len - 2; \
-}
-
-void
-format(orec,fcmd,sp)
-register struct outrec *orec;
-register FCMD *fcmd;
-int sp;
-{
- register char *d = orec->o_str;
- register char *s;
- register int curlen = orec->o_len - 2;
- register int size;
- FCMD *nextfcmd;
- FCMD *linebeg = fcmd;
- char tmpchar;
- char *t;
- CMD mycmd;
- STR *str;
- char *chophere;
- int blank = TRUE;
-
- mycmd.c_type = C_NULL;
- orec->o_lines = 0;
- for (; fcmd; fcmd = nextfcmd) {
- nextfcmd = fcmd->f_next;
- CHKLEN(fcmd->f_presize);
- /*SUPPRESS 560*/
- if (s = fcmd->f_pre) {
- while (*s) {
- if (*s == '\n') {
- t = orec->o_str;
- if (blank && (fcmd->f_flags & FC_REPEAT)) {
- while (d > t && (d[-1] != '\n'))
- d--;
- }
- else {
- while (d > t && (d[-1] == ' ' || d[-1] == '\t'))
- d--;
- }
- if (fcmd->f_flags & FC_NOBLANK) {
- if (blank || d == orec->o_str || d[-1] == '\n') {
- orec->o_lines--; /* don't print blank line */
- linebeg = fcmd->f_next;
- break;
- }
- else if (fcmd->f_flags & FC_REPEAT)
- nextfcmd = linebeg;
- else
- linebeg = fcmd->f_next;
- }
- else
- linebeg = fcmd->f_next;
- blank = TRUE;
- }
- *d++ = *s++;
- }
- }
- if (fcmd->f_unparsed)
- form_parseargs(fcmd);
- switch (fcmd->f_type) {
- case F_NULL:
- orec->o_lines++;
- break;
- case F_LEFT:
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- s = str_get(str);
- size = fcmd->f_size;
- CHKLEN(size);
- chophere = Nullch;
- while (size && *s && *s != '\n') {
- if (*s == '\t')
- *s = ' ';
- else if (*s != ' ')
- blank = FALSE;
- size--;
- if (*s && index(chopset,(*d++ = *s++)))
- chophere = s;
- if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
- *s = ' ';
- }
- if (size || !*s)
- chophere = s;
- else if (chophere && chophere < s && *s && index(chopset,*s))
- chophere = s;
- if (fcmd->f_flags & FC_CHOP) {
- if (!chophere)
- chophere = s;
- size += (s - chophere);
- d -= (s - chophere);
- if (fcmd->f_flags & FC_MORE &&
- *chophere && strNE(chophere,"\n")) {
- while (size < 3) {
- d--;
- size++;
- }
- while (d[-1] == ' ' && size < fcmd->f_size) {
- d--;
- size++;
- }
- *d++ = '.';
- *d++ = '.';
- *d++ = '.';
- size -= 3;
- }
- while (*chophere && index(chopset,*chophere)
- && isSPACE(*chophere))
- chophere++;
- str_chop(str,chophere);
- }
- if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
- size = 0; /* no spaces before newline */
- while (size) {
- size--;
- *d++ = ' ';
- }
- break;
- case F_RIGHT:
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- t = s = str_get(str);
- size = fcmd->f_size;
- CHKLEN(size);
- chophere = Nullch;
- while (size && *s && *s != '\n') {
- if (*s == '\t')
- *s = ' ';
- else if (*s != ' ')
- blank = FALSE;
- size--;
- if (*s && index(chopset,*s++))
- chophere = s;
- if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
- *s = ' ';
- }
- if (size || !*s)
- chophere = s;
- else if (chophere && chophere < s && *s && index(chopset,*s))
- chophere = s;
- if (fcmd->f_flags & FC_CHOP) {
- if (!chophere)
- chophere = s;
- size += (s - chophere);
- s = chophere;
- while (*chophere && index(chopset,*chophere)
- && isSPACE(*chophere))
- chophere++;
- }
- tmpchar = *s;
- *s = '\0';
- while (size) {
- size--;
- *d++ = ' ';
- }
- size = s - t;
- Copy(t,d,size,char);
- d += size;
- *s = tmpchar;
- if (fcmd->f_flags & FC_CHOP)
- str_chop(str,chophere);
- break;
- case F_CENTER: {
- int halfsize;
-
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- t = s = str_get(str);
- size = fcmd->f_size;
- CHKLEN(size);
- chophere = Nullch;
- while (size && *s && *s != '\n') {
- if (*s == '\t')
- *s = ' ';
- else if (*s != ' ')
- blank = FALSE;
- size--;
- if (*s && index(chopset,*s++))
- chophere = s;
- if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
- *s = ' ';
- }
- if (size || !*s)
- chophere = s;
- else if (chophere && chophere < s && *s && index(chopset,*s))
- chophere = s;
- if (fcmd->f_flags & FC_CHOP) {
- if (!chophere)
- chophere = s;
- size += (s - chophere);
- s = chophere;
- while (*chophere && index(chopset,*chophere)
- && isSPACE(*chophere))
- chophere++;
- }
- tmpchar = *s;
- *s = '\0';
- halfsize = size / 2;
- while (size > halfsize) {
- size--;
- *d++ = ' ';
- }
- size = s - t;
- Copy(t,d,size,char);
- d += size;
- *s = tmpchar;
- if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
- size = 0; /* no spaces before newline */
- else
- size = halfsize;
- while (size) {
- size--;
- *d++ = ' ';
- }
- if (fcmd->f_flags & FC_CHOP)
- str_chop(str,chophere);
- break;
- }
- case F_LINES:
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- s = str_get(str);
- size = str_len(str);
- CHKLEN(size+1);
- orec->o_lines += countlines(s,size) - 1;
- Copy(s,d,size,char);
- d += size;
- if (size && s[size-1] != '\n') {
- *d++ = '\n';
- orec->o_lines++;
- }
- linebeg = fcmd->f_next;
- break;
- case F_DECIMAL: {
- double value;
-
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- size = fcmd->f_size;
- CHKLEN(size+1);
- /* If the field is marked with ^ and the value is undefined,
- blank it out. */
- if ((fcmd->f_flags & FC_CHOP) && !str->str_pok && !str->str_nok) {
- while (size) {
- size--;
- *d++ = ' ';
- }
- break;
- }
- blank = FALSE;
- value = str_gnum(str);
- if (fcmd->f_flags & FC_DP) {
- sprintf(d, "%#*.*f", size, fcmd->f_decimals, value);
- } else {
- sprintf(d, "%*.0f", size, value);
- }
- d += size;
- break;
- }
- }
- }
- CHKLEN(1);
- *d++ = '\0';
-}
-
-static int
-countlines(s,size)
-register char *s;
-register int size;
-{
- register int count = 0;
-
- while (size--) {
- if (*s++ == '\n')
- count++;
- }
- return count;
-}
-
-void
-do_write(orec,stab,sp)
-struct outrec *orec;
-STAB *stab;
-int sp;
-{
- register STIO *stio = stab_io(stab);
- FILE *ofp = stio->ofp;
-
-#ifdef DEBUGGING
- if (debug & 256)
- fprintf(stderr,"left=%ld, todo=%ld\n",
- (long)stio->lines_left, (long)orec->o_lines);
-#endif
- if (stio->lines_left < orec->o_lines) {
- if (!stio->top_stab) {
- STAB *topstab;
- char tmpbuf[256];
-
- if (!stio->top_name) {
- if (!stio->fmt_name)
- stio->fmt_name = savestr(stab_name(stab));
- sprintf(tmpbuf, "%s_TOP", stio->fmt_name);
- topstab = stabent(tmpbuf,FALSE);
- if (topstab && stab_form(topstab))
- stio->top_name = savestr(tmpbuf);
- else
- stio->top_name = savestr("top");
- }
- topstab = stabent(stio->top_name,FALSE);
- if (!topstab || !stab_form(topstab)) {
- stio->lines_left = 100000000;
- goto forget_top;
- }
- stio->top_stab = topstab;
- }
- if (stio->lines_left >= 0 && stio->page > 0)
- fwrite(formfeed->str_ptr, formfeed->str_cur, 1, ofp);
- stio->lines_left = stio->page_len;
- stio->page++;
- format(&toprec,stab_form(stio->top_stab),sp);
- fputs(toprec.o_str,ofp);
- stio->lines_left -= toprec.o_lines;
- }
- forget_top:
- fputs(orec->o_str,ofp);
- stio->lines_left -= orec->o_lines;
-}
+++ /dev/null
-/* $RCSfile: form.c,v $$Revision: 4.0.1.3 $$Date: 92/06/08 13:21:42 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: form.c,v $
- * Revision 4.0.1.3 92/06/08 13:21:42 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: form feed for formats is now specifiable via $^L
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- *
- * Revision 4.0.1.2 91/11/05 17:18:43 lwall
- * patch11: formats didn't fill their fields as well as they could
- * patch11: ^ fields chopped hyphens on line break
- * patch11: # fields could write outside allocated memory
- *
- * Revision 4.0.1.1 91/06/07 11:07:59 lwall
- * patch4: new copyright notice
- * patch4: default top-of-form format is now FILEHANDLE_TOP
- *
- * Revision 4.0 91/03/20 01:19:23 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-/* Forms stuff */
-
-static int countlines();
-
-void
-form_parseargs(fcmd)
-register FCMD *fcmd;
-{
- register int i;
- register ARG *arg;
- register int items;
- STR *str;
- ARG *parselist();
- line_t oldline = curcmd->c_line;
- int oldsave = savestack->ary_fill;
-
- str = fcmd->f_unparsed;
- curcmd->c_line = fcmd->f_line;
- fcmd->f_unparsed = Nullstr;
- (void)savehptr(&curstash);
- curstash = str->str_u.str_hash;
- arg = parselist(str);
- restorelist(oldsave);
-
- items = arg->arg_len - 1; /* ignore $$ on end */
- for (i = 1; i <= items; i++) {
- if (!fcmd || fcmd->f_type == F_NULL)
- fatal("Too many field values");
- dehoist(arg,i);
- fcmd->f_expr = make_op(O_ITEM,1,
- arg[i].arg_ptr.arg_arg,Nullarg,Nullarg);
- if (fcmd->f_flags & FC_CHOP) {
- if ((fcmd->f_expr[1].arg_type & A_MASK) == A_STAB)
- fcmd->f_expr[1].arg_type = A_LVAL;
- else if ((fcmd->f_expr[1].arg_type & A_MASK) == A_EXPR)
- fcmd->f_expr[1].arg_type = A_LEXPR;
- else
- fatal("^ field requires scalar lvalue");
- }
- fcmd = fcmd->f_next;
- }
- if (fcmd && fcmd->f_type)
- fatal("Not enough field values");
- curcmd->c_line = oldline;
- Safefree(arg);
- str_free(str);
-}
-
-int newsize;
-
-#define CHKLEN(allow) \
-newsize = (d - orec->o_str) + (allow); \
-if (newsize >= curlen) { \
- curlen = d - orec->o_str; \
- GROWSTR(&orec->o_str,&orec->o_len,orec->o_len + (allow)); \
- d = orec->o_str + curlen; /* in case it moves */ \
- curlen = orec->o_len - 2; \
-}
-
-void
-format(orec,fcmd,sp)
-register struct outrec *orec;
-register FCMD *fcmd;
-int sp;
-{
- register char *d = orec->o_str;
- register char *s;
- register int curlen = orec->o_len - 2;
- register int size;
- FCMD *nextfcmd;
- FCMD *linebeg = fcmd;
- char tmpchar;
- char *t;
- CMD mycmd;
- STR *str;
- char *chophere;
-
- mycmd.c_type = C_NULL;
- orec->o_lines = 0;
- for (; fcmd; fcmd = nextfcmd) {
- nextfcmd = fcmd->f_next;
- CHKLEN(fcmd->f_presize);
- /*SUPPRESS 560*/
- if (s = fcmd->f_pre) {
- while (*s) {
- if (*s == '\n') {
- while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t'))
- d--;
- if (fcmd->f_flags & FC_NOBLANK) {
- if (d == orec->o_str || d[-1] == '\n') {
- orec->o_lines--; /* don't print blank line */
- linebeg = fcmd->f_next;
- break;
- }
- else if (fcmd->f_flags & FC_REPEAT)
- nextfcmd = linebeg;
- else
- linebeg = fcmd->f_next;
- }
- else
- linebeg = fcmd->f_next;
- }
- *d++ = *s++;
- }
- }
- if (fcmd->f_unparsed)
- form_parseargs(fcmd);
- switch (fcmd->f_type) {
- case F_NULL:
- orec->o_lines++;
- break;
- case F_LEFT:
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- s = str_get(str);
- size = fcmd->f_size;
- CHKLEN(size);
- chophere = Nullch;
- while (size && *s && *s != '\n') {
- if (*s == '\t')
- *s = ' ';
- size--;
- if (*s && index(chopset,(*d++ = *s++)))
- chophere = s;
- if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
- *s = ' ';
- }
- if (size || !*s)
- chophere = s;
- else if (chophere && chophere < s && *s && index(chopset,*s))
- chophere = s;
- if (fcmd->f_flags & FC_CHOP) {
- if (!chophere)
- chophere = s;
- size += (s - chophere);
- d -= (s - chophere);
- if (fcmd->f_flags & FC_MORE &&
- *chophere && strNE(chophere,"\n")) {
- while (size < 3) {
- d--;
- size++;
- }
- while (d[-1] == ' ' && size < fcmd->f_size) {
- d--;
- size++;
- }
- *d++ = '.';
- *d++ = '.';
- *d++ = '.';
- size -= 3;
- }
- while (*chophere && index(chopset,*chophere)
- && isSPACE(*chophere))
- chophere++;
- str_chop(str,chophere);
- }
- if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
- size = 0; /* no spaces before newline */
- while (size) {
- size--;
- *d++ = ' ';
- }
- break;
- case F_RIGHT:
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- t = s = str_get(str);
- size = fcmd->f_size;
- CHKLEN(size);
- chophere = Nullch;
- while (size && *s && *s != '\n') {
- if (*s == '\t')
- *s = ' ';
- size--;
- if (*s && index(chopset,*s++))
- chophere = s;
- if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
- *s = ' ';
- }
- if (size || !*s)
- chophere = s;
- else if (chophere && chophere < s && *s && index(chopset,*s))
- chophere = s;
- if (fcmd->f_flags & FC_CHOP) {
- if (!chophere)
- chophere = s;
- size += (s - chophere);
- s = chophere;
- while (*chophere && index(chopset,*chophere)
- && isSPACE(*chophere))
- chophere++;
- }
- tmpchar = *s;
- *s = '\0';
- while (size) {
- size--;
- *d++ = ' ';
- }
- size = s - t;
- Copy(t,d,size,char);
- d += size;
- *s = tmpchar;
- if (fcmd->f_flags & FC_CHOP)
- str_chop(str,chophere);
- break;
- case F_CENTER: {
- int halfsize;
-
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- t = s = str_get(str);
- size = fcmd->f_size;
- CHKLEN(size);
- chophere = Nullch;
- while (size && *s && *s != '\n') {
- if (*s == '\t')
- *s = ' ';
- size--;
- if (*s && index(chopset,*s++))
- chophere = s;
- if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
- *s = ' ';
- }
- if (size || !*s)
- chophere = s;
- else if (chophere && chophere < s && *s && index(chopset,*s))
- chophere = s;
- if (fcmd->f_flags & FC_CHOP) {
- if (!chophere)
- chophere = s;
- size += (s - chophere);
- s = chophere;
- while (*chophere && index(chopset,*chophere)
- && isSPACE(*chophere))
- chophere++;
- }
- tmpchar = *s;
- *s = '\0';
- halfsize = size / 2;
- while (size > halfsize) {
- size--;
- *d++ = ' ';
- }
- size = s - t;
- Copy(t,d,size,char);
- d += size;
- *s = tmpchar;
- if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
- size = 0; /* no spaces before newline */
- else
- size = halfsize;
- while (size) {
- size--;
- *d++ = ' ';
- }
- if (fcmd->f_flags & FC_CHOP)
- str_chop(str,chophere);
- break;
- }
- case F_LINES:
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- s = str_get(str);
- size = str_len(str);
- CHKLEN(size+1);
- orec->o_lines += countlines(s,size) - 1;
- Copy(s,d,size,char);
- d += size;
- if (size && s[size-1] != '\n') {
- *d++ = '\n';
- orec->o_lines++;
- }
- linebeg = fcmd->f_next;
- break;
- case F_DECIMAL: {
- double value;
-
- (void)eval(fcmd->f_expr,G_SCALAR,sp);
- str = stack->ary_array[sp+1];
- size = fcmd->f_size;
- CHKLEN(size+1);
- /* If the field is marked with ^ and the value is undefined,
- blank it out. */
- if ((fcmd->f_flags & FC_CHOP) && !str->str_pok && !str->str_nok) {
- while (size) {
- size--;
- *d++ = ' ';
- }
- break;
- }
- value = str_gnum(str);
- if (fcmd->f_flags & FC_DP) {
- sprintf(d, "%#*.*f", size, fcmd->f_decimals, value);
- } else {
- sprintf(d, "%*.0f", size, value);
- }
- d += size;
- break;
- }
- }
- }
- CHKLEN(1);
- *d++ = '\0';
-}
-
-static int
-countlines(s,size)
-register char *s;
-register int size;
-{
- register int count = 0;
-
- while (size--) {
- if (*s++ == '\n')
- count++;
- }
- return count;
-}
-
-void
-do_write(orec,stab,sp)
-struct outrec *orec;
-STAB *stab;
-int sp;
-{
- register STIO *stio = stab_io(stab);
- FILE *ofp = stio->ofp;
-
-#ifdef DEBUGGING
- if (debug & 256)
- fprintf(stderr,"left=%ld, todo=%ld\n",
- (long)stio->lines_left, (long)orec->o_lines);
-#endif
- if (stio->lines_left < orec->o_lines) {
- if (!stio->top_stab) {
- STAB *topstab;
- char tmpbuf[256];
-
- if (!stio->top_name) {
- if (!stio->fmt_name)
- stio->fmt_name = savestr(stab_name(stab));
- sprintf(tmpbuf, "%s_TOP", stio->fmt_name);
- topstab = stabent(tmpbuf,FALSE);
- if (topstab && stab_form(topstab))
- stio->top_name = savestr(tmpbuf);
- else
- stio->top_name = savestr("top");
- }
- topstab = stabent(stio->top_name,FALSE);
- if (!topstab || !stab_form(topstab)) {
- stio->lines_left = 100000000;
- goto forget_top;
- }
- stio->top_stab = topstab;
- }
- if (stio->lines_left >= 0 && stio->page > 0)
- fwrite(formfeed->str_ptr, formfeed->str_cur, 1, ofp);
- stio->lines_left = stio->page_len;
- stio->page++;
- format(&toprec,stab_form(stio->top_stab),sp);
- fputs(toprec.o_str,ofp);
- stio->lines_left -= toprec.o_lines;
- }
- forget_top:
- fputs(orec->o_str,ofp);
- stio->lines_left -= orec->o_lines;
-}
+++ /dev/null
-***************
-*** 1,4 ****
-! /* $RCSfile: form.c,v $$Revision: 4.0.1.3 $$Date: 1992/06/08 13:21:42 $
- *
- * Copyright (c) 1991, Larry Wall
- *
---- 1,4 ----
-! /* $RCSfile: form.c,v $$Revision: 4.0.1.4 $$Date: 1993/02/05 19:34:32 $
- *
- * Copyright (c) 1991, Larry Wall
- *
-***************
-*** 6,16 ****
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: form.c,v $
-! * Revision 4.0.1.3 1992/06/08 13:21:42 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: form feed for formats is now specifiable via $^L
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
-! *
- * Revision 4.0.1.2 91/11/05 17:18:43 lwall
- * patch11: formats didn't fill their fields as well as they could
- * patch11: ^ fields chopped hyphens on line break
---- 6,19 ----
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: form.c,v $
-! * Revision 4.0.1.4 1993/02/05 19:34:32 lwall
-! * patch36: formats now ignore literal text for ~~ loop determination
-! *
-! * Revision 4.0.1.3 92/06/08 13:21:42 lwall
- * patch20: removed implicit int declarations on funcions
- * patch20: form feed for formats is now specifiable via $^L
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
-! *
- * Revision 4.0.1.2 91/11/05 17:18:43 lwall
- * patch11: formats didn't fill their fields as well as they could
- * patch11: ^ fields chopped hyphens on line break
-/* $RCSfile: form.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:08:20 $
+/* $RCSfile: form.h,v $$Revision: 4.1 $$Date: 92/08/07 18:20:43 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: form.h,v $
+ * Revision 4.1 92/08/07 18:20:43 lwall
+ *
* Revision 4.0.1.1 91/06/07 11:08:20 lwall
* patch4: new copyright notice
*
*
*/
-#define F_NULL 0
-#define F_LEFT 1
-#define F_RIGHT 2
-#define F_CENTER 3
-#define F_LINES 4
-#define F_DECIMAL 5
-
-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;
- short f_decimals;
- char f_type;
- char f_flags;
-};
-
-#define FC_CHOP 1
-#define FC_NOBLANK 2
-#define FC_MORE 4
-#define FC_REPEAT 8
-#define FC_DP 16
-
-#define Nullfcmd Null(FCMD*)
+#define FF_END 0
+#define FF_LINEMARK 1
+#define FF_LITERAL 2
+#define FF_SKIP 3
+#define FF_FETCH 4
+#define FF_CHECKNL 5
+#define FF_CHECKCHOP 6
+#define FF_SPACE 7
+#define FF_HALFSPACE 8
+#define FF_ITEM 9
+#define FF_CHOP 10
+#define FF_LINEGLOB 11
+#define FF_DECIMAL 12
+#define FF_NEWLINE 13
+#define FF_BLANK 14
+#define FF_MORE 15
-EXT char *chopset INIT(" \n-");
--- /dev/null
+FF *
+parse_format()
+{
+ FF froot;
+ FF *flinebeg;
+ char *eol;
+ register FF *fprev = &froot;
+ register FF *fcmd;
+ register char *s;
+ register char *t;
+ register SV *sv;
+ bool noblank;
+ bool repeater;
+
+ Zero(&froot, 1, FF);
+ s = bufptr;
+ while (s < bufend || (rsfp && (s = sv_gets(linestr,rsfp, 0)) != Nullch)) {
+ curcop->cop_line++;
+ if (in_eval && !rsfp) {
+ eol = index(s,'\n');
+ if (!eol++)
+ eol = bufend;
+ }
+ else
+ eol = bufend = linestr->sv_ptr + linestr->sv_cur;
+ if (perldb) {
+ SV *tmpstr = NEWSV(89,0);
+
+ sv_setpvn(tmpstr, s, eol-s);
+ av_store(GvAV(curcop->cop_filegv), (int)curcop->cop_line,tmpstr);
+ }
+ if (*s == '.') {
+ /*SUPPRESS 530*/
+ for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
+ if (*t == '\n') {
+ bufptr = s;
+ return froot.ff_next;
+ }
+ }
+ if (*s == '#') {
+ s = eol;
+ continue;
+ }
+ flinebeg = Nullfield;
+ noblank = FALSE;
+ repeater = FALSE;
+ while (s < eol) {
+ Newz(804,fcmd,1,FF);
+ fprev->ff_next = fcmd;
+ fprev = fcmd;
+ for (t=s; t < eol && *t != '@' && *t != '^'; t++) {
+ if (*t == '~') {
+ noblank = TRUE;
+ *t = ' ';
+ if (t[1] == '~') {
+ repeater = TRUE;
+ t[1] = ' ';
+ }
+ }
+ }
+ fcmd->ff_pre = nsavestr(s, t-s);
+ fcmd->ff_presize = t-s;
+ s = t;
+ if (s >= eol) {
+ if (noblank)
+ fcmd->ff_flags |= FFf_NOBLANK;
+ if (repeater)
+ fcmd->ff_flags |= FFf_REPEAT;
+ break;
+ }
+ if (!flinebeg)
+ flinebeg = fcmd; /* start values here */
+ if (*s++ == '^')
+ fcmd->ff_flags |= FFf_CHOP; /* for doing text filling */
+ switch (*s) {
+ case '*':
+ fcmd->ff_type = FFt_LINES;
+ *s = '\0';
+ break;
+ case '<':
+ fcmd->ff_type = FFt_LEFT;
+ while (*s == '<')
+ s++;
+ break;
+ case '>':
+ fcmd->ff_type = FFt_RIGHT;
+ while (*s == '>')
+ s++;
+ break;
+ case '|':
+ fcmd->ff_type = FFt_CENTER;
+ while (*s == '|')
+ s++;
+ break;
+ case '#':
+ case '.':
+ /* Catch the special case @... and handle it as a string
+ field. */
+ if (*s == '.' && s[1] == '.') {
+ goto default_format;
+ }
+ fcmd->ff_type = FFt_DECIMAL;
+ {
+ char *p;
+
+ /* Read a run_format in the form @####.####, where either group
+ of ### may be empty, or the final .### may be missing. */
+ while (*s == '#')
+ s++;
+ if (*s == '.') {
+ s++;
+ p = s;
+ while (*s == '#')
+ s++;
+ fcmd->ff_decimals = s-p;
+ fcmd->ff_flags |= FFf_DP;
+ } else {
+ fcmd->ff_decimals = 0;
+ }
+ }
+ break;
+ default:
+ default_format:
+ fcmd->ff_type = FFt_LEFT;
+ break;
+ }
+ if (fcmd->ff_flags & FFf_CHOP && *s == '.') {
+ fcmd->ff_flags |= FFf_MORE;
+ while (*s == '.')
+ s++;
+ }
+ fcmd->ff_size = s-t;
+ }
+ if (flinebeg) {
+ again:
+ if (s >= bufend &&
+ (!rsfp || (s = sv_gets(linestr, rsfp, 0)) == Nullch) )
+ goto badform;
+ curcop->cop_line++;
+ if (in_eval && !rsfp) {
+ eol = index(s,'\n');
+ if (!eol++)
+ eol = bufend;
+ }
+ else
+ eol = bufend = linestr->sv_ptr + linestr->sv_cur;
+ if (perldb) {
+ SV *tmpstr = NEWSV(90,0);
+
+ sv_setpvn(tmpstr, s, eol-s);
+ av_store(GvAV(curcop->cop_filegv),
+ (int)curcop->cop_line,tmpstr);
+ }
+ if (strnEQ(s,".\n",2)) {
+ bufptr = s;
+ yyerror("Missing values line");
+ return froot.ff_next;
+ }
+ if (*s == '#') {
+ s = eol;
+ goto again;
+ }
+ sv = flinebeg->ff_unparsed = NEWSV(91,eol - s);
+ sv->sv_u.sv_hv = curstash;
+ sv_setpvn(sv,"(",1);
+ flinebeg->ff_line = curcop->cop_line;
+ eol[-1] = '\0';
+ if (!flinebeg->ff_next->ff_type || index(s, ',')) {
+ eol[-1] = '\n';
+ sv_catpvn(sv, s, eol - s - 1);
+ sv_catpvn(sv,",$$);",5);
+ s = eol;
+ }
+ else {
+ eol[-1] = '\n';
+ while (s < eol && isSPACE(*s))
+ s++;
+ t = s;
+ while (s < eol) {
+ switch (*s) {
+ case ' ': case '\t': case '\n': case ';':
+ sv_catpvn(sv, t, s - t);
+ sv_catpvn(sv, "," ,1);
+ while (s < eol && (isSPACE(*s) || *s == ';'))
+ s++;
+ t = s;
+ break;
+ case '$':
+ sv_catpvn(sv, t, s - t);
+ t = s;
+ s = scan_ident(s,eol,tokenbuf,FALSE);
+ sv_catpvn(sv, t, s - t);
+ t = s;
+ if (s < eol && *s && index("$'\"",*s))
+ sv_catpvn(sv, ",", 1);
+ break;
+ case '"': case '\'':
+ sv_catpvn(sv, t, s - t);
+ t = s;
+ s++;
+ while (s < eol && (*s != *t || s[-1] == '\\'))
+ s++;
+ if (s < eol)
+ s++;
+ sv_catpvn(sv, t, s - t);
+ t = s;
+ if (s < eol && *s && index("$'\"",*s))
+ sv_catpvn(sv, ",", 1);
+ break;
+ default:
+ yyerror("Please use commas to separate fields");
+ }
+ }
+ sv_catpvn(sv,"$$);",4);
+ }
+ }
+ }
+ badform:
+ bufptr = SvPV(linestr);
+ yyerror("Format not terminated");
+ return froot.ff_next;
+}
+
--- /dev/null
+OP *
+newFOROP(label,forline,scalar,expr,block,cont)
+char *label;
+line_t forline;
+OP *scalar;
+OP *expr
+OP *block
+OP *cont;
+{
+ OP *newop;
+
+ copline = forline;
+
+ /*
+ * 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 newGVgen().
+ * (Note that @ary may become a local array if
+ * it is determined that it might be called
+ * recursively. See cmd_tosave().)
+ */
+ if (expr->op_type != OP_ARRAY) {
+ scrstab = gv_AVadd(newGVgen());
+ newop = append_elem(OP_LINESEQ,
+ newSTATEOP(label,
+ newBINOP(OP_ASSIGN,
+ listref(newUNOP(OP_ARRAY,
+ gv_to_op(A_STAB,scrstab))),
+ forcelist(expr))),
+ loopscope(over(scalar,newSTATEOP(label,
+ newLOOPOP( 0,
+ newUNOP(OP_ARRAY,
+ gv_to_op(A_STAB,scrstab)),
+ block,cont)))));
+ newop->cop_line = forline;
+ newop->cop_head->cop_line = forline;
+ }
+ else {
+ newop = loopscope(over(scalar,newSTATEOP(label,
+ newLOOPOP(1,expr,block,cont) )));
+ }
+ return newop;
+}
--- /dev/null
+head 20301.49;
+access ;
+symbols r03_01_13:20301.49 r03_01_12:20301.47 r03_01_11:20301.47 r03_01_10:20301.47 r03_01_09:20301.47 r03_01_08:20301.47 r03_01_07:20301.47 r03_01_06:20301.46 r03_01_05:20301.46 trout-farm:20301.43.1.1 r03_01_04:20301.45 r03_01_03:20301.43.1.1 r03_01_02:20301.43 r03_01_01:20301.43 r03_01_00:20301.43 r03_00_02:20301.41.1.1 r03_00_01:20301.38 r03_00_00:20301.37 r02_02_03_hp:20301.6 r02_02_02_hp:20301.2 r02_02_01_hp:20201.35 stage_02:20201.35 stage_01:20201.35 r02_01_09_hp:20103.1.1.1.1.1 r02_01_08_hp:20103.1.1.1.1.1 r02_01_07_hp:20103.1.1.1 r02_01_06_hp:20103.1.1.1 r02_01_05_hp:20103.1 r02_02_00_hp:20201.28 r02_01_04_hp:20103.1 r02_01_03_hp:20103.1 r02_01_02_hp:20102.3 r02_01_01_hp:1.4 r02_01_00_hp:1.2 stage:1.2 r01_00_41_hp:1.1;
+locks ; strict;
+comment @ * @;
+
+
+20301.49
+date 91.07.15.11.01.55; author twood; state r03_01_13;
+branches ;
+next 20301.48;
+
+20301.48
+date 91.07.11.16.16.43; author twood; state Exp;
+branches ;
+next 20301.47;
+
+20301.47
+date 91.05.31.15.16.41; author twood; state r03_01_12;
+branches ;
+next 20301.46;
+
+20301.46
+date 91.05.16.13.14.38; author twood; state r03_01_06;
+branches ;
+next 20301.45;
+
+20301.45
+date 91.05.08.16.32.02; author twood; state r03_01_04;
+branches ;
+next 20301.44;
+
+20301.44
+date 91.05.07.15.56.50; author twood; state Exp;
+branches ;
+next 20301.43;
+
+20301.43
+date 91.04.09.09.15.58; author twood; state r03_01_03;
+branches 20301.43.1.1;
+next 20301.42;
+
+20301.42
+date 91.03.27.15.42.43; author twood; state Exp;
+branches ;
+next 20301.41;
+
+20301.41
+date 91.03.27.10.35.38; author twood; state Exp;
+branches 20301.41.1.1;
+next 20301.40;
+
+20301.40
+date 91.03.25.14.36.14; author twood; state Exp;
+branches ;
+next 20301.39;
+
+20301.39
+date 91.03.21.10.47.45; author melodi; state Exp;
+branches ;
+next 20301.38;
+
+20301.38
+date 91.03.19.09.59.42; author twood; state r03_00_01;
+branches ;
+next 20301.37;
+
+20301.37
+date 91.03.05.13.03.52; author melodi; state Exp;
+branches ;
+next 20301.36;
+
+20301.36
+date 91.03.05.10.46.57; author melodi; state Exp;
+branches ;
+next 20301.35;
+
+20301.35
+date 91.02.19.09.32.29; author twood; state Exp;
+branches ;
+next 20301.34;
+
+20301.34
+date 91.02.13.16.19.01; author twood; state Exp;
+branches ;
+next 20301.33;
+
+20301.33
+date 91.02.08.12.33.50; author melodi; state Exp;
+branches ;
+next 20301.32;
+
+20301.32
+date 91.02.05.14.40.10; author melodi; state Exp;
+branches ;
+next 20301.31;
+
+20301.31
+date 91.01.25.11.41.11; author melodi; state Exp;
+branches ;
+next 20301.30;
+
+20301.30
+date 91.01.25.08.54.11; author twood; state Exp;
+branches ;
+next 20301.29;
+
+20301.29
+date 91.01.25.08.47.41; author melodi; state Exp;
+branches ;
+next 20301.28;
+
+20301.28
+date 91.01.23.15.18.20; author twood; state Exp;
+branches ;
+next 20301.27;
+
+20301.27
+date 91.01.22.16.30.23; author melodi; state Exp;
+branches ;
+next 20301.26;
+
+20301.26
+date 91.01.22.11.51.03; author pepler; state Exp;
+branches ;
+next 20301.25;
+
+20301.25
+date 91.01.17.14.03.19; author greg; state Exp;
+branches ;
+next 20301.24;
+
+20301.24
+date 91.01.17.11.05.36; author pepler; state Exp;
+branches ;
+next 20301.23;
+
+20301.23
+date 91.01.16.16.20.24; author greg; state Exp;
+branches ;
+next 20301.22;
+
+20301.22
+date 91.01.15.12.35.53; author greg; state Exp;
+branches ;
+next 20301.21;
+
+20301.21
+date 91.01.11.12.16.03; author greg; state Exp;
+branches ;
+next 20301.20;
+
+20301.20
+date 91.01.11.10.41.39; author melodi; state Exp;
+branches ;
+next 20301.19;
+
+20301.19
+date 91.01.03.14.31.49; author twood; state Exp;
+branches ;
+next 20301.18;
+
+20301.18
+date 91.01.02.11.02.45; author greg; state Exp;
+branches ;
+next 20301.17;
+
+20301.17
+date 90.12.28.17.21.08; author greg; state Exp;
+branches ;
+next 20301.16;
+
+20301.16
+date 90.12.21.10.18.52; author greg; state Exp;
+branches ;
+next 20301.15;
+
+20301.15
+date 90.12.19.17.38.10; author greg; state Exp;
+branches ;
+next 20301.14;
+
+20301.14
+date 90.12.19.08.40.09; author twood; state Exp;
+branches ;
+next 20301.13;
+
+20301.13
+date 90.12.17.08.20.40; author greg; state Exp;
+branches ;
+next 20301.12;
+
+20301.12
+date 90.12.13.08.11.32; author greg; state Exp;
+branches ;
+next 20301.11;
+
+20301.11
+date 90.12.10.09.32.39; author greg; state Exp;
+branches ;
+next 20301.10;
+
+20301.10
+date 90.12.10.08.59.12; author twood; state Exp;
+branches ;
+next 20301.9;
+
+20301.9
+date 90.12.03.11.56.24; author pepler; state Exp;
+branches ;
+next 20301.8;
+
+20301.8
+date 90.11.29.12.06.14; author melodi; state Exp;
+branches ;
+next 20301.7;
+
+20301.7
+date 90.11.29.11.37.42; author twood; state Exp;
+branches ;
+next 20301.6;
+
+20301.6
+date 90.11.16.14.46.42; author pepler; state r02_02_03_hp;
+branches ;
+next 20301.5;
+
+20301.5
+date 90.11.16.13.47.22; author melodi; state Exp;
+branches ;
+next 20301.4;
+
+20301.4
+date 90.11.15.14.45.11; author melodi; state Exp;
+branches ;
+next 20301.3;
+
+20301.3
+date 90.11.14.15.18.28; author twood; state Exp;
+branches ;
+next 20301.2;
+
+20301.2
+date 90.11.14.08.13.16; author greg; state r02_02_02_hp;
+branches ;
+next 20301.1;
+
+20301.1
+date 90.11.13.09.55.08; author greg; state Exp;
+branches ;
+next 20201.38;
+
+20201.38
+date 90.11.07.17.00.01; author melodi; state Exp;
+branches ;
+next 20201.37;
+
+20201.37
+date 90.11.07.16.58.34; author greg; state Exp;
+branches ;
+next 20201.36;
+
+20201.36
+date 90.11.07.16.09.07; author twood; state Exp;
+branches ;
+next 20201.35;
+
+20201.35
+date 90.10.25.10.40.53; author melodi; state r02_02_01_hp;
+branches ;
+next 20201.34;
+
+20201.34
+date 90.10.24.17.31.46; author melodi; state Exp;
+branches ;
+next 20201.33;
+
+20201.33
+date 90.10.23.16.22.21; author greg; state Exp;
+branches ;
+next 20201.32;
+
+20201.32
+date 90.10.23.09.06.11; author twood; state Exp;
+branches ;
+next 20201.31;
+
+20201.31
+date 90.10.22.12.18.42; author melodi; state Exp;
+branches ;
+next 20201.30;
+
+20201.30
+date 90.10.22.11.40.59; author twood; state Exp;
+branches ;
+next 20201.29;
+
+20201.29
+date 90.10.19.11.59.03; author greg; state Exp;
+branches ;
+next 20201.28;
+
+20201.28
+date 90.10.16.14.10.59; author greg; state r02_02_00_hp;
+branches ;
+next 20201.27;
+
+20201.27
+date 90.10.15.08.51.32; author greg; state Exp;
+branches ;
+next 20201.26;
+
+20201.26
+date 90.10.12.11.29.14; author twood; state Exp;
+branches ;
+next 20201.25;
+
+20201.25
+date 90.10.02.12.28.18; author greg; state sandbox;
+branches ;
+next 20201.24;
+
+20201.24
+date 90.10.02.11.06.06; author greg; state Exp;
+branches ;
+next 20201.23;
+
+20201.23
+date 90.09.28.11.13.27; author greg; state Exp;
+branches ;
+next 20201.22;
+
+20201.22
+date 90.09.28.10.17.28; author twood; state Exp;
+branches ;
+next 20201.21;
+
+20201.21
+date 90.09.25.13.05.13; author greg; state Exp;
+branches ;
+next 20201.20;
+
+20201.20
+date 90.09.24.16.26.29; author twood; state Exp;
+branches ;
+next 20201.19;
+
+20201.19
+date 90.09.10.10.53.22; author twood; state Exp;
+branches ;
+next 20201.18;
+
+20201.18
+date 90.09.10.10.39.48; author greg; state Exp;
+branches ;
+next 20201.17;
+
+20201.17
+date 90.08.29.14.27.40; author twood; state Exp;
+branches ;
+next 20201.16;
+
+20201.16
+date 90.08.29.13.03.02; author melodi; state Exp;
+branches ;
+next 20201.15;
+
+20201.15
+date 90.08.17.15.52.55; author twood; state Exp;
+branches ;
+next 20201.14;
+
+20201.14
+date 90.08.14.13.11.15; author twood; state Exp;
+branches ;
+next 20201.13;
+
+20201.13
+date 90.08.14.12.39.43; author melodi; state Exp;
+branches ;
+next 20201.12;
+
+20201.12
+date 90.08.10.10.15.52; author melodi; state Exp;
+branches ;
+next 20201.11;
+
+20201.11
+date 90.08.08.15.13.21; author greg; state Exp;
+branches ;
+next 20201.10;
+
+20201.10
+date 90.08.08.14.22.52; author greg; state Exp;
+branches ;
+next 20201.9;
+
+20201.9
+date 90.08.07.09.22.07; author melodi; state Exp;
+branches ;
+next 20201.8;
+
+20201.8
+date 90.08.07.08.29.22; author melodi; state Exp;
+branches ;
+next 20201.7;
+
+20201.7
+date 90.08.06.12.21.43; author twood; state Exp;
+branches ;
+next 20201.6;
+
+20201.6
+date 90.07.26.15.49.03; author melodi; state Exp;
+branches ;
+next 20201.5;
+
+20201.5
+date 90.07.26.13.37.53; author melodi; state Exp;
+branches ;
+next 20201.4;
+
+20201.4
+date 90.07.24.11.11.21; author melodi; state Exp;
+branches ;
+next 20201.3;
+
+20201.3
+date 90.07.17.13.41.20; author melodi; state Exp;
+branches ;
+next 20201.2;
+
+20201.2
+date 90.06.14.10.43.29; author greg; state Exp;
+branches ;
+next 20201.1;
+
+20201.1
+date 90.06.12.10.37.36; author greg; state Exp;
+branches ;
+next 20103.1;
+
+20103.1
+date 90.05.17.08.57.08; author melodi; state r02_01_05_hp;
+branches 20103.1.1.1;
+next 20102.3;
+
+20102.3
+date 90.05.08.08.56.46; author ricks; state r02_01_02_hp;
+branches ;
+next 20102.2;
+
+20102.2
+date 90.05.03.08.00.21; author greg; state r02_01_02_hp;
+branches ;
+next 20102.1;
+
+20102.1
+date 90.04.30.14.22.39; author greg; state r02_01_02_hp;
+branches ;
+next 1.5;
+
+1.5
+date 90.04.30.09.53.46; author greg; state Exp;
+branches ;
+next 1.4;
+
+1.4
+date 90.04.20.16.43.05; author greg; state r02_01_02_hp;
+branches ;
+next 1.3;
+
+1.3
+date 90.04.17.15.03.42; author greg; state Exp;
+branches ;
+next 1.2;
+
+1.2
+date 90.03.14.15.23.08; author admin; state r02_01_00_hp;
+branches ;
+next 1.1;
+
+1.1
+date 90.03.12.11.58.44; author rampson; state Exp;
+branches ;
+next ;
+
+20103.1.1.1
+date 90.07.26.14.56.36; author twood; state r02_01_07_hp;
+branches 20103.1.1.1.1.1;
+next 20103.1.1.2;
+
+20103.1.1.2
+date 90.08.13.11.13.31; author melodi; state Exp;
+branches ;
+next ;
+
+20103.1.1.1.1.1
+date 90.08.16.14.19.32; author greg; state r02_01_09_hp;
+branches ;
+next ;
+
+20301.41.1.1
+date 91.03.27.15.46.26; author twood; state r03_00_02;
+branches ;
+next ;
+
+20301.43.1.1
+date 91.05.08.12.56.08; author rfullmer; state trout-farm;
+branches ;
+next ;
+
+
+desc
+@@
+
+
+20301.49
+log
+@CR#10427:M:added sr08load.
+@
+text
+@/*****************************************************************************
+*
+* CONFIDENTIAL
+* Disclose And Distribute Solely To Employees Of
+* U S WEST And It's Affiliates Having A Need To Know.
+*
+*------------------------------------------------------------------------
+*
+* (c)Copyright 1990, U S WEST Information Technologies Group
+* All Rights Reserved
+*
+******************************************************************************/
+@
+
+
+20301.48
+log
+@CR#10488:M:changed upent9/10 & downent9/10 to upent11/12 & downent11/12
+@
+text
+@d24 3
+d570 1
+@
+
+
+20301.47
+log
+@CR#10237:M:added sr16 ???NextPagePart functions.
+@
+text
+@d24 3
+d473 2
+a474 2
+ {"downent10", (caddr_t)downent10},
+ {"downent9", (caddr_t)downent9},
+d580 2
+a581 2
+ {"upent10", (caddr_t)upent10},
+ {"upent9", (caddr_t)upent9},
+@
+
+
+20301.46
+log
+@ CR#9586:M:added slider bars to screendisp
+@
+text
+@d24 3
+d303 1
+d306 1
+d313 1
+d326 1
+d345 1
+@
+
+
+20301.45
+log
+@CR#9912:M:changed BOSSCSBlIbal to BOSSCSBLIbal (capitalized the first L)
+@
+text
+@d24 3
+d281 1
+d352 1
+@
+
+
+20301.44
+log
+@ CR#9912:M:added BOSSCSBlIbal
+@
+text
+@d24 3
+d275 1
+a275 1
+ {"BOSSCSBlIbal", (caddr_t)BOSSCSBlIbal},
+d369 1
+@
+
+
+20301.43
+log
+@CR#9279:M:removed collections
+@
+text
+@d24 3
+d272 1
+a321 1
+ {"MakeTreatTypeText", (caddr_t)MakeTreatTypeText},
+@
+
+
+20301.43.1.1
+log
+@CR#9904:M:Remove MakeTreatTypeText reference
+@
+text
+@a23 3
+ * Revision 20301.43 91/04/09 09:15:58 09:15:58 twood (Tim Woodward)
+ * CR#9279:M:removed collections
+ *
+d318 1
+@
+
+
+20301.42
+log
+@ CR#9279:M:deleted change_trfuuid and change_hostid
+@
+text
+@d24 3
+a426 2
+ {"collectdcback", (caddr_t)collectdcback},
+ {"collections", (caddr_t)collections},
+@
+
+
+20301.41
+log
+@CR#9532:M:deleted Check Exit
+@
+text
+@d276 1
+a400 2
+ {"change_hostid", (caddr_t)change_hostid},
+ {"change_trfuuid", (caddr_t)change_trfuuid},
+@
+
+
+20301.41.1.1
+log
+@ CR#9596:M:deleted change_trfuuid and change_hostid
+@
+text
+@a23 3
+ * Revision 20301.41 91/03/27 10:35:38 10:35:38 twood (Tim Woodward)
+ * CR#9532:M:deleted Check Exit
+ *
+d400 2
+@
+
+
+20301.40
+log
+@CR#9532:M:added CheckExit
+@
+text
+@d24 3
+a262 1
+ {"CheckExit", (caddr_t)CheckExit},
+@
+
+
+20301.39
+log
+@CR#9492:M:Bring up UBIC Summary when UBIC flup selected from QTFU/TRFU
+@
+text
+@d24 3
+d260 1
+@
+
+
+20301.38
+log
+@ CR#9458:M: added BuildDialog funcs
+@
+text
+@d24 3
+d270 1
+a398 1
+ {"checklock", (caddr_t)checklock},
+@
+
+
+20301.37
+log
+@add AmtTtlDpstAccnt
+@
+text
+@d24 3
+d259 2
+@
+
+
+20301.36
+log
+@remove obsolete nextserfunc
+@
+text
+@d24 3
+d246 1
+@
+
+
+20301.35
+log
+@added OTCEntAmt1 and OTCEntAmt2
+@
+text
+@d24 3
+a479 1
+ {"nextserfunc", (caddr_t)nextserfunc},
+@
+
+
+20301.34
+log
+@added requestcpal and change_hostid
+@
+text
+@d24 3
+d305 2
+@
+
+
+20301.33
+log
+@remove follow through actions, add new traversable buttons & window ID
+indicator
+@
+text
+@d24 4
+d329 1
+d373 1
+@
+
+
+20301.32
+log
+@add NextPayFill()
+@
+text
+@d24 3
+d287 1
+@
+
+
+20301.31
+log
+@work on prev bill & Forward for pay/adj
+@
+text
+@d24 3
+d287 1
+@
+
+
+20301.30
+log
+@CR#7187:M:removed GetCPAL
+@
+text
+@d24 3
+d309 1
+@
+
+
+20301.29
+log
+@added NextPay()
+@
+text
+@d24 3
+a257 1
+ {"GetCPAL", (caddr_t)GetCPAL},
+@
+
+
+20301.28
+log
+@CR#7588:M: added GetCPAL and CSBlIbal
+@
+text
+@d24 3
+d278 1
+@
+
+
+20301.27
+log
+@added ShowPayAdj
+@
+text
+@d24 3
+d230 1
+d252 1
+@
+
+
+20301.26
+log
+@CR#8822:M:remove natmodes
+@
+text
+@d24 3
+d263 1
+a263 1
+ {"LowEnttyID", (caddr_t)LowEnttyID},
+d304 2
+a313 2
+ {"SONARpsw", (caddr_t)SONARpsw},
+ {"SOPADpsw", (caddr_t)SOPADpsw},
+d315 1
+@
+
+
+20301.25
+log
+@CR#7170:M: Added getdefaultval function
+@
+text
+@d24 3
+a433 1
+ {"natmodes", (caddr_t)natmodes},
+@
+
+
+20301.24
+log
+@CR#8822:M:added autologon functions
+@
+text
+@d24 3
+d398 1
+@
+
+
+20301.23
+log
+@CR#7170:M: Worked on note cooperation
+@
+text
+@d24 3
+d206 3
+d214 1
+d224 1
+d232 1
+d249 3
+d303 2
+d428 1
+@
+
+
+20301.22
+log
+@CR#7170:M: Made LoadFollowUpKeys() function
+@
+text
+@d24 3
+d225 1
+d246 1
+d263 1
+d280 1
+a376 1
+ {"fix_buttons", (caddr_t)fix_buttons},
+@
+
+
+20301.21
+log
+@CR#7170:M: Added StippleButton function
+@
+text
+@d24 3
+d236 1
+@
+
+
+20301.20
+log
+@CR#8718:M:New payments & adjustments functionality
+@
+text
+@d24 3
+d281 1
+@
+
+
+20301.19
+log
+@CR#7187:M: added sr14load
+@
+text
+@d24 3
+d221 1
+d231 1
+d250 1
+d260 1
+@
+
+
+20301.18
+log
+@CR#7169:M: Worked on genericizing lists
+@
+text
+@d24 3
+d444 1
+@
+
+
+20301.17
+log
+@CR#7170:M: Generalized the Trfu and Qtfu shared functions for all lists
+@
+text
+@d24 3
+d200 1
+d213 1
+d242 1
+@
+
+
+20301.16
+log
+@CR#7192:M: Worked on TRFU and QTFU follow thru code
+@
+text
+@d24 3
+d185 4
+d194 1
+d220 2
+a221 1
+ {"MakeTreatText", (caddr_t)MakeTreatText},
+a236 1
+ {"Prev_month_valuator", (caddr_t)Prev_month_valuator},
+d239 1
+d250 2
+a252 7
+ {"RequestTSUM", (caddr_t)RequestTSUM},
+ {"SaveFollowUpVariables", (caddr_t)SaveFollowUpVariables},
+ {"SelectFollowUpItem", (caddr_t)SelectFollowUpItem},
+ {"SendDataToCLSA", (caddr_t)SendDataToCLSA},
+ {"Set120LineList", (caddr_t)Set120LineList},
+ {"SetDataFields", (caddr_t)SetDataFields},
+ {"ShortenFollowUpList", (caddr_t)ShortenFollowUpList},
+d258 4
+d266 1
+d294 1
+d296 1
+a297 1
+ {"checkpi", (caddr_t)checkpi},
+d300 2
+a312 2
+ {"closeRestCallback", (caddr_t)closeRestCallback},
+ {"closeWinCallback", (caddr_t)closeWinCallback},
+a316 1
+ {"crtranhead", (caddr_t)crtranhead},
+d333 1
+d340 1
+a341 1
+ {"downent10", (caddr_t)downent10},
+d370 1
+a371 1
+ {"list_deposit", (caddr_t)list_deposit},
+d418 1
+a424 1
+ {"send_refund", (caddr_t)send_refund},
+d447 1
+a448 1
+ {"upent10", (caddr_t)upent10},
+@
+
+
+20301.15
+log
+@CR#7192:M: Worked on QTFU
+@
+text
+@d23 4
+a26 1
+* $Log: functab.h,v $
+d244 1
+d248 1
+@
+
+
+20301.14
+log
+@CR#7174:M: added requestTSUM
+@
+text
+@d3 3
+a5 3
+* CONFIDENTIAL
+* Disclose And Distribute Solely To Employees Of
+* U S WEST And It's Affiliates Having A Need To Know.
+d9 2
+a10 2
+* (c)Copyright 1990, U S WEST Information Technologies Group
+* All Rights Reserved
+d23 4
+a26 1
+* $Log: functab.h,v $
+d160 1
+a160 1
+* THIS CODE HAS NOT BEEN MADE TO COMPLY WITH NEW STANDARDS !
+d177 1
+a177 1
+Tabfunc functable[] =
+d179 261
+a439 252
+ {"BOSSDateEffctv", (caddr_t)BOSSDateEffctv},
+ {"CB", (caddr_t)CB},
+ {"CBED", (caddr_t)CBED},
+ {"CSRData", (caddr_t)CSRData},
+ {"CancelTRFU", (caddr_t)CancelTRFU},
+ {"CchEnttySmmry", (caddr_t)CchEnttySmmry},
+ {"ClearEnd", (caddr_t)ClearEnd},
+ {"CloseUbic", (caddr_t)CloseUbic},
+ {"CpalCodeEntity", (caddr_t)CpalCodeEntity},
+ {"CustPayAmt", (caddr_t)CustPayAmt},
+ {"DADGenericImage", (caddr_t)DADGenericImage},
+ {"DETAILUbicImage", (caddr_t)DETAILUbicImage},
+ {"DOAGenericImage", (caddr_t)DOAGenericImage},
+ {"DS", (caddr_t)DS},
+ {"Deposits", (caddr_t)Deposits},
+ {"EnterObject", (caddr_t)EnterObject},
+ {"FYIGenericImage", (caddr_t)FYIGenericImage},
+ {"FindDataSource", (caddr_t)FindDataSource},
+ {"FixTeList", (caddr_t)FixTeList},
+ {"HashGetObject", (caddr_t)HashGetObject},
+ {"IdEnttySmmry", (caddr_t)IdEnttySmmry},
+ {"InfoPrntImg", (caddr_t)InfoPrntImg},
+ {"InfoPrntImge", (caddr_t)InfoPrntImge},
+ {"InsertToggle", (caddr_t)InsertToggle},
+ {"LP", (caddr_t)LP},
+ {"LPED", (caddr_t)LPED},
+ {"LUDGenericImage", (caddr_t)LUDGenericImage},
+ {"LeaveObject", (caddr_t)LeaveObject},
+ {"MakeTranUsable", (caddr_t)MakeTranUsable},
+ {"MakeTreatText", (caddr_t)MakeTreatText},
+ {"MoveNextEditor", (caddr_t)MoveNextEditor},
+ {"MovePreviousEditor", (caddr_t)MovePreviousEditor},
+ {"NextTRFU", (caddr_t)NextTRFU},
+ {"OCDGenericImage", (caddr_t)OCDGenericImage},
+ {"OTCDiscChrg", (caddr_t)OTCDiscChrg},
+ {"OTCDiscCodes", (caddr_t)OTCDiscCodes},
+ {"OTCDscrtnryAr", (caddr_t)OTCDscrtnryAr},
+ {"OpenTRFU", (caddr_t)OpenTRFU},
+ {"OpenTreatment", (caddr_t)OpenTreatment},
+ {"PB", (caddr_t)PB},
+ {"PBED", (caddr_t)PBED},
+ {"PE", (caddr_t)PE},
+ {"PEED", (caddr_t)PEED},
+ {"Prev_month_valuator", (caddr_t)Prev_month_valuator},
+ {"PrevTRFU", (caddr_t)PrevTRFU},
+ {"QtfuLoad", (caddr_t)QtfuLoad},
+ {"RB", (caddr_t)RB},
+ {"RBED", (caddr_t)RBED},
+ {"RaiseCLSA", (caddr_t)RaiseCLSA},
+ {"RaiseQtfu", (caddr_t)RaiseQtfu},
+ {"RaiseTreatment", (caddr_t)RaiseTreatment},
+ {"RaiseUbicDetail", (caddr_t)RaiseUbicDetail},
+ {"RaiseUbicSummary", (caddr_t)RaiseUbicSummary},
+ {"RequestTRFU", (caddr_t)RequestTRFU},
+ {"RequestTSUM", (caddr_t)RequestTSUM},
+ {"SendDataToCLSA", (caddr_t)SendDataToCLSA},
+ {"SetDataFields", (caddr_t)SetDataFields},
+ {"SR", (caddr_t)SR},
+ {"SRED", (caddr_t)SRED},
+ {"SUMMARYUbicImage", (caddr_t)SUMMARYUbicImage},
+ {"SW", (caddr_t)SW},
+ {"SWED", (caddr_t)SWED},
+ {"TB", (caddr_t)TB},
+ {"TBED", (caddr_t)TBED},
+ {"TE", (caddr_t)TE},
+ {"TEED", (caddr_t)TEED},
+ {"TreatPayLoad", (caddr_t)TreatPayLoad},
+ {"TrfuFill", (caddr_t)TrfuFill},
+ {"TrfuLoad", (caddr_t)TrfuLoad},
+ {"TsumInfo", (caddr_t)TsumInfo},
+ {"TtlsEnttySmmry", (caddr_t)TtlsEnttySmmry},
+ {"UbicSelect", (caddr_t)UbicSelect},
+ {"WindowID", (caddr_t)WindowID},
+ {"activate", (caddr_t)activate},
+ {"addlcarrier", (caddr_t)addlcarrier},
+ {"adjustitem", (caddr_t)adjustitem},
+ {"adlitem", (caddr_t)adlitem},
+ {"allocmem", (caddr_t)allocmem},
+ {"billcarrier", (caddr_t)billcarrier},
+ {"cancelallrefs", (caddr_t)cancelallrefs},
+ {"candshdhist", (caddr_t)candshdhist},
+ {"canpi", (caddr_t)canpi},
+ {"canref", (caddr_t)canref},
+ {"cansi", (caddr_t)cansi},
+ {"cantrthist", (caddr_t)cantrthist},
+ {"carrierlst", (caddr_t)carrierlst},
+ {"cartask", (caddr_t)cartask},
+ {"carvals", (caddr_t)carvals},
+ {"change_trfuuid", (caddr_t)change_trfuuid},
+ {"checkdb", (caddr_t)checkdb},
+ {"checkentinfo", (caddr_t)checkentinfo},
+ {"checkind", (caddr_t)checkind},
+ {"checknote", (caddr_t)checknote},
+ {"checkscreen", (caddr_t)checkscreen},
+ {"checkpi", (caddr_t)checkpi},
+ {"checksi", (caddr_t)checksi},
+ {"client_ret", (caddr_t)client_ret},
+ {"closeaccnt", (caddr_t)closeaccnt},
+ {"closecarrierd", (caddr_t)closecarrierd},
+ {"closedep", (caddr_t)closedep},
+ {"closedoa", (caddr_t)closedoa},
+ {"closeitem", (caddr_t)closeitem},
+ {"closenotes", (caddr_t)closenotes},
+ {"closeocc", (caddr_t)closeocc},
+ {"closepad", (caddr_t)closepad},
+ {"closeph", (caddr_t)closeph},
+ {"closeser", (caddr_t)closeser},
+ {"closesvw", (caddr_t)closesvw},
+ {"closeRestCallback", (caddr_t)closeRestCallback},
+ {"closeWinCallback", (caddr_t)closeWinCallback},
+ {"closew", (caddr_t)closew},
+ {"cnacustcd", (caddr_t)cnacustcd},
+ {"collectdcback", (caddr_t)collectdcback},
+ {"collections", (caddr_t)collections},
+ {"crtranhead", (caddr_t)crtranhead},
+ {"crcb", (caddr_t)crcb},
+ {"crdataval", (caddr_t)crdataval},
+ {"crds", (caddr_t)crds},
+ {"createed", (caddr_t)createed},
+ {"createrb", (caddr_t)createrb},
+ {"createwind", (caddr_t)createwind},
+ {"crhistnode", (caddr_t)crhistnode},
+ {"crlp", (caddr_t)crlp},
+ {"crpb", (caddr_t)crpb},
+ {"crpe", (caddr_t)crpe},
+ {"crrb", (caddr_t)crrb},
+ {"crsr", (caddr_t)crsr},
+ {"crsw", (caddr_t)crsw},
+ {"crtask", (caddr_t)crtask},
+ {"crtb", (caddr_t)crtb},
+ {"crte", (caddr_t)crte},
+ {"curnames", (caddr_t)curnames},
+ {"curwinds", (caddr_t)curwinds},
+ {"dad_list", (caddr_t)dad_list},
+ {"deposits", (caddr_t)deposits},
+ {"displabel", (caddr_t)displabel},
+ {"downent", (caddr_t)downent},
+ {"downent9", (caddr_t)downent9},
+ {"downent10", (caddr_t)downent10},
+ {"erasepad", (caddr_t)erasepad},
+ {"exitsr", (caddr_t)exitsr},
+ {"extractinfo", (caddr_t)extractinfo},
+ {"findtranhead", (caddr_t)findtranhead},
+ {"fix_buttons", (caddr_t)fix_buttons},
+ {"freesi", (caddr_t)freesi},
+ {"freetext", (caddr_t)freetext},
+ {"getcuscode", (caddr_t)getcuscode},
+ {"getdataval", (caddr_t)getdataval},
+ {"getdupt", (caddr_t)getdupt},
+ {"getent", (caddr_t)getent},
+ {"getinputstring", (caddr_t)getinputstring},
+ {"getnames", (caddr_t)getnames},
+ {"getph", (caddr_t)getph},
+ {"getrealval", (caddr_t)getrealval},
+ {"getreftype", (caddr_t)getreftype},
+ {"gettar", (caddr_t)gettar},
+ {"gettext", (caddr_t)gettext},
+ {"getvalue", (caddr_t)getvalue},
+ {"gotoitem", (caddr_t)gotoitem},
+ {"helpindex", (caddr_t)helpindex},
+ {"helpnames", (caddr_t)helpnames},
+ {"initdicts", (caddr_t)initdicts},
+ {"initentities", (caddr_t)initentities},
+ {"initscr", (caddr_t)initscr},
+ {"initwind", (caddr_t)initwind},
+ {"itemcarrier", (caddr_t)itemcarrier},
+ {"lineitem", (caddr_t)lineitem},
+ {"listrefs", (caddr_t)listrefs},
+ {"list_deposit", (caddr_t)list_deposit},
+ {"load_cust_cred", (caddr_t)load_cust_cred},
+ {"loaddata", (caddr_t)loaddata},
+ {"loadpsw", (caddr_t)loadpsw},
+ {"lud_list", (caddr_t)lud_list},
+ {"main", (caddr_t)main},
+ {"makedatatag", (caddr_t)makedatatag},
+ {"makeentity", (caddr_t)makeentity},
+ {"manipulate_spa", (caddr_t)manipulate_spa},
+ {"mkref", (caddr_t)mkref},
+ {"modverify", (caddr_t)modverify},
+ {"municarrier", (caddr_t)municarrier},
+ {"natmodes", (caddr_t)natmodes},
+ {"nextcarrier", (caddr_t)nextcarrier},
+ {"nextcsr", (caddr_t)nextcsr},
+ {"nextfunc", (caddr_t)nextfunc},
+ {"nexthelp", (caddr_t)nexthelp},
+ {"nextserfunc", (caddr_t)nextserfunc},
+ {"nexttext", (caddr_t)nexttext},
+ {"nextwinds", (caddr_t)nextwinds},
+ {"no_close_halt", (caddr_t)no_close_halt},
+ {"nodata", (caddr_t)nodata},
+ {"note", (caddr_t)note},
+ {"notescback", (caddr_t)notescback},
+ {"occcarrier", (caddr_t)occcarrier},
+ {"ocd_list", (caddr_t)ocd_list},
+ {"order", (caddr_t)order},
+ {"padjcarrier", (caddr_t)padjcarrier},
+ {"phonecna", (caddr_t)phonecna},
+ {"phonenum", (caddr_t)phonenum},
+ {"piupdate", (caddr_t)piupdate},
+ {"prevcarrier", (caddr_t)prevcarrier},
+ {"prevcsr", (caddr_t)prevcsr},
+ {"prevhelp", (caddr_t)prevhelp},
+ {"prevtext", (caddr_t)prevtext},
+ {"prevwinds", (caddr_t)prevwinds},
+ {"putval", (caddr_t)putval},
+ {"quitiws", (caddr_t)quitiws},
+ {"raisenative", (caddr_t)raisenative},
+ {"raisewind", (caddr_t)raisewind},
+ {"refund", (caddr_t)refund},
+ {"relayer", (caddr_t)relayer},
+ {"rewindtext", (caddr_t)rewindtext},
+ {"rmtasks", (caddr_t)rmtasks},
+ {"screendisplay", (caddr_t)screendisplay},
+ {"searchcur", (caddr_t)searchcur},
+ {"searchhelp", (caddr_t)searchhelp},
+ {"sendlabel", (caddr_t)sendlabel},
+ {"sendphone", (caddr_t)sendphone},
+ {"sendphtoBOSS", (caddr_t)sendphtoBOSS},
+ {"sendphtofilesvr", (caddr_t)sendphtofilesvr},
+ {"sendreq", (caddr_t)sendreq},
+ {"sendscreen", (caddr_t)sendscreen},
+ {"send_refund", (caddr_t)send_refund},
+ {"servcarrier", (caddr_t)servcarrier},
+ {"servdcback", (caddr_t)servdcback},
+ {"setbutton", (caddr_t)setbutton},
+ {"setcuscode", (caddr_t)setcuscode},
+ {"setnatsys", (caddr_t)setnatsys},
+ {"showsel", (caddr_t)showsel},
+ {"siupdate", (caddr_t)siupdate},
+ {"sr01load", (caddr_t)sr01load},
+ {"sr02load", (caddr_t)sr02load},
+ {"sr05load", (caddr_t)sr05load},
+ {"sr16carrier", (caddr_t)sr16carrier},
+ {"taxcarrier", (caddr_t)taxcarrier},
+ {"tcnv", (caddr_t)tcnv},
+ {"textdcback", (caddr_t)textdcback},
+ {"textptrinit", (caddr_t)textptrinit},
+ {"textvalinit", (caddr_t)textvalinit},
+ {"tranfeat", (caddr_t)tranfeat},
+ {"updatecback", (caddr_t)updatecback},
+ {"updatenote", (caddr_t)updatenote},
+ {"upddshdhist", (caddr_t)upddshdhist},
+ {"updtrthist", (caddr_t)updtrthist},
+ {"upent", (caddr_t)upent},
+ {"upent9", (caddr_t)upent9},
+ {"upent10", (caddr_t)upent10},
+ {"usoctran", (caddr_t)usoctran},
+ {"validnumber", (caddr_t)validnumber},
+ {"varsican", (caddr_t)varsican},
+ {"varsiup", (caddr_t)varsiup},
+ {"windraise", (caddr_t)windraise},
+ {"END", (caddr_t)NULL}
+@
+
+
+20301.13
+log
+@CR#7192:M: Worked on treatment
+@
+text
+@d24 3
+d230 1
+d264 1
+d348 1
+@
+
+
+20301.12
+log
+@CR#7192:M: Worked on Treatment
+@
+text
+@d24 3
+d201 2
+d211 1
+@
+
+
+20301.11
+log
+@CR#7169:M: Added Treatment functionality
+@
+text
+@d24 3
+d175 1
+d217 1
+@
+
+
+20301.10
+log
+@CR#7187:M: added cpal functions.
+@
+text
+@d24 3
+d227 1
+@
+
+
+20301.9
+log
+@CR#7175:M:added lista-deposit & send_refund
+@
+text
+@d24 3
+d172 1
+d238 1
+d250 1
+d353 1
+@
+
+
+20301.8
+log
+@CR#7170:M:Temporary check-in of QTFU work in progress
+@
+text
+@d24 3
+d318 1
+d369 1
+@
+
+
+20301.7
+log
+@CR#7187:M: added cpal loading fctn.
+@
+text
+@d24 3
+d198 1
+d202 1
+@
+
+
+20301.6
+log
+@CR#8227:M:added getreftype
+@
+text
+@d24 3
+d162 1
+d278 3
+d381 3
+@
+
+
+20301.5
+log
+@CR#7182:M:Added function to close all UBIC associated windows when UBIC
+detail is closed
+@
+text
+@d24 4
+d289 1
+@
+
+
+20301.4
+log
+@CR#7182:M:Add UBIC detail processing
+@
+text
+@d24 3
+d154 1
+@
+
+
+20301.3
+log
+@CR#7180:M: added ocd_list.
+@
+text
+@d24 3
+a150 1
+ {"DS", (caddr_t)DS},
+d152 1
+d154 1
+d186 1
+d204 1
+@
+
+
+20301.2
+log
+@CR#7169:M: Worked on TRFU
+@
+text
+@d24 3
+d311 1
+@
+
+
+20301.1
+log
+@CR#7169:M: Worked on TRFU Request
+@
+text
+@d24 3
+d164 1
+d169 1
+d175 1
+d192 2
+@
+
+
+20201.38
+log
+@CR#8102:M:Added functions for UBIC Summary
+@
+text
+@d24 3
+d140 1
+d174 1
+@
+
+
+20201.37
+log
+@CR#7977:M: Fixed Entrance window workings
+@
+text
+@d24 3
+d169 1
+d174 1
+@
+
+
+20201.36
+log
+@CR#7180:M:added sr16 data loading functions.
+@
+text
+@d24 3
+d141 1
+@
+
+
+20201.35
+log
+@CR#7843:M:Remove unneeded SetupDataForCLSA
+@
+text
+@d24 3
+d133 2
+d137 1
+a138 1
+ {"GenericImage", (caddr_t)GenericImage},
+d146 1
+d150 1
+d199 1
+d232 1
+@
+
+
+20201.34
+log
+@CR#7843:M:stage build for CGI integration
+@
+text
+@d24 3
+a155 1
+ {"SetupDataForCLSA", (caddr_t)SetupDataForCLSA},
+@
+
+
+20201.33
+log
+@CR#7977:M: Worked on SetDataFields
+@
+text
+@d24 3
+a130 1
+ {"GetSaSR07", (caddr_t)GetSaSR07},
+d152 2
+@
+
+
+20201.32
+log
+@CR#7180:M:uncommented Tsuminfo
+@
+text
+@d24 3
+d150 1
+a150 1
+ {"SetDataField", (caddr_t)SetDataField},
+a300 1
+ {"setdata", (caddr_t)setdata},
+@
+
+
+20201.31
+log
+@CR#7843:M:Added RaiseCLSA & GetSaSR07 for CLSA Integration, commented TsumInfo
+out since it was not defined.
+@
+text
+@d24 4
+d156 1
+a156 1
+/* {"TsumInfo", (caddr_t)TsumInfo},*/
+@
+
+
+20201.30
+log
+@added TsumInfo
+@
+text
+@d24 3
+d121 1
+d142 1
+d152 1
+a152 1
+ {"TsumInfo", (caddr_t)TsumInfo},
+@
+
+
+20201.29
+log
+@CR#7977:M: Worked on transaction aliasing
+@
+text
+@d24 3
+d147 1
+@
+
+
+20201.28
+log
+@CR#7717:M: Added collectdcback
+@
+text
+@d24 3
+a112 1
+ {"Error", (caddr_t)Error},
+a151 3
+ {"binaryfind", (caddr_t)binaryfind},
+ {"buildsrc", (caddr_t)buildsrc},
+ {"buildtd", (caddr_t)buildtd},
+a185 1
+ {"createdata", (caddr_t)createdata},
+a201 1
+ {"ddcheck", (caddr_t)ddcheck},
+d225 1
+a225 1
+ {"initdata", (caddr_t)initdata},
+a234 1
+ {"loadtd", (caddr_t)loadtd},
+@
+
+
+20201.27
+log
+@CR#7717:M: Fixed lots of stuff
+@
+text
+@d24 3
+d182 1
+@
+
+
+20201.26
+log
+@added collections.
+@
+text
+@d24 3
+d127 1
+d140 1
+@
+
+
+20201.25
+log
+@CR#7717:M: Fixed enter and leave handlers
+@
+text
+@d24 3
+d174 1
+@
+
+
+20201.24
+log
+@CR#7717:M: Removed curform global and enterform() and leaveform()
+@
+text
+@d24 3
+d100 1
+d111 1
+a193 1
+ {"enterTE", (caddr_t)enterTE},
+a219 1
+ {"leaveTE", (caddr_t)leaveTE},
+@
+
+
+20201.23
+log
+@CR#7717:M: Worked on fonts and pixmaps
+@
+text
+@d24 3
+a189 1
+ {"enterform", (caddr_t)enterform},
+a216 1
+ {"leaveform", (caddr_t)leaveform},
+@
+
+
+20201.22
+log
+@CR#7181:M: added sr16carrier
+@
+text
+@d24 1
+a24 1
+ * Revision 20201.21 90/09/25 13:05:13 13:05:13 greg ( Greg DeMent)
+d97 1
+a97 1
+ {"HashGetFont", (caddr_t)HashGetFont},
+@
+
+
+20201.21
+log
+@CR#7717:M: Worked on font loading
+@
+text
+@d24 3
+d279 1
+@
+
+
+20201.20
+log
+@CR#7180:M: added GenericImage for SR16 processing.
+@
+text
+@d24 3
+d94 1
+@
+
+
+20201.19
+log
+@CR#7581:M: added closeRestCallback()
+@
+text
+@d24 3
+d90 1
+@
+
+
+20201.18
+log
+@CR#7717:M:Added scrolled window functions
+@
+text
+@d24 3
+d148 1
+@
+
+
+20201.17
+log
+@CR#7581:M: removed dispserpg, prevser, nextser, and servinfo.
+@
+text
+@d3 3
+a5 3
+* CONFIDENTIAL
+* Disclose And Distribute Solely To Employees Of
+* U S WEST And It's Affiliates Having A Need To Know.
+d9 2
+a10 2
+* (c)Copyright 1990, U S WEST Information Technologies Group
+* All Rights Reserved
+d24 3
+d56 1
+a56 1
+* THIS CODE HAS NOT BEEN MADE TO COMPLY WITH NEW STANDARDS !
+a61 1
+
+d73 1
+a73 3
+
+
+Tabfunc functable[] =
+d75 205
+a279 205
+ {"BOSSDateEffctv", (caddr_t)BOSSDateEffctv},
+ {"CB", (caddr_t)CB},
+ {"CBED", (caddr_t)CBED},
+ {"CSRData", (caddr_t)CSRData},
+ {"ClearEnd", (caddr_t)ClearEnd},
+ {"DS", (caddr_t)DS},
+ {"Deposits", (caddr_t)Deposits},
+ {"Error", (caddr_t)Error},
+ {"IdEnttySmmry", (caddr_t)IdEnttySmmry},
+ {"InfoPrntImg", (caddr_t)InfoPrntImg},
+ {"InfoPrntImge", (caddr_t)InfoPrntImge},
+ {"InsertToggle", (caddr_t)InsertToggle},
+ {"LP", (caddr_t)LP},
+ {"LPED", (caddr_t)LPED},
+ {"MoveNextEditor", (caddr_t)MoveNextEditor},
+ {"MovePreviousEditor", (caddr_t)MovePreviousEditor},
+ {"OTCDiscChrg", (caddr_t)OTCDiscChrg},
+ {"OTCDiscCodes", (caddr_t)OTCDiscCodes},
+ {"OTCDscrtnryAr", (caddr_t)OTCDscrtnryAr},
+ {"PB", (caddr_t)PB},
+ {"PBED", (caddr_t)PBED},
+ {"PE", (caddr_t)PE},
+ {"PEED", (caddr_t)PEED},
+ {"RB", (caddr_t)RB},
+ {"RBED", (caddr_t)RBED},
+ {"SetDataField", (caddr_t)SetDataField},
+ {"SR", (caddr_t)SR},
+ {"SRED", (caddr_t)SRED},
+ {"SW", (caddr_t)SW},
+ {"SWED", (caddr_t)SWED},
+ {"TB", (caddr_t)TB},
+ {"TBED", (caddr_t)TBED},
+ {"TE", (caddr_t)TE},
+ {"TEED", (caddr_t)TEED},
+ {"TtlsEnttySmmry", (caddr_t)TtlsEnttySmmry},
+ {"activate", (caddr_t)activate},
+ {"addlcarrier", (caddr_t)addlcarrier},
+ {"adjustitem", (caddr_t)adjustitem},
+ {"adlitem", (caddr_t)adlitem},
+ {"allocmem", (caddr_t)allocmem},
+ {"billcarrier", (caddr_t)billcarrier},
+ {"binaryfind", (caddr_t)binaryfind},
+ {"buildsrc", (caddr_t)buildsrc},
+ {"buildtd", (caddr_t)buildtd},
+ {"cancelallrefs", (caddr_t)cancelallrefs},
+ {"candshdhist", (caddr_t)candshdhist},
+ {"canref", (caddr_t)canref},
+ {"cansi", (caddr_t)cansi},
+ {"cantrthist", (caddr_t)cantrthist},
+ {"carrierlst", (caddr_t)carrierlst},
+ {"cartask", (caddr_t)cartask},
+ {"carvals", (caddr_t)carvals},
+ {"checkdb", (caddr_t)checkdb},
+ {"checkentinfo", (caddr_t)checkentinfo},
+ {"checkind", (caddr_t)checkind},
+ {"checknote", (caddr_t)checknote},
+ {"checkscreen", (caddr_t)checkscreen},
+ {"checksi", (caddr_t)checksi},
+ {"client_ret", (caddr_t)client_ret},
+ {"closeaccnt", (caddr_t)closeaccnt},
+ {"closecarrierd", (caddr_t)closecarrierd},
+ {"closedep", (caddr_t)closedep},
+ {"closeitem", (caddr_t)closeitem},
+ {"closenotes", (caddr_t)closenotes},
+ {"closeocc", (caddr_t)closeocc},
+ {"closepad", (caddr_t)closepad},
+ {"closeph", (caddr_t)closeph},
+ {"closeser", (caddr_t)closeser},
+ {"closesvw", (caddr_t)closesvw},
+ {"closeWinCallback", (caddr_t)closeWinCallback},
+ {"closew", (caddr_t)closew},
+ {"cnacustcd", (caddr_t)cnacustcd},
+ {"crtranhead", (caddr_t)crtranhead},
+ {"crcb", (caddr_t)crcb},
+ {"crdataval", (caddr_t)crdataval},
+ {"createdata", (caddr_t)createdata},
+ {"createds", (caddr_t)createds},
+ {"createed", (caddr_t)createed},
+ {"createrb", (caddr_t)createrb},
+ {"createwind", (caddr_t)createwind},
+ {"crhistnode", (caddr_t)crhistnode},
+ {"crlp", (caddr_t)crlp},
+ {"crpb", (caddr_t)crpb},
+ {"crpe", (caddr_t)crpe},
+ {"crrb", (caddr_t)crrb},
+ {"crsr", (caddr_t)crsr},
+ {"crsw", (caddr_t)crsw},
+ {"crtask", (caddr_t)crtask},
+ {"crtb", (caddr_t)crtb},
+ {"crte", (caddr_t)crte},
+ {"curnames", (caddr_t)curnames},
+ {"curwinds", (caddr_t)curwinds},
+ {"ddcheck", (caddr_t)ddcheck},
+ {"deposits", (caddr_t)deposits},
+ {"displabel", (caddr_t)displabel},
+ {"enterTE", (caddr_t)enterTE},
+ {"enterform", (caddr_t)enterform},
+ {"erasepad", (caddr_t)erasepad},
+ {"exitsr", (caddr_t)exitsr},
+ {"extractinfo", (caddr_t)extractinfo},
+ {"findtranhead", (caddr_t)findtranhead},
+ {"fix_buttons", (caddr_t)fix_buttons},
+ {"freesi", (caddr_t)freesi},
+ {"freetext", (caddr_t)freetext},
+ {"getcuscode", (caddr_t)getcuscode},
+ {"getdataval", (caddr_t)getdataval},
+ {"getdupt", (caddr_t)getdupt},
+ {"getent", (caddr_t)getent},
+ {"getinputstring", (caddr_t)getinputstring},
+ {"getnames", (caddr_t)getnames},
+ {"getph", (caddr_t)getph},
+ {"getrealval", (caddr_t)getrealval},
+ {"gettar", (caddr_t)gettar},
+ {"gettext", (caddr_t)gettext},
+ {"getvalue", (caddr_t)getvalue},
+ {"gotoitem", (caddr_t)gotoitem},
+ {"helpindex", (caddr_t)helpindex},
+ {"helpnames", (caddr_t)helpnames},
+ {"initdata", (caddr_t)initdata},
+ {"initentities", (caddr_t)initentities},
+ {"initscr", (caddr_t)initscr},
+ {"initwind", (caddr_t)initwind},
+ {"itemcarrier", (caddr_t)itemcarrier},
+ {"leaveTE", (caddr_t)leaveTE},
+ {"leaveform", (caddr_t)leaveform},
+ {"lineitem", (caddr_t)lineitem},
+ {"listrefs", (caddr_t)listrefs},
+ {"load_cust_cred", (caddr_t)load_cust_cred},
+ {"loaddata", (caddr_t)loaddata},
+ {"loadpsw", (caddr_t)loadpsw},
+ {"loadtd", (caddr_t)loadtd},
+ {"main", (caddr_t)main},
+ {"makedatatag", (caddr_t)makedatatag},
+ {"makeentity", (caddr_t)makeentity},
+ {"manipulate_spa", (caddr_t)manipulate_spa},
+ {"mkref", (caddr_t)mkref},
+ {"modverify", (caddr_t)modverify},
+ {"municarrier", (caddr_t)municarrier},
+ {"natmodes", (caddr_t)natmodes},
+ {"nextcarrier", (caddr_t)nextcarrier},
+ {"nextcsr", (caddr_t)nextcsr},
+ {"nextfunc", (caddr_t)nextfunc},
+ {"nexthelp", (caddr_t)nexthelp},
+ {"nextserfunc", (caddr_t)nextserfunc},
+ {"nexttext", (caddr_t)nexttext},
+ {"nextwinds", (caddr_t)nextwinds},
+ {"no_close_halt", (caddr_t)no_close_halt},
+ {"nodata", (caddr_t)nodata},
+ {"note", (caddr_t)note},
+ {"notescback", (caddr_t)notescback},
+ {"occcarrier", (caddr_t)occcarrier},
+ {"order", (caddr_t)order},
+ {"padjcarrier", (caddr_t)padjcarrier},
+ {"phonecna", (caddr_t)phonecna},
+ {"phonenum", (caddr_t)phonenum},
+ {"prevcarrier", (caddr_t)prevcarrier},
+ {"prevcsr", (caddr_t)prevcsr},
+ {"prevhelp", (caddr_t)prevhelp},
+ {"prevtext", (caddr_t)prevtext},
+ {"prevwinds", (caddr_t)prevwinds},
+ {"putval", (caddr_t)putval},
+ {"quitiws", (caddr_t)quitiws},
+ {"raisenative", (caddr_t)raisenative},
+ {"raisewind", (caddr_t)raisewind},
+ {"refund", (caddr_t)refund},
+ {"relayer", (caddr_t)relayer},
+ {"rewindtext", (caddr_t)rewindtext},
+ {"rmprevwind", (caddr_t)rmprevwind},
+ {"rmtasks", (caddr_t)rmtasks},
+ {"screendisplay", (caddr_t)screendisplay},
+ {"searchcur", (caddr_t)searchcur},
+ {"searchhelp", (caddr_t)searchhelp},
+ {"sendlabel", (caddr_t)sendlabel},
+ {"sendphone", (caddr_t)sendphone},
+ {"sendphtoBOSS", (caddr_t)sendphtoBOSS},
+ {"sendphtofilesvr", (caddr_t)sendphtofilesvr},
+ {"sendreq", (caddr_t)sendreq},
+ {"sendscreen", (caddr_t)sendscreen},
+ {"servcarrier", (caddr_t)servcarrier},
+ {"servdcback", (caddr_t)servdcback},
+ {"setbutton", (caddr_t)setbutton},
+ {"setcuscode", (caddr_t)setcuscode},
+ {"setdata", (caddr_t)setdata},
+ {"setnatsys", (caddr_t)setnatsys},
+ {"showsel", (caddr_t)showsel},
+ {"siupdate", (caddr_t)siupdate},
+ {"sr01load", (caddr_t)sr01load},
+ {"sr02load", (caddr_t)sr02load},
+ {"sr05load", (caddr_t)sr05load},
+ {"taxcarrier", (caddr_t)taxcarrier},
+ {"tcnv", (caddr_t)tcnv},
+ {"textdcback", (caddr_t)textdcback},
+ {"textptrinit", (caddr_t)textptrinit},
+ {"textvalinit", (caddr_t)textvalinit},
+ {"tranfeat", (caddr_t)tranfeat},
+ {"updatecback", (caddr_t)updatecback},
+ {"updatenote", (caddr_t)updatenote},
+ {"upddshdhist", (caddr_t)upddshdhist},
+ {"updtrthist", (caddr_t)updtrthist},
+ {"usoctran", (caddr_t)usoctran},
+ {"validnumber", (caddr_t)validnumber},
+ {"varsican", (caddr_t)varsican},
+ {"varsiup", (caddr_t)varsiup},
+ {"windraise", (caddr_t)windraise},
+ {"END", (caddr_t)NULL}
+@
+
+
+20201.16
+log
+@CR#7581:M:Change noexit() to closeWinCallback() so name will reflect
+wider usage by dialogs
+@
+text
+@d24 4
+a169 1
+ {"dispserpg", (caddr_t)dispserpg},
+a217 1
+ {"nextser", (caddr_t)nextser},
+a232 1
+ {"prevser", (caddr_t)prevser},
+a254 1
+ {"servinfo", (caddr_t)servinfo},
+@
+
+
+20201.15
+log
+@CR#7581:M: deleted serinit and service funtions.
+@
+text
+@d24 3
+d140 1
+a220 1
+ {"noexit", (caddr_t)noexit},
+@
+
+
+20201.14
+log
+@CR#7581:M: removed serheadings
+@
+text
+@d24 3
+a248 1
+ {"serinit", (caddr_t)serinit},
+a250 1
+ {"service", (caddr_t)service},
+@
+
+
+20201.13
+log
+@CR#7581:M:Remove Ref Mgr at the Motif port level
+@
+text
+@d24 3
+a245 1
+ {"serheadings", (caddr_t)serheadings},
+@
+
+
+20201.12
+log
+@CR#7581:M:Added new translations for cursor movement with text edits
+@
+text
+@d24 3
+a86 1
+ {"RemoveRefEntity", (caddr_t)RemoveRefEntity},
+a97 3
+ {"add_file_to_list", (caddr_t)add_file_to_list},
+ {"add_new_sections", (caddr_t)add_new_sections},
+ {"add_paperclip_to_list", (caddr_t)add_paperclip_to_list},
+a103 2
+ {"build_file_page_index", (caddr_t)build_file_page_index},
+ {"build_sec_notes", (caddr_t)build_sec_notes},
+a106 1
+ {"cancel_paperclip", (caddr_t)cancel_paperclip},
+a113 3
+ {"changefont", (caddr_t)changefont},
+ {"check_concurrent_update", (caddr_t)check_concurrent_update},
+ {"check_for_note", (caddr_t)check_for_note},
+a119 2
+ {"clean_up_section", (caddr_t)clean_up_section},
+ {"cleanup_deleted_sections", (caddr_t)cleanup_deleted_sections},
+a120 1
+ {"close_note_and_pc_win", (caddr_t)close_note_and_pc_win},
+a132 4
+ {"comp", (caddr_t)comp},
+ {"cont_update_notes", (caddr_t)cont_update_notes},
+ {"cont_update_pc", (caddr_t)cont_update_pc},
+ {"cpfile", (caddr_t)cpfile},
+a135 3
+ {"create_admin_lists", (caddr_t)create_admin_lists},
+ {"create_user_dir", (caddr_t)create_user_dir},
+ {"create_user_lists", (caddr_t)create_user_lists},
+a153 4
+ {"decide_menu", (caddr_t)decide_menu},
+ {"del_outdated_pc", (caddr_t)del_outdated_pc},
+ {"delete_note", (caddr_t)delete_note},
+ {"delete_paperclip", (caddr_t)delete_paperclip},
+a155 2
+ {"display_data_to_screen", (caddr_t)display_data_to_screen},
+ {"display_search_pg_to_screen", (caddr_t)display_search_pg_to_screen},
+a160 3
+ {"extract_section", (caddr_t)extract_section},
+ {"extract_update_pc", (caddr_t)extract_update_pc},
+ {"extract_update_sec", (caddr_t)extract_update_sec},
+a161 2
+ {"find_outdated_paperclps", (caddr_t)find_outdated_paperclps},
+ {"find_str", (caddr_t)find_str},
+a163 1
+ {"free_user_adm_lists", (caddr_t)free_usr_adm_lists},
+a165 10
+ {"get_ava_sec_entity", (caddr_t)get_ava_sec_entity},
+ {"get_entity", (caddr_t)get_entity},
+ {"get_file_pg_offset", (caddr_t)get_file_pg_offset},
+ {"get_max_char", (caddr_t)get_max_char},
+ {"get_max_line", (caddr_t)get_max_line},
+ {"get_node_ptr", (caddr_t)get_node_ptr},
+ {"get_sec_alpha_entity", (caddr_t)get_sec_alpha_entity},
+ {"get_sec_index", (caddr_t)get_sec_index},
+ {"get_te_string", (caddr_t)get_te_string},
+ {"get_total_pages", (caddr_t)get_total_pages},
+a176 1
+ {"gotoindex", (caddr_t)gotoindex},
+a177 2
+ {"gotopage", (caddr_t)gotopage},
+ {"handbook", (caddr_t)handbook},
+a183 4
+ {"insert_alpha_numeric", (caddr_t)insert_alpha_numeric},
+ {"insert_lead_alpha_numeric", (caddr_t)insert_lead_alpha_numeric},
+ {"insert_numeric", (caddr_t)insert_numeric},
+ {"is_number", (caddr_t)is_number},
+a185 1
+ {"leave_note", (caddr_t)leave_note},
+a189 4
+ {"load_paperclip_file", (caddr_t)load_paperclip_file},
+ {"load_paperclips", (caddr_t)load_paperclips},
+ {"load_sections", (caddr_t)load_sections},
+ {"load_updated_sections", (caddr_t)load_updated_sections},
+a192 3
+ {"log_pc", (caddr_t)log_pc},
+ {"log_sec", (caddr_t)log_sec},
+ {"look_up_page", (caddr_t)look_up_page},
+a198 1
+ {"move_note_to", (caddr_t)move_note_to},
+a200 3
+ {"new_log_item", (caddr_t)new_log_item},
+ {"new_user", (caddr_t)new_user},
+ {"next", (caddr_t)next},
+a208 1
+ {"no_change", (caddr_t)no_change},
+a213 2
+ {"note_exists", (caddr_t)note_exists},
+ {"notes_in_section", (caddr_t)notes_in_section},
+a214 1
+ {"odd_page", (caddr_t)odd_page},
+a215 1
+ {"outdated_paperclips", (caddr_t)outdated_paperclips},
+a216 1
+ {"paperclip", (caddr_t)paperclip},
+a218 4
+ {"place_date_node", (caddr_t)place_date_node},
+ {"place_note_node", (caddr_t)place_note_node},
+ {"prepare_hb_screen", (caddr_t)prepare_hb_screen},
+ {"prev", (caddr_t)prev},
+a228 7
+ {"read_file_into_index", (caddr_t)read_file_into_index},
+ {"ref_abend", (caddr_t)ref_abend},
+ {"ref_close_window", (caddr_t)ref_close_window},
+ {"ref_update_pc", (caddr_t)ref_update_pc},
+ {"ref_update_stop", (caddr_t)ref_update_stop},
+ {"ref_update_win_list", (caddr_t)ref_update_win_list},
+ {"refresh_updt_pc_screen", (caddr_t)refresh_updt_pc_screen},
+a230 5
+ {"relocate_delete_note", (caddr_t)relocate_delete_note},
+ {"relocate_note_exists", (caddr_t)relocate_note_exists},
+ {"relocate_note_to", (caddr_t)relocate_note_to},
+ {"remove_clip_from_list", (caddr_t)remove_clip_from_list},
+ {"removedir", (caddr_t)removedir},
+a231 1
+ {"rm_old_paperclip", (caddr_t)rm_old_paperclip},
+a233 2
+ {"save_note", (caddr_t)save_note},
+ {"save_paperclip", (caddr_t)save_paperclip},
+a234 2
+ {"search_dn", (caddr_t)search_dn},
+ {"search_up", (caddr_t)search_up},
+a236 2
+ {"sec_entity_available", (caddr_t)sec_entity_available},
+ {"sec_ind_displayed", (caddr_t)sec_ind_displayed},
+a262 1
+ {"too_many_paperclips", (caddr_t)too_many_paperclips},
+a263 7
+ {"two_paperclips_one_page", (caddr_t)two_paperclips_one_page},
+ {"unique_paperclip_name", (caddr_t)unique_paperclip_name},
+ {"update_entity_sec_list", (caddr_t)update_entity_sec_list},
+ {"update_notes", (caddr_t)update_notes},
+ {"update_paperclips", (caddr_t)update_paperclips},
+ {"update_section_notes", (caddr_t)update_section_notes},
+ {"update_user_notes_list", (caddr_t)update_user_notes_list},
+a265 1
+ {"updates_exist", (caddr_t)updates_exist},
+a268 2
+ {"valid_page_number", (caddr_t)valid_page_number},
+ {"valid_section", (caddr_t)valid_section},
+a272 2
+ {"write_list_to_file", (caddr_t)write_list_to_file},
+ {"write_user_notes_file", (caddr_t)write_user_notes_file},
+@
+
+
+20201.11
+log
+@CR#7173:M: Fixed compile problem with get_item_list
+@
+text
+@d24 3
+d73 1
+@
+
+
+20201.10
+log
+@CR#7173:M: Put in scrolled window stub functions and structures
+@
+text
+@d24 3
+d81 1
+a81 1
+ {"SetDataField", (caddr_t)SetDataField},
+d84 2
+a85 2
+ {"SW", (caddr_t)SW},
+ {"SWED", (caddr_t)SWED},
+d106 1
+a106 1
+ {"cancel_paperclip", (caddr_t)cancel_paperclip},
+a193 1
+ {"get_item_list", (caddr_t)get_item_list},
+@
+
+
+20201.9
+log
+@CR#7581:M:Removed accidental redefine of RCSid
+@
+text
+@d24 3
+d81 2
+d157 1
+@
+
+
+20201.8
+log
+@CR#7581:M:Added SetDataField()
+@
+text
+@d23 4
+a26 1
+* $Log$
+a31 1
+static char *sRCS_ID_s = "$Header$";
+@
+
+
+20201.7
+log
+@CR#7581:M:
+@
+text
+@d1 12
+a12 6
+/* @@(#) "*/
+/* @@(#)Copyright U S WEST Information Technologies Group, 1989. "*/
+/* @@(#) "*/
+/* @@(#)Proprietary: Not for use or disclosure outside U S WEST and its "*/
+/* @@(#)affiliates exceptr under written agreement. "*/
+/* @@(#) "*/
+d14 16
+d73 1
+d183 1
+a183 1
+ {"get_item_list", (caddr_t)get_item_list},
+@
+
+
+20201.6
+log
+@CR#7581:M:Motif Port
+@
+text
+@d160 1
+@
+
+
+20201.5
+log
+@Motif Port
+@
+text
+@a118 1
+ {"createicon", (caddr_t)createicon},
+a185 1
+ {"initicons", (caddr_t)initicons},
+@
+
+
+20201.4
+log
+@CR#7553:M:Remove Sales Advisor
+@
+text
+@a52 2
+ /* {"ST", (caddr_t)ST},*/
+ {"STED", (caddr_t)STED},
+a127 1
+ {"crst", (caddr_t)crst},
+@
+
+
+20201.3
+log
+@Motif port.
+@
+text
+@a64 1
+ {"addons", (caddr_t)addons},
+a66 2
+ {"akas", (caddr_t)akas},
+ {"alalac", (caddr_t)alalac},
+a67 2
+ {"alplac", (caddr_t)alplac},
+ {"benefits", (caddr_t)benefits},
+a69 1
+ {"bndle", (caddr_t)bndle},
+a73 2
+ {"callknlg", (caddr_t)callknlg},
+ {"caloc", (caddr_t)caloc},
+a106 6
+ {"clpit", (caddr_t)clpit},
+ {"clz", (caddr_t)clz},
+ {"clzbnft", (caddr_t)clzbnft},
+ {"clzprfl", (caddr_t)clzprfl},
+ {"clzrcmnd", (caddr_t)clzrcmnd},
+ {"clzum", (caddr_t)clzum},
+a110 1
+ {"cost", (caddr_t)cost},
+a113 1
+ {"crcursoc", (caddr_t)crcursoc},
+a128 1
+ {"crsaleusoc", (caddr_t)crsaleusoc},
+a133 1
+ {"cualoc", (caddr_t)cualoc},
+a135 1
+ {"custbenes", (caddr_t)custbenes},
+a141 1
+ {"dispbenes", (caddr_t)dispbenes},
+a145 1
+ {"dsply", (caddr_t)dsply},
+a153 1
+ {"fakeit", (caddr_t)fakeit},
+a157 4
+ {"fndit", (caddr_t)fndit},
+ {"fnsh", (caddr_t)fnsh},
+ {"fre", (caddr_t)fre},
+ {"frealac", (caddr_t)frealac},
+a160 1
+ {"frmt", (caddr_t)frmt},
+a170 2
+ {"getall", (caddr_t)getall},
+ {"getcr", (caddr_t)getcr},
+a176 1
+ {"getoffice", (caddr_t)getoffice},
+a178 1
+ {"getstd", (caddr_t)getstd},
+a180 1
+ {"getuscs", (caddr_t)getuscs},
+a184 1
+ {"gtit", (caddr_t)gtit},
+a187 1
+ {"init", (caddr_t)init},
+a190 1
+ {"initsales", (caddr_t)initsales},
+a197 1
+ {"ksrspnscr", (caddr_t)ksrspnscr},
+a213 1
+ {"lrgr", (caddr_t)lrgr},
+a218 1
+ {"mng", (caddr_t)mng},
+a219 1
+ {"motset", (caddr_t)motset},
+a221 2
+ {"mvit", (caddr_t)mvit},
+ {"mxmch", (caddr_t)mxmch},
+a227 1
+ {"nextcusts", (caddr_t)nextcusts},
+a241 3
+ {"nxtbnprd", (caddr_t)nxtbnprd},
+ {"nxtcustpg", (caddr_t)nxtcustpg},
+ {"nxtcustscroll", (caddr_t)nxtcustscroll},
+a244 1
+ {"out", (caddr_t)out},
+a249 1
+ {"pkit", (caddr_t)pkit},
+a251 4
+ {"play", (caddr_t)play},
+ {"pldwn", (caddr_t)pldwn},
+ {"pooaloc", (caddr_t)pooaloc},
+ {"prdsort", (caddr_t)prdsort},
+a255 1
+ {"prevcusts", (caddr_t)prevcusts},
+a259 6
+ {"pricit", (caddr_t)pricit},
+ {"prvbnprd", (caddr_t)prvbnprd},
+ {"prvcustpg", (caddr_t)prvcustpg},
+ {"prvcustscroll", (caddr_t)prvcustscroll},
+ {"ptup", (caddr_t)ptup},
+ {"pupaloc", (caddr_t)pupaloc},
+a263 1
+ {"rankit", (caddr_t)rankit},
+a277 1
+ {"rerun", (caddr_t)rerun},
+a281 7
+ {"rnctb", (caddr_t)rnctb},
+ {"rnitb", (caddr_t)rnitb},
+ {"rnmtb", (caddr_t)rnmtb},
+ {"rnstb", (caddr_t)rnstb},
+ {"safrmt", (caddr_t)safrmt},
+ {"sales", (caddr_t)sales},
+ {"salesinfo", (caddr_t)salesinfo},
+a305 1
+ {"setlnpr", (caddr_t)setlnpr},
+a306 1
+ {"shft", (caddr_t)shft},
+a308 1
+ {"smlr", (caddr_t)smlr},
+a316 1
+ {"tkit", (caddr_t)tkit},
+a336 1
+ {"waloc", (caddr_t)waloc},
+a337 1
+ {"wldcrd", (caddr_t)wldcrd},
+a339 1
+ {"xactm", (caddr_t)xactm},
+@
+
+
+20201.2
+log
+@CR#7188:M:Made Carrier Information work
+@
+text
+@d53 1
+a53 1
+ {"ST", (caddr_t)ST},
+@
+
+
+20201.1
+log
+@CR#7166:M:Made EntityTable load from a file instead of being compiled in
+@
+text
+@d95 1
+@
+
+
+20103.1
+log
+@CR#7019:M:Add cancel_paperclip() function.
+@
+text
+@d222 1
+@
+
+
+20103.1.1.1
+log
+@CR#7103:M:
+@
+text
+@a120 1
+ {"collections", (caddr_t)collections},
+@
+
+
+20103.1.1.1.1.1
+log
+@CR#7610:M: Fixed memory leaks
+@
+text
+@d50 1
+d61 3
+d65 1
+d68 5
+d75 3
+d80 2
+d83 1
+d91 3
+d99 2
+d102 1
+d114 6
+d122 5
+d129 1
+d131 3
+d145 1
+d151 1
+d154 1
+d156 4
+d161 1
+d163 2
+d166 1
+d171 3
+d175 3
+d180 5
+d187 13
+d206 1
+d209 1
+d212 1
+d214 1
+d216 3
+d221 1
+d224 1
+d227 4
+d232 1
+d234 1
+d239 4
+d246 4
+d255 1
+d257 2
+d260 2
+d263 3
+d268 1
+d275 1
+d281 5
+d287 1
+d289 2
+d292 1
+d295 9
+d306 1
+d311 6
+d321 8
+d331 6
+d338 1
+d341 9
+d351 2
+d355 2
+d372 1
+d374 1
+d377 1
+d386 2
+d389 7
+d398 1
+d402 2
+d407 1
+d409 4
+@
+
+
+20103.1.1.2
+log
+@CR#7610:M:Remove Sales Advisor & Ref Mgr code
+@
+text
+@d50 1
+d61 3
+d65 1
+d68 2
+d71 2
+d75 3
+d80 2
+d83 1
+d91 3
+d99 2
+d102 1
+d114 6
+d122 5
+d129 1
+d131 3
+d145 1
+d151 1
+d154 1
+d156 4
+d161 1
+d163 2
+d166 1
+d171 3
+d175 3
+d180 5
+d187 13
+d206 1
+d209 1
+d212 1
+d214 1
+d216 3
+d221 1
+d224 1
+d227 4
+d232 1
+d234 1
+d239 4
+d246 4
+d255 1
+d257 2
+d260 2
+d263 3
+d268 1
+d275 1
+d281 5
+d287 1
+d289 2
+d292 1
+d295 9
+d306 1
+d311 6
+d321 8
+d331 6
+d338 1
+d341 9
+d351 2
+d355 2
+d372 1
+d374 1
+d377 1
+d386 2
+d389 7
+d398 1
+d402 2
+d407 1
+d409 4
+@
+
+
+20102.3
+log
+@CR#6879:M:Added entries for prevcsr() and nextcsr()
+CR#6939:M:Added entries for closenotes() and notescback()
+@
+text
+@d83 1
+@
+
+
+20102.2
+log
+@Removed the datechk function, which is not used
+@
+text
+@d106 1
+d265 1
+d278 1
+d303 1
+@
+
+
+20102.1
+log
+@Initial correction of RCS revision numbers
+@
+text
+@a151 1
+ {"datechk", (caddr_t)datechk},
+@
+
+
+1.5
+log
+@CR#6881:M: Fixed SR01 processing partially
+@
+text
+@@
+
+
+1.4
+log
+@rm phchk, add sr02load, sr05load
+@
+text
+@d198 1
+@
+
+
+1.3
+log
+@modified to support multiple phone numbers
+@
+text
+@a287 1
+ {"phchk", (caddr_t)phchk},
+d373 2
+@
+
+
+1.2
+log
+@Initial 2.0 release
+@
+text
+@d124 1
+a124 1
+ {"crabi", (caddr_t)crabi},
+d176 1
+a176 1
+ {"findscreen", (caddr_t)findscreen},
+@
+
+
+1.1
+log
+@Initial revision
+@
+text
+@d1 6
+a6 6
+/* @@(#) "*/
+/* @@(#)Copyright U S WEST Information Technologies Group, 1989. "*/
+/* @@(#) "*/
+/* @@(#)Proprietary: Not for use or disclosure outside U S WEST and its "*/
+/* @@(#)affiliates exceptr under written agreement. "*/
+/* @@(#) "*/
+d9 15
+a25 100
+ {"getbuttons", (caddr_t)getbuttons},
+ {"crdataval", (caddr_t)crdataval},
+ {"getent", (caddr_t)getent},
+ {"crhistnode", (caddr_t)crhistnode},
+ {"get_ava_sec_entity", (caddr_t)get_ava_sec_entity},
+ {"get_node_ptr", (caddr_t)get_node_ptr},
+ {"gettar", (caddr_t)gettar},
+ {"gettext", (caddr_t)gettext},
+ {"rewindtext", (caddr_t)rewindtext},
+ {"textptrinit", (caddr_t)textptrinit},
+ {"crabi", (caddr_t)crabi},
+ {"findscreen", (caddr_t)findscreen},
+ {"allocmem", (caddr_t)allocmem},
+ {"get_search_string", (caddr_t)get_search_string},
+ {"getdataval", (caddr_t)getdataval},
+ {"getinputstring", (caddr_t)getinputstring},
+ {"getrealval", (caddr_t)getrealval},
+ {"getvalue", (caddr_t)getvalue},
+ {"search", (caddr_t)search},
+ {"get_file_pg_offset", (caddr_t)get_file_pg_offset},
+ {"get_total_pages", (caddr_t)get_total_pages},
+ {"look_up_page", (caddr_t)look_up_page},
+ {"add_new_sections", (caddr_t)add_new_sections},
+ {"cleanup_deleted_sections", (caddr_t)cleanup_deleted_sections},
+ {"addons", (caddr_t)addons},
+ {"akas", (caddr_t)akas},
+ {"alalac", (caddr_t)alalac},
+ {"alplac", (caddr_t)alplac},
+ {"bndle", (caddr_t)bndle},
+ {"caloc", (caddr_t)caloc},
+ {"checkdb", (caddr_t)checkdb},
+ {"closeph", (caddr_t)closeph},
+ {"clpit", (caddr_t)clpit},
+ {"clz", (caddr_t)clz},
+ {"comp", (caddr_t)comp},
+ {"cualoc", (caddr_t)cualoc},
+ {"deposits", (caddr_t)deposits},
+ {"dsply", (caddr_t)dsply},
+ {"fakeit", (caddr_t)fakeit},
+ {"find_str", (caddr_t)find_str},
+ {"fndit", (caddr_t)fndit},
+ {"fnsh", (caddr_t)fnsh},
+ {"fre", (caddr_t)fre},
+ {"frealac", (caddr_t)frealac},
+ {"frmt", (caddr_t)frmt},
+ {"get_numeric_day", (caddr_t)get_numeric_day},
+ {"get_numeric_month", (caddr_t)get_numeric_month},
+ {"get_numeric_year", (caddr_t)get_numeric_year},
+ {"getall", (caddr_t)getall},
+ {"getcr", (caddr_t)getcr},
+ {"getstd", (caddr_t)getstd},
+ {"getuscs", (caddr_t)getuscs},
+ {"gtit", (caddr_t)gtit},
+ {"helpinfo", (caddr_t)helpinfo},
+ {"init", (caddr_t)init},
+ {"is_number", (caddr_t)is_number},
+ {"loaddata", (caddr_t)loaddata},
+ {"main", (caddr_t)main},
+ {"makedatatag", (caddr_t)makedatatag},
+ {"mvit", (caddr_t)mvit},
+ {"mxmch", (caddr_t)mxmch},
+ {"new_user", (caddr_t)new_user},
+ {"nodata", (caddr_t)nodata},
+ {"no_close_halt", (caddr_t)no_close_halt},
+ {"note_exists", (caddr_t)note_exists},
+ {"notes_in_section", (caddr_t)notes_in_section},
+ {"odd_page", (caddr_t)odd_page},
+ {"out", (caddr_t)out},
+ {"pkit", (caddr_t)pkit},
+ {"play", (caddr_t)play},
+ {"pldwn", (caddr_t)pldwn},
+ {"pooaloc", (caddr_t)pooaloc},
+ {"pricit", (caddr_t)pricit},
+ {"ptrup", (caddr_t)ptup},
+ {"pupaloc", (caddr_t)pupaloc},
+ {"putval", (caddr_t)putval},
+ {"rankit", (caddr_t)rankit},
+ {"relocate_note_exists", (caddr_t)relocate_note_exists},
+ {"rerun", (caddr_t)rerun},
+ {"rnctb", (caddr_t)rnctb},
+ {"rnitb", (caddr_t)rnitb},
+ {"rnmtb", (caddr_t)rnmtb},
+ {"rnstb", (caddr_t)rnstb},
+ {"safrmt", (caddr_t)safrmt},
+ {"sales", (caddr_t)sales},
+ {"sales", (caddr_t)sales},
+ {"sec_entity_available", (caddr_t)sec_entity_available},
+ {"sec_ind_displayed", (caddr_t)sec_ind_displayed},
+ {"serheadings", (caddr_t)serheadings},
+ {"service", (caddr_t)service},
+ {"setlnpr", (caddr_t)setlnpr},
+ {"shft", (caddr_t)shft},
+ {"tkit", (caddr_t)tkit},
+ {"update_entity_sec_list", (caddr_t)update_entity_sec_list},
+ {"updates_exist", (caddr_t)updates_exist},
+ {"valid_page_number", (caddr_t)valid_page_number},
+ {"waloc", (caddr_t)waloc},
+ {"windfunc", (caddr_t)windfunc},
+ {"wldcrd", (caddr_t)wldcrd},
+ {"xactm", (caddr_t)xactm},
+d30 1
+a30 1
+ {"CodeEnttyID", (caddr_t)CodeEnttyID},
+d37 1
+d40 1
+d61 3
+d65 1
+d68 4
+d74 2
+d78 2
+d81 1
+d91 1
+d93 1
+d97 1
+d99 1
+d101 1
+a101 1
+ {"close_note_window", (caddr_t)close_note_window},
+d108 1
+d112 2
+d119 1
+d121 1
+d123 2
+d127 2
+a128 1
+ {"create_user_admin_lists", (caddr_t)create_user_admin_lists},
+d130 1
+d137 1
+d148 2
+d153 3
+d157 2
+d164 1
+a165 1
+ {"enteract", (caddr_t)enteract},
+d170 1
+d173 9
+a181 1
+ {"footnote", (caddr_t)footnote},
+d183 1
+d185 4
+d191 1
+d194 5
+a198 1
+ {"get_string", (caddr_t)get_string},
+d200 2
+a201 1
+ {"gethelp", (caddr_t)gethelp},
+d205 6
+d214 1
+d217 2
+d221 1
+d227 1
+d236 3
+d240 1
+d242 7
+d252 1
+d254 1
+d257 2
+d260 2
+d265 1
+d268 1
+d272 2
+d276 3
+d282 1
+d284 2
+a285 1
+ {"openhelp", (caddr_t)openhelp},
+d287 1
+d291 6
+d306 2
+d310 3
+a312 1
+ {"putvarput", (caddr_t)putvarput},
+d314 1
+d316 1
+d320 1
+d323 1
+d325 1
+d327 1
+d329 5
+a333 1
+ {"rmactlist", (caddr_t)rmactlist},
+d336 6
+d344 1
+d348 1
+d350 2
+d354 2
+d358 1
+a359 1
+ {"serv_ret", (caddr_t)serv_ret},
+d362 1
+d367 1
+d369 1
+d372 1
+a375 1
+ {"testsi", (caddr_t)testsi},
+d377 1
+d379 2
+d382 3
+d386 1
+d391 1
+d395 3
+a397 2
+ {"varcopytable", (caddr_t)varcopytable},
+ {"varputval", (caddr_t)varputval},
+d400 4
+d405 2
+a406 2
+ {"windraise", (caddr_t)windraise},
+ {"END", (caddr_t)NULL},
+@
--- /dev/null
+# Global variables
+No
+Sv
+Yes
+an
+buf
+bufend
+bufptr
+compiling
+comppad
+cryptseen
+cshlen
+cshname
+curinterp
+curpad
+dc
+di
+ds
+egid
+error_count
+euid
+evstr
+expectterm
+fold
+freq
+gid
+hexdigit
+in_format
+know_next
+last_lop
+last_uni
+linestr
+multi_close
+multi_end
+multi_open
+multi_start
+nexttype
+nextval
+nointrp
+nomem
+nomemok
+oldbufptr
+oldoldbufptr
+origalen
+origenviron
+pad
+padix
+patleave
+regbol
+regcode
+regendp
+regeol
+regfold
+reginput
+reglastparen
+regmyendp
+regmyp_size
+regmystartp
+regnpar
+regparse
+regprecomp
+regprev
+regsawback
+regsawbracket
+regsize
+regstartp
+regtill
+regxend
+rsfp
+saw_return
+statbuf
+subline
+subname
+sv_no
+sv_undef
+sv_yes
+thisexpr
+timesbuf
+tokenbuf
+uid
+vert
+
+# Functions
--- /dev/null
+#!./perl -Dpxstl
+#!./perl -w
+
+foo: while (1) {
+ bar: {
+ goto bar;
+ bar: ;
+ }
+ print "here\n";
+}
--- /dev/null
+/* $RCSfile: gv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:39 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: gv.c,v $
+ * Revision 4.1 92/08/07 18:26:39 lwall
+ *
+ * Revision 4.0.1.4 92/06/08 15:32:19 lwall
+ * patch20: fixed confusion between a *var's real name and its effective name
+ * patch20: the debugger now warns you on lines that can't set a breakpoint
+ * patch20: the debugger made perl forget the last pattern used by //
+ * patch20: paragraph mode now skips extra newlines automatically
+ * patch20: ($<,$>) = ... didn't work on some architectures
+ *
+ * Revision 4.0.1.3 91/11/05 18:35:33 lwall
+ * patch11: length($x) was sometimes wrong for numeric $x
+ * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
+ * patch11: *foo = undef coredumped
+ * patch11: solitary subroutine references no longer trigger typo warnings
+ * patch11: local(*FILEHANDLE) had a memory leak
+ *
+ * Revision 4.0.1.2 91/06/07 11:55:53 lwall
+ * patch4: new copyright notice
+ * patch4: added $^P variable to control calling of perldb routines
+ * patch4: added $^F variable to specify maximum system fd, default 2
+ * patch4: $` was busted inside s///
+ * patch4: default top-of-form run_format is now FILEHANDLE_TOP
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ * patch4: $^D |= 1024 now does syntax tree dump at run-time
+ *
+ * Revision 4.0.1.1 91/04/12 09:10:24 lwall
+ * patch1: Configure now differentiates getgroups() type from getgid() type
+ * patch1: you may now use "die" and "caller" in a signal handler
+ *
+ * Revision 4.0 91/03/20 01:39:41 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+GV *
+gv_AVadd(gv)
+register GV *gv;
+{
+ if (!GvAV(gv))
+ GvAV(gv) = newAV();
+ return gv;
+}
+
+GV *
+gv_HVadd(gv)
+register GV *gv;
+{
+ if (!GvHV(gv))
+ GvHV(gv) = newHV(COEFFSIZE);
+ return gv;
+}
+
+GV *
+gv_fetchfile(name)
+char *name;
+{
+ char tmpbuf[1200];
+ GV *gv;
+
+ sprintf(tmpbuf,"'_<%s", name);
+ gv = gv_fetchpv(tmpbuf, TRUE);
+ sv_setpv(GvSV(gv), name);
+ if (perldb)
+ (void)gv_HVadd(gv_AVadd(gv));
+ return gv;
+}
+
+GV *
+gv_fetchmethod(stash, name)
+HV* stash;
+char* name;
+{
+ AV* av;
+ GV* gv;
+ GV** gvp = (GV**)hv_fetch(stash,name,strlen(name),FALSE);
+ if (gvp && (gv = *gvp) != (GV*)&sv_undef && GvCV(gv))
+ return gv;
+
+ gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
+ if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+ SV** svp = AvARRAY(av);
+ I32 items = AvFILL(av) + 1;
+ while (items--) {
+ char tmpbuf[512];
+ SV* sv = *svp++;
+ *tmpbuf = '_';
+ SvUPGRADE(sv, SVt_PV);
+ strcpy(tmpbuf+1,SvPVn(sv));
+ gv = gv_fetchpv(tmpbuf,FALSE);
+ if (!gv || !(stash = GvHV(gv))) {
+ if (dowarn)
+ warn("Can't locate package %s for @%s'ISA",
+ SvPV(sv), HvNAME(stash));
+ continue;
+ }
+ gv = gv_fetchmethod(stash, name);
+ if (gv)
+ return gv;
+ }
+ }
+ return 0;
+}
+
+GV *
+gv_fetchpv(name,add)
+register char *name;
+I32 add;
+{
+ register GV *gv;
+ GV**gvp;
+ register GP *gp;
+ I32 len;
+ register char *namend;
+ HV *stash;
+ char *sawquote = Nullch;
+ char *prevquote = Nullch;
+ bool global = FALSE;
+
+ if (isUPPER(*name)) {
+ if (*name > 'I') {
+ if (*name == 'S' && (
+ strEQ(name, "SIG") ||
+ strEQ(name, "STDIN") ||
+ strEQ(name, "STDOUT") ||
+ strEQ(name, "STDERR") ))
+ global = TRUE;
+ }
+ else if (*name > 'E') {
+ if (*name == 'I' && strEQ(name, "INC"))
+ global = TRUE;
+ }
+ else if (*name > 'A') {
+ if (*name == 'E' && strEQ(name, "ENV"))
+ global = TRUE;
+ }
+ else if (*name == 'A' && (
+ strEQ(name, "ARGV") ||
+ strEQ(name, "ARGVOUT") ))
+ global = TRUE;
+ }
+ for (namend = name; *namend; namend++) {
+ if (*namend == '\'' && namend[1])
+ prevquote = sawquote, sawquote = namend;
+ }
+ if (sawquote == name && name[1]) {
+ stash = defstash;
+ sawquote = Nullch;
+ name++;
+ }
+ else if (!isALPHA(*name) || global)
+ stash = defstash;
+ else if ((COP*)curcop == &compiling)
+ stash = curstash;
+ else
+ stash = curcop->cop_stash;
+ if (sawquote) {
+ char tmpbuf[256];
+ char *s, *d;
+
+ *sawquote = '\0';
+ /*SUPPRESS 560*/
+ if (s = prevquote) {
+ strncpy(tmpbuf,name,s-name+1);
+ d = tmpbuf+(s-name+1);
+ *d++ = '_';
+ strcpy(d,s+1);
+ }
+ else {
+ *tmpbuf = '_';
+ strcpy(tmpbuf+1,name);
+ }
+ gv = gv_fetchpv(tmpbuf,TRUE);
+ if (!(stash = GvHV(gv)))
+ stash = GvHV(gv) = newHV(0);
+ if (!HvNAME(stash))
+ HvNAME(stash) = savestr(name);
+ name = sawquote+1;
+ *sawquote = '\'';
+ }
+ len = namend - name;
+ gvp = (GV**)hv_fetch(stash,name,len,add);
+ if (!gvp || *gvp == (GV*)&sv_undef)
+ return Nullgv;
+ gv = *gvp;
+ if (SvTYPE(gv) == SVt_PVGV) {
+ SvMULTI_on(gv);
+ return gv;
+ }
+ else {
+ sv_upgrade(gv, SVt_PVGV);
+ if (SvLEN(gv))
+ Safefree(SvPV(gv));
+ Newz(602,gp, 1, GP);
+ GvGP(gv) = gp;
+ GvREFCNT(gv) = 1;
+ GvSV(gv) = NEWSV(72,0);
+ GvLINE(gv) = curcop->cop_line;
+ GvEGV(gv) = gv;
+ sv_magic((SV*)gv, (SV*)gv, '*', name, len);
+ GvSTASH(gv) = stash;
+ GvNAME(gv) = nsavestr(name, len);
+ GvNAMELEN(gv) = len;
+ if (isDIGIT(*name) && *name != '0')
+ sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
+ if (add & 2)
+ SvMULTI_on(gv);
+ return gv;
+ }
+}
+
+void
+gv_fullname(sv,gv)
+SV *sv;
+GV *gv;
+{
+ HV *hv = GvSTASH(gv);
+
+ if (!hv)
+ return;
+ sv_setpv(sv, sv == (SV*)gv ? "*" : "");
+ sv_catpv(sv,HvNAME(hv));
+ sv_catpvn(sv,"'", 1);
+ sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+}
+
+void
+gv_efullname(sv,gv)
+SV *sv;
+GV *gv;
+{
+ GV* egv = GvEGV(gv);
+ HV *hv = GvSTASH(egv);
+
+ if (!hv)
+ return;
+ sv_setpv(sv, sv == (SV*)gv ? "*" : "");
+ sv_catpv(sv,HvNAME(hv));
+ sv_catpvn(sv,"'", 1);
+ sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
+}
+
+IO *
+newIO()
+{
+ IO *io;
+
+ Newz(603,io,1,IO);
+ io->page_len = 60;
+ return io;
+}
+
+void
+gv_check(min,max)
+I32 min;
+register I32 max;
+{
+ register HE *entry;
+ register I32 i;
+ register GV *gv;
+
+ for (i = min; i <= max; i++) {
+ for (entry = HvARRAY(defstash)[i]; entry; entry = entry->hent_next) {
+ gv = (GV*)entry->hent_val;
+ if (SvMULTI(gv))
+ continue;
+ curcop->cop_line = GvLINE(gv);
+ warn("Possible typo: \"%s\"", GvNAME(gv));
+ }
+ }
+}
+
+GV *
+newGVgen()
+{
+ (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
+ return gv_fetchpv(tokenbuf,TRUE);
+}
+
+/* hopefully this is only called on local symbol table entries */
+
+GP*
+gp_ref(gp)
+GP* gp;
+{
+ gp->gp_refcnt++;
+ return gp;
+
+}
+
+void
+gp_free(gv)
+GV* gv;
+{
+ IO *io;
+ CV *cv;
+ GP* gp;
+
+ if (!gv || !(gp = GvGP(gv)))
+ return;
+ if (gp->gp_refcnt == 0) {
+ warn("Attempt to free unreferenced glob pointers");
+ return;
+ }
+ if (--gp->gp_refcnt > 0)
+ return;
+
+ sv_free(gp->gp_sv);
+ sv_free(gp->gp_av);
+ sv_free(gp->gp_hv);
+ if (io = gp->gp_io) {
+ do_close(gv,FALSE);
+ Safefree(io->top_name);
+ Safefree(io->fmt_name);
+ Safefree(io);
+ }
+ if (cv = gp->gp_cv)
+ sv_free(cv);
+ Safefree(gp);
+ GvGP(gv) = 0;
+}
+
+#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
+#define MICROPORT
+#endif
+
+#ifdef MICROPORT /* Microport 2.4 hack */
+AV *GvAVn(gv)
+register GV *gv;
+{
+ if (GvGP(gv)->gp_av)
+ return GvGP(gv)->gp_av;
+ else
+ return GvGP(gv_AVadd(gv))->gp_av;
+}
+
+HV *GvHVn(gv)
+register GV *gv;
+{
+ if (GvGP(gv)->gp_hv)
+ return GvGP(gv)->gp_hv;
+ else
+ return GvGP(gv_HVadd(gv))->gp_hv;
+}
+#endif /* Microport 2.4 hack */
+
+GV *
+fetch_gv(op,num)
+OP *op;
+I32 num;
+{
+ if (op->op_private < num)
+ return 0;
+ if (op->op_flags & OPf_STACKED)
+ return gv_fetchpv(SvPVnx(*(stack_sp--)),TRUE);
+ else
+ return cGVOP->op_gv;
+}
+
+IO *
+fetch_io(op,num)
+OP *op;
+I32 num;
+{
+ GV *gv;
+
+ if (op->op_private < num)
+ return 0;
+ if (op->op_flags & OPf_STACKED)
+ gv = gv_fetchpv(SvPVnx(*(stack_sp--)),TRUE);
+ else
+ gv = cGVOP->op_gv;
+
+ if (!gv)
+ return 0;
+
+ return GvIOn(gv);
+}
--- /dev/null
+/* $RCSfile: gv.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:42 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: gv.h,v $
+ * Revision 4.1 92/08/07 18:26:42 lwall
+ *
+ * Revision 4.0.1.3 92/06/08 15:33:44 lwall
+ * patch20: fixed confusion between a *var's real name and its effective name
+ * patch20: ($<,$>) = ... didn't work on some architectures
+ *
+ * Revision 4.0.1.2 91/11/05 18:36:15 lwall
+ * patch11: length($x) was sometimes wrong for numeric $x
+ *
+ * Revision 4.0.1.1 91/06/07 11:56:35 lwall
+ * patch4: new copyright notice
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ *
+ * Revision 4.0 91/03/20 01:39:49 lwall
+ * 4.0 baseline.
+ *
+ */
+
+struct gp {
+ SV * gp_sv; /* scalar value */
+ U32 gp_refcnt; /* how many globs point to this? */
+ struct io * gp_io; /* filehandle value */
+ CV * gp_form; /* format value */
+ AV * gp_av; /* array value */
+ HV * gp_hv; /* associative array value */
+ GV * gp_egv; /* effective gv, if *glob */
+ CV * gp_cv; /* subroutine value */
+ I32 gp_lastexpr; /* used by nothing_in_common() */
+ line_t gp_line; /* line first declared at (for -w) */
+ char gp_flags;
+};
+
+#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
+#define MICROPORT
+#endif
+
+#define GvXPVGV(gv) ((XPVGV*)SvANY(gv))
+
+#define GvMAGIC(gv) (GvGP(gv)->gp_magic)
+#define GvSV(gv) (GvGP(gv)->gp_sv)
+#define GvREFCNT(gv) (GvGP(gv)->gp_refcnt)
+#define GvIO(gv) (GvGP(gv)->gp_io)
+#define GvIOn(gv) (GvIO(gv) ? \
+ GvIO(gv) : \
+ (GvIO(gv) = newIO()))
+
+#define GvFORM(gv) (GvGP(gv)->gp_form)
+#define GvAV(gv) (GvGP(gv)->gp_av)
+
+#ifdef MICROPORT /* Microport 2.4 hack */
+AV *GvAVn();
+#else
+#define GvAVn(gv) (GvGP(gv)->gp_av ? \
+ GvGP(gv)->gp_av : \
+ GvGP(gv_AVadd(gv))->gp_av)
+#endif
+#define GvHV(gv) ((GvGP(gv))->gp_hv)
+
+#ifdef MICROPORT /* Microport 2.4 hack */
+HV *GvHVn();
+#else
+#define GvHVn(gv) (GvGP(gv)->gp_hv ? \
+ GvGP(gv)->gp_hv : \
+ GvGP(gv_HVadd(gv))->gp_hv)
+#endif /* Microport 2.4 hack */
+
+#define GvCV(gv) (GvGP(gv)->gp_cv)
+
+#define GvLASTEXPR(gv) (GvGP(gv)->gp_lastexpr)
+
+#define GvLINE(gv) (GvGP(gv)->gp_line)
+
+#define GvFLAGS(gv) (GvGP(gv)->gp_flags)
+
+#define GvEGV(gv) (GvGP(gv)->gp_egv)
+
+#define GvGP(gv) (GvXPVGV(gv)->xgv_gp)
+#define GvNAME(gv) (GvXPVGV(gv)->xgv_name)
+#define GvNAMELEN(gv) (GvXPVGV(gv)->xgv_namelen)
+#define GvENAME(gv) GvNAME(GvEGV(gv))
+
+#define GvSTASH(gv) (GvXPVGV(gv)->xgv_stash)
+#define GvESTASH(gv) GvSTASH(GvEGV(gv))
+
+struct io {
+ FILE * ifp; /* ifp and ofp are normally the same */
+ FILE * ofp; /* but sockets need separate streams */
+#ifdef HAS_READDIR
+ DIR * dirp; /* for opendir, readdir, etc */
+#endif
+ long lines; /* $. */
+ long page; /* $% */
+ long page_len; /* $= */
+ long lines_left; /* $- */
+ char * top_name; /* $^ */
+ GV * top_gv; /* $^ */
+ char * fmt_name; /* $~ */
+ GV * fmt_gv; /* $~ */
+ short subprocess; /* -| or |- */
+ char type;
+ char flags;
+};
+
+#define IOf_ARGV 1 /* this fp iterates over ARGV */
+#define IOf_START 2 /* check for null ARGV and substitute '-' */
+#define IOf_FLUSH 4 /* this fp wants a flush after write op */
+
+#define Nullgv Null(GV*)
+
+#define DM_UID 0x003
+#define DM_RUID 0x001
+#define DM_EUID 0x002
+#define DM_GID 0x030
+#define DM_RGID 0x010
+#define DM_EGID 0x020
+#define DM_DELAY 0x100
+
--- /dev/null
+#!/usr/local/bin/perl
+'di';
+'ig00';
+
+$perlincl = '/usr/local/lib/perl';
+
+chdir '/usr/include' || die "Can't cd /usr/include";
+
+@isatype = split(' ',<<END);
+ char uchar u_char
+ short ushort u_short
+ int uint u_int
+ long ulong u_long
+ FILE
+END
+
+@isatype{@isatype} = (1) x @isatype;
+
+@ARGV = ('-') unless @ARGV;
+
+foreach $file (@ARGV) {
+ if ($file eq '-') {
+ open(IN, "-");
+ open(OUT, ">-");
+ }
+ else {
+ ($outfile = $file) =~ s/\.h$/.ph/ || next;
+ print "$file -> $outfile\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/$outfile") || die "Can't create $outfile: $!\n";
+ }
+ while (<IN>) {
+ chop;
+ while (/\\$/) {
+ chop;
+ $_ .= <IN>;
+ chop;
+ }
+ if (s:/\*:\200:g) {
+ s:\*/:\201:g;
+ s/\200[^\201]*\201//g; # delete single line comments
+ if (s/\200.*//) { # begin multi-line comment?
+ $_ .= '/*';
+ $_ .= <IN>;
+ redo;
+ }
+ }
+ if (s/^#\s*//) {
+ if (s/^define\s+(\w+)//) {
+ $name = $1;
+ $new = '';
+ s/\s+$//;
+ if (s/^\(([\w,\s]*)\)//) {
+ $args = $1;
+ if ($args ne '') {
+ foreach $arg (split(/,\s*/,$args)) {
+ $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
+ $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\s+<(.*)>/) {
+ ($incl = $1) =~ s/\.h$/.ph/;
+ print OUT $t,"require '$incl';\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]+)[lL]?// && do {$new .= $1; next;};
+ s/^(\d+)[lL]?// && do {$new .= $1; next;};
+ s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
+ s/^'((\\"|[^"])*)'// && do {
+ if ($curargs{$1}) {
+ $new .= "ord('\$$1')";
+ }
+ else {
+ $new .= "ord('$1')";
+ }
+ next;
+ };
+ s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
+ $new .= '$sizeof';
+ next;
+ };
+ s/^([_a-zA-Z]\w*)// && do {
+ $id = $1;
+ if ($id eq 'struct') {
+ s/^\s+(\w+)//;
+ $id .= ' ' . $1;
+ $isatype{$id} = 1;
+ }
+ elsif ($id eq 'unsigned') {
+ s/^\s+(\w+)//;
+ $id .= ' ' . $1;
+ $isatype{$id} = 1;
+ }
+ if ($curargs{$id}) {
+ $new .= '$' . $id;
+ }
+ elsif ($id eq 'defined') {
+ $new .= 'defined';
+ }
+ elsif (/^\(/) {
+ s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
+ $new .= " &$id";
+ }
+ elsif ($isatype{$id}) {
+ if ($new =~ /{\s*$/) {
+ $new .= "'$id'";
+ }
+ elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
+ $new =~ s/\(\s*$//;
+ s/^[\s*]*\)//;
+ }
+ else {
+ $new .= $id;
+ }
+ }
+ else {
+ $new .= ' &' . $id;
+ }
+ next;
+ };
+ s/^(.)// && do {$new .= $1; next;};
+ }
+}
+##############################################################################
+
+ # These next few lines are legal in both Perl and nroff.
+
+.00; # finish .ig
+
+'di \" finish diversion--previous line must be blank
+.nr nl 0-1 \" fake up transition to first page again
+.nr % 0 \" start at page 1
+'; __END__ ############# From here on it's a standard manual page ############
+.TH H2PH 1 "August 8, 1990"
+.AT 3
+.SH NAME
+h2ph \- convert .h C header files to .ph Perl header files
+.SH SYNOPSIS
+.B h2ph [headerfiles]
+.SH DESCRIPTION
+.I h2ph
+converts any C header files specified to the corresponding Perl header file
+format.
+It is most easily run while in /usr/include:
+.nf
+
+ cd /usr/include; h2ph * sys/*
+
+.fi
+If run with no arguments, filters standard input to standard output.
+.SH ENVIRONMENT
+No environment variables are used.
+.SH FILES
+/usr/include/*.h
+.br
+/usr/include/sys/*.h
+.br
+etc.
+.SH AUTHOR
+Larry Wall
+.SH "SEE ALSO"
+perl(1)
+.SH DIAGNOSTICS
+The usual warnings if it can't read or write the files involved.
+.SH BUGS
+Doesn't construct the %sizeof array for you.
+.PP
+It doesn't handle all C constructs, but it does attempt to isolate
+definitions inside evals so that you can get at the definitions
+that it can translate.
+.PP
+It's only intended as a rough tool.
+You may need to dicker with the files produced.
+.ex
--- /dev/null
+#!/usr/local/bin/perl
+'di';
+'ig00';
+
+$perlincl = '/usr/local/lib/perl';
+
+chdir '/usr/include' || die "Can't cd /usr/include";
+
+@isatype = split(' ',<<END);
+ char uchar u_char
+ short ushort u_short
+ int uint u_int
+ long ulong u_long
+ FILE
+END
+
+@isatype{@isatype} = (1) x @isatype;
+
+@ARGV = ('-') unless @ARGV;
+
+foreach $file (@ARGV) {
+ if ($file eq '-') {
+ open(IN, "-");
+ open(OUT, ">-");
+ }
+ else {
+ ($outfile = $file) =~ s/\.h$/.ph/ || next;
+ print "$file -> $outfile\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/$outfile") || die "Can't create $outfile: $!\n";
+ }
+ while (<IN>) {
+ chop;
+ while (/\\$/) {
+ chop;
+ $_ .= <IN>;
+ chop;
+ }
+ if (s:/\*:\200:g) {
+ s:\*/:\201:g;
+ s/\200[^\201]*\201//g; # delete single line comments
+ if (s/\200.*//) { # begin multi-line comment?
+ $_ .= '/*';
+ $_ .= <IN>;
+ redo;
+ }
+ }
+ if (s/^#\s*//) {
+ if (s/^define\s+(\w+)//) {
+ $name = $1;
+ $new = '';
+ s/\s+$//;
+ if (s/^\(([\w,\s]*)\)//) {
+ $args = $1;
+ if ($args ne '') {
+ foreach $arg (split(/,\s*/,$args)) {
+ $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
+ $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\s+<(.*)>/) {
+ ($incl = $1) =~ s/\.h$/.ph/;
+ print OUT $t,"require '$incl';\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/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
+ $new .= '$sizeof';
+ next;
+ };
+ s/^([_a-zA-Z]\w*)// && do {
+ $id = $1;
+ if ($id eq 'struct') {
+ s/^\s+(\w+)//;
+ $id .= ' ' . $1;
+ $isatype{$id} = 1;
+ }
+ elsif ($id eq 'unsigned') {
+ s/^\s+(\w+)//;
+ $id .= ' ' . $1;
+ $isatype{$id} = 1;
+ }
+ if ($curargs{$id}) {
+ $new .= '$' . $id;
+ }
+ elsif ($id eq 'defined') {
+ $new .= 'defined';
+ }
+ elsif (/^\(/) {
+ s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
+ $new .= " &$id";
+ }
+ elsif ($isatype{$id}) {
+ if ($new =~ /{\s*$/) {
+ $new .= "'$id'";
+ }
+ elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
+ $new =~ s/\(\s*$//;
+ s/^[\s*]*\)//;
+ }
+ else {
+ $new .= $id;
+ }
+ }
+ else {
+ $new .= ' &' . $id;
+ }
+ next;
+ };
+ s/^(.)// && do {$new .= $1; next;};
+ }
+}
+##############################################################################
+
+ # These next few lines are legal in both Perl and nroff.
+
+.00; # finish .ig
+
+'di \" finish diversion--previous line must be blank
+.nr nl 0-1 \" fake up transition to first page again
+.nr % 0 \" start at page 1
+'; __END__ ############# From here on it's a standard manual page ############
+.TH H2PH 1 "August 8, 1990"
+.AT 3
+.SH NAME
+h2ph \- convert .h C header files to .ph Perl header files
+.SH SYNOPSIS
+.B h2ph [headerfiles]
+.SH DESCRIPTION
+.I h2ph
+converts any C header files specified to the corresponding Perl header file
+format.
+It is most easily run while in /usr/include:
+.nf
+
+ cd /usr/include; h2ph * sys/*
+
+.fi
+If run with no arguments, filters standard input to standard output.
+.SH ENVIRONMENT
+No environment variables are used.
+.SH FILES
+/usr/include/*.h
+.br
+/usr/include/sys/*.h
+.br
+etc.
+.SH AUTHOR
+Larry Wall
+.SH "SEE ALSO"
+perl(1)
+.SH DIAGNOSTICS
+The usual warnings if it can't read or write the files involved.
+.SH BUGS
+Doesn't construct the %sizeof array for you.
+.PP
+It doesn't handle all C constructs, but it does attempt to isolate
+definitions inside evals so that you can get at the definitions
+that it can translate.
+.PP
+It's only intended as a rough tool.
+You may need to dicker with the files produced.
+.ex
-/* $RCSfile: handy.h,v $$Revision: 4.0.1.4 $$Date: 92/06/08 13:23:17 $
+/* $RCSfile: handy.h,v $$Revision: 4.1 $$Date: 92/08/07 18:21:46 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: handy.h,v $
+ * Revision 4.1 92/08/07 18:21:46 lwall
+ *
* Revision 4.0.1.4 92/06/08 13:23:17 lwall
* patch20: isascii() may now be supplied by a library routine
* patch20: Perl now distinguishes overlapped copies from non-overlapped
#define Null(type) ((type)NULL)
#define Nullch Null(char*)
#define Nullfp Null(FILE*)
+#define Nullsv Null(SV*)
#ifdef UTS
#define bool int
#define TRUE (1)
#define FALSE (0)
+typedef char I8;
+typedef unsigned char U8;
+
+typedef short I16;
+typedef unsigned short U16;
+
+#if INTSIZE == 4
+typedef int I32;
+typedef unsigned int U32;
+#else
+typedef long I32;
+typedef unsigned long U32;
+#endif
+
#define Ctl(ch) (ch & 037)
#define strNE(s1,s2) (strcmp(s1,s2))
#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
#if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII))
-#define isALNUM(c) (isalpha(c) || isdigit(c) || c == '_')
-#define isALPHA(c) isalpha(c)
-#define isSPACE(c) isspace(c)
-#define isDIGIT(c) isdigit(c)
-#define isUPPER(c) isupper(c)
-#define isLOWER(c) islower(c)
+#define isALNUM(c) (isalpha(c) || isdigit(c) || c == '_')
+#define isIDFIRST(c) (isalpha(c) || (c) == '_')
+#define isALPHA(c) isalpha(c)
+#define isSPACE(c) isspace(c)
+#define isDIGIT(c) isdigit(c)
+#define isUPPER(c) isupper(c)
+#define isLOWER(c) islower(c)
#else
-#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_'))
-#define isALPHA(c) (isascii(c) && isalpha(c))
-#define isSPACE(c) (isascii(c) && isspace(c))
-#define isDIGIT(c) (isascii(c) && isdigit(c))
-#define isUPPER(c) (isascii(c) && isupper(c))
-#define isLOWER(c) (isascii(c) && islower(c))
+#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_'))
+#define isIDFIRST(c) (isascii(c) && (isalpha(c) || (c) == '_'))
+#define isALPHA(c) (isascii(c) && isalpha(c))
+#define isSPACE(c) (isascii(c) && isspace(c))
+#define isDIGIT(c) (isascii(c) && isdigit(c))
+#define isUPPER(c) (isascii(c) && isupper(c))
+#define isLOWER(c) (isascii(c) && islower(c))
#endif
/* Line numbers are unsigned, 16 bits. */
-typedef unsigned short line_t;
+typedef U16 line_t;
#ifdef lint
#define NOLINE ((line_t)0)
#else
#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
#endif /* MSDOS */
#define Safefree(d) safefree((char*)d)
-#define Str_new(x,len) str_new(len)
+#define NEWSV(x,len) newSV(len)
#else /* LEAKTEST */
char *safexmalloc();
char *safexrealloc();
#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 NEWSV(x,len) newSV(x,len)
#define MAXXCOUNT 1200
long xcount[MAXXCOUNT];
long lastxcount[MAXXCOUNT];
+++ /dev/null
-/* $RCSfile: hash.c,v $$Revision: 4.0.1.3 $$Date: 92/06/08 13:26:29 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: hash.c,v $
- * Revision 4.0.1.3 92/06/08 13:26:29 lwall
- * patch20: removed implicit int declarations on functions
- * patch20: delete could cause %array to give too low a count of buckets filled
- * patch20: hash tables now split only if the memory is available to do so
- *
- * Revision 4.0.1.2 91/11/05 17:24:13 lwall
- * patch11: saberized perl
- *
- * Revision 4.0.1.1 91/06/07 11:10:11 lwall
- * patch4: new copyright notice
- *
- * Revision 4.0 91/03/20 01:22:26 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-static void hsplit();
-
-static 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};
-
-static void hfreeentries();
-
-STR *
-hfetch(tb,key,klen,lval)
-register HASH *tb;
-char *key;
-unsigned 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 &str_undef;
- if (!tb->tbl_array) {
- if (lval)
- Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*);
- else
- return &str_undef;
- }
-
- /* 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; /*SUPPRESS 8*/
- 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;
-#ifdef HAS_GDBM
- dcontent = gdbm_fetch(tb->tbl_dbm,dkey);
-#else
- dcontent = dbm_fetch(tb->tbl_dbm,dkey);
-#endif
- 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 &str_undef;
-}
-
-bool
-hstore(tb,key,klen,val,hash)
-register HASH *tb;
-char *key;
-unsigned 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)
- /*SUPPRESS 530*/
- ;
- 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; /*SUPPRESS 8*/
- s++, i++, hash *= 5) {
- hash += *s * coeff[i];
- }
- }
-
- if (!tb->tbl_array)
- Newz(505,tb->tbl_array, tb->tbl_max + 1, HENT*);
-
- 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? */
- void hentdelayfree();
-
- 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;
- hentdelayfree(entry); /* no doubt they'll want this next. */
- entry = *oentry;
- }
- }
-#endif
-
- return FALSE;
-}
-
-STR *
-hdelete(tb,key,klen)
-register HASH *tb;
-char *key;
-unsigned 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 || !tb->tbl_array)
- 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; /*SUPPRESS 8*/
- 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;
- if (i && !*oentry)
- tb->tbl_fill--;
- str = str_mortal(entry->hent_val);
- hentfree(entry);
-#ifdef SOME_DBM
- do_dbm_delete:
- if (tb->tbl_dbm) {
- dkey.dptr = key;
- dkey.dsize = klen;
-#ifdef HAS_GDBM
- gdbm_delete(tb->tbl_dbm,dkey);
-#else
- dbm_delete(tb->tbl_dbm,dkey);
-#endif
- }
-#endif
- return str;
- }
-#ifdef SOME_DBM
- str = Nullstr;
- goto do_dbm_delete;
-#else
- return Nullstr;
-#endif
-}
-
-static void
-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;
- nomemok = TRUE;
- Renew(a, newsize, HENT*);
- nomemok = FALSE;
- if (!a) {
- tb->tbl_dosplit = tb->tbl_max + 1; /* never split again */
- return;
- }
- Zero(&a[oldsize], oldsize, HENT*); /* zero 2nd half*/
- tb->tbl_max = --newsize;
- tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
- tb->tbl_array = a;
-
- for (i=0; i<oldsize; i++,a++) {
- if (!*a) /* non-existent */
- continue;
- b = a+oldsize;
- for (oentry = a, entry = *a; entry; entry = *oentry) {
- if ((entry->hent_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 */
- }
- 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
-hentdelayfree(hent)
-register HENT *hent;
-{
- if (!hent)
- return;
- str_2mortal(hent->hent_val); /* free between statements */
- Safefree(hent->hent_key);
- Safefree(hent);
-}
-
-void
-hclear(tb,dodbm)
-register HASH *tb;
-int dodbm;
-{
- if (!tb)
- return;
- hfreeentries(tb,dodbm);
- tb->tbl_fill = 0;
-#ifndef lint
- if (tb->tbl_array)
- (void)memzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*));
-#endif
-}
-
-static void
-hfreeentries(tb,dodbm)
-register HASH *tb;
-int dodbm;
-{
- register HENT *hent;
- register HENT *ohent = Null(HENT*);
-#ifdef SOME_DBM
- datum dkey;
- datum nextdkey;
-#ifdef HAS_GDBM
- GDBM_FILE old_dbm;
-#else
-#ifdef HAS_NDBM
- DBM *old_dbm;
-#else
- int old_dbm;
-#endif
-#endif
-#endif
-
- if (!tb || !tb->tbl_array)
- return;
-#ifdef SOME_DBM
- if ((old_dbm = tb->tbl_dbm) && dodbm) {
-#ifdef HAS_GDBM
- while (dkey = gdbm_firstkey(tb->tbl_dbm), dkey.dptr) {
-#else
- while (dkey = dbm_firstkey(tb->tbl_dbm), dkey.dptr) {
-#endif
- do {
-#ifdef HAS_GDBM
- nextdkey = gdbm_nextkey(tb->tbl_dbm, dkey);
-#else
-#ifdef HAS_NDBM
-#ifdef _CX_UX
- nextdkey = dbm_nextkey(tb->tbl_dbm, dkey);
-#else
- nextdkey = dbm_nextkey(tb->tbl_dbm);
-#endif
-#else
- nextdkey = nextkey(dkey);
-#endif
-#endif
-#ifdef HAS_GDBM
- gdbm_delete(tb->tbl_dbm,dkey);
-#else
- dbm_delete(tb->tbl_dbm,dkey);
-#endif
- dkey = nextdkey;
- } while (dkey.dptr); /* one way or another, this works */
- }
- }
- tb->tbl_dbm = 0; /* now clear just cache */
-#endif
- (void)hiterinit(tb);
- /*SUPPRESS 560*/
- while (hent = hiternext(tb)) { /* concise but not very efficient */
- hentfree(ohent);
- ohent = hent;
- }
- hentfree(ohent);
-#ifdef SOME_DBM
- tb->tbl_dbm = old_dbm;
-#endif
-}
-
-void
-hfree(tb,dodbm)
-register HASH *tb;
-int dodbm;
-{
- if (!tb)
- return;
- hfreeentries(tb,dodbm);
- 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 HAS_GDBM
- key.dptr = entry->hent_key;
- key.dsize = entry->hent_klen;
- key = gdbm_nextkey(tb->tbl_dbm, key);
-#else
-#ifdef HAS_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
-#endif
- }
- else {
- Newz(504,entry, 1, HENT);
- tb->tbl_eiter = entry;
-#ifdef HAS_GDBM
- key = gdbm_firstkey(tb->tbl_dbm);
-#else
- key = dbm_firstkey(tb->tbl_dbm);
-#endif
- }
- 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
- if (!tb->tbl_array)
- Newz(506,tb->tbl_array, tb->tbl_max + 1, HENT*);
- 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;
-#ifdef HAS_GDBM
- content = gdbm_fetch(tb->tbl_dbm,key);
-#else
- content = dbm_fetch(tb->tbl_dbm,key);
-#endif
- 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
-
-#ifndef O_CREAT
-# ifdef I_FCNTL
-# include <fcntl.h>
-# endif
-# ifdef I_SYS_FILE
-# include <sys/file.h>
-# endif
-#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
-
-#ifdef HAS_ODBM
-static int dbmrefcnt = 0;
-#endif
-
-bool
-hdbmopen(tb,fname,mode)
-register HASH *tb;
-char *fname;
-int mode;
-{
- if (!tb)
- return FALSE;
-#ifdef HAS_ODBM
- if (tb->tbl_dbm) /* never really closed it */
- return TRUE;
-#endif
- if (tb->tbl_dbm) {
- hdbmclose(tb);
- tb->tbl_dbm = 0;
- }
- hclear(tb, FALSE); /* clear cache */
-#ifdef HAS_GDBM
- if (mode >= 0)
- tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRCREAT,mode, (void *) NULL);
- if (!tb->tbl_dbm)
- tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRITER, mode, (void *) NULL);
- if (!tb->tbl_dbm)
- tb->tbl_dbm = gdbm_open(fname, 0, GDBM_READER, mode, (void *) NULL);
-#else
-#ifdef HAS_NDBM
- if (mode >= 0)
- tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode);
- if (!tb->tbl_dbm)
- tb->tbl_dbm = dbm_open(fname, O_RDWR, mode);
- if (!tb->tbl_dbm)
- 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 (mode < 0 || 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
-#endif
- if (!tb->tbl_array && tb->tbl_dbm != 0)
- Newz(507,tb->tbl_array, tb->tbl_max + 1, HENT*);
- return tb->tbl_dbm != 0;
-}
-
-void
-hdbmclose(tb)
-register HASH *tb;
-{
- if (tb && tb->tbl_dbm) {
-#ifdef HAS_GDBM
- gdbm_close(tb->tbl_dbm);
- tb->tbl_dbm = 0;
-#else
-#ifdef HAS_NDBM
- dbm_close(tb->tbl_dbm);
- tb->tbl_dbm = 0;
-#else
- /* dbmrefcnt--; */ /* doesn't work, rats */
-#endif
-#endif
- }
- else if (dowarn)
- warn("Close on unopened dbm file");
-}
-
-bool
-hdbmstore(tb,key,klen,str)
-register HASH *tb;
-char *key;
-unsigned 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;
-#ifdef HAS_GDBM
- error = gdbm_store(tb->tbl_dbm, dkey, dcontent, GDBM_REPLACE);
-#else
- error = dbm_store(tb->tbl_dbm, dkey, dcontent, DBM_REPLACE);
-#endif
- 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 HAS_NDBM
- dbm_clearerr(tb->tbl_dbm);
-#endif
- }
- return !error;
-}
-#endif /* SOME_DBM */
+++ /dev/null
-/* $RCSfile: hash.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:24:31 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: hash.h,v $
- * Revision 4.0.1.2 91/11/05 17:24:31 lwall
- * patch11: random cleanup
- *
- * Revision 4.0.1.1 91/06/07 11:10:33 lwall
- * patch4: new copyright notice
- *
- * Revision 4.0 91/03/20 01:22:38 lwall
- * 4.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 coeff array */
-
-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 */
- char *tbl_name; /* name, if a symbol table */
-#ifdef SOME_DBM
-#ifdef HAS_GDBM
- GDBM_FILE tbl_dbm;
-#else
-#ifdef HAS_NDBM
- DBM *tbl_dbm;
-#else
- int tbl_dbm;
-#endif
-#endif
-#endif
- unsigned char tbl_coeffsize; /* is 0 for symbol tables */
-};
-
-STR *hfetch();
-bool hstore();
-STR *hdelete();
-HASH *hnew();
-void hclear();
-void hentfree();
-void hfree();
-int hiterinit();
-HENT *hiternext();
-char *hiterkey();
-STR *hiterval();
-bool hdbmopen();
-void hdbmclose();
-bool hdbmstore();
+++ /dev/null
-ccflags="$ccflags -D_BSD"
--- /dev/null
+/* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:21:48 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: hash.c,v $
+ * Revision 4.1 92/08/07 18:21:48 lwall
+ *
+ * Revision 4.0.1.3 92/06/08 13:26:29 lwall
+ * patch20: removed implicit int declarations on functions
+ * patch20: delete could cause %array to give too low a count of buckets filled
+ * patch20: hash tables now split only if the memory is available to do so
+ *
+ * Revision 4.0.1.2 91/11/05 17:24:13 lwall
+ * patch11: saberized perl
+ *
+ * Revision 4.0.1.1 91/06/07 11:10:11 lwall
+ * patch4: new copyright notice
+ *
+ * Revision 4.0 91/03/20 01:22:26 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+static void hsplit();
+
+static void hfreeentries();
+
+SV**
+hv_fetch(hv,key,klen,lval)
+HV *hv;
+char *key;
+U32 klen;
+I32 lval;
+{
+ register XPVHV* xhv;
+ register char *s;
+ register I32 i;
+ register I32 hash;
+ register HE *entry;
+ register I32 maxi;
+ SV *sv;
+#ifdef SOME_DBM
+ datum dkey,dcontent;
+#endif
+
+ if (!hv)
+ return 0;
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_array) {
+ if (lval)
+ Newz(503,xhv->xhv_array, xhv->xhv_max + 1, HE*);
+ else
+ return 0;
+ }
+
+ /* The hash function we use on symbols has to be equal to the first
+ * character when taken modulo 128, so that sv_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 hv_fetch(), since it
+ * compares hash values before trying strEQ().
+ */
+ if (!xhv->xhv_coeffsize && klen)
+ hash = klen ? *key + 128 * key[1] + 128 * key[klen-1] : 0;
+ else { /* use normal coefficients */
+ if (klen < xhv->xhv_coeffsize)
+ maxi = klen;
+ else
+ maxi = xhv->xhv_coeffsize;
+ for (s=key, i=0, hash = 0;
+ i < maxi; /*SUPPRESS 8*/
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+ }
+
+ entry = xhv->xhv_array[hash & xhv->xhv_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 (xhv->xhv_dbm) {
+ dkey.dptr = key;
+ dkey.dsize = klen;
+#ifdef HAS_GDBM
+ dcontent = gdbm_fetch(xhv->xhv_dbm,dkey);
+#else
+ dcontent = dbm_fetch(xhv->xhv_dbm,dkey);
+#endif
+ if (dcontent.dptr) { /* found one */
+ sv = NEWSV(60,dcontent.dsize);
+ sv_setpvn(sv,dcontent.dptr,dcontent.dsize);
+ return hv_store(hv,key,klen,sv,hash); /* cache it */
+ }
+ }
+#endif
+ if (lval) { /* gonna assign to this, so it better be there */
+ sv = NEWSV(61,0);
+ return hv_store(hv,key,klen,sv,hash);
+ }
+ return 0;
+}
+
+SV**
+hv_store(hv,key,klen,val,hash)
+HV *hv;
+char *key;
+U32 klen;
+SV *val;
+register I32 hash;
+{
+ register XPVHV* xhv;
+ register char *s;
+ register I32 i;
+ register HE *entry;
+ register HE **oentry;
+ register I32 maxi;
+
+ if (!hv)
+ return 0;
+
+ xhv = (XPVHV*)SvANY(hv);
+ if (hash)
+ /*SUPPRESS 530*/
+ ;
+ else if (!xhv->xhv_coeffsize && klen)
+ hash = klen ? *key + 128 * key[1] + 128 * key[klen-1] : 0;
+ else { /* use normal coefficients */
+ if (klen < xhv->xhv_coeffsize)
+ maxi = klen;
+ else
+ maxi = xhv->xhv_coeffsize;
+ for (s=key, i=0, hash = 0;
+ i < maxi; /*SUPPRESS 8*/
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+ }
+
+ if (!xhv->xhv_array)
+ Newz(505,xhv->xhv_array, xhv->xhv_max + 1, HE*);
+
+ oentry = &(xhv->xhv_array[hash & xhv->xhv_max]);
+ i = 1;
+
+ if (SvMAGICAL(hv)) {
+ MAGIC* mg = SvMAGIC(hv);
+ sv_magic(val, (SV*)hv, tolower(mg->mg_type), key, klen);
+ }
+ 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;
+ sv_free(entry->hent_val);
+ entry->hent_val = val;
+ return &entry->hent_val;
+ }
+ New(501,entry, 1, HE);
+
+ entry->hent_klen = klen;
+ entry->hent_key = nsavestr(key,klen);
+ entry->hent_val = val;
+ entry->hent_hash = hash;
+ entry->hent_next = *oentry;
+ *oentry = entry;
+
+ /* hv_dbmstore not necessary here because it's called from sv_setmagic() */
+
+ if (i) { /* initial entry? */
+ xhv->xhv_fill++;
+#ifdef SOME_DBM
+ if (xhv->xhv_dbm && xhv->xhv_max >= DBM_CACHE_MAX)
+ return &entry->hent_val;
+#endif
+ if (xhv->xhv_fill > xhv->xhv_dosplit)
+ hsplit(hv);
+ }
+#ifdef SOME_DBM
+ else if (xhv->xhv_dbm) { /* is this just a cache for dbm file? */
+ void he_delayfree();
+ HE* ent;
+
+ ent = xhv->xhv_array[hash & xhv->xhv_max];
+ oentry = &ent->hent_next;
+ ent = *oentry;
+ while (ent) { /* trim chain down to 1 entry */
+ *oentry = ent->hent_next;
+ he_delayfree(ent); /* no doubt they'll want this next, sigh... */
+ ent = *oentry;
+ }
+ }
+#endif
+
+ return &entry->hent_val;
+}
+
+SV *
+hv_delete(hv,key,klen)
+HV *hv;
+char *key;
+U32 klen;
+{
+ register XPVHV* xhv;
+ register char *s;
+ register I32 i;
+ register I32 hash;
+ register HE *entry;
+ register HE **oentry;
+ SV *sv;
+ I32 maxi;
+#ifdef SOME_DBM
+ datum dkey;
+#endif
+
+ if (!hv)
+ return Nullsv;
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_array)
+ return Nullsv;
+ if (!xhv->xhv_coeffsize && klen)
+ hash = klen ? *key + 128 * key[1] + 128 * key[klen-1] : 0;
+ else { /* use normal coefficients */
+ if (klen < xhv->xhv_coeffsize)
+ maxi = klen;
+ else
+ maxi = xhv->xhv_coeffsize;
+ for (s=key, i=0, hash = 0;
+ i < maxi; /*SUPPRESS 8*/
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+ }
+
+ oentry = &(xhv->xhv_array[hash & xhv->xhv_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;
+ if (i && !*oentry)
+ xhv->xhv_fill--;
+ sv = sv_mortalcopy(entry->hent_val);
+ he_free(entry);
+#ifdef SOME_DBM
+ do_dbm_delete:
+ if (xhv->xhv_dbm) {
+ dkey.dptr = key;
+ dkey.dsize = klen;
+#ifdef HAS_GDBM
+ gdbm_delete(xhv->xhv_dbm,dkey);
+#else
+ dbm_delete(xhv->xhv_dbm,dkey);
+#endif
+ }
+#endif
+ return sv;
+ }
+#ifdef SOME_DBM
+ sv = Nullsv;
+ goto do_dbm_delete;
+#else
+ return Nullsv;
+#endif
+}
+
+static void
+hsplit(hv)
+HV *hv;
+{
+ register XPVHV* xhv = (XPVHV*)SvANY(hv);
+ I32 oldsize = xhv->xhv_max + 1;
+ register I32 newsize = oldsize * 2;
+ register I32 i;
+ register HE **a;
+ register HE **b;
+ register HE *entry;
+ register HE **oentry;
+
+ a = xhv->xhv_array;
+ nomemok = TRUE;
+ Renew(a, newsize, HE*);
+ nomemok = FALSE;
+ if (!a) {
+ xhv->xhv_dosplit = xhv->xhv_max + 1; /* never split again */
+ return;
+ }
+ Zero(&a[oldsize], oldsize, HE*); /* zero 2nd half*/
+ xhv->xhv_max = --newsize;
+ xhv->xhv_dosplit = xhv->xhv_max * FILLPCT / 100;
+ xhv->xhv_array = a;
+
+ for (i=0; i<oldsize; i++,a++) {
+ if (!*a) /* non-existent */
+ continue;
+ b = a+oldsize;
+ for (oentry = a, entry = *a; entry; entry = *oentry) {
+ if ((entry->hent_hash & newsize) != i) {
+ *oentry = entry->hent_next;
+ entry->hent_next = *b;
+ if (!*b)
+ xhv->xhv_fill++;
+ *b = entry;
+ continue;
+ }
+ else
+ oentry = &entry->hent_next;
+ }
+ if (!*a) /* everything moved */
+ xhv->xhv_fill--;
+ }
+}
+
+HV *
+newHV(lookat)
+U32 lookat;
+{
+ register HV *hv;
+ register XPVHV* xhv;
+
+ Newz(502,hv, 1, HV);
+ SvREFCNT(hv) = 1;
+ sv_upgrade(hv, SVt_PVHV);
+ xhv = (XPVHV*)SvANY(hv);
+ SvPOK_off(hv);
+ SvNOK_off(hv);
+ if (lookat) {
+ xhv->xhv_coeffsize = lookat;
+ xhv->xhv_max = 7; /* it's a normal associative array */
+ xhv->xhv_dosplit = xhv->xhv_max * FILLPCT / 100;
+ }
+ else {
+ xhv->xhv_max = 127; /* it's a symbol table */
+ xhv->xhv_dosplit = 128; /* so never split */
+ }
+ xhv->xhv_fill = 0;
+ xhv->xhv_pmroot = 0;
+#ifdef SOME_DBM
+ xhv->xhv_dbm = 0;
+#endif
+ (void)hv_iterinit(hv); /* so each() will start off right */
+ return hv;
+}
+
+void
+he_free(hent)
+register HE *hent;
+{
+ if (!hent)
+ return;
+ sv_free(hent->hent_val);
+ Safefree(hent->hent_key);
+ Safefree(hent);
+}
+
+void
+he_delayfree(hent)
+register HE *hent;
+{
+ if (!hent)
+ return;
+ sv_2mortal(hent->hent_val); /* free between statements */
+ Safefree(hent->hent_key);
+ Safefree(hent);
+}
+
+void
+hv_clear(hv,dodbm)
+HV *hv;
+I32 dodbm;
+{
+ register XPVHV* xhv;
+ if (!hv)
+ return;
+ xhv = (XPVHV*)SvANY(hv);
+ hfreeentries(hv,dodbm);
+ xhv->xhv_fill = 0;
+#ifndef lint
+ if (xhv->xhv_array)
+ (void)memzero((char*)xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
+#endif
+}
+
+static void
+hfreeentries(hv,dodbm)
+HV *hv;
+I32 dodbm;
+{
+ register XPVHV* xhv;
+ register HE *hent;
+ register HE *ohent = Null(HE*);
+#ifdef SOME_DBM
+ datum dkey;
+ datum nextdkey;
+#ifdef HAS_GDBM
+ GDBM_FILE old_dbm;
+#else
+#ifdef HAS_NDBM
+ DBM *old_dbm;
+#else
+ I32 old_dbm;
+#endif
+#endif
+#endif
+
+ if (!hv)
+ return;
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_array)
+ return;
+#ifdef SOME_DBM
+ if ((old_dbm = xhv->xhv_dbm) && dodbm) {
+#ifdef HAS_GDBM
+ while (dkey = gdbm_firstkey(xhv->xhv_dbm), dkey.dptr) {
+#else
+ while (dkey = dbm_firstkey(xhv->xhv_dbm), dkey.dptr) {
+#endif
+ do {
+#ifdef HAS_GDBM
+ nextdkey = gdbm_nextkey(xhv->xhv_dbm, dkey);
+#else
+#ifdef HAS_NDBM
+#ifdef _CX_UX
+ nextdkey = dbm_nextkey(xhv->xhv_dbm, dkey);
+#else
+ nextdkey = dbm_nextkey(xhv->xhv_dbm);
+#endif
+#else
+ nextdkey = nextkey(dkey);
+#endif
+#endif
+#ifdef HAS_GDBM
+ gdbm_delete(xhv->xhv_dbm,dkey);
+#else
+ dbm_delete(xhv->xhv_dbm,dkey);
+#endif
+ dkey = nextdkey;
+ } while (dkey.dptr); /* one way or another, this works */
+ }
+ }
+ xhv->xhv_dbm = 0; /* now clear just cache */
+#endif
+ (void)hv_iterinit(hv);
+ /*SUPPRESS 560*/
+ while (hent = hv_iternext(hv)) { /* concise but not very efficient */
+ he_free(ohent);
+ ohent = hent;
+ }
+ he_free(ohent);
+#ifdef SOME_DBM
+ xhv->xhv_dbm = old_dbm;
+#endif
+ if (SvMAGIC(hv))
+ mg_clear(hv);
+}
+
+void
+hv_undef(hv,dodbm)
+HV *hv;
+I32 dodbm;
+{
+ register XPVHV* xhv;
+ if (!hv)
+ return;
+ xhv = (XPVHV*)SvANY(hv);
+ hfreeentries(hv,dodbm);
+ Safefree(xhv->xhv_array);
+ xhv->xhv_array = 0;
+ if (xhv->xhv_coeffsize) {
+ xhv->xhv_max = 7; /* it's a normal associative array */
+ xhv->xhv_dosplit = xhv->xhv_max * FILLPCT / 100;
+ }
+ else {
+ xhv->xhv_max = 127; /* it's a symbol table */
+ xhv->xhv_dosplit = 128; /* so never split */
+ }
+ xhv->xhv_fill = 0;
+#ifdef SOME_DBM
+ xhv->xhv_dbm = 0;
+#endif
+ (void)hv_iterinit(hv); /* so each() will start off right */
+}
+
+void
+hv_free(hv,dodbm)
+register HV *hv;
+I32 dodbm;
+{
+ if (!hv)
+ return;
+ hfreeentries(hv,dodbm);
+ Safefree(HvARRAY(hv));
+ Safefree(hv);
+}
+
+I32
+hv_iterinit(hv)
+HV *hv;
+{
+ register XPVHV* xhv = (XPVHV*)SvANY(hv);
+ xhv->xhv_riter = -1;
+ xhv->xhv_eiter = Null(HE*);
+ return xhv->xhv_fill;
+}
+
+HE *
+hv_iternext(hv)
+HV *hv;
+{
+ register XPVHV* xhv;
+ register HE *entry;
+#ifdef SOME_DBM
+ datum key;
+#endif
+
+ if (!hv)
+ fatal("Bad associative array");
+ xhv = (XPVHV*)SvANY(hv);
+ entry = xhv->xhv_eiter;
+#ifdef SOME_DBM
+ if (xhv->xhv_dbm) {
+ if (entry) {
+#ifdef HAS_GDBM
+ key.dptr = entry->hent_key;
+ key.dsize = entry->hent_klen;
+ key = gdbm_nextkey(xhv->xhv_dbm, key);
+#else
+#ifdef HAS_NDBM
+#ifdef _CX_UX
+ key.dptr = entry->hent_key;
+ key.dsize = entry->hent_klen;
+ key = dbm_nextkey(xhv->xhv_dbm, key);
+#else
+ key = dbm_nextkey(xhv->xhv_dbm);
+#endif /* _CX_UX */
+#else
+ key.dptr = entry->hent_key;
+ key.dsize = entry->hent_klen;
+ key = nextkey(key);
+#endif
+#endif
+ }
+ else {
+ Newz(504,entry, 1, HE);
+ xhv->xhv_eiter = entry;
+#ifdef HAS_GDBM
+ key = gdbm_firstkey(xhv->xhv_dbm);
+#else
+ key = dbm_firstkey(xhv->xhv_dbm);
+#endif
+ }
+ entry->hent_key = key.dptr;
+ entry->hent_klen = key.dsize;
+ if (!key.dptr) {
+ if (entry->hent_val)
+ sv_free(entry->hent_val);
+ Safefree(entry);
+ xhv->xhv_eiter = Null(HE*);
+ return Null(HE*);
+ }
+ return entry;
+ }
+#endif
+ if (!xhv->xhv_array)
+ Newz(506,xhv->xhv_array, xhv->xhv_max + 1, HE*);
+ do {
+ if (entry)
+ entry = entry->hent_next;
+ if (!entry) {
+ xhv->xhv_riter++;
+ if (xhv->xhv_riter > xhv->xhv_max) {
+ xhv->xhv_riter = -1;
+ break;
+ }
+ entry = xhv->xhv_array[xhv->xhv_riter];
+ }
+ } while (!entry);
+
+ xhv->xhv_eiter = entry;
+ return entry;
+}
+
+char *
+hv_iterkey(entry,retlen)
+register HE *entry;
+I32 *retlen;
+{
+ *retlen = entry->hent_klen;
+ return entry->hent_key;
+}
+
+SV *
+hv_iterval(hv,entry)
+HV *hv;
+register HE *entry;
+{
+#ifdef SOME_DBM
+ register XPVHV* xhv;
+ datum key, content;
+
+ if (!hv)
+ fatal("Bad associative array");
+ xhv = (XPVHV*)SvANY(hv);
+ if (xhv->xhv_dbm) {
+ key.dptr = entry->hent_key;
+ key.dsize = entry->hent_klen;
+#ifdef HAS_GDBM
+ content = gdbm_fetch(xhv->xhv_dbm,key);
+#else
+ content = dbm_fetch(xhv->xhv_dbm,key);
+#endif
+ if (!entry->hent_val)
+ entry->hent_val = NEWSV(62,0);
+ sv_setpvn(entry->hent_val,content.dptr,content.dsize);
+ }
+#endif
+ return entry->hent_val;
+}
+
+#ifdef SOME_DBM
+
+#ifndef OP_CREAT
+# ifdef I_FCNTL
+# include <fcntl.h>
+# endif
+# ifdef I_SYS_FILE
+# include <sys/file.h>
+# endif
+#endif
+
+#ifndef OP_RDONLY
+#define OP_RDONLY 0
+#endif
+#ifndef OP_RDWR
+#define OP_RDWR 2
+#endif
+#ifndef OP_CREAT
+#define OP_CREAT 01000
+#endif
+
+bool
+hv_dbmopen(hv,fname,mode)
+HV *hv;
+char *fname;
+I32 mode;
+{
+ register XPVHV* xhv;
+ if (!hv)
+ return FALSE;
+ xhv = (XPVHV*)SvANY(hv);
+#ifdef HAS_ODBM
+ if (xhv->xhv_dbm) /* never really closed it */
+ return TRUE;
+#endif
+ if (xhv->xhv_dbm) {
+ hv_dbmclose(hv);
+ xhv->xhv_dbm = 0;
+ }
+ hv_clear(hv, FALSE); /* clear cache */
+#ifdef HAS_GDBM
+ if (mode >= 0)
+ xhv->xhv_dbm = gdbm_open(fname, 0, GDBM_WRCREAT,mode, (void *) NULL);
+ if (!xhv->xhv_dbm)
+ xhv->xhv_dbm = gdbm_open(fname, 0, GDBM_WRITER, mode, (void *) NULL);
+ if (!xhv->xhv_dbm)
+ xhv->xhv_dbm = gdbm_open(fname, 0, GDBM_READER, mode, (void *) NULL);
+#else
+#ifdef HAS_NDBM
+ if (mode >= 0)
+ xhv->xhv_dbm = dbm_open(fname, OP_RDWR|OP_CREAT, mode);
+ if (!xhv->xhv_dbm)
+ xhv->xhv_dbm = dbm_open(fname, OP_RDWR, mode);
+ if (!xhv->xhv_dbm)
+ xhv->xhv_dbm = dbm_open(fname, OP_RDONLY, mode);
+#else
+ if (dbmrefcnt++)
+ fatal("Old dbm can only open one database");
+ sprintf(buf,"%s.dir",fname);
+ if (stat(buf, &statbuf) < 0) {
+ if (mode < 0 || close(creat(buf,mode)) < 0)
+ return FALSE;
+ sprintf(buf,"%s.pag",fname);
+ if (close(creat(buf,mode)) < 0)
+ return FALSE;
+ }
+ xhv->xhv_dbm = dbminit(fname) >= 0;
+#endif
+#endif
+ if (!xhv->xhv_array && xhv->xhv_dbm != 0)
+ Newz(507,xhv->xhv_array, xhv->xhv_max + 1, HE*);
+ hv_magic(hv, 0, 'D');
+ return xhv->xhv_dbm != 0;
+}
+
+void
+hv_dbmclose(hv)
+HV *hv;
+{
+ register XPVHV* xhv;
+ if (!hv)
+ fatal("Bad associative array");
+ xhv = (XPVHV*)SvANY(hv);
+ if (xhv->xhv_dbm) {
+#ifdef HAS_GDBM
+ gdbm_close(xhv->xhv_dbm);
+ xhv->xhv_dbm = 0;
+#else
+#ifdef HAS_NDBM
+ dbm_close(xhv->xhv_dbm);
+ xhv->xhv_dbm = 0;
+#else
+ /* dbmrefcnt--; */ /* doesn't work, rats */
+#endif
+#endif
+ }
+ else if (dowarn)
+ warn("Close on unopened dbm file");
+}
+
+bool
+hv_dbmstore(hv,key,klen,sv)
+HV *hv;
+char *key;
+U32 klen;
+register SV *sv;
+{
+ register XPVHV* xhv;
+ datum dkey, dcontent;
+ I32 error;
+
+ if (!hv)
+ return FALSE;
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_dbm)
+ return FALSE;
+ dkey.dptr = key;
+ dkey.dsize = klen;
+ dcontent.dptr = SvPVn(sv);
+ dcontent.dsize = SvCUR(sv);
+#ifdef HAS_GDBM
+ error = gdbm_store(xhv->xhv_dbm, dkey, dcontent, GDBM_REPLACE);
+#else
+ error = dbm_store(xhv->xhv_dbm, dkey, dcontent, DBM_REPLACE);
+#endif
+ if (error) {
+ if (errno == EPERM)
+ fatal("No write permission to dbm file");
+ fatal("dbm store returned %d, errno %d, key \"%s\"",error,errno,key);
+#ifdef HAS_NDBM
+ dbm_clearerr(xhv->xhv_dbm);
+#endif
+ }
+ return !error;
+}
+#endif /* SOME_DBM */
+
+#ifdef XXX
+ magictype = MgTYPE(magic);
+ switch (magictype) {
+ case 'E':
+ environ[0] = Nullch;
+ break;
+ case 'S':
+#ifndef NSIG
+#define NSIG 32
+#endif
+ for (i = 1; i < NSIG; i++)
+ signal(i, SIG_DFL); /* crunch, crunch, crunch */
+ break;
+ }
+
+ if (magic) {
+ sv_magic(tmpstr, (SV*)tmpgv, magic, tmps, SvCUR(sv));
+ sv_magicset(tmpstr, magic);
+ }
+
+ if (hv->hv_sv.sv_rare && !sv->sv_magic)
+ sv_magic(sv, (GV*)hv, hv->hv_sv.sv_rare, key, keylen);
+#endif
+
+void
+hv_magic(hv, gv, how)
+HV* hv;
+GV* gv;
+I32 how;
+{
+ sv_magic(hv, gv, how, 0, 0);
+}
--- /dev/null
+/* $RCSfile: hash.h,v $$Revision: 4.1 $$Date: 92/08/07 18:21:52 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: hash.h,v $
+ * Revision 4.1 92/08/07 18:21:52 lwall
+ *
+ * Revision 4.0.1.2 91/11/05 17:24:31 lwall
+ * patch11: random cleanup
+ *
+ * Revision 4.0.1.1 91/06/07 11:10:33 lwall
+ * patch4: new copyright notice
+ *
+ * Revision 4.0 91/03/20 01:22:38 lwall
+ * 4.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 coeff array */
+
+typedef struct he HE;
+
+struct he {
+ HE *hent_next;
+ char *hent_key;
+ SV *hent_val;
+ I32 hent_hash;
+ I32 hent_klen;
+};
+
+struct xpvhv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xp_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ STRLEN xof_off; /* ptr is incremented by offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* magic for scalar array */
+ HV* xmg_stash; /* class package */
+
+ MAGIC* xhv_magic; /* magic for elements */
+
+ HE **xhv_array;
+ I32 xhv_max; /* subscript of last element of xhv_array */
+ I32 xhv_dosplit; /* how full to get before splitting */
+ I32 xhv_fill; /* how full xhv_array currently is */
+ I32 xhv_riter; /* current root of iterator */
+ HE *xhv_eiter; /* current entry of iterator */
+ PMOP *xhv_pmroot; /* list of pm's for this package */
+ char *xhv_name; /* name, if a symbol table */
+#ifdef SOME_DBM
+#ifdef HAS_GDBM
+ GDBM_FILE xhv_dbm;
+#else
+#ifdef HAS_NDBM
+ DBM *xhv_dbm;
+#else
+ I32 xhv_dbm;
+#endif
+#endif
+#endif
+ unsigned char xhv_coeffsize; /* is 0 for symbol tables */
+};
+
+#define Nullhv Null(HV*)
+#define HvMAGIC(hv) ((XPVHV*) SvANY(hv))->xhv_magic
+#define HvARRAY(hv) ((XPVHV*) SvANY(hv))->xhv_array
+#define HvMAX(hv) ((XPVHV*) SvANY(hv))->xhv_max
+#define HvDOSPLIT(hv) ((XPVHV*) SvANY(hv))->xhv_dosplit
+#define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill
+#define HvRITER(hv) ((XPVHV*) SvANY(hv))->xhv_riter
+#define HvEITER(hv) ((XPVHV*) SvANY(hv))->xhv_eiter
+#define HvPMROOT(hv) ((XPVHV*) SvANY(hv))->xhv_pmroot
+#define HvNAME(hv) ((XPVHV*) SvANY(hv))->xhv_name
+#define HvDBM(hv) ((XPVHV*) SvANY(hv))->xhv_dbm
+#define HvCOEFFSIZE(hv) ((XPVHV*) SvANY(hv))->xhv_coeffsize
--- /dev/null
+#!/usr/bin/perl
+
+while (<>) {
+ chop;
+ $stuff[$i++] .= $_;
+ $i = 0 if eof;
+}
+
+$" = "\n"; print "@stuff\n";
--- /dev/null
+Argv
+Cmd
+DBgv
+DBline
+DBsignal
+DBsingle
+DBsub
+DBtrace
+allgvs
+ampergv
+argvgv
+argvoutgv
+arybase
+basetime
+bodytarget
+cddir
+chopset
+copline
+curblock
+curcop
+curcsv
+curoutgv
+curpm
+curstash
+curstname
+cxstack
+cxstack_ix
+cxstack_max
+dbargs
+dbmrefcnt
+debdelim
+debname
+debstash
+debug
+defgv
+defoutgv
+defstash
+delaymagic
+dirty
+dlevel
+dlmax
+do_undump
+doextract
+doswitches
+dowarn
+dumplvl
+e_fp
+e_tmpname
+envgv
+eval_root
+eval_start
+fdpid
+filemode
+firstgv
+forkprocess
+formfeed
+formtarget
+freestrroot
+gensym
+hint
+in_eval
+incgv
+inplace
+last_elen
+last_eval
+last_in_gv
+last_root
+lastfd
+lastretstr
+lastscream
+lastsize
+lastspbase
+laststatval
+laststype
+leftgv
+lineary
+localizing
+main_root
+main_start
+mainstack
+maxscream
+maxsysfd
+minus_a
+minus_c
+minus_l
+minus_n
+minus_p
+multiline
+mystack_base
+mystack_mark
+mystack_max
+mystack_sp
+mystrk
+nrs
+nrschar
+nrslen
+ofmt
+ofs
+ofslen
+oldlastpm
+oldname
+origargc
+origargv
+origfilename
+ors
+orslen
+patchlevel
+perldb
+pidstatus
+preambled
+preprocess
+restartop
+rightgv
+rs
+rschar
+rslen
+rspara
+sawampersand
+sawi
+sawstudy
+sawvec
+screamfirst
+screamnext
+secondgv
+siggv
+signalstack
+sortcop
+sortstack
+sortstash
+stack
+statcache
+statgv
+statname
+statusvalue
+stdingv
+strchop
+taintanyway
+tainted
+tmps_floor
+tmps_ix
+tmps_max
+tmps_stack
+top_env
+toptarget
+unsafe
--- /dev/null
+#define KEY_NULL 0
+#define KEY___LINE__ 1
+#define KEY___FILE__ 2
+#define KEY___END__ 3
+#define KEY_alarm 4
+#define KEY_accept 5
+#define KEY_atan2 6
+#define KEY_bind 7
+#define KEY_binmode 8
+#define KEY_bless 9
+#define KEY_chop 10
+#define KEY_continue 11
+#define KEY_chdir 12
+#define KEY_close 13
+#define KEY_closedir 14
+#define KEY_cmp 15
+#define KEY_caller 16
+#define KEY_crypt 17
+#define KEY_chmod 18
+#define KEY_chown 19
+#define KEY_connect 20
+#define KEY_cos 21
+#define KEY_chroot 22
+#define KEY_do 23
+#define KEY_die 24
+#define KEY_defined 25
+#define KEY_delete 26
+#define KEY_dbmopen 27
+#define KEY_dbmclose 28
+#define KEY_dump 29
+#define KEY_else 30
+#define KEY_elsif 31
+#define KEY_eq 32
+#define KEY_EQ 33
+#define KEY_exit 34
+#define KEY_eval 35
+#define KEY_eof 36
+#define KEY_exp 37
+#define KEY_each 38
+#define KEY_exec 39
+#define KEY_endhostent 40
+#define KEY_endnetent 41
+#define KEY_endservent 42
+#define KEY_endprotoent 43
+#define KEY_endpwent 44
+#define KEY_endgrent 45
+#define KEY_for 46
+#define KEY_foreach 47
+#define KEY_format 48
+#define KEY_formline 49
+#define KEY_fork 50
+#define KEY_fcntl 51
+#define KEY_fileno 52
+#define KEY_flock 53
+#define KEY_gt 54
+#define KEY_GT 55
+#define KEY_ge 56
+#define KEY_GE 57
+#define KEY_grep 58
+#define KEY_goto 59
+#define KEY_gmtime 60
+#define KEY_getc 61
+#define KEY_getppid 62
+#define KEY_getpgrp 63
+#define KEY_getpriority 64
+#define KEY_getprotobyname 65
+#define KEY_getprotobynumber 66
+#define KEY_getprotoent 67
+#define KEY_getpwent 68
+#define KEY_getpwnam 69
+#define KEY_getpwuid 70
+#define KEY_getpeername 71
+#define KEY_gethostbyname 72
+#define KEY_gethostbyaddr 73
+#define KEY_gethostent 74
+#define KEY_getnetbyname 75
+#define KEY_getnetbyaddr 76
+#define KEY_getnetent 77
+#define KEY_getservbyname 78
+#define KEY_getservbyport 79
+#define KEY_getservent 80
+#define KEY_getsockname 81
+#define KEY_getsockopt 82
+#define KEY_getgrent 83
+#define KEY_getgrnam 84
+#define KEY_getgrgid 85
+#define KEY_getlogin 86
+#define KEY_hex 87
+#define KEY_if 88
+#define KEY_index 89
+#define KEY_int 90
+#define KEY_ioctl 91
+#define KEY_join 92
+#define KEY_keys 93
+#define KEY_kill 94
+#define KEY_last 95
+#define KEY_lc 96
+#define KEY_lcfirst 97
+#define KEY_local 98
+#define KEY_length 99
+#define KEY_lt 100
+#define KEY_LT 101
+#define KEY_le 102
+#define KEY_LE 103
+#define KEY_localtime 104
+#define KEY_log 105
+#define KEY_link 106
+#define KEY_listen 107
+#define KEY_lstat 108
+#define KEY_m 109
+#define KEY_mkdir 110
+#define KEY_msgctl 111
+#define KEY_msgget 112
+#define KEY_msgrcv 113
+#define KEY_msgsnd 114
+#define KEY_next 115
+#define KEY_ne 116
+#define KEY_NE 117
+#define KEY_open 118
+#define KEY_ord 119
+#define KEY_oct 120
+#define KEY_opendir 121
+#define KEY_print 122
+#define KEY_printf 123
+#define KEY_push 124
+#define KEY_pop 125
+#define KEY_pack 126
+#define KEY_package 127
+#define KEY_pipe 128
+#define KEY_q 129
+#define KEY_qq 130
+#define KEY_qx 131
+#define KEY_return 132
+#define KEY_require 133
+#define KEY_reset 134
+#define KEY_redo 135
+#define KEY_rename 136
+#define KEY_rand 137
+#define KEY_rmdir 138
+#define KEY_rindex 139
+#define KEY_ref 140
+#define KEY_read 141
+#define KEY_readdir 142
+#define KEY_rewinddir 143
+#define KEY_recv 144
+#define KEY_reverse 145
+#define KEY_readlink 146
+#define KEY_s 147
+#define KEY_scalar 148
+#define KEY_select 149
+#define KEY_seek 150
+#define KEY_semctl 151
+#define KEY_semget 152
+#define KEY_semop 153
+#define KEY_send 154
+#define KEY_setpgrp 155
+#define KEY_setpriority 156
+#define KEY_sethostent 157
+#define KEY_setnetent 158
+#define KEY_setservent 159
+#define KEY_setprotoent 160
+#define KEY_setpwent 161
+#define KEY_setgrent 162
+#define KEY_seekdir 163
+#define KEY_setsockopt 164
+#define KEY_shift 165
+#define KEY_shmctl 166
+#define KEY_shmget 167
+#define KEY_shmread 168
+#define KEY_shmwrite 169
+#define KEY_shutdown 170
+#define KEY_sin 171
+#define KEY_sleep 172
+#define KEY_socket 173
+#define KEY_socketpair 174
+#define KEY_sort 175
+#define KEY_split 176
+#define KEY_sprintf 177
+#define KEY_splice 178
+#define KEY_sqrt 179
+#define KEY_srand 180
+#define KEY_stat 181
+#define KEY_study 182
+#define KEY_substr 183
+#define KEY_sub 184
+#define KEY_system 185
+#define KEY_symlink 186
+#define KEY_syscall 187
+#define KEY_sysread 188
+#define KEY_syswrite 189
+#define KEY_tr 190
+#define KEY_tell 191
+#define KEY_telldir 192
+#define KEY_time 193
+#define KEY_times 194
+#define KEY_truncate 195
+#define KEY_uc 196
+#define KEY_ucfirst 197
+#define KEY_until 198
+#define KEY_unless 199
+#define KEY_unlink 200
+#define KEY_undef 201
+#define KEY_unpack 202
+#define KEY_utime 203
+#define KEY_umask 204
+#define KEY_unshift 205
+#define KEY_values 206
+#define KEY_vec 207
+#define KEY_while 208
+#define KEY_warn 209
+#define KEY_wait 210
+#define KEY_waitpid 211
+#define KEY_wantarray 212
+#define KEY_write 213
+#define KEY_x 214
+#define KEY_y 215
+#define KEY_BEGIN 216
+#define KEY_END 217
# routine shamelessly borrowed from the perl debugger.
sub assert {
- &panic("ASSERTION BOTCHED: $_[0]",$@) unless eval $_[0];
+ &panic("ASSERTION BOTCHED: $_[$[]",$@) unless eval $_[$[];
}
sub panic {
# 'NaN' An input parameter was "Not a Number" or
# divide by zero or sqrt of negative number
# Division is computed to
-# max($div_scale,length(dividend).length(divisor))
+# max($div_scale,length(dividend)+length(divisor))
# digits by default.
# Also used for default sqrt scale
# negation
sub main'fneg { #(fnum_str) return fnum_str
- local($_) = &'fnorm($_[0]);
+ local($_) = &'fnorm($_[$[]);
vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
s/^H/N/;
$_;
# absolute value
sub main'fabs { #(fnum_str) return fnum_str
- local($_) = &'fnorm($_[0]);
+ local($_) = &'fnorm($_[$[]);
s/^-/+/; # mash sign
$_;
}
# multiplication
sub main'fmul { #(fnum_str, fnum_str) return fnum_str
- local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
if ($x eq 'NaN' || $y eq 'NaN') {
'NaN';
} else {
\f
# addition
sub main'fadd { #(fnum_str, fnum_str) return fnum_str
- local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
if ($x eq 'NaN' || $y eq 'NaN') {
'NaN';
} else {
# subtraction
sub main'fsub { #(fnum_str, fnum_str) return fnum_str
- &'fadd($_[0],&'fneg($_[1]));
+ &'fadd($_[$[],&'fneg($_[$[+1]));
}
# division
# result has at most max(scale, length(dividend), length(divisor)) digits
sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
{
- local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]);
+ local($x,$y,$scale) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]),$_[$[+2]);
if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
'NaN';
} else {
if ( $cmp < 0 ||
($cmp == 0 &&
( $rnd_mode eq 'zero' ||
- ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) ||
- ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) ||
+ ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) ||
+ ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) ||
($rnd_mode eq 'even' && $q =~ /[24680]$/) ||
($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) {
$q; # round down
} else {
- &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1'));
+ &'badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1'));
# round up
}
}
# round the mantissa of $x to $scale digits
sub main'fround { #(fnum_str, scale) return fnum_str
- local($x,$scale) = (&'fnorm($_[0]),$_[1]);
+ local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
if ($x eq 'NaN' || $scale <= 0) {
$x;
} else {
if (length($xm)-1 <= $scale) {
$x;
} else {
- &norm(&round(substr($xm,0,$scale+1),
- "+0".substr($xm,$scale+1,1),"+10"),
+ &norm(&round(substr($xm,$[,$scale+1),
+ "+0".substr($xm,$[+$scale+1,1),"+10"),
$xe+length($xm)-$scale-1);
}
}
\f
# round $x at the 10 to the $scale digit place
sub main'ffround { #(fnum_str, scale) return fnum_str
- local($x,$scale) = (&'fnorm($_[0]),$_[1]);
+ local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
if ($x eq 'NaN') {
'NaN';
} else {
if ($xe < 1) {
'+0E+0';
} elsif ($xe == 1) {
- &norm(&round('+0',"+0".substr($xm,1,1),"+10"), $scale);
+ &norm(&round('+0',"+0".substr($xm,$[+1,1),"+10"), $scale);
} else {
- &norm(&round(substr($xm,0,$trunc),
- "+0".substr($xm,$trunc,1),"+10"), $scale);
+ &norm(&round(substr($xm,$[,$xe),
+ "+0".substr($xm,$[+$xe,1),"+10"), $scale);
}
}
}
# returns undef if either or both input value are not numbers
sub main'fcmp #(fnum_str, fnum_str) return cond_code
{
- local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ local($x, $y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
if ($x eq "NaN" || $y eq "NaN") {
undef;
} else {
ord($y) <=> ord($x)
||
( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
- (($xe <=> $ye) * (substr($x,0,1).'1')
+ (($xe <=> $ye) * (substr($x,$[,1).'1')
|| &bigint'cmp($xm,$ym))
);
}
\f
# square root by Newtons method.
sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
- local($x, $scale) = (&'fnorm($_[0]), $_[1]);
+ local($x, $scale) = (&'fnorm($_[$[]), $_[$[+1]);
if ($x eq 'NaN' || $x =~ /^-/) {
'NaN';
} elsif ($x eq '+0E+0') {
local($_) = @_;
s/\s+//g; # strip white space
if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number
- substr($_,0,0) = '+' unless $1; # Add missing sign
+ substr($_,$[,0) = '+' unless $1; # Add missing sign
s/^-0/+0/;
$_;
} else {
# Assumes normalized value as input.
sub internal { #(num_str) return int_num_array
local($d) = @_;
- ($is,$il) = (substr($d,0,1),length($d)-2);
- substr($d,0,1) = '';
+ ($is,$il) = (substr($d,$[,1),length($d)-2);
+ substr($d,$[,1) = '';
($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
}
\f
# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
sub main'bcmp { #(num_str, num_str) return cond_code
- local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+ local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
if ($x eq 'NaN') {
undef;
} elsif ($y eq 'NaN') {
}
sub main'badd { #(num_str, num_str) return num_str
- local(*x, *y); ($x, $y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+ local(*x, *y); ($x, $y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
if ($x eq 'NaN') {
'NaN';
} elsif ($y eq 'NaN') {
}
sub main'bsub { #(num_str, num_str) return num_str
- &'badd($_[0],&'bneg($_[1]));
+ &'badd($_[$[],&'bneg($_[$[+1]));
}
# GCD -- Euclids algorithm Knuth Vol 2 pg 296
sub main'bgcd { #(num_str, num_str) return num_str
- local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+ local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
if ($x eq 'NaN' || $y eq 'NaN') {
'NaN';
} else {
# multiply two numbers -- stolen from Knuth Vol 2 pg 233
sub main'bmul { #(num_str, num_str) return num_str
- local(*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
+ local(*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1]));
if ($x eq 'NaN') {
'NaN';
} elsif ($y eq 'NaN') {
local($signr) = (shift @x ne shift @y) ? '-' : '+';
@prod = ();
for $x (@x) {
- ($car, $cty) = (0, 0);
+ ($car, $cty) = (0, $[);
for $y (@y) {
$prod = $x * $y + $prod[$cty] + $car;
$prod[$cty++] =
# modulus
sub main'bmod { #(num_str, num_str) return num_str
- (&'bdiv(@_))[1];
+ (&'bdiv(@_))[$[+1];
}
\f
sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
- local (*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
+ local (*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1]));
return wantarray ? ('NaN','NaN') : 'NaN'
if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
@x = &internal($x); @y = &internal($y);
- $srem = $y[0];
+ $srem = $y[$[];
$sr = (shift @x ne shift @y) ? '-' : '+';
$car = $bar = $prd = 0;
if (($dd = int(1e5/($y[$#y]+1))) != 1) {
--$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
if ($q) {
($car, $bar) = (0,0);
- for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
+ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
$prd = $q * $y[$y] + $car;
$prd -= ($car = int($prd * 1e-5)) * 1e5;
$x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0));
}
if ($x[$#x] < $car + $bar) {
$car = 0; --$q;
- for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
+ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
$x[$x] -= 1e5
if ($car = (($x[$x] += $y[$y] + $car) > 1e5));
}
$num = &'bnorm($num);
$dom = &'bnorm($dom);
}
- substr($dom,0,1) = '';
+ substr($dom,$[,1) = '';
"$num/$dom";
}
}
# negation
sub main'rneg { #(rat_num) return rat_num
- local($_) = &'rnorm($_[0]);
+ local($_) = &'rnorm(@_);
tr/-+/+-/ if ($_ ne '+0/1');
$_;
}
# absolute value
sub main'rabs { #(rat_num) return $rat_num
- local($_) = &'rnorm($_[0]);
- substr($_,0,1) = '+' unless $_ eq 'NaN';
+ local($_) = &'rnorm(@_);
+ substr($_,$[,1) = '+' unless $_ eq 'NaN';
$_;
}
# multipication
sub main'rmul { #(rat_num, rat_num) return rat_num
- local($xn,$xd) = split('/',&'rnorm($_[0]));
- local($yn,$yd) = split('/',&'rnorm($_[1]));
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
}
# division
sub main'rdiv { #(rat_num, rat_num) return rat_num
- local($xn,$xd) = split('/',&'rnorm($_[0]));
- local($yn,$yd) = split('/',&'rnorm($_[1]));
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
}
\f
# addition
sub main'radd { #(rat_num, rat_num) return rat_num
- local($xn,$xd) = split('/',&'rnorm($_[0]));
- local($yn,$yd) = split('/',&'rnorm($_[1]));
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
}
# subtraction
sub main'rsub { #(rat_num, rat_num) return rat_num
- local($xn,$xd) = split('/',&'rnorm($_[0]));
- local($yn,$yd) = split('/',&'rnorm($_[1]));
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
}
# comparison
sub main'rcmp { #(rat_num, rat_num) return cond_code
- local($xn,$xd) = split('/',&'rnorm($_[0]));
- local($yn,$yd) = split('/',&'rnorm($_[1]));
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
}
# int and frac parts
sub main'rmod { #(rat_num) return (rat_num,rat_num)
- local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($xn,$xd) = split('/',&'rnorm(@_));
local($i,$f) = &'bdiv($xn,$xd);
if (wantarray) {
("$i/1", "$f/$xd");
# square root by Newtons method.
# cycles specifies the number of iterations default: 5
sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
- local($x, $scale) = (&'rnorm($_[0]), $_[1]);
+ local($x, $scale) = (&'rnorm($_[$[]), $_[$[+1]);
if ($x eq 'NaN') {
'NaN';
} elsif ($x =~ /^-/) {
-## chat.pl: chat with a server
-## V2.01.alpha.7 91/06/16
-## Randal L. Schwartz
+# chat.pl: chat with a server
+# Based on: V2.01.alpha.7 91/06/16
+# Randal L. Schwartz (was <merlyn@iwarp.intel.com>)
+# multihome additions by A.Macpherson@bnr.co.uk
+# allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU>
package chat;
+if( defined( &main'PF_INET ) ){
+ $pf_inet = &main'PF_INET;
+ $sock_stream = &main'SOCK_STREAM;
+ local($name, $aliases, $proto) = getprotobyname( 'tcp' );
+ $tcp_proto = $proto;
+}
+else {
+ # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
+ # but who the heck would change these anyway? (:-)
+ $pf_inet = 2;
+ $sock_stream = 1;
+ $tcp_proto = 6;
+}
+
+
$sockaddr = 'S n a4 x8';
-chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
-$thisproc = pack($sockaddr, 2, 0, $thisaddr);
+chop($thishost = `hostname`);
# *S = symbol for current I/O, gets assigned *chatsymbol....
$next = "chatsymbol000000"; # next one
local($serveraddr,$serverproc);
+ # We may be multi-homed, start with 0, fixup once connexion is made
+ $thisaddr = "\0\0\0\0" ;
+ $thisproc = pack($sockaddr, 2, 0, $thisaddr);
+
*S = ++$next;
if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
$serveraddr = pack('C4', $1, $2, $3, $4);
$serveraddr = $x[4];
}
$serverproc = pack($sockaddr, 2, $port, $serveraddr);
- unless (socket(S, 2, 1, 6)) {
- # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
- # but who the heck would change these anyway? (:-)
+ unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) {
($!) = ($!, close(S)); # close S while saving $!
return undef;
}
($!) = ($!, close(S)); # close S while saving $!
return undef;
}
+# We opened with the local address set to ANY, at this stage we know
+# which interface we are using. This is critical if our machine is
+# multi-homed, with IP forwarding off, so fix-up.
+ local($fam,$lport);
+ ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S));
+ $thisproc = pack($sockaddr, 2, 0, $thisaddr);
+# end of post-connect fixup
select((select(S), $| = 1)[0]);
$next; # return symbol for switcharound
}
local($thisport) = shift || 0;
local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
local(*NS) = "__" . time;
- unless (socket(NS, 2, 1, 6)) {
- # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
- # but who the heck would change these anyway? (:-)
+ unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) {
($!) = ($!, close(NS));
return undef;
}
local(*TTY) = "__TTY" . time;
local($pty,$tty) = &_getpty(S,TTY);
die "Cannot find a new pty" unless defined $pty;
- local($pid) = fork;
+ $pid = fork;
die "Cannot fork: $!" unless defined $pid;
unless ($pid) {
close STDIN; close STDOUT; close STDERR;
die "Cannot exec @cmd: $!";
}
close(TTY);
- $PID{$next} = $pid;
$next; # return symbol for switcharound
}
*S = shift;
}
print S @_;
+ if( $chat'debug ){
+ print STDERR "printed:";
+ print STDERR @_;
+ }
}
## &chat'close([$handle,])
## like close $handle
sub close { ## public
- local($pid);
if ($_[0] =~ /$nextpat/) {
- $pid = $PID{$_[0]};
*S = shift;
- } else {
- $pid = $PID{$next};
}
close(S);
- waitpid($pid,0);
if (defined $S{"needs_close"}) { # is it a listen socket?
local(*NS) = $S{"needs_close"};
delete $S{"needs_close"};
# internal procedure to get the next available pty.
# opens pty on handle PTY, and matching tty on handle TTY.
# returns undef if can't find a pty.
+# Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik.
sub _getpty { ## private
local($_PTY,$_TTY) = @_;
$_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
$_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
- local($pty,$tty);
+ local($pty, $tty, $kind);
+ if( -e "/dev/pts000" ){ ## mods by Joe Doupnik Dec 1992
+ $kind = "pts"; ## SVR4 Streams
+ } else {
+ $kind = "pty"; ## BSD Clist stuff
+ }
for $bank (112..127) {
- next unless -e sprintf("/dev/pty%c0", $bank);
+ next unless -e sprintf("/dev/$kind%c0", $bank);
for $unit (48..57) {
- $pty = sprintf("/dev/pty%c%c", $bank, $unit);
+ $pty = sprintf("/dev/$kind%c%c", $bank, $unit);
open($_PTY,"+>$pty") || next;
select((select($_PTY), $| = 1)[0]);
($tty = $pty) =~ s/pty/tty/;
;# Waldemar Kebsch, Federal Republic of Germany, November 1988
;# kebsch.pad@nixpbe.UUCP
;# Modified March 1990, Feb 1991 to properly handle timezones
-;# $RCSfile: ctime.pl,v $$Revision: 4.0.1.1 $$Date: 92/06/08 13:38:06 $
+;# $RCSfile: ctime.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:47 $
;# Marion Hakanson (hakanson@cse.ogi.edu)
;# Oregon Graduate Institute of Science and Technology
;#
--- /dev/null
+#-*-perl-*-
+# This is a wrapper to the chat2.pl routines that make life easier
+# to do ftp type work.
+# Mostly by Lee McLoughlin <lmjm@doc.ic.ac.uk>
+# based on original version by Alan R. Martello <al@ee.pitt.edu>
+# And by A.Macpherson@bnr.co.uk for multi-homed hosts
+#
+# $Header: /a/swan/home/swan/staff/csg/lmjm/src/perl/mirror/RCS/ftp.pl,v 1.17 1993/04/21 10:06:54 lmjm Exp lmjm $
+# $Log: ftp.pl,v $
+# Revision 1.17 1993/04/21 10:06:54 lmjm
+# Send all status reports to STDERR not to STDOUT (to allow use by ftpcat).
+# Allow target file to be '-' meaning STDOUT
+# Added ftp'quote
+#
+# Revision 1.16 1993/01/28 18:59:05 lmjm
+# Allow socket arguemtns to come from main.
+# Minor cleanups - removed old comments.
+#
+# Revision 1.15 1992/11/25 21:09:30 lmjm
+# Added another REST return code.
+#
+# Revision 1.14 1992/08/12 14:33:42 lmjm
+# Fail ftp'write if out of space.
+#
+# Revision 1.13 1992/03/20 21:01:03 lmjm
+# Added in the proxy ftp code from Edwards Reed <err@cinops.xerox.com>
+# Added ftp'delete from Aaron Wohl <aw0g+@andrew.cmu.edu>
+#
+# Revision 1.12 1992/02/06 23:25:56 lmjm
+# Moved code around so can use this as a lib for both mirror and ftpmail.
+# Time out opens. In case Unix doesn't bother to.
+#
+# Revision 1.11 1991/11/27 22:05:57 lmjm
+# Match the response code number at the start of a line allowing
+# for any leading junk.
+#
+# Revision 1.10 1991/10/23 22:42:20 lmjm
+# Added better timeout code.
+# Tried to optimise file transfer
+# Moved open/close code to not leak file handles.
+# Cleaned up the alarm code.
+# Added $fatalerror to show wether the ftp link is really dead.
+#
+# Revision 1.9 1991/10/07 18:30:35 lmjm
+# Made the timeout-read code work.
+# Added restarting file gets.
+# Be more verbose if ever have to call die.
+#
+# Revision 1.8 1991/09/17 22:53:16 lmjm
+# Spot when open_data_socket fails and return a failure rather than dying.
+#
+# Revision 1.7 1991/09/12 22:40:25 lmjm
+# Added Andrew Macpherson's patches for hosts without ip forwarding.
+#
+# Revision 1.6 1991/09/06 19:53:52 lmjm
+# Relaid out the code the way I like it!
+# Changed the debuggin to produce more "appropriate" messages
+# Fixed bugs in the ordering of put and dir listing.
+# Allow for hash printing when getting files (a la ftp).
+# Added the new commands from Al.
+# Don't print passwords in debugging.
+#
+# Revision 1.5 1991/08/29 16:23:49 lmjm
+# Timeout reads from the remote ftp server.
+# No longer call die expect on fatal errors. Just return fail codes.
+# Changed returns so higher up routines can tell whats happening.
+# Get expect/accept in correct order for dir listing.
+# When ftp_show is set then print hashes every 1k transfered (like ftp).
+# Allow for stripping returns out of incoming data.
+# Save last error in a global string.
+#
+# Revision 1.4 1991/08/14 21:04:58 lmjm
+# ftp'get now copes with ungetable files.
+# ftp'expect code changed such that the string_to_print is
+# ignored and the string sent back from the remote system is printed
+# instead.
+# Implemented patches from al. Removed spuiours tracing statements.
+#
+# Revision 1.3 1991/08/09 21:32:18 lmjm
+# Allow for another ok code on cwd's
+# Rejigger the log levels
+# Send \r\n for some odd ftp daemons
+#
+# Revision 1.2 1991/08/09 18:07:37 lmjm
+# Don't print messages unless ftp_show says to.
+#
+# Revision 1.1 1991/08/08 20:31:00 lmjm
+# Initial revision
+#
+
+require 'chat2.pl';
+require 'socket.ph';
+
+
+package ftp;
+
+if( defined( &main'PF_INET ) ){
+ $pf_inet = &main'PF_INET;
+ $sock_stream = &main'SOCK_STREAM;
+ local($name, $aliases, $proto) = getprotobyname( 'tcp' );
+ $tcp_proto = $proto;
+}
+else {
+ # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
+ # but who the heck would change these anyway? (:-)
+ $pf_inet = 2;
+ $sock_stream = 1;
+ $tcp_proto = 6;
+}
+
+# If the remote ftp daemon doesn't respond within this time presume its dead
+# or something.
+$timeout = 30;
+
+# Timeout a read if I don't get data back within this many seconds
+$timeout_read = 20 * $timeout;
+
+# Timeout an open
+$timeout_open = $timeout;
+
+# This is a "global" it contains the last response from the remote ftp server
+# for use in error messages
+$ftp'response = "";
+# Also ftp'NS is the socket containing the data coming in from the remote ls
+# command.
+
+# The size of block to be read or written when talking to the remote
+# ftp server
+$ftp'ftpbufsize = 4096;
+
+# How often to print a hash out, when debugging
+$ftp'hashevery = 1024;
+# Output a newline after this many hashes to prevent outputing very long lines
+$ftp'hashnl = 70;
+
+# If a proxy connection then who am I really talking to?
+$real_site = "";
+
+# This is just a tracing aid.
+$ftp_show = 0;
+sub ftp'debug
+{
+ $ftp_show = @_[0];
+# if( $ftp_show ){
+# print STDERR "ftp debugging on\n";
+# }
+}
+
+sub ftp'set_timeout
+{
+ $timeout = @_[0];
+ $timeout_open = $timeout;
+ $timeout_read = 20 * $timeout;
+ if( $ftp_show ){
+ print STDERR "ftp timeout set to $timeout\n";
+ }
+}
+
+
+sub ftp'open_alarm
+{
+ die "timeout: open";
+}
+
+sub ftp'timed_open
+{
+ local( $site, $ftp_port, $retry_call, $attempts ) = @_;
+ local( $connect_site, $connect_port );
+ local( $res );
+
+ alarm( $timeout_open );
+
+ while( $attempts-- ){
+ if( $ftp_show ){
+ print STDERR "proxy connecting via $proxy_gateway [$proxy_ftp_port]\n" if $proxy;
+ print STDERR "Connecting to $site";
+ if( $ftp_port != 21 ){
+ print STDERR " [port $ftp_port]";
+ }
+ print STDERR "\n";
+ }
+
+ if( $proxy ) {
+ if( ! $proxy_gateway ) {
+ # if not otherwise set
+ $proxy_gateway = "internet-gateway";
+ }
+ if( $debug ) {
+ print STDERR "using proxy services of $proxy_gateway, ";
+ print STDERR "at $proxy_ftp_port\n";
+ }
+ $connect_site = $proxy_gateway;
+ $connect_port = $proxy_ftp_port;
+ $real_site = $site;
+ }
+ else {
+ $connect_site = $site;
+ $connect_port = $ftp_port;
+ }
+ if( ! &chat'open_port( $connect_site, $connect_port ) ){
+ if( $retry_call ){
+ print STDERR "Failed to connect\n" if $ftp_show;
+ next;
+ }
+ else {
+ print STDERR "proxy connection failed " if $proxy;
+ print STDERR "Cannot open ftp to $connect_site\n" if $ftp_show;
+ return 0;
+ }
+ }
+ $res = &ftp'expect( $timeout,
+ 120, "service unavailable to $site", 0,
+ 220, "ready for login to $site", 1,
+ 421, "service unavailable to $site, closing connection", 0);
+ if( ! $res ){
+ &chat'close();
+ next;
+ }
+ return 1;
+ }
+ continue {
+ print STDERR "Pausing between retries\n";
+ sleep( $retry_pause );
+ }
+ return 0;
+}
+
+sub ftp'open
+{
+ local( $site, $ftp_port, $retry_call, $attempts ) = @_;
+
+ $SIG{ 'ALRM' } = "ftp\'open_alarm";
+
+ local( $ret ) = eval "&timed_open( '$site', $ftp_port, $retry_call, $attempts )";
+ alarm( 0 );
+
+ if( $@ =~ /^timeout/ ){
+ return -1;
+ }
+ return $ret;
+}
+
+sub ftp'login
+{
+ local( $remote_user, $remote_password ) = @_;
+
+ if( $proxy ){
+ &ftp'send( "USER $remote_user@$site" );
+ }
+ else {
+ &ftp'send( "USER $remote_user" );
+ }
+ local( $val ) =
+ &ftp'expect($timeout,
+ 230, "$remote_user logged in", 1,
+ 331, "send password for $remote_user", 2,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 530, "not logged in", 0,
+ 332, "account for login not supported", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ if( $val == 1 ){
+ return 1;
+ }
+ if( $val == 2 ){
+ # A password is needed
+ &ftp'send( "PASS $remote_password" );
+
+ $val = &ftp'expect( $timeout,
+ 230, "$remote_user logged in", 1,
+
+ 202, "command not implemented", 0,
+ 332, "account for login not supported", 0,
+
+ 530, "not logged in", 0,
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 503, "bad sequence of commands", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ if( $val == 1){
+ # Logged in
+ return 1;
+ }
+ }
+ # If I got here I failed to login
+ return 0;
+}
+
+sub ftp'close
+{
+ &ftp'quit();
+ &chat'close();
+}
+
+# Change directory
+# return 1 if successful
+# 0 on a failure
+sub ftp'cwd
+{
+ local( $dir ) = @_;
+
+ &ftp'send( "CWD $dir" );
+
+ return &ftp'expect( $timeout,
+ 200, "working directory = $dir", 1,
+ 250, "working directory = $dir", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "command not implemented", 0,
+ 530, "not logged in", 0,
+ 550, "cannot change directory", 0,
+ 421, "service unavailable, closing connection", 0 );
+}
+
+# Get a full directory listing:
+# &ftp'dir( remote LIST options )
+# Start a list goin with the given options.
+# Presuming that the remote deamon uses the ls command to generate the
+# data to send back then then you can send it some extra options (eg: -lRa)
+# return 1 if sucessful and 0 on a failure
+sub ftp'dir_open
+{
+ local( $options ) = @_;
+ local( $ret );
+
+ if( ! &ftp'open_data_socket() ){
+ return 0;
+ }
+
+ if( $options ){
+ &ftp'send( "LIST $options" );
+ }
+ else {
+ &ftp'send( "LIST" );
+ }
+
+ $ret = &ftp'expect( $timeout,
+ 150, "reading directory", 1,
+
+ 125, "data connection already open?", 0,
+
+ 450, "file unavailable", 0,
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "command not implemented", 0,
+ 530, "not logged in", 0,
+
+ 421, "service unavailable, closing connection", 0 );
+ if( ! $ret ){
+ &ftp'close_data_socket;
+ return 0;
+ }
+
+ #
+ # the data should be coming at us now
+ #
+
+ # now accept
+ accept(NS,S) || die "accept failed $!";
+
+ return 1;
+}
+
+
+# Close down reading the result of a remote ls command
+# return 1 if successful and 0 on failure
+sub ftp'dir_close
+{
+ local( $ret );
+
+ # read the close
+ #
+ $ret = &ftp'expect($timeout,
+ 226, "", 1, # transfer complete, closing connection
+ 250, "", 1, # action completed
+
+ 425, "can't open data connection", 0,
+ 426, "connection closed, transfer aborted", 0,
+ 451, "action aborted, local error", 0,
+ 421, "service unavailable, closing connection", 0);
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ if( ! $ret ){
+ return 0;
+ }
+
+ return 1;
+}
+
+# Quit from the remote ftp server
+# return 1 if successful and 0 on failure
+sub ftp'quit
+{
+ $site_command_check = 0;
+ @site_command_list = ();
+
+ &ftp'send("QUIT");
+
+ return &ftp'expect($timeout,
+ 221, "Goodbye", 1, # transfer complete, closing connection
+
+ 500, "error quitting??", 0);
+}
+
+sub ftp'read_alarm
+{
+ die "timeout: read";
+}
+
+sub ftp'timed_read
+{
+ alarm( $timeout_read );
+ return sysread( NS, $buf, $ftpbufsize );
+}
+
+sub ftp'read
+{
+ $SIG{ 'ALRM' } = "ftp\'read_alarm";
+
+ local( $ret ) = eval '&timed_read()';
+ alarm( 0 );
+
+ if( $@ =~ /^timeout/ ){
+ return -1;
+ }
+ return $ret;
+}
+
+# Get a remote file back into a local file.
+# If no loc_fname passed then uses rem_fname.
+# returns 1 on success and 0 on failure
+sub ftp'get
+{
+ local($rem_fname, $loc_fname, $restart ) = @_;
+
+ if ($loc_fname eq "") {
+ $loc_fname = $rem_fname;
+ }
+
+ if( ! &ftp'open_data_socket() ){
+ print STDERR "Cannot open data socket\n";
+ return 0;
+ }
+
+ if( $loc_fname ne '-' ){
+ # Find the size of the target file
+ local( $restart_at ) = &ftp'filesize( $loc_fname );
+ if( $restart && $restart_at > 0 && &ftp'restart( $restart_at ) ){
+ $restart = 1;
+ # Make sure the file can be updated
+ chmod( 0644, $loc_fname );
+ }
+ else {
+ $restart = 0;
+ unlink( $loc_fname );
+ }
+ }
+
+ &ftp'send( "RETR $rem_fname" );
+
+ local( $ret ) =
+ &ftp'expect($timeout,
+ 150, "receiving $rem_fname", 1,
+
+ 125, "data connection already open?", 0,
+
+ 450, "file unavailable", 2,
+ 550, "file unavailable", 2,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 530, "not logged in", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ if( $ret != 1 ){
+ print STDERR "Failure on RETR command\n";
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ return 0;
+ }
+
+ #
+ # the data should be coming at us now
+ #
+
+ # now accept
+ accept(NS,S) || die "accept failed: $!";
+
+ #
+ # open the local fname
+ # concatenate on the end if restarting, else just overwrite
+ if( !open(FH, ($restart ? '>>' : '>') . $loc_fname) ){
+ print STDERR "Cannot create local file $loc_fname\n";
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ return 0;
+ }
+
+# while (<NS>) {
+# print FH ;
+# }
+
+ local( $start_time ) = time;
+ local( $bytes, $lasthash, $hashes ) = (0, 0, 0);
+ while( ($len = &ftp'read()) > 0 ){
+ $bytes += $len;
+ if( $strip_cr ){
+ $ftp'buf =~ s/\r//g;
+ }
+ if( $ftp_show ){
+ while( $bytes > ($lasthash + $ftp'hashevery) ){
+ print STDERR '#';
+ $lasthash += $ftp'hashevery;
+ $hashes++;
+ if( ($hashes % $ftp'hashnl) == 0 ){
+ print STDERR "\n";
+ }
+ }
+ }
+ if( ! print FH $ftp'buf ){
+ print STDERR "\nfailed to write data";
+ return 0;
+ }
+ }
+ close( FH );
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ if( $len < 0 ){
+ print STDERR "\ntimed out reading data!\n";
+
+ return 0;
+ }
+
+ if( $ftp_show ){
+ if( $hashes && ($hashes % $ftp'hashnl) != 0 ){
+ print STDERR "\n";
+ }
+ local( $secs ) = (time - $start_time);
+ if( $secs <= 0 ){
+ $secs = 1; # To avoid a divide by zero;
+ }
+
+ local( $rate ) = int( $bytes / $secs );
+ print STDERR "Got $bytes bytes ($rate bytes/sec)\n";
+ }
+
+ #
+ # read the close
+ #
+
+ $ret = &ftp'expect($timeout,
+ 226, "Got file", 1, # transfer complete, closing connection
+ 250, "Got file", 1, # action completed
+
+ 110, "restart not supported", 0,
+ 425, "can't open data connection", 0,
+ 426, "connection closed, transfer aborted", 0,
+ 451, "action aborted, local error", 0,
+ 421, "service unavailable, closing connection", 0);
+
+ return $ret;
+}
+
+sub ftp'delete
+{
+ local( $rem_fname, $val ) = @_;
+
+ &ftp'send("DELE $rem_fname" );
+ $val = &ftp'expect( $timeout,
+ 250,"Deleted $rem_fname", 1,
+ 550,"Permission denied",0
+ );
+ return $val == 1;
+}
+
+sub ftp'deldir
+{
+ local( $fname ) = @_;
+
+ # not yet implemented
+ # RMD
+}
+
+# UPDATE ME!!!!!!
+# Add in the hash printing and newline conversion
+sub ftp'put
+{
+ local( $loc_fname, $rem_fname ) = @_;
+ local( $strip_cr );
+
+ if ($loc_fname eq "") {
+ $loc_fname = $rem_fname;
+ }
+
+ if( ! &ftp'open_data_socket() ){
+ return 0;
+ }
+
+ &ftp'send("STOR $rem_fname");
+
+ #
+ # the data should be coming at us now
+ #
+
+ local( $ret ) =
+ &ftp'expect($timeout,
+ 150, "sending $loc_fname", 1,
+
+ 125, "data connection already open?", 0,
+ 450, "file unavailable", 0,
+
+ 532, "need account for storing files", 0,
+ 452, "insufficient storage on system", 0,
+ 553, "file name not allowed", 0,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 530, "not logged in", 0,
+
+ 421, "service unavailable, closing connection", 0);
+
+ if( $ret != 1 ){
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ return 0;
+ }
+
+
+ #
+ # the data should be coming at us now
+ #
+
+ # now accept
+ accept(NS,S) || die "accept failed: $!";
+
+ #
+ # open the local fname
+ #
+ if( !open(FH, "<$loc_fname") ){
+ print STDERR "Cannot open local file $loc_fname\n";
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ return 0;
+ }
+
+ while (<FH>) {
+ print NS ;
+ }
+ close(FH);
+
+ # shut down our end of the socket to signal EOF
+ &ftp'close_data_socket;
+
+ #
+ # read the close
+ #
+
+ $ret = &ftp'expect($timeout,
+ 226, "file put", 1, # transfer complete, closing connection
+ 250, "file put", 1, # action completed
+
+ 110, "restart not supported", 0,
+ 425, "can't open data connection", 0,
+ 426, "connection closed, transfer aborted", 0,
+ 451, "action aborted, local error", 0,
+ 551, "page type unknown", 0,
+ 552, "storage allocation exceeded", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ if( ! $ret ){
+ print STDERR "error putting $loc_fname\n";
+ }
+ return $ret;
+}
+
+sub ftp'restart
+{
+ local( $restart_point, $ret ) = @_;
+
+ &ftp'send("REST $restart_point");
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect($timeout,
+ 350, "restarting at $restart_point", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "REST not implemented", 2,
+ 530, "not logged in", 0,
+ 554, "REST not implemented", 2,
+
+ 421, "service unavailable, closing connection", 0);
+ return $ret;
+}
+
+# Set the file transfer type
+sub ftp'type
+{
+ local( $type ) = @_;
+
+ &ftp'send("TYPE $type");
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect($timeout,
+ 200, "file type set to $type", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 504, "Invalid form or byte size for type $type", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ return $ret;
+}
+
+$site_command_check = 0;
+@site_command_list = ();
+
+# routine to query the remote server for 'SITE' commands supported
+sub ftp'site_commands
+{
+ local( $ret );
+
+ # if we havent sent a 'HELP SITE', send it now
+ if( !$site_command_check ){
+
+ $site_command_check = 1;
+
+ &ftp'send( "HELP SITE" );
+
+ # assume the line in the HELP SITE response with the 'HELP'
+ # command is the one for us
+ $ret = &ftp'expect( $timeout,
+ ".*HELP.*", "", "\$1",
+ 214, "", "0",
+ 202, "", "0" );
+
+ if( $ret eq "0" ){
+ print STDERR "No response from HELP SITE\n" if( $ftp_show );
+ }
+
+ @site_command_list = split(/\s+/, $ret);
+ }
+
+ return @site_command_list;
+}
+
+# return the pwd, or null if we can't get the pwd
+sub ftp'pwd
+{
+ local( $ret, $cwd );
+
+ &ftp'send( "PWD" );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 257, "working dir is", 1,
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "PWD not implemented", 0,
+ 550, "file unavailable", 0,
+
+ 421, "service unavailable, closing connection", 0 );
+ if( $ret ){
+ if( $ftp'response =~ /^257\s"(.*)"\s.*$/ ){
+ $cwd = $1;
+ }
+ }
+ return $cwd;
+}
+
+# return 1 for success, 0 for failure
+sub ftp'mkdir
+{
+ local( $path ) = @_;
+ local( $ret );
+
+ &ftp'send( "MKD $path" );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 257, "made directory $path", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "MKD not implemented", 0,
+ 530, "not logged in", 0,
+ 550, "file unavailable", 0,
+
+ 421, "service unavailable, closing connection", 0 );
+ return $ret;
+}
+
+# return 1 for success, 0 for failure
+sub ftp'chmod
+{
+ local( $path, $mode ) = @_;
+ local( $ret );
+
+ &ftp'send( sprintf( "SITE CHMOD %o $path", $mode ) );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 200, "chmod $mode $path succeeded", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "CHMOD not implemented", 0,
+ 530, "not logged in", 0,
+ 550, "file unavailable", 0,
+
+ 421, "service unavailable, closing connection", 0 );
+ return $ret;
+}
+
+# rename a file
+sub ftp'rename
+{
+ local( $old_name, $new_name ) = @_;
+ local( $ret );
+
+ &ftp'send( "RNFR $old_name" );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 350, "", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "RNFR not implemented", 0,
+ 530, "not logged in", 0,
+ 550, "file unavailable", 0,
+ 450, "file unavailable", 0,
+
+ 421, "service unavailable, closing connection", 0);
+
+
+ # check if the "rename from" occurred ok
+ if( $ret ) {
+ &ftp'send( "RNTO $new_name" );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 250, "rename $old_name to $new_name", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "RNTO not implemented", 0,
+ 503, "bad sequence of commands", 0,
+ 530, "not logged in", 0,
+ 532, "need account for storing files", 0,
+ 553, "file name not allowed", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ }
+
+ return $ret;
+}
+
+
+sub ftp'quote
+{
+ local( $cmd ) = @_;
+
+ &ftp'send( $cmd );
+
+ return &ftp'expect( $timeout,
+ 200, "Remote '$cmd' OK", 1,
+ 500, "error in remote '$cmd'", 0 );
+}
+
+# ------------------------------------------------------------------------------
+# These are the lower level support routines
+
+sub ftp'expectgot
+{
+ ($ftp'response, $ftp'fatalerror) = @_;
+ if( $ftp_show ){
+ print STDERR "$ftp'response\n";
+ }
+}
+
+#
+# create the list of parameters for chat'expect
+#
+# ftp'expect(time_out, {value, string_to_print, return value});
+# if the string_to_print is "" then nothing is printed
+# the last response is stored in $ftp'response
+#
+# NOTE: lmjm has changed this code such that the string_to_print is
+# ignored and the string sent back from the remote system is printed
+# instead.
+#
+sub ftp'expect {
+ local( $ret );
+ local( $time_out );
+ local( $expect_args );
+
+ $ftp'response = '';
+ $ftp'fatalerror = 0;
+
+ @expect_args = ();
+
+ $time_out = shift(@_);
+
+ while( @_ ){
+ local( $code ) = shift( @_ );
+ local( $pre ) = '^';
+ if( $code =~ /^\d/ ){
+ $pre =~ "[.|\n]*^";
+ }
+ push( @expect_args, "$pre(" . $code . " .*)\\015\\n" );
+ shift( @_ );
+ push( @expect_args,
+ "&ftp'expectgot( \$1, 0 ); " . shift( @_ ) );
+ }
+
+ # Treat all unrecognised lines as continuations
+ push( @expect_args, "^(.*)\\015\\n" );
+ push( @expect_args, "&ftp'expectgot( \$1, 0 ); 100" );
+
+ # add patterns TIMEOUT and EOF
+
+ push( @expect_args, 'TIMEOUT' );
+ push( @expect_args, "&ftp'expectgot( \"timed out\", 1 ); 0" );
+
+ push( @expect_args, 'EOF' );
+ push( @expect_args, "&ftp'expectgot( \"remote server gone away\", 1 ); 0" );
+
+ if( $ftp_show > 9 ){
+ &printargs( $time_out, @expect_args );
+ }
+
+ $ret = &chat'expect( $time_out, @expect_args );
+ if( $ret == 100 ){
+ # we saw a continuation line, wait for the end
+ push( @expect_args, "^.*\n" );
+ push( @expect_args, "100" );
+
+ while( $ret == 100 ){
+ $ret = &chat'expect( $time_out, @expect_args );
+ }
+ }
+
+ return $ret;
+}
+
+#
+# opens NS for io
+#
+sub ftp'open_data_socket
+{
+ local( $ret );
+ local( $hostname );
+ local( $sockaddr, $name, $aliases, $proto, $port );
+ local( $type, $len, $thisaddr, $myaddr, $a, $b, $c, $d );
+ local( $mysockaddr, $family, $hi, $lo );
+
+
+ $sockaddr = 'S n a4 x8';
+ chop( $hostname = `hostname` );
+
+ $port = "ftp";
+
+ ($name, $aliases, $proto) = getprotobyname( 'tcp' );
+ ($name, $aliases, $port) = getservbyname( $port, 'tcp' );
+
+# ($name, $aliases, $type, $len, $thisaddr) =
+# gethostbyname( $hostname );
+ ($a,$b,$c,$d) = unpack( 'C4', $chat'thisaddr );
+
+# $this = pack( $sockaddr, &main'AF_INET, 0, $thisaddr );
+ $this = $chat'thisproc;
+
+ socket(S, $pf_inet, $sock_stream, $proto ) || die "socket: $!";
+ bind(S, $this) || die "bind: $!";
+
+ # get the port number
+ $mysockaddr = getsockname(S);
+ ($family, $port, $myaddr) = unpack( $sockaddr, $mysockaddr );
+
+ $hi = ($port >> 8) & 0x00ff;
+ $lo = $port & 0x00ff;
+
+ #
+ # we MUST do a listen before sending the port otherwise
+ # the PORT may fail
+ #
+ listen( S, 5 ) || die "listen";
+
+ &ftp'send( "PORT $a,$b,$c,$d,$hi,$lo" );
+
+ return &ftp'expect($timeout,
+ 200, "PORT command successful", 1,
+ 250, "PORT command successful", 1 ,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 530, "not logged in", 0,
+
+ 421, "service unavailable, closing connection", 0);
+}
+
+sub ftp'close_data_socket
+{
+ close(NS);
+}
+
+sub ftp'send
+{
+ local($send_cmd) = @_;
+ if( $send_cmd =~ /\n/ ){
+ print STDERR "ERROR, \\n in send string for $send_cmd\n";
+ }
+
+ if( $ftp_show ){
+ local( $sc ) = $send_cmd;
+
+ if( $send_cmd =~ /^PASS/){
+ $sc = "PASS <somestring>";
+ }
+ print STDERR "---> $sc\n";
+ }
+
+ &chat'print( "$send_cmd\r\n" );
+}
+
+sub ftp'printargs
+{
+ while( @_ ){
+ print STDERR shift( @_ ) . "\n";
+ }
+}
+
+sub ftp'filesize
+{
+ local( $fname ) = @_;
+
+ if( ! -f $fname ){
+ return -1;
+ }
+
+ return (stat( _ ))[ 7 ];
+
+}
+
+# make this package return true
+1;
-;# $RCSfile: getopt.pl,v $$Revision: 4.0.1.1 $$Date: 91/11/05 17:53:01 $
+;# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
;# Process single-character switches with switch clustering. Pass one argument
;# which is a string containing all switches that take an argument. For each
-;# $Header: importenv.pl,v 4.0 91/03/20 01:25:28 lwall Locked $
+;# $RCSfile: importenv.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:02 $
;# This file, when interpreted, pulls the environment into normal variables.
;# Usage:
# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
# Johan Vromans -- upgrade to 4.0 pl 10
-$header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.3 $$Date: 92/06/08 13:43:57 $';
+$header = '$RCSfile: perldb.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:07 $';
#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
#
# $Log: perldb.pl,v $
+# Revision 4.1 92/08/07 18:24:07 lwall
+#
# Revision 4.0.1.3 92/06/08 13:43:57 lwall
# patch20: support for MSDOS folded into perldb.pl
# patch20: perldb couldn't debug file containing '-', such as STDIN designator
next CMD; };
$cmd =~ s/^X\b/V $package/;
$cmd =~ /^V$/ && do {
- $cmd = 'V $package'; };
+ $cmd = "V $package"; };
$cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
+ local ($savout) = select(OUT);
$packname = $1;
@vars = split(' ',$2);
do 'dumpvar.pl' unless defined &main'dumpvar;
else {
print DB'OUT "dumpvar.pl not available.\n";
}
+ select ($savout);
next CMD; };
$cmd =~ /^f\b\s*(.*)/ && do {
$file = $1;
;# pwd.pl - keeps track of current working directory in PWD environment var
;#
-;# $RCSfile: pwd.pl,v $$Revision: 4.0.1.1 $$Date: 92/06/08 13:45:22 $
+;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
;#
;# $Log: pwd.pl,v $
+;# Revision 4.1 92/08/07 18:24:11 lwall
+;#
;# Revision 4.0.1.1 92/06/08 13:45:22 lwall
;# patch20: support added to pwd.pl to strip automounter crud
;#
-;# $Header: stat.pl,v 4.0 91/03/20 01:26:16 lwall Locked $
+;# $RCSfile: stat.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:13 $
;# Usage:
;# require 'stat.pl';
# syslog.pl
#
# $Log: syslog.pl,v $
+# Revision 4.1 92/08/07 18:24:15 lwall
+#
# Revision 4.0.1.1 92/06/08 13:48:05 lwall
# patch20: new warning for ambiguous use of unary operators
#
--- /dev/null
+# This subroutine returns true if its argument is tainted, false otherwise.
+
+sub tainted {
+ local($@);
+ eval { kill 0 * $_[0] };
+ $@ =~ /^Insecure/;
+}
+
+1;
-;# $RCSfile: termcap.pl,v $$Revision: 4.0.1.1 $$Date: 92/06/08 13:49:17 $
+;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
;#
;# Usage:
;# require 'ioctl.pl';
-;# $Header: validate.pl,v 4.0 91/03/20 01:26:56 lwall Locked $
+;# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $
;# The validate routine takes a single multiline string consisting of
;# lines containing a filename plus a file test to try on it. (The
--- /dev/null
+#include "INTERN.h"
+#include "perl.h"
+
+main(argc, argv, env)
+int argc;
+char **argv;
+char **env;
+{
+ int exitstatus;
+ Interpreter *my_perl;
+
+ my_perl = perl_alloc();
+ if (!my_perl)
+ exit(1);
+ perl_construct( my_perl );
+
+ exitstatus = perl_parse( my_perl, argc, argv, env );
+ if (exitstatus)
+ exit( exitstatus );
+
+ exitstatus = perl_run( my_perl );
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ exit( exitstatus );
+}
--- /dev/null
+make: Warning: Both `makefile' and `Makefile' exists
+`sh cflags perl.o` perl.c
+ CCCMD = cc -c -I/usr/include/sun -I/usr/ucbinclude -DDEBUGGING -g
+cc -Bstatic main.o perly.o perl.o av.o scope.o op.o doop.o doio.o dolist.o dump.o malloc.o mg.o pp.o regcomp.o regexec.o gv.o sv.o toke.o util.o deb.o run.o hv.o usersub.o -ldbm -lm -lposix -o perl
+echo "\a"
+\a
--- /dev/null
+#!/bin/sh
+# : makedepend.SH,v 15738Revision: 4.1 15738Date: 92/08/07 18:24:20 $
+#
+# $Log: makedepend.SH,v $
+# Revision 4.1 92/08/07 18:24:20 lwall
+#
+# Revision 4.0.1.4 92/06/08 13:51:24 lwall
+# patch20: various and sundry fixes
+#
+# Revision 4.0.1.3 91/11/05 17:56:33 lwall
+# patch11: various portability fixes
+#
+# Revision 4.0.1.2 91/06/07 15:40:06 lwall
+# patch4: fixed cppstdin to run in the right directory
+#
+# Revision 4.0.1.1 91/06/07 11:20:06 lwall
+# patch4: Makefile is no longer self-modifying code under makedepend
+#
+# Revision 4.0 91/03/20 01:27:04 lwall
+# 4.0 baseline.
+#
+#
+
+export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0; kill $$)
+
+cat='/bin/cat'
+cppflags=' -I/usr/include/sun -I/usr/ucbinclude -DDEBUGGING'
+cp='/bin/cp'
+cppstdin='/usr/lib/cpp'
+cppminus=''
+echo='/bin/echo'
+egrep='/bin/egrep'
+expr='/bin/expr'
+mv='/bin/mv'
+rm='/bin/rm'
+sed='/bin/sed'
+sort='/bin/sort'
+test='test'
+tr='/bin/tr'
+uniq='/bin/uniq'
+
+PATH="$PATH:."
+export PATH
+
+$cat /dev/null >.deptmp
+$rm -f *.c.c c/*.c.c
+if test -f Makefile; then
+ cp Makefile makefile
+fi
+mf=makefile
+if test -f $mf; then
+ defrule=`<$mf sed -n \
+ -e '/^\.c\.o:.*;/{' \
+ -e 's/\$\*\.c//' \
+ -e 's/^[^;]*;[ ]*//p' \
+ -e q \
+ -e '}' \
+ -e '/^\.c\.o: *$/{' \
+ -e N \
+ -e 's/\$\*\.c//' \
+ -e 's/^.*\n[ ]*//p' \
+ -e q \
+ -e '}'`
+fi
+case "$defrule" in
+'') defrule='$(CC) -c $(CFLAGS)' ;;
+esac
+
+make clist || ($echo "Searching for .c files..."; \
+ $echo *.c | $tr ' ' '\012' | $egrep -v '\*' >.clist)
+for file in `$cat .clist`; do
+# for file in `cat /dev/null`; do
+ case "$file" in
+ *.c) filebase=`basename $file .c` ;;
+ *.y) filebase=`basename $file .y` ;;
+ esac
+ case "$file" in
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ *) finc= ;;
+ esac
+ $echo "Finding dependencies for $filebase.o."
+ ( $echo "#line 1 \"$file\""; \
+ $sed -n <$file \
+ -e "/^${filebase}_init(/q" \
+ -e '/^#/{' \
+ -e 's|/\*.*$||' \
+ -e 's|\\$||' \
+ -e p \
+ -e '}' ) >$file.c
+ $cppstdin $finc -I/usr/local/include -I. $cppflags $cppminus <$file.c |
+ $sed \
+ -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
+ -e 's/^[ ]*#[ ]*line/#/' \
+ -e '/^# *[0-9][0-9]* *[".\/]/!d' \
+ -e 's/^.*"\(.*\)".*$/'$filebase'.o: \1/' \
+ -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'.o: \1/' \
+ -e 's|: \./|: |' \
+ -e 's|\.c\.c|.c|' | \
+ $uniq | $sort | $uniq >> .deptmp
+done
+
+$sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d'
+
+make shlist || ($echo "Searching for .SH files..."; \
+ $echo *.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist)
+if $test -s .deptmp; then
+ for file in `cat .shlist`; do
+ $echo `$expr X$file : 'X\(.*\).SH'`: $file config.sh \; \
+ /bin/sh $file >> .deptmp
+ done
+ $echo "Updating $mf..."
+ $echo "# If this runs make out of memory, delete /usr/include lines." \
+ >> $mf.new
+ $sed 's|^\(.*\.o:\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
+ >>$mf.new
+else
+ make hlist || ($echo "Searching for .h files..."; \
+ $echo *.h | $tr ' ' '\012' | $egrep -v '\*' >.hlist)
+ $echo "You don't seem to have a proper C preprocessor. Using grep instead."
+ $egrep '^#include ' `cat .clist` `cat .hlist` >.deptmp
+ $echo "Updating $mf..."
+ <.clist $sed -n \
+ -e '/\//{' \
+ -e 's|^\(.*\)/\(.*\)\.c|\2.o: \1/\2.c; '"$defrule \1/\2.c|p" \
+ -e d \
+ -e '}' \
+ -e 's|^\(.*\)\.c|\1.o: \1.c|p' >> $mf.new
+ <.hlist $sed -n 's|\(.*/\)\(.*\)|s= \2= \1\2=|p' >.hsed
+ <.deptmp $sed -n 's|c:#include "\(.*\)".*$|o: \1|p' | \
+ $sed 's|^[^;]*/||' | \
+ $sed -f .hsed >> $mf.new
+ <.deptmp $sed -n 's|c:#include <\(.*\)>.*$|o: /usr/include/\1|p' \
+ >> $mf.new
+ <.deptmp $sed -n 's|h:#include "\(.*\)".*$|h: \1|p' | \
+ $sed -f .hsed >> $mf.new
+ <.deptmp $sed -n 's|h:#include <\(.*\)>.*$|h: /usr/include/\1|p' \
+ >> $mf.new
+ for file in `$cat .shlist`; do
+ $echo `$expr X$file : 'X\(.*\).SH'`: $file config.sh \; \
+ /bin/sh $file >> $mf.new
+ done
+fi
+$rm -f $mf.old
+$cp $mf $mf.old
+$cp $mf.new $mf
+$rm $mf.new
+$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
+$rm -f .deptmp `sed 's/\.c/.c.c/' .clist` .shlist .clist .hlist .hsed
+
rm -f makedepend
$spitshell >makedepend <<!GROK!THIS!
$startsh
-# $RCSfile: makedepend.SH,v $$Revision: 4.0.1.4 $$Date: 92/06/08 13:51:24 $
+# $RCSfile: makedepend.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:24:20 $
#
# $Log: makedepend.SH,v $
+# Revision 4.1 92/08/07 18:24:20 lwall
+#
# Revision 4.0.1.4 92/06/08 13:51:24 lwall
# patch20: various and sundry fixes
#
--- /dev/null
+#!/bin/sh
+# : makedir.SH,v 15738Revision: 4.1 15738Date: 92/08/07 18:24:23 $
+#
+# $Log: makedir.SH,v $
+# Revision 4.1 92/08/07 18:24:23 lwall
+#
+# Revision 4.0.1.1 92/06/08 14:24:55 lwall
+# patch20: SH files didn't work well with symbolic links
+#
+# Revision 4.0 91/03/20 01:27:13 lwall
+# 4.0 baseline.
+#
+#
+
+export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0; kill $$)
+
+case $# in
+ 0)
+ /bin/echo "makedir pathname filenameflag"
+ exit 1
+ ;;
+esac
+
+: guarantee one slash before 1st component
+case $1 in
+ /*) ;;
+ *) set ./$1 $2 ;;
+esac
+
+: strip last component if it is to be a filename
+case X$2 in
+ X1) set `/bin/echo $1 | /bin/sed 's:\(.*\)/[^/]*$:\1:'` ;;
+ *) set $1 ;;
+esac
+
+: return reasonable status if nothing to be created
+if test -d "$1" ; then
+ exit 0
+fi
+
+list=''
+while true ; do
+ case $1 in
+ */*)
+ list="$1 $list"
+ set `echo $1 | /bin/sed 's:\(.*\)/:\1 :'`
+ ;;
+ *)
+ break
+ ;;
+ esac
+done
+
+set $list
+
+for dir do
+ /bin/mkdir $dir >/dev/null 2>&1
+done
rm -f makedir
$spitshell >makedir <<!GROK!THIS!
$startsh
-# $RCSfile: makedir.SH,v $$Revision: 4.0.1.1 $$Date: 92/06/08 14:24:55 $
+# $RCSfile: makedir.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:24:23 $
#
# $Log: makedir.SH,v $
+# Revision 4.1 92/08/07 18:24:23 lwall
+#
# Revision 4.0.1.1 92/06/08 14:24:55 lwall
# patch20: SH files didn't work well with symbolic links
#
--- /dev/null
+# : Makefile.SH,v 15738Revision: 4.1 15738Date: 92/08/07 17:18:08 $
+#
+# $Log: Makefile.SH,v $
+# Revision 4.1 92/08/07 17:18:08 lwall
+# Stage 6 Snapshot
+#
+# Revision 4.0.1.4 92/06/08 11:40:43 lwall
+# patch20: cray didn't give enough memory to /bin/sh
+# patch20: various and sundry fixes
+#
+# Revision 4.0.1.3 91/11/05 15:48:11 lwall
+# patch11: saberized perl
+# patch11: added support for dbz
+#
+# Revision 4.0.1.2 91/06/07 10:14:43 lwall
+# patch4: cflags now emits entire cc command except for the filename
+# patch4: alternate make programs are now semi-supported
+# patch4: uperl.o no longer tries to link in libraries prematurely
+# patch4: installperl now installs x2p stuff too
+#
+# Revision 4.0.1.1 91/04/11 17:30:39 lwall
+# patch1: C flags are now settable on a per-file basis
+#
+# Revision 4.0 91/03/20 00:58:54 lwall
+# 4.0 baseline.
+#
+#
+
+CC = cc
+YACC = /bin/yacc
+bin = /usr/local/bin
+scriptdir = /usr/local/bin
+privlib = /usr/local/lib/perl
+mansrc = /usr/man/manl
+manext = l
+LDFLAGS =
+CLDFLAGS =
+SMALL =
+LARGE =
+mallocsrc = malloc.c
+mallocobj = malloc.o
+SLN = ln -s
+RMS = rm -f
+
+libs = -ldbm -lm -lposix
+
+public = perl
+
+shellflags =
+
+# To use an alternate make, set in config.sh.
+MAKE = make
+
+
+CCCMD = `sh $(shellflags) cflags $@`
+
+private =
+
+scripts = h2ph
+
+manpages = perl.man h2ph.man
+
+util =
+
+sh = Makefile.SH makedepend.SH h2ph.SH
+
+h1 = EXTERN.h INTERN.h av.h cop.h config.h embed.h form.h handy.h
+h2 = hv.h op.h opcode.h perl.h regcomp.h regexp.h gv.h sv.h util.h
+
+h = $(h1) $(h2)
+
+c1 = av.c cop.c cons.c consop.c doop.c doio.c dolist.c
+c2 = eval.c hv.c main.c $(mallocsrc) perl.c pp.c regcomp.c regexec.c
+c3 = gv.c sv.c toke.c util.c usersub.c
+
+c = $(c1) $(c2) $(c3)
+
+s1 = av.c cop.c cons.c consop.c doop.c doio.c dolist.c
+s2 = eval.c hv.c main.c perl.c pp.c regcomp.c regexec.c
+s3 = gv.c sv.c toke.c util.c usersub.c perly.c
+
+saber = $(s1) $(s2) $(s3)
+
+obj1 = av.o scope.o op.o doop.o doio.o dolist.o dump.o
+obj2 = $(mallocobj) mg.o pp.o regcomp.o regexec.o
+obj3 = gv.o sv.o toke.o util.o deb.o run.o
+
+obj = $(obj1) $(obj2) $(obj3)
+
+tobj1 = tav.o tcop.o tcons.o tconsop.o tdoop.o tdoio.o tdolist.o tdump.o
+tobj2 = teval.o thv.o $(mallocobj) tpp.o tregcomp.o tregexec.o
+tobj3 = tgv.o tsv.o ttoke.o tutil.o
+
+tobj = $(tobj1) $(tobj2) $(tobj3)
+
+lintflags = -hbvxac
+
+addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
+
+# grrr
+SHELL = /bin/sh
+
+.c.o:
+ $(CCCMD) $*.c
+
+
+all: perl
+
+#all: $(public) $(private) $(util) uperl.o $(scripts)
+# cd x2p; $(MAKE) all
+# touch all
+
+# This is the standard version that contains no "taint" checks and is
+# used for all scripts that aren't set-id or running under something set-id.
+# The $& notation is tells Sequent machines that it can do a parallel make,
+# and is harmless otherwise.
+
+perl: $& main.o perly.o perl.o $(obj) hv.o usersub.o
+ $(CC) -Bstatic $(LARGE) $(CLDFLAGS) main.o perly.o perl.o $(obj) hv.o usersub.o $(libs) -o perl
+ echo "\a"
+
+libperl.rlb: libperl.a
+ ranlib libperl.a
+ touch libperl.rlb
+
+libperl.a: $& perly.o perl.o $(obj) hv.o usersub.o
+ ar rcuv libperl.a $(obj) hv.o perly.o usersub.o
+
+# This version, if specified in Configure, does ONLY those scripts which need
+# set-id emulation. Suidperl must be setuid root. It contains the "taint"
+# checks as well as the special code to validate that the script in question
+# has been invoked correctly.
+
+suidperl: $& sperl.o tmain.o libtperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) sperl.o tmain.o libtperl.a $(libs) -o suidperl
+
+# This version interprets scripts that are already set-id either via a wrapper
+# or through the kernel allowing set-id scripts (bad idea). Taintperl must
+# NOT be setuid to root or anything else. The only difference between it
+# and normal perl is the presence of the "taint" checks.
+
+taintperl: $& tmain.o libtperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) tmain.o libtperl.a $(libs) -o taintperl
+
+libtperl.rlb: libtperl.a
+ ranlib libtperl.a
+ touch libtperl.rlb
+
+libtperl.a: $& tperly.o tperl.o $(tobj) thv.o usersub.o
+ ar rcuv libtperl.a $(tobj) thv.o tperly.o usersub.o tperl.o
+
+# This command assumes that /usr/include/dbz.h and /usr/lib/dbz.o exist.
+
+dbzperl: $& main.o zhv.o libperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) main.o zhv.o /usr/lib/dbz.o libperl.a $(libs) -o dbzperl
+
+zhv.o: hv.c $(h)
+ $(RMS) zhv.c
+ $(SLN) hv.c zhv.c
+ $(CCCMD) -DWANT_DBZ zhv.c
+ $(RMS) zhv.c
+
+uperl.o: $& $(obj) main.o hv.o perly.o
+ -ld $(LARGE) $(LDFLAGS) -r $(obj) main.o hv.o perly.o -o uperl.o
+
+saber: $(saber)
+ # load $(saber)
+ # load /lib/libm.a
+
+# Replicating all this junk is yucky, but I don't see a portable way to fix it.
+
+tperly.o: perly.c perly.h $(h)
+ $(RMS) tperly.c
+ $(SLN) perly.c tperly.c
+ $(CCCMD) -DTAINT tperly.c
+ $(RMS) tperly.c
+
+tperl.o: perl.c perly.h patchlevel.h perl.h $(h)
+ $(RMS) tperl.c
+ $(SLN) perl.c tperl.c
+ $(CCCMD) -DTAINT tperl.c
+ $(RMS) tperl.c
+
+sperl.o: perl.c perly.h patchlevel.h $(h)
+ $(RMS) sperl.c
+ $(SLN) perl.c sperl.c
+ $(CCCMD) -DTAINT -DIAMSUID sperl.c
+ $(RMS) sperl.c
+
+tav.o: av.c $(h)
+ $(RMS) tav.c
+ $(SLN) av.c tav.c
+ $(CCCMD) -DTAINT tav.c
+ $(RMS) tav.c
+
+tcop.o: cop.c $(h)
+ $(RMS) tcop.c
+ $(SLN) cop.c tcop.c
+ $(CCCMD) -DTAINT tcop.c
+ $(RMS) tcop.c
+
+tcons.o: cons.c $(h) perly.h
+ $(RMS) tcons.c
+ $(SLN) cons.c tcons.c
+ $(CCCMD) -DTAINT tcons.c
+ $(RMS) tcons.c
+
+tconsop.o: consop.c $(h)
+ $(RMS) tconsop.c
+ $(SLN) consop.c tconsop.c
+ $(CCCMD) -DTAINT tconsop.c
+ $(RMS) tconsop.c
+
+tdoop.o: doop.c $(h)
+ $(RMS) tdoop.c
+ $(SLN) doop.c tdoop.c
+ $(CCCMD) -DTAINT tdoop.c
+ $(RMS) tdoop.c
+
+tdoio.o: doio.c $(h)
+ $(RMS) tdoio.c
+ $(SLN) doio.c tdoio.c
+ $(CCCMD) -DTAINT tdoio.c
+ $(RMS) tdoio.c
+
+tdolist.o: dolist.c $(h)
+ $(RMS) tdolist.c
+ $(SLN) dolist.c tdolist.c
+ $(CCCMD) -DTAINT tdolist.c
+ $(RMS) tdolist.c
+
+tdump.o: dump.c $(h)
+ $(RMS) tdump.c
+ $(SLN) dump.c tdump.c
+ $(CCCMD) -DTAINT tdump.c
+ $(RMS) tdump.c
+
+teval.o: eval.c $(h)
+ $(RMS) teval.c
+ $(SLN) eval.c teval.c
+ $(CCCMD) -DTAINT teval.c
+ $(RMS) teval.c
+
+thv.o: hv.c $(h)
+ $(RMS) thv.c
+ $(SLN) hv.c thv.c
+ $(CCCMD) -DTAINT thv.c
+ $(RMS) thv.c
+
+tmain.o: main.c $(h)
+ $(RMS) tmain.c
+ $(SLN) main.c tmain.c
+ $(CCCMD) -DTAINT tmain.c
+ $(RMS) tmain.c
+
+tpp.o: pp.c $(h)
+ $(RMS) tpp.c
+ $(SLN) pp.c tpp.c
+ $(CCCMD) -DTAINT tpp.c
+ $(RMS) tpp.c
+
+tregcomp.o: regcomp.c $(h)
+ $(RMS) tregcomp.c
+ $(SLN) regcomp.c tregcomp.c
+ $(CCCMD) -DTAINT tregcomp.c
+ $(RMS) tregcomp.c
+
+tregexec.o: regexec.c $(h)
+ $(RMS) tregexec.c
+ $(SLN) regexec.c tregexec.c
+ $(CCCMD) -DTAINT tregexec.c
+ $(RMS) tregexec.c
+
+tgv.o: gv.c $(h)
+ $(RMS) tgv.c
+ $(SLN) gv.c tgv.c
+ $(CCCMD) -DTAINT tgv.c
+ $(RMS) tgv.c
+
+tsv.o: sv.c $(h) perly.h
+ $(RMS) tsv.c
+ $(SLN) sv.c tsv.c
+ $(CCCMD) -DTAINT tsv.c
+ $(RMS) tsv.c
+
+ttoke.o: toke.c $(h) perly.h
+ $(RMS) ttoke.c
+ $(SLN) toke.c ttoke.c
+ $(CCCMD) -DTAINT ttoke.c
+ $(RMS) ttoke.c
+
+tutil.o: util.c $(h)
+ $(RMS) tutil.c
+ $(SLN) util.c tutil.c
+ $(CCCMD) -DTAINT tutil.c
+ $(RMS) tutil.c
+
+perly.h: perly.c
+ @ echo Dummy dependency for dumb parallel make
+ touch perly.h
+
+embed.h: embed_h.SH global.var interp.var
+ sh embed_h.SH
+
+perly.c: perly.y perly.fixer
+ @ \
+case "$(YACC)" in \
+ *bison*) echo 'Expect' 25 shift/reduce and 53 reduce/reduce conflicts;; \
+ *) echo 'Expect' 27 shift/reduce and 51 reduce/reduce conflicts;; \
+esac
+ $(YACC) -d perly.y
+ sh $(shellflags) ./perly.fixer y.tab.c perly.c
+ mv y.tab.h perly.h
+ echo 'extern YYSTYPE yylval;' >>perly.h
+
+perly.o: perly.c perly.h $(h)
+ $(CCCMD) perly.c
+
+install: all
+ ./perl installperl
+
+clean:
+ rm -f *.o all perl taintperl suidperl perly.c
+ cd x2p; $(MAKE) clean
+
+realclean: clean
+ cd x2p; $(MAKE) realclean
+ rm -f *.orig */*.orig *~ */*~ core $(addedbyconf) h2ph h2ph.man
+ rm -f perly.c perly.h t/perl Makefile config.h makedepend makedir
+ rm -f makefile x2p/Makefile x2p/makefile cflags x2p/cflags
+ rm -f c2ph pstruct
+
+# 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: perly.c $(c)
+ lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz
+
+depend: makedepend
+ - test -f perly.h || cp /dev/null perly.h
+ ./makedepend
+ - test -s perly.h || /bin/rm -f perly.h
+ cd x2p; $(MAKE) depend
+
+test: perl
+ - cd t && chmod +x TEST */*.t
+ - cd t && (rm -f perl; $(SLN) ../perl perl) && ./perl TEST </dev/tty
+
+clist:
+ echo $(c) | tr ' ' '\012' >.clist
+
+hlist:
+ echo $(h) | tr ' ' '\012' >.hlist
+
+shlist:
+ echo $(sh) | tr ' ' '\012' >.shlist
+
+# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
+# If this runs make out of memory, delete /usr/include lines.
+av.o:
+av.o: /usr/ucbinclude/ctype.h
+av.o: /usr/ucbinclude/dirent.h
+av.o: /usr/ucbinclude/errno.h
+av.o: /usr/ucbinclude/machine/param.h
+av.o: /usr/ucbinclude/machine/setjmp.h
+av.o: /usr/ucbinclude/ndbm.h
+av.o: /usr/ucbinclude/netinet/in.h
+av.o: /usr/ucbinclude/setjmp.h
+av.o: /usr/ucbinclude/stdio.h
+av.o: /usr/ucbinclude/sys/dirent.h
+av.o: /usr/ucbinclude/sys/errno.h
+av.o: /usr/ucbinclude/sys/filio.h
+av.o: /usr/ucbinclude/sys/ioccom.h
+av.o: /usr/ucbinclude/sys/ioctl.h
+av.o: /usr/ucbinclude/sys/param.h
+av.o: /usr/ucbinclude/sys/signal.h
+av.o: /usr/ucbinclude/sys/sockio.h
+av.o: /usr/ucbinclude/sys/stat.h
+av.o: /usr/ucbinclude/sys/stdtypes.h
+av.o: /usr/ucbinclude/sys/sysmacros.h
+av.o: /usr/ucbinclude/sys/time.h
+av.o: /usr/ucbinclude/sys/times.h
+av.o: /usr/ucbinclude/sys/ttold.h
+av.o: /usr/ucbinclude/sys/ttychars.h
+av.o: /usr/ucbinclude/sys/ttycom.h
+av.o: /usr/ucbinclude/sys/ttydev.h
+av.o: /usr/ucbinclude/sys/types.h
+av.o: /usr/ucbinclude/time.h
+av.o: /usr/ucbinclude/vm/faultcode.h
+av.o: EXTERN.h
+av.o: av.c
+av.o: av.h
+av.o: config.h
+av.o: cop.h
+av.o: embed.h
+av.o: form.h
+av.o: gv.h
+av.o: handy.h
+av.o: hv.h
+av.o: op.h
+av.o: opcode.h
+av.o: perl.h
+av.o: pp.h
+av.o: proto.h
+av.o: regexp.h
+av.o: sv.h
+av.o: unixish.h
+av.o: util.h
+cop.o:
+cop.o: /usr/ucbinclude/ctype.h
+cop.o: /usr/ucbinclude/dirent.h
+cop.o: /usr/ucbinclude/errno.h
+cop.o: /usr/ucbinclude/machine/param.h
+cop.o: /usr/ucbinclude/machine/setjmp.h
+cop.o: /usr/ucbinclude/ndbm.h
+cop.o: /usr/ucbinclude/netinet/in.h
+cop.o: /usr/ucbinclude/setjmp.h
+cop.o: /usr/ucbinclude/stdio.h
+cop.o: /usr/ucbinclude/sys/dirent.h
+cop.o: /usr/ucbinclude/sys/errno.h
+cop.o: /usr/ucbinclude/sys/filio.h
+cop.o: /usr/ucbinclude/sys/ioccom.h
+cop.o: /usr/ucbinclude/sys/ioctl.h
+cop.o: /usr/ucbinclude/sys/param.h
+cop.o: /usr/ucbinclude/sys/signal.h
+cop.o: /usr/ucbinclude/sys/sockio.h
+cop.o: /usr/ucbinclude/sys/stat.h
+cop.o: /usr/ucbinclude/sys/stdtypes.h
+cop.o: /usr/ucbinclude/sys/sysmacros.h
+cop.o: /usr/ucbinclude/sys/time.h
+cop.o: /usr/ucbinclude/sys/times.h
+cop.o: /usr/ucbinclude/sys/ttold.h
+cop.o: /usr/ucbinclude/sys/ttychars.h
+cop.o: /usr/ucbinclude/sys/ttycom.h
+cop.o: /usr/ucbinclude/sys/ttydev.h
+cop.o: /usr/ucbinclude/sys/types.h
+cop.o: /usr/ucbinclude/time.h
+cop.o: /usr/ucbinclude/varargs.h
+cop.o: /usr/ucbinclude/vm/faultcode.h
+cop.o: EXTERN.h
+cop.o: av.h
+cop.o: config.h
+cop.o: cop.c
+cop.o: cop.h
+cop.o: embed.h
+cop.o: form.h
+cop.o: gv.h
+cop.o: handy.h
+cop.o: hv.h
+cop.o: op.h
+cop.o: opcode.h
+cop.o: perl.h
+cop.o: pp.h
+cop.o: proto.h
+cop.o: regexp.h
+cop.o: sv.h
+cop.o: unixish.h
+cop.o: util.h
+cons.o:
+cons.o: /usr/ucbinclude/ctype.h
+cons.o: /usr/ucbinclude/dirent.h
+cons.o: /usr/ucbinclude/errno.h
+cons.o: /usr/ucbinclude/machine/param.h
+cons.o: /usr/ucbinclude/machine/setjmp.h
+cons.o: /usr/ucbinclude/ndbm.h
+cons.o: /usr/ucbinclude/netinet/in.h
+cons.o: /usr/ucbinclude/setjmp.h
+cons.o: /usr/ucbinclude/stdio.h
+cons.o: /usr/ucbinclude/sys/dirent.h
+cons.o: /usr/ucbinclude/sys/errno.h
+cons.o: /usr/ucbinclude/sys/filio.h
+cons.o: /usr/ucbinclude/sys/ioccom.h
+cons.o: /usr/ucbinclude/sys/ioctl.h
+cons.o: /usr/ucbinclude/sys/param.h
+cons.o: /usr/ucbinclude/sys/signal.h
+cons.o: /usr/ucbinclude/sys/sockio.h
+cons.o: /usr/ucbinclude/sys/stat.h
+cons.o: /usr/ucbinclude/sys/stdtypes.h
+cons.o: /usr/ucbinclude/sys/sysmacros.h
+cons.o: /usr/ucbinclude/sys/time.h
+cons.o: /usr/ucbinclude/sys/times.h
+cons.o: /usr/ucbinclude/sys/ttold.h
+cons.o: /usr/ucbinclude/sys/ttychars.h
+cons.o: /usr/ucbinclude/sys/ttycom.h
+cons.o: /usr/ucbinclude/sys/ttydev.h
+cons.o: /usr/ucbinclude/sys/types.h
+cons.o: /usr/ucbinclude/time.h
+cons.o: /usr/ucbinclude/vm/faultcode.h
+cons.o: EXTERN.h
+cons.o: av.h
+cons.o: config.h
+cons.o: cons.c
+cons.o: cop.h
+cons.o: embed.h
+cons.o: form.h
+cons.o: gv.h
+cons.o: handy.h
+cons.o: hv.h
+cons.o: op.h
+cons.o: opcode.h
+cons.o: perl.h
+cons.o: perly.h
+cons.o: pp.h
+cons.o: proto.h
+cons.o: regexp.h
+cons.o: sv.h
+cons.o: unixish.h
+cons.o: util.h
+consop.o:
+consop.o: /usr/ucbinclude/ctype.h
+consop.o: /usr/ucbinclude/dirent.h
+consop.o: /usr/ucbinclude/errno.h
+consop.o: /usr/ucbinclude/machine/param.h
+consop.o: /usr/ucbinclude/machine/setjmp.h
+consop.o: /usr/ucbinclude/ndbm.h
+consop.o: /usr/ucbinclude/netinet/in.h
+consop.o: /usr/ucbinclude/setjmp.h
+consop.o: /usr/ucbinclude/stdio.h
+consop.o: /usr/ucbinclude/sys/dirent.h
+consop.o: /usr/ucbinclude/sys/errno.h
+consop.o: /usr/ucbinclude/sys/filio.h
+consop.o: /usr/ucbinclude/sys/ioccom.h
+consop.o: /usr/ucbinclude/sys/ioctl.h
+consop.o: /usr/ucbinclude/sys/param.h
+consop.o: /usr/ucbinclude/sys/signal.h
+consop.o: /usr/ucbinclude/sys/sockio.h
+consop.o: /usr/ucbinclude/sys/stat.h
+consop.o: /usr/ucbinclude/sys/stdtypes.h
+consop.o: /usr/ucbinclude/sys/sysmacros.h
+consop.o: /usr/ucbinclude/sys/time.h
+consop.o: /usr/ucbinclude/sys/times.h
+consop.o: /usr/ucbinclude/sys/ttold.h
+consop.o: /usr/ucbinclude/sys/ttychars.h
+consop.o: /usr/ucbinclude/sys/ttycom.h
+consop.o: /usr/ucbinclude/sys/ttydev.h
+consop.o: /usr/ucbinclude/sys/types.h
+consop.o: /usr/ucbinclude/time.h
+consop.o: /usr/ucbinclude/vm/faultcode.h
+consop.o: EXTERN.h
+consop.o: av.h
+consop.o: config.h
+consop.o: consop.c
+consop.o: cop.h
+consop.o: embed.h
+consop.o: form.h
+consop.o: gv.h
+consop.o: handy.h
+consop.o: hv.h
+consop.o: op.h
+consop.o: opcode.h
+consop.o: perl.h
+consop.o: pp.h
+consop.o: proto.h
+consop.o: regexp.h
+consop.o: sv.h
+consop.o: unixish.h
+consop.o: util.h
+scope.o: EXTERN.h
+scope.o: av.h
+scope.o: config.h
+scope.o: cop.h
+scope.o: doop.c
+scope.o: embed.h
+scope.o: form.h
+scope.o: gv.h
+scope.o: handy.h
+scope.o: hv.h
+scope.o: op.h
+scope.o: opcode.h
+scope.o: perl.h
+scope.o: pp.h
+scope.o: proto.h
+scope.o: regexp.h
+scope.o: sv.h
+scope.o: unixish.h
+scope.o: util.h
+op.o: EXTERN.h
+op.o: av.h
+op.o: config.h
+op.o: cop.h
+op.o: doop.c
+op.o: embed.h
+op.o: form.h
+op.o: gv.h
+op.o: handy.h
+op.o: hv.h
+op.o: op.h
+op.o: opcode.h
+op.o: perl.h
+op.o: pp.h
+op.o: proto.h
+op.o: regexp.h
+op.o: sv.h
+op.o: unixish.h
+op.o: util.h
+run.o: EXTERN.h
+run.o: av.h
+run.o: config.h
+run.o: cop.h
+run.o: doop.c
+run.o: embed.h
+run.o: form.h
+run.o: gv.h
+run.o: handy.h
+run.o: hv.h
+run.o: op.h
+run.o: opcode.h
+run.o: perl.h
+run.o: pp.h
+run.o: proto.h
+run.o: regexp.h
+run.o: sv.h
+run.o: unixish.h
+run.o: util.h
+deb.o: EXTERN.h
+deb.o: av.h
+deb.o: config.h
+deb.o: cop.h
+deb.o: doop.c
+deb.o: embed.h
+deb.o: form.h
+deb.o: gv.h
+deb.o: handy.h
+deb.o: hv.h
+deb.o: op.h
+deb.o: opcode.h
+deb.o: perl.h
+deb.o: pp.h
+deb.o: proto.h
+deb.o: regexp.h
+deb.o: sv.h
+deb.o: unixish.h
+deb.o: util.h
+doop.o:
+doop.o: /usr/ucbinclude/ctype.h
+doop.o: /usr/ucbinclude/dirent.h
+doop.o: /usr/ucbinclude/errno.h
+doop.o: /usr/ucbinclude/machine/param.h
+doop.o: /usr/ucbinclude/machine/setjmp.h
+doop.o: /usr/ucbinclude/ndbm.h
+doop.o: /usr/ucbinclude/netinet/in.h
+doop.o: /usr/ucbinclude/setjmp.h
+doop.o: /usr/ucbinclude/stdio.h
+doop.o: /usr/ucbinclude/sys/dirent.h
+doop.o: /usr/ucbinclude/sys/errno.h
+doop.o: /usr/ucbinclude/sys/filio.h
+doop.o: /usr/ucbinclude/sys/ioccom.h
+doop.o: /usr/ucbinclude/sys/ioctl.h
+doop.o: /usr/ucbinclude/sys/param.h
+doop.o: /usr/ucbinclude/sys/signal.h
+doop.o: /usr/ucbinclude/sys/sockio.h
+doop.o: /usr/ucbinclude/sys/stat.h
+doop.o: /usr/ucbinclude/sys/stdtypes.h
+doop.o: /usr/ucbinclude/sys/sysmacros.h
+doop.o: /usr/ucbinclude/sys/time.h
+doop.o: /usr/ucbinclude/sys/times.h
+doop.o: /usr/ucbinclude/sys/ttold.h
+doop.o: /usr/ucbinclude/sys/ttychars.h
+doop.o: /usr/ucbinclude/sys/ttycom.h
+doop.o: /usr/ucbinclude/sys/ttydev.h
+doop.o: /usr/ucbinclude/sys/types.h
+doop.o: /usr/ucbinclude/time.h
+doop.o: /usr/ucbinclude/vm/faultcode.h
+doop.o: EXTERN.h
+doop.o: av.h
+doop.o: config.h
+doop.o: cop.h
+doop.o: doop.c
+doop.o: embed.h
+doop.o: form.h
+doop.o: gv.h
+doop.o: handy.h
+doop.o: hv.h
+doop.o: op.h
+doop.o: opcode.h
+doop.o: perl.h
+doop.o: pp.h
+doop.o: proto.h
+doop.o: regexp.h
+doop.o: sv.h
+doop.o: unixish.h
+doop.o: util.h
+doio.o:
+doio.o: /usr/ucbinclude/ctype.h
+doio.o: /usr/ucbinclude/debug/debug.h
+doio.o: /usr/ucbinclude/dirent.h
+doio.o: /usr/ucbinclude/errno.h
+doio.o: /usr/ucbinclude/machine/mmu.h
+doio.o: /usr/ucbinclude/machine/param.h
+doio.o: /usr/ucbinclude/machine/setjmp.h
+doio.o: /usr/ucbinclude/mon/obpdefs.h
+doio.o: /usr/ucbinclude/mon/openprom.h
+doio.o: /usr/ucbinclude/mon/sunromvec.h
+doio.o: /usr/ucbinclude/ndbm.h
+doio.o: /usr/ucbinclude/netinet/in.h
+doio.o: /usr/ucbinclude/setjmp.h
+doio.o: /usr/ucbinclude/stdio.h
+doio.o: /usr/ucbinclude/sys/dirent.h
+doio.o: /usr/ucbinclude/sys/errno.h
+doio.o: /usr/ucbinclude/sys/fcntlcom.h
+doio.o: /usr/ucbinclude/sys/file.h
+doio.o: /usr/ucbinclude/sys/filio.h
+doio.o: /usr/ucbinclude/sys/ioccom.h
+doio.o: /usr/ucbinclude/sys/ioctl.h
+doio.o: /usr/ucbinclude/sys/ipc.h
+doio.o: /usr/ucbinclude/sys/msg.h
+doio.o: /usr/ucbinclude/sys/param.h
+doio.o: /usr/ucbinclude/sys/sem.h
+doio.o: /usr/ucbinclude/sys/shm.h
+doio.o: /usr/ucbinclude/sys/signal.h
+doio.o: /usr/ucbinclude/sys/sockio.h
+doio.o: /usr/ucbinclude/sys/stat.h
+doio.o: /usr/ucbinclude/sys/stdtypes.h
+doio.o: /usr/ucbinclude/sys/sysmacros.h
+doio.o: /usr/ucbinclude/sys/time.h
+doio.o: /usr/ucbinclude/sys/times.h
+doio.o: /usr/ucbinclude/sys/ttold.h
+doio.o: /usr/ucbinclude/sys/ttychars.h
+doio.o: /usr/ucbinclude/sys/ttycom.h
+doio.o: /usr/ucbinclude/sys/ttydev.h
+doio.o: /usr/ucbinclude/sys/types.h
+doio.o: /usr/ucbinclude/time.h
+doio.o: /usr/ucbinclude/utime.h
+doio.o: /usr/ucbinclude/vm/faultcode.h
+doio.o: EXTERN.h
+doio.o: av.h
+doio.o: config.h
+doio.o: cop.h
+doio.o: doio.c
+doio.o: embed.h
+doio.o: form.h
+doio.o: gv.h
+doio.o: handy.h
+doio.o: hv.h
+doio.o: op.h
+doio.o: opcode.h
+doio.o: perl.h
+doio.o: pp.h
+doio.o: proto.h
+doio.o: regexp.h
+doio.o: sv.h
+doio.o: unixish.h
+doio.o: util.h
+dolist.o:
+dolist.o: /usr/ucbinclude/ctype.h
+dolist.o: /usr/ucbinclude/dirent.h
+dolist.o: /usr/ucbinclude/errno.h
+dolist.o: /usr/ucbinclude/machine/param.h
+dolist.o: /usr/ucbinclude/machine/setjmp.h
+dolist.o: /usr/ucbinclude/ndbm.h
+dolist.o: /usr/ucbinclude/netinet/in.h
+dolist.o: /usr/ucbinclude/setjmp.h
+dolist.o: /usr/ucbinclude/stdio.h
+dolist.o: /usr/ucbinclude/sys/dirent.h
+dolist.o: /usr/ucbinclude/sys/errno.h
+dolist.o: /usr/ucbinclude/sys/filio.h
+dolist.o: /usr/ucbinclude/sys/ioccom.h
+dolist.o: /usr/ucbinclude/sys/ioctl.h
+dolist.o: /usr/ucbinclude/sys/param.h
+dolist.o: /usr/ucbinclude/sys/signal.h
+dolist.o: /usr/ucbinclude/sys/sockio.h
+dolist.o: /usr/ucbinclude/sys/stat.h
+dolist.o: /usr/ucbinclude/sys/stdtypes.h
+dolist.o: /usr/ucbinclude/sys/sysmacros.h
+dolist.o: /usr/ucbinclude/sys/time.h
+dolist.o: /usr/ucbinclude/sys/times.h
+dolist.o: /usr/ucbinclude/sys/ttold.h
+dolist.o: /usr/ucbinclude/sys/ttychars.h
+dolist.o: /usr/ucbinclude/sys/ttycom.h
+dolist.o: /usr/ucbinclude/sys/ttydev.h
+dolist.o: /usr/ucbinclude/sys/types.h
+dolist.o: /usr/ucbinclude/time.h
+dolist.o: /usr/ucbinclude/vm/faultcode.h
+dolist.o: EXTERN.h
+dolist.o: av.h
+dolist.o: config.h
+dolist.o: cop.h
+dolist.o: dolist.c
+dolist.o: embed.h
+dolist.o: form.h
+dolist.o: gv.h
+dolist.o: handy.h
+dolist.o: hv.h
+dolist.o: op.h
+dolist.o: opcode.h
+dolist.o: perl.h
+dolist.o: pp.h
+dolist.o: proto.h
+dolist.o: regexp.h
+dolist.o: sv.h
+dolist.o: unixish.h
+dolist.o: util.h
+dump.o:
+dump.o: /usr/ucbinclude/ctype.h
+dump.o: /usr/ucbinclude/dirent.h
+dump.o: /usr/ucbinclude/errno.h
+dump.o: /usr/ucbinclude/machine/param.h
+dump.o: /usr/ucbinclude/machine/setjmp.h
+dump.o: /usr/ucbinclude/ndbm.h
+dump.o: /usr/ucbinclude/netinet/in.h
+dump.o: /usr/ucbinclude/setjmp.h
+dump.o: /usr/ucbinclude/stdio.h
+dump.o: /usr/ucbinclude/sys/dirent.h
+dump.o: /usr/ucbinclude/sys/errno.h
+dump.o: /usr/ucbinclude/sys/filio.h
+dump.o: /usr/ucbinclude/sys/ioccom.h
+dump.o: /usr/ucbinclude/sys/ioctl.h
+dump.o: /usr/ucbinclude/sys/param.h
+dump.o: /usr/ucbinclude/sys/signal.h
+dump.o: /usr/ucbinclude/sys/sockio.h
+dump.o: /usr/ucbinclude/sys/stat.h
+dump.o: /usr/ucbinclude/sys/stdtypes.h
+dump.o: /usr/ucbinclude/sys/sysmacros.h
+dump.o: /usr/ucbinclude/sys/time.h
+dump.o: /usr/ucbinclude/sys/times.h
+dump.o: /usr/ucbinclude/sys/ttold.h
+dump.o: /usr/ucbinclude/sys/ttychars.h
+dump.o: /usr/ucbinclude/sys/ttycom.h
+dump.o: /usr/ucbinclude/sys/ttydev.h
+dump.o: /usr/ucbinclude/sys/types.h
+dump.o: /usr/ucbinclude/time.h
+dump.o: /usr/ucbinclude/vm/faultcode.h
+dump.o: EXTERN.h
+dump.o: av.h
+dump.o: config.h
+dump.o: cop.h
+dump.o: dump.c
+dump.o: embed.h
+dump.o: form.h
+dump.o: gv.h
+dump.o: handy.h
+dump.o: hv.h
+dump.o: op.h
+dump.o: opcode.h
+dump.o: perl.h
+dump.o: pp.h
+dump.o: proto.h
+dump.o: regexp.h
+dump.o: sv.h
+dump.o: unixish.h
+dump.o: util.h
+eval.o:
+eval.o: /usr/ucbinclude/ctype.h
+eval.o: /usr/ucbinclude/dirent.h
+eval.o: /usr/ucbinclude/errno.h
+eval.o: /usr/ucbinclude/machine/param.h
+eval.o: /usr/ucbinclude/machine/setjmp.h
+eval.o: /usr/ucbinclude/ndbm.h
+eval.o: /usr/ucbinclude/netinet/in.h
+eval.o: /usr/ucbinclude/setjmp.h
+eval.o: /usr/ucbinclude/stdio.h
+eval.o: /usr/ucbinclude/sys/dirent.h
+eval.o: /usr/ucbinclude/sys/errno.h
+eval.o: /usr/ucbinclude/sys/fcntlcom.h
+eval.o: /usr/ucbinclude/sys/file.h
+eval.o: /usr/ucbinclude/sys/filio.h
+eval.o: /usr/ucbinclude/sys/ioccom.h
+eval.o: /usr/ucbinclude/sys/ioctl.h
+eval.o: /usr/ucbinclude/sys/param.h
+eval.o: /usr/ucbinclude/sys/signal.h
+eval.o: /usr/ucbinclude/sys/sockio.h
+eval.o: /usr/ucbinclude/sys/stat.h
+eval.o: /usr/ucbinclude/sys/stdtypes.h
+eval.o: /usr/ucbinclude/sys/sysmacros.h
+eval.o: /usr/ucbinclude/sys/time.h
+eval.o: /usr/ucbinclude/sys/times.h
+eval.o: /usr/ucbinclude/sys/ttold.h
+eval.o: /usr/ucbinclude/sys/ttychars.h
+eval.o: /usr/ucbinclude/sys/ttycom.h
+eval.o: /usr/ucbinclude/sys/ttydev.h
+eval.o: /usr/ucbinclude/sys/types.h
+eval.o: /usr/ucbinclude/time.h
+eval.o: /usr/ucbinclude/vfork.h
+eval.o: /usr/ucbinclude/vm/faultcode.h
+eval.o: EXTERN.h
+eval.o: av.h
+eval.o: config.h
+eval.o: cop.h
+eval.o: embed.h
+eval.o: eval.c
+eval.o: form.h
+eval.o: gv.h
+eval.o: handy.h
+eval.o: hv.h
+eval.o: op.h
+eval.o: opcode.h
+eval.o: perl.h
+eval.o: pp.h
+eval.o: proto.h
+eval.o: regexp.h
+eval.o: sv.h
+eval.o: unixish.h
+eval.o: util.h
+hv.o:
+hv.o: /usr/ucbinclude/ctype.h
+hv.o: /usr/ucbinclude/dirent.h
+hv.o: /usr/ucbinclude/errno.h
+hv.o: /usr/ucbinclude/machine/param.h
+hv.o: /usr/ucbinclude/machine/setjmp.h
+hv.o: /usr/ucbinclude/ndbm.h
+hv.o: /usr/ucbinclude/netinet/in.h
+hv.o: /usr/ucbinclude/setjmp.h
+hv.o: /usr/ucbinclude/stdio.h
+hv.o: /usr/ucbinclude/sys/dirent.h
+hv.o: /usr/ucbinclude/sys/errno.h
+hv.o: /usr/ucbinclude/sys/fcntlcom.h
+hv.o: /usr/ucbinclude/sys/file.h
+hv.o: /usr/ucbinclude/sys/filio.h
+hv.o: /usr/ucbinclude/sys/ioccom.h
+hv.o: /usr/ucbinclude/sys/ioctl.h
+hv.o: /usr/ucbinclude/sys/param.h
+hv.o: /usr/ucbinclude/sys/signal.h
+hv.o: /usr/ucbinclude/sys/sockio.h
+hv.o: /usr/ucbinclude/sys/stat.h
+hv.o: /usr/ucbinclude/sys/stdtypes.h
+hv.o: /usr/ucbinclude/sys/sysmacros.h
+hv.o: /usr/ucbinclude/sys/time.h
+hv.o: /usr/ucbinclude/sys/times.h
+hv.o: /usr/ucbinclude/sys/ttold.h
+hv.o: /usr/ucbinclude/sys/ttychars.h
+hv.o: /usr/ucbinclude/sys/ttycom.h
+hv.o: /usr/ucbinclude/sys/ttydev.h
+hv.o: /usr/ucbinclude/sys/types.h
+hv.o: /usr/ucbinclude/time.h
+hv.o: /usr/ucbinclude/vm/faultcode.h
+hv.o: EXTERN.h
+hv.o: av.h
+hv.o: config.h
+hv.o: cop.h
+hv.o: embed.h
+hv.o: form.h
+hv.o: gv.h
+hv.o: handy.h
+hv.o: hv.c
+hv.o: hv.h
+hv.o: op.h
+hv.o: opcode.h
+hv.o: perl.h
+hv.o: pp.h
+hv.o: proto.h
+hv.o: regexp.h
+hv.o: sv.h
+hv.o: unixish.h
+hv.o: util.h
+main.o:
+main.o: /usr/ucbinclude/ctype.h
+main.o: /usr/ucbinclude/dirent.h
+main.o: /usr/ucbinclude/errno.h
+main.o: /usr/ucbinclude/machine/param.h
+main.o: /usr/ucbinclude/machine/setjmp.h
+main.o: /usr/ucbinclude/ndbm.h
+main.o: /usr/ucbinclude/netinet/in.h
+main.o: /usr/ucbinclude/setjmp.h
+main.o: /usr/ucbinclude/stdio.h
+main.o: /usr/ucbinclude/sys/dirent.h
+main.o: /usr/ucbinclude/sys/errno.h
+main.o: /usr/ucbinclude/sys/filio.h
+main.o: /usr/ucbinclude/sys/ioccom.h
+main.o: /usr/ucbinclude/sys/ioctl.h
+main.o: /usr/ucbinclude/sys/param.h
+main.o: /usr/ucbinclude/sys/signal.h
+main.o: /usr/ucbinclude/sys/sockio.h
+main.o: /usr/ucbinclude/sys/stat.h
+main.o: /usr/ucbinclude/sys/stdtypes.h
+main.o: /usr/ucbinclude/sys/sysmacros.h
+main.o: /usr/ucbinclude/sys/time.h
+main.o: /usr/ucbinclude/sys/times.h
+main.o: /usr/ucbinclude/sys/ttold.h
+main.o: /usr/ucbinclude/sys/ttychars.h
+main.o: /usr/ucbinclude/sys/ttycom.h
+main.o: /usr/ucbinclude/sys/ttydev.h
+main.o: /usr/ucbinclude/sys/types.h
+main.o: /usr/ucbinclude/time.h
+main.o: /usr/ucbinclude/vm/faultcode.h
+main.o: INTERN.h
+main.o: av.h
+main.o: config.h
+main.o: cop.h
+main.o: embed.h
+main.o: form.h
+main.o: gv.h
+main.o: handy.h
+main.o: hv.h
+main.o: main.c
+main.o: op.h
+main.o: opcode.h
+main.o: perl.h
+main.o: pp.h
+main.o: proto.h
+main.o: regexp.h
+main.o: sv.h
+main.o: unixish.h
+main.o: util.h
+malloc.o:
+malloc.o: /usr/ucbinclude/ctype.h
+malloc.o: /usr/ucbinclude/dirent.h
+malloc.o: /usr/ucbinclude/errno.h
+malloc.o: /usr/ucbinclude/machine/param.h
+malloc.o: /usr/ucbinclude/machine/setjmp.h
+malloc.o: /usr/ucbinclude/ndbm.h
+malloc.o: /usr/ucbinclude/netinet/in.h
+malloc.o: /usr/ucbinclude/setjmp.h
+malloc.o: /usr/ucbinclude/stdio.h
+malloc.o: /usr/ucbinclude/sys/dirent.h
+malloc.o: /usr/ucbinclude/sys/errno.h
+malloc.o: /usr/ucbinclude/sys/filio.h
+malloc.o: /usr/ucbinclude/sys/ioccom.h
+malloc.o: /usr/ucbinclude/sys/ioctl.h
+malloc.o: /usr/ucbinclude/sys/param.h
+malloc.o: /usr/ucbinclude/sys/signal.h
+malloc.o: /usr/ucbinclude/sys/sockio.h
+malloc.o: /usr/ucbinclude/sys/stat.h
+malloc.o: /usr/ucbinclude/sys/stdtypes.h
+malloc.o: /usr/ucbinclude/sys/sysmacros.h
+malloc.o: /usr/ucbinclude/sys/time.h
+malloc.o: /usr/ucbinclude/sys/times.h
+malloc.o: /usr/ucbinclude/sys/ttold.h
+malloc.o: /usr/ucbinclude/sys/ttychars.h
+malloc.o: /usr/ucbinclude/sys/ttycom.h
+malloc.o: /usr/ucbinclude/sys/ttydev.h
+malloc.o: /usr/ucbinclude/sys/types.h
+malloc.o: /usr/ucbinclude/time.h
+malloc.o: /usr/ucbinclude/vm/faultcode.h
+malloc.o: EXTERN.h
+malloc.o: av.h
+malloc.o: config.h
+malloc.o: cop.h
+malloc.o: embed.h
+malloc.o: form.h
+malloc.o: gv.h
+malloc.o: handy.h
+malloc.o: hv.h
+malloc.o: malloc.c
+malloc.o: op.h
+malloc.o: opcode.h
+malloc.o: perl.h
+malloc.o: pp.h
+malloc.o: proto.h
+malloc.o: regexp.h
+malloc.o: sv.h
+malloc.o: unixish.h
+malloc.o: util.h
+perl.o:
+perl.o: /usr/ucbinclude/ctype.h
+perl.o: /usr/ucbinclude/dirent.h
+perl.o: /usr/ucbinclude/errno.h
+perl.o: /usr/ucbinclude/machine/param.h
+perl.o: /usr/ucbinclude/machine/setjmp.h
+perl.o: /usr/ucbinclude/ndbm.h
+perl.o: /usr/ucbinclude/netinet/in.h
+perl.o: /usr/ucbinclude/setjmp.h
+perl.o: /usr/ucbinclude/stdio.h
+perl.o: /usr/ucbinclude/sys/dirent.h
+perl.o: /usr/ucbinclude/sys/errno.h
+perl.o: /usr/ucbinclude/sys/filio.h
+perl.o: /usr/ucbinclude/sys/ioccom.h
+perl.o: /usr/ucbinclude/sys/ioctl.h
+perl.o: /usr/ucbinclude/sys/param.h
+perl.o: /usr/ucbinclude/sys/signal.h
+perl.o: /usr/ucbinclude/sys/sockio.h
+perl.o: /usr/ucbinclude/sys/stat.h
+perl.o: /usr/ucbinclude/sys/stdtypes.h
+perl.o: /usr/ucbinclude/sys/sysmacros.h
+perl.o: /usr/ucbinclude/sys/time.h
+perl.o: /usr/ucbinclude/sys/times.h
+perl.o: /usr/ucbinclude/sys/ttold.h
+perl.o: /usr/ucbinclude/sys/ttychars.h
+perl.o: /usr/ucbinclude/sys/ttycom.h
+perl.o: /usr/ucbinclude/sys/ttydev.h
+perl.o: /usr/ucbinclude/sys/types.h
+perl.o: /usr/ucbinclude/time.h
+perl.o: /usr/ucbinclude/vm/faultcode.h
+perl.o: EXTERN.h
+perl.o: av.h
+perl.o: config.h
+perl.o: cop.h
+perl.o: embed.h
+perl.o: form.h
+perl.o: gv.h
+perl.o: handy.h
+perl.o: hv.h
+perl.o: op.h
+perl.o: opcode.h
+perl.o: patchlevel.h
+perl.o: perl.c
+perl.o: perl.h
+perl.o: perly.h
+perl.o: pp.h
+perl.o: proto.h
+perl.o: regexp.h
+perl.o: sv.h
+perl.o: unixish.h
+perl.o: util.h
+pp.o:
+pp.o: /usr/ucbinclude/ctype.h
+pp.o: /usr/ucbinclude/dirent.h
+pp.o: /usr/ucbinclude/errno.h
+pp.o: /usr/ucbinclude/grp.h
+pp.o: /usr/ucbinclude/machine/param.h
+pp.o: /usr/ucbinclude/machine/setjmp.h
+pp.o: /usr/ucbinclude/ndbm.h
+pp.o: /usr/ucbinclude/netdb.h
+pp.o: /usr/ucbinclude/netinet/in.h
+pp.o: /usr/ucbinclude/pwd.h
+pp.o: /usr/ucbinclude/setjmp.h
+pp.o: /usr/ucbinclude/stdio.h
+pp.o: /usr/ucbinclude/sys/dirent.h
+pp.o: /usr/ucbinclude/sys/errno.h
+pp.o: /usr/ucbinclude/sys/fcntlcom.h
+pp.o: /usr/ucbinclude/sys/file.h
+pp.o: /usr/ucbinclude/sys/filio.h
+pp.o: /usr/ucbinclude/sys/ioccom.h
+pp.o: /usr/ucbinclude/sys/ioctl.h
+pp.o: /usr/ucbinclude/sys/param.h
+pp.o: /usr/ucbinclude/sys/signal.h
+pp.o: /usr/ucbinclude/sys/socket.h
+pp.o: /usr/ucbinclude/sys/sockio.h
+pp.o: /usr/ucbinclude/sys/stat.h
+pp.o: /usr/ucbinclude/sys/stdtypes.h
+pp.o: /usr/ucbinclude/sys/sysmacros.h
+pp.o: /usr/ucbinclude/sys/time.h
+pp.o: /usr/ucbinclude/sys/times.h
+pp.o: /usr/ucbinclude/sys/ttold.h
+pp.o: /usr/ucbinclude/sys/ttychars.h
+pp.o: /usr/ucbinclude/sys/ttycom.h
+pp.o: /usr/ucbinclude/sys/ttydev.h
+pp.o: /usr/ucbinclude/sys/types.h
+pp.o: /usr/ucbinclude/time.h
+pp.o: /usr/ucbinclude/utime.h
+pp.o: /usr/ucbinclude/vm/faultcode.h
+pp.o: EXTERN.h
+pp.o: av.h
+pp.o: config.h
+pp.o: cop.h
+pp.o: embed.h
+pp.o: form.h
+pp.o: gv.h
+pp.o: handy.h
+pp.o: hv.h
+pp.o: op.h
+pp.o: opcode.h
+pp.o: perl.h
+pp.o: pp.c
+pp.o: pp.h
+pp.o: proto.h
+pp.o: regexp.h
+pp.o: sv.h
+pp.o: unixish.h
+pp.o: util.h
+regcomp.o:
+regcomp.o: /usr/ucbinclude/ctype.h
+regcomp.o: /usr/ucbinclude/dirent.h
+regcomp.o: /usr/ucbinclude/errno.h
+regcomp.o: /usr/ucbinclude/machine/param.h
+regcomp.o: /usr/ucbinclude/machine/setjmp.h
+regcomp.o: /usr/ucbinclude/ndbm.h
+regcomp.o: /usr/ucbinclude/netinet/in.h
+regcomp.o: /usr/ucbinclude/setjmp.h
+regcomp.o: /usr/ucbinclude/stdio.h
+regcomp.o: /usr/ucbinclude/sys/dirent.h
+regcomp.o: /usr/ucbinclude/sys/errno.h
+regcomp.o: /usr/ucbinclude/sys/filio.h
+regcomp.o: /usr/ucbinclude/sys/ioccom.h
+regcomp.o: /usr/ucbinclude/sys/ioctl.h
+regcomp.o: /usr/ucbinclude/sys/param.h
+regcomp.o: /usr/ucbinclude/sys/signal.h
+regcomp.o: /usr/ucbinclude/sys/sockio.h
+regcomp.o: /usr/ucbinclude/sys/stat.h
+regcomp.o: /usr/ucbinclude/sys/stdtypes.h
+regcomp.o: /usr/ucbinclude/sys/sysmacros.h
+regcomp.o: /usr/ucbinclude/sys/time.h
+regcomp.o: /usr/ucbinclude/sys/times.h
+regcomp.o: /usr/ucbinclude/sys/ttold.h
+regcomp.o: /usr/ucbinclude/sys/ttychars.h
+regcomp.o: /usr/ucbinclude/sys/ttycom.h
+regcomp.o: /usr/ucbinclude/sys/ttydev.h
+regcomp.o: /usr/ucbinclude/sys/types.h
+regcomp.o: /usr/ucbinclude/time.h
+regcomp.o: /usr/ucbinclude/vm/faultcode.h
+regcomp.o: EXTERN.h
+regcomp.o: INTERN.h
+regcomp.o: av.h
+regcomp.o: config.h
+regcomp.o: cop.h
+regcomp.o: embed.h
+regcomp.o: form.h
+regcomp.o: gv.h
+regcomp.o: handy.h
+regcomp.o: hv.h
+regcomp.o: op.h
+regcomp.o: opcode.h
+regcomp.o: perl.h
+regcomp.o: pp.h
+regcomp.o: proto.h
+regcomp.o: regcomp.c
+regcomp.o: regcomp.h
+regcomp.o: regexp.h
+regcomp.o: sv.h
+regcomp.o: unixish.h
+regcomp.o: util.h
+regexec.o:
+regexec.o: /usr/ucbinclude/ctype.h
+regexec.o: /usr/ucbinclude/dirent.h
+regexec.o: /usr/ucbinclude/errno.h
+regexec.o: /usr/ucbinclude/machine/param.h
+regexec.o: /usr/ucbinclude/machine/setjmp.h
+regexec.o: /usr/ucbinclude/ndbm.h
+regexec.o: /usr/ucbinclude/netinet/in.h
+regexec.o: /usr/ucbinclude/setjmp.h
+regexec.o: /usr/ucbinclude/stdio.h
+regexec.o: /usr/ucbinclude/sys/dirent.h
+regexec.o: /usr/ucbinclude/sys/errno.h
+regexec.o: /usr/ucbinclude/sys/filio.h
+regexec.o: /usr/ucbinclude/sys/ioccom.h
+regexec.o: /usr/ucbinclude/sys/ioctl.h
+regexec.o: /usr/ucbinclude/sys/param.h
+regexec.o: /usr/ucbinclude/sys/signal.h
+regexec.o: /usr/ucbinclude/sys/sockio.h
+regexec.o: /usr/ucbinclude/sys/stat.h
+regexec.o: /usr/ucbinclude/sys/stdtypes.h
+regexec.o: /usr/ucbinclude/sys/sysmacros.h
+regexec.o: /usr/ucbinclude/sys/time.h
+regexec.o: /usr/ucbinclude/sys/times.h
+regexec.o: /usr/ucbinclude/sys/ttold.h
+regexec.o: /usr/ucbinclude/sys/ttychars.h
+regexec.o: /usr/ucbinclude/sys/ttycom.h
+regexec.o: /usr/ucbinclude/sys/ttydev.h
+regexec.o: /usr/ucbinclude/sys/types.h
+regexec.o: /usr/ucbinclude/time.h
+regexec.o: /usr/ucbinclude/vm/faultcode.h
+regexec.o: EXTERN.h
+regexec.o: av.h
+regexec.o: config.h
+regexec.o: cop.h
+regexec.o: embed.h
+regexec.o: form.h
+regexec.o: gv.h
+regexec.o: handy.h
+regexec.o: hv.h
+regexec.o: op.h
+regexec.o: opcode.h
+regexec.o: perl.h
+regexec.o: pp.h
+regexec.o: proto.h
+regexec.o: regcomp.h
+regexec.o: regexec.c
+regexec.o: regexp.h
+regexec.o: sv.h
+regexec.o: unixish.h
+regexec.o: util.h
+gv.o:
+gv.o: /usr/ucbinclude/ctype.h
+gv.o: /usr/ucbinclude/dirent.h
+gv.o: /usr/ucbinclude/errno.h
+gv.o: /usr/ucbinclude/machine/param.h
+gv.o: /usr/ucbinclude/machine/setjmp.h
+gv.o: /usr/ucbinclude/ndbm.h
+gv.o: /usr/ucbinclude/netinet/in.h
+gv.o: /usr/ucbinclude/setjmp.h
+gv.o: /usr/ucbinclude/stdio.h
+gv.o: /usr/ucbinclude/sys/dirent.h
+gv.o: /usr/ucbinclude/sys/errno.h
+gv.o: /usr/ucbinclude/sys/filio.h
+gv.o: /usr/ucbinclude/sys/ioccom.h
+gv.o: /usr/ucbinclude/sys/ioctl.h
+gv.o: /usr/ucbinclude/sys/param.h
+gv.o: /usr/ucbinclude/sys/signal.h
+gv.o: /usr/ucbinclude/sys/sockio.h
+gv.o: /usr/ucbinclude/sys/stat.h
+gv.o: /usr/ucbinclude/sys/stdtypes.h
+gv.o: /usr/ucbinclude/sys/sysmacros.h
+gv.o: /usr/ucbinclude/sys/time.h
+gv.o: /usr/ucbinclude/sys/times.h
+gv.o: /usr/ucbinclude/sys/ttold.h
+gv.o: /usr/ucbinclude/sys/ttychars.h
+gv.o: /usr/ucbinclude/sys/ttycom.h
+gv.o: /usr/ucbinclude/sys/ttydev.h
+gv.o: /usr/ucbinclude/sys/types.h
+gv.o: /usr/ucbinclude/time.h
+gv.o: /usr/ucbinclude/vm/faultcode.h
+gv.o: EXTERN.h
+gv.o: av.h
+gv.o: config.h
+gv.o: cop.h
+gv.o: embed.h
+gv.o: form.h
+gv.o: gv.c
+gv.o: gv.h
+gv.o: handy.h
+gv.o: hv.h
+gv.o: op.h
+gv.o: opcode.h
+gv.o: perl.h
+gv.o: pp.h
+gv.o: proto.h
+gv.o: regexp.h
+gv.o: sv.h
+gv.o: unixish.h
+gv.o: util.h
+sv.o:
+sv.o: /usr/ucbinclude/ctype.h
+sv.o: /usr/ucbinclude/dirent.h
+sv.o: /usr/ucbinclude/errno.h
+sv.o: /usr/ucbinclude/machine/param.h
+sv.o: /usr/ucbinclude/machine/setjmp.h
+sv.o: /usr/ucbinclude/ndbm.h
+sv.o: /usr/ucbinclude/netinet/in.h
+sv.o: /usr/ucbinclude/setjmp.h
+sv.o: /usr/ucbinclude/stdio.h
+sv.o: /usr/ucbinclude/sys/dirent.h
+sv.o: /usr/ucbinclude/sys/errno.h
+sv.o: /usr/ucbinclude/sys/filio.h
+sv.o: /usr/ucbinclude/sys/ioccom.h
+sv.o: /usr/ucbinclude/sys/ioctl.h
+sv.o: /usr/ucbinclude/sys/param.h
+sv.o: /usr/ucbinclude/sys/signal.h
+sv.o: /usr/ucbinclude/sys/sockio.h
+sv.o: /usr/ucbinclude/sys/stat.h
+sv.o: /usr/ucbinclude/sys/stdtypes.h
+sv.o: /usr/ucbinclude/sys/sysmacros.h
+sv.o: /usr/ucbinclude/sys/time.h
+sv.o: /usr/ucbinclude/sys/times.h
+sv.o: /usr/ucbinclude/sys/ttold.h
+sv.o: /usr/ucbinclude/sys/ttychars.h
+sv.o: /usr/ucbinclude/sys/ttycom.h
+sv.o: /usr/ucbinclude/sys/ttydev.h
+sv.o: /usr/ucbinclude/sys/types.h
+sv.o: /usr/ucbinclude/time.h
+sv.o: /usr/ucbinclude/vm/faultcode.h
+sv.o: EXTERN.h
+sv.o: av.h
+sv.o: config.h
+sv.o: cop.h
+sv.o: embed.h
+sv.o: form.h
+sv.o: gv.h
+sv.o: handy.h
+sv.o: hv.h
+sv.o: op.h
+sv.o: opcode.h
+sv.o: perl.h
+sv.o: perly.h
+sv.o: pp.h
+sv.o: proto.h
+sv.o: regexp.h
+sv.o: sv.c
+sv.o: sv.h
+sv.o: unixish.h
+sv.o: util.h
+toke.o:
+toke.o: /usr/ucbinclude/ctype.h
+toke.o: /usr/ucbinclude/dirent.h
+toke.o: /usr/ucbinclude/errno.h
+toke.o: /usr/ucbinclude/machine/param.h
+toke.o: /usr/ucbinclude/machine/setjmp.h
+toke.o: /usr/ucbinclude/ndbm.h
+toke.o: /usr/ucbinclude/netinet/in.h
+toke.o: /usr/ucbinclude/setjmp.h
+toke.o: /usr/ucbinclude/stdio.h
+toke.o: /usr/ucbinclude/sys/dirent.h
+toke.o: /usr/ucbinclude/sys/errno.h
+toke.o: /usr/ucbinclude/sys/fcntlcom.h
+toke.o: /usr/ucbinclude/sys/file.h
+toke.o: /usr/ucbinclude/sys/filio.h
+toke.o: /usr/ucbinclude/sys/ioccom.h
+toke.o: /usr/ucbinclude/sys/ioctl.h
+toke.o: /usr/ucbinclude/sys/param.h
+toke.o: /usr/ucbinclude/sys/signal.h
+toke.o: /usr/ucbinclude/sys/sockio.h
+toke.o: /usr/ucbinclude/sys/stat.h
+toke.o: /usr/ucbinclude/sys/stdtypes.h
+toke.o: /usr/ucbinclude/sys/sysmacros.h
+toke.o: /usr/ucbinclude/sys/time.h
+toke.o: /usr/ucbinclude/sys/times.h
+toke.o: /usr/ucbinclude/sys/ttold.h
+toke.o: /usr/ucbinclude/sys/ttychars.h
+toke.o: /usr/ucbinclude/sys/ttycom.h
+toke.o: /usr/ucbinclude/sys/ttydev.h
+toke.o: /usr/ucbinclude/sys/types.h
+toke.o: /usr/ucbinclude/time.h
+toke.o: /usr/ucbinclude/vm/faultcode.h
+toke.o: EXTERN.h
+toke.o: av.h
+toke.o: config.h
+toke.o: cop.h
+toke.o: embed.h
+toke.o: form.h
+toke.o: gv.h
+toke.o: handy.h
+toke.o: hv.h
+toke.o: keywords.h
+toke.o: op.h
+toke.o: opcode.h
+toke.o: perl.h
+toke.o: perly.h
+toke.o: pp.h
+toke.o: proto.h
+toke.o: regexp.h
+toke.o: sv.h
+toke.o: toke.c
+toke.o: unixish.h
+toke.o: util.h
+util.o:
+util.o: /usr/ucbinclude/ctype.h
+util.o: /usr/ucbinclude/dirent.h
+util.o: /usr/ucbinclude/errno.h
+util.o: /usr/ucbinclude/machine/param.h
+util.o: /usr/ucbinclude/machine/setjmp.h
+util.o: /usr/ucbinclude/ndbm.h
+util.o: /usr/ucbinclude/netinet/in.h
+util.o: /usr/ucbinclude/setjmp.h
+util.o: /usr/ucbinclude/stdio.h
+util.o: /usr/ucbinclude/sys/dirent.h
+util.o: /usr/ucbinclude/sys/errno.h
+util.o: /usr/ucbinclude/sys/fcntlcom.h
+util.o: /usr/ucbinclude/sys/file.h
+util.o: /usr/ucbinclude/sys/filio.h
+util.o: /usr/ucbinclude/sys/ioccom.h
+util.o: /usr/ucbinclude/sys/ioctl.h
+util.o: /usr/ucbinclude/sys/param.h
+util.o: /usr/ucbinclude/sys/signal.h
+util.o: /usr/ucbinclude/sys/sockio.h
+util.o: /usr/ucbinclude/sys/stat.h
+util.o: /usr/ucbinclude/sys/stdtypes.h
+util.o: /usr/ucbinclude/sys/sysmacros.h
+util.o: /usr/ucbinclude/sys/time.h
+util.o: /usr/ucbinclude/sys/times.h
+util.o: /usr/ucbinclude/sys/ttold.h
+util.o: /usr/ucbinclude/sys/ttychars.h
+util.o: /usr/ucbinclude/sys/ttycom.h
+util.o: /usr/ucbinclude/sys/ttydev.h
+util.o: /usr/ucbinclude/sys/types.h
+util.o: /usr/ucbinclude/time.h
+util.o: /usr/ucbinclude/varargs.h
+util.o: /usr/ucbinclude/vfork.h
+util.o: /usr/ucbinclude/vm/faultcode.h
+util.o: EXTERN.h
+util.o: av.h
+util.o: config.h
+util.o: cop.h
+util.o: embed.h
+util.o: form.h
+util.o: gv.h
+util.o: handy.h
+util.o: hv.h
+util.o: op.h
+util.o: opcode.h
+util.o: perl.h
+util.o: pp.h
+util.o: proto.h
+util.o: regexp.h
+util.o: sv.h
+util.o: unixish.h
+util.o: util.c
+util.o: util.h
+usersub.o:
+usersub.o: /usr/ucbinclude/ctype.h
+usersub.o: /usr/ucbinclude/dirent.h
+usersub.o: /usr/ucbinclude/errno.h
+usersub.o: /usr/ucbinclude/machine/param.h
+usersub.o: /usr/ucbinclude/machine/setjmp.h
+usersub.o: /usr/ucbinclude/ndbm.h
+usersub.o: /usr/ucbinclude/netinet/in.h
+usersub.o: /usr/ucbinclude/setjmp.h
+usersub.o: /usr/ucbinclude/stdio.h
+usersub.o: /usr/ucbinclude/sys/dirent.h
+usersub.o: /usr/ucbinclude/sys/errno.h
+usersub.o: /usr/ucbinclude/sys/filio.h
+usersub.o: /usr/ucbinclude/sys/ioccom.h
+usersub.o: /usr/ucbinclude/sys/ioctl.h
+usersub.o: /usr/ucbinclude/sys/param.h
+usersub.o: /usr/ucbinclude/sys/signal.h
+usersub.o: /usr/ucbinclude/sys/sockio.h
+usersub.o: /usr/ucbinclude/sys/stat.h
+usersub.o: /usr/ucbinclude/sys/stdtypes.h
+usersub.o: /usr/ucbinclude/sys/sysmacros.h
+usersub.o: /usr/ucbinclude/sys/time.h
+usersub.o: /usr/ucbinclude/sys/times.h
+usersub.o: /usr/ucbinclude/sys/ttold.h
+usersub.o: /usr/ucbinclude/sys/ttychars.h
+usersub.o: /usr/ucbinclude/sys/ttycom.h
+usersub.o: /usr/ucbinclude/sys/ttydev.h
+usersub.o: /usr/ucbinclude/sys/types.h
+usersub.o: /usr/ucbinclude/time.h
+usersub.o: /usr/ucbinclude/vm/faultcode.h
+usersub.o: EXTERN.h
+usersub.o: av.h
+usersub.o: config.h
+usersub.o: cop.h
+usersub.o: embed.h
+usersub.o: form.h
+usersub.o: gv.h
+usersub.o: handy.h
+usersub.o: hv.h
+usersub.o: op.h
+usersub.o: opcode.h
+usersub.o: perl.h
+usersub.o: pp.h
+usersub.o: proto.h
+usersub.o: regexp.h
+usersub.o: sv.h
+usersub.o: unixish.h
+usersub.o: usersub.c
+usersub.o: util.h
+Makefile: Makefile.SH config.sh ; /bin/sh Makefile.SH
+makedepend: makedepend.SH config.sh ; /bin/sh makedepend.SH
+h2ph: h2ph.SH config.sh ; /bin/sh h2ph.SH
+# WARNING: Put nothing here or make depend will gobble it up!
--- /dev/null
+# : Makefile.SH,v 303Revision: 4.0.1.4 303Date: 92/06/08 11:40:43 $
+#
+# $Log: Makefile.SH,v $
+# Revision 4.0.1.4 92/06/08 11:40:43 lwall
+# patch20: cray didn't give enough memory to /bin/sh
+# patch20: various and sundry fixes
+#
+# Revision 4.0.1.3 91/11/05 15:48:11 lwall
+# patch11: saberized perl
+# patch11: added support for dbz
+#
+# Revision 4.0.1.2 91/06/07 10:14:43 lwall
+# patch4: cflags now emits entire cc command except for the filename
+# patch4: alternate make programs are now semi-supported
+# patch4: uperl.o no longer tries to link in libraries prematurely
+# patch4: installperl now installs x2p stuff too
+#
+# Revision 4.0.1.1 91/04/11 17:30:39 lwall
+# patch1: C flags are now settable on a per-file basis
+#
+# Revision 4.0 91/03/20 00:58:54 lwall
+# 4.0 baseline.
+#
+#
+
+CC = cc
+YACC = /bin/yacc
+bin = /usr/local/bin
+scriptdir = /usr/local/bin
+privlib = /usr/local/lib/perl
+mansrc = /usr/man/manl
+manext = l
+LDFLAGS =
+CLDFLAGS =
+SMALL =
+LARGE =
+mallocsrc = malloc.c
+mallocobj = malloc.o
+SLN = ln -s
+RMS = rm -f
+LIB = .
+
+libs = -ldbm -lm -lposix
+
+public = perl taintperl
+
+shellflags =
+
+# To use an alternate make, set in config.sh.
+MAKE = make
+
+
+CCCMD = `sh $(shellflags) cflags $@`
+
+private =
+
+scripts = h2ph
+
+manpages = perl.man h2ph.man
+
+util =
+
+sh = Makefile.SH makedepend.SH h2ph.SH
+
+h1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h embed.h form.h handy.h
+h2 = hash.h perl.h regcomp.h regexp.h spat.h stab.h str.h util.h
+
+h = $(h1) $(h2)
+
+c1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c
+c2 = eval.c form.c hash.c main.c $(mallocsrc) perl.c pp.c regcomp.c regexec.c
+c3 = stab.c str.c toke.c util.c usersub.c
+
+c = $(c1) $(c2) $(c3)
+
+s1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c
+s2 = eval.c form.c hash.c main.c perl.c pp.c regcomp.c regexec.c
+s3 = stab.c str.c toke.c util.c usersub.c perly.c
+
+saber = $(s1) $(s2) $(s3)
+
+obj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o
+obj2 = eval.o form.o $(mallocobj) perl.o pp.o regcomp.o regexec.o
+obj3 = stab.o str.o toke.o util.o
+
+obj = $(obj1) $(obj2) $(obj3)
+
+tobj1 = tarray.o tcmd.o tcons.o tconsarg.o tdoarg.o tdoio.o tdolist.o tdump.o
+tobj2 = teval.o tform.o thash.o $(mallocobj) tpp.o tregcomp.o tregexec.o
+tobj3 = tstab.o tstr.o ttoke.o tutil.o
+
+tobj = $(tobj1) $(tobj2) $(tobj3)
+
+lintflags = -hbvxac
+
+addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
+
+# grrr
+SHELL = /bin/sh
+
+.c.o:
+ $(CCCMD) $*.c
+
+all: libperl.rlb
+
+#all: $(public) $(private) $(util) uperl.o $(scripts)
+# cd x2p; $(MAKE) all
+# touch all
+
+# This is the standard version that contains no "taint" checks and is
+# used for all scripts that aren't set-id or running under something set-id.
+# The $& notation is tells Sequent machines that it can do a parallel make,
+# and is harmless otherwise.
+
+#perl: $& main.o $(obj) hash.o perly.o usersub.o
+# $(CC) $(LARGE) $(CLDFLAGS) main.o $(obj) hash.o perly.o usersub.o \
+# $(libs) -o perl
+# echo '\a'
+
+perl: $& main.o libperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) main.o $(LIB)/libperl.a $(libs) -o perl
+ echo '\a'
+
+libperl.rlb: $(LIB)/libperl.a
+ ranlib $(LIB)/libperl.a
+ touch libperl.rlb
+
+$(LIB)/libperl.a: $& perly.o perl.o $(obj) hash.o usersub.o
+ ar rcuv $(LIB)/libperl.a $(obj) hash.o perly.o usersub.o
+
+# This version, if specified in Configure, does ONLY those scripts which need
+# set-id emulation. Suidperl must be setuid root. It contains the "taint"
+# checks as well as the special code to validate that the script in question
+# has been invoked correctly.
+
+suidperl: $& sperl.o main.o libtperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) sperl.o main.o libtperl.a $(libs) -o suidperl
+
+# This version interprets scripts that are already set-id either via a wrapper
+# or through the kernel allowing set-id scripts (bad idea). Taintperl must
+# NOT be setuid to root or anything else. The only difference between it
+# and normal perl is the presence of the "taint" checks.
+
+taintperl: $& main.o libtperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) main.o libtperl.a $(libs) -o taintperl
+
+libtperl.rlb: libtperl.a
+ ranlib libtperl.a
+ touch libtperl.rlb
+
+libtperl.a: $& tperly.o tperl.o $(tobj) thash.o usersub.o
+ ar rcuv libtperl.a $(tobj) thash.o tperly.o usersub.o tperl.o
+
+# This command assumes that /usr/include/dbz.h and /usr/lib/dbz.o exist.
+
+dbzperl: $& main.o zhash.o libperl.rlb
+ $(CC) $(LARGE) $(CLDFLAGS) main.o zhash.o /usr/lib/dbz.o $(LIB)/libperl.a $(libs) -o dbzperl
+
+zhash.o: hash.c $(h)
+ $(RMS) zhash.c
+ $(SLN) hash.c zhash.c
+ $(CCCMD) -DWANT_DBZ zhash.c
+ $(RMS) zhash.c
+
+uperl.o: $& $(obj) main.o hash.o perly.o
+ -ld $(LARGE) $(LDFLAGS) -r $(obj) main.o hash.o perly.o -o uperl.o
+
+saber: $(saber)
+ # load $(saber)
+ # load /lib/libm.a
+
+# Replicating all this junk is yucky, but I don't see a portable way to fix it.
+
+tperly.o: perly.c perly.h $(h)
+ $(RMS) tperly.c
+ $(SLN) perly.c tperly.c
+ $(CCCMD) -DTAINT tperly.c
+ $(RMS) tperly.c
+
+tperl.o: perl.c perly.h patchlevel.h perl.h $(h)
+ $(RMS) tperl.c
+ $(SLN) perl.c tperl.c
+ $(CCCMD) -DTAINT tperl.c
+ $(RMS) tperl.c
+
+sperl.o: perl.c perly.h patchlevel.h $(h)
+ $(RMS) sperl.c
+ $(SLN) perl.c sperl.c
+ $(CCCMD) -DTAINT -DIAMSUID sperl.c
+ $(RMS) sperl.c
+
+tarray.o: array.c $(h)
+ $(RMS) tarray.c
+ $(SLN) array.c tarray.c
+ $(CCCMD) -DTAINT tarray.c
+ $(RMS) tarray.c
+
+tcmd.o: cmd.c $(h)
+ $(RMS) tcmd.c
+ $(SLN) cmd.c tcmd.c
+ $(CCCMD) -DTAINT tcmd.c
+ $(RMS) tcmd.c
+
+tcons.o: cons.c $(h) perly.h
+ $(RMS) tcons.c
+ $(SLN) cons.c tcons.c
+ $(CCCMD) -DTAINT tcons.c
+ $(RMS) tcons.c
+
+tconsarg.o: consarg.c $(h)
+ $(RMS) tconsarg.c
+ $(SLN) consarg.c tconsarg.c
+ $(CCCMD) -DTAINT tconsarg.c
+ $(RMS) tconsarg.c
+
+tdoarg.o: doarg.c $(h)
+ $(RMS) tdoarg.c
+ $(SLN) doarg.c tdoarg.c
+ $(CCCMD) -DTAINT tdoarg.c
+ $(RMS) tdoarg.c
+
+tdoio.o: doio.c $(h)
+ $(RMS) tdoio.c
+ $(SLN) doio.c tdoio.c
+ $(CCCMD) -DTAINT tdoio.c
+ $(RMS) tdoio.c
+
+tdolist.o: dolist.c $(h)
+ $(RMS) tdolist.c
+ $(SLN) dolist.c tdolist.c
+ $(CCCMD) -DTAINT tdolist.c
+ $(RMS) tdolist.c
+
+tdump.o: dump.c $(h)
+ $(RMS) tdump.c
+ $(SLN) dump.c tdump.c
+ $(CCCMD) -DTAINT tdump.c
+ $(RMS) tdump.c
+
+teval.o: eval.c $(h)
+ $(RMS) teval.c
+ $(SLN) eval.c teval.c
+ $(CCCMD) -DTAINT teval.c
+ $(RMS) teval.c
+
+tform.o: form.c $(h)
+ $(RMS) tform.c
+ $(SLN) form.c tform.c
+ $(CCCMD) -DTAINT tform.c
+ $(RMS) tform.c
+
+thash.o: hash.c $(h)
+ $(RMS) thash.c
+ $(SLN) hash.c thash.c
+ $(CCCMD) -DTAINT thash.c
+ $(RMS) thash.c
+
+tpp.o: pp.c $(h)
+ $(RMS) tpp.c
+ $(SLN) pp.c tpp.c
+ $(CCCMD) -DTAINT tpp.c
+ $(RMS) tpp.c
+
+tregcomp.o: regcomp.c $(h)
+ $(RMS) tregcomp.c
+ $(SLN) regcomp.c tregcomp.c
+ $(CCCMD) -DTAINT tregcomp.c
+ $(RMS) tregcomp.c
+
+tregexec.o: regexec.c $(h)
+ $(RMS) tregexec.c
+ $(SLN) regexec.c tregexec.c
+ $(CCCMD) -DTAINT tregexec.c
+ $(RMS) tregexec.c
+
+tstab.o: stab.c $(h)
+ $(RMS) tstab.c
+ $(SLN) stab.c tstab.c
+ $(CCCMD) -DTAINT tstab.c
+ $(RMS) tstab.c
+
+tstr.o: str.c $(h) perly.h
+ $(RMS) tstr.c
+ $(SLN) str.c tstr.c
+ $(CCCMD) -DTAINT tstr.c
+ $(RMS) tstr.c
+
+ttoke.o: toke.c $(h) perly.h
+ $(RMS) ttoke.c
+ $(SLN) toke.c ttoke.c
+ $(CCCMD) -DTAINT ttoke.c
+ $(RMS) ttoke.c
+
+tutil.o: util.c $(h)
+ $(RMS) tutil.c
+ $(SLN) util.c tutil.c
+ $(CCCMD) -DTAINT tutil.c
+ $(RMS) tutil.c
+
+perly.h: perly.c
+ @ echo Dummy dependency for dumb parallel make
+ touch perly.h
+
+embed.h: embed_h.SH global.var interp.var
+ sh embed_h.SH
+
+perly.c: perly.y perly.fixer
+ @ \
+case "$(YACC)" in \
+ *bison*) echo 'Expect' 25 shift/reduce and 53 reduce/reduce conflicts;; \
+ *) echo 'Expect' 27 shift/reduce and 51 reduce/reduce conflicts;; \
+esac
+ $(YACC) -d perly.y
+ sh $(shellflags) ./perly.fixer y.tab.c perly.c
+ mv y.tab.h perly.h
+ echo 'extern YYSTYPE yylval;' >>perly.h
+
+perly.o: perly.c perly.h $(h)
+ $(CCCMD) perly.c
+
+install: all
+ ./perl installperl
+
+clean:
+ rm -f *.o all perl taintperl suidperl perly.c
+ cd x2p; $(MAKE) clean
+
+realclean: clean
+ cd x2p; $(MAKE) realclean
+ rm -f *.orig */*.orig *~ */*~ core $(addedbyconf) h2ph h2ph.man
+ rm -f perly.c perly.h t/perl Makefile config.h makedepend makedir
+ rm -f makefile x2p/Makefile x2p/makefile cflags x2p/cflags
+ rm -f c2ph pstruct
+
+# 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: perly.c $(c)
+ lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz
+
+depend: makedepend
+ - test -f perly.h || cp /dev/null perly.h
+ ./makedepend
+ - test -s perly.h || /bin/rm -f perly.h
+ cd x2p; $(MAKE) depend
+
+test: perl
+ - cd t && chmod +x TEST */*.t
+ - cd t && (rm -f perl; $(SLN) ../perl perl) && ./perl TEST </dev/tty
+
+clist:
+ echo $(c) | tr ' ' '\012' >.clist
+
+hlist:
+ echo $(h) | tr ' ' '\012' >.hlist
+
+shlist:
+ echo $(sh) | tr ' ' '\012' >.shlist
+
+# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
+# If this runs make out of memory, delete /usr/include lines.
+array.o:
+array.o: /usr/ucbinclude/ctype.h
+array.o: /usr/ucbinclude/dirent.h
+array.o: /usr/ucbinclude/errno.h
+array.o: /usr/ucbinclude/machine/param.h
+array.o: /usr/ucbinclude/machine/setjmp.h
+array.o: /usr/ucbinclude/ndbm.h
+array.o: /usr/ucbinclude/netinet/in.h
+array.o: /usr/ucbinclude/setjmp.h
+array.o: /usr/ucbinclude/stdio.h
+array.o: /usr/ucbinclude/sys/dirent.h
+array.o: /usr/ucbinclude/sys/errno.h
+array.o: /usr/ucbinclude/sys/filio.h
+array.o: /usr/ucbinclude/sys/ioccom.h
+array.o: /usr/ucbinclude/sys/ioctl.h
+array.o: /usr/ucbinclude/sys/param.h
+array.o: /usr/ucbinclude/sys/signal.h
+array.o: /usr/ucbinclude/sys/sockio.h
+array.o: /usr/ucbinclude/sys/stat.h
+array.o: /usr/ucbinclude/sys/stdtypes.h
+array.o: /usr/ucbinclude/sys/sysmacros.h
+array.o: /usr/ucbinclude/sys/time.h
+array.o: /usr/ucbinclude/sys/times.h
+array.o: /usr/ucbinclude/sys/ttold.h
+array.o: /usr/ucbinclude/sys/ttychars.h
+array.o: /usr/ucbinclude/sys/ttycom.h
+array.o: /usr/ucbinclude/sys/ttydev.h
+array.o: /usr/ucbinclude/sys/types.h
+array.o: /usr/ucbinclude/time.h
+array.o: /usr/ucbinclude/vm/faultcode.h
+array.o: EXTERN.h
+array.o: arg.h
+array.o: array.c
+array.o: array.h
+array.o: cmd.h
+array.o: config.h
+array.o: embed.h
+array.o: form.h
+array.o: handy.h
+array.o: hash.h
+array.o: perl.h
+array.o: regexp.h
+array.o: spat.h
+array.o: stab.h
+array.o: str.h
+array.o: unixish.h
+array.o: util.h
+cmd.o:
+cmd.o: /usr/ucbinclude/ctype.h
+cmd.o: /usr/ucbinclude/dirent.h
+cmd.o: /usr/ucbinclude/errno.h
+cmd.o: /usr/ucbinclude/machine/param.h
+cmd.o: /usr/ucbinclude/machine/setjmp.h
+cmd.o: /usr/ucbinclude/ndbm.h
+cmd.o: /usr/ucbinclude/netinet/in.h
+cmd.o: /usr/ucbinclude/setjmp.h
+cmd.o: /usr/ucbinclude/stdio.h
+cmd.o: /usr/ucbinclude/sys/dirent.h
+cmd.o: /usr/ucbinclude/sys/errno.h
+cmd.o: /usr/ucbinclude/sys/filio.h
+cmd.o: /usr/ucbinclude/sys/ioccom.h
+cmd.o: /usr/ucbinclude/sys/ioctl.h
+cmd.o: /usr/ucbinclude/sys/param.h
+cmd.o: /usr/ucbinclude/sys/signal.h
+cmd.o: /usr/ucbinclude/sys/sockio.h
+cmd.o: /usr/ucbinclude/sys/stat.h
+cmd.o: /usr/ucbinclude/sys/stdtypes.h
+cmd.o: /usr/ucbinclude/sys/sysmacros.h
+cmd.o: /usr/ucbinclude/sys/time.h
+cmd.o: /usr/ucbinclude/sys/times.h
+cmd.o: /usr/ucbinclude/sys/ttold.h
+cmd.o: /usr/ucbinclude/sys/ttychars.h
+cmd.o: /usr/ucbinclude/sys/ttycom.h
+cmd.o: /usr/ucbinclude/sys/ttydev.h
+cmd.o: /usr/ucbinclude/sys/types.h
+cmd.o: /usr/ucbinclude/time.h
+cmd.o: /usr/ucbinclude/varargs.h
+cmd.o: /usr/ucbinclude/vm/faultcode.h
+cmd.o: EXTERN.h
+cmd.o: arg.h
+cmd.o: array.h
+cmd.o: cmd.c
+cmd.o: cmd.h
+cmd.o: config.h
+cmd.o: embed.h
+cmd.o: form.h
+cmd.o: handy.h
+cmd.o: hash.h
+cmd.o: perl.h
+cmd.o: regexp.h
+cmd.o: spat.h
+cmd.o: stab.h
+cmd.o: str.h
+cmd.o: unixish.h
+cmd.o: util.h
+cons.o:
+cons.o: /usr/ucbinclude/ctype.h
+cons.o: /usr/ucbinclude/dirent.h
+cons.o: /usr/ucbinclude/errno.h
+cons.o: /usr/ucbinclude/machine/param.h
+cons.o: /usr/ucbinclude/machine/setjmp.h
+cons.o: /usr/ucbinclude/ndbm.h
+cons.o: /usr/ucbinclude/netinet/in.h
+cons.o: /usr/ucbinclude/setjmp.h
+cons.o: /usr/ucbinclude/stdio.h
+cons.o: /usr/ucbinclude/sys/dirent.h
+cons.o: /usr/ucbinclude/sys/errno.h
+cons.o: /usr/ucbinclude/sys/filio.h
+cons.o: /usr/ucbinclude/sys/ioccom.h
+cons.o: /usr/ucbinclude/sys/ioctl.h
+cons.o: /usr/ucbinclude/sys/param.h
+cons.o: /usr/ucbinclude/sys/signal.h
+cons.o: /usr/ucbinclude/sys/sockio.h
+cons.o: /usr/ucbinclude/sys/stat.h
+cons.o: /usr/ucbinclude/sys/stdtypes.h
+cons.o: /usr/ucbinclude/sys/sysmacros.h
+cons.o: /usr/ucbinclude/sys/time.h
+cons.o: /usr/ucbinclude/sys/times.h
+cons.o: /usr/ucbinclude/sys/ttold.h
+cons.o: /usr/ucbinclude/sys/ttychars.h
+cons.o: /usr/ucbinclude/sys/ttycom.h
+cons.o: /usr/ucbinclude/sys/ttydev.h
+cons.o: /usr/ucbinclude/sys/types.h
+cons.o: /usr/ucbinclude/time.h
+cons.o: /usr/ucbinclude/vm/faultcode.h
+cons.o: EXTERN.h
+cons.o: arg.h
+cons.o: array.h
+cons.o: cmd.h
+cons.o: config.h
+cons.o: cons.c
+cons.o: embed.h
+cons.o: form.h
+cons.o: handy.h
+cons.o: hash.h
+cons.o: perl.h
+cons.o: perly.h
+cons.o: regexp.h
+cons.o: spat.h
+cons.o: stab.h
+cons.o: str.h
+cons.o: unixish.h
+cons.o: util.h
+consarg.o:
+consarg.o: /usr/ucbinclude/ctype.h
+consarg.o: /usr/ucbinclude/dirent.h
+consarg.o: /usr/ucbinclude/errno.h
+consarg.o: /usr/ucbinclude/machine/param.h
+consarg.o: /usr/ucbinclude/machine/setjmp.h
+consarg.o: /usr/ucbinclude/ndbm.h
+consarg.o: /usr/ucbinclude/netinet/in.h
+consarg.o: /usr/ucbinclude/setjmp.h
+consarg.o: /usr/ucbinclude/stdio.h
+consarg.o: /usr/ucbinclude/sys/dirent.h
+consarg.o: /usr/ucbinclude/sys/errno.h
+consarg.o: /usr/ucbinclude/sys/filio.h
+consarg.o: /usr/ucbinclude/sys/ioccom.h
+consarg.o: /usr/ucbinclude/sys/ioctl.h
+consarg.o: /usr/ucbinclude/sys/param.h
+consarg.o: /usr/ucbinclude/sys/signal.h
+consarg.o: /usr/ucbinclude/sys/sockio.h
+consarg.o: /usr/ucbinclude/sys/stat.h
+consarg.o: /usr/ucbinclude/sys/stdtypes.h
+consarg.o: /usr/ucbinclude/sys/sysmacros.h
+consarg.o: /usr/ucbinclude/sys/time.h
+consarg.o: /usr/ucbinclude/sys/times.h
+consarg.o: /usr/ucbinclude/sys/ttold.h
+consarg.o: /usr/ucbinclude/sys/ttychars.h
+consarg.o: /usr/ucbinclude/sys/ttycom.h
+consarg.o: /usr/ucbinclude/sys/ttydev.h
+consarg.o: /usr/ucbinclude/sys/types.h
+consarg.o: /usr/ucbinclude/time.h
+consarg.o: /usr/ucbinclude/vm/faultcode.h
+consarg.o: EXTERN.h
+consarg.o: arg.h
+consarg.o: array.h
+consarg.o: cmd.h
+consarg.o: config.h
+consarg.o: consarg.c
+consarg.o: embed.h
+consarg.o: form.h
+consarg.o: handy.h
+consarg.o: hash.h
+consarg.o: perl.h
+consarg.o: regexp.h
+consarg.o: spat.h
+consarg.o: stab.h
+consarg.o: str.h
+consarg.o: unixish.h
+consarg.o: util.h
+doarg.o:
+doarg.o: /usr/ucbinclude/ctype.h
+doarg.o: /usr/ucbinclude/dirent.h
+doarg.o: /usr/ucbinclude/errno.h
+doarg.o: /usr/ucbinclude/machine/param.h
+doarg.o: /usr/ucbinclude/machine/setjmp.h
+doarg.o: /usr/ucbinclude/ndbm.h
+doarg.o: /usr/ucbinclude/netinet/in.h
+doarg.o: /usr/ucbinclude/setjmp.h
+doarg.o: /usr/ucbinclude/stdio.h
+doarg.o: /usr/ucbinclude/sys/dirent.h
+doarg.o: /usr/ucbinclude/sys/errno.h
+doarg.o: /usr/ucbinclude/sys/filio.h
+doarg.o: /usr/ucbinclude/sys/ioccom.h
+doarg.o: /usr/ucbinclude/sys/ioctl.h
+doarg.o: /usr/ucbinclude/sys/param.h
+doarg.o: /usr/ucbinclude/sys/signal.h
+doarg.o: /usr/ucbinclude/sys/sockio.h
+doarg.o: /usr/ucbinclude/sys/stat.h
+doarg.o: /usr/ucbinclude/sys/stdtypes.h
+doarg.o: /usr/ucbinclude/sys/sysmacros.h
+doarg.o: /usr/ucbinclude/sys/time.h
+doarg.o: /usr/ucbinclude/sys/times.h
+doarg.o: /usr/ucbinclude/sys/ttold.h
+doarg.o: /usr/ucbinclude/sys/ttychars.h
+doarg.o: /usr/ucbinclude/sys/ttycom.h
+doarg.o: /usr/ucbinclude/sys/ttydev.h
+doarg.o: /usr/ucbinclude/sys/types.h
+doarg.o: /usr/ucbinclude/time.h
+doarg.o: /usr/ucbinclude/vm/faultcode.h
+doarg.o: EXTERN.h
+doarg.o: arg.h
+doarg.o: array.h
+doarg.o: cmd.h
+doarg.o: config.h
+doarg.o: doarg.c
+doarg.o: embed.h
+doarg.o: form.h
+doarg.o: handy.h
+doarg.o: hash.h
+doarg.o: perl.h
+doarg.o: regexp.h
+doarg.o: spat.h
+doarg.o: stab.h
+doarg.o: str.h
+doarg.o: unixish.h
+doarg.o: util.h
+doio.o:
+doio.o: /usr/ucbinclude/ctype.h
+doio.o: /usr/ucbinclude/debug/debug.h
+doio.o: /usr/ucbinclude/dirent.h
+doio.o: /usr/ucbinclude/errno.h
+doio.o: /usr/ucbinclude/grp.h
+doio.o: /usr/ucbinclude/machine/mmu.h
+doio.o: /usr/ucbinclude/machine/param.h
+doio.o: /usr/ucbinclude/machine/setjmp.h
+doio.o: /usr/ucbinclude/mon/obpdefs.h
+doio.o: /usr/ucbinclude/mon/openprom.h
+doio.o: /usr/ucbinclude/mon/sunromvec.h
+doio.o: /usr/ucbinclude/ndbm.h
+doio.o: /usr/ucbinclude/netdb.h
+doio.o: /usr/ucbinclude/netinet/in.h
+doio.o: /usr/ucbinclude/pwd.h
+doio.o: /usr/ucbinclude/setjmp.h
+doio.o: /usr/ucbinclude/stdio.h
+doio.o: /usr/ucbinclude/sys/dirent.h
+doio.o: /usr/ucbinclude/sys/errno.h
+doio.o: /usr/ucbinclude/sys/fcntlcom.h
+doio.o: /usr/ucbinclude/sys/file.h
+doio.o: /usr/ucbinclude/sys/filio.h
+doio.o: /usr/ucbinclude/sys/ioccom.h
+doio.o: /usr/ucbinclude/sys/ioctl.h
+doio.o: /usr/ucbinclude/sys/ipc.h
+doio.o: /usr/ucbinclude/sys/msg.h
+doio.o: /usr/ucbinclude/sys/param.h
+doio.o: /usr/ucbinclude/sys/sem.h
+doio.o: /usr/ucbinclude/sys/shm.h
+doio.o: /usr/ucbinclude/sys/signal.h
+doio.o: /usr/ucbinclude/sys/socket.h
+doio.o: /usr/ucbinclude/sys/sockio.h
+doio.o: /usr/ucbinclude/sys/stat.h
+doio.o: /usr/ucbinclude/sys/stdtypes.h
+doio.o: /usr/ucbinclude/sys/sysmacros.h
+doio.o: /usr/ucbinclude/sys/time.h
+doio.o: /usr/ucbinclude/sys/times.h
+doio.o: /usr/ucbinclude/sys/ttold.h
+doio.o: /usr/ucbinclude/sys/ttychars.h
+doio.o: /usr/ucbinclude/sys/ttycom.h
+doio.o: /usr/ucbinclude/sys/ttydev.h
+doio.o: /usr/ucbinclude/sys/types.h
+doio.o: /usr/ucbinclude/time.h
+doio.o: /usr/ucbinclude/utime.h
+doio.o: /usr/ucbinclude/vm/faultcode.h
+doio.o: EXTERN.h
+doio.o: arg.h
+doio.o: array.h
+doio.o: cmd.h
+doio.o: config.h
+doio.o: doio.c
+doio.o: embed.h
+doio.o: form.h
+doio.o: handy.h
+doio.o: hash.h
+doio.o: perl.h
+doio.o: regexp.h
+doio.o: spat.h
+doio.o: stab.h
+doio.o: str.h
+doio.o: unixish.h
+doio.o: util.h
+dolist.o:
+dolist.o: /usr/ucbinclude/ctype.h
+dolist.o: /usr/ucbinclude/dirent.h
+dolist.o: /usr/ucbinclude/errno.h
+dolist.o: /usr/ucbinclude/machine/param.h
+dolist.o: /usr/ucbinclude/machine/setjmp.h
+dolist.o: /usr/ucbinclude/ndbm.h
+dolist.o: /usr/ucbinclude/netinet/in.h
+dolist.o: /usr/ucbinclude/setjmp.h
+dolist.o: /usr/ucbinclude/stdio.h
+dolist.o: /usr/ucbinclude/sys/dirent.h
+dolist.o: /usr/ucbinclude/sys/errno.h
+dolist.o: /usr/ucbinclude/sys/filio.h
+dolist.o: /usr/ucbinclude/sys/ioccom.h
+dolist.o: /usr/ucbinclude/sys/ioctl.h
+dolist.o: /usr/ucbinclude/sys/param.h
+dolist.o: /usr/ucbinclude/sys/signal.h
+dolist.o: /usr/ucbinclude/sys/sockio.h
+dolist.o: /usr/ucbinclude/sys/stat.h
+dolist.o: /usr/ucbinclude/sys/stdtypes.h
+dolist.o: /usr/ucbinclude/sys/sysmacros.h
+dolist.o: /usr/ucbinclude/sys/time.h
+dolist.o: /usr/ucbinclude/sys/times.h
+dolist.o: /usr/ucbinclude/sys/ttold.h
+dolist.o: /usr/ucbinclude/sys/ttychars.h
+dolist.o: /usr/ucbinclude/sys/ttycom.h
+dolist.o: /usr/ucbinclude/sys/ttydev.h
+dolist.o: /usr/ucbinclude/sys/types.h
+dolist.o: /usr/ucbinclude/time.h
+dolist.o: /usr/ucbinclude/vm/faultcode.h
+dolist.o: EXTERN.h
+dolist.o: arg.h
+dolist.o: array.h
+dolist.o: cmd.h
+dolist.o: config.h
+dolist.o: dolist.c
+dolist.o: embed.h
+dolist.o: form.h
+dolist.o: handy.h
+dolist.o: hash.h
+dolist.o: perl.h
+dolist.o: regexp.h
+dolist.o: spat.h
+dolist.o: stab.h
+dolist.o: str.h
+dolist.o: unixish.h
+dolist.o: util.h
+dump.o:
+dump.o: /usr/ucbinclude/ctype.h
+dump.o: /usr/ucbinclude/dirent.h
+dump.o: /usr/ucbinclude/errno.h
+dump.o: /usr/ucbinclude/machine/param.h
+dump.o: /usr/ucbinclude/machine/setjmp.h
+dump.o: /usr/ucbinclude/ndbm.h
+dump.o: /usr/ucbinclude/netinet/in.h
+dump.o: /usr/ucbinclude/setjmp.h
+dump.o: /usr/ucbinclude/stdio.h
+dump.o: /usr/ucbinclude/sys/dirent.h
+dump.o: /usr/ucbinclude/sys/errno.h
+dump.o: /usr/ucbinclude/sys/filio.h
+dump.o: /usr/ucbinclude/sys/ioccom.h
+dump.o: /usr/ucbinclude/sys/ioctl.h
+dump.o: /usr/ucbinclude/sys/param.h
+dump.o: /usr/ucbinclude/sys/signal.h
+dump.o: /usr/ucbinclude/sys/sockio.h
+dump.o: /usr/ucbinclude/sys/stat.h
+dump.o: /usr/ucbinclude/sys/stdtypes.h
+dump.o: /usr/ucbinclude/sys/sysmacros.h
+dump.o: /usr/ucbinclude/sys/time.h
+dump.o: /usr/ucbinclude/sys/times.h
+dump.o: /usr/ucbinclude/sys/ttold.h
+dump.o: /usr/ucbinclude/sys/ttychars.h
+dump.o: /usr/ucbinclude/sys/ttycom.h
+dump.o: /usr/ucbinclude/sys/ttydev.h
+dump.o: /usr/ucbinclude/sys/types.h
+dump.o: /usr/ucbinclude/time.h
+dump.o: /usr/ucbinclude/vm/faultcode.h
+dump.o: EXTERN.h
+dump.o: arg.h
+dump.o: array.h
+dump.o: cmd.h
+dump.o: config.h
+dump.o: dump.c
+dump.o: embed.h
+dump.o: form.h
+dump.o: handy.h
+dump.o: hash.h
+dump.o: perl.h
+dump.o: regexp.h
+dump.o: spat.h
+dump.o: stab.h
+dump.o: str.h
+dump.o: unixish.h
+dump.o: util.h
+eval.o:
+eval.o: /usr/ucbinclude/ctype.h
+eval.o: /usr/ucbinclude/dirent.h
+eval.o: /usr/ucbinclude/errno.h
+eval.o: /usr/ucbinclude/machine/param.h
+eval.o: /usr/ucbinclude/machine/setjmp.h
+eval.o: /usr/ucbinclude/ndbm.h
+eval.o: /usr/ucbinclude/netinet/in.h
+eval.o: /usr/ucbinclude/setjmp.h
+eval.o: /usr/ucbinclude/stdio.h
+eval.o: /usr/ucbinclude/sys/dirent.h
+eval.o: /usr/ucbinclude/sys/errno.h
+eval.o: /usr/ucbinclude/sys/fcntlcom.h
+eval.o: /usr/ucbinclude/sys/file.h
+eval.o: /usr/ucbinclude/sys/filio.h
+eval.o: /usr/ucbinclude/sys/ioccom.h
+eval.o: /usr/ucbinclude/sys/ioctl.h
+eval.o: /usr/ucbinclude/sys/param.h
+eval.o: /usr/ucbinclude/sys/signal.h
+eval.o: /usr/ucbinclude/sys/sockio.h
+eval.o: /usr/ucbinclude/sys/stat.h
+eval.o: /usr/ucbinclude/sys/stdtypes.h
+eval.o: /usr/ucbinclude/sys/sysmacros.h
+eval.o: /usr/ucbinclude/sys/time.h
+eval.o: /usr/ucbinclude/sys/times.h
+eval.o: /usr/ucbinclude/sys/ttold.h
+eval.o: /usr/ucbinclude/sys/ttychars.h
+eval.o: /usr/ucbinclude/sys/ttycom.h
+eval.o: /usr/ucbinclude/sys/ttydev.h
+eval.o: /usr/ucbinclude/sys/types.h
+eval.o: /usr/ucbinclude/time.h
+eval.o: /usr/ucbinclude/vfork.h
+eval.o: /usr/ucbinclude/vm/faultcode.h
+eval.o: EXTERN.h
+eval.o: arg.h
+eval.o: array.h
+eval.o: cmd.h
+eval.o: config.h
+eval.o: embed.h
+eval.o: eval.c
+eval.o: form.h
+eval.o: handy.h
+eval.o: hash.h
+eval.o: perl.h
+eval.o: regexp.h
+eval.o: spat.h
+eval.o: stab.h
+eval.o: str.h
+eval.o: unixish.h
+eval.o: util.h
+form.o:
+form.o: /usr/ucbinclude/ctype.h
+form.o: /usr/ucbinclude/dirent.h
+form.o: /usr/ucbinclude/errno.h
+form.o: /usr/ucbinclude/machine/param.h
+form.o: /usr/ucbinclude/machine/setjmp.h
+form.o: /usr/ucbinclude/ndbm.h
+form.o: /usr/ucbinclude/netinet/in.h
+form.o: /usr/ucbinclude/setjmp.h
+form.o: /usr/ucbinclude/stdio.h
+form.o: /usr/ucbinclude/sys/dirent.h
+form.o: /usr/ucbinclude/sys/errno.h
+form.o: /usr/ucbinclude/sys/filio.h
+form.o: /usr/ucbinclude/sys/ioccom.h
+form.o: /usr/ucbinclude/sys/ioctl.h
+form.o: /usr/ucbinclude/sys/param.h
+form.o: /usr/ucbinclude/sys/signal.h
+form.o: /usr/ucbinclude/sys/sockio.h
+form.o: /usr/ucbinclude/sys/stat.h
+form.o: /usr/ucbinclude/sys/stdtypes.h
+form.o: /usr/ucbinclude/sys/sysmacros.h
+form.o: /usr/ucbinclude/sys/time.h
+form.o: /usr/ucbinclude/sys/times.h
+form.o: /usr/ucbinclude/sys/ttold.h
+form.o: /usr/ucbinclude/sys/ttychars.h
+form.o: /usr/ucbinclude/sys/ttycom.h
+form.o: /usr/ucbinclude/sys/ttydev.h
+form.o: /usr/ucbinclude/sys/types.h
+form.o: /usr/ucbinclude/time.h
+form.o: /usr/ucbinclude/vm/faultcode.h
+form.o: EXTERN.h
+form.o: arg.h
+form.o: array.h
+form.o: cmd.h
+form.o: config.h
+form.o: embed.h
+form.o: form.c
+form.o: form.h
+form.o: handy.h
+form.o: hash.h
+form.o: perl.h
+form.o: regexp.h
+form.o: spat.h
+form.o: stab.h
+form.o: str.h
+form.o: unixish.h
+form.o: util.h
+hash.o:
+hash.o: /usr/ucbinclude/ctype.h
+hash.o: /usr/ucbinclude/dirent.h
+hash.o: /usr/ucbinclude/errno.h
+hash.o: /usr/ucbinclude/machine/param.h
+hash.o: /usr/ucbinclude/machine/setjmp.h
+hash.o: /usr/ucbinclude/ndbm.h
+hash.o: /usr/ucbinclude/netinet/in.h
+hash.o: /usr/ucbinclude/setjmp.h
+hash.o: /usr/ucbinclude/stdio.h
+hash.o: /usr/ucbinclude/sys/dirent.h
+hash.o: /usr/ucbinclude/sys/errno.h
+hash.o: /usr/ucbinclude/sys/fcntlcom.h
+hash.o: /usr/ucbinclude/sys/file.h
+hash.o: /usr/ucbinclude/sys/filio.h
+hash.o: /usr/ucbinclude/sys/ioccom.h
+hash.o: /usr/ucbinclude/sys/ioctl.h
+hash.o: /usr/ucbinclude/sys/param.h
+hash.o: /usr/ucbinclude/sys/signal.h
+hash.o: /usr/ucbinclude/sys/sockio.h
+hash.o: /usr/ucbinclude/sys/stat.h
+hash.o: /usr/ucbinclude/sys/stdtypes.h
+hash.o: /usr/ucbinclude/sys/sysmacros.h
+hash.o: /usr/ucbinclude/sys/time.h
+hash.o: /usr/ucbinclude/sys/times.h
+hash.o: /usr/ucbinclude/sys/ttold.h
+hash.o: /usr/ucbinclude/sys/ttychars.h
+hash.o: /usr/ucbinclude/sys/ttycom.h
+hash.o: /usr/ucbinclude/sys/ttydev.h
+hash.o: /usr/ucbinclude/sys/types.h
+hash.o: /usr/ucbinclude/time.h
+hash.o: /usr/ucbinclude/vm/faultcode.h
+hash.o: EXTERN.h
+hash.o: arg.h
+hash.o: array.h
+hash.o: cmd.h
+hash.o: config.h
+hash.o: embed.h
+hash.o: form.h
+hash.o: handy.h
+hash.o: hash.c
+hash.o: hash.h
+hash.o: perl.h
+hash.o: regexp.h
+hash.o: spat.h
+hash.o: stab.h
+hash.o: str.h
+hash.o: unixish.h
+hash.o: util.h
+main.o:
+main.o: /usr/ucbinclude/ctype.h
+main.o: /usr/ucbinclude/dirent.h
+main.o: /usr/ucbinclude/errno.h
+main.o: /usr/ucbinclude/machine/param.h
+main.o: /usr/ucbinclude/machine/setjmp.h
+main.o: /usr/ucbinclude/ndbm.h
+main.o: /usr/ucbinclude/netinet/in.h
+main.o: /usr/ucbinclude/setjmp.h
+main.o: /usr/ucbinclude/stdio.h
+main.o: /usr/ucbinclude/sys/dirent.h
+main.o: /usr/ucbinclude/sys/errno.h
+main.o: /usr/ucbinclude/sys/filio.h
+main.o: /usr/ucbinclude/sys/ioccom.h
+main.o: /usr/ucbinclude/sys/ioctl.h
+main.o: /usr/ucbinclude/sys/param.h
+main.o: /usr/ucbinclude/sys/signal.h
+main.o: /usr/ucbinclude/sys/sockio.h
+main.o: /usr/ucbinclude/sys/stat.h
+main.o: /usr/ucbinclude/sys/stdtypes.h
+main.o: /usr/ucbinclude/sys/sysmacros.h
+main.o: /usr/ucbinclude/sys/time.h
+main.o: /usr/ucbinclude/sys/times.h
+main.o: /usr/ucbinclude/sys/ttold.h
+main.o: /usr/ucbinclude/sys/ttychars.h
+main.o: /usr/ucbinclude/sys/ttycom.h
+main.o: /usr/ucbinclude/sys/ttydev.h
+main.o: /usr/ucbinclude/sys/types.h
+main.o: /usr/ucbinclude/time.h
+main.o: /usr/ucbinclude/vm/faultcode.h
+main.o: INTERN.h
+main.o: arg.h
+main.o: array.h
+main.o: cmd.h
+main.o: config.h
+main.o: embed.h
+main.o: form.h
+main.o: handy.h
+main.o: hash.h
+main.o: main.c
+main.o: perl.h
+main.o: regexp.h
+main.o: spat.h
+main.o: stab.h
+main.o: str.h
+main.o: unixish.h
+main.o: util.h
+malloc.o:
+malloc.o: /usr/ucbinclude/ctype.h
+malloc.o: /usr/ucbinclude/dirent.h
+malloc.o: /usr/ucbinclude/errno.h
+malloc.o: /usr/ucbinclude/machine/param.h
+malloc.o: /usr/ucbinclude/machine/setjmp.h
+malloc.o: /usr/ucbinclude/ndbm.h
+malloc.o: /usr/ucbinclude/netinet/in.h
+malloc.o: /usr/ucbinclude/setjmp.h
+malloc.o: /usr/ucbinclude/stdio.h
+malloc.o: /usr/ucbinclude/sys/dirent.h
+malloc.o: /usr/ucbinclude/sys/errno.h
+malloc.o: /usr/ucbinclude/sys/filio.h
+malloc.o: /usr/ucbinclude/sys/ioccom.h
+malloc.o: /usr/ucbinclude/sys/ioctl.h
+malloc.o: /usr/ucbinclude/sys/param.h
+malloc.o: /usr/ucbinclude/sys/signal.h
+malloc.o: /usr/ucbinclude/sys/sockio.h
+malloc.o: /usr/ucbinclude/sys/stat.h
+malloc.o: /usr/ucbinclude/sys/stdtypes.h
+malloc.o: /usr/ucbinclude/sys/sysmacros.h
+malloc.o: /usr/ucbinclude/sys/time.h
+malloc.o: /usr/ucbinclude/sys/times.h
+malloc.o: /usr/ucbinclude/sys/ttold.h
+malloc.o: /usr/ucbinclude/sys/ttychars.h
+malloc.o: /usr/ucbinclude/sys/ttycom.h
+malloc.o: /usr/ucbinclude/sys/ttydev.h
+malloc.o: /usr/ucbinclude/sys/types.h
+malloc.o: /usr/ucbinclude/time.h
+malloc.o: /usr/ucbinclude/vm/faultcode.h
+malloc.o: EXTERN.h
+malloc.o: arg.h
+malloc.o: array.h
+malloc.o: cmd.h
+malloc.o: config.h
+malloc.o: embed.h
+malloc.o: form.h
+malloc.o: handy.h
+malloc.o: hash.h
+malloc.o: malloc.c
+malloc.o: perl.h
+malloc.o: regexp.h
+malloc.o: spat.h
+malloc.o: stab.h
+malloc.o: str.h
+malloc.o: unixish.h
+malloc.o: util.h
+perl.o:
+perl.o: /usr/ucbinclude/ctype.h
+perl.o: /usr/ucbinclude/dirent.h
+perl.o: /usr/ucbinclude/errno.h
+perl.o: /usr/ucbinclude/machine/param.h
+perl.o: /usr/ucbinclude/machine/setjmp.h
+perl.o: /usr/ucbinclude/ndbm.h
+perl.o: /usr/ucbinclude/netinet/in.h
+perl.o: /usr/ucbinclude/setjmp.h
+perl.o: /usr/ucbinclude/stdio.h
+perl.o: /usr/ucbinclude/sys/dirent.h
+perl.o: /usr/ucbinclude/sys/errno.h
+perl.o: /usr/ucbinclude/sys/filio.h
+perl.o: /usr/ucbinclude/sys/ioccom.h
+perl.o: /usr/ucbinclude/sys/ioctl.h
+perl.o: /usr/ucbinclude/sys/param.h
+perl.o: /usr/ucbinclude/sys/signal.h
+perl.o: /usr/ucbinclude/sys/sockio.h
+perl.o: /usr/ucbinclude/sys/stat.h
+perl.o: /usr/ucbinclude/sys/stdtypes.h
+perl.o: /usr/ucbinclude/sys/sysmacros.h
+perl.o: /usr/ucbinclude/sys/time.h
+perl.o: /usr/ucbinclude/sys/times.h
+perl.o: /usr/ucbinclude/sys/ttold.h
+perl.o: /usr/ucbinclude/sys/ttychars.h
+perl.o: /usr/ucbinclude/sys/ttycom.h
+perl.o: /usr/ucbinclude/sys/ttydev.h
+perl.o: /usr/ucbinclude/sys/types.h
+perl.o: /usr/ucbinclude/time.h
+perl.o: /usr/ucbinclude/vm/faultcode.h
+perl.o: EXTERN.h
+perl.o: arg.h
+perl.o: array.h
+perl.o: cmd.h
+perl.o: config.h
+perl.o: embed.h
+perl.o: form.h
+perl.o: handy.h
+perl.o: hash.h
+perl.o: patchlevel.h
+perl.o: perl.c
+perl.o: perl.h
+perl.o: perly.h
+perl.o: regexp.h
+perl.o: spat.h
+perl.o: stab.h
+perl.o: str.h
+perl.o: unixish.h
+perl.o: util.h
+pp.o: EXTERN.h
+pp.o: arg.h
+pp.o: array.h
+pp.o: cmd.h
+pp.o: config.h
+pp.o: embed.h
+pp.o: pp.c
+pp.o: pp.h
+pp.o: form.h
+pp.o: handy.h
+pp.o: hash.h
+pp.o: perl.h
+pp.o: regexp.h
+pp.o: spat.h
+pp.o: stab.h
+pp.o: str.h
+pp.o: unixish.h
+pp.o: util.h
+regcomp.o:
+regcomp.o: /usr/ucbinclude/ctype.h
+regcomp.o: /usr/ucbinclude/dirent.h
+regcomp.o: /usr/ucbinclude/errno.h
+regcomp.o: /usr/ucbinclude/machine/param.h
+regcomp.o: /usr/ucbinclude/machine/setjmp.h
+regcomp.o: /usr/ucbinclude/ndbm.h
+regcomp.o: /usr/ucbinclude/netinet/in.h
+regcomp.o: /usr/ucbinclude/setjmp.h
+regcomp.o: /usr/ucbinclude/stdio.h
+regcomp.o: /usr/ucbinclude/sys/dirent.h
+regcomp.o: /usr/ucbinclude/sys/errno.h
+regcomp.o: /usr/ucbinclude/sys/filio.h
+regcomp.o: /usr/ucbinclude/sys/ioccom.h
+regcomp.o: /usr/ucbinclude/sys/ioctl.h
+regcomp.o: /usr/ucbinclude/sys/param.h
+regcomp.o: /usr/ucbinclude/sys/signal.h
+regcomp.o: /usr/ucbinclude/sys/sockio.h
+regcomp.o: /usr/ucbinclude/sys/stat.h
+regcomp.o: /usr/ucbinclude/sys/stdtypes.h
+regcomp.o: /usr/ucbinclude/sys/sysmacros.h
+regcomp.o: /usr/ucbinclude/sys/time.h
+regcomp.o: /usr/ucbinclude/sys/times.h
+regcomp.o: /usr/ucbinclude/sys/ttold.h
+regcomp.o: /usr/ucbinclude/sys/ttychars.h
+regcomp.o: /usr/ucbinclude/sys/ttycom.h
+regcomp.o: /usr/ucbinclude/sys/ttydev.h
+regcomp.o: /usr/ucbinclude/sys/types.h
+regcomp.o: /usr/ucbinclude/time.h
+regcomp.o: /usr/ucbinclude/vm/faultcode.h
+regcomp.o: EXTERN.h
+regcomp.o: INTERN.h
+regcomp.o: arg.h
+regcomp.o: array.h
+regcomp.o: cmd.h
+regcomp.o: config.h
+regcomp.o: embed.h
+regcomp.o: form.h
+regcomp.o: handy.h
+regcomp.o: hash.h
+regcomp.o: perl.h
+regcomp.o: regcomp.c
+regcomp.o: regcomp.h
+regcomp.o: regexp.h
+regcomp.o: spat.h
+regcomp.o: stab.h
+regcomp.o: str.h
+regcomp.o: unixish.h
+regcomp.o: util.h
+regexec.o:
+regexec.o: /usr/ucbinclude/ctype.h
+regexec.o: /usr/ucbinclude/dirent.h
+regexec.o: /usr/ucbinclude/errno.h
+regexec.o: /usr/ucbinclude/machine/param.h
+regexec.o: /usr/ucbinclude/machine/setjmp.h
+regexec.o: /usr/ucbinclude/ndbm.h
+regexec.o: /usr/ucbinclude/netinet/in.h
+regexec.o: /usr/ucbinclude/setjmp.h
+regexec.o: /usr/ucbinclude/stdio.h
+regexec.o: /usr/ucbinclude/sys/dirent.h
+regexec.o: /usr/ucbinclude/sys/errno.h
+regexec.o: /usr/ucbinclude/sys/filio.h
+regexec.o: /usr/ucbinclude/sys/ioccom.h
+regexec.o: /usr/ucbinclude/sys/ioctl.h
+regexec.o: /usr/ucbinclude/sys/param.h
+regexec.o: /usr/ucbinclude/sys/signal.h
+regexec.o: /usr/ucbinclude/sys/sockio.h
+regexec.o: /usr/ucbinclude/sys/stat.h
+regexec.o: /usr/ucbinclude/sys/stdtypes.h
+regexec.o: /usr/ucbinclude/sys/sysmacros.h
+regexec.o: /usr/ucbinclude/sys/time.h
+regexec.o: /usr/ucbinclude/sys/times.h
+regexec.o: /usr/ucbinclude/sys/ttold.h
+regexec.o: /usr/ucbinclude/sys/ttychars.h
+regexec.o: /usr/ucbinclude/sys/ttycom.h
+regexec.o: /usr/ucbinclude/sys/ttydev.h
+regexec.o: /usr/ucbinclude/sys/types.h
+regexec.o: /usr/ucbinclude/time.h
+regexec.o: /usr/ucbinclude/vm/faultcode.h
+regexec.o: EXTERN.h
+regexec.o: arg.h
+regexec.o: array.h
+regexec.o: cmd.h
+regexec.o: config.h
+regexec.o: embed.h
+regexec.o: form.h
+regexec.o: handy.h
+regexec.o: hash.h
+regexec.o: perl.h
+regexec.o: regcomp.h
+regexec.o: regexec.c
+regexec.o: regexp.h
+regexec.o: spat.h
+regexec.o: stab.h
+regexec.o: str.h
+regexec.o: unixish.h
+regexec.o: util.h
+stab.o:
+stab.o: /usr/ucbinclude/ctype.h
+stab.o: /usr/ucbinclude/dirent.h
+stab.o: /usr/ucbinclude/errno.h
+stab.o: /usr/ucbinclude/machine/param.h
+stab.o: /usr/ucbinclude/machine/setjmp.h
+stab.o: /usr/ucbinclude/ndbm.h
+stab.o: /usr/ucbinclude/netinet/in.h
+stab.o: /usr/ucbinclude/setjmp.h
+stab.o: /usr/ucbinclude/stdio.h
+stab.o: /usr/ucbinclude/sys/dirent.h
+stab.o: /usr/ucbinclude/sys/errno.h
+stab.o: /usr/ucbinclude/sys/filio.h
+stab.o: /usr/ucbinclude/sys/ioccom.h
+stab.o: /usr/ucbinclude/sys/ioctl.h
+stab.o: /usr/ucbinclude/sys/param.h
+stab.o: /usr/ucbinclude/sys/signal.h
+stab.o: /usr/ucbinclude/sys/sockio.h
+stab.o: /usr/ucbinclude/sys/stat.h
+stab.o: /usr/ucbinclude/sys/stdtypes.h
+stab.o: /usr/ucbinclude/sys/sysmacros.h
+stab.o: /usr/ucbinclude/sys/time.h
+stab.o: /usr/ucbinclude/sys/times.h
+stab.o: /usr/ucbinclude/sys/ttold.h
+stab.o: /usr/ucbinclude/sys/ttychars.h
+stab.o: /usr/ucbinclude/sys/ttycom.h
+stab.o: /usr/ucbinclude/sys/ttydev.h
+stab.o: /usr/ucbinclude/sys/types.h
+stab.o: /usr/ucbinclude/time.h
+stab.o: /usr/ucbinclude/vm/faultcode.h
+stab.o: EXTERN.h
+stab.o: arg.h
+stab.o: array.h
+stab.o: cmd.h
+stab.o: config.h
+stab.o: embed.h
+stab.o: form.h
+stab.o: handy.h
+stab.o: hash.h
+stab.o: perl.h
+stab.o: regexp.h
+stab.o: spat.h
+stab.o: stab.c
+stab.o: stab.h
+stab.o: str.h
+stab.o: unixish.h
+stab.o: util.h
+str.o:
+str.o: /usr/ucbinclude/ctype.h
+str.o: /usr/ucbinclude/dirent.h
+str.o: /usr/ucbinclude/errno.h
+str.o: /usr/ucbinclude/machine/param.h
+str.o: /usr/ucbinclude/machine/setjmp.h
+str.o: /usr/ucbinclude/ndbm.h
+str.o: /usr/ucbinclude/netinet/in.h
+str.o: /usr/ucbinclude/setjmp.h
+str.o: /usr/ucbinclude/stdio.h
+str.o: /usr/ucbinclude/sys/dirent.h
+str.o: /usr/ucbinclude/sys/errno.h
+str.o: /usr/ucbinclude/sys/filio.h
+str.o: /usr/ucbinclude/sys/ioccom.h
+str.o: /usr/ucbinclude/sys/ioctl.h
+str.o: /usr/ucbinclude/sys/param.h
+str.o: /usr/ucbinclude/sys/signal.h
+str.o: /usr/ucbinclude/sys/sockio.h
+str.o: /usr/ucbinclude/sys/stat.h
+str.o: /usr/ucbinclude/sys/stdtypes.h
+str.o: /usr/ucbinclude/sys/sysmacros.h
+str.o: /usr/ucbinclude/sys/time.h
+str.o: /usr/ucbinclude/sys/times.h
+str.o: /usr/ucbinclude/sys/ttold.h
+str.o: /usr/ucbinclude/sys/ttychars.h
+str.o: /usr/ucbinclude/sys/ttycom.h
+str.o: /usr/ucbinclude/sys/ttydev.h
+str.o: /usr/ucbinclude/sys/types.h
+str.o: /usr/ucbinclude/time.h
+str.o: /usr/ucbinclude/vm/faultcode.h
+str.o: EXTERN.h
+str.o: arg.h
+str.o: array.h
+str.o: cmd.h
+str.o: config.h
+str.o: embed.h
+str.o: form.h
+str.o: handy.h
+str.o: hash.h
+str.o: perl.h
+str.o: perly.h
+str.o: regexp.h
+str.o: spat.h
+str.o: stab.h
+str.o: str.c
+str.o: str.h
+str.o: unixish.h
+str.o: util.h
+toke.o:
+toke.o: /usr/ucbinclude/ctype.h
+toke.o: /usr/ucbinclude/dirent.h
+toke.o: /usr/ucbinclude/errno.h
+toke.o: /usr/ucbinclude/machine/param.h
+toke.o: /usr/ucbinclude/machine/setjmp.h
+toke.o: /usr/ucbinclude/ndbm.h
+toke.o: /usr/ucbinclude/netinet/in.h
+toke.o: /usr/ucbinclude/setjmp.h
+toke.o: /usr/ucbinclude/stdio.h
+toke.o: /usr/ucbinclude/sys/dirent.h
+toke.o: /usr/ucbinclude/sys/errno.h
+toke.o: /usr/ucbinclude/sys/fcntlcom.h
+toke.o: /usr/ucbinclude/sys/file.h
+toke.o: /usr/ucbinclude/sys/filio.h
+toke.o: /usr/ucbinclude/sys/ioccom.h
+toke.o: /usr/ucbinclude/sys/ioctl.h
+toke.o: /usr/ucbinclude/sys/param.h
+toke.o: /usr/ucbinclude/sys/signal.h
+toke.o: /usr/ucbinclude/sys/sockio.h
+toke.o: /usr/ucbinclude/sys/stat.h
+toke.o: /usr/ucbinclude/sys/stdtypes.h
+toke.o: /usr/ucbinclude/sys/sysmacros.h
+toke.o: /usr/ucbinclude/sys/time.h
+toke.o: /usr/ucbinclude/sys/times.h
+toke.o: /usr/ucbinclude/sys/ttold.h
+toke.o: /usr/ucbinclude/sys/ttychars.h
+toke.o: /usr/ucbinclude/sys/ttycom.h
+toke.o: /usr/ucbinclude/sys/ttydev.h
+toke.o: /usr/ucbinclude/sys/types.h
+toke.o: /usr/ucbinclude/time.h
+toke.o: /usr/ucbinclude/vm/faultcode.h
+toke.o: EXTERN.h
+toke.o: arg.h
+toke.o: array.h
+toke.o: cmd.h
+toke.o: config.h
+toke.o: embed.h
+toke.o: form.h
+toke.o: handy.h
+toke.o: hash.h
+toke.o: keywords.h
+toke.o: perl.h
+toke.o: perly.h
+toke.o: regexp.h
+toke.o: spat.h
+toke.o: stab.h
+toke.o: str.h
+toke.o: toke.c
+toke.o: unixish.h
+toke.o: util.h
+util.o:
+util.o: /usr/ucbinclude/ctype.h
+util.o: /usr/ucbinclude/dirent.h
+util.o: /usr/ucbinclude/errno.h
+util.o: /usr/ucbinclude/machine/param.h
+util.o: /usr/ucbinclude/machine/setjmp.h
+util.o: /usr/ucbinclude/ndbm.h
+util.o: /usr/ucbinclude/netinet/in.h
+util.o: /usr/ucbinclude/setjmp.h
+util.o: /usr/ucbinclude/stdio.h
+util.o: /usr/ucbinclude/sys/dirent.h
+util.o: /usr/ucbinclude/sys/errno.h
+util.o: /usr/ucbinclude/sys/fcntlcom.h
+util.o: /usr/ucbinclude/sys/file.h
+util.o: /usr/ucbinclude/sys/filio.h
+util.o: /usr/ucbinclude/sys/ioccom.h
+util.o: /usr/ucbinclude/sys/ioctl.h
+util.o: /usr/ucbinclude/sys/param.h
+util.o: /usr/ucbinclude/sys/signal.h
+util.o: /usr/ucbinclude/sys/sockio.h
+util.o: /usr/ucbinclude/sys/stat.h
+util.o: /usr/ucbinclude/sys/stdtypes.h
+util.o: /usr/ucbinclude/sys/sysmacros.h
+util.o: /usr/ucbinclude/sys/time.h
+util.o: /usr/ucbinclude/sys/times.h
+util.o: /usr/ucbinclude/sys/ttold.h
+util.o: /usr/ucbinclude/sys/ttychars.h
+util.o: /usr/ucbinclude/sys/ttycom.h
+util.o: /usr/ucbinclude/sys/ttydev.h
+util.o: /usr/ucbinclude/sys/types.h
+util.o: /usr/ucbinclude/time.h
+util.o: /usr/ucbinclude/varargs.h
+util.o: /usr/ucbinclude/vfork.h
+util.o: /usr/ucbinclude/vm/faultcode.h
+util.o: EXTERN.h
+util.o: arg.h
+util.o: array.h
+util.o: cmd.h
+util.o: config.h
+util.o: embed.h
+util.o: form.h
+util.o: handy.h
+util.o: hash.h
+util.o: perl.h
+util.o: regexp.h
+util.o: spat.h
+util.o: stab.h
+util.o: str.h
+util.o: unixish.h
+util.o: util.c
+util.o: util.h
+usersub.o:
+usersub.o: /usr/ucbinclude/ctype.h
+usersub.o: /usr/ucbinclude/dirent.h
+usersub.o: /usr/ucbinclude/errno.h
+usersub.o: /usr/ucbinclude/machine/param.h
+usersub.o: /usr/ucbinclude/machine/setjmp.h
+usersub.o: /usr/ucbinclude/ndbm.h
+usersub.o: /usr/ucbinclude/netinet/in.h
+usersub.o: /usr/ucbinclude/setjmp.h
+usersub.o: /usr/ucbinclude/stdio.h
+usersub.o: /usr/ucbinclude/sys/dirent.h
+usersub.o: /usr/ucbinclude/sys/errno.h
+usersub.o: /usr/ucbinclude/sys/filio.h
+usersub.o: /usr/ucbinclude/sys/ioccom.h
+usersub.o: /usr/ucbinclude/sys/ioctl.h
+usersub.o: /usr/ucbinclude/sys/param.h
+usersub.o: /usr/ucbinclude/sys/signal.h
+usersub.o: /usr/ucbinclude/sys/sockio.h
+usersub.o: /usr/ucbinclude/sys/stat.h
+usersub.o: /usr/ucbinclude/sys/stdtypes.h
+usersub.o: /usr/ucbinclude/sys/sysmacros.h
+usersub.o: /usr/ucbinclude/sys/time.h
+usersub.o: /usr/ucbinclude/sys/times.h
+usersub.o: /usr/ucbinclude/sys/ttold.h
+usersub.o: /usr/ucbinclude/sys/ttychars.h
+usersub.o: /usr/ucbinclude/sys/ttycom.h
+usersub.o: /usr/ucbinclude/sys/ttydev.h
+usersub.o: /usr/ucbinclude/sys/types.h
+usersub.o: /usr/ucbinclude/time.h
+usersub.o: /usr/ucbinclude/vm/faultcode.h
+usersub.o: EXTERN.h
+usersub.o: arg.h
+usersub.o: array.h
+usersub.o: cmd.h
+usersub.o: config.h
+usersub.o: embed.h
+usersub.o: form.h
+usersub.o: handy.h
+usersub.o: hash.h
+usersub.o: perl.h
+usersub.o: regexp.h
+usersub.o: spat.h
+usersub.o: stab.h
+usersub.o: str.h
+usersub.o: unixish.h
+usersub.o: usersub.c
+usersub.o: util.h
+Makefile: Makefile.SH config.sh ; /bin/sh Makefile.SH
+makedepend: makedepend.SH config.sh ; /bin/sh makedepend.SH
+h2ph: h2ph.SH config.sh ; /bin/sh h2ph.SH
+# WARNING: Put nothing here or make depend will gobble it up!
-/* $RCSfile: malloc.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 14:28:38 $
+/* $RCSfile: malloc.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:25 $
*
* $Log: malloc.c,v $
+ * Revision 4.1 92/08/07 18:24:25 lwall
+ *
* Revision 4.0.1.4 92/06/08 14:28:38 lwall
* patch20: removed implicit int declarations on functions
* patch20: hash tables now split only if the memory is available to do so
#include "EXTERN.h"
#include "perl.h"
-static findbucket(), morecore();
+static int findbucket();
+static int morecore();
/* I don't much care whether these are defined in sys/types.h--LAW */
#define ASSERT(p)
#endif
-#ifdef safemalloc
-static int an = 0;
-#endif
-
MALLOCPTRTYPE *
malloc(nbytes)
register MEM_SIZE nbytes;
#ifdef MSDOS
if (nbytes > 0xffff) {
fprintf(stderr, "Allocation too large: %lx\n", (long)nbytes);
- exit(1);
+ my_exit(1);
}
#endif /* MSDOS */
#ifdef DEBUGGING
#ifdef safemalloc
if (!nomemok) {
fputs("Out of memory!\n", stderr);
- exit(1);
+ my_exit(1);
}
#else
return (NULL);
}
#ifdef safemalloc
-#ifdef DEBUGGING
-# if !(defined(I286) || defined(atarist))
- if (debug & 128)
- fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",p+1,an++,(long)size);
-# else
- if (debug & 128)
- fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",p+1,an++,(long)size);
-# endif
+#if !(defined(I286) || defined(atarist))
+ DEBUG_m(fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",p+1,an++,(long)size));
+#else
+ DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",p+1,an++,(long)size));
#endif
#endif /* safemalloc */
char *cp = (char*)mp;
#ifdef safemalloc
-#ifdef DEBUGGING
-# if !(defined(I286) || defined(atarist))
- if (debug & 128)
- fprintf(stderr,"0x%x: (%05d) free\n",cp,an++);
-# else
- if (debug & 128)
- fprintf(stderr,"0x%lx: (%05d) free\n",cp,an++);
-# endif
+#if !(defined(I286) || defined(atarist))
+ DEBUG_m(fprintf(stderr,"0x%x: (%05d) free\n",cp,an++));
+#else
+ DEBUG_m(fprintf(stderr,"0x%lx: (%05d) free\n",cp,an++));
#endif
#endif /* safemalloc */
#ifdef MSDOS
if (nbytes > 0xffff) {
fprintf(stderr, "Reallocation too large: %lx\n", size);
- exit(1);
+ my_exit(1);
}
#endif /* MSDOS */
if (!cp)
--- /dev/null
+ len = sv->sv_cur;
+ e = sv->sv_ptr + len;
+ if (delim == '\'')
+ d = e;
+ else
+ d = sv->sv_ptr;
+ for (; d < e; d++) {
+ if (*d == '\\')
+ d++;
+ else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') ||
+ (*d == '@')) {
+ lex_stuff = newSVsv(sv);
+ d = scan_ident(d,bufend,buf,FALSE);
+ (void)gv_fetchpv(buf,TRUE); /* make sure it's created */
+ for (; d < e; d++) {
+ if (*d == '\\')
+ d++;
+ else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') {
+ d = scan_ident(d,bufend,buf,FALSE);
+ (void)gv_fetchpv(buf,TRUE);
+ }
+ else if (*d == '@') {
+ d = scan_ident(d,bufend,buf,FALSE);
+ if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
+ strEQ(buf,"SIG") || strEQ(buf,"INC"))
+ (void)gv_fetchpv(buf,TRUE);
+ }
+ }
+ pm->op_pmflags |= PMf_RUNTIME;
+ goto got_pat; /* skip compiling for now */
+ }
+ }
+ if (pm->op_pmflags & PMf_FOLD)
+ StructCopy(pm, &savepm, PMOP);
+ scan_prefix(pm,sv->sv_ptr,len);
+ if ((pm->op_pmflags & PMf_ALL) && (pm->op_pmflags & PMf_SCANFIRST)) {
+ fbm_compile(pm->op_pmshort, pm->op_pmflags & PMf_FOLD);
+ pm->op_pmregexp = regcomp(sv->sv_ptr,sv->sv_ptr+len,
+ pm->op_pmflags & PMf_FOLD);
+ /* Note that this regexp can still be used if someone says
+ * something like /a/ && s//b/; so we can't delete it.
+ */
+ }
+ else {
+ if (pm->op_pmflags & PMf_FOLD)
+ StructCopy(&savepm, pm, PMOP);
+ if (pm->op_pmshort)
+ fbm_compile(pm->op_pmshort, pm->op_pmflags & PMf_FOLD);
+ pm->op_pmregexp = regcomp(sv->sv_ptr,sv->sv_ptr+len,
+ pm->op_pmflags & PMf_FOLD);
+ hoistmust(pm);
+ }
+ got_pat:
--- /dev/null
+/* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:21:48 $
+ *
+ * Copyright (c) 1993, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: hash.c,v $
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+int
+mg_get(sv)
+SV* sv;
+{
+ MAGIC* mg;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ if (vtbl && vtbl->svt_get)
+ (*vtbl->svt_get)(sv, mg);
+ }
+ return 0;
+}
+
+int
+mg_set(sv)
+SV* sv;
+{
+ MAGIC* mg;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ if (vtbl && vtbl->svt_set)
+ (*vtbl->svt_set)(sv, mg);
+ }
+ return 0;
+}
+
+U32
+mg_len(sv)
+SV* sv;
+{
+ MAGIC* mg;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ if (vtbl && vtbl->svt_len)
+ return (*vtbl->svt_len)(sv, mg);
+ }
+ if (!SvPOK(sv) && SvNIOK(sv))
+ sv_2pv(sv);
+ if (SvPOK(sv))
+ return SvCUR(sv);
+ return 0;
+}
+
+int
+mg_clear(sv)
+SV* sv;
+{
+ MAGIC* mg;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ if (vtbl && vtbl->svt_clear)
+ (*vtbl->svt_clear)(sv, mg);
+ }
+ return 0;
+}
+
+int
+mg_free(sv, type)
+SV* sv;
+char type;
+{
+ MAGIC* mg;
+ MAGIC** mgp = &SvMAGIC(sv);
+ for (mg = *mgp; mg; mg = *mgp) {
+ if (mg->mg_type == type) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ *mgp = mg->mg_moremagic;
+ if (vtbl && vtbl->svt_free)
+ (*vtbl->svt_free)(sv, mg);
+ if (mg->mg_ptr)
+ Safefree(mg->mg_ptr);
+ Safefree(mg);
+ }
+ else
+ mgp = &mg->mg_moremagic;
+ }
+ return 0;
+}
+
+int
+mg_freeall(sv)
+SV* sv;
+{
+ MAGIC* mg;
+ MAGIC* moremagic;
+ for (mg = SvMAGIC(sv); mg; mg = moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ moremagic = mg->mg_moremagic;
+ if (vtbl && vtbl->svt_free)
+ (*vtbl->svt_free)(sv, mg);
+ if (mg->mg_ptr)
+ Safefree(mg->mg_ptr);
+ Safefree(mg);
+ }
+ SvMAGIC(sv) = 0;
+ return 0;
+}
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+#include <signal.h>
+#endif
+
+#ifdef VOIDSIG
+#define handlertype void
+#else
+#define handlertype int
+#endif
+
+static handlertype sighandler();
+
+int
+magic_get(sv, mg)
+SV *sv;
+MAGIC *mg;
+{
+ register I32 paren;
+ register char *s;
+ register I32 i;
+
+ switch (*mg->mg_ptr) {
+ case '\004': /* ^D */
+ sv_setiv(sv,(I32)(debug & 32767));
+ break;
+ case '\006': /* ^F */
+ sv_setiv(sv,(I32)maxsysfd);
+ break;
+ case '\t': /* ^I */
+ if (inplace)
+ sv_setpv(sv, inplace);
+ else
+ sv_setsv(sv,&sv_undef);
+ break;
+ case '\020': /* ^P */
+ sv_setiv(sv,(I32)perldb);
+ break;
+ case '\024': /* ^T */
+ sv_setiv(sv,(I32)basetime);
+ break;
+ case '\027': /* ^W */
+ sv_setiv(sv,(I32)dowarn);
+ break;
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': case '&':
+ if (curpm) {
+ paren = atoi(GvENAME(mg->mg_obj));
+ getparen:
+ if (curpm->op_pmregexp &&
+ paren <= curpm->op_pmregexp->nparens &&
+ (s = curpm->op_pmregexp->startp[paren]) ) {
+ i = curpm->op_pmregexp->endp[paren] - s;
+ if (i >= 0)
+ sv_setpvn(sv,s,i);
+ else
+ sv_setsv(sv,&sv_undef);
+ }
+ else
+ sv_setsv(sv,&sv_undef);
+ }
+ break;
+ case '+':
+ if (curpm) {
+ paren = curpm->op_pmregexp->lastparen;
+ goto getparen;
+ }
+ break;
+ case '`':
+ if (curpm) {
+ if (curpm->op_pmregexp &&
+ (s = curpm->op_pmregexp->subbeg) ) {
+ i = curpm->op_pmregexp->startp[0] - s;
+ if (i >= 0)
+ sv_setpvn(sv,s,i);
+ else
+ sv_setpvn(sv,"",0);
+ }
+ else
+ sv_setpvn(sv,"",0);
+ }
+ break;
+ case '\'':
+ if (curpm) {
+ if (curpm->op_pmregexp &&
+ (s = curpm->op_pmregexp->endp[0]) ) {
+ sv_setpvn(sv,s, curpm->op_pmregexp->subend - s);
+ }
+ else
+ sv_setpvn(sv,"",0);
+ }
+ break;
+ case '.':
+#ifndef lint
+ if (last_in_gv && GvIO(last_in_gv)) {
+ sv_setiv(sv,(I32)GvIO(last_in_gv)->lines);
+ }
+#endif
+ break;
+ case '?':
+ sv_setiv(sv,(I32)statusvalue);
+ break;
+ case '^':
+ s = GvIO(defoutgv)->top_name;
+ if (s)
+ sv_setpv(sv,s);
+ else {
+ sv_setpv(sv,GvENAME(defoutgv));
+ sv_catpv(sv,"_TOP");
+ }
+ break;
+ case '~':
+ s = GvIO(defoutgv)->fmt_name;
+ if (!s)
+ s = GvENAME(defoutgv);
+ sv_setpv(sv,s);
+ break;
+#ifndef lint
+ case '=':
+ sv_setiv(sv,(I32)GvIO(defoutgv)->page_len);
+ break;
+ case '-':
+ sv_setiv(sv,(I32)GvIO(defoutgv)->lines_left);
+ break;
+ case '%':
+ sv_setiv(sv,(I32)GvIO(defoutgv)->page);
+ break;
+#endif
+ case ':':
+ break;
+ case '/':
+ break;
+ case '[':
+ sv_setiv(sv,(I32)arybase);
+ break;
+ case '|':
+ if (!GvIO(defoutgv))
+ GvIO(defoutgv) = newIO();
+ sv_setiv(sv, (GvIO(defoutgv)->flags & IOf_FLUSH) != 0 );
+ break;
+ case ',':
+ sv_setpvn(sv,ofs,ofslen);
+ break;
+ case '\\':
+ sv_setpvn(sv,ors,orslen);
+ break;
+ case '#':
+ sv_setpv(sv,ofmt);
+ break;
+ case '!':
+ sv_setnv(sv,(double)errno);
+ sv_setpv(sv, errno ? strerror(errno) : "");
+ SvNOK_on(sv); /* what a wonderful hack! */
+ break;
+ case '<':
+ sv_setiv(sv,(I32)uid);
+ break;
+ case '>':
+ sv_setiv(sv,(I32)euid);
+ break;
+ case '(':
+ s = buf;
+ (void)sprintf(s,"%d",(int)gid);
+ goto add_groups;
+ case ')':
+ s = buf;
+ (void)sprintf(s,"%d",(int)egid);
+ add_groups:
+ while (*s) s++;
+#ifdef HAS_GETGROUPS
+#ifndef NGROUPS
+#define NGROUPS 32
+#endif
+ {
+ GROUPSTYPE gary[NGROUPS];
+
+ i = getgroups(NGROUPS,gary);
+ while (--i >= 0) {
+ (void)sprintf(s," %ld", (long)gary[i]);
+ while (*s) s++;
+ }
+ }
+#endif
+ sv_setpv(sv,buf);
+ break;
+ case '*':
+ break;
+ case '0':
+ break;
+ }
+}
+
+int
+magic_getuvar(sv, mg)
+SV *sv;
+MAGIC *mg;
+{
+ struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
+
+ if (uf && uf->uf_val)
+ (*uf->uf_val)(uf->uf_index, sv);
+ return 0;
+}
+
+int
+magic_setenv(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ register char *s;
+ I32 i;
+ s = SvPV(sv);
+ my_setenv(mg->mg_ptr,s);
+ /* And you'll never guess what the dog had */
+ /* in its mouth... */
+#ifdef TAINT
+ if (s && strEQ(mg->mg_ptr,"PATH")) {
+ char *strend = SvEND(sv);
+
+ while (s < strend) {
+ s = cpytill(tokenbuf,s,strend,':',&i);
+ s++;
+ if (*tokenbuf != '/'
+ || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
+ sv->sv_tainted = 2;
+ }
+ }
+#endif
+ return 0;
+}
+
+int
+magic_setsig(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ register char *s;
+ I32 i;
+ s = SvPV(sv);
+ i = whichsig(mg->mg_ptr); /* ...no, a brick */
+ if (!i && (dowarn || strEQ(mg->mg_ptr,"ALARM")))
+ warn("No such signal: SIG%s", mg->mg_ptr);
+ if (strEQ(s,"IGNORE"))
+#ifndef lint
+ (void)signal(i,SIG_IGN);
+#else
+ ;
+#endif
+ else if (strEQ(s,"DEFAULT") || !*s)
+ (void)signal(i,SIG_DFL);
+ else {
+ (void)signal(i,sighandler);
+ if (!index(s,'\'')) {
+ sprintf(tokenbuf, "main'%s",s);
+ sv_setpv(sv,tokenbuf);
+ }
+ }
+ return 0;
+}
+
+int
+magic_setdbm(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ HV* hv = (HV*)mg->mg_obj;
+ hv_dbmstore(hv,mg->mg_ptr,mg->mg_len,sv); /* XXX slurp? */
+ return 0;
+}
+
+int
+magic_setdbline(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ OP *o;
+ I32 i;
+ GV* gv;
+ SV** svp;
+
+ gv = DBline;
+ i = SvTRUE(sv);
+ svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
+ if (svp && SvMAGICAL(*svp) && (o = (OP*)SvMAGIC(*svp)->mg_ptr)) {
+#ifdef NOTDEF
+ cmd->cop_flags &= ~COPf_OPTIMIZE;
+ cmd->cop_flags |= i? COPo_D1 : COPo_D0;
+#endif
+ }
+ else
+ warn("Can't break at that line\n");
+ return 0;
+}
+
+int
+magic_getarylen(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + arybase);
+ return 0;
+}
+
+int
+magic_setarylen(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ av_fill((AV*)mg->mg_obj, (SvIOK(sv) ? SvIV(sv) : sv_2iv(sv)) - arybase);
+ return 0;
+}
+
+int
+magic_getglob(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
+ return 0;
+}
+
+int
+magic_setglob(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ register char *s;
+ GV* gv;
+
+ if (!SvOK(sv))
+ return 0;
+ s = SvPOK(sv) ? SvPV(sv) : sv_2pv(sv);
+ if (*s == '*' && s[1])
+ s++;
+ gv = gv_fetchpv(s,TRUE);
+ if (sv == (SV*)gv)
+ return 0;
+ if (GvGP(sv))
+ gp_free(sv);
+ GvGP(sv) = gp_ref(GvGP(gv));
+ if (!GvAV(gv))
+ gv_AVadd(gv);
+ if (!GvHV(gv))
+ gv_HVadd(gv);
+ if (!GvIO(gv))
+ GvIO(gv) = newIO();
+ return 0;
+}
+
+int
+magic_setsubstr(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ char *tmps = SvPV(sv);
+ if (!tmps)
+ tmps = "";
+ sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps,SvCUR(sv));
+ return 0;
+}
+
+int
+magic_setvec(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ do_vecset(sv); /* XXX slurp this routine */
+ return 0;
+}
+
+int
+magic_setbm(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ mg_free(sv, 'B');
+ SvVALID_off(sv);
+ return 0;
+}
+
+int
+magic_setuvar(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
+
+ if (uf && uf->uf_set)
+ (*uf->uf_set)(uf->uf_index, sv);
+ return 0;
+}
+
+int
+magic_set(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ register char *s;
+ I32 i;
+ switch (*mg->mg_ptr) {
+ case '\004': /* ^D */
+ debug = (SvIOK(sv) ? SvIV(sv) : sv_2iv(sv)) | 32768;
+ DEBUG_x(dump_all());
+ break;
+ case '\006': /* ^F */
+ maxsysfd = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv);
+ break;
+ case '\t': /* ^I */
+ if (inplace)
+ Safefree(inplace);
+ if (SvOK(sv))
+ inplace = savestr(SvPV(sv));
+ else
+ inplace = Nullch;
+ break;
+ case '\020': /* ^P */
+ i = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv);
+ if (i != perldb) {
+ if (perldb)
+ oldlastpm = curpm;
+ else
+ curpm = oldlastpm;
+ }
+ perldb = i;
+ break;
+ case '\024': /* ^T */
+ basetime = (time_t)(SvIOK(sv) ? SvIV(sv) : sv_2iv(sv));
+ break;
+ case '\027': /* ^W */
+ dowarn = (bool)(SvIOK(sv) ? SvIV(sv) : sv_2iv(sv));
+ break;
+ case '.':
+ if (localizing)
+ save_sptr((SV**)&last_in_gv);
+ break;
+ case '^':
+ Safefree(GvIO(defoutgv)->top_name);
+ GvIO(defoutgv)->top_name = s = savestr(SvPV(sv));
+ GvIO(defoutgv)->top_gv = gv_fetchpv(s,TRUE);
+ break;
+ case '~':
+ Safefree(GvIO(defoutgv)->fmt_name);
+ GvIO(defoutgv)->fmt_name = s = savestr(SvPV(sv));
+ GvIO(defoutgv)->fmt_gv = gv_fetchpv(s,TRUE);
+ break;
+ case '=':
+ GvIO(defoutgv)->page_len = (long)(SvIOK(sv) ? SvIV(sv) : sv_2iv(sv));
+ break;
+ case '-':
+ GvIO(defoutgv)->lines_left = (long)(SvIOK(sv) ? SvIV(sv) : sv_2iv(sv));
+ if (GvIO(defoutgv)->lines_left < 0L)
+ GvIO(defoutgv)->lines_left = 0L;
+ break;
+ case '%':
+ GvIO(defoutgv)->page = (long)(SvIOK(sv) ? SvIV(sv) : sv_2iv(sv));
+ break;
+ case '|':
+ if (!GvIO(defoutgv))
+ GvIO(defoutgv) = newIO();
+ GvIO(defoutgv)->flags &= ~IOf_FLUSH;
+ if ((SvIOK(sv) ? SvIV(sv) : sv_2iv(sv)) != 0) {
+ GvIO(defoutgv)->flags |= IOf_FLUSH;
+ }
+ break;
+ case '*':
+ i = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv);
+ multiline = (i != 0);
+ break;
+ case '/':
+ if (SvPOK(sv)) {
+ rs = SvPV(sv);
+ rslen = SvCUR(sv);
+ if (rspara = !rslen) {
+ rs = "\n\n";
+ rslen = 2;
+ }
+ rschar = rs[rslen - 1];
+ }
+ else {
+ rschar = 0777; /* fake a non-existent char */
+ rslen = 1;
+ }
+ break;
+ case '\\':
+ if (ors)
+ Safefree(ors);
+ ors = savestr(SvPV(sv));
+ orslen = SvCUR(sv);
+ break;
+ case ',':
+ if (ofs)
+ Safefree(ofs);
+ ofs = savestr(SvPV(sv));
+ ofslen = SvCUR(sv);
+ break;
+ case '#':
+ if (ofmt)
+ Safefree(ofmt);
+ ofmt = savestr(SvPV(sv));
+ break;
+ case '[':
+ arybase = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv);
+ break;
+ case '?':
+ statusvalue = U_S(SvIOK(sv) ? SvIV(sv) : sv_2iv(sv));
+ break;
+ case '!':
+ errno = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv); /* will anyone ever use this? */
+ break;
+ case '<':
+ uid = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv);
+ if (delaymagic) {
+ delaymagic |= DM_RUID;
+ break; /* don't do magic till later */
+ }
+#ifdef HAS_SETRUID
+ (void)setruid((UIDTYPE)uid);
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1);
+#else
+ if (uid == euid) /* special case $< = $> */
+ (void)setuid(uid);
+ else
+ fatal("setruid() not implemented");
+#endif
+#endif
+ uid = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv);
+ break;
+ case '>':
+ euid = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv);
+ if (delaymagic) {
+ delaymagic |= DM_EUID;
+ break; /* don't do magic till later */
+ }
+#ifdef HAS_SETEUID
+ (void)seteuid((UIDTYPE)euid);
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid);
+#else
+ if (euid == uid) /* special case $> = $< */
+ setuid(euid);
+ else
+ fatal("seteuid() not implemented");
+#endif
+#endif
+ euid = (I32)geteuid();
+ break;
+ case '(':
+ gid = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv);
+ if (delaymagic) {
+ delaymagic |= DM_RGID;
+ break; /* don't do magic till later */
+ }
+#ifdef HAS_SETRGID
+ (void)setrgid((GIDTYPE)gid);
+#else
+#ifdef HAS_SETREGID
+ (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
+#else
+ if (gid == egid) /* special case $( = $) */
+ (void)setgid(gid);
+ else
+ fatal("setrgid() not implemented");
+#endif
+#endif
+ gid = (I32)getgid();
+ break;
+ case ')':
+ egid = SvIOK(sv) ? SvIV(sv) : sv_2iv(sv);
+ if (delaymagic) {
+ delaymagic |= DM_EGID;
+ break; /* don't do magic till later */
+ }
+#ifdef HAS_SETEGID
+ (void)setegid((GIDTYPE)egid);
+#else
+#ifdef HAS_SETREGID
+ (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
+#else
+ if (egid == gid) /* special case $) = $( */
+ (void)setgid(egid);
+ else
+ fatal("setegid() not implemented");
+#endif
+#endif
+ egid = (I32)getegid();
+ break;
+ case ':':
+ chopset = SvPV(sv);
+ break;
+ case '0':
+ if (!origalen) {
+ s = origargv[0];
+ s += strlen(s);
+ /* See if all the arguments are contiguous in memory */
+ for (i = 1; i < origargc; i++) {
+ if (origargv[i] == s + 1)
+ s += strlen(++s); /* this one is ok too */
+ }
+ if (origenviron[0] == s + 1) { /* can grab env area too? */
+ my_setenv("NoNeSuCh", Nullch);
+ /* force copy of environment */
+ for (i = 0; origenviron[i]; i++)
+ if (origenviron[i] == s + 1)
+ s += strlen(++s);
+ }
+ origalen = s - origargv[0];
+ }
+ s = SvPV(sv);
+ i = SvCUR(sv);
+ if (i >= origalen) {
+ i = origalen;
+ SvCUR_set(sv, i);
+ *SvEND(sv) = '\0';
+ Copy(s, origargv[0], i, char);
+ }
+ else {
+ Copy(s, origargv[0], i, char);
+ s = origargv[0]+i;
+ *s++ = '\0';
+ while (++i < origalen)
+ *s++ = ' ';
+ }
+ break;
+ }
+ return 0;
+}
+
+I32
+whichsig(sig)
+char *sig;
+{
+ register char **sigv;
+
+ for (sigv = sig_name+1; *sigv; sigv++)
+ if (strEQ(sig,*sigv))
+ return sigv - sig_name;
+#ifdef SIGCLD
+ if (strEQ(sig,"CHLD"))
+ return SIGCLD;
+#endif
+#ifdef SIGCHLD
+ if (strEQ(sig,"CLD"))
+ return SIGCHLD;
+#endif
+ return 0;
+}
+
+static handlertype
+sighandler(sig)
+I32 sig;
+{
+ dSP;
+ GV *gv;
+ SV *sv;
+ CV *cv;
+ CONTEXT *cx;
+ AV *oldstack;
+ I32 hasargs = 1;
+ I32 items = 1;
+ I32 gimme = G_SCALAR;
+
+#ifdef OS2 /* or anybody else who requires SIG_ACK */
+ signal(sig, SIG_ACK);
+#endif
+
+ gv = gv_fetchpv(
+ SvPVnx(*hv_fetch(GvHVn(siggv),sig_name[sig],strlen(sig_name[sig]),
+ TRUE)), TRUE);
+ cv = GvCV(gv);
+ if (!cv && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
+ if (sig_name[sig][1] == 'H')
+ gv = gv_fetchpv(SvPVnx(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE)),
+ TRUE);
+ else
+ gv = gv_fetchpv(SvPVnx(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE)),
+ TRUE);
+ cv = GvCV(gv); /* gag */
+ }
+ if (!cv) {
+ if (dowarn)
+ warn("SIG%s handler \"%s\" not defined.\n",
+ sig_name[sig], GvENAME(gv) );
+ return;
+ }
+
+ oldstack = stack;
+ SWITCHSTACK(stack, signalstack);
+
+ sv = sv_mortalcopy(&sv_undef);
+ sv_setpv(sv,sig_name[sig]);
+ PUSHs(sv);
+
+ ENTER;
+ SAVETMPS;
+
+ push_return(op);
+ push_return(0);
+ PUSHBLOCK(cx, CXt_SUB, sp);
+ PUSHSUB(cx);
+ cx->blk_sub.savearray = GvAV(defgv);
+ cx->blk_sub.argarray = av_fake(items, sp);
+ GvAV(defgv) = cx->blk_sub.argarray;
+ CvDEPTH(cv)++;
+ if (CvDEPTH(cv) >= 2) {
+ if (CvDEPTH(cv) == 100 && dowarn)
+ warn("Deep recursion on subroutine \"%s\"",GvENAME(gv));
+ }
+ op = CvSTART(cv);
+ PUTBACK;
+ run(); /* Does the LEAVE for us. */
+
+ SWITCHSTACK(signalstack, oldstack);
+ op = pop_return();
+
+ return;
+}
+
+#ifdef OLD
+ if (sv->sv_magic && !sv->sv_rare) {
+ GV *gv = sv->sv_magic->sv_u.sv_gv;
+
+ switch (*SvPV(gv->sv_magic)) {
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': case '&':
+ if (curpm) {
+ paren = atoi(GvENAME(gv));
+ getparen:
+ if (curpm->op_pmregexp &&
+ paren <= curpm->op_pmregexp->nparens &&
+ (s = curpm->op_pmregexp->startp[paren]) ) {
+ i = curpm->op_pmregexp->endp[paren] - s;
+ if (i >= 0)
+ return i;
+ else
+ return 0;
+ }
+ else
+ return 0;
+ }
+ break;
+ case '+':
+ if (curpm) {
+ paren = curpm->op_pmregexp->lastparen;
+ goto getparen;
+ }
+ break;
+ case '`':
+ if (curpm) {
+ if (curpm->op_pmregexp &&
+ (s = curpm->op_pmregexp->subbeg) ) {
+ i = curpm->op_pmregexp->startp[0] - s;
+ if (i >= 0)
+ return i;
+ else
+ return 0;
+ }
+ else
+ return 0;
+ }
+ break;
+ case '\'':
+ if (curpm) {
+ if (curpm->op_pmregexp &&
+ (s = curpm->op_pmregexp->endp[0]) ) {
+ return (STRLEN) (curpm->op_pmregexp->subend - s);
+ }
+ else
+ return 0;
+ }
+ break;
+ case ',':
+ return (STRLEN)ofslen;
+ case '\\':
+ return (STRLEN)orslen;
+ }
+ sv = gv_str(sv);
+ }
+#endif
--- /dev/null
+/* $RCSfile: arg.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:16 $
+ *
+ * Copyright (c) 1993, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: arg.h,v $
+ */
+
+struct mgvtbl {
+ int (*svt_get) P((SV *sv, MAGIC* mg));
+ int (*svt_set) P((SV *sv, MAGIC* mg));
+ U32 (*svt_len) P((SV *sv, MAGIC* mg));
+ int (*svt_clear) P((SV *sv, MAGIC* mg));
+ int (*svt_free) P((SV *sv, MAGIC* mg));
+};
+
+struct magic {
+ MAGIC* mg_moremagic;
+ MGVTBL* mg_virtual; /* pointer to magic functions */
+ U16 mg_private;
+ char mg_type;
+ U8 mg_flags;
+ SV* mg_obj;
+ char* mg_ptr;
+ U32 mg_len;
+};
-/* $RCSfile: dir.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:10 $
+/* $RCSfile: dir.h,v $$Revision: 4.1 $$Date: 92/08/07 18:24:41 $
*
* (C) Copyright 1987, 1990 Diomidis Spinellis.
*
* License or the Artistic License, as specified in the README file.
*
* $Log: dir.h,v $
+ * Revision 4.1 92/08/07 18:24:41 lwall
+ *
* Revision 4.0.1.1 91/06/07 11:22:10 lwall
* patch4: new copyright notice
*
-/* $RCSfile: directory.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:24 $
+/* $RCSfile: directory.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:42 $
*
* (C) Copyright 1987, 1988, 1990 Diomidis Spinellis.
*
* License or the Artistic License, as specified in the README file.
*
* $Log: directory.c,v $
+ * Revision 4.1 92/08/07 18:24:42 lwall
+ *
* Revision 4.0.1.1 91/06/07 11:22:24 lwall
* patch4: new copyright notice
*
#define PATHLEN 65
#ifndef lint
-static char rcsid[] = "$RCSfile: directory.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:24 $";
+static char rcsid[] = "$RCSfile: directory.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:42 $";
#endif
DIR *
-/* $RCSfile: msdos.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:37 $
+/* $RCSfile: msdos.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:49 $
*
* (C) Copyright 1989, 1990 Diomidis Spinellis.
*
* License or the Artistic License, as specified in the README file.
*
* $Log: msdos.c,v $
+ * Revision 4.1 92/08/07 18:24:49 lwall
+ *
* Revision 4.0.1.1 91/06/07 11:22:37 lwall
* patch4: new copyright notice
*
-/* $RCSfile: popen.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:52 $
+/* $RCSfile: popen.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:50 $
*
* (C) Copyright 1988, 1990 Diomidis Spinellis.
*
* License or the Artistic License, as specified in the README file.
*
* $Log: popen.c,v $
+ * Revision 4.1 92/08/07 18:24:50 lwall
+ *
* Revision 4.0.1.1 91/06/07 11:22:52 lwall
* patch4: new copyright notice
*
--- /dev/null
+/scalpel/lwall/netperl
\ No newline at end of file
--- /dev/null
+#!./perl
+
+package OBJ;
+
+@ISA = BASEOBJ;
+
+$main'object = bless {FOO => foo, BAR => bar};
+
+package main;
+
+$object->mymethod("BAR");
+
+mymethod $object "FOO";
+
+#&mymethod($object, "BAR");
+
+sub BASEOBJ'mymethod {
+ local $ref = shift;
+ print ref $ref, "\n";
+ print $ref->{shift}, "\n";
+}
--- /dev/null
+#ifdef NOTDEF
+ if (go_to) {
+ if (op->cop_label && strEQ(go_to,op->cop_label))
+ goto_targ = go_to = Nullch; /* here at last */
+ else {
+ switch (op->cop_type) {
+ case COP_IF:
+ oldspat = curspat;
+ oldsave = savestack->av_fill;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ retstr = &sv_yes;
+ newsp = -2;
+ if (op->uop.ccop_true) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ deb_growlevel();
+ }
+#endif
+ newsp = cop_exec(op->uop.ccop_true,gimme && (opflags & COPf_TERM),sp);
+ st = stack->av_array; /* possibly reallocated */
+ retstr = st[newsp];
+ }
+ if (!goto_targ)
+ go_to = Nullch;
+ curspat = oldspat;
+ if (savestack->av_fill > oldsave)
+ leave_scope(oldsave);
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ op = op->uop.ccop_alt;
+ goto tail_recursion_entry;
+ case COP_ELSE:
+ oldspat = curspat;
+ oldsave = savestack->av_fill;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ retstr = &sv_undef;
+ newsp = -2;
+ if (op->uop.ccop_true) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 'e';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ deb_growlevel();
+ }
+#endif
+ newsp = cop_exec(op->uop.ccop_true,gimme && (opflags & COPf_TERM),sp);
+ st = stack->av_array; /* possibly reallocated */
+ retstr = st[newsp];
+ }
+ if (!goto_targ)
+ go_to = Nullch;
+ curspat = oldspat;
+ if (savestack->av_fill > oldsave)
+ leave_scope(oldsave);
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ break;
+ case COP_BLOCK:
+ case COP_WHILE:
+ if (!(opflags & COPf_ONCE)) {
+ opflags |= COPf_ONCE;
+ if (++loop_ptr >= loop_max) {
+ loop_max += 128;
+ Renew(loop_stack, loop_max, struct loop);
+ }
+ loop_stack[loop_ptr].loop_label = op->cop_label;
+ loop_stack[loop_ptr].loop_sp = sp;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d %s)\n",
+ loop_ptr, op->cop_label ? op->cop_label : "");
+ }
+#endif
+ }
+#ifdef JMPCLOBBER
+ opparm = op;
+#endif
+ match = setjmp(loop_stack[loop_ptr].loop_env);
+ if (match) {
+ st = stack->av_array; /* possibly reallocated */
+#ifdef JMPCLOBBER
+ op = opparm;
+ opflags = op->cop_flags|COPf_ONCE;
+#endif
+ if (savestack->av_fill > oldsave)
+ leave_scope(oldsave);
+ switch (match) {
+ default:
+ fatal("longjmp returned bad value (%d)",match);
+ case OP_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_op;
+ case OP_NEXT: /* not done unless go_to found */
+ go_to = Nullch;
+#ifdef JMPCLOBBER
+ newsp = -2;
+ retstr = &sv_undef;
+#endif
+ goto next_iter;
+ case OP_REDO: /* not done unless go_to found */
+ go_to = Nullch;
+#ifdef JMPCLOBBER
+ newsp = -2;
+ retstr = &sv_undef;
+#endif
+ goto doit;
+ }
+ }
+ oldspat = curspat;
+ oldsave = savestack->av_fill;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ if (op->uop.ccop_true) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ deb_growlevel();
+ }
+#endif
+ newsp = cop_exec(op->uop.ccop_true,gimme && (opflags & COPf_TERM),sp);
+ st = stack->av_array; /* possibly reallocated */
+ if (newsp >= 0)
+ retstr = st[newsp];
+ }
+ if (!goto_targ) {
+ go_to = Nullch;
+ goto next_iter;
+ }
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ if (op->uop.ccop_alt) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 'a';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ deb_growlevel();
+ }
+#endif
+ newsp = cop_exec(op->uop.ccop_alt,gimme && (opflags & COPf_TERM),sp);
+ st = stack->av_array; /* possibly reallocated */
+ if (newsp >= 0)
+ retstr = st[newsp];
+ }
+ if (goto_targ)
+ break;
+ go_to = Nullch;
+ goto finish_while;
+ }
+ op = op->cop_next;
+ if (op && op->cop_head == op)
+ /* reached end of while loop */
+ return sp; /* targ isn't in this block */
+ if (opflags & COPf_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;
+ }
+ }
+#endif
+
+#ifdef DEBUGGING
+ if (debug) {
+ if (debug & 2) {
+ deb("%s (%lx) r%lx t%lx a%lx n%lx cs%lx\n",
+ cop_name[op->cop_type],op,op->cop_expr,
+ op->uop.ccop_true,op->uop.ccop_alt,op->cop_next,
+ curspat);
+ }
+ debname[dlevel] = cop_name[op->cop_type][0];
+ debdelim[dlevel] = '!';
+ if (++dlevel >= dlmax)
+ deb_growlevel();
+ }
+#endif
+
+ /* Here is some common optimization */
+
+ if (opflags & COPf_COND) {
+ switch (opflags & COPf_OPTIMIZE) {
+
+ case COPo_FALSE:
+ retstr = op->cop_short;
+ newsp = -2;
+ match = FALSE;
+ if (opflags & COPf_NESURE)
+ goto maybe;
+ break;
+ case COPo_TRUE:
+ retstr = op->cop_short;
+ newsp = -2;
+ match = TRUE;
+ if (opflags & COPf_EQSURE)
+ goto flipmaybe;
+ break;
+
+ case COPo_REG:
+ retstr = GV_STR(op->cop_stab);
+ newsp = -2;
+ match = SvTRUE(retstr); /* => retstr = retstr, c2 should fix */
+ if (opflags & (match ? COPf_EQSURE : COPf_NESURE))
+ goto flipmaybe;
+ break;
+
+ case COPo_ANCHOR: /* /^pat/ optimization */
+ if (multiline) {
+ if (*op->cop_short->sv_ptr && !(opflags & COPf_EQSURE))
+ goto scanner; /* just unanchor it */
+ else
+ break; /* must evaluate */
+ }
+ match = 0;
+ goto strop;
+
+ case COPo_STROP: /* string op optimization */
+ match = 1;
+ strop:
+ retstr = GV_STR(op->cop_stab);
+ newsp = -2;
+#ifndef I286
+ if (*op->cop_short->sv_ptr == *SvPV(retstr) &&
+ (match ? retstr->sv_cur == op->cop_slen - 1 :
+ retstr->sv_cur >= op->cop_slen) &&
+ bcmp(op->cop_short->sv_ptr, SvPV(retstr),
+ op->cop_slen) == 0 ) {
+ if (opflags & COPf_EQSURE) {
+ if (sawampersand && (opflags & COPf_OPTIMIZE) != COPo_STROP) {
+ curspat = Nullpm;
+ if (leftstab)
+ sv_setpvn(GvSV(leftstab),"",0);
+ if (amperstab)
+ sv_setsv(GvSV(amperstab),op->cop_short);
+ if (rightstab)
+ sv_setpvn(GvSV(rightstab),
+ retstr->sv_ptr + op->cop_slen,
+ retstr->sv_cur - op->cop_slen);
+ }
+ if (op->cop_spat)
+ lastspat = op->cop_spat;
+ match = !(opflags & COPf_FIRSTNEG);
+ retstr = match ? &sv_yes : &sv_no;
+ goto flipmaybe;
+ }
+ }
+ else if (opflags & COPf_NESURE) {
+ match = opflags & COPf_FIRSTNEG;
+ retstr = match ? &sv_yes : &sv_no;
+ goto flipmaybe;
+ }
+#else
+ {
+ char *zap1, *zap2, zap1c, zap2c;
+ int zaplen;
+ int lenok;
+
+ zap1 = op->cop_short->sv_ptr;
+ zap2 = SvPV(retstr);
+ zap1c = *zap1;
+ zap2c = *zap2;
+ zaplen = op->cop_slen;
+ if (match)
+ lenok = (retstr->sv_cur == op->cop_slen - 1);
+ else
+ lenok = (retstr->sv_cur >= op->cop_slen);
+ if ((zap1c == zap2c) && lenok && (bcmp(zap1, zap2, zaplen) == 0)) {
+ if (opflags & COPf_EQSURE) {
+ if (sawampersand &&
+ (opflags & COPf_OPTIMIZE) != COPo_STROP) {
+ curspat = Nullpm;
+ if (leftstab)
+ sv_setpvn(GvSV(leftstab),"",0);
+ if (amperstab)
+ sv_setsv(GvSV(amperstab),op->cop_short);
+ if (rightstab)
+ sv_setpvn(GvSV(rightstab),
+ retstr->sv_ptr + op->cop_slen,
+ retstr->sv_cur - op->cop_slen);
+ }
+ if (op->cop_spat)
+ lastspat = op->cop_spat;
+ match = !(opflags & COPf_FIRSTNEG);
+ retstr = match ? &sv_yes : &sv_no;
+ goto flipmaybe;
+ }
+ }
+ else if (opflags & COPf_NESURE) {
+ match = opflags & COPf_FIRSTNEG;
+ retstr = match ? &sv_yes : &sv_no;
+ goto flipmaybe;
+ }
+ }
+#endif
+ break; /* must evaluate */
+
+ case COPo_SCAN: /* non-anchored search */
+ scanner:
+ retstr = GV_STR(op->cop_stab);
+ newsp = -2;
+ if (retstr->sv_pok & SVp_STUDIED)
+ if (screamfirst[op->cop_short->sv_rare] >= 0)
+ tmps = screaminstr(retstr, op->cop_short);
+ else
+ tmps = Nullch;
+ else {
+ tmps = SvPV(retstr); /* make sure it's pok */
+#ifndef lint
+ tmps = fbm_instr((unsigned char*)tmps,
+ (unsigned char*)tmps + retstr->sv_cur, op->cop_short);
+#endif
+ }
+ if (tmps) {
+ if (opflags & COPf_EQSURE) {
+ ++op->cop_short->sv_u.sv_useful;
+ if (sawampersand) {
+ curspat = Nullpm;
+ if (leftstab)
+ sv_setpvn(GvSV(leftstab),retstr->sv_ptr,
+ tmps - retstr->sv_ptr);
+ if (amperstab)
+ sv_setpvn(GvSV(amperstab),
+ tmps, op->cop_short->sv_cur);
+ if (rightstab)
+ sv_setpvn(GvSV(rightstab),
+ tmps + op->cop_short->sv_cur,
+ retstr->sv_cur - (tmps - retstr->sv_ptr) -
+ op->cop_short->sv_cur);
+ }
+ lastspat = op->cop_spat;
+ match = !(opflags & COPf_FIRSTNEG);
+ retstr = match ? &sv_yes : &sv_no;
+ goto flipmaybe;
+ }
+ else
+ hint = tmps;
+ }
+ else {
+ if (opflags & COPf_NESURE) {
+ ++op->cop_short->sv_u.sv_useful;
+ match = opflags & COPf_FIRSTNEG;
+ retstr = match ? &sv_yes : &sv_no;
+ goto flipmaybe;
+ }
+ }
+ if (--op->cop_short->sv_u.sv_useful < 0) {
+ opflags &= ~COPf_OPTIMIZE;
+ opflags |= COPo_EVAL; /* never try this optimization again */
+ op->cop_flags = (opflags & ~COPf_ONCE);
+ }
+ break; /* must evaluate */
+
+ case COPo_NUMOP: /* numeric op optimization */
+ retstr = GV_STR(op->cop_stab);
+ newsp = -2;
+ switch (op->cop_slen) {
+ case OP_EQ:
+ if (dowarn) {
+ if ((!retstr->sv_nok && !looks_like_number(retstr)))
+ warn("Possible use of == on string value");
+ }
+ match = (SvNV(retstr) == op->cop_short->sv_u.sv_nv);
+ break;
+ case OP_NE:
+ match = (SvNV(retstr) != op->cop_short->sv_u.sv_nv);
+ break;
+ case OP_LT:
+ match = (SvNV(retstr) < op->cop_short->sv_u.sv_nv);
+ break;
+ case OP_LE:
+ match = (SvNV(retstr) <= op->cop_short->sv_u.sv_nv);
+ break;
+ case OP_GT:
+ match = (SvNV(retstr) > op->cop_short->sv_u.sv_nv);
+ break;
+ case OP_GE:
+ match = (SvNV(retstr) >= op->cop_short->sv_u.sv_nv);
+ break;
+ }
+ if (match) {
+ if (opflags & COPf_EQSURE) {
+ retstr = &sv_yes;
+ goto flipmaybe;
+ }
+ }
+ else if (opflags & COPf_NESURE) {
+ retstr = &sv_no;
+ goto flipmaybe;
+ }
+ break; /* must evaluate */
+
+ case COPo_INDGETS: /* while (<$foo>) */
+ last_in_stab = newGV(SvPV(GV_STR(op->cop_stab)),TRUE);
+ if (!GvIO(last_in_stab))
+ GvIO(last_in_stab) = newIO();
+ goto dogets;
+ case COPo_GETS: /* really a while (<file>) */
+ last_in_stab = op->cop_stab;
+ dogets:
+ fp = GvIO(last_in_stab)->ifp;
+ retstr = GvSV(defstab);
+ newsp = -2;
+ keepgoing:
+ if (fp && sv_gets(retstr, fp, 0)) {
+ if (*retstr->sv_ptr == '0' && retstr->sv_cur == 1)
+ match = FALSE;
+ else
+ match = TRUE;
+ GvIO(last_in_stab)->lines++;
+ }
+ else if (GvIO(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);
+ GvIO(last_in_stab)->flags |= IOf_START;
+ retstr = &sv_undef;
+ match = FALSE;
+ }
+ else {
+ retstr = &sv_undef;
+ match = FALSE;
+ }
+ goto flipmaybe;
+ case COPo_EVAL:
+ break;
+ case COPo_UNFLIP:
+ while (tmps_max > tmps_base) { /* clean up after last oldeval */
+ sv_free(tmps_list[tmps_max]);
+ tmps_list[tmps_max--] = Nullsv;
+ }
+ newsp = oldeval(Nullsv,op->cop_expr,gimme && (opflags & COPf_TERM),sp);
+ st = stack->av_array; /* possibly reallocated */
+ retstr = st[newsp];
+ match = SvTRUE(retstr);
+ if (op->cop_expr->arg_type == OP_FLIP) /* undid itself? */
+ opflags = copyopt(op,op->cop_expr[3].arg_ptr.arg_op);
+ goto maybe;
+ case COPo_CHOP:
+ retstr = GvSV(op->cop_stab);
+ newsp = -2;
+ match = (retstr->sv_cur != 0);
+ tmps = SvPV(retstr);
+ tmps += retstr->sv_cur - match;
+ sv_setpvn(&strchop,tmps,match);
+ *tmps = '\0';
+ retstr->sv_nok = 0;
+ retstr->sv_cur = tmps - retstr->sv_ptr;
+ SvSETMAGIC(retstr);
+ retstr = &strchop;
+ goto flipmaybe;
+ case COPo_ARRAY:
+ match = op->cop_short->sv_u.sv_useful; /* just to get register */
+
+ if (match < 0) { /* first time through here? */
+ ar = GvAVn(op->cop_expr[1].arg_ptr.arg_stab);
+ aryoptsave = savestack->av_fill;
+ save_sptr(&GvSV(op->cop_stab));
+ save_long(&op->cop_short->sv_u.sv_useful);
+ }
+ else {
+ ar = GvAV(op->cop_expr[1].arg_ptr.arg_stab);
+ if (op->cop_type != COP_WHILE && savestack->av_fill > firstsave)
+ leave_scope(firstsave);
+ }
+
+ if (match >= ar->av_fill) { /* we're in LAST, probably */
+ if (match < 0 && /* er, probably not... */
+ savestack->av_fill > aryoptsave)
+ leave_scope(aryoptsave);
+ retstr = &sv_undef;
+ op->cop_short->sv_u.sv_useful = -1; /* actually redundant */
+ match = FALSE;
+ }
+ else {
+ match++;
+ if (!(retstr = ar->av_array[match]))
+ retstr = av_fetch(ar,match,TRUE);
+ GvSV(op->cop_stab) = retstr;
+ op->cop_short->sv_u.sv_useful = match;
+ match = TRUE;
+ }
+ newsp = -2;
+ goto maybe;
+ case COPo_D1:
+ break;
+ case COPo_D0:
+ if (DBsingle->sv_u.sv_nv != 0)
+ break;
+ if (DBsignal->sv_u.sv_nv != 0)
+ break;
+ if (DBtrace->sv_u.sv_nv != 0)
+ break;
+ goto next_op;
+ }
+
+ /* we have tried to make this normal case as abnormal as possible */
+
+ doeval:
+ if (gimme == G_ARRAY) {
+ lastretstr = Nullsv;
+ lastspbase = sp;
+ lastsize = newsp - sp;
+ if (lastsize < 0)
+ lastsize = 0;
+ }
+ else
+ lastretstr = retstr;
+ while (tmps_max > tmps_base) { /* clean up after last oldeval */
+ sv_free(tmps_list[tmps_max]);
+ tmps_list[tmps_max--] = Nullsv;
+ }
+ newsp = oldeval(Nullsv,op->cop_expr,
+ gimme && (opflags & COPf_TERM) && op->cop_type == COP_EXPR &&
+ !op->uop.acop_expr,
+ sp);
+ st = stack->av_array; /* possibly reallocated */
+ retstr = st[newsp];
+ if (newsp > sp && retstr)
+ match = SvTRUE(retstr);
+ else
+ match = FALSE;
+ goto maybe;
+
+ /* if flipflop was true, flop it */
+
+ flipmaybe:
+ if (match && opflags & COPf_FLIP) {
+ while (tmps_max > tmps_base) { /* clean up after last oldeval */
+ sv_free(tmps_list[tmps_max]);
+ tmps_list[tmps_max--] = Nullsv;
+ }
+ if (op->cop_expr->arg_type == OP_FLOP) { /* currently toggled? */
+ newsp = oldeval(Nullsv,op->cop_expr,G_SCALAR,sp);/*let oldeval undo it*/
+ opflags = copyopt(op,op->cop_expr[3].arg_ptr.arg_op);
+ }
+ else {
+ newsp = oldeval(Nullsv,op->cop_expr,G_SCALAR,sp);/* let oldeval do it */
+ if (op->cop_expr->arg_type == OP_FLOP) /* still toggled? */
+ opflags = copyopt(op,op->cop_expr[4].arg_ptr.arg_op);
+ }
+ }
+ else if (opflags & COPf_FLIP) {
+ if (op->cop_expr->arg_type == OP_FLOP) { /* currently toggled? */
+ match = TRUE; /* force on */
+ }
+ }
+
+ /* at this point, match says whether our expression was true */
+
+ maybe:
+ if (opflags & COPf_INVERT)
+ match = !match;
+ if (!match)
+ goto next_op;
+ }
+#ifdef TAINT
+ tainted = 0; /* modifier doesn't affect regular expression */
+#endif
--- /dev/null
+/* $RCSfile: cmd.h,v $$Revision: 4.1 $$Date: 92/08/07 17:19:19 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: cmd.h,v $
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+extern int yychar;
+
+/* Lowest byte of opargs */
+#define OA_MARK 1
+#define OA_FOLDCONST 2
+#define OA_RETSCALAR 4
+#define OA_TARGET 8
+#define OA_RETINTEGER 16
+#define OA_OTHERINT 32
+#define OA_DANGEROUS 64
+
+/* Remaining nybbles of opargs */
+#define OA_SCALAR 1
+#define OA_LIST 2
+#define OA_AVREF 3
+#define OA_HVREF 4
+#define OA_CVREF 5
+#define OA_FILEREF 6
+#define OA_SCALARREF 7
+#define OA_OPTIONAL 8
+
+I32 op_seq;
+
+void
+cpy7bit(d,s,l)
+register char *d;
+register char *s;
+register I32 l;
+{
+ while (l--)
+ *d++ = *s++ & 127;
+ *d = '\0';
+}
+
+int
+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++;
+ cpy7bit(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr);
+ sprintf(tname,"next 2 tokens \"%s\"",tmp2buf);
+ }
+ else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
+ oldbufptr != bufptr) {
+ while (isSPACE(*oldbufptr))
+ oldbufptr++;
+ cpy7bit(tmp2buf, oldbufptr, bufptr - oldbufptr);
+ sprintf(tname,"next token \"%s\"",tmp2buf);
+ }
+ else if (yychar > 255)
+ tname = "next token ???";
+ else if (!yychar || (yychar == ';' && !rsfp))
+ (void)strcpy(tname,"at EOF");
+ else if ((yychar & 127) == 127)
+ (void)strcpy(tname,"at end of line");
+ else if (yychar < 32)
+ (void)sprintf(tname,"next char ^%c",yychar+64);
+ else
+ (void)sprintf(tname,"next char %c",yychar);
+ (void)sprintf(buf, "%s at %s line %d, %s\n",
+ s,SvPV(GvSV(curcop->cop_filegv)),curcop->cop_line,tname);
+ if (curcop->cop_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)
+ sv_catpv(GvSV(gv_fetchpv("@",TRUE)),buf);
+ else
+ fputs(buf,stderr);
+ if (++error_count >= 10)
+ fatal("%s has too many errors.\n",
+ SvPV(GvSV(curcop->cop_filegv)));
+ return 0;
+}
+
+OP *
+no_fh_allowed(op)
+OP *op;
+{
+ sprintf(tokenbuf,"Missing comma after first argument to %s function",
+ op_name[op->op_type]);
+ yyerror(tokenbuf);
+ return op;
+}
+
+OP *
+too_few_arguments(op)
+OP *op;
+{
+ sprintf(tokenbuf,"Not enough arguments for %s", op_name[op->op_type]);
+ yyerror(tokenbuf);
+ return op;
+}
+
+OP *
+too_many_arguments(op)
+OP *op;
+{
+ sprintf(tokenbuf,"Too many arguments for %s", op_name[op->op_type]);
+ yyerror(tokenbuf);
+ return op;
+}
+
+/* "register" allocation */
+
+PADOFFSET
+pad_alloc(optype,tmptype)
+I32 optype;
+char tmptype;
+{
+ SV *sv;
+ I32 retval;
+
+ if (AvARRAY(comppad) != curpad)
+ fatal("panic: pad_alloc");
+ if (tmptype == 'M') {
+ do {
+ sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE);
+ } while (SvSTORAGE(sv)); /* need a fresh one */
+ retval = AvFILL(comppad);
+ }
+ else {
+ do {
+ sv = *av_fetch(comppad, ++padix, TRUE);
+ } while (SvSTORAGE(sv) == 'T' || SvSTORAGE(sv) == 'M');
+ retval = padix;
+ }
+ SvSTORAGE(sv) = tmptype;
+ curpad = AvARRAY(comppad);
+ DEBUG_X(fprintf(stderr, "Pad alloc %d for %s\n", retval, op_name[optype]));
+ return (PADOFFSET)retval;
+}
+
+SV *
+pad_sv(po)
+PADOFFSET po;
+{
+ if (!po)
+ fatal("panic: pad_sv po");
+ DEBUG_X(fprintf(stderr, "Pad sv %d\n", po));
+ return curpad[po]; /* eventually we'll turn this into a macro */
+}
+
+void
+pad_free(po)
+PADOFFSET po;
+{
+ if (AvARRAY(comppad) != curpad)
+ fatal("panic: pad_free curpad");
+ if (!po)
+ fatal("panic: pad_free po");
+ DEBUG_X(fprintf(stderr, "Pad free %d\n", po));
+ if (curpad[po])
+ SvSTORAGE(curpad[po]) = 'F';
+ if (po < padix)
+ padix = po - 1;
+}
+
+void
+pad_swipe(po)
+PADOFFSET po;
+{
+ if (AvARRAY(comppad) != curpad)
+ fatal("panic: pad_swipe curpad");
+ if (!po)
+ fatal("panic: pad_swipe po");
+ DEBUG_X(fprintf(stderr, "Pad swipe %d\n", po));
+ curpad[po] = NEWSV(0,0);
+ SvSTORAGE(curpad[po]) = 'F';
+ if (po < padix)
+ padix = po - 1;
+}
+
+void
+pad_reset()
+{
+ register I32 po;
+
+ if (AvARRAY(comppad) != curpad)
+ fatal("panic: pad_reset curpad");
+ DEBUG_X(fprintf(stderr, "Pad reset\n"));
+ for (po = AvMAX(comppad); po > 0; po--) {
+ if (curpad[po] && SvSTORAGE(curpad[po]) == 'T')
+ SvSTORAGE(curpad[po]) = 'F';
+ }
+ padix = 0;
+}
+
+/* Destructor */
+
+void
+op_free(op)
+OP *op;
+{
+ register OP *kid;
+
+ if (!op)
+ return;
+
+ if (op->op_flags & OPf_KIDS) {
+ for (kid = cUNOP->op_first; kid; kid = kid->op_sibling)
+ op_free(kid);
+ }
+
+ if (op->op_targ > 0)
+ pad_free(op->op_targ);
+
+ switch (op->op_type) {
+ case OP_GV:
+/*XXX sv_free(cGVOP->op_gv); */
+ break;
+ case OP_CONST:
+ sv_free(cSVOP->op_sv);
+ break;
+ }
+
+ Safefree(op);
+}
+
+/* Contextualizers */
+
+#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist(o))
+
+OP *
+linklist(op)
+OP *op;
+{
+ register OP *kid;
+
+ if (op->op_next)
+ return op->op_next;
+
+ /* establish postfix order */
+ if (cUNOP->op_first) {
+ op->op_next = LINKLIST(cUNOP->op_first);
+ for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ kid->op_next = LINKLIST(kid->op_sibling);
+ else
+ kid->op_next = op;
+ }
+ }
+ else
+ op->op_next = op;
+
+ return op->op_next;
+}
+
+OP *
+scalarkids(op)
+OP *op;
+{
+ OP *kid;
+ if (op && op->op_flags & OPf_KIDS) {
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ scalar(kid);
+ }
+ return op;
+}
+
+OP *
+scalar(op)
+OP *op;
+{
+ OP *kid;
+
+ if (!op || (op->op_flags & OPf_KNOW)) /* assumes no premature commitment */
+ return op;
+
+ op->op_flags &= ~OPf_LIST;
+ op->op_flags |= OPf_KNOW;
+
+ switch (op->op_type) {
+ case OP_REPEAT:
+ scalar(cBINOP->op_first);
+ return op;
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ break;
+ default:
+ case OP_MATCH:
+ case OP_SUBST:
+ case OP_NULL:
+ if (!(op->op_flags & OPf_KIDS))
+ return op;
+ break;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ case OP_LINESEQ:
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ scalarvoid(kid);
+ else
+ scalar(kid);
+ }
+ return op;
+ case OP_LIST:
+ op = prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), op);
+ break;
+ }
+ for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
+ scalar(kid);
+ return op;
+}
+
+OP *
+scalarvoid(op)
+OP *op;
+{
+ OP *kid;
+
+ if (!op)
+ return op;
+ if (op->op_flags & OPf_LIST)
+ return op;
+
+ op->op_flags |= OPf_KNOW;
+
+ switch (op->op_type) {
+ default:
+ return op;
+
+ case OP_CONST:
+ op->op_type = OP_NULL; /* don't execute a constant */
+ sv_free(cSVOP->op_sv); /* don't even remember it */
+ break;
+
+ case OP_POSTINC:
+ op->op_type = OP_PREINC;
+ op->op_ppaddr = ppaddr[OP_PREINC];
+ break;
+
+ case OP_POSTDEC:
+ op->op_type = OP_PREDEC;
+ op->op_ppaddr = ppaddr[OP_PREDEC];
+ break;
+
+ case OP_REPEAT:
+ scalarvoid(cBINOP->op_first);
+ break;
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
+ scalarvoid(kid);
+ break;
+ case OP_ENTERTRY:
+ case OP_ENTER:
+ case OP_SCALAR:
+ case OP_NULL:
+ if (!(op->op_flags & OPf_KIDS))
+ break;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ case OP_LINESEQ:
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ scalarvoid(kid);
+ break;
+ case OP_LIST:
+ op = prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), op);
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ scalarvoid(kid);
+ break;
+ }
+ return op;
+}
+
+OP *
+listkids(op)
+OP *op;
+{
+ OP *kid;
+ if (op && op->op_flags & OPf_KIDS) {
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ list(kid);
+ }
+ return op;
+}
+
+OP *
+list(op)
+OP *op;
+{
+ OP *kid;
+
+ if (!op || (op->op_flags & OPf_KNOW)) /* assumes no premature commitment */
+ return op;
+
+ op->op_flags |= (OPf_KNOW | OPf_LIST);
+
+ switch (op->op_type) {
+ case OP_FLOP:
+ case OP_REPEAT:
+ list(cBINOP->op_first);
+ break;
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
+ list(kid);
+ break;
+ default:
+ case OP_MATCH:
+ case OP_SUBST:
+ case OP_NULL:
+ if (!(op->op_flags & OPf_KIDS))
+ break;
+ if (!op->op_next && cUNOP->op_first->op_type == OP_FLOP) {
+ list(cBINOP->op_first);
+ return gen_constant_list(op);
+ }
+ case OP_LIST:
+ listkids(op);
+ break;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ case OP_LINESEQ:
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ scalarvoid(kid);
+ else
+ list(kid);
+ }
+ break;
+ }
+ return op;
+}
+
+OP *
+scalarseq(op)
+OP *op;
+{
+ OP *kid;
+
+ if (op &&
+ (op->op_type == OP_LINESEQ ||
+ op->op_type == OP_LEAVE ||
+ op->op_type == OP_LEAVETRY) )
+ {
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ scalarvoid(kid);
+ }
+ }
+ return op;
+}
+
+OP *
+refkids(op, type)
+OP *op;
+I32 type;
+{
+ OP *kid;
+ if (op && op->op_flags & OPf_KIDS) {
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ ref(kid, type);
+ }
+ return op;
+}
+
+static I32 refcount;
+
+OP *
+ref(op, type)
+OP *op;
+I32 type;
+{
+ OP *kid;
+ SV *sv;
+
+ if (!op)
+ return op;
+
+ switch (op->op_type) {
+ case OP_ENTERSUBR:
+ if ((type == OP_DEFINED || type == OP_UNDEF || type == OP_REFGEN) &&
+ !(op->op_flags & OPf_STACKED)) {
+ op->op_type = OP_NULL; /* disable entersubr */
+ op->op_ppaddr = ppaddr[OP_NULL];
+ cLISTOP->op_first->op_type = OP_NULL; /* disable pushmark */
+ cLISTOP->op_first->op_ppaddr = ppaddr[OP_NULL];
+ break;
+ }
+ /* FALL THROUGH */
+ default:
+ if (type == OP_DEFINED)
+ return scalar(op); /* ordinary expression, not lvalue */
+ sprintf(tokenbuf, "Can't %s %s in %s",
+ type == OP_REFGEN ? "refer to" : "modify",
+ op_name[op->op_type],
+ type ? op_name[type] : "local");
+ yyerror(tokenbuf);
+ return op;
+
+ case OP_COND_EXPR:
+ for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
+ ref(kid, type);
+ break;
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ case OP_RV2GV:
+ ref(cUNOP->op_first, type ? type : op->op_type);
+ /* FALL THROUGH */
+ case OP_AASSIGN:
+ case OP_ASLICE:
+ case OP_HSLICE:
+ case OP_CURCOP:
+ refcount = 10000;
+ break;
+ case OP_UNDEF:
+ case OP_GV:
+ case OP_RV2SV:
+ case OP_AV2ARYLEN:
+ case OP_SASSIGN:
+ case OP_REFGEN:
+ case OP_ANONLIST:
+ case OP_ANONHASH:
+ refcount++;
+ break;
+
+ case OP_PUSHMARK:
+ break;
+
+ case OP_SUBSTR:
+ case OP_VEC:
+ op->op_targ = pad_alloc(op->op_type,'M');
+ sv = PAD_SV(op->op_targ);
+ sv_upgrade(sv, SVt_PVLV);
+ sv_magic(sv, 0, op->op_type == OP_VEC ? 'v' : 'x', 0, 0);
+ curpad[op->op_targ] = sv;
+ /* FALL THROUGH */
+ case OP_NULL:
+ if (!(op->op_flags & OPf_KIDS))
+ fatal("panic: ref");
+ ref(cBINOP->op_first, type ? type : op->op_type);
+ break;
+ case OP_AELEM:
+ case OP_HELEM:
+ ref(cBINOP->op_first, type ? type : op->op_type);
+ op->op_private = type;
+ break;
+
+ case OP_LEAVE:
+ case OP_ENTER:
+ if (type != OP_RV2HV && type != OP_RV2AV)
+ break;
+ if (!(op->op_flags & OPf_KIDS))
+ break;
+ /* FALL THROUGH */
+ case OP_LIST:
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ ref(kid, type);
+ break;
+ }
+ op->op_flags |= OPf_LVAL;
+ if (!type) {
+ op->op_flags &= ~OPf_SPECIAL;
+ op->op_flags |= OPf_LOCAL;
+ }
+ else if (type == OP_AASSIGN || type == OP_SASSIGN)
+ op->op_flags |= OPf_SPECIAL;
+ return op;
+}
+
+OP *
+sawparens(o)
+OP *o;
+{
+ if (o)
+ o->op_flags |= OPf_PARENS;
+ return o;
+}
+
+OP *
+bind_match(type, left, right)
+I32 type;
+OP *left;
+OP *right;
+{
+ OP *op;
+
+ if (right->op_type == OP_MATCH ||
+ right->op_type == OP_SUBST ||
+ right->op_type == OP_TRANS) {
+ right->op_flags |= OPf_STACKED;
+ if (right->op_type != OP_MATCH)
+ left = ref(left, right->op_type);
+ if (right->op_type == OP_TRANS)
+ op = newBINOP(OP_NULL, 0, scalar(left), right);
+ else
+ op = prepend_elem(right->op_type, scalar(left), right);
+ if (type == OP_NOT)
+ return newUNOP(OP_NOT, 0, scalar(op));
+ return op;
+ }
+ else
+ return bind_match(type, left,
+ pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
+}
+
+OP *
+invert(op)
+OP *op;
+{
+ if (!op)
+ return op;
+ /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
+ return newUNOP(OP_NOT, OPf_SPECIAL, scalar(op));
+}
+
+OP *
+scope(o)
+OP *o;
+{
+ if (o) {
+ o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
+ o->op_type = OP_LEAVE;
+ o->op_ppaddr = ppaddr[OP_LEAVE];
+ }
+ return o;
+}
+
+OP *
+block_head(o, startp)
+OP *o;
+OP **startp;
+{
+ if (!o) {
+ *startp = 0;
+ return o;
+ }
+ o = scalarseq(scope(o));
+ *startp = LINKLIST(o);
+ o->op_next = 0;
+ peep(*startp);
+ return o;
+}
+
+OP *
+localize(o)
+OP *o;
+{
+ if (o->op_flags & OPf_PARENS)
+ list(o);
+ else
+ scalar(o);
+ return ref(o, Nullop); /* a bit kludgey */
+}
+
+OP *
+jmaybe(o)
+OP *o;
+{
+ if (o->op_type == OP_LIST) {
+ o = convert(OP_JOIN, 0,
+ prepend_elem(OP_LIST,
+ newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE))),
+ o));
+ }
+ return o;
+}
+
+OP *
+fold_constants(o)
+register OP *o;
+{
+ register OP *curop;
+ I32 type = o->op_type;
+ SV *sv;
+
+ if (opargs[type] & OA_RETSCALAR)
+ scalar(o);
+ if (opargs[type] & OA_TARGET)
+ o->op_targ = pad_alloc(type,'T');
+
+ if (!(opargs[type] & OA_FOLDCONST))
+ goto nope;
+
+ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
+ if (curop->op_type != OP_CONST && curop->op_type != OP_LIST) {
+ goto nope;
+ }
+ }
+
+ curop = LINKLIST(o);
+ o->op_next = 0;
+ op = curop;
+ run();
+ if (o->op_targ && *stack_sp == PAD_SV(o->op_targ))
+ pad_swipe(o->op_targ);
+ op_free(o);
+ if (type == OP_RV2GV)
+ return newGVOP(OP_GV, 0, *(stack_sp--));
+ else
+ return newSVOP(OP_CONST, 0, *(stack_sp--));
+
+ nope:
+ if (!(opargs[type] & OA_OTHERINT))
+ return o;
+ if (!(o->op_flags & OPf_KIDS))
+ return o;
+
+ for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
+ if (curop->op_type == OP_CONST) {
+ if (SvIOK(((SVOP*)curop)->op_sv))
+ continue;
+ return o;
+ }
+ if (opargs[curop->op_type] & OA_RETINTEGER)
+ continue;
+ return o;
+ }
+
+ o->op_ppaddr = ppaddr[++(o->op_type)];
+ return o;
+}
+
+OP *
+gen_constant_list(o)
+register OP *o;
+{
+ register OP *curop;
+ OP *anonop;
+ I32 tmpmark;
+ I32 tmpsp;
+ I32 oldtmps_floor = tmps_floor;
+ AV *av;
+ GV *gv;
+
+ tmpmark = stack_sp - stack_base;
+ anonop = newANONLIST(o);
+ curop = LINKLIST(anonop);
+ anonop->op_next = 0;
+ op = curop;
+ run();
+ tmpsp = stack_sp - stack_base;
+ tmps_floor = oldtmps_floor;
+ stack_sp = stack_base + tmpmark;
+
+ o->op_type = OP_RV2AV;
+ o->op_ppaddr = ppaddr[OP_RV2AV];
+ o->op_sibling = 0;
+ curop = ((UNOP*)o)->op_first;
+ ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, newSVsv(stack_sp[1]));
+ op_free(curop);
+ curop = ((UNOP*)anonop)->op_first;
+ curop = ((UNOP*)curop)->op_first;
+ curop->op_sibling = 0;
+ op_free(anonop);
+ o->op_next = 0;
+ linklist(o);
+ return list(o);
+}
+
+OP *
+convert(type, flags, op)
+I32 type;
+I32 flags;
+OP* op;
+{
+ OP *kid;
+ OP *last;
+
+ if (opargs[type] & OA_MARK)
+ op = prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), op);
+
+ if (!op || op->op_type != OP_LIST)
+ op = newLISTOP(OP_LIST, 0, op, Nullop);
+
+ op->op_type = type;
+ op->op_ppaddr = ppaddr[type];
+ op->op_flags |= flags;
+
+ op = (*check[type])(op);
+ if (op->op_type != type)
+ return op;
+
+ if (cLISTOP->op_children < 7) {
+ /* XXX do we really need to do this if we're done appending?? */
+ for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ last = kid;
+ cLISTOP->op_last = last; /* in case check substituted last arg */
+ }
+
+ return fold_constants(op);
+}
+
+/* List constructors */
+
+OP *
+append_elem(type, first, last)
+I32 type;
+OP* first;
+OP* last;
+{
+ if (!first)
+ return last;
+ else if (!last)
+ return first;
+ else if (first->op_type == type) {
+ if (first->op_flags & OPf_KIDS)
+ ((LISTOP*)first)->op_last->op_sibling = last;
+ else {
+ first->op_flags |= OPf_KIDS;
+ ((LISTOP*)first)->op_first = last;
+ }
+ ((LISTOP*)first)->op_last = last;
+ ((LISTOP*)first)->op_children++;
+ return first;
+ }
+
+ return newLISTOP(type, 0, first, last);
+}
+
+OP *
+append_list(type, first, last)
+I32 type;
+LISTOP* first;
+LISTOP* last;
+{
+ if (!first)
+ return (OP*)last;
+ else if (!last)
+ return (OP*)first;
+ else if (first->op_type != type)
+ return prepend_elem(type, (OP*)first, (OP*)last);
+ else if (last->op_type != type)
+ return append_elem(type, (OP*)first, (OP*)last);
+
+ first->op_last->op_sibling = last->op_first;
+ first->op_last = last->op_last;
+ first->op_children += last->op_children;
+ if (first->op_children)
+ last->op_flags |= OPf_KIDS;
+
+ Safefree(last);
+ return (OP*)first;
+}
+
+OP *
+prepend_elem(type, first, last)
+I32 type;
+OP* first;
+OP* last;
+{
+ if (!first)
+ return last;
+ else if (!last)
+ return first;
+ else if (last->op_type == type) {
+ if (!(last->op_flags & OPf_KIDS)) {
+ ((LISTOP*)last)->op_last = first;
+ last->op_flags |= OPf_KIDS;
+ }
+ first->op_sibling = ((LISTOP*)last)->op_first;
+ ((LISTOP*)last)->op_first = first;
+ ((LISTOP*)last)->op_children++;
+ return last;
+ }
+
+ return newLISTOP(type, 0, first, last);
+}
+
+/* Constructors */
+
+OP *
+newNULLLIST()
+{
+ return Nullop;
+}
+
+OP *
+newLISTOP(type, flags, first, last)
+I32 type;
+I32 flags;
+OP* first;
+OP* last;
+{
+ LISTOP *listop;
+
+ Newz(1101, listop, 1, LISTOP);
+
+ listop->op_type = type;
+ listop->op_ppaddr = ppaddr[type];
+ listop->op_children = (first != 0) + (last != 0);
+ listop->op_flags = flags;
+ if (listop->op_children)
+ listop->op_flags |= OPf_KIDS;
+
+ if (!last && first)
+ last = first;
+ else if (!first && last)
+ first = last;
+ listop->op_first = first;
+ listop->op_last = last;
+ if (first && first != last)
+ first->op_sibling = last;
+
+ return (OP*)listop;
+}
+
+OP *
+newOP(type, flags)
+I32 type;
+I32 flags;
+{
+ OP *op;
+ Newz(1101, op, 1, OP);
+ op->op_type = type;
+ op->op_ppaddr = ppaddr[type];
+ op->op_flags = flags;
+
+ op->op_next = op;
+ /* op->op_private = 0; */
+ if (opargs[type] & OA_RETSCALAR)
+ scalar(op);
+ if (opargs[type] & OA_TARGET)
+ op->op_targ = pad_alloc(type,'T');
+ return (*check[type])(op);
+}
+
+OP *
+newUNOP(type, flags, first)
+I32 type;
+I32 flags;
+OP* first;
+{
+ UNOP *unop;
+
+ if (opargs[type] & OA_MARK) {
+ if (first->op_type == OP_LIST)
+ prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), first);
+ else
+ return newBINOP(type, flags, newOP(OP_PUSHMARK, 0), first);
+ }
+
+ Newz(1101, unop, 1, UNOP);
+ unop->op_type = type;
+ unop->op_ppaddr = ppaddr[type];
+ unop->op_first = first;
+ unop->op_flags = flags | OPf_KIDS;
+ unop->op_private = 1;
+
+ unop = (UNOP*)(*check[type])((OP*)unop);
+ if (unop->op_next)
+ return (OP*)unop;
+
+ return fold_constants(unop);
+}
+
+OP *
+newBINOP(type, flags, first, last)
+I32 type;
+I32 flags;
+OP* first;
+OP* last;
+{
+ BINOP *binop;
+ Newz(1101, binop, 1, BINOP);
+
+ if (!first)
+ first = newOP(OP_NULL, 0);
+
+ binop->op_type = type;
+ binop->op_ppaddr = ppaddr[type];
+ binop->op_first = first;
+ binop->op_flags = flags | OPf_KIDS;
+ if (!last) {
+ last = first;
+ binop->op_private = 1;
+ }
+ else {
+ binop->op_private = 2;
+ first->op_sibling = last;
+ }
+
+ binop = (BINOP*)(*check[type])((OP*)binop);
+ if (binop->op_next)
+ return (OP*)binop;
+
+ binop->op_last = last = binop->op_first->op_sibling;
+
+ return fold_constants(binop);
+}
+
+OP *
+pmtrans(op, expr, repl)
+OP *op;
+OP *expr;
+OP *repl;
+{
+ PMOP *pm = (PMOP*)op;
+ SV *tstr = ((SVOP*)expr)->op_sv;
+ SV *rstr = ((SVOP*)repl)->op_sv;
+ register char *t = SvPVn(tstr);
+ register char *r = SvPVn(rstr);
+ I32 tlen = SvCUR(tstr);
+ I32 rlen = SvCUR(rstr);
+ register I32 i;
+ register I32 j;
+ I32 squash;
+ I32 delete;
+ I32 complement;
+ register short *tbl;
+
+ tbl = (short*)cPVOP->op_pv;
+ complement = op->op_private & OPpTRANS_COMPLEMENT;
+ delete = op->op_private & OPpTRANS_DELETE;
+ squash = op->op_private & OPpTRANS_SQUASH;
+
+ if (complement) {
+ Zero(tbl, 256, short);
+ for (i = 0; i < tlen; i++)
+ tbl[t[i] & 0377] = -1;
+ for (i = 0, j = 0; i < 256; i++) {
+ if (!tbl[i]) {
+ if (j >= rlen) {
+ if (delete)
+ tbl[i] = -2;
+ else if (rlen)
+ tbl[i] = r[j-1] & 0377;
+ else
+ tbl[i] = i;
+ }
+ else
+ tbl[i] = r[j++] & 0377;
+ }
+ }
+ }
+ else {
+ if (!rlen && !delete) {
+ r = t; rlen = tlen;
+ }
+ for (i = 0; i < 256; i++)
+ tbl[i] = -1;
+ for (i = 0, j = 0; i < tlen; i++,j++) {
+ if (j >= rlen) {
+ if (delete) {
+ if (tbl[t[i] & 0377] == -1)
+ tbl[t[i] & 0377] = -2;
+ continue;
+ }
+ --j;
+ }
+ if (tbl[t[i] & 0377] == -1)
+ tbl[t[i] & 0377] = r[j] & 0377;
+ }
+ }
+ op_free(expr);
+ op_free(repl);
+
+ return op;
+}
+
+OP *
+newPMOP(type, flags)
+I32 type;
+I32 flags;
+{
+ PMOP *pmop;
+
+ Newz(1101, pmop, 1, PMOP);
+ pmop->op_type = type;
+ pmop->op_ppaddr = ppaddr[type];
+ pmop->op_flags = flags;
+ pmop->op_private = 0;
+
+ /* link into pm list */
+ if (type != OP_TRANS) {
+ pmop->op_pmnext = HvPMROOT(curstash);
+ HvPMROOT(curstash) = pmop;
+ }
+
+ return (OP*)pmop;
+}
+
+OP *
+pmruntime(op, expr, repl)
+OP *op;
+OP *expr;
+OP *repl;
+{
+ PMOP *pm;
+ LOGOP *rcop;
+
+ if (op->op_type == OP_TRANS)
+ return pmtrans(op, expr, repl);
+
+ pm = (PMOP*)op;
+
+ if (expr->op_type == OP_CONST) {
+ SV *pat = ((SVOP*)expr)->op_sv;
+ char *p = SvPVn(pat);
+ if ((op->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
+ sv_setpv(pat, "\\s+", 3);
+ p = SvPVn(pat);
+ pm->op_pmflags |= PMf_SKIPWHITE;
+ }
+ scan_prefix(pm, p, SvCUR(pat));
+ if (pm->op_pmshort && (pm->op_pmflags & PMf_SCANFIRST))
+ fbm_compile(pm->op_pmshort, pm->op_pmflags & PMf_FOLD);
+ pm->op_pmregexp = regcomp(p, p + SvCUR(pat), pm->op_pmflags & PMf_FOLD);
+ hoistmust(pm);
+ op_free(expr);
+ }
+ else {
+ Newz(1101, rcop, 1, LOGOP);
+ rcop->op_type = OP_REGCOMP;
+ rcop->op_ppaddr = ppaddr[OP_REGCOMP];
+ rcop->op_first = scalar(expr);
+ rcop->op_flags |= OPf_KIDS;
+ rcop->op_private = 1;
+ rcop->op_other = op;
+
+ /* establish postfix order */
+ rcop->op_next = LINKLIST(expr);
+ expr->op_next = (OP*)rcop;
+
+ prepend_elem(op->op_type, scalar(rcop), op);
+ }
+
+ if (repl) {
+ if (repl->op_type == OP_CONST) {
+ pm->op_pmflags |= PMf_CONST;
+ prepend_elem(op->op_type, scalar(repl), op);
+ }
+ else {
+ OP *curop;
+ OP *lastop = 0;
+ for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
+ if (opargs[curop->op_type] & OA_DANGEROUS) {
+ if (curop->op_type == OP_GV) {
+ GV *gv = ((GVOP*)curop)->op_gv;
+ if (index("&`'123456789+", *GvENAME(gv)))
+ break;
+ }
+ else if (curop->op_type == OP_RV2CV)
+ break;
+ else if (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV) {
+ if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
+ break;
+ }
+ else
+ break;
+ }
+ lastop = curop;
+ }
+ if (curop == repl) {
+ pm->op_pmflags |= PMf_CONST; /* const for long enough */
+ prepend_elem(op->op_type, scalar(repl), op);
+ }
+ else {
+ Newz(1101, rcop, 1, LOGOP);
+ rcop->op_type = OP_SUBSTCONT;
+ rcop->op_ppaddr = ppaddr[OP_SUBSTCONT];
+ rcop->op_first = scalar(repl);
+ rcop->op_flags |= OPf_KIDS;
+ rcop->op_private = 1;
+ rcop->op_other = op;
+
+ /* establish postfix order */
+ rcop->op_next = LINKLIST(repl);
+ repl->op_next = (OP*)rcop;
+
+ pm->op_pmreplroot = scalar(rcop);
+ pm->op_pmreplstart = LINKLIST(rcop);
+ rcop->op_next = 0;
+ }
+ }
+ }
+
+ return (OP*)pm;
+}
+
+OP *
+newSVOP(type, flags, sv)
+I32 type;
+I32 flags;
+SV *sv;
+{
+ SVOP *svop;
+ Newz(1101, svop, 1, SVOP);
+ svop->op_type = type;
+ svop->op_ppaddr = ppaddr[type];
+ svop->op_sv = sv;
+ svop->op_next = (OP*)svop;
+ svop->op_flags = flags;
+ if (opargs[type] & OA_RETSCALAR)
+ scalar(svop);
+ if (opargs[type] & OA_TARGET)
+ svop->op_targ = pad_alloc(type,'T');
+ return (*check[type])((OP*)svop);
+}
+
+OP *
+newGVOP(type, flags, gv)
+I32 type;
+I32 flags;
+GV *gv;
+{
+ GVOP *gvop;
+ Newz(1101, gvop, 1, GVOP);
+ gvop->op_type = type;
+ gvop->op_ppaddr = ppaddr[type];
+ gvop->op_gv = (GV*)sv_ref(gv);
+ gvop->op_next = (OP*)gvop;
+ gvop->op_flags = flags;
+ if (opargs[type] & OA_RETSCALAR)
+ scalar(gvop);
+ if (opargs[type] & OA_TARGET)
+ gvop->op_targ = pad_alloc(type,'T');
+ return (*check[type])((OP*)gvop);
+}
+
+OP *
+newPVOP(type, flags, pv)
+I32 type;
+I32 flags;
+char *pv;
+{
+ PVOP *pvop;
+ Newz(1101, pvop, 1, PVOP);
+ pvop->op_type = type;
+ pvop->op_ppaddr = ppaddr[type];
+ pvop->op_pv = pv;
+ pvop->op_next = (OP*)pvop;
+ pvop->op_flags = flags;
+ if (opargs[type] & OA_RETSCALAR)
+ scalar(pvop);
+ if (opargs[type] & OA_TARGET)
+ pvop->op_targ = pad_alloc(type,'T');
+ return (*check[type])((OP*)pvop);
+}
+
+OP *
+newCVOP(type, flags, cv, cont)
+I32 type;
+I32 flags;
+CV *cv;
+OP *cont;
+{
+ CVOP *cvop;
+ Newz(1101, cvop, 1, CVOP);
+ cvop->op_type = type;
+ cvop->op_ppaddr = ppaddr[type];
+ cvop->op_cv = cv;
+ cvop->op_cont = cont;
+ cvop->op_next = (OP*)cvop;
+ cvop->op_flags = flags;
+ if (opargs[type] & OA_RETSCALAR)
+ scalar(cvop);
+ if (opargs[type] & OA_TARGET)
+ cvop->op_targ = pad_alloc(type,'T');
+ return (*check[type])((OP*)cvop);
+}
+
+void
+package(op)
+OP *op;
+{
+ char tmpbuf[256];
+ GV *tmpgv;
+ SV *sv = cSVOP->op_sv;
+ char *name = SvPVn(sv);
+
+ save_hptr(&curstash);
+ save_item(curstname);
+ sv_setpv(curstname,name);
+ sprintf(tmpbuf,"'_%s",name);
+ tmpgv = gv_fetchpv(tmpbuf,TRUE);
+ if (!GvHV(tmpgv))
+ GvHV(tmpgv) = newHV(0);
+ curstash = GvHV(tmpgv);
+ if (!HvNAME(curstash))
+ HvNAME(curstash) = savestr(name);
+ HvCOEFFSIZE(curstash) = 0;
+ op_free(op);
+ copline = NOLINE;
+ expect = XBLOCK;
+}
+
+OP *
+newSLICEOP(flags, subscript, listval)
+I32 flags;
+OP *subscript;
+OP *listval;
+{
+ return newBINOP(OP_LSLICE, flags,
+ list(prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), subscript)),
+ list(prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), listval)) );
+}
+
+static I32
+list_assignment(op)
+register OP *op;
+{
+ if (!op)
+ return TRUE;
+
+ if (op->op_type == OP_NULL && op->op_flags & OPf_KIDS)
+ op = cUNOP->op_first;
+
+ if (op->op_type == OP_COND_EXPR) {
+ I32 t = list_assignment(cCONDOP->op_first->op_sibling);
+ I32 f = list_assignment(cCONDOP->op_first->op_sibling->op_sibling);
+
+ if (t && f)
+ return TRUE;
+ if (t || f)
+ yyerror("Assignment to both a list and a scalar");
+ return FALSE;
+ }
+
+ if (op->op_type == OP_LIST || op->op_flags & OPf_PARENS ||
+ op->op_type == OP_RV2AV || op->op_type == OP_RV2HV ||
+ op->op_type == OP_ASLICE || op->op_type == OP_HSLICE)
+ return TRUE;
+
+ if (op->op_type == OP_RV2SV)
+ return FALSE;
+
+ return FALSE;
+}
+
+OP *
+newASSIGNOP(flags, left, right)
+I32 flags;
+OP *left;
+OP *right;
+{
+ OP *op;
+
+ if (list_assignment(left)) {
+ refcount = 0;
+ left = ref(left, OP_AASSIGN);
+ if (right && right->op_type == OP_SPLIT) {
+ if ((op = ((LISTOP*)right)->op_first) && op->op_type == OP_PUSHRE) {
+ PMOP *pm = (PMOP*)op;
+ if (left->op_type == OP_RV2AV) {
+ op = ((UNOP*)left)->op_first;
+ if (op->op_type == OP_GV && !pm->op_pmreplroot) {
+ pm->op_pmreplroot = (OP*)((GVOP*)op)->op_gv;
+ pm->op_pmflags |= PMf_ONCE;
+ op_free(left);
+ return right;
+ }
+ }
+ else {
+ if (refcount < 10000) {
+ SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
+ if (SvIV(sv) == 0)
+ sv_setiv(sv, refcount+1);
+ }
+ }
+ }
+ }
+ op = newBINOP(OP_AASSIGN, flags,
+ list(prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), right)),
+ list(prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), left)) );
+ op->op_private = 0;
+ if (!(left->op_flags & OPf_LOCAL)) {
+ static int generation = 0;
+ OP *curop;
+ OP *lastop = op;
+ generation++;
+ for (curop = LINKLIST(op); curop != op; curop = LINKLIST(curop)) {
+ if (opargs[curop->op_type] & OA_DANGEROUS) {
+ if (curop->op_type == OP_GV) {
+ GV *gv = ((GVOP*)curop)->op_gv;
+ if (gv == defgv || SvCUR(gv) == generation)
+ break;
+ SvCUR(gv) = generation;
+ }
+ else if (curop->op_type == OP_RV2CV)
+ break;
+ else if (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV) {
+ if (lastop->op_type != OP_GV) /* funny deref? */
+ break;
+ }
+ else
+ break;
+ }
+ lastop = curop;
+ }
+ if (curop != op)
+ op->op_private = OPpASSIGN_COMMON;
+ }
+ op->op_targ = pad_alloc(OP_AASSIGN, 'T'); /* for scalar context */
+ return op;
+ }
+ if (!right)
+ right = newOP(OP_UNDEF, 0);
+ if (right->op_type == OP_READLINE) {
+ right->op_flags |= OPf_STACKED;
+ return newBINOP(OP_NULL, flags, ref(scalar(left), OP_SASSIGN), scalar(right));
+ }
+ else
+ op = newBINOP(OP_SASSIGN, flags,
+ scalar(right), ref(scalar(left), OP_SASSIGN) );
+ return op;
+}
+
+OP *
+newSTATEOP(flags, label, op)
+I32 flags;
+char *label;
+OP *op;
+{
+ register COP *cop;
+
+ Newz(1101, cop, 1, COP);
+ cop->op_type = OP_CURCOP;
+ cop->op_ppaddr = ppaddr[OP_CURCOP];
+ cop->op_flags = flags;
+ cop->op_private = 0;
+ cop->op_next = (OP*)cop;
+
+ cop->cop_label = label;
+
+ if (copline == NOLINE)
+ cop->cop_line = curcop->cop_line;
+ else {
+ cop->cop_line = copline;
+ copline = NOLINE;
+ }
+ cop->cop_filegv = curcop->cop_filegv;
+ cop->cop_stash = curstash;
+
+ return prepend_elem(OP_LINESEQ, (OP*)cop, op);
+}
+
+OP *
+newLOGOP(type, flags, first, other)
+I32 type;
+I32 flags;
+OP* first;
+OP* other;
+{
+ LOGOP *logop;
+ OP *op;
+
+ scalar(first);
+ /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
+ if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
+ if (type == OP_AND || type == OP_OR) {
+ if (type == OP_AND)
+ type = OP_OR;
+ else
+ type = OP_AND;
+ op = first;
+ first = cUNOP->op_first;
+ if (op->op_next)
+ first->op_next = op->op_next;
+ cUNOP->op_first = Nullop;
+ op_free(op);
+ }
+ }
+ if (first->op_type == OP_CONST) {
+ if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
+ op_free(first);
+ return other;
+ }
+ else {
+ op_free(other);
+ return first;
+ }
+ }
+ else if (first->op_type == OP_WANTARRAY) {
+ if (type == OP_AND)
+ list(other);
+ else
+ scalar(other);
+ }
+
+ if (!other)
+ return first;
+
+ Newz(1101, logop, 1, LOGOP);
+
+ logop->op_type = type;
+ logop->op_ppaddr = ppaddr[type];
+ logop->op_first = first;
+ logop->op_flags = flags | OPf_KIDS;
+ logop->op_other = LINKLIST(other);
+ logop->op_private = 1;
+
+ /* establish postfix order */
+ logop->op_next = LINKLIST(first);
+ first->op_next = (OP*)logop;
+ first->op_sibling = other;
+
+ op = newUNOP(OP_NULL, 0, (OP*)logop);
+ other->op_next = op;
+
+ return op;
+}
+
+OP *
+newCONDOP(flags, first, true, false)
+I32 flags;
+OP* first;
+OP* true;
+OP* false;
+{
+ CONDOP *condop;
+ OP *op;
+
+ if (!false)
+ return newLOGOP(OP_AND, 0, first, true);
+
+ scalar(first);
+ if (first->op_type == OP_CONST) {
+ if (SvTRUE(((SVOP*)first)->op_sv)) {
+ op_free(first);
+ op_free(false);
+ return true;
+ }
+ else {
+ op_free(first);
+ op_free(true);
+ return false;
+ }
+ }
+ else if (first->op_type == OP_WANTARRAY) {
+ list(true);
+ scalar(false);
+ }
+ Newz(1101, condop, 1, CONDOP);
+
+ condop->op_type = OP_COND_EXPR;
+ condop->op_ppaddr = ppaddr[OP_COND_EXPR];
+ condop->op_first = first;
+ condop->op_flags = flags | OPf_KIDS;
+ condop->op_true = LINKLIST(true);
+ condop->op_false = LINKLIST(false);
+ condop->op_private = 1;
+
+ /* establish postfix order */
+ condop->op_next = LINKLIST(first);
+ first->op_next = (OP*)condop;
+
+ first->op_sibling = true;
+ true->op_sibling = false;
+ op = newUNOP(OP_NULL, 0, (OP*)condop);
+
+ true->op_next = op;
+ false->op_next = op;
+
+ return op;
+}
+
+OP *
+newRANGE(flags, left, right)
+I32 flags;
+OP *left;
+OP *right;
+{
+ CONDOP *condop;
+ OP *flip;
+ OP *flop;
+ OP *op;
+
+ Newz(1101, condop, 1, CONDOP);
+
+ condop->op_type = OP_RANGE;
+ condop->op_ppaddr = ppaddr[OP_RANGE];
+ condop->op_first = left;
+ condop->op_flags = OPf_KIDS;
+ condop->op_true = LINKLIST(left);
+ condop->op_false = LINKLIST(right);
+ condop->op_private = 1;
+
+ left->op_sibling = right;
+
+ condop->op_next = (OP*)condop;
+ flip = newUNOP(OP_FLIP, flags, (OP*)condop);
+ flop = newUNOP(OP_FLOP, 0, flip);
+ op = newUNOP(OP_NULL, 0, flop);
+ linklist(flop);
+
+ left->op_next = flip;
+ right->op_next = flop;
+
+ condop->op_targ = pad_alloc(OP_RANGE, 'M');
+ sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV);
+ flip->op_targ = pad_alloc(OP_RANGE, 'M');
+ sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
+
+ flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
+ flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
+
+ flip->op_next = op;
+ if (!flip->op_private || !flop->op_private)
+ linklist(op); /* blow off optimizer unless constant */
+
+ return op;
+}
+
+OP *
+newLOOPOP(flags, debuggable, expr, block)
+I32 flags;
+I32 debuggable;
+OP *expr;
+OP *block;
+{
+ OP* listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
+ OP* op = newLOGOP(OP_AND, 0, expr, listop);
+ ((LISTOP*)listop)->op_last->op_next = LINKLIST(op);
+
+ if (block->op_flags & OPf_SPECIAL && /* skip conditional on do {} ? */
+ (block->op_type == OP_ENTERSUBR || block->op_type == OP_NULL))
+ op->op_next = ((LOGOP*)cUNOP->op_first)->op_other;
+
+ op->op_flags |= flags;
+ return op;
+}
+
+OP *
+newWHILEOP(flags, debuggable, loop, expr, block, cont)
+I32 flags;
+I32 debuggable;
+LOOP *loop;
+OP *expr;
+OP *block;
+OP *cont;
+{
+ OP *redo;
+ OP *next = 0;
+ OP *listop;
+ OP *op;
+ OP *condop;
+
+ if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB))
+ expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), expr);
+
+ if (!block)
+ block = newOP(OP_NULL, 0);
+
+ if (cont)
+ next = LINKLIST(cont);
+ if (expr)
+ cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
+
+ listop = append_list(OP_LINESEQ, block, cont);
+ redo = LINKLIST(listop);
+
+ if (expr) {
+ op = newLOGOP(OP_AND, 0, expr, scalar(listop));
+ ((LISTOP*)listop)->op_last->op_next = condop =
+ (op == listop ? redo : LINKLIST(op));
+ if (!next)
+ next = condop;
+ }
+ else
+ op = listop;
+
+ if (!loop) {
+ Newz(1101,loop,1,LOOP);
+ loop->op_type = OP_ENTERLOOP;
+ loop->op_ppaddr = ppaddr[OP_ENTERLOOP];
+ loop->op_private = 0;
+ loop->op_next = (OP*)loop;
+ }
+
+ op = newBINOP(OP_LEAVELOOP, 0, loop, op);
+
+ loop->op_redoop = redo;
+ loop->op_lastop = op;
+
+ if (next)
+ loop->op_nextop = next;
+ else
+ loop->op_nextop = op;
+
+ op->op_flags |= flags;
+ return op;
+}
+
+OP *
+newFOROP(flags,label,forline,sv,expr,block,cont)
+I32 flags;
+char *label;
+line_t forline;
+OP* sv;
+OP* expr;
+OP*block;
+OP*cont;
+{
+ LOOP *loop;
+
+ copline = forline;
+ if (sv) {
+ if (sv->op_type == OP_RV2SV) {
+ OP *op = sv;
+ sv = cUNOP->op_first;
+ sv->op_next = sv;
+ cUNOP->op_first = Nullop;
+ op_free(op);
+ }
+ else
+ fatal("Can't use %s for loop variable", op_name[sv->op_type]);
+ }
+ else {
+ sv = newGVOP(OP_GV, 0, defgv);
+ }
+ loop = (LOOP*)list(convert(OP_ENTERITER, 0,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), expr),
+ scalar(sv))));
+ return newSTATEOP(0, label, newWHILEOP(flags, 1,
+ loop, newOP(OP_ITER), block, cont));
+}
+
+void
+cv_free(cv)
+CV *cv;
+{
+ if (!CvUSERSUB(cv) && CvROOT(cv)) {
+ op_free(CvROOT(cv));
+ CvROOT(cv) = Nullop;
+ if (CvDEPTH(cv))
+ warn("Deleting active subroutine"); /* XXX */
+ if (CvPADLIST(cv)) {
+ I32 i = AvFILL(CvPADLIST(cv));
+ while (i > 0) {
+ SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
+ if (svp)
+ av_free(*svp);
+ }
+ av_free(CvPADLIST(cv));
+ }
+ }
+ Safefree(cv);
+}
+
+void
+newSUB(floor,op,block)
+I32 floor;
+OP *op;
+OP *block;
+{
+ register CV *cv;
+ char *name = SvPVnx(cSVOP->op_sv);
+ GV *gv = gv_fetchpv(name,TRUE);
+ AV* av;
+
+ if (cv = GvCV(gv)) {
+ if (CvDEPTH(cv))
+ CvDELETED(cv) = TRUE; /* probably an autoloader */
+ else {
+ if (dowarn) {
+ line_t oldline = curcop->cop_line;
+
+ curcop->cop_line = copline;
+ warn("Subroutine %s redefined",name);
+ curcop->cop_line = oldline;
+ }
+ cv_free(cv);
+ }
+ }
+ Newz(101,cv,1,CV);
+ sv_upgrade(cv, SVt_PVCV);
+ GvCV(gv) = cv;
+ CvFILEGV(cv) = curcop->cop_filegv;
+
+ av = newAV();
+ AvREAL_off(av);
+ av_store(av, 1, (SV*)comppad);
+ AvFILL(av) = 1;
+ CvPADLIST(cv) = av;
+
+ CvROOT(cv) = newUNOP(OP_LEAVESUBR, 0, scalarseq(block));
+ CvSTART(cv) = LINKLIST(CvROOT(cv));
+ CvROOT(cv)->op_next = 0;
+ peep(CvSTART(cv));
+ CvDELETED(cv) = FALSE;
+ if (perldb) {
+ SV *sv;
+ SV *tmpstr = sv_mortalcopy(&sv_undef);
+
+ sprintf(buf,"%s:%ld",SvPV(GvSV(curcop->cop_filegv)), subline);
+ sv = newSVpv(buf,0);
+ sv_catpv(sv,"-");
+ sprintf(buf,"%ld",(long)curcop->cop_line);
+ sv_catpv(sv,buf);
+ gv_efullname(tmpstr,gv);
+ hv_store(GvHV(DBsub), SvPV(tmpstr), SvCUR(tmpstr), sv, 0);
+ }
+ op_free(op);
+ copline = NOLINE;
+ leave_scope(floor);
+}
+
+void
+newUSUB(name, ix, subaddr, filename)
+char *name;
+I32 ix;
+I32 (*subaddr)();
+char *filename;
+{
+ register CV *cv;
+ GV *gv = gv_fetchpv(name,allgvs);
+
+ if (!gv) /* unused function */
+ return;
+ if (cv = GvCV(gv)) {
+ if (dowarn)
+ warn("Subroutine %s redefined",name);
+ if (!CvUSERSUB(cv) && CvROOT(cv)) {
+ op_free(CvROOT(cv));
+ CvROOT(cv) = Nullop;
+ }
+ Safefree(cv);
+ }
+ Newz(101,cv,1,CV);
+ sv_upgrade(cv, SVt_PVCV);
+ GvCV(gv) = cv;
+ CvFILEGV(cv) = gv_fetchfile(filename);
+ CvUSERSUB(cv) = subaddr;
+ CvUSERINDEX(cv) = ix;
+ CvDELETED(cv) = FALSE;
+}
+
+void
+newFORM(floor,op,block)
+I32 floor;
+OP *op;
+OP *block;
+{
+ register CV *cv;
+ char *name;
+ GV *gv;
+ AV* av;
+
+ if (op)
+ name = SvPVnx(cSVOP->op_sv);
+ else
+ name = "STDOUT";
+ gv = gv_fetchpv(name,TRUE);
+ if (cv = GvFORM(gv)) {
+ if (dowarn) {
+ line_t oldline = curcop->cop_line;
+
+ curcop->cop_line = copline;
+ warn("Format %s redefined",name);
+ curcop->cop_line = oldline;
+ }
+ cv_free(cv);
+ }
+ Newz(101,cv,1,CV);
+ sv_upgrade(cv, SVt_PVFM);
+ GvFORM(gv) = cv;
+ CvFILEGV(cv) = curcop->cop_filegv;
+
+ CvPADLIST(cv) = av = newAV();
+ AvREAL_off(av);
+ av_store(av, 1, (SV*)comppad);
+ AvFILL(av) = 1;
+
+ CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
+ CvSTART(cv) = LINKLIST(CvROOT(cv));
+ CvROOT(cv)->op_next = 0;
+ peep(CvSTART(cv));
+ CvDELETED(cv) = FALSE;
+ FmLINES(cv) = 0;
+ op_free(op);
+ copline = NOLINE;
+ leave_scope(floor);
+}
+
+OP *
+newMETHOD(ref,name)
+OP *ref;
+OP *name;
+{
+ LOGOP* mop;
+ Newz(1101, mop, 1, LOGOP);
+ mop->op_type = OP_METHOD;
+ mop->op_ppaddr = ppaddr[OP_METHOD];
+ mop->op_first = scalar(ref);
+ mop->op_flags |= OPf_KIDS;
+ mop->op_private = 1;
+ mop->op_other = LINKLIST(name);
+ mop->op_targ = pad_alloc(OP_METHOD,'T');
+ mop->op_next = LINKLIST(ref);
+ ref->op_next = (OP*)mop;
+ return (OP*)mop;
+}
+
+OP *
+newANONLIST(op)
+OP* op;
+{
+ return newUNOP(OP_REFGEN, 0, ref(list(convert(OP_ANONLIST, 0, op))));
+}
+
+OP *
+newANONHASH(op)
+OP* op;
+{
+ return newUNOP(OP_REFGEN, 0, ref(list(convert(OP_ANONHASH, 0, op))));
+}
+
+OP *
+oopsAV(o)
+OP *o;
+{
+ if (o->op_type == OP_RV2SV) {
+ o->op_type = OP_RV2AV;
+ o->op_ppaddr = ppaddr[OP_RV2AV];
+ ref(o, OP_RV2AV);
+ }
+ else
+ warn("oops: oopsAV");
+ return o;
+}
+
+OP *
+oopsHV(o)
+OP *o;
+{
+ if (o->op_type == OP_RV2SV || o->op_type == OP_RV2AV) {
+ o->op_type = OP_RV2HV;
+ o->op_ppaddr = ppaddr[OP_RV2HV];
+ ref(o, OP_RV2HV);
+ }
+ else
+ warn("oops: oopsHV");
+ return o;
+}
+
+OP *
+newAVREF(o)
+OP *o;
+{
+ return newUNOP(OP_RV2AV, 0, scalar(o));
+}
+
+OP *
+newGVREF(o)
+OP *o;
+{
+ return newUNOP(OP_RV2GV, 0, scalar(o));
+}
+
+OP *
+newHVREF(o)
+OP *o;
+{
+ return newUNOP(OP_RV2HV, 0, scalar(o));
+}
+
+OP *
+oopsCV(o)
+OP *o;
+{
+ fatal("NOT IMPL LINE %d",__LINE__);
+ /* STUB */
+ return o;
+}
+
+OP *
+newCVREF(o)
+OP *o;
+{
+ return newUNOP(OP_RV2CV, 0, scalar(o));
+}
+
+OP *
+newSVREF(o)
+OP *o;
+{
+ return newUNOP(OP_RV2SV, 0, scalar(o));
+}
+
+/* Check routines. */
+
+OP *
+ck_aelem(op)
+OP *op;
+{
+ /* XXX need to optimize constant subscript here. */
+ return op;
+}
+
+OP *
+ck_concat(op)
+OP *op;
+{
+ if (cUNOP->op_first->op_type == OP_CONCAT)
+ op->op_flags |= OPf_STACKED;
+ return op;
+}
+
+OP *
+ck_chop(op)
+OP *op;
+{
+ if (op->op_flags & OPf_KIDS) {
+ OP* newop;
+ op = refkids(ck_fun(op), op->op_type);
+ if (op->op_private != 1)
+ return op;
+ newop = cUNOP->op_first->op_sibling;
+ if (!newop || newop->op_type != OP_RV2SV)
+ return op;
+ op_free(cUNOP->op_first);
+ cUNOP->op_first = newop;
+ }
+ op->op_type = OP_SCHOP;
+ op->op_ppaddr = ppaddr[OP_SCHOP];
+ return op;
+}
+
+OP *
+ck_eof(op)
+OP *op;
+{
+ I32 type = op->op_type;
+
+ if (op->op_flags & OPf_KIDS)
+ return ck_fun(op);
+
+ if (op->op_flags & OPf_SPECIAL) {
+ op_free(op);
+ op = newUNOP(type, 0, newGVOP(OP_GV, 0, gv_fetchpv("main'ARGV", TRUE)));
+ }
+ return op;
+}
+
+OP *
+ck_eval(op)
+OP *op;
+{
+ if (op->op_flags & OPf_KIDS) {
+ SVOP *kid = (SVOP*)cUNOP->op_first;
+
+ if (kid->op_type == OP_CONST) {
+#ifdef NOTDEF
+ op->op_type = OP_EVALONCE;
+ op->op_ppaddr = ppaddr[OP_EVALONCE];
+#endif
+ }
+ else if (kid->op_type == OP_LINESEQ) {
+ LOGOP *enter;
+
+ kid->op_next = op->op_next;
+ cUNOP->op_first = 0;
+ op_free(op);
+
+ Newz(1101, enter, 1, LOGOP);
+ enter->op_type = OP_ENTERTRY;
+ enter->op_ppaddr = ppaddr[OP_ENTERTRY];
+ enter->op_private = 0;
+
+ /* establish postfix order */
+ enter->op_next = (OP*)enter;
+
+ op = prepend_elem(OP_LINESEQ, enter, kid);
+ op->op_type = OP_LEAVETRY;
+ op->op_ppaddr = ppaddr[OP_LEAVETRY];
+ enter->op_other = op;
+ return op;
+ }
+ }
+ else {
+ op_free(op);
+ op = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
+ }
+ return op;
+}
+
+OP *
+ck_exec(op)
+OP *op;
+{
+ OP *kid;
+ op = ck_fun(op);
+ if (op->op_flags & OPf_STACKED) {
+ kid = cUNOP->op_first->op_sibling;
+ if (kid->op_type == OP_RV2GV) {
+ kid->op_type = OP_NULL;
+ kid->op_ppaddr = ppaddr[OP_NULL];
+ }
+ }
+ return op;
+}
+
+OP *
+ck_gvconst(o)
+register OP *o;
+{
+ o = fold_constants(o);
+ if (o->op_type == OP_CONST)
+ o->op_type = OP_GV;
+ return o;
+}
+
+OP *
+ck_rvconst(op)
+register OP *op;
+{
+ SVOP *kid = (SVOP*)cUNOP->op_first;
+ if (kid->op_type == OP_CONST) {
+ kid->op_type = OP_GV;
+ kid->op_sv = (SV*)gv_fetchpv(SvPVnx(kid->op_sv),
+ 1+(op->op_type==OP_RV2CV));
+ }
+ return op;
+}
+
+OP *
+ck_formline(op)
+OP *op;
+{
+ return ck_fun(op);
+}
+
+OP *
+ck_ftst(op)
+OP *op;
+{
+ I32 type = op->op_type;
+
+ if (op->op_flags & OPf_SPECIAL)
+ return op;
+
+ if (op->op_flags & OPf_KIDS) {
+ SVOP *kid = (SVOP*)cUNOP->op_first;
+
+ if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ OP *newop = newGVOP(type, OPf_SPECIAL,
+ gv_fetchpv(SvPVnx(kid->op_sv), TRUE));
+ op_free(op);
+ return newop;
+ }
+ }
+ else {
+ op_free(op);
+ if (type == OP_FTTTY)
+ return newGVOP(type, OPf_SPECIAL, gv_fetchpv("main'STDIN", TRUE));
+ else
+ return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
+ }
+ return op;
+}
+
+OP *
+ck_fun(op)
+OP *op;
+{
+ register OP *kid;
+ OP **tokid;
+ OP *sibl;
+ I32 numargs = 0;
+ register I32 oa = opargs[op->op_type] >> 8;
+
+ if (op->op_flags & OPf_STACKED) {
+ if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
+ oa &= ~OA_OPTIONAL;
+ else
+ return no_fh_allowed(op);
+ }
+
+ if (op->op_flags & OPf_KIDS) {
+ tokid = &cLISTOP->op_first;
+ kid = cLISTOP->op_first;
+ if (kid->op_type == OP_PUSHMARK) {
+ tokid = &kid->op_sibling;
+ kid = kid->op_sibling;
+ }
+
+ while (oa && kid) {
+ numargs++;
+ sibl = kid->op_sibling;
+ switch (oa & 7) {
+ case OA_SCALAR:
+ scalar(kid);
+ break;
+ case OA_LIST:
+ if (oa < 16) {
+ kid = 0;
+ continue;
+ }
+ else
+ list(kid);
+ break;
+ case OA_AVREF:
+ if (kid->op_type == OP_CONST &&
+ (kid->op_private & OPpCONST_BARE)) {
+ OP *newop = newAVREF(newGVOP(OP_GV, 0,
+ gv_fetchpv(SvPVnx(((SVOP*)kid)->op_sv), TRUE) ));
+ op_free(kid);
+ kid = newop;
+ kid->op_sibling = sibl;
+ *tokid = kid;
+ }
+ ref(kid, op->op_type);
+ break;
+ case OA_HVREF:
+ if (kid->op_type == OP_CONST &&
+ (kid->op_private & OPpCONST_BARE)) {
+ OP *newop = newHVREF(newGVOP(OP_GV, 0,
+ gv_fetchpv(SvPVnx(((SVOP*)kid)->op_sv), TRUE) ));
+ op_free(kid);
+ kid = newop;
+ kid->op_sibling = sibl;
+ *tokid = kid;
+ }
+ ref(kid, op->op_type);
+ break;
+ case OA_CVREF:
+ {
+ OP *newop = newUNOP(OP_NULL, 0, scalar(kid));
+ kid->op_sibling = 0;
+ linklist(kid);
+ newop->op_next = newop;
+ kid = newop;
+ kid->op_sibling = sibl;
+ *tokid = kid;
+ }
+ break;
+ case OA_FILEREF:
+ if (kid->op_type != OP_GV) {
+ if (kid->op_type == OP_CONST &&
+ (kid->op_private & OPpCONST_BARE)) {
+ OP *newop = newGVOP(OP_GV, 0,
+ gv_fetchpv(SvPVnx(((SVOP*)kid)->op_sv), TRUE) );
+ op_free(kid);
+ kid = newop;
+ }
+ else {
+ kid->op_sibling = 0;
+ kid = newUNOP(OP_RV2GV, 0, scalar(kid));
+ }
+ kid->op_sibling = sibl;
+ *tokid = kid;
+ }
+ scalar(kid);
+ break;
+ case OA_SCALARREF:
+ ref(scalar(kid), op->op_type);
+ break;
+ }
+ oa >>= 4;
+ tokid = &kid->op_sibling;
+ kid = kid->op_sibling;
+ }
+ op->op_private = numargs;
+ if (kid)
+ return too_many_arguments(op);
+ listkids(op);
+ }
+ if (oa) {
+ while (oa & OA_OPTIONAL)
+ oa >>= 4;
+ if (oa && oa != OA_LIST)
+ return too_few_arguments(op);
+ }
+ return op;
+}
+
+OP *
+ck_glob(op)
+OP *op;
+{
+ GV *gv = newGVgen();
+ GvIOn(gv);
+ append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv));
+ scalarkids(op);
+ return op;
+}
+
+OP *
+ck_grep(op)
+OP *op;
+{
+ LOGOP *gwop;
+ OP *kid;
+
+ op->op_flags &= ~OPf_STACKED; /* XXX do we need to scope() it? */
+ op = ck_fun(op);
+ if (error_count)
+ return op;
+ kid = cLISTOP->op_first->op_sibling;
+ if (kid->op_type != OP_NULL)
+ fatal("panic: ck_grep");
+ kid = kUNOP->op_first;
+
+ Newz(1101, gwop, 1, LOGOP);
+ gwop->op_type = OP_GREPWHILE;
+ gwop->op_ppaddr = ppaddr[OP_GREPWHILE];
+ gwop->op_first = list(op);
+ gwop->op_flags |= OPf_KIDS;
+ gwop->op_private = 1;
+ gwop->op_other = LINKLIST(kid);
+ gwop->op_targ = pad_alloc(OP_GREPWHILE,'T');
+ kid->op_next = (OP*)gwop;
+
+ return (OP*)gwop;
+}
+
+OP *
+ck_index(op)
+OP *op;
+{
+ if (op->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
+ if (kid && kid->op_type == OP_CONST)
+ fbm_compile(((SVOP*)kid)->op_sv, 0);
+ }
+ return ck_fun(op);
+}
+
+OP *
+ck_lengthconst(op)
+OP *op;
+{
+ /* XXX length optimization goes here */
+ return op;
+}
+
+OP *
+ck_lfun(op)
+OP *op;
+{
+ return refkids(ck_fun(op), op->op_type);
+}
+
+OP *
+ck_listiob(op)
+OP *op;
+{
+ register OP *kid;
+
+ kid = cLISTOP->op_first;
+ if (!kid) {
+ prepend_elem(op->op_type, newOP(OP_PUSHMARK), op);
+ kid = cLISTOP->op_first;
+ }
+ if (kid->op_type == OP_PUSHMARK)
+ kid = kid->op_sibling;
+ if (kid && op->op_flags & OPf_STACKED)
+ kid = kid->op_sibling;
+ else if (kid && !kid->op_sibling) { /* print HANDLE; */
+ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
+ op->op_flags |= OPf_STACKED; /* make it a filehandle */
+ kid = newUNOP(OP_RV2GV, 0, scalar(kid));
+ cLISTOP->op_first->op_sibling = kid;
+ cLISTOP->op_last = kid;
+ kid = kid->op_sibling;
+ }
+ }
+
+ if (!kid)
+ append_elem(op->op_type, op, newSVREF(newGVOP(OP_GV, 0, defgv)) );
+
+ return listkids(op);
+}
+
+OP *
+ck_match(op)
+OP *op;
+{
+ cPMOP->op_pmflags |= PMf_RUNTIME;
+ return op;
+}
+
+OP *
+ck_null(op)
+OP *op;
+{
+ return op;
+}
+
+OP *
+ck_repeat(op)
+OP *op;
+{
+ if (cBINOP->op_first->op_flags & OPf_PARENS) {
+ op->op_private = OPpREPEAT_DOLIST;
+ cBINOP->op_first =
+ prepend_elem(OP_NULL, newOP(OP_PUSHMARK, 0), cBINOP->op_first);
+ }
+ else
+ scalar(op);
+ return op;
+}
+
+OP *
+ck_retarget(op)
+OP *op;
+{
+ fatal("NOT IMPL LINE %d",__LINE__);
+ /* STUB */
+ return op;
+}
+
+OP *
+ck_select(op)
+OP *op;
+{
+ if (op->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
+ if (kid) {
+ op->op_type = OP_SSELECT;
+ op->op_ppaddr = ppaddr[OP_SSELECT];
+ op = ck_fun(op);
+ return fold_constants(op);
+ }
+ }
+ return ck_fun(op);
+}
+
+OP *
+ck_shift(op)
+OP *op;
+{
+ I32 type = op->op_type;
+
+ if (!(op->op_flags & OPf_KIDS)) {
+ op_free(op);
+ return newUNOP(type, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ scalar(newGVOP(OP_GV, 0,
+ gv_fetchpv((subline ? "_" : "ARGV"), TRUE) )))));
+ }
+ return scalar(refkids(ck_fun(op), type));
+}
+
+OP *
+ck_sort(op)
+OP *op;
+{
+ if (op->op_flags & OPf_STACKED) {
+ OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
+ kid = kUNOP->op_first; /* get past sv2gv */
+ if (kid->op_type == OP_LEAVE) {
+ OP *k;
+
+ linklist(kid);
+ kid->op_type = OP_NULL; /* wipe out leave */
+ kid->op_ppaddr = ppaddr[OP_NULL];
+ kid->op_next = kid;
+
+ for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
+ if (k->op_next == kid)
+ k->op_next = 0;
+ }
+ kid->op_type = OP_NULL; /* wipe out enter */
+ kid->op_ppaddr = ppaddr[OP_NULL];
+
+ kid = cLISTOP->op_first->op_sibling;
+ kid->op_type = OP_NULL; /* wipe out sv2gv */
+ kid->op_ppaddr = ppaddr[OP_NULL];
+ kid->op_next = kid;
+
+ op->op_flags |= OPf_SPECIAL;
+ }
+ }
+ return op;
+}
+
+OP *
+ck_split(op)
+OP *op;
+{
+ register OP *kid;
+
+ if (op->op_flags & OPf_STACKED)
+ return no_fh_allowed(op);
+
+ if (!(op->op_flags & OPf_KIDS))
+ op = prepend_elem(OP_SPLIT,
+ pmruntime(
+ newPMOP(OP_MATCH, OPf_SPECIAL),
+ newSVOP(OP_CONST, 0, newSVpv(" ", 1)),
+ Nullop),
+ op);
+
+ kid = cLISTOP->op_first;
+ if (kid->op_type == OP_PUSHMARK)
+ fatal("panic: ck_split");
+
+ if (kid->op_type != OP_MATCH) {
+ OP *sibl = kid->op_sibling;
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
+ if (cLISTOP->op_first == cLISTOP->op_last)
+ cLISTOP->op_last = kid;
+ cLISTOP->op_first = kid;
+ kid->op_sibling = sibl;
+ }
+
+ kid->op_type = OP_PUSHRE;
+ kid->op_ppaddr = ppaddr[OP_PUSHRE];
+ scalar(kid);
+
+ if (!kid->op_sibling)
+ append_elem(OP_SPLIT, op, newSVREF(newGVOP(OP_GV, 0, defgv)) );
+
+ kid = kid->op_sibling;
+ scalar(kid);
+
+ if (!kid->op_sibling)
+ append_elem(OP_SPLIT, op, newSVOP(OP_CONST, 0, newSViv(0)));
+
+ kid = kid->op_sibling;
+ scalar(kid);
+
+ if (kid->op_sibling)
+ return too_many_arguments(op);
+
+ return op;
+}
+
+OP *
+ck_subr(op)
+OP *op;
+{
+ op->op_private = 0;
+ return op;
+}
+
+OP *
+ck_trunc(op)
+OP *op;
+{
+ if (op->op_flags & OPf_KIDS) {
+ SVOP *kid = (SVOP*)cUNOP->op_first;
+
+ if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE))
+ op->op_flags |= OPf_SPECIAL;
+ }
+ return ck_fun(op);
+}
+
+void
+peep(op)
+register OP* op;
+{
+ register OP* oldop = 0;
+ if (!op || op->op_seq)
+ return;
+ for (; op; op = op->op_next) {
+ if (op->op_seq)
+ return;
+ switch (op->op_type) {
+ case OP_NULL:
+ case OP_SCALAR:
+ if (oldop) {
+ oldop->op_next = op->op_next;
+ continue;
+ }
+ op->op_seq = ++op_seq;
+ break;
+
+ case OP_GV:
+ if (op->op_next->op_type == OP_RV2SV) {
+ op->op_next->op_type = OP_NULL;
+ op->op_next->op_ppaddr = ppaddr[OP_NULL];
+ op->op_flags |= op->op_next->op_flags & OPf_LOCAL;
+ op->op_next = op->op_next->op_next;
+ op->op_type = OP_GVSV;
+ op->op_ppaddr = ppaddr[OP_GVSV];
+ }
+ op->op_seq = ++op_seq;
+ break;
+
+ case OP_GREPWHILE:
+ case OP_AND:
+ case OP_OR:
+ op->op_seq = ++op_seq;
+ peep(cLOGOP->op_other);
+ break;
+
+ case OP_COND_EXPR:
+ op->op_seq = ++op_seq;
+ peep(cCONDOP->op_true);
+ peep(cCONDOP->op_false);
+ break;
+
+ case OP_ENTERLOOP:
+ op->op_seq = ++op_seq;
+ peep(cLOOP->op_redoop);
+ peep(cLOOP->op_nextop);
+ peep(cLOOP->op_lastop);
+ break;
+
+ case OP_MATCH:
+ case OP_SUBST:
+ op->op_seq = ++op_seq;
+ peep(cPMOP->op_pmreplroot);
+ break;
+
+ default:
+ op->op_seq = ++op_seq;
+ break;
+ }
+ oldop = op;
+ }
+}
--- /dev/null
+/* $RCSfile: arg.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:16 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: arg.h,v $
+ */
+
+/*
+ * The fields of BASEOP are:
+ * op_next Pointer to next ppcode to execute after this one.
+ * (Top level pre-grafted op points to first op,
+ * but this is replaced when op is grafted in, when
+ * this op will point to the real next op, and the new
+ * parent takes over role of remembering starting op.)
+ * op_ppaddr Pointer to current ppcode's function.
+ * op_type The type of the operation.
+ * op_flags Flags common to all operations. See OPf_* below.
+ * op_private Flags peculiar to a particular operation (BUT,
+ * by default, set to the number of children until
+ * the operation is privatized by a check routine,
+ * which may or may not check number of children).
+ */
+
+typedef U16 PADOFFSET;
+
+#ifdef DEBUGGING
+#define OPCODE opcode
+#else
+#define OPCODE U16
+#endif
+
+#define BASEOP \
+ OP* op_next; \
+ OP* op_sibling; \
+ OP* (*op_ppaddr)(); \
+ PADOFFSET op_targ; \
+ OPCODE op_type; \
+ U16 op_seq; \
+ char op_flags; \
+ char op_private;
+
+#define GIMME (op->op_flags & OPf_KNOW ? op->op_flags & OPf_LIST : getgimme(op))
+
+/* Public flags */
+#define OPf_LIST 1 /* Do operator in list context. */
+#define OPf_KNOW 2 /* Context is known. */
+#define OPf_KIDS 4 /* There is a firstborn child. */
+#define OPf_PARENS 8 /* This operator was parenthesized. */
+#define OPf_STACKED 16 /* Some arg is arriving on the stack. */
+#define OPf_LVAL 32 /* Certified reference (lvalue). */
+#define OPf_LOCAL 64 /* Lvalue must be localized */
+#define OPf_SPECIAL 128 /* Do something weird for this op: */
+ /* On local LVAL, don't init local value. */
+ /* On OP_SORT, subroutine is inlined. */
+ /* On OP_NOT, inversion was implicit. */
+ /* On file tests, we fstat filehandle */
+ /* On truncate, we truncate filehandle */
+ /* On control verbs, we saw no label */
+ /* On flipflop, we saw ... instead of .. */
+ /* On UNOPs, saw bare parens, e.g. eof(). */
+ /* On OP_ENTERSUBR || OP_NULL, saw a "do". */
+
+/* Private for OP_ASSIGN */
+#define OPpASSIGN_COMMON 1 /* Left & right have syms in common. */
+
+/* Private for OP_TRANS */
+#define OPpTRANS_SQUASH 1
+#define OPpTRANS_DELETE 2
+#define OPpTRANS_COMPLEMENT 4
+
+/* Private for OP_REPEAT */
+#define OPpREPEAT_DOLIST 1 /* List replication. */
+
+/* Private for OP_SUBR */
+#define OPpSUBR_DB 1 /* Debug subroutine. */
+
+/* Private for OP_CONST */
+#define OPpCONST_BARE 1 /* Was a bare word (filehandle?). */
+
+/* Private for OP_FLIP/FLOP */
+#define OPpFLIP_LINENUM 1 /* Range arg potentially a line num. */
+
+struct op {
+ BASEOP
+};
+
+struct unop {
+ BASEOP
+ OP * op_first;
+};
+
+struct binop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+};
+
+struct logop {
+ BASEOP
+ OP * op_first;
+ OP * op_other;
+};
+
+struct condop {
+ BASEOP
+ OP * op_first;
+ OP * op_true;
+ OP * op_false;
+};
+
+struct listop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+ U32 op_children;
+};
+
+struct pmop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+ U32 op_children;
+ OP * op_pmreplroot;
+ OP * op_pmreplstart;
+ PMOP * op_pmnext; /* list of all scanpats */
+ REGEXP * op_pmregexp; /* compiled expression */
+ SV * op_pmshort; /* for a fast bypass of execute() */
+ short op_pmflags;
+ char op_pmslen;
+};
+#define PMf_USED 1 /* pm has been used once already */
+#define PMf_ONCE 2 /* use pattern only once per reset */
+#define PMf_SCANFIRST 4 /* initial constant not anchored */
+#define PMf_ALL 8 /* initial constant is whole pat */
+#define PMf_SKIPWHITE 16 /* skip leading whitespace for split */
+#define PMf_FOLD 32 /* case insensitivity */
+#define PMf_CONST 64 /* subst replacement is constant */
+#define PMf_KEEP 128 /* keep 1st runtime pattern forever */
+#define PMf_GLOBAL 256 /* pattern had a g modifier */
+#define PMf_RUNTIME 512 /* pattern coming in on the stack */
+#define PMf_EVAL 1024 /* evaluating replacement as expr */
+
+struct svop {
+ BASEOP
+ SV * op_sv;
+};
+
+struct gvop {
+ BASEOP
+ GV * op_gv;
+};
+
+struct pvop {
+ BASEOP
+ char * op_pv;
+};
+
+struct cvop {
+ BASEOP
+ CV * op_cv;
+ OP * op_cont;
+};
+
+struct loop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+ U32 op_children;
+ OP * op_redoop;
+ OP * op_nextop;
+ OP * op_lastop;
+};
+
+#define cUNOP ((UNOP*)op)
+#define cBINOP ((BINOP*)op)
+#define cLISTOP ((LISTOP*)op)
+#define cLOGOP ((LOGOP*)op)
+#define cCONDOP ((CONDOP*)op)
+#define cPMOP ((PMOP*)op)
+#define cSVOP ((SVOP*)op)
+#define cGVOP ((GVOP*)op)
+#define cPVOP ((PVOP*)op)
+#define cCVOP ((CVOP*)op)
+#define cCOP ((COP*)op)
+#define cLOOP ((LOOP*)op)
+
+#define kUNOP ((UNOP*)kid)
+#define kBINOP ((BINOP*)kid)
+#define kLISTOP ((LISTOP*)kid)
+#define kLOGOP ((LOGOP*)kid)
+#define kCONDOP ((CONDOP*)kid)
+#define kPMOP ((PMOP*)kid)
+#define kSVOP ((SVOP*)kid)
+#define kGVOP ((GVOP*)kid)
+#define kPVOP ((PVOP*)kid)
+#define kCVOP ((CVOP*)kid)
+#define kCOP ((COP*)kid)
+#define kLOOP ((LOOP*)kid)
+
+#define Nullop Null(OP*)
+
--- /dev/null
+typedef enum {
+ OP_NULL, /* 0 */
+ OP_SCALAR, /* 1 */
+ OP_PUSHMARK, /* 2 */
+ OP_WANTARRAY, /* 3 */
+ OP_WORD, /* 4 */
+ OP_CONST, /* 5 */
+ OP_INTERP, /* 6 */
+ OP_GVSV, /* 7 */
+ OP_GV, /* 8 */
+ OP_PUSHRE, /* 9 */
+ OP_RV2GV, /* 10 */
+ OP_SV2LEN, /* 11 */
+ OP_RV2SV, /* 12 */
+ OP_AV2ARYLEN, /* 13 */
+ OP_RV2CV, /* 14 */
+ OP_REFGEN, /* 15 */
+ OP_REF, /* 16 */
+ OP_BLESS, /* 17 */
+ OP_BACKTICK, /* 18 */
+ OP_GLOB, /* 19 */
+ OP_READLINE, /* 20 */
+ OP_RCATLINE, /* 21 */
+ OP_REGCOMP, /* 22 */
+ OP_MATCH, /* 23 */
+ OP_SUBST, /* 24 */
+ OP_SUBSTCONT, /* 25 */
+ OP_TRANS, /* 26 */
+ OP_SASSIGN, /* 27 */
+ OP_AASSIGN, /* 28 */
+ OP_SCHOP, /* 29 */
+ OP_CHOP, /* 30 */
+ OP_DEFINED, /* 31 */
+ OP_UNDEF, /* 32 */
+ OP_STUDY, /* 33 */
+ OP_PREINC, /* 34 */
+ OP_PREDEC, /* 35 */
+ OP_POSTINC, /* 36 */
+ OP_POSTDEC, /* 37 */
+ OP_POW, /* 38 */
+ OP_MULTIPLY, /* 39 */
+ OP_DIVIDE, /* 40 */
+ OP_MODULO, /* 41 */
+ OP_REPEAT, /* 42 */
+ OP_ADD, /* 43 */
+ OP_INTADD, /* 44 */
+ OP_SUBTRACT, /* 45 */
+ OP_CONCAT, /* 46 */
+ OP_LEFT_SHIFT, /* 47 */
+ OP_RIGHT_SHIFT, /* 48 */
+ OP_LT, /* 49 */
+ OP_GT, /* 50 */
+ OP_LE, /* 51 */
+ OP_GE, /* 52 */
+ OP_EQ, /* 53 */
+ OP_NE, /* 54 */
+ OP_NCMP, /* 55 */
+ OP_SLT, /* 56 */
+ OP_SGT, /* 57 */
+ OP_SLE, /* 58 */
+ OP_SGE, /* 59 */
+ OP_SEQ, /* 60 */
+ OP_SNE, /* 61 */
+ OP_SCMP, /* 62 */
+ OP_BIT_AND, /* 63 */
+ OP_XOR, /* 64 */
+ OP_BIT_OR, /* 65 */
+ OP_NEGATE, /* 66 */
+ OP_NOT, /* 67 */
+ OP_COMPLEMENT, /* 68 */
+ OP_ATAN2, /* 69 */
+ OP_SIN, /* 70 */
+ OP_COS, /* 71 */
+ OP_RAND, /* 72 */
+ OP_SRAND, /* 73 */
+ OP_EXP, /* 74 */
+ OP_LOG, /* 75 */
+ OP_SQRT, /* 76 */
+ OP_INT, /* 77 */
+ OP_HEX, /* 78 */
+ OP_OCT, /* 79 */
+ OP_LENGTH, /* 80 */
+ OP_SUBSTR, /* 81 */
+ OP_VEC, /* 82 */
+ OP_INDEX, /* 83 */
+ OP_RINDEX, /* 84 */
+ OP_SPRINTF, /* 85 */
+ OP_FORMLINE, /* 86 */
+ OP_ORD, /* 87 */
+ OP_CRYPT, /* 88 */
+ OP_UCFIRST, /* 89 */
+ OP_LCFIRST, /* 90 */
+ OP_UC, /* 91 */
+ OP_LC, /* 92 */
+ OP_RV2AV, /* 93 */
+ OP_AELEMFAST, /* 94 */
+ OP_AELEM, /* 95 */
+ OP_ASLICE, /* 96 */
+ OP_EACH, /* 97 */
+ OP_VALUES, /* 98 */
+ OP_KEYS, /* 99 */
+ OP_DELETE, /* 100 */
+ OP_RV2HV, /* 101 */
+ OP_HELEM, /* 102 */
+ OP_HSLICE, /* 103 */
+ OP_UNPACK, /* 104 */
+ OP_PACK, /* 105 */
+ OP_SPLIT, /* 106 */
+ OP_JOIN, /* 107 */
+ OP_LIST, /* 108 */
+ OP_LSLICE, /* 109 */
+ OP_ANONLIST, /* 110 */
+ OP_ANONHASH, /* 111 */
+ OP_SPLICE, /* 112 */
+ OP_PUSH, /* 113 */
+ OP_POP, /* 114 */
+ OP_SHIFT, /* 115 */
+ OP_UNSHIFT, /* 116 */
+ OP_SORT, /* 117 */
+ OP_REVERSE, /* 118 */
+ OP_GREPSTART, /* 119 */
+ OP_GREPWHILE, /* 120 */
+ OP_RANGE, /* 121 */
+ OP_FLIP, /* 122 */
+ OP_FLOP, /* 123 */
+ OP_AND, /* 124 */
+ OP_OR, /* 125 */
+ OP_COND_EXPR, /* 126 */
+ OP_ANDASSIGN, /* 127 */
+ OP_ORASSIGN, /* 128 */
+ OP_METHOD, /* 129 */
+ OP_ENTERSUBR, /* 130 */
+ OP_LEAVESUBR, /* 131 */
+ OP_CALLER, /* 132 */
+ OP_WARN, /* 133 */
+ OP_DIE, /* 134 */
+ OP_RESET, /* 135 */
+ OP_LINESEQ, /* 136 */
+ OP_CURCOP, /* 137 */
+ OP_UNSTACK, /* 138 */
+ OP_ENTER, /* 139 */
+ OP_LEAVE, /* 140 */
+ OP_ENTERITER, /* 141 */
+ OP_ITER, /* 142 */
+ OP_ENTERLOOP, /* 143 */
+ OP_LEAVELOOP, /* 144 */
+ OP_RETURN, /* 145 */
+ OP_LAST, /* 146 */
+ OP_NEXT, /* 147 */
+ OP_REDO, /* 148 */
+ OP_DUMP, /* 149 */
+ OP_GOTO, /* 150 */
+ OP_EXIT, /* 151 */
+ OP_NSWITCH, /* 152 */
+ OP_CSWITCH, /* 153 */
+ OP_OPEN, /* 154 */
+ OP_CLOSE, /* 155 */
+ OP_PIPE_OP, /* 156 */
+ OP_FILENO, /* 157 */
+ OP_UMASK, /* 158 */
+ OP_BINMODE, /* 159 */
+ OP_DBMOPEN, /* 160 */
+ OP_DBMCLOSE, /* 161 */
+ OP_SSELECT, /* 162 */
+ OP_SELECT, /* 163 */
+ OP_GETC, /* 164 */
+ OP_READ, /* 165 */
+ OP_ENTERWRITE, /* 166 */
+ OP_LEAVEWRITE, /* 167 */
+ OP_PRTF, /* 168 */
+ OP_PRINT, /* 169 */
+ OP_SYSREAD, /* 170 */
+ OP_SYSWRITE, /* 171 */
+ OP_SEND, /* 172 */
+ OP_RECV, /* 173 */
+ OP_EOF, /* 174 */
+ OP_TELL, /* 175 */
+ OP_SEEK, /* 176 */
+ OP_TRUNCATE, /* 177 */
+ OP_FCNTL, /* 178 */
+ OP_IOCTL, /* 179 */
+ OP_FLOCK, /* 180 */
+ OP_SOCKET, /* 181 */
+ OP_SOCKPAIR, /* 182 */
+ OP_BIND, /* 183 */
+ OP_CONNECT, /* 184 */
+ OP_LISTEN, /* 185 */
+ OP_ACCEPT, /* 186 */
+ OP_SHUTDOWN, /* 187 */
+ OP_GSOCKOPT, /* 188 */
+ OP_SSOCKOPT, /* 189 */
+ OP_GETSOCKNAME, /* 190 */
+ OP_GETPEERNAME, /* 191 */
+ OP_LSTAT, /* 192 */
+ OP_STAT, /* 193 */
+ OP_FTRREAD, /* 194 */
+ OP_FTRWRITE, /* 195 */
+ OP_FTREXEC, /* 196 */
+ OP_FTEREAD, /* 197 */
+ OP_FTEWRITE, /* 198 */
+ OP_FTEEXEC, /* 199 */
+ OP_FTIS, /* 200 */
+ OP_FTEOWNED, /* 201 */
+ OP_FTROWNED, /* 202 */
+ OP_FTZERO, /* 203 */
+ OP_FTSIZE, /* 204 */
+ OP_FTMTIME, /* 205 */
+ OP_FTATIME, /* 206 */
+ OP_FTCTIME, /* 207 */
+ OP_FTSOCK, /* 208 */
+ OP_FTCHR, /* 209 */
+ OP_FTBLK, /* 210 */
+ OP_FTFILE, /* 211 */
+ OP_FTDIR, /* 212 */
+ OP_FTPIPE, /* 213 */
+ OP_FTLINK, /* 214 */
+ OP_FTSUID, /* 215 */
+ OP_FTSGID, /* 216 */
+ OP_FTSVTX, /* 217 */
+ OP_FTTTY, /* 218 */
+ OP_FTTEXT, /* 219 */
+ OP_FTBINARY, /* 220 */
+ OP_CHDIR, /* 221 */
+ OP_CHOWN, /* 222 */
+ OP_CHROOT, /* 223 */
+ OP_UNLINK, /* 224 */
+ OP_CHMOD, /* 225 */
+ OP_UTIME, /* 226 */
+ OP_RENAME, /* 227 */
+ OP_LINK, /* 228 */
+ OP_SYMLINK, /* 229 */
+ OP_READLINK, /* 230 */
+ OP_MKDIR, /* 231 */
+ OP_RMDIR, /* 232 */
+ OP_OPEN_DIR, /* 233 */
+ OP_READDIR, /* 234 */
+ OP_TELLDIR, /* 235 */
+ OP_SEEKDIR, /* 236 */
+ OP_REWINDDIR, /* 237 */
+ OP_CLOSEDIR, /* 238 */
+ OP_FORK, /* 239 */
+ OP_WAIT, /* 240 */
+ OP_WAITPID, /* 241 */
+ OP_SYSTEM, /* 242 */
+ OP_EXEC, /* 243 */
+ OP_KILL, /* 244 */
+ OP_GETPPID, /* 245 */
+ OP_GETPGRP, /* 246 */
+ OP_SETPGRP, /* 247 */
+ OP_GETPRIORITY, /* 248 */
+ OP_SETPRIORITY, /* 249 */
+ OP_TIME, /* 250 */
+ OP_TMS, /* 251 */
+ OP_LOCALTIME, /* 252 */
+ OP_GMTIME, /* 253 */
+ OP_ALARM, /* 254 */
+ OP_SLEEP, /* 255 */
+ OP_SHMGET, /* 256 */
+ OP_SHMCTL, /* 257 */
+ OP_SHMREAD, /* 258 */
+ OP_SHMWRITE, /* 259 */
+ OP_MSGGET, /* 260 */
+ OP_MSGCTL, /* 261 */
+ OP_MSGSND, /* 262 */
+ OP_MSGRCV, /* 263 */
+ OP_SEMGET, /* 264 */
+ OP_SEMCTL, /* 265 */
+ OP_SEMOP, /* 266 */
+ OP_REQUIRE, /* 267 */
+ OP_DOFILE, /* 268 */
+ OP_ENTEREVAL, /* 269 */
+ OP_LEAVEEVAL, /* 270 */
+ OP_EVALONCE, /* 271 */
+ OP_ENTERTRY, /* 272 */
+ OP_LEAVETRY, /* 273 */
+ OP_GHBYNAME, /* 274 */
+ OP_GHBYADDR, /* 275 */
+ OP_GHOSTENT, /* 276 */
+ OP_GNBYNAME, /* 277 */
+ OP_GNBYADDR, /* 278 */
+ OP_GNETENT, /* 279 */
+ OP_GPBYNAME, /* 280 */
+ OP_GPBYNUMBER, /* 281 */
+ OP_GPROTOENT, /* 282 */
+ OP_GSBYNAME, /* 283 */
+ OP_GSBYPORT, /* 284 */
+ OP_GSERVENT, /* 285 */
+ OP_SHOSTENT, /* 286 */
+ OP_SNETENT, /* 287 */
+ OP_SPROTOENT, /* 288 */
+ OP_SSERVENT, /* 289 */
+ OP_EHOSTENT, /* 290 */
+ OP_ENETENT, /* 291 */
+ OP_EPROTOENT, /* 292 */
+ OP_ESERVENT, /* 293 */
+ OP_GPWNAM, /* 294 */
+ OP_GPWUID, /* 295 */
+ OP_GPWENT, /* 296 */
+ OP_SPWENT, /* 297 */
+ OP_EPWENT, /* 298 */
+ OP_GGRNAM, /* 299 */
+ OP_GGRGID, /* 300 */
+ OP_GGRENT, /* 301 */
+ OP_SGRENT, /* 302 */
+ OP_EGRENT, /* 303 */
+ OP_GETLOGIN, /* 304 */
+ OP_SYSCALL, /* 305 */
+} opcode;
+
+#define MAXO 306
+
+#ifndef DOINIT
+extern char *op_name[];
+#else
+char *op_name[] = {
+ "null operation",
+ "null operation",
+ "pushmark",
+ "wantarray",
+ "bare word",
+ "constant item",
+ "interpreted string",
+ "scalar variable",
+ "glob value",
+ "push regexp",
+ "ref-to-glob cast",
+ "scalar value length",
+ "ref-to-scalar cast",
+ "array length",
+ "subroutine reference",
+ "backslash reference",
+ "reference-type operator",
+ "bless",
+ "backticks",
+ "glob",
+ "<HANDLE>",
+ "append I/O operator",
+ "regexp compilation",
+ "pattern match",
+ "substitution",
+ "substitution cont",
+ "character translation",
+ "scalar assignment",
+ "list assignment",
+ "scalar chop",
+ "chop",
+ "defined operator",
+ "undef operator",
+ "study",
+ "preincrement",
+ "predecrement",
+ "postincrement",
+ "postdecrement",
+ "exponentiation",
+ "multiplication",
+ "division",
+ "modulus",
+ "repeat",
+ "addition",
+ "integer addition",
+ "subtraction",
+ "concatenation",
+ "left bitshift",
+ "right bitshift",
+ "numeric lt",
+ "numeric gt",
+ "numeric le",
+ "numeric ge",
+ "numeric eq",
+ "numeric ne",
+ "spaceship",
+ "string lt",
+ "string gt",
+ "string le",
+ "string ge",
+ "string eq",
+ "string ne",
+ "string comparison",
+ "bit and",
+ "xor",
+ "bit or",
+ "negate",
+ "not",
+ "1's complement",
+ "atan2",
+ "sin",
+ "cos",
+ "rand",
+ "srand",
+ "exp",
+ "log",
+ "sqrt",
+ "int",
+ "hex",
+ "oct",
+ "length",
+ "substr",
+ "vec",
+ "index",
+ "rindex",
+ "sprintf",
+ "formline",
+ "ord",
+ "crypt",
+ "upper case first",
+ "lower case first",
+ "upper case",
+ "lower case",
+ "array deref",
+ "known array element",
+ "array element",
+ "array slice",
+ "each",
+ "values",
+ "keys",
+ "delete",
+ "associative array deref",
+ "associative array elem",
+ "associative array slice",
+ "unpack",
+ "pack",
+ "split",
+ "join",
+ "list",
+ "list slice",
+ "anonymous list",
+ "anonymous hash",
+ "splice",
+ "push",
+ "pop",
+ "shift",
+ "unshift",
+ "sort",
+ "reverse",
+ "grep",
+ "grep iterator",
+ "flipflop",
+ "range (or flip)",
+ "range (or flop)",
+ "logical and",
+ "logical or",
+ "conditional expression",
+ "logical and assignment",
+ "logical or assignment",
+ "method lookup",
+ "subroutine entry",
+ "subroutine exit",
+ "caller",
+ "warn",
+ "die",
+ "reset",
+ "line sequence",
+ "next statement",
+ "unstack",
+ "block entry",
+ "block exit",
+ "foreach loop entry",
+ "foreach loop iterator",
+ "loop entry",
+ "loop exit",
+ "return",
+ "last",
+ "next",
+ "redo",
+ "dump",
+ "goto",
+ "exit",
+ "numeric switch",
+ "character switch",
+ "open",
+ "close",
+ "pipe",
+ "fileno",
+ "umask",
+ "binmode",
+ "dbmopen",
+ "dbmclose",
+ "select system call",
+ "select",
+ "getc",
+ "read",
+ "write",
+ "write exit",
+ "prtf",
+ "print",
+ "sysread",
+ "syswrite",
+ "send",
+ "recv",
+ "eof",
+ "tell",
+ "seek",
+ "truncate",
+ "fcntl",
+ "ioctl",
+ "flock",
+ "socket",
+ "socketpair",
+ "bind",
+ "connect",
+ "listen",
+ "accept",
+ "shutdown",
+ "getsockopt",
+ "setsockopt",
+ "getsockname",
+ "getpeername",
+ "lstat",
+ "stat",
+ "-R",
+ "-W",
+ "-X",
+ "-r",
+ "-w",
+ "-x",
+ "-e",
+ "-O",
+ "-o",
+ "-z",
+ "-s",
+ "-M",
+ "-A",
+ "-C",
+ "-S",
+ "-c",
+ "-b",
+ "-f",
+ "-d",
+ "-p",
+ "-l",
+ "-u",
+ "-g",
+ "-k",
+ "-t",
+ "-T",
+ "-B",
+ "chdir",
+ "chown",
+ "chroot",
+ "unlink",
+ "chmod",
+ "utime",
+ "rename",
+ "link",
+ "symlink",
+ "readlink",
+ "mkdir",
+ "rmdir",
+ "opendir",
+ "readdir",
+ "telldir",
+ "seekdir",
+ "rewinddir",
+ "closedir",
+ "fork",
+ "wait",
+ "waitpid",
+ "system",
+ "exec",
+ "kill",
+ "getppid",
+ "getpgrp",
+ "setpgrp",
+ "getpriority",
+ "setpriority",
+ "time",
+ "times",
+ "localtime",
+ "gmtime",
+ "alarm",
+ "sleep",
+ "shmget",
+ "shmctl",
+ "shmread",
+ "shmwrite",
+ "msgget",
+ "msgctl",
+ "msgsnd",
+ "msgrcv",
+ "semget",
+ "semctl",
+ "semop",
+ "require",
+ "do 'file'",
+ "eval string",
+ "eval exit",
+ "eval constant string",
+ "eval block",
+ "eval block exit",
+ "gethostbyname",
+ "gethostbyaddr",
+ "gethostent",
+ "getnetbyname",
+ "getnetbyaddr",
+ "getnetent",
+ "getprotobyname",
+ "getprotobynumber",
+ "getprotoent",
+ "getservbyname",
+ "getservbyport",
+ "getservent",
+ "sethostent",
+ "setnetent",
+ "setprotoent",
+ "setservent",
+ "endhostent",
+ "endnetent",
+ "endprotoent",
+ "endservent",
+ "getpwnam",
+ "getpwuid",
+ "getpwent",
+ "setpwent",
+ "endpwent",
+ "getgrnam",
+ "getgrgid",
+ "getgrent",
+ "setgrent",
+ "endgrent",
+ "getlogin",
+ "syscall",
+};
+#endif
+
+OP * ck_aelem P((OP* op));
+OP * ck_chop P((OP* op));
+OP * ck_concat P((OP* op));
+OP * ck_eof P((OP* op));
+OP * ck_eval P((OP* op));
+OP * ck_exec P((OP* op));
+OP * ck_formline P((OP* op));
+OP * ck_ftst P((OP* op));
+OP * ck_fun P((OP* op));
+OP * ck_glob P((OP* op));
+OP * ck_grep P((OP* op));
+OP * ck_index P((OP* op));
+OP * ck_lengthconst P((OP* op));
+OP * ck_lfun P((OP* op));
+OP * ck_listiob P((OP* op));
+OP * ck_match P((OP* op));
+OP * ck_null P((OP* op));
+OP * ck_repeat P((OP* op));
+OP * ck_rvconst P((OP* op));
+OP * ck_select P((OP* op));
+OP * ck_shift P((OP* op));
+OP * ck_sort P((OP* op));
+OP * ck_split P((OP* op));
+OP * ck_subr P((OP* op));
+OP * ck_trunc P((OP* op));
+
+OP * pp_null P((ARGSproto));
+OP * pp_scalar P((ARGSproto));
+OP * pp_pushmark P((ARGSproto));
+OP * pp_wantarray P((ARGSproto));
+OP * pp_word P((ARGSproto));
+OP * pp_const P((ARGSproto));
+OP * pp_interp P((ARGSproto));
+OP * pp_gvsv P((ARGSproto));
+OP * pp_gv P((ARGSproto));
+OP * pp_pushre P((ARGSproto));
+OP * pp_rv2gv P((ARGSproto));
+OP * pp_sv2len P((ARGSproto));
+OP * pp_rv2sv P((ARGSproto));
+OP * pp_av2arylen P((ARGSproto));
+OP * pp_rv2cv P((ARGSproto));
+OP * pp_refgen P((ARGSproto));
+OP * pp_ref P((ARGSproto));
+OP * pp_bless P((ARGSproto));
+OP * pp_backtick P((ARGSproto));
+OP * pp_glob P((ARGSproto));
+OP * pp_readline P((ARGSproto));
+OP * pp_rcatline P((ARGSproto));
+OP * pp_regcomp P((ARGSproto));
+OP * pp_match P((ARGSproto));
+OP * pp_subst P((ARGSproto));
+OP * pp_substcont P((ARGSproto));
+OP * pp_trans P((ARGSproto));
+OP * pp_sassign P((ARGSproto));
+OP * pp_aassign P((ARGSproto));
+OP * pp_schop P((ARGSproto));
+OP * pp_chop P((ARGSproto));
+OP * pp_defined P((ARGSproto));
+OP * pp_undef P((ARGSproto));
+OP * pp_study P((ARGSproto));
+OP * pp_preinc P((ARGSproto));
+OP * pp_predec P((ARGSproto));
+OP * pp_postinc P((ARGSproto));
+OP * pp_postdec P((ARGSproto));
+OP * pp_pow P((ARGSproto));
+OP * pp_multiply P((ARGSproto));
+OP * pp_divide P((ARGSproto));
+OP * pp_modulo P((ARGSproto));
+OP * pp_repeat P((ARGSproto));
+OP * pp_add P((ARGSproto));
+OP * pp_intadd P((ARGSproto));
+OP * pp_subtract P((ARGSproto));
+OP * pp_concat P((ARGSproto));
+OP * pp_left_shift P((ARGSproto));
+OP * pp_right_shift P((ARGSproto));
+OP * pp_lt P((ARGSproto));
+OP * pp_gt P((ARGSproto));
+OP * pp_le P((ARGSproto));
+OP * pp_ge P((ARGSproto));
+OP * pp_eq P((ARGSproto));
+OP * pp_ne P((ARGSproto));
+OP * pp_ncmp P((ARGSproto));
+OP * pp_slt P((ARGSproto));
+OP * pp_sgt P((ARGSproto));
+OP * pp_sle P((ARGSproto));
+OP * pp_sge P((ARGSproto));
+OP * pp_seq P((ARGSproto));
+OP * pp_sne P((ARGSproto));
+OP * pp_scmp P((ARGSproto));
+OP * pp_bit_and P((ARGSproto));
+OP * pp_xor P((ARGSproto));
+OP * pp_bit_or P((ARGSproto));
+OP * pp_negate P((ARGSproto));
+OP * pp_not P((ARGSproto));
+OP * pp_complement P((ARGSproto));
+OP * pp_atan2 P((ARGSproto));
+OP * pp_sin P((ARGSproto));
+OP * pp_cos P((ARGSproto));
+OP * pp_rand P((ARGSproto));
+OP * pp_srand P((ARGSproto));
+OP * pp_exp P((ARGSproto));
+OP * pp_log P((ARGSproto));
+OP * pp_sqrt P((ARGSproto));
+OP * pp_int P((ARGSproto));
+OP * pp_hex P((ARGSproto));
+OP * pp_oct P((ARGSproto));
+OP * pp_length P((ARGSproto));
+OP * pp_substr P((ARGSproto));
+OP * pp_vec P((ARGSproto));
+OP * pp_index P((ARGSproto));
+OP * pp_rindex P((ARGSproto));
+OP * pp_sprintf P((ARGSproto));
+OP * pp_formline P((ARGSproto));
+OP * pp_ord P((ARGSproto));
+OP * pp_crypt P((ARGSproto));
+OP * pp_ucfirst P((ARGSproto));
+OP * pp_lcfirst P((ARGSproto));
+OP * pp_uc P((ARGSproto));
+OP * pp_lc P((ARGSproto));
+OP * pp_rv2av P((ARGSproto));
+OP * pp_aelemfast P((ARGSproto));
+OP * pp_aelem P((ARGSproto));
+OP * pp_aslice P((ARGSproto));
+OP * pp_each P((ARGSproto));
+OP * pp_values P((ARGSproto));
+OP * pp_keys P((ARGSproto));
+OP * pp_delete P((ARGSproto));
+OP * pp_rv2hv P((ARGSproto));
+OP * pp_helem P((ARGSproto));
+OP * pp_hslice P((ARGSproto));
+OP * pp_unpack P((ARGSproto));
+OP * pp_pack P((ARGSproto));
+OP * pp_split P((ARGSproto));
+OP * pp_join P((ARGSproto));
+OP * pp_list P((ARGSproto));
+OP * pp_lslice P((ARGSproto));
+OP * pp_anonlist P((ARGSproto));
+OP * pp_anonhash P((ARGSproto));
+OP * pp_splice P((ARGSproto));
+OP * pp_push P((ARGSproto));
+OP * pp_pop P((ARGSproto));
+OP * pp_shift P((ARGSproto));
+OP * pp_unshift P((ARGSproto));
+OP * pp_sort P((ARGSproto));
+OP * pp_reverse P((ARGSproto));
+OP * pp_grepstart P((ARGSproto));
+OP * pp_grepwhile P((ARGSproto));
+OP * pp_range P((ARGSproto));
+OP * pp_flip P((ARGSproto));
+OP * pp_flop P((ARGSproto));
+OP * pp_and P((ARGSproto));
+OP * pp_or P((ARGSproto));
+OP * pp_cond_expr P((ARGSproto));
+OP * pp_andassign P((ARGSproto));
+OP * pp_orassign P((ARGSproto));
+OP * pp_method P((ARGSproto));
+OP * pp_entersubr P((ARGSproto));
+OP * pp_leavesubr P((ARGSproto));
+OP * pp_caller P((ARGSproto));
+OP * pp_warn P((ARGSproto));
+OP * pp_die P((ARGSproto));
+OP * pp_reset P((ARGSproto));
+OP * pp_lineseq P((ARGSproto));
+OP * pp_curcop P((ARGSproto));
+OP * pp_unstack P((ARGSproto));
+OP * pp_enter P((ARGSproto));
+OP * pp_leave P((ARGSproto));
+OP * pp_enteriter P((ARGSproto));
+OP * pp_iter P((ARGSproto));
+OP * pp_enterloop P((ARGSproto));
+OP * pp_leaveloop P((ARGSproto));
+OP * pp_return P((ARGSproto));
+OP * pp_last P((ARGSproto));
+OP * pp_next P((ARGSproto));
+OP * pp_redo P((ARGSproto));
+OP * pp_dump P((ARGSproto));
+OP * pp_goto P((ARGSproto));
+OP * pp_exit P((ARGSproto));
+OP * pp_nswitch P((ARGSproto));
+OP * pp_cswitch P((ARGSproto));
+OP * pp_open P((ARGSproto));
+OP * pp_close P((ARGSproto));
+OP * pp_pipe_op P((ARGSproto));
+OP * pp_fileno P((ARGSproto));
+OP * pp_umask P((ARGSproto));
+OP * pp_binmode P((ARGSproto));
+OP * pp_dbmopen P((ARGSproto));
+OP * pp_dbmclose P((ARGSproto));
+OP * pp_sselect P((ARGSproto));
+OP * pp_select P((ARGSproto));
+OP * pp_getc P((ARGSproto));
+OP * pp_read P((ARGSproto));
+OP * pp_enterwrite P((ARGSproto));
+OP * pp_leavewrite P((ARGSproto));
+OP * pp_prtf P((ARGSproto));
+OP * pp_print P((ARGSproto));
+OP * pp_sysread P((ARGSproto));
+OP * pp_syswrite P((ARGSproto));
+OP * pp_send P((ARGSproto));
+OP * pp_recv P((ARGSproto));
+OP * pp_eof P((ARGSproto));
+OP * pp_tell P((ARGSproto));
+OP * pp_seek P((ARGSproto));
+OP * pp_truncate P((ARGSproto));
+OP * pp_fcntl P((ARGSproto));
+OP * pp_ioctl P((ARGSproto));
+OP * pp_flock P((ARGSproto));
+OP * pp_socket P((ARGSproto));
+OP * pp_sockpair P((ARGSproto));
+OP * pp_bind P((ARGSproto));
+OP * pp_connect P((ARGSproto));
+OP * pp_listen P((ARGSproto));
+OP * pp_accept P((ARGSproto));
+OP * pp_shutdown P((ARGSproto));
+OP * pp_gsockopt P((ARGSproto));
+OP * pp_ssockopt P((ARGSproto));
+OP * pp_getsockname P((ARGSproto));
+OP * pp_getpeername P((ARGSproto));
+OP * pp_lstat P((ARGSproto));
+OP * pp_stat P((ARGSproto));
+OP * pp_ftrread P((ARGSproto));
+OP * pp_ftrwrite P((ARGSproto));
+OP * pp_ftrexec P((ARGSproto));
+OP * pp_fteread P((ARGSproto));
+OP * pp_ftewrite P((ARGSproto));
+OP * pp_fteexec P((ARGSproto));
+OP * pp_ftis P((ARGSproto));
+OP * pp_fteowned P((ARGSproto));
+OP * pp_ftrowned P((ARGSproto));
+OP * pp_ftzero P((ARGSproto));
+OP * pp_ftsize P((ARGSproto));
+OP * pp_ftmtime P((ARGSproto));
+OP * pp_ftatime P((ARGSproto));
+OP * pp_ftctime P((ARGSproto));
+OP * pp_ftsock P((ARGSproto));
+OP * pp_ftchr P((ARGSproto));
+OP * pp_ftblk P((ARGSproto));
+OP * pp_ftfile P((ARGSproto));
+OP * pp_ftdir P((ARGSproto));
+OP * pp_ftpipe P((ARGSproto));
+OP * pp_ftlink P((ARGSproto));
+OP * pp_ftsuid P((ARGSproto));
+OP * pp_ftsgid P((ARGSproto));
+OP * pp_ftsvtx P((ARGSproto));
+OP * pp_fttty P((ARGSproto));
+OP * pp_fttext P((ARGSproto));
+OP * pp_ftbinary P((ARGSproto));
+OP * pp_chdir P((ARGSproto));
+OP * pp_chown P((ARGSproto));
+OP * pp_chroot P((ARGSproto));
+OP * pp_unlink P((ARGSproto));
+OP * pp_chmod P((ARGSproto));
+OP * pp_utime P((ARGSproto));
+OP * pp_rename P((ARGSproto));
+OP * pp_link P((ARGSproto));
+OP * pp_symlink P((ARGSproto));
+OP * pp_readlink P((ARGSproto));
+OP * pp_mkdir P((ARGSproto));
+OP * pp_rmdir P((ARGSproto));
+OP * pp_open_dir P((ARGSproto));
+OP * pp_readdir P((ARGSproto));
+OP * pp_telldir P((ARGSproto));
+OP * pp_seekdir P((ARGSproto));
+OP * pp_rewinddir P((ARGSproto));
+OP * pp_closedir P((ARGSproto));
+OP * pp_fork P((ARGSproto));
+OP * pp_wait P((ARGSproto));
+OP * pp_waitpid P((ARGSproto));
+OP * pp_system P((ARGSproto));
+OP * pp_exec P((ARGSproto));
+OP * pp_kill P((ARGSproto));
+OP * pp_getppid P((ARGSproto));
+OP * pp_getpgrp P((ARGSproto));
+OP * pp_setpgrp P((ARGSproto));
+OP * pp_getpriority P((ARGSproto));
+OP * pp_setpriority P((ARGSproto));
+OP * pp_time P((ARGSproto));
+OP * pp_tms P((ARGSproto));
+OP * pp_localtime P((ARGSproto));
+OP * pp_gmtime P((ARGSproto));
+OP * pp_alarm P((ARGSproto));
+OP * pp_sleep P((ARGSproto));
+OP * pp_shmget P((ARGSproto));
+OP * pp_shmctl P((ARGSproto));
+OP * pp_shmread P((ARGSproto));
+OP * pp_shmwrite P((ARGSproto));
+OP * pp_msgget P((ARGSproto));
+OP * pp_msgctl P((ARGSproto));
+OP * pp_msgsnd P((ARGSproto));
+OP * pp_msgrcv P((ARGSproto));
+OP * pp_semget P((ARGSproto));
+OP * pp_semctl P((ARGSproto));
+OP * pp_semop P((ARGSproto));
+OP * pp_require P((ARGSproto));
+OP * pp_dofile P((ARGSproto));
+OP * pp_entereval P((ARGSproto));
+OP * pp_leaveeval P((ARGSproto));
+OP * pp_evalonce P((ARGSproto));
+OP * pp_entertry P((ARGSproto));
+OP * pp_leavetry P((ARGSproto));
+OP * pp_ghbyname P((ARGSproto));
+OP * pp_ghbyaddr P((ARGSproto));
+OP * pp_ghostent P((ARGSproto));
+OP * pp_gnbyname P((ARGSproto));
+OP * pp_gnbyaddr P((ARGSproto));
+OP * pp_gnetent P((ARGSproto));
+OP * pp_gpbyname P((ARGSproto));
+OP * pp_gpbynumber P((ARGSproto));
+OP * pp_gprotoent P((ARGSproto));
+OP * pp_gsbyname P((ARGSproto));
+OP * pp_gsbyport P((ARGSproto));
+OP * pp_gservent P((ARGSproto));
+OP * pp_shostent P((ARGSproto));
+OP * pp_snetent P((ARGSproto));
+OP * pp_sprotoent P((ARGSproto));
+OP * pp_sservent P((ARGSproto));
+OP * pp_ehostent P((ARGSproto));
+OP * pp_enetent P((ARGSproto));
+OP * pp_eprotoent P((ARGSproto));
+OP * pp_eservent P((ARGSproto));
+OP * pp_gpwnam P((ARGSproto));
+OP * pp_gpwuid P((ARGSproto));
+OP * pp_gpwent P((ARGSproto));
+OP * pp_spwent P((ARGSproto));
+OP * pp_epwent P((ARGSproto));
+OP * pp_ggrnam P((ARGSproto));
+OP * pp_ggrgid P((ARGSproto));
+OP * pp_ggrent P((ARGSproto));
+OP * pp_sgrent P((ARGSproto));
+OP * pp_egrent P((ARGSproto));
+OP * pp_getlogin P((ARGSproto));
+OP * pp_syscall P((ARGSproto));
+
+#ifndef DOINIT
+extern OP * (*ppaddr[])();
+#else
+OP * (*ppaddr[])() = {
+ pp_null,
+ pp_scalar,
+ pp_pushmark,
+ pp_wantarray,
+ pp_word,
+ pp_const,
+ pp_interp,
+ pp_gvsv,
+ pp_gv,
+ pp_pushre,
+ pp_rv2gv,
+ pp_sv2len,
+ pp_rv2sv,
+ pp_av2arylen,
+ pp_rv2cv,
+ pp_refgen,
+ pp_ref,
+ pp_bless,
+ pp_backtick,
+ pp_glob,
+ pp_readline,
+ pp_rcatline,
+ pp_regcomp,
+ pp_match,
+ pp_subst,
+ pp_substcont,
+ pp_trans,
+ pp_sassign,
+ pp_aassign,
+ pp_schop,
+ pp_chop,
+ pp_defined,
+ pp_undef,
+ pp_study,
+ pp_preinc,
+ pp_predec,
+ pp_postinc,
+ pp_postdec,
+ pp_pow,
+ pp_multiply,
+ pp_divide,
+ pp_modulo,
+ pp_repeat,
+ pp_add,
+ pp_intadd,
+ pp_subtract,
+ pp_concat,
+ pp_left_shift,
+ pp_right_shift,
+ pp_lt,
+ pp_gt,
+ pp_le,
+ pp_ge,
+ pp_eq,
+ pp_ne,
+ pp_ncmp,
+ pp_slt,
+ pp_sgt,
+ pp_sle,
+ pp_sge,
+ pp_seq,
+ pp_sne,
+ pp_scmp,
+ pp_bit_and,
+ pp_xor,
+ pp_bit_or,
+ pp_negate,
+ pp_not,
+ pp_complement,
+ pp_atan2,
+ pp_sin,
+ pp_cos,
+ pp_rand,
+ pp_srand,
+ pp_exp,
+ pp_log,
+ pp_sqrt,
+ pp_int,
+ pp_hex,
+ pp_oct,
+ pp_length,
+ pp_substr,
+ pp_vec,
+ pp_index,
+ pp_rindex,
+ pp_sprintf,
+ pp_formline,
+ pp_ord,
+ pp_crypt,
+ pp_ucfirst,
+ pp_lcfirst,
+ pp_uc,
+ pp_lc,
+ pp_rv2av,
+ pp_aelemfast,
+ pp_aelem,
+ pp_aslice,
+ pp_each,
+ pp_values,
+ pp_keys,
+ pp_delete,
+ pp_rv2hv,
+ pp_helem,
+ pp_hslice,
+ pp_unpack,
+ pp_pack,
+ pp_split,
+ pp_join,
+ pp_list,
+ pp_lslice,
+ pp_anonlist,
+ pp_anonhash,
+ pp_splice,
+ pp_push,
+ pp_pop,
+ pp_shift,
+ pp_unshift,
+ pp_sort,
+ pp_reverse,
+ pp_grepstart,
+ pp_grepwhile,
+ pp_range,
+ pp_flip,
+ pp_flop,
+ pp_and,
+ pp_or,
+ pp_cond_expr,
+ pp_andassign,
+ pp_orassign,
+ pp_method,
+ pp_entersubr,
+ pp_leavesubr,
+ pp_caller,
+ pp_warn,
+ pp_die,
+ pp_reset,
+ pp_lineseq,
+ pp_curcop,
+ pp_unstack,
+ pp_enter,
+ pp_leave,
+ pp_enteriter,
+ pp_iter,
+ pp_enterloop,
+ pp_leaveloop,
+ pp_return,
+ pp_last,
+ pp_next,
+ pp_redo,
+ pp_dump,
+ pp_goto,
+ pp_exit,
+ pp_nswitch,
+ pp_cswitch,
+ pp_open,
+ pp_close,
+ pp_pipe_op,
+ pp_fileno,
+ pp_umask,
+ pp_binmode,
+ pp_dbmopen,
+ pp_dbmclose,
+ pp_sselect,
+ pp_select,
+ pp_getc,
+ pp_read,
+ pp_enterwrite,
+ pp_leavewrite,
+ pp_prtf,
+ pp_print,
+ pp_sysread,
+ pp_syswrite,
+ pp_send,
+ pp_recv,
+ pp_eof,
+ pp_tell,
+ pp_seek,
+ pp_truncate,
+ pp_fcntl,
+ pp_ioctl,
+ pp_flock,
+ pp_socket,
+ pp_sockpair,
+ pp_bind,
+ pp_connect,
+ pp_listen,
+ pp_accept,
+ pp_shutdown,
+ pp_gsockopt,
+ pp_ssockopt,
+ pp_getsockname,
+ pp_getpeername,
+ pp_lstat,
+ pp_stat,
+ pp_ftrread,
+ pp_ftrwrite,
+ pp_ftrexec,
+ pp_fteread,
+ pp_ftewrite,
+ pp_fteexec,
+ pp_ftis,
+ pp_fteowned,
+ pp_ftrowned,
+ pp_ftzero,
+ pp_ftsize,
+ pp_ftmtime,
+ pp_ftatime,
+ pp_ftctime,
+ pp_ftsock,
+ pp_ftchr,
+ pp_ftblk,
+ pp_ftfile,
+ pp_ftdir,
+ pp_ftpipe,
+ pp_ftlink,
+ pp_ftsuid,
+ pp_ftsgid,
+ pp_ftsvtx,
+ pp_fttty,
+ pp_fttext,
+ pp_ftbinary,
+ pp_chdir,
+ pp_chown,
+ pp_chroot,
+ pp_unlink,
+ pp_chmod,
+ pp_utime,
+ pp_rename,
+ pp_link,
+ pp_symlink,
+ pp_readlink,
+ pp_mkdir,
+ pp_rmdir,
+ pp_open_dir,
+ pp_readdir,
+ pp_telldir,
+ pp_seekdir,
+ pp_rewinddir,
+ pp_closedir,
+ pp_fork,
+ pp_wait,
+ pp_waitpid,
+ pp_system,
+ pp_exec,
+ pp_kill,
+ pp_getppid,
+ pp_getpgrp,
+ pp_setpgrp,
+ pp_getpriority,
+ pp_setpriority,
+ pp_time,
+ pp_tms,
+ pp_localtime,
+ pp_gmtime,
+ pp_alarm,
+ pp_sleep,
+ pp_shmget,
+ pp_shmctl,
+ pp_shmread,
+ pp_shmwrite,
+ pp_msgget,
+ pp_msgctl,
+ pp_msgsnd,
+ pp_msgrcv,
+ pp_semget,
+ pp_semctl,
+ pp_semop,
+ pp_require,
+ pp_dofile,
+ pp_entereval,
+ pp_leaveeval,
+ pp_evalonce,
+ pp_entertry,
+ pp_leavetry,
+ pp_ghbyname,
+ pp_ghbyaddr,
+ pp_ghostent,
+ pp_gnbyname,
+ pp_gnbyaddr,
+ pp_gnetent,
+ pp_gpbyname,
+ pp_gpbynumber,
+ pp_gprotoent,
+ pp_gsbyname,
+ pp_gsbyport,
+ pp_gservent,
+ pp_shostent,
+ pp_snetent,
+ pp_sprotoent,
+ pp_sservent,
+ pp_ehostent,
+ pp_enetent,
+ pp_eprotoent,
+ pp_eservent,
+ pp_gpwnam,
+ pp_gpwuid,
+ pp_gpwent,
+ pp_spwent,
+ pp_epwent,
+ pp_ggrnam,
+ pp_ggrgid,
+ pp_ggrent,
+ pp_sgrent,
+ pp_egrent,
+ pp_getlogin,
+ pp_syscall,
+};
+#endif
+
+#ifndef DOINIT
+extern OP * (*check[])();
+#else
+OP * (*check[])() = {
+ ck_null, /* null */
+ ck_null, /* scalar */
+ ck_null, /* pushmark */
+ ck_null, /* wantarray */
+ ck_null, /* word */
+ ck_null, /* const */
+ ck_null, /* interp */
+ ck_null, /* gvsv */
+ ck_null, /* gv */
+ ck_null, /* pushre */
+ ck_rvconst, /* rv2gv */
+ ck_null, /* sv2len */
+ ck_rvconst, /* rv2sv */
+ ck_null, /* av2arylen */
+ ck_rvconst, /* rv2cv */
+ ck_null, /* refgen */
+ ck_fun, /* ref */
+ ck_fun, /* bless */
+ ck_null, /* backtick */
+ ck_glob, /* glob */
+ ck_null, /* readline */
+ ck_null, /* rcatline */
+ ck_null, /* regcomp */
+ ck_match, /* match */
+ ck_null, /* subst */
+ ck_null, /* substcont */
+ ck_null, /* trans */
+ ck_null, /* sassign */
+ ck_null, /* aassign */
+ ck_null, /* schop */
+ ck_chop, /* chop */
+ ck_lfun, /* defined */
+ ck_lfun, /* undef */
+ ck_fun, /* study */
+ ck_lfun, /* preinc */
+ ck_lfun, /* predec */
+ ck_lfun, /* postinc */
+ ck_lfun, /* postdec */
+ ck_null, /* pow */
+ ck_null, /* multiply */
+ ck_null, /* divide */
+ ck_null, /* modulo */
+ ck_repeat, /* repeat */
+ ck_null, /* add */
+ ck_null, /* intadd */
+ ck_null, /* subtract */
+ ck_concat, /* concat */
+ ck_null, /* left_shift */
+ ck_null, /* right_shift */
+ ck_null, /* lt */
+ ck_null, /* gt */
+ ck_null, /* le */
+ ck_null, /* ge */
+ ck_null, /* eq */
+ ck_null, /* ne */
+ ck_null, /* ncmp */
+ ck_null, /* slt */
+ ck_null, /* sgt */
+ ck_null, /* sle */
+ ck_null, /* sge */
+ ck_null, /* seq */
+ ck_null, /* sne */
+ ck_null, /* scmp */
+ ck_null, /* bit_and */
+ ck_null, /* xor */
+ ck_null, /* bit_or */
+ ck_null, /* negate */
+ ck_null, /* not */
+ ck_null, /* complement */
+ ck_fun, /* atan2 */
+ ck_fun, /* sin */
+ ck_fun, /* cos */
+ ck_fun, /* rand */
+ ck_fun, /* srand */
+ ck_fun, /* exp */
+ ck_fun, /* log */
+ ck_fun, /* sqrt */
+ ck_fun, /* int */
+ ck_fun, /* hex */
+ ck_fun, /* oct */
+ ck_lengthconst, /* length */
+ ck_fun, /* substr */
+ ck_fun, /* vec */
+ ck_index, /* index */
+ ck_index, /* rindex */
+ ck_fun, /* sprintf */
+ ck_formline, /* formline */
+ ck_fun, /* ord */
+ ck_fun, /* crypt */
+ ck_fun, /* ucfirst */
+ ck_fun, /* lcfirst */
+ ck_fun, /* uc */
+ ck_fun, /* lc */
+ ck_rvconst, /* rv2av */
+ ck_null, /* aelemfast */
+ ck_aelem, /* aelem */
+ ck_null, /* aslice */
+ ck_fun, /* each */
+ ck_fun, /* values */
+ ck_fun, /* keys */
+ ck_null, /* delete */
+ ck_rvconst, /* rv2hv */
+ ck_null, /* helem */
+ ck_null, /* hslice */
+ ck_fun, /* unpack */
+ ck_fun, /* pack */
+ ck_split, /* split */
+ ck_fun, /* join */
+ ck_null, /* list */
+ ck_null, /* lslice */
+ ck_null, /* anonlist */
+ ck_null, /* anonhash */
+ ck_fun, /* splice */
+ ck_fun, /* push */
+ ck_shift, /* pop */
+ ck_shift, /* shift */
+ ck_fun, /* unshift */
+ ck_sort, /* sort */
+ ck_fun, /* reverse */
+ ck_grep, /* grepstart */
+ ck_null, /* grepwhile */
+ ck_null, /* range */
+ ck_null, /* flip */
+ ck_null, /* flop */
+ ck_null, /* and */
+ ck_null, /* or */
+ ck_null, /* cond_expr */
+ ck_null, /* andassign */
+ ck_null, /* orassign */
+ ck_null, /* method */
+ ck_subr, /* entersubr */
+ ck_null, /* leavesubr */
+ ck_fun, /* caller */
+ ck_fun, /* warn */
+ ck_fun, /* die */
+ ck_fun, /* reset */
+ ck_null, /* lineseq */
+ ck_null, /* curcop */
+ ck_null, /* unstack */
+ ck_null, /* enter */
+ ck_null, /* leave */
+ ck_null, /* enteriter */
+ ck_null, /* iter */
+ ck_null, /* enterloop */
+ ck_null, /* leaveloop */
+ ck_fun, /* return */
+ ck_null, /* last */
+ ck_null, /* next */
+ ck_null, /* redo */
+ ck_null, /* dump */
+ ck_null, /* goto */
+ ck_fun, /* exit */
+ ck_null, /* nswitch */
+ ck_null, /* cswitch */
+ ck_fun, /* open */
+ ck_fun, /* close */
+ ck_fun, /* pipe_op */
+ ck_fun, /* fileno */
+ ck_fun, /* umask */
+ ck_fun, /* binmode */
+ ck_fun, /* dbmopen */
+ ck_fun, /* dbmclose */
+ ck_select, /* sselect */
+ ck_select, /* select */
+ ck_eof, /* getc */
+ ck_fun, /* read */
+ ck_fun, /* enterwrite */
+ ck_null, /* leavewrite */
+ ck_listiob, /* prtf */
+ ck_listiob, /* print */
+ ck_fun, /* sysread */
+ ck_fun, /* syswrite */
+ ck_fun, /* send */
+ ck_fun, /* recv */
+ ck_eof, /* eof */
+ ck_fun, /* tell */
+ ck_fun, /* seek */
+ ck_trunc, /* truncate */
+ ck_fun, /* fcntl */
+ ck_fun, /* ioctl */
+ ck_fun, /* flock */
+ ck_fun, /* socket */
+ ck_fun, /* sockpair */
+ ck_fun, /* bind */
+ ck_fun, /* connect */
+ ck_fun, /* listen */
+ ck_fun, /* accept */
+ ck_fun, /* shutdown */
+ ck_fun, /* gsockopt */
+ ck_fun, /* ssockopt */
+ ck_fun, /* getsockname */
+ ck_fun, /* getpeername */
+ ck_ftst, /* lstat */
+ ck_ftst, /* stat */
+ ck_ftst, /* ftrread */
+ ck_ftst, /* ftrwrite */
+ ck_ftst, /* ftrexec */
+ ck_ftst, /* fteread */
+ ck_ftst, /* ftewrite */
+ ck_ftst, /* fteexec */
+ ck_ftst, /* ftis */
+ ck_ftst, /* fteowned */
+ ck_ftst, /* ftrowned */
+ ck_ftst, /* ftzero */
+ ck_ftst, /* ftsize */
+ ck_ftst, /* ftmtime */
+ ck_ftst, /* ftatime */
+ ck_ftst, /* ftctime */
+ ck_ftst, /* ftsock */
+ ck_ftst, /* ftchr */
+ ck_ftst, /* ftblk */
+ ck_ftst, /* ftfile */
+ ck_ftst, /* ftdir */
+ ck_ftst, /* ftpipe */
+ ck_ftst, /* ftlink */
+ ck_ftst, /* ftsuid */
+ ck_ftst, /* ftsgid */
+ ck_ftst, /* ftsvtx */
+ ck_ftst, /* fttty */
+ ck_ftst, /* fttext */
+ ck_ftst, /* ftbinary */
+ ck_fun, /* chdir */
+ ck_fun, /* chown */
+ ck_fun, /* chroot */
+ ck_fun, /* unlink */
+ ck_fun, /* chmod */
+ ck_fun, /* utime */
+ ck_fun, /* rename */
+ ck_fun, /* link */
+ ck_fun, /* symlink */
+ ck_fun, /* readlink */
+ ck_fun, /* mkdir */
+ ck_fun, /* rmdir */
+ ck_fun, /* open_dir */
+ ck_fun, /* readdir */
+ ck_fun, /* telldir */
+ ck_fun, /* seekdir */
+ ck_fun, /* rewinddir */
+ ck_fun, /* closedir */
+ ck_null, /* fork */
+ ck_null, /* wait */
+ ck_fun, /* waitpid */
+ ck_exec, /* system */
+ ck_exec, /* exec */
+ ck_fun, /* kill */
+ ck_null, /* getppid */
+ ck_fun, /* getpgrp */
+ ck_fun, /* setpgrp */
+ ck_fun, /* getpriority */
+ ck_fun, /* setpriority */
+ ck_null, /* time */
+ ck_null, /* tms */
+ ck_fun, /* localtime */
+ ck_fun, /* gmtime */
+ ck_fun, /* alarm */
+ ck_fun, /* sleep */
+ ck_fun, /* shmget */
+ ck_fun, /* shmctl */
+ ck_fun, /* shmread */
+ ck_fun, /* shmwrite */
+ ck_fun, /* msgget */
+ ck_fun, /* msgctl */
+ ck_fun, /* msgsnd */
+ ck_fun, /* msgrcv */
+ ck_fun, /* semget */
+ ck_fun, /* semctl */
+ ck_fun, /* semop */
+ ck_fun, /* require */
+ ck_fun, /* dofile */
+ ck_eval, /* entereval */
+ ck_null, /* leaveeval */
+ ck_null, /* evalonce */
+ ck_null, /* entertry */
+ ck_null, /* leavetry */
+ ck_fun, /* ghbyname */
+ ck_fun, /* ghbyaddr */
+ ck_null, /* ghostent */
+ ck_fun, /* gnbyname */
+ ck_fun, /* gnbyaddr */
+ ck_null, /* gnetent */
+ ck_fun, /* gpbyname */
+ ck_fun, /* gpbynumber */
+ ck_null, /* gprotoent */
+ ck_fun, /* gsbyname */
+ ck_fun, /* gsbyport */
+ ck_null, /* gservent */
+ ck_fun, /* shostent */
+ ck_fun, /* snetent */
+ ck_fun, /* sprotoent */
+ ck_fun, /* sservent */
+ ck_null, /* ehostent */
+ ck_null, /* enetent */
+ ck_null, /* eprotoent */
+ ck_null, /* eservent */
+ ck_fun, /* gpwnam */
+ ck_fun, /* gpwuid */
+ ck_null, /* gpwent */
+ ck_null, /* spwent */
+ ck_null, /* epwent */
+ ck_fun, /* ggrnam */
+ ck_fun, /* ggrgid */
+ ck_null, /* ggrent */
+ ck_null, /* sgrent */
+ ck_null, /* egrent */
+ ck_null, /* getlogin */
+ ck_fun, /* syscall */
+};
+#endif
+
+#ifndef DOINIT
+EXT U32 opargs[];
+#else
+U32 opargs[] = {
+ 0x00000000, /* null */
+ 0x00000004, /* scalar */
+ 0x00000004, /* pushmark */
+ 0x00000014, /* wantarray */
+ 0x00000004, /* word */
+ 0x00000004, /* const */
+ 0x00000000, /* interp */
+ 0x00000044, /* gvsv */
+ 0x00000044, /* gv */
+ 0x00000000, /* pushre */
+ 0x00000044, /* rv2gv */
+ 0x0000001c, /* sv2len */
+ 0x00000044, /* rv2sv */
+ 0x00000014, /* av2arylen */
+ 0x00000040, /* rv2cv */
+ 0x0000020e, /* refgen */
+ 0x0000010c, /* ref */
+ 0x00000104, /* bless */
+ 0x00000008, /* backtick */
+ 0x00000008, /* glob */
+ 0x00000008, /* readline */
+ 0x00000008, /* rcatline */
+ 0x00000104, /* regcomp */
+ 0x00000040, /* match */
+ 0x00000154, /* subst */
+ 0x00000054, /* substcont */
+ 0x00000114, /* trans */
+ 0x00000004, /* sassign */
+ 0x00002208, /* aassign */
+ 0x00000008, /* schop */
+ 0x00000209, /* chop */
+ 0x00000914, /* defined */
+ 0x00000904, /* undef */
+ 0x0000090c, /* study */
+ 0x00000104, /* preinc */
+ 0x00000104, /* predec */
+ 0x0000010c, /* postinc */
+ 0x0000010c, /* postdec */
+ 0x0000110e, /* pow */
+ 0x0000110e, /* multiply */
+ 0x0000110e, /* divide */
+ 0x0000111e, /* modulo */
+ 0x00001209, /* repeat */
+ 0x0000112e, /* add */
+ 0x0000111e, /* intadd */
+ 0x0000110e, /* subtract */
+ 0x0000110e, /* concat */
+ 0x0000111e, /* left_shift */
+ 0x0000111e, /* right_shift */
+ 0x00001116, /* lt */
+ 0x00001116, /* gt */
+ 0x00001116, /* le */
+ 0x00001116, /* ge */
+ 0x00001116, /* eq */
+ 0x00001116, /* ne */
+ 0x0000111e, /* ncmp */
+ 0x00001116, /* slt */
+ 0x00001116, /* sgt */
+ 0x00001116, /* sle */
+ 0x00001116, /* sge */
+ 0x00001116, /* seq */
+ 0x00001116, /* sne */
+ 0x0000111e, /* scmp */
+ 0x0000110e, /* bit_and */
+ 0x0000110e, /* xor */
+ 0x0000110e, /* bit_or */
+ 0x0000010e, /* negate */
+ 0x00000116, /* not */
+ 0x0000010e, /* complement */
+ 0x0000110e, /* atan2 */
+ 0x0000090e, /* sin */
+ 0x0000090e, /* cos */
+ 0x0000090c, /* rand */
+ 0x00000904, /* srand */
+ 0x0000090e, /* exp */
+ 0x0000090e, /* log */
+ 0x0000090e, /* sqrt */
+ 0x0000090e, /* int */
+ 0x0000091c, /* hex */
+ 0x0000091c, /* oct */
+ 0x0000011c, /* length */
+ 0x0009110c, /* substr */
+ 0x0001111c, /* vec */
+ 0x0009111c, /* index */
+ 0x0009111c, /* rindex */
+ 0x0000210d, /* sprintf */
+ 0x00002105, /* formline */
+ 0x0000091e, /* ord */
+ 0x0000110e, /* crypt */
+ 0x0000010a, /* ucfirst */
+ 0x0000010a, /* lcfirst */
+ 0x0000010a, /* uc */
+ 0x0000010a, /* lc */
+ 0x00000048, /* rv2av */
+ 0x00001304, /* aelemfast */
+ 0x00001304, /* aelem */
+ 0x00002301, /* aslice */
+ 0x00000408, /* each */
+ 0x00000408, /* values */
+ 0x00000408, /* keys */
+ 0x00001404, /* delete */
+ 0x00000048, /* rv2hv */
+ 0x00001404, /* helem */
+ 0x00002401, /* hslice */
+ 0x00001100, /* unpack */
+ 0x0000210d, /* pack */
+ 0x00011108, /* split */
+ 0x0000210d, /* join */
+ 0x00000201, /* list */
+ 0x00022400, /* lslice */
+ 0x00000201, /* anonlist */
+ 0x00000201, /* anonhash */
+ 0x00291301, /* splice */
+ 0x0000231d, /* push */
+ 0x00000304, /* pop */
+ 0x00000304, /* shift */
+ 0x0000231d, /* unshift */
+ 0x00002d01, /* sort */
+ 0x00000209, /* reverse */
+ 0x00002541, /* grepstart */
+ 0x00000048, /* grepwhile */
+ 0x00001100, /* range */
+ 0x00001100, /* flip */
+ 0x00000000, /* flop */
+ 0x00000000, /* and */
+ 0x00000000, /* or */
+ 0x00000000, /* cond_expr */
+ 0x00000004, /* andassign */
+ 0x00000004, /* orassign */
+ 0x00000048, /* method */
+ 0x00000241, /* entersubr */
+ 0x00000000, /* leavesubr */
+ 0x00000908, /* caller */
+ 0x0000021d, /* warn */
+ 0x0000025d, /* die */
+ 0x00000914, /* reset */
+ 0x00000000, /* lineseq */
+ 0x00000004, /* curcop */
+ 0x00000004, /* unstack */
+ 0x00000000, /* enter */
+ 0x00000000, /* leave */
+ 0x00000040, /* enteriter */
+ 0x00000000, /* iter */
+ 0x00000040, /* enterloop */
+ 0x00000004, /* leaveloop */
+ 0x00000241, /* return */
+ 0x00000044, /* last */
+ 0x00000044, /* next */
+ 0x00000044, /* redo */
+ 0x00000044, /* dump */
+ 0x00000044, /* goto */
+ 0x00000944, /* exit */
+ 0x00000040, /* nswitch */
+ 0x00000040, /* cswitch */
+ 0x0000961c, /* open */
+ 0x00000e14, /* close */
+ 0x00006614, /* pipe_op */
+ 0x0000061c, /* fileno */
+ 0x0000091c, /* umask */
+ 0x00000604, /* binmode */
+ 0x0001141c, /* dbmopen */
+ 0x00000414, /* dbmclose */
+ 0x00111108, /* sselect */
+ 0x00000e0c, /* select */
+ 0x00000e0c, /* getc */
+ 0x0091761d, /* read */
+ 0x00000e54, /* enterwrite */
+ 0x00000000, /* leavewrite */
+ 0x00002e15, /* prtf */
+ 0x00002e15, /* print */
+ 0x0091761d, /* sysread */
+ 0x0091161d, /* syswrite */
+ 0x0091161d, /* send */
+ 0x0011761d, /* recv */
+ 0x00000e14, /* eof */
+ 0x00000e0c, /* tell */
+ 0x00011604, /* seek */
+ 0x00001114, /* truncate */
+ 0x0001160c, /* fcntl */
+ 0x0001160c, /* ioctl */
+ 0x0000161c, /* flock */
+ 0x00111614, /* socket */
+ 0x01116614, /* sockpair */
+ 0x00001614, /* bind */
+ 0x00001614, /* connect */
+ 0x00001614, /* listen */
+ 0x0000661c, /* accept */
+ 0x0000161c, /* shutdown */
+ 0x00011614, /* gsockopt */
+ 0x00111614, /* ssockopt */
+ 0x00000614, /* getsockname */
+ 0x00000614, /* getpeername */
+ 0x00000600, /* lstat */
+ 0x00000600, /* stat */
+ 0x00000614, /* ftrread */
+ 0x00000614, /* ftrwrite */
+ 0x00000614, /* ftrexec */
+ 0x00000614, /* fteread */
+ 0x00000614, /* ftewrite */
+ 0x00000614, /* fteexec */
+ 0x00000614, /* ftis */
+ 0x00000614, /* fteowned */
+ 0x00000614, /* ftrowned */
+ 0x00000614, /* ftzero */
+ 0x0000061c, /* ftsize */
+ 0x0000060c, /* ftmtime */
+ 0x0000060c, /* ftatime */
+ 0x0000060c, /* ftctime */
+ 0x00000614, /* ftsock */
+ 0x00000614, /* ftchr */
+ 0x00000614, /* ftblk */
+ 0x00000614, /* ftfile */
+ 0x00000614, /* ftdir */
+ 0x00000614, /* ftpipe */
+ 0x00000614, /* ftlink */
+ 0x00000614, /* ftsuid */
+ 0x00000614, /* ftsgid */
+ 0x00000614, /* ftsvtx */
+ 0x00000614, /* fttty */
+ 0x00000614, /* fttext */
+ 0x00000614, /* ftbinary */
+ 0x0000091c, /* chdir */
+ 0x0000021d, /* chown */
+ 0x0000091c, /* chroot */
+ 0x0000021d, /* unlink */
+ 0x0000021d, /* chmod */
+ 0x0000021d, /* utime */
+ 0x0000111c, /* rename */
+ 0x0000111c, /* link */
+ 0x0000111c, /* symlink */
+ 0x0000090c, /* readlink */
+ 0x0000111c, /* mkdir */
+ 0x0000091c, /* rmdir */
+ 0x00001614, /* open_dir */
+ 0x00000600, /* readdir */
+ 0x0000060c, /* telldir */
+ 0x00001604, /* seekdir */
+ 0x00000604, /* rewinddir */
+ 0x00000614, /* closedir */
+ 0x0000001c, /* fork */
+ 0x0000001c, /* wait */
+ 0x0000111c, /* waitpid */
+ 0x0000291d, /* system */
+ 0x0000295d, /* exec */
+ 0x0000025d, /* kill */
+ 0x0000001c, /* getppid */
+ 0x0000091c, /* getpgrp */
+ 0x0000111c, /* setpgrp */
+ 0x0000111c, /* getpriority */
+ 0x0001111c, /* setpriority */
+ 0x0000001c, /* time */
+ 0x00000000, /* tms */
+ 0x00000908, /* localtime */
+ 0x00000908, /* gmtime */
+ 0x0000091c, /* alarm */
+ 0x0000091c, /* sleep */
+ 0x0001111d, /* shmget */
+ 0x0001111d, /* shmctl */
+ 0x0011111d, /* shmread */
+ 0x0011111c, /* shmwrite */
+ 0x0000111d, /* msgget */
+ 0x0001111d, /* msgctl */
+ 0x0001111d, /* msgsnd */
+ 0x0111111d, /* msgrcv */
+ 0x0001111d, /* semget */
+ 0x0011111d, /* semctl */
+ 0x0001111d, /* semop */
+ 0x00000140, /* require */
+ 0x00000140, /* dofile */
+ 0x00000140, /* entereval */
+ 0x00000100, /* leaveeval */
+ 0x00000140, /* evalonce */
+ 0x00000000, /* entertry */
+ 0x00000000, /* leavetry */
+ 0x00000100, /* ghbyname */
+ 0x00001100, /* ghbyaddr */
+ 0x00000000, /* ghostent */
+ 0x00000100, /* gnbyname */
+ 0x00001100, /* gnbyaddr */
+ 0x00000000, /* gnetent */
+ 0x00000100, /* gpbyname */
+ 0x00000100, /* gpbynumber */
+ 0x00000000, /* gprotoent */
+ 0x00001100, /* gsbyname */
+ 0x00001100, /* gsbyport */
+ 0x00000000, /* gservent */
+ 0x0000011c, /* shostent */
+ 0x0000011c, /* snetent */
+ 0x0000011c, /* sprotoent */
+ 0x0000011c, /* sservent */
+ 0x0000001c, /* ehostent */
+ 0x0000001c, /* enetent */
+ 0x0000001c, /* eprotoent */
+ 0x0000001c, /* eservent */
+ 0x00000100, /* gpwnam */
+ 0x00000100, /* gpwuid */
+ 0x00000000, /* gpwent */
+ 0x0000001c, /* spwent */
+ 0x0000001c, /* epwent */
+ 0x00000100, /* ggrnam */
+ 0x00000100, /* ggrgid */
+ 0x00000000, /* ggrent */
+ 0x0000001c, /* sgrent */
+ 0x0000001c, /* egrent */
+ 0x0000000c, /* getlogin */
+ 0x0000211c, /* syscall */
+};
+#endif
--- /dev/null
+#!/usr/bin/perl
+
+open(OC, ">opcode.h") || die "Can't create opcode.h: $!\n";
+select OC;
+
+# Read data.
+
+while (<DATA>) {
+ chop;
+ next unless $_;
+ next if /^#/;
+ ($key, $name, $check, $flags, $args) = split(/\t+/, $_, 5);
+ push(@ops, $key);
+ $name{$key} = $name;
+ $check{$key} = $check;
+ $ckname{$check}++;
+ $flags{$key} = $flags;
+ $args{$key} = $args;
+}
+
+# Emit defines.
+
+$i = 0;
+print "typedef enum {\n";
+for (@ops) {
+ print "\t", &tab(3,"OP_\U$_,"), "/* ", $i++, " */\n";
+}
+print "} opcode;\n";
+print "\n#define MAXO ", scalar @ops, "\n\n";
+
+# Emit opnames.
+
+print <<END;
+#ifndef DOINIT
+extern char *op_name[];
+#else
+char *op_name[] = {
+END
+
+for (@ops) {
+ print qq(\t"$name{$_}",\n);
+}
+
+print <<END;
+};
+#endif
+
+END
+
+# Emit function declarations.
+
+for (sort keys %ckname) {
+ print "OP *\t", &tab(3,$_),"P((OP* op));\n";
+}
+
+print "\n";
+
+for (@ops) {
+ print "OP *\t", &tab(3, "pp_\L$_"), "P((ARGSproto));\n";
+}
+
+# Emit ppcode switch array.
+
+print <<END;
+
+#ifndef DOINIT
+extern OP * (*ppaddr[])();
+#else
+OP * (*ppaddr[])() = {
+END
+
+for (@ops) {
+ print "\tpp_\L$_,\n";
+}
+
+print <<END;
+};
+#endif
+
+END
+
+# Emit check routines.
+
+print <<END;
+#ifndef DOINIT
+extern OP * (*check[])();
+#else
+OP * (*check[])() = {
+END
+
+for (@ops) {
+ print "\t", &tab(3, "$check{$_},"), "/* \L$_ */\n";
+}
+
+print <<END;
+};
+#endif
+
+END
+
+# Emit allowed argument types.
+
+print <<END;
+#ifndef DOINIT
+EXT U32 opargs[];
+#else
+U32 opargs[] = {
+END
+
+%argnum = (
+ S, 1, # scalar
+ L, 2, # list
+ A, 3, # array value
+ H, 4, # hash value
+ C, 5, # code value
+ F, 6, # file value
+ R, 7, # scalar reference
+);
+
+for (@ops) {
+ $argsum = 0;
+ $flags = $flags{$_};
+ $argsum |= 1 if $flags =~ /m/; # needs stack mark
+ $argsum |= 2 if $flags =~ /f/; # fold constants
+ $argsum |= 4 if $flags =~ /s/; # always produces scalar
+ $argsum |= 8 if $flags =~ /t/; # needs target scalar
+ $argsum |= 16 if $flags =~ /i/; # always produces integer
+ $argsum |= 32 if $flags =~ /I/; # has corresponding int op
+ $argsum |= 64 if $flags =~ /d/; # danger, unknown side effects
+ $mul = 256;
+ for $arg (split(' ',$args{$_})) {
+ $argnum = ($arg =~ s/\?//) ? 8 : 0;
+ $argnum += $argnum{$arg};
+ $argsum += $argnum * $mul;
+ $mul <<= 4;
+ }
+ $argsum = sprintf("0x%08x", $argsum);
+ print "\t", &tab(3, "$argsum,"), "/* \L$_ */\n";
+}
+
+print <<END;
+};
+#endif
+END
+
+###########################################################################
+sub tab {
+ local($l, $t) = @_;
+ $t .= "\t" x ($l - (length($t) + 1) / 8);
+ $t;
+}
+###########################################################################
+__END__
+
+# Nothing.
+
+null null operation ck_null 0
+scalar null operation ck_null s
+
+# Pushy stuff.
+
+pushmark pushmark ck_null s
+wantarray wantarray ck_null is
+
+word bare word ck_null s
+const constant item ck_null s
+interp interpreted string ck_null 0
+
+gvsv scalar variable ck_null ds
+gv glob value ck_null ds
+
+pushre push regexp ck_null 0
+
+# References and stuff.
+
+rv2gv ref-to-glob cast ck_rvconst ds
+sv2len scalar value length ck_null ist
+rv2sv ref-to-scalar cast ck_rvconst ds
+av2arylen array length ck_null is
+rv2cv subroutine reference ck_rvconst d
+refgen backslash reference ck_null fst L
+ref reference-type operator ck_fun st S
+bless bless ck_fun s S
+
+# Pushy I/O.
+
+backtick backticks ck_null t
+glob glob ck_glob t
+readline <HANDLE> ck_null t
+rcatline append I/O operator ck_null t
+
+# Bindable operators.
+
+regcomp regexp compilation ck_null s S
+match pattern match ck_match d
+subst substitution ck_null dis S
+substcont substitution cont ck_null dis
+trans character translation ck_null is S
+
+# Lvalue operators.
+
+sassign scalar assignment ck_null s
+aassign list assignment ck_null t L L
+
+schop scalar chop ck_null t
+chop chop ck_chop mt L
+defined defined operator ck_lfun is S?
+undef undef operator ck_lfun s S?
+study study ck_fun st S?
+
+preinc preincrement ck_lfun s S
+predec predecrement ck_lfun s S
+postinc postincrement ck_lfun st S
+postdec postdecrement ck_lfun st S
+
+# Ordinary operators.
+
+pow exponentiation ck_null fst S S
+
+multiply multiplication ck_null fst S S
+divide division ck_null fst S S
+modulo modulus ck_null ifst S S
+repeat repeat ck_repeat mt L S
+
+add addition ck_null Ifst S S
+intadd integer addition ck_null ifst S S
+subtract subtraction ck_null fst S S
+concat concatenation ck_concat fst S S
+
+left_shift left bitshift ck_null ifst S S
+right_shift right bitshift ck_null ifst S S
+
+lt numeric lt ck_null ifs S S
+gt numeric gt ck_null ifs S S
+le numeric le ck_null ifs S S
+ge numeric ge ck_null ifs S S
+eq numeric eq ck_null ifs S S
+ne numeric ne ck_null ifs S S
+ncmp spaceship ck_null ifst S S
+
+slt string lt ck_null ifs S S
+sgt string gt ck_null ifs S S
+sle string le ck_null ifs S S
+sge string ge ck_null ifs S S
+seq string eq ck_null ifs S S
+sne string ne ck_null ifs S S
+scmp string comparison ck_null ifst S S
+
+bit_and bit and ck_null fst S S
+xor xor ck_null fst S S
+bit_or bit or ck_null fst S S
+
+negate negate ck_null fst S
+not not ck_null ifs S
+complement 1's complement ck_null fst S
+
+# High falutin' math.
+
+atan2 atan2 ck_fun fst S S
+sin sin ck_fun fst S?
+cos cos ck_fun fst S?
+rand rand ck_fun st S?
+srand srand ck_fun s S?
+exp exp ck_fun fst S?
+log log ck_fun fst S?
+sqrt sqrt ck_fun fst S?
+
+int int ck_fun fst S?
+hex hex ck_fun ist S?
+oct oct ck_fun ist S?
+
+# String stuff.
+
+length length ck_lengthconst ist S
+substr substr ck_fun st S S S?
+vec vec ck_fun ist S S S
+
+index index ck_index ist S S S?
+rindex rindex ck_index ist S S S?
+
+sprintf sprintf ck_fun mst S L
+formline formline ck_formline ms S L
+ord ord ck_fun ifst S?
+crypt crypt ck_fun fst S S
+ucfirst upper case first ck_fun ft S
+lcfirst lower case first ck_fun ft S
+uc upper case ck_fun ft S
+lc lower case ck_fun ft S
+
+# Arrays.
+
+rv2av array deref ck_rvconst dt
+aelemfast known array element ck_null s A S
+aelem array element ck_aelem s A S
+aslice array slice ck_null m A L
+
+# Associative arrays.
+
+each each ck_fun t H
+values values ck_fun t H
+keys keys ck_fun t H
+delete delete ck_null s H S
+rv2hv associative array deref ck_rvconst dt
+helem associative array elem ck_null s H S
+hslice associative array slice ck_null m H L
+
+# Explosives and implosives.
+
+unpack unpack ck_fun 0 S S
+pack pack ck_fun mst S L
+split split ck_split t S S S
+join join ck_fun mst S L
+
+# List operators.
+
+list list ck_null m L
+lslice list slice ck_null 0 H L L
+anonlist anonymous list ck_null m L
+anonhash anonymous hash ck_null m L
+
+splice splice ck_fun m A S S? L
+push push ck_fun imst A L
+pop pop ck_shift s A
+shift shift ck_shift s A
+unshift unshift ck_fun imst A L
+sort sort ck_sort m C? L
+reverse reverse ck_fun mt L
+
+grepstart grep ck_grep dm C L
+grepwhile grep iterator ck_null dt
+
+# Range stuff.
+
+range flipflop ck_null 0 S S
+flip range (or flip) ck_null 0 S S
+flop range (or flop) ck_null 0
+
+# Control.
+
+and logical and ck_null 0
+or logical or ck_null 0
+cond_expr conditional expression ck_null 0
+andassign logical and assignment ck_null s
+orassign logical or assignment ck_null s
+
+method method lookup ck_null dt
+entersubr subroutine entry ck_subr dm L
+leavesubr subroutine exit ck_null 0
+caller caller ck_fun t S?
+warn warn ck_fun imst L
+die die ck_fun dimst L
+reset reset ck_fun is S?
+
+lineseq line sequence ck_null 0
+curcop next statement ck_null s
+unstack unstack ck_null s
+enter block entry ck_null 0
+leave block exit ck_null 0
+enteriter foreach loop entry ck_null d
+iter foreach loop iterator ck_null 0
+enterloop loop entry ck_null d
+leaveloop loop exit ck_null s
+return return ck_fun dm L
+last last ck_null ds
+next next ck_null ds
+redo redo ck_null ds
+dump dump ck_null ds
+goto goto ck_null ds
+exit exit ck_fun ds S?
+
+nswitch numeric switch ck_null d
+cswitch character switch ck_null d
+
+# I/O.
+
+open open ck_fun ist F S?
+close close ck_fun is F?
+pipe_op pipe ck_fun is F F
+
+fileno fileno ck_fun ist F
+umask umask ck_fun ist S?
+binmode binmode ck_fun s F
+
+dbmopen dbmopen ck_fun ist H S S
+dbmclose dbmclose ck_fun is H
+
+sselect select system call ck_select t S S S S
+select select ck_select st F?
+
+getc getc ck_eof st F?
+read read ck_fun imst F R S S?
+enterwrite write ck_fun dis F?
+leavewrite write exit ck_null 0
+
+prtf prtf ck_listiob ims F? L
+print print ck_listiob ims F? L
+
+sysread sysread ck_fun imst F R S S?
+syswrite syswrite ck_fun imst F S S S?
+
+send send ck_fun imst F S S S?
+recv recv ck_fun imst F R S S
+
+eof eof ck_eof is F?
+tell tell ck_fun st F?
+seek seek ck_fun s F S S
+truncate truncate ck_trunc is S S
+
+fcntl fcntl ck_fun st F S S
+ioctl ioctl ck_fun st F S S
+flock flock ck_fun ist F S
+
+# Sockets.
+
+socket socket ck_fun is F S S S
+sockpair socketpair ck_fun is F F S S S
+
+bind bind ck_fun is F S
+connect connect ck_fun is F S
+listen listen ck_fun is F S
+accept accept ck_fun ist F F
+shutdown shutdown ck_fun ist F S
+
+gsockopt getsockopt ck_fun is F S S
+ssockopt setsockopt ck_fun is F S S S
+
+getsockname getsockname ck_fun is F
+getpeername getpeername ck_fun is F
+
+# Stat calls.
+
+lstat lstat ck_ftst 0 F
+stat stat ck_ftst 0 F
+ftrread -R ck_ftst is F
+ftrwrite -W ck_ftst is F
+ftrexec -X ck_ftst is F
+fteread -r ck_ftst is F
+ftewrite -w ck_ftst is F
+fteexec -x ck_ftst is F
+ftis -e ck_ftst is F
+fteowned -O ck_ftst is F
+ftrowned -o ck_ftst is F
+ftzero -z ck_ftst is F
+ftsize -s ck_ftst ist F
+ftmtime -M ck_ftst st F
+ftatime -A ck_ftst st F
+ftctime -C ck_ftst st F
+ftsock -S ck_ftst is F
+ftchr -c ck_ftst is F
+ftblk -b ck_ftst is F
+ftfile -f ck_ftst is F
+ftdir -d ck_ftst is F
+ftpipe -p ck_ftst is F
+ftlink -l ck_ftst is F
+ftsuid -u ck_ftst is F
+ftsgid -g ck_ftst is F
+ftsvtx -k ck_ftst is F
+fttty -t ck_ftst is F
+fttext -T ck_ftst is F
+ftbinary -B ck_ftst is F
+
+# File calls.
+
+chdir chdir ck_fun ist S?
+chown chown ck_fun imst L
+chroot chroot ck_fun ist S?
+unlink unlink ck_fun imst L
+chmod chmod ck_fun imst L
+utime utime ck_fun imst L
+rename rename ck_fun ist S S
+link link ck_fun ist S S
+symlink symlink ck_fun ist S S
+readlink readlink ck_fun st S?
+mkdir mkdir ck_fun ist S S
+rmdir rmdir ck_fun ist S?
+
+# Directory calls.
+
+open_dir opendir ck_fun is F S
+readdir readdir ck_fun 0 F
+telldir telldir ck_fun st F
+seekdir seekdir ck_fun s F S
+rewinddir rewinddir ck_fun s F
+closedir closedir ck_fun is F
+
+# Process control.
+
+fork fork ck_null ist
+wait wait ck_null ist
+waitpid waitpid ck_fun ist S S
+system system ck_exec imst S? L
+exec exec ck_exec dimst S? L
+kill kill ck_fun dimst L
+getppid getppid ck_null ist
+getpgrp getpgrp ck_fun ist S?
+setpgrp setpgrp ck_fun ist S S
+getpriority getpriority ck_fun ist S S
+setpriority setpriority ck_fun ist S S S
+
+# Time calls.
+
+time time ck_null ist
+tms times ck_null 0
+localtime localtime ck_fun t S?
+gmtime gmtime ck_fun t S?
+alarm alarm ck_fun ist S?
+sleep sleep ck_fun ist S?
+
+# Shared memory.
+
+shmget shmget ck_fun imst S S S
+shmctl shmctl ck_fun imst S S S
+shmread shmread ck_fun imst S S S S
+shmwrite shmwrite ck_fun ist S S S S
+
+# Message passing.
+
+msgget msgget ck_fun imst S S
+msgctl msgctl ck_fun imst S S S
+msgsnd msgsnd ck_fun imst S S S
+msgrcv msgrcv ck_fun imst S S S S S
+
+# Semaphores.
+
+semget semget ck_fun imst S S S
+semctl semctl ck_fun imst S S S S
+semop semop ck_fun imst S S S
+
+# Eval.
+
+require require ck_fun d S
+dofile do 'file' ck_fun d S
+entereval eval string ck_eval d S
+leaveeval eval exit ck_null 0 S
+evalonce eval constant string ck_null d S
+entertry eval block ck_null 0
+leavetry eval block exit ck_null 0
+
+# Get system info.
+
+ghbyname gethostbyname ck_fun 0 S
+ghbyaddr gethostbyaddr ck_fun 0 S S
+ghostent gethostent ck_null 0
+gnbyname getnetbyname ck_fun 0 S
+gnbyaddr getnetbyaddr ck_fun 0 S S
+gnetent getnetent ck_null 0
+gpbyname getprotobyname ck_fun 0 S
+gpbynumber getprotobynumber ck_fun 0 S
+gprotoent getprotoent ck_null 0
+gsbyname getservbyname ck_fun 0 S S
+gsbyport getservbyport ck_fun 0 S S
+gservent getservent ck_null 0
+shostent sethostent ck_fun ist S
+snetent setnetent ck_fun ist S
+sprotoent setprotoent ck_fun ist S
+sservent setservent ck_fun ist S
+ehostent endhostent ck_null ist
+enetent endnetent ck_null ist
+eprotoent endprotoent ck_null ist
+eservent endservent ck_null ist
+gpwnam getpwnam ck_fun 0 S
+gpwuid getpwuid ck_fun 0 S
+gpwent getpwent ck_null 0
+spwent setpwent ck_null ist
+epwent endpwent ck_null ist
+ggrnam getgrnam ck_fun 0 S
+ggrgid getgrgid ck_fun 0 S
+ggrent getgrent ck_null 0
+sgrent setgrent ck_null ist
+egrent endgrent ck_null ist
+getlogin getlogin ck_null st
+
+# Miscellaneous.
+
+syscall syscall ck_fun ist S L
-/* $RCSfile: os2.c,v $$Revision: 4.0.1.2 $$Date: 92/06/08 14:32:30 $
+/* $RCSfile: os2.c,v $$Revision: 4.1 $$Date: 92/08/07 18:25:20 $
*
* (C) Copyright 1989, 1990 Diomidis Spinellis.
*
* License or the Artistic License, as specified in the README file.
*
* $Log: os2.c,v $
+ * Revision 4.1 92/08/07 18:25:20 lwall
+ *
* Revision 4.0.1.2 92/06/08 14:32:30 lwall
* patch20: new OS/2 support
*
$bin = 'c:/bin';
-# $Header: s2p.cmd,v 4.0 91/03/20 01:37:09 lwall Locked $
+# $RCSfile: s2p.cmd,v $$Revision: 4.1 $$Date: 92/08/07 18:25:37 $
#
# $Log: s2p.cmd,v $
+# Revision 4.1 92/08/07 18:25:37 lwall
+#
# Revision 4.0 91/03/20 01:37:09 lwall
# 4.0 baseline.
#
--- /dev/null
+ | LVALFUN sexpr %prec '('
+ { $$ = redOP($1, 1, lv($2)); }
+ | LVALFUN
+ { $$ = redOP($1, 1,
+ lv(gv_to_op(A_STAB,defstab))); }
+ | SSELECT
+ { $$ = redOP(OP_SELECT, 0);}
+ | SSELECT WORD
+ { $$ = redOP(OP_SELECT, 1,
+ gv_to_op(A_WORD,newGV($2,TRUE)));
+ Safefree($2); $2 = Nullch; }
+ | SSELECT '(' handle ')'
+ { $$ = redOP(OP_SELECT, 1, $3); }
+ | SSELECT '(' sexpr csexpr csexpr csexpr ')'
+ { op4 = $6;
+ $$ = redOP(OP_SSELECT, 4, $3, $4, $5); }
--- /dev/null
+
+void
+package(OP *name)
+{ char tmpbuf[256];
+ GV *tmpgv;
+
+ save_hptr(&curstash);
+ save_item(curstname);
+ sv_setpv(curstname,$2);
+ sprintf(tmpbuf,"'_%s",$2);
+ tmpgv = gv_fetchpv(tmpbuf,TRUE);
+ if (!GvHV(tmpgv))
+ GvHV(tmpgv) = newHV(0);
+ curstash = GvHV(tmpgv);
+ if (!curstash->hv_name)
+ curstash->hv_name = savestr($2);
+ curstash->hv_coeffsize = 0;
+ op_free($2);
+ copline = NOLINE;
+ expectterm = 2;
+}
--- /dev/null
+void
+XXX(fcmd)
+register FF *fcmd;
+{
+ register int i;
+ register OP *arg;
+ register int items;
+ SV *sv;
+ OP *parse_list();
+ line_t oldline = curcmd->cop_line;
+
+ sv = fcmd->ff_unparsed;
+ curcmd->cop_line = fcmd->ff_line;
+ fcmd->ff_unparsed = Nullsv;
+
+ /* Grrf. We have to fake curcmd to be in run_format's package temporarily... */
+ (void)save_hptr(&curcmd->cop_stash);
+ (void)save_hptr(&curstash);
+ curstash = sv->sv_u.sv_hv;
+ curcmd->cop_stash = sv->sv_u.sv_hv;
+ arg = parse_list(sv);
+
+ items = arg->arg_len - 1; /* ignore $$ on end */
+ for (i = 1; i <= items; i++) {
+ if (!fcmd || fcmd->ff_type == FFt_NULL)
+ fatal("Too many field values");
+ dehoistXXX(arg,i);
+ fcmd->ff_expr = redOP(OP_ITEM,1,
+ arg[i].arg_ptr.arg_arg,Nullop,Nullop);
+ if (fcmd->ff_flags & FFf_CHOP) {
+ if ((fcmd->ff_expr[1].arg_type & A_MASK) == A_STAB) {
+ fcmd->ff_expr[1].arg_type = DD_LVAL;
+ ldehoistXXX(fcmd->ff_expr,1);
+ }
+ else if ((fcmd->ff_expr[1].arg_type & A_MASK) == A_EXPR)
+ fcmd->ff_expr[1].arg_type = A_LEXPR;
+ else
+ fatal("^ field requires scalar lvalue");
+ }
+ fcmd = fcmd->ff_next;
+ }
+ if (fcmd && fcmd->ff_type)
+ fatal("Not enough field values");
+ curcmd->cop_line = oldline;
+ Safefree(arg);
+ sv_free(sv);
+}
+
-#define PATCHLEVEL 36
+#define PATCHLEVEL 0
-char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 $\nPatch level: ###\n";
+char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n";
/*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: perl.c,v $
+ * Revision 4.1 92/08/07 18:25:50 lwall
+ *
* Revision 4.0.1.7 92/06/08 14:50:39 lwall
* patch20: PERLLIB now supports multiple directories
* patch20: running taintperl explicitly now does checks even if $< == $>
* patch20: perl -P now uses location of sed determined by Configure
* patch20: form feed for formats is now specifiable via $^L
* patch20: paragraph mode now skips extra newlines automatically
- * patch20: eval "1 #comment" didn't work
+ * patch20: oldeval "1 #comment" didn't work
* patch20: couldn't require . files
* patch20: semantic compilation errors didn't abort execution
*
* patch11: cppstdin now installed outside of source directory
* patch11: -P didn't allow use of #elif or #undef
* patch11: prepared for ctype implementations that don't define isascii()
- * patch11: added eval {}
- * patch11: eval confused by string containing null
+ * patch11: added oldeval {}
+ * patch11: oldeval confused by string containing null
*
* Revision 4.0.1.4 91/06/10 01:23:07 lwall
* patch10: perl -v printed incorrect copyright notice
* patch4: new copyright notice
* patch4: added $^P variable to control calling of perldb routines
* patch4: added $^F variable to specify maximum system fd, default 2
- * patch4: debugger lost track of lines in eval
+ * patch4: debugger lost track of lines in oldeval
*
* Revision 4.0.1.1 91/04/11 17:49:05 lwall
* patch1: fixed undefined environ problem
#include "perly.h"
#include "patchlevel.h"
-char *getenv();
-
#ifdef IAMSUID
#ifndef DOSUID
#define DOSUID
#endif
#endif
-static char* moreswitches();
static void incpush();
-static char* cddir;
-static bool minus_c;
-static char patchlevel[6];
-static char *nrs = "\n";
-static int nrschar = '\n'; /* final char of rs, or 0777 if none */
-static int nrslen = 1;
-
-main(argc,argv,env)
+static void validate_suid();
+static void find_beginning();
+static void init_main_stash();
+static void open_script();
+static void init_debugger();
+static void init_stack();
+static void init_lexer();
+static void init_context_stack();
+static void init_predump_symbols();
+static void init_postdump_symbols();
+static void init_perllib();
+
+Interpreter *
+perl_alloc()
+{
+ Interpreter *sv_interp;
+ Interpreter junk;
+
+ curinterp = &junk;
+ Zero(&junk, 1, Interpreter);
+ New(53, sv_interp, 1, Interpreter);
+ return sv_interp;
+}
+
+void
+perl_construct( sv_interp )
+register Interpreter *sv_interp;
+{
+ if (!(curinterp = sv_interp))
+ return;
+
+ Zero(sv_interp, 1, Interpreter);
+
+ /* Init the real globals? */
+ if (!linestr) {
+ linestr = NEWSV(65,80);
+
+ SvREADONLY_on(&sv_undef);
+
+ sv_setpv(&sv_no,No);
+ SvNVn(&sv_no);
+ SvREADONLY_on(&sv_no);
+
+ sv_setpv(&sv_yes,Yes);
+ SvNVn(&sv_yes);
+ SvREADONLY_on(&sv_yes);
+
+#ifdef MSDOS
+ /*
+ * There is no way we can refer to them from Perl so close them to save
+ * space. The other alternative would be to provide STDAUX and STDPRN
+ * filehandles.
+ */
+ (void)fclose(stdaux);
+ (void)fclose(stdprn);
+#endif
+ }
+
+#ifdef EMBEDDED
+ chopset = " \n-";
+ cmdline = NOLINE;
+ curcop = &compiling;
+ cxstack_ix = -1;
+ cxstack_max = 128;
+ dlmax = 128;
+ laststatval = -1;
+ laststype = OP_STAT;
+ maxscream = -1;
+ maxsysfd = MAXSYSFD;
+ nrs = "\n";
+ nrschar = '\n';
+ nrslen = 1;
+ rs = "\n";
+ rschar = '\n';
+ rsfp = Nullfp;
+ rslen = 1;
+ statname = Nullstr;
+ tmps_floor = -1;
+ tmps_ix = -1;
+ tmps_max = -1;
+#endif
+
+ uid = (int)getuid();
+ euid = (int)geteuid();
+ gid = (int)getgid();
+ egid = (int)getegid();
+ sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
+
+ (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
+
+ fdpid = newAV(); /* for remembering popen pids by fd */
+ pidstatus = newHV(COEFFSIZE);/* for remembering status of dead pids */
+
+#ifdef TAINT
+#ifndef DOSUID
+ if (uid == euid && gid == egid)
+ taintanyway = TRUE; /* running taintperl explicitly */
+#endif
+#endif
+
+}
+
+void
+perl_destruct(sv_interp)
+register Interpreter *sv_interp;
+{
+ if (!(curinterp = sv_interp))
+ return;
+#ifdef EMBEDDED
+ if (main_root)
+ op_free(main_root);
+ main_root = 0;
+ if (last_root)
+ op_free(last_root);
+ last_root = 0;
+#endif
+}
+
+void
+perl_free(sv_interp)
+Interpreter *sv_interp;
+{
+ if (!(curinterp = sv_interp))
+ return;
+ Safefree(sv_interp);
+}
+
+int
+perl_parse(sv_interp, argc, argv, env)
+Interpreter *sv_interp;
register int argc;
register char **argv;
-register char **env;
+char **env;
{
- register STR *str;
+ register SV *sv;
register char *s;
char *scriptname;
char *getenv();
bool dosearch = FALSE;
-#ifdef DOSUID
char *validarg = "";
-#endif
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
#endif
#endif
+ if (!(curinterp = sv_interp))
+ return 255;
+
+ if (main_root)
+ op_free(main_root);
+ main_root = 0;
+ if (last_root)
+ op_free(last_root);
+ last_root = 0;
+
origargv = argv;
origargc = argc;
origenviron = environ;
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
- sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
-#ifdef MSDOS
- /*
- * There is no way we can refer to them from Perl so close them to save
- * space. The other alternative would be to provide STDAUX and STDPRN
- * filehandles.
- */
- (void)fclose(stdaux);
- (void)fclose(stdprn);
-#endif
+
+ switch (setjmp(top_env)) {
+ case 1:
+ statusvalue = 255;
+ case 2:
+ return(statusvalue); /* my_exit() was called */
+ case 3:
+ fprintf(stderr, "panic: top_env\n");
+ exit(1);
+ }
+
if (do_undump) {
origfilename = savestr(argv[0]);
- do_undump = 0;
- loop_ptr = -1; /* start label stack again */
+ do_undump = FALSE;
+ cxstack_ix = -1; /* start label stack again */
goto just_doit;
}
-#ifdef TAINT
-#ifndef DOSUID
- if (uid == euid && gid == egid)
- taintanyway = TRUE; /* running taintperl explicitly */
-#endif
-#endif
- (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;
- defstash->tbl_name = "main";
- incstab = hadd(aadd(stabent("INC",TRUE)));
- incstab->str_pok |= SP_MULTI;
+ sv_setpvn(linestr,"",0);
+ sv = newSVpv("",0); /* first used for -I flags */
+ init_main_stash();
for (argc--,argv++; argc > 0; argc--,argv++) {
if (argv[0][0] != '-' || !argv[0][1])
break;
case 'l':
case 'n':
case 'p':
+ case 's':
case 'u':
case 'U':
case 'v':
if (euid != uid || egid != gid)
fatal("No -I allowed in setuid scripts");
#endif
- str_cat(str,"-");
- str_cat(str,s);
- str_cat(str," ");
+ sv_catpv(sv,"-");
+ sv_catpv(sv,s);
+ sv_catpv(sv," ");
if (*++s) {
- (void)apush(stab_array(incstab),str_make(s,0));
+ (void)av_push(GvAVn(incgv),newSVpv(s,0));
}
else if (argv[1]) {
- (void)apush(stab_array(incstab),str_make(argv[1],0));
- str_cat(str,argv[1]);
+ (void)av_push(GvAVn(incgv),newSVpv(argv[1],0));
+ sv_catpv(sv,argv[1]);
argc--,argv++;
- str_cat(str," ");
+ sv_catpv(sv," ");
}
break;
case 'P':
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':
#ifdef TAINT
if (euid != uid || egid != gid)
argc++,argv--;
scriptname = e_tmpname;
}
-
-#ifdef DOSISH
-#define PERLLIB_SEP ';'
-#else
-#define PERLLIB_SEP ':'
+ else if (scriptname == Nullch) {
+#ifdef MSDOS
+ if ( isatty(fileno(stdin)) )
+ moreswitches("v");
#endif
-#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
- incpush(getenv("PERLLIB"));
-#endif /* TAINT */
+ scriptname = "-";
+ }
-#ifndef PRIVLIB
-#define PRIVLIB "/usr/local/lib/perl"
-#endif
- incpush(PRIVLIB);
- (void)apush(stab_array(incstab),str_make(".",1));
+ init_perllib();
- str_set(&str_no,No);
- str_set(&str_yes,Yes);
+ open_script(scriptname,dosearch,sv);
- /* open script */
+ sv_free(sv); /* free -I directories */
+ sv = Nullsv;
- if (scriptname == Nullch)
-#ifdef MSDOS
- {
- if ( isatty(fileno(stdin)) )
- moreswitches("v");
- scriptname = "-";
- }
-#else
- scriptname = "-";
-#endif
- if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
- char *xfound = Nullch, *xfailed = Nullch;
- int len;
+ validate_suid(validarg);
- bufend = s + strlen(s);
- while (*s) {
-#ifndef DOSISH
- s = cpytill(tokenbuf,s,bufend,':',&len);
-#else
-#ifdef atarist
- for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
- tokenbuf[len] = '\0';
-#else
- for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
- tokenbuf[len] = '\0';
-#endif
-#endif
- if (*s)
- s++;
-#ifndef DOSISH
- if (len && tokenbuf[len-1] != '/')
-#else
-#ifdef atarist
- if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
-#else
- if (len && tokenbuf[len-1] != '\\')
-#endif
-#endif
- (void)strcat(tokenbuf+len,"/");
- (void)strcat(tokenbuf+len,scriptname);
-#ifdef DEBUGGING
- if (debug & 1)
- fprintf(stderr,"Looking for %s\n",tokenbuf);
-#endif
- if (stat(tokenbuf,&statbuf) < 0) /* not there? */
- continue;
- if (S_ISREG(statbuf.st_mode)
- && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
- xfound = tokenbuf; /* bingo! */
- break;
- }
- if (!xfailed)
- xfailed = savestr(tokenbuf);
+ if (doextract)
+ find_beginning();
+
+ if (perldb)
+ init_debugger();
+
+ pad = newAV();
+ comppad = pad;
+ av_push(comppad, Nullsv);
+ curpad = AvARRAY(comppad);
+ padix = 0;
+
+ init_stack();
+
+ init_lexer();
+
+ /* now parse the script */
+
+ error_count = 0;
+ if (yyparse() || error_count) {
+ if (minus_c)
+ fatal("%s had compilation errors.\n", origfilename);
+ else {
+ fatal("Execution of %s aborted due to compilation errors.\n",
+ origfilename);
}
- if (!xfound)
- fatal("Can't execute %s", xfailed ? xfailed : scriptname );
- if (xfailed)
- Safefree(xfailed);
- scriptname = savestr(xfound);
+ }
+ curcop->cop_line = 0;
+ curstash = defstash;
+ preprocess = FALSE;
+ if (e_fp) {
+ e_fp = Nullfp;
+ (void)UNLINK(e_tmpname);
}
- fdpid = anew(Nullstab); /* for remembering popen pids by fd */
- pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
+ init_context_stack();
- origfilename = savestr(scriptname);
- curcmd->c_filestab = fstab(origfilename);
- if (strEQ(origfilename,"-"))
- scriptname = "";
- if (preprocess) {
- char *cpp = CPPSTDIN;
+ init_predump_symbols();
- if (strEQ(cpp,"cppstdin"))
- sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
- else
- sprintf(tokenbuf, "%s", cpp);
- str_cat(str,"-I");
- str_cat(str,PRIVLIB);
-#ifdef MSDOS
- (void)sprintf(buf, "\
-sed %s -e \"/^[^#]/b\" \
- -e \"/^#[ ]*include[ ]/b\" \
- -e \"/^#[ ]*define[ ]/b\" \
- -e \"/^#[ ]*if[ ]/b\" \
- -e \"/^#[ ]*ifdef[ ]/b\" \
- -e \"/^#[ ]*ifndef[ ]/b\" \
- -e \"/^#[ ]*else/b\" \
- -e \"/^#[ ]*elif[ ]/b\" \
- -e \"/^#[ ]*undef[ ]/b\" \
- -e \"/^#[ ]*endif/b\" \
- -e \"s/^#.*//\" \
- %s | %s -C %s %s",
- (doextract ? "-e \"1,/^#/d\n\"" : ""),
-#else
- (void)sprintf(buf, "\
-%s %s -e '/^[^#]/b' \
- -e '/^#[ ]*include[ ]/b' \
- -e '/^#[ ]*define[ ]/b' \
- -e '/^#[ ]*if[ ]/b' \
- -e '/^#[ ]*ifdef[ ]/b' \
- -e '/^#[ ]*ifndef[ ]/b' \
- -e '/^#[ ]*else/b' \
- -e '/^#[ ]*elif[ ]/b' \
- -e '/^#[ ]*undef[ ]/b' \
- -e '/^#[ ]*endif/b' \
- -e 's/^[ ]*#.*//' \
- %s | %s -C %s %s",
-#ifdef LOC_SED
- LOC_SED,
-#else
- "sed",
-#endif
- (doextract ? "-e '1,/^#/d\n'" : ""),
-#endif
- scriptname, tokenbuf, str_get(str), CPPMINUS);
-#ifdef DEBUGGING
- if (debug & 64) {
- fputs(buf,stderr);
- fputs("\n",stderr);
+ if (do_undump)
+ my_unexec();
+
+ just_doit: /* come here if running an undumped a.out */
+ init_postdump_symbols(argc,argv,env);
+ return 0;
+}
+
+int
+perl_run(sv_interp)
+Interpreter *sv_interp;
+{
+ if (!(curinterp = sv_interp))
+ return 255;
+ switch (setjmp(top_env)) {
+ case 1:
+ cxstack_ix = -1; /* start context stack again */
+ break;
+ case 2:
+ curstash = defstash;
+ {
+ GV *gv = gv_fetchpv("END", FALSE);
+
+ if (gv && GvCV(gv)) {
+ if (!setjmp(top_env))
+ perl_callback("END", 0, G_SCALAR, 0, 0);
+ }
+ return(statusvalue); /* my_exit() was called */
}
-#endif
- doextract = FALSE;
-#ifdef IAMSUID /* actually, this is caught earlier */
- if (euid != uid && !euid) { /* if running suidperl */
-#ifdef HAS_SETEUID
- (void)seteuid(uid); /* musn't stay setuid root */
-#else
-#ifdef HAS_SETREUID
- (void)setreuid(-1, uid);
-#else
- setuid(uid);
-#endif
-#endif
- if (geteuid() != uid)
- fatal("Can't do seteuid!\n");
+ case 3:
+ if (!restartop) {
+ fprintf(stderr, "panic: restartop\n");
+ exit(1);
}
-#endif /* IAMSUID */
- rsfp = mypopen(buf,"r");
+ if (stack != mainstack) {
+ dSP;
+ SWITCHSTACK(stack, mainstack);
+ }
+ break;
}
- else if (!*scriptname) {
-#ifdef TAINT
- if (euid != uid || egid != gid)
- fatal("Can't take set-id script from stdin");
-#endif
- rsfp = stdin;
+
+ if (!restartop) {
+ DEBUG_x(dump_all());
+ DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
+
+ if (minus_c) {
+ fprintf(stderr,"%s syntax OK\n", origfilename);
+ my_exit(0);
+ }
}
- else
- rsfp = fopen(scriptname,"r");
+
+ /* do it */
+
+ if (restartop) {
+ op = restartop;
+ restartop = 0;
+ run();
+ }
+ else if (main_start) {
+ op = main_start;
+ run();
+ }
+ else
+ fatal("panic: perl_run");
+
+ my_exit(0);
+}
+
+void
+my_exit(status)
+int status;
+{
+ statusvalue = (unsigned short)(status & 0xffff);
+ longjmp(top_env, 2);
+}
+
+/* Be sure to refetch the stack pointer after calling these routines. */
+
+int
+perl_callback(subname, sp, gimme, hasargs, numargs)
+char *subname;
+I32 sp; /* stack pointer after args are pushed */
+I32 gimme; /* called in array or scalar context */
+I32 hasargs; /* whether to create a @_ array for routine */
+I32 numargs; /* how many args are pushed on the stack */
+{
+ BINOP myop; /* fake syntax tree node */
+
+ ENTER;
+ SAVESPTR(op);
+ stack_base = AvARRAY(stack);
+ stack_sp = stack_base + sp - numargs;
+ op = (OP*)&myop;
+ pp_pushmark(); /* doesn't look at op, actually, except to return */
+ *stack_sp = (SV*)gv_fetchpv(subname, FALSE);
+ stack_sp += numargs;
+
+ myop.op_last = hasargs ? (OP*)&myop : Nullop;
+ myop.op_next = Nullop;
+
+ op = pp_entersubr();
+ run();
+ LEAVE;
+ return stack_sp - stack_base;
+}
+
+int
+perl_callv(subname, sp, gimme, argv)
+char *subname;
+register I32 sp; /* current stack pointer */
+I32 gimme; /* called in array or scalar context */
+register char **argv; /* null terminated arg list, NULL for no arglist */
+{
+ register I32 items = 0;
+ I32 hasargs = (argv != 0);
+
+ av_store(stack, ++sp, Nullsv); /* reserve spot for 1st return arg */
+ if (hasargs) {
+ while (*argv) {
+ av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0)));
+ items++;
+ argv++;
+ }
+ }
+ return perl_callback(subname, sp, gimme, hasargs, items);
+}
+
+void
+magicalize(list)
+register char *list;
+{
+ char sym[2];
+
+ sym[1] = '\0';
+ while (*sym = *list++)
+ magicname(sym, sym, 1);
+}
+
+void
+magicname(sym,name,namlen)
+char *sym;
+char *name;
+I32 namlen;
+{
+ register GV *gv;
+
+ if (gv = gv_fetchpv(sym,allgvs))
+ sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
+}
+
+#ifdef DOSISH
+#define PERLLIB_SEP ';'
+#else
+#define PERLLIB_SEP ':'
+#endif
+
+static void
+incpush(p)
+char *p;
+{
+ char *s;
+
+ if (!p)
+ return;
+
+ /* Break at all separators */
+ while (*p) {
+ /* First, skip any consecutive separators */
+ while ( *p == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
+ p++;
+ }
+ if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
+ (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
+ p = s + 1;
+ } else {
+ (void)av_push(GvAVn(incgv), newSVpv(p, 0));
+ break;
+ }
+ }
+}
+
+/* This routine handles any switches that can be given during run */
+
+char *
+moreswitches(s)
+char *s;
+{
+ I32 numlen;
+
+ switch (*s) {
+ case '0':
+ nrschar = scan_oct(s, 4, &numlen);
+ nrs = nsavestr("\n",1);
+ *nrs = nrschar;
+ if (nrschar > 0377) {
+ nrslen = 0;
+ nrs = "";
+ }
+ else if (!nrschar && numlen >= 2) {
+ nrslen = 2;
+ nrs = "\n\n";
+ nrschar = '\n';
+ }
+ return s + numlen;
+ case 'a':
+ minus_a = TRUE;
+ s++;
+ return s;
+ case 'c':
+ minus_c = TRUE;
+ s++;
+ return s;
+ case 'd':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -d allowed in setuid scripts");
+#endif
+ perldb = TRUE;
+ s++;
+ return s;
+ case 'D':
+#ifdef DEBUGGING
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -D allowed in setuid scripts");
+#endif
+ if (isALPHA(s[1])) {
+ static char debopts[] = "psltocPmfrxuLHX";
+ char *d;
+
+ for (s++; *s && (d = index(debopts,*s)); s++)
+ debug |= 1 << (d - debopts);
+ }
+ else {
+ debug = atoi(s+1);
+ for (s++; isDIGIT(*s); s++) ;
+ }
+ debug |= 32768;
+#else
+ warn("Recompile perl with -DDEBUGGING to use -D switch\n");
+ for (s++; isDIGIT(*s); s++) ;
+#endif
+ /*SUPPRESS 530*/
+ return s;
+ case 'i':
+ if (inplace)
+ Safefree(inplace);
+ inplace = savestr(s+1);
+ /*SUPPRESS 530*/
+ for (s = inplace; *s && !isSPACE(*s); s++) ;
+ *s = '\0';
+ break;
+ case 'I':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -I allowed in setuid scripts");
+#endif
+ if (*++s) {
+ (void)av_push(GvAVn(incgv),newSVpv(s,0));
+ }
+ else
+ fatal("No space allowed after -I");
+ break;
+ case 'l':
+ minus_l = TRUE;
+ s++;
+ if (isDIGIT(*s)) {
+ ors = savestr("\n");
+ orslen = 1;
+ *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
+ s += numlen;
+ }
+ else {
+ ors = nsavestr(nrs,nrslen);
+ orslen = nrslen;
+ }
+ return s;
+ case 'n':
+ minus_n = TRUE;
+ s++;
+ return s;
+ case 'p':
+ minus_p = TRUE;
+ s++;
+ return s;
+ case 's':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -s allowed in setuid scripts");
+#endif
+ doswitches = TRUE;
+ s++;
+ return s;
+ case 'u':
+ do_undump = TRUE;
+ s++;
+ return s;
+ case 'U':
+ unsafe = TRUE;
+ s++;
+ return s;
+ case 'v':
+ fputs("\nThis is perl, version 5.0, Alpha 2 (unsupported)\n\n",stdout);
+ fputs(rcsid,stdout);
+ fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993 Larry Wall\n",stdout);
+#ifdef MSDOS
+ fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
+ stdout);
+#ifdef OS2
+ fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
+ stdout);
+#endif
+#endif
+#ifdef atarist
+ fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
+#endif
+ fputs("\n\
+Perl may be copied only under the terms of either the Artistic License or the\n\
+GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
+#ifdef MSDOS
+ usage(origargv[0]);
+#endif
+ exit(0);
+ case 'w':
+ dowarn = TRUE;
+ s++;
+ return s;
+ case ' ':
+ if (s[1] == '-') /* Additional switches on #! line. */
+ return s+2;
+ break;
+ case 0:
+ case '\n':
+ case '\t':
+ break;
+ default:
+ fatal("Switch meaningless after -x: -%s",s);
+ }
+ return Nullch;
+}
+
+/* compliments of Tom Christiansen */
+
+/* unexec() can be found in the Gnu emacs distribution */
+
+void
+my_unexec()
+{
+#ifdef UNEXEC
+ int status;
+ extern int etext;
+
+ sprintf (buf, "%s.perldump", origfilename);
+ sprintf (tokenbuf, "%s/perl", BIN);
+
+ status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
+ if (status)
+ fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
+ my_exit(status);
+#else
+ ABORT(); /* for use with undump */
+#endif
+}
+
+static void
+init_main_stash()
+{
+ curstash = defstash = newHV(0);
+ curstname = newSVpv("main",4);
+ GvHV(gv_fetchpv("_main",TRUE)) = defstash;
+ HvNAME(defstash) = "main";
+ incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE)));
+ SvMULTI_on(incgv);
+ defgv = gv_fetchpv("_",TRUE);
+}
+
+static void
+open_script(scriptname,dosearch,sv)
+char *scriptname;
+bool dosearch;
+SV *sv;
+{
+ char *xfound = Nullch;
+ char *xfailed = Nullch;
+ register char *s;
+ I32 len;
+
+ if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
+
+ bufend = s + strlen(s);
+ while (*s) {
+#ifndef DOSISH
+ s = cpytill(tokenbuf,s,bufend,':',&len);
+#else
+#ifdef atarist
+ for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
+ tokenbuf[len] = '\0';
+#else
+ for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
+ tokenbuf[len] = '\0';
+#endif
+#endif
+ if (*s)
+ s++;
+#ifndef DOSISH
+ if (len && tokenbuf[len-1] != '/')
+#else
+#ifdef atarist
+ if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
+#else
+ if (len && tokenbuf[len-1] != '\\')
+#endif
+#endif
+ (void)strcat(tokenbuf+len,"/");
+ (void)strcat(tokenbuf+len,scriptname);
+ DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
+ if (stat(tokenbuf,&statbuf) < 0) /* not there? */
+ continue;
+ if (S_ISREG(statbuf.st_mode)
+ && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
+ xfound = tokenbuf; /* bingo! */
+ break;
+ }
+ if (!xfailed)
+ xfailed = savestr(tokenbuf);
+ }
+ if (!xfound)
+ fatal("Can't execute %s", xfailed ? xfailed : scriptname );
+ if (xfailed)
+ Safefree(xfailed);
+ scriptname = xfound;
+ }
+
+ origfilename = savestr(scriptname);
+ curcop->cop_filegv = gv_fetchfile(origfilename);
+ if (strEQ(origfilename,"-"))
+ scriptname = "";
+ if (preprocess) {
+ char *cpp = CPPSTDIN;
+
+ if (strEQ(cpp,"cppstdin"))
+ sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
+ else
+ sprintf(tokenbuf, "%s", cpp);
+ sv_catpv(sv,"-I");
+ sv_catpv(sv,PRIVLIB);
+#ifdef MSDOS
+ (void)sprintf(buf, "\
+sed %s -e \"/^[^#]/b\" \
+ -e \"/^#[ ]*include[ ]/b\" \
+ -e \"/^#[ ]*define[ ]/b\" \
+ -e \"/^#[ ]*if[ ]/b\" \
+ -e \"/^#[ ]*ifdef[ ]/b\" \
+ -e \"/^#[ ]*ifndef[ ]/b\" \
+ -e \"/^#[ ]*else/b\" \
+ -e \"/^#[ ]*elif[ ]/b\" \
+ -e \"/^#[ ]*undef[ ]/b\" \
+ -e \"/^#[ ]*endif/b\" \
+ -e \"s/^#.*//\" \
+ %s | %s -C %s %s",
+ (doextract ? "-e \"1,/^#/d\n\"" : ""),
+#else
+ (void)sprintf(buf, "\
+%s %s -e '/^[^#]/b' \
+ -e '/^#[ ]*include[ ]/b' \
+ -e '/^#[ ]*define[ ]/b' \
+ -e '/^#[ ]*if[ ]/b' \
+ -e '/^#[ ]*ifdef[ ]/b' \
+ -e '/^#[ ]*ifndef[ ]/b' \
+ -e '/^#[ ]*else/b' \
+ -e '/^#[ ]*elif[ ]/b' \
+ -e '/^#[ ]*undef[ ]/b' \
+ -e '/^#[ ]*endif/b' \
+ -e 's/^[ ]*#.*//' \
+ %s | %s -C %s %s",
+#ifdef LOC_SED
+ LOC_SED,
+#else
+ "sed",
+#endif
+ (doextract ? "-e '1,/^#/d\n'" : ""),
+#endif
+ scriptname, tokenbuf, SvPVn(sv), CPPMINUS);
+ DEBUG_P(fprintf(stderr, "%s\n", buf));
+ doextract = FALSE;
+#ifdef IAMSUID /* actually, this is caught earlier */
+ if (euid != uid && !euid) { /* if running suidperl */
+#ifdef HAS_SETEUID
+ (void)seteuid(uid); /* musn't stay setuid root */
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid(-1, uid);
+#else
+ setuid(uid);
+#endif
+#endif
+ if (geteuid() != uid)
+ fatal("Can't do seteuid!\n");
+ }
+#endif /* IAMSUID */
+ rsfp = my_popen(buf,"r");
+ }
+ else if (!*scriptname) {
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("Can't take set-id script from stdin");
+#endif
+ rsfp = stdin;
+ }
+ else
+ rsfp = fopen(scriptname,"r");
if ((FILE*)rsfp == Nullfp) {
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
- if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
+ if (euid && stat(SvPV(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
statbuf.st_mode & (S_ISUID|S_ISGID)) {
(void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
execv(buf, origargv); /* try again */
#endif
#endif
fatal("Can't open perl script \"%s\": %s\n",
- stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
+ SvPV(GvSV(curcop->cop_filegv)), strerror(errno));
}
- str_free(str); /* free -I directories */
- str = Nullstr;
+}
+static void
+validate_suid(validarg)
+char *validarg;
+{
/* do we need to emulate setuid on scripts? */
/* This code is for those BSD systems that have setuid #! scripts disabled
if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
fatal("Can't stat script \"%s\"",origfilename);
if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
- int len;
+ I32 len;
#ifdef IAMSUID
#ifndef HAS_SETREUID
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (access(stab_val(curcmd->c_filestab)->str_ptr,1)) /*double check*/
+ if (access(SvPV(GvSV(curcop->cop_filegv)),1)) /*double check*/
fatal("Permission denied");
#else
/* If we can swap euid and uid, then we can determine access rights
if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
fatal("Can't swap uid and euid"); /* really paranoid */
- if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
+ if (stat(SvPV(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
fatal("Permission denied"); /* testing full pathname here */
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 */
+ if (rsfp = my_popen("/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,
- stab_val(curcmd->c_filestab)->str_ptr,
+ SvPV(GvSV(curcop->cop_filegv)),
statbuf.st_uid, statbuf.st_gid);
- (void)mypclose(rsfp);
+ (void)my_pclose(rsfp);
}
fatal("Permission denied\n");
}
if (statbuf.st_mode & S_IWOTH)
fatal("Setuid/gid script is writable by world");
doswitches = FALSE; /* -s is insecure in suid */
- curcmd->c_line++;
+ curcop->cop_line++;
if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
fatal("No #! line");
}
#endif /* TAINT */
#endif /* DOSUID */
+}
+static void
+find_beginning()
+{
#if !defined(IAMSUID) && !defined(TAINT)
+ register char *s;
/* skip forward in input to the real script? */
while (doextract) {
- if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
+ if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
fatal("No Perl script found in input\n");
if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
ungetc('\n',rsfp); /* to keep line count right */
/*SUPPRESS 530*/
while (s = moreswitches(s)) ;
}
- if (cddir && chdir(cddir) < 0)
- fatal("Can't chdir to %s",cddir);
- }
- }
-#endif /* !defined(IAMSUID) && !defined(TAINT) */
-
- defstab = stabent("_",TRUE);
-
- subname = str_make("main",4);
- if (perldb) {
- debstash = hnew(0);
- stab_xhash(stabent("_DB",TRUE)) = debstash;
- curstash = debstash;
- dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
- tmpstab->str_pok |= SP_MULTI;
- dbargs->ary_flags = 0;
- DBstab = stabent("DB",TRUE);
- DBstab->str_pok |= SP_MULTI;
- DBline = stabent("dbline",TRUE);
- DBline->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;
- DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
- tmpstab->str_pok |= SP_MULTI;
- DBsignal = stab_val((tmpstab = stabent("signal",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 */
- afill(stack,63); afill(stack,-1); /* preextend stack */
- afill(savestack,63); afill(savestack,-1);
-
- /* now parse the script */
-
- error_count = 0;
- if (yyparse() || error_count) {
- if (minus_c)
- fatal("%s had compilation errors.\n", origfilename);
- else {
- fatal("Execution of %s aborted due to compilation errors.\n",
- origfilename);
- }
- }
-
- 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("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
- userinit(); /* in case linked C routines want magical variables */
-
- amperstab = stabent("&",allstabs);
- leftstab = stabent("`",allstabs);
- rightstab = stabent("'",allstabs);
- sawampersand = (amperstab || leftstab || rightstab);
- if (tmpstab = stabent(":",allstabs))
- str_set(stab_val(tmpstab),chopset);
- if (tmpstab = stabent("\024",allstabs))
- time(&basetime);
-
- /* these aren't necessarily magical */
- if (tmpstab = stabent("\014",allstabs)) {
- str_set(stab_val(tmpstab),"\f");
- formfeed = stab_val(tmpstab);
- }
- if (tmpstab = stabent(";",allstabs))
- str_set(STAB_STR(tmpstab),"\034");
- if (tmpstab = stabent("]",allstabs)) {
- str = STAB_STR(tmpstab);
- str_set(str,rcsid);
- str->str_u.str_nval = atof(patchlevel);
- str->str_nok = 1;
- }
- str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
-
- stdinstab = stabent("STDIN",TRUE);
- stdinstab->str_pok |= SP_MULTI;
- if (!stab_io(stdinstab))
- 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;
- if (!stab_io(tmpstab))
- 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;
- if (!stab_io(curoutstab))
- 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 */
-
- /* now that script is parsed, we can modify record separator */
-
- rs = nrs;
- rslen = nrslen;
- rschar = nrschar;
- rspara = (nrslen == 2);
- str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
-
- if (do_undump)
- my_unexec();
-
- 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;
- }
- if (s = index(argv[0], '=')) {
- *s++ = '\0';
- str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
- }
- else
- str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
- }
- }
-#ifdef TAINT
- tainted = 1;
-#endif
- if (tmpstab = stabent("0",allstabs)) {
- str_set(stab_val(tmpstab),origfilename);
- magicname("0", Nullch, 0);
- }
- if (tmpstab = stabent("\030",allstabs))
- str_set(stab_val(tmpstab),origargv[0]);
- if (argvstab = stabent("ARGV",allstabs)) {
- argvstab->str_pok |= SP_MULTI;
- (void)aadd(argvstab);
- aclear(stab_array(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);
- hclear(stab_hash(envstab), FALSE);
- if (env != environ)
- environ[0] = Nullch;
- 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 (dowarn) {
- stab_check('A','Z');
- stab_check('a','z');
- }
-
- 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
-
- if (minus_c) {
- fprintf(stderr,"%s syntax OK\n", origfilename);
- exit(0);
- }
-
- /* 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 */
-}
-
-void
-magicalize(list)
-register char *list;
-{
- char sym[2];
-
- sym[1] = '\0';
- while (*sym = *list++)
- magicname(sym, Nullch, 0);
-}
-
-void
-magicname(sym,name,namlen)
-char *sym;
-char *name;
-int namlen;
-{
- register STAB *stab;
-
- if (stab = stabent(sym,allstabs)) {
- stab_flags(stab) = SF_VMAGIC;
- str_magic(stab_val(stab), stab, 0, name, namlen);
- }
-}
-
-static void
-incpush(p)
-char *p;
-{
- char *s;
-
- if (!p)
- return;
-
- /* Break at all separators */
- while (*p) {
- /* First, skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
- /* Uncomment the next line for PATH semantics */
- /* (void)apush(stab_array(incstab), str_make(".", 1)); */
- p++;
- }
- if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
- (void)apush(stab_array(incstab), str_make(p, (int)(s - p)));
- p = s + 1;
- } else {
- (void)apush(stab_array(incstab), str_make(p, 0));
- break;
+ if (cddir && chdir(cddir) < 0)
+ fatal("Can't chdir to %s",cddir);
}
}
+#endif /* !defined(IAMSUID) && !defined(TAINT) */
}
-void
-savelines(array, str)
-ARRAY *array;
-STR *str;
+static void
+init_debugger()
{
- register char *s = str->str_ptr;
- register char *send = str->str_ptr + str->str_cur;
- register char *t;
- register int line = 1;
-
- while (s && s < send) {
- STR *tmpstr = Str_new(85,0);
-
- t = index(s, '\n');
- if (t)
- t++;
- else
- t = send;
-
- str_nset(tmpstr, s, t - s);
- astore(array, line++, tmpstr);
- s = t;
- }
+ GV* tmpgv;
+
+ debstash = newHV(0);
+ GvHV(gv_fetchpv("_DB",TRUE)) = debstash;
+ curstash = debstash;
+ dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE))));
+ SvMULTI_on(tmpgv);
+ AvREAL_off(dbargs);
+ DBgv = gv_fetchpv("DB",TRUE);
+ SvMULTI_on(DBgv);
+ DBline = gv_fetchpv("dbline",TRUE);
+ SvMULTI_on(DBline);
+ DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE));
+ SvMULTI_on(tmpgv);
+ DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE)));
+ SvMULTI_on(tmpgv);
+ DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE)));
+ SvMULTI_on(tmpgv);
+ DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE)));
+ SvMULTI_on(tmpgv);
+ curstash = defstash;
}
-/* this routine is in perl.c by virtue of being sort of an alternate main() */
+static void
+init_stack()
+{
+ stack = newAV();
+ mainstack = stack; /* remember in case we switch stacks */
+ AvREAL_off(stack); /* not a real array */
+ av_fill(stack,127); av_fill(stack,-1); /* preextend stack */
+
+ stack_base = AvARRAY(stack);
+ stack_sp = stack_base;
+ stack_max = stack_base + 128;
+
+ New(54,markstack,64,int);
+ markstack_ptr = markstack;
+ markstack_max = markstack + 64;
+
+ New(54,scopestack,32,int);
+ scopestack_ix = 0;
+ scopestack_max = 32;
+
+ New(54,savestack,128,ANY);
+ savestack_ix = 0;
+ savestack_max = 128;
+
+ New(54,retstack,16,OP*);
+ retstack_ix = 0;
+ retstack_max = 16;
+}
-int
-do_eval(str,optype,stash,savecmd,gimme,arglast)
-STR *str;
-int optype;
-HASH *stash;
-int savecmd;
-int gimme;
-int *arglast;
+static void
+init_lexer()
{
- STR **st = stack->ary_array;
- int retval;
- CMD *myroot = Nullcmd;
- ARRAY *ar;
- int i;
- CMD * VOLATILE oldcurcmd = curcmd;
- VOLATILE int oldtmps_base = tmps_base;
- VOLATILE int oldsave = savestack->ary_fill;
- VOLATILE int oldperldb = perldb;
- SPAT * VOLATILE oldspat = curspat;
- SPAT * VOLATILE oldlspat = lastspat;
- static char *last_eval = Nullch;
- static long last_elen = 0;
- static CMD *last_root = Nullcmd;
- VOLATILE int sp = arglast[0];
- char *specfilename;
- char *tmpfilename;
- int parsing = 1;
-
- tmps_base = tmps_max;
- if (curstash != stash) {
- (void)savehptr(&curstash);
- curstash = stash;
- }
- str_set(stab_val(stabent("@",TRUE)),"");
- if (curcmd->c_line == 0) /* don't debug debugger... */
- perldb = FALSE;
- curcmd = &compiling;
- if (optype == O_EVAL) { /* normal eval */
- curcmd->c_filestab = fstab("(eval)");
- curcmd->c_line = 1;
- str_sset(linestr,str);
- str_cat(linestr,";\n;\n"); /* be kind to them */
- if (perldb)
- savelines(stab_xarray(curcmd->c_filestab), linestr);
- }
- else {
- if (last_root && !in_eval) {
- Safefree(last_eval);
- last_eval = Nullch;
- cmd_free(last_root);
- last_root = Nullcmd;
- }
- specfilename = str_get(str);
- str_set(linestr,"");
- if (optype == O_REQUIRE && &str_undef !=
- hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
- curcmd = oldcurcmd;
- tmps_base = oldtmps_base;
- st[++sp] = &str_yes;
- perldb = oldperldb;
- return sp;
- }
- tmpfilename = savestr(specfilename);
- if (*tmpfilename == '/' ||
- (*tmpfilename == '.' &&
- (tmpfilename[1] == '/' ||
- (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
- {
- rsfp = fopen(tmpfilename,"r");
- }
- else {
- ar = stab_array(incstab);
- for (i = 0; i <= ar->ary_fill; i++) {
- (void)sprintf(buf, "%s/%s",
- str_get(afetch(ar,i,TRUE)), specfilename);
- rsfp = fopen(buf,"r");
- if (rsfp) {
- char *s = buf;
-
- if (*s == '.' && s[1] == '/')
- s += 2;
- Safefree(tmpfilename);
- tmpfilename = savestr(s);
- break;
- }
- }
- }
- curcmd->c_filestab = fstab(tmpfilename);
- Safefree(tmpfilename);
- tmpfilename = Nullch;
- if (!rsfp) {
- curcmd = oldcurcmd;
- tmps_base = oldtmps_base;
- if (optype == O_REQUIRE) {
- sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
- if (instr(tokenbuf,".h "))
- strcat(tokenbuf," (change .h to .ph maybe?)");
- if (instr(tokenbuf,".ph "))
- strcat(tokenbuf," (did you run h2ph?)");
- fatal("%s",tokenbuf);
- }
- if (gimme != G_ARRAY)
- st[++sp] = &str_undef;
- perldb = oldperldb;
- return sp;
- }
- curcmd->c_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
- eval_root = Nullcmd;
- if (setjmp(loop_stack[loop_ptr].loop_env)) {
- retval = 1;
- }
- else {
- error_count = 0;
- if (rsfp) {
- retval = yyparse();
- retval |= error_count;
- }
- else if (last_root && last_elen == bufend - bufptr
- && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
- retval = 0;
- eval_root = last_root; /* no point in reparsing */
- }
- else if (in_eval == 1 && !savecmd) {
- if (last_root) {
- Safefree(last_eval);
- last_eval = Nullch;
- cmd_free(last_root);
- }
- last_root = Nullcmd;
- last_elen = bufend - bufptr;
- last_eval = nsavestr(bufptr, last_elen);
- retval = yyparse();
- retval |= error_count;
- if (!retval)
- last_root = eval_root;
- if (!last_root) {
- Safefree(last_eval);
- last_eval = Nullch;
- }
- }
- 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;
- if (parsing) {
-#ifndef MANGLEDPARSE
-#ifdef DEBUGGING
- if (debug & 128)
- fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
-#endif
- cmd_free(eval_root);
-#endif
- /*SUPPRESS 29*/ /*SUPPRESS 30*/
- if ((CMD*)eval_root == last_root)
- last_root = Nullcmd;
- eval_root = myroot = Nullcmd;
- }
- if (rsfp) {
- fclose(rsfp);
- rsfp = 0;
- }
- }
- else {
- parsing = 0;
- sp = cmd_exec(eval_root,gimme,sp);
- st = stack->ary_array;
- for (i = arglast[0] + 1; i <= sp; i++)
- st[i] = str_mortal(st[i]);
- /* if we don't save result, free zaps it */
- if (savecmd)
- eval_root = myroot;
- else if (in_eval != 1 && myroot != last_root)
- cmd_free(myroot);
- if (eval_root == myroot)
- eval_root = Nullcmd;
- }
+ bufend = bufptr = SvPVn(linestr);
+ subname = newSVpv("main",4);
+}
- perldb = oldperldb;
- in_eval--;
-#ifdef DEBUGGING
- if (debug & 4) {
- char *tmps = loop_stack[loop_ptr].loop_label;
- deb("(Popping label #%d %s)\n",loop_ptr,
- tmps ? tmps : "" );
- }
-#endif
- loop_ptr--;
- tmps_base = oldtmps_base;
- curspat = oldspat;
- lastspat = oldlspat;
- if (savestack->ary_fill > oldsave) /* let them use local() */
- restorelist(oldsave);
-
- if (optype != O_EVAL) {
- if (retval) {
- if (optype == O_REQUIRE)
- fatal("%s", str_get(stab_val(stabent("@",TRUE))));
- }
- else {
- curcmd = oldcurcmd;
- if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
- (void)hstore(stab_hash(incstab), specfilename,
- strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
- 0 );
- }
- else if (optype == O_REQUIRE)
- fatal("%s did not return a true value", specfilename);
- }
- }
- curcmd = oldcurcmd;
- return sp;
+static void
+init_context_stack()
+{
+ New(50,cxstack,128,CONTEXT);
+ DEBUG( {
+ New(51,debname,128,char);
+ New(52,debdelim,128,char);
+ } )
}
-int
-do_try(cmd,gimme,arglast)
-CMD *cmd;
-int gimme;
-int *arglast;
+static void
+init_predump_symbols()
{
- STR **st = stack->ary_array;
-
- CMD * VOLATILE oldcurcmd = curcmd;
- VOLATILE int oldtmps_base = tmps_base;
- VOLATILE int oldsave = savestack->ary_fill;
- SPAT * VOLATILE oldspat = curspat;
- SPAT * VOLATILE oldlspat = lastspat;
- VOLATILE int sp = arglast[0];
-
- tmps_base = tmps_max;
- str_set(stab_val(stabent("@",TRUE)),"");
- in_eval++;
- 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);
+ SV *sv;
+ GV* tmpgv;
+
+ /* initialize everything that won't change if we undump */
+
+ if (siggv = gv_fetchpv("SIG",allgvs)) {
+ HV *hv;
+ SvMULTI_on(siggv);
+ hv = GvHVn(siggv);
+ hv_magic(hv, siggv, 'S');
+
+ /* initialize signal stack */
+ signalstack = newAV();
+ av_store(signalstack, 32, Nullsv);
+ av_clear(signalstack);
+ AvREAL_off(signalstack);
}
-#endif
- if (setjmp(loop_stack[loop_ptr].loop_env)) {
- st = stack->ary_array;
- sp = arglast[0];
- if (gimme != G_ARRAY)
- st[++sp] = &str_undef;
+
+ magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
+ userinit(); /* in case linked C routines want magical variables */
+
+ ampergv = gv_fetchpv("&",allgvs);
+ leftgv = gv_fetchpv("`",allgvs);
+ rightgv = gv_fetchpv("'",allgvs);
+ sawampersand = (ampergv || leftgv || rightgv);
+ if (tmpgv = gv_fetchpv(":",allgvs))
+ sv_setpv(GvSV(tmpgv),chopset);
+
+ /* these aren't necessarily magical */
+ if (tmpgv = gv_fetchpv("\014",allgvs)) {
+ sv_setpv(GvSV(tmpgv),"\f");
+ formfeed = GvSV(tmpgv);
}
- else {
- sp = cmd_exec(cmd,gimme,sp);
- st = stack->ary_array;
-/* for (i = arglast[0] + 1; i <= sp; i++)
- st[i] = str_mortal(st[i]); not needed, I think */
- /* if we don't save result, free zaps it */
+ if (tmpgv = gv_fetchpv(";",allgvs))
+ sv_setpv(GvSV(tmpgv),"\034");
+ if (tmpgv = gv_fetchpv("]",allgvs)) {
+ sv = GvSV(tmpgv);
+ sv_upgrade(sv, SVt_PVNV);
+ sv_setpv(sv,rcsid);
+ SvNV(sv) = atof(patchlevel);
+ SvNOK_on(sv);
}
+ sv_setpvn(GvSV(gv_fetchpv("\"", TRUE)), " ", 1);
+
+ stdingv = gv_fetchpv("STDIN",TRUE);
+ SvMULTI_on(stdingv);
+ if (!GvIO(stdingv))
+ GvIO(stdingv) = newIO();
+ GvIO(stdingv)->ifp = stdin;
+ tmpgv = gv_fetchpv("stdin",TRUE);
+ GvIO(tmpgv) = GvIO(stdingv);
+ SvMULTI_on(tmpgv);
+
+ tmpgv = gv_fetchpv("STDOUT",TRUE);
+ SvMULTI_on(tmpgv);
+ if (!GvIO(tmpgv))
+ GvIO(tmpgv) = newIO();
+ GvIO(tmpgv)->ofp = GvIO(tmpgv)->ifp = stdout;
+ defoutgv = tmpgv;
+ tmpgv = gv_fetchpv("stdout",TRUE);
+ GvIO(tmpgv) = GvIO(defoutgv);
+ SvMULTI_on(tmpgv);
+
+ curoutgv = gv_fetchpv("STDERR",TRUE);
+ SvMULTI_on(curoutgv);
+ if (!GvIO(curoutgv))
+ GvIO(curoutgv) = newIO();
+ GvIO(curoutgv)->ofp = GvIO(curoutgv)->ifp = stderr;
+ tmpgv = gv_fetchpv("stderr",TRUE);
+ GvIO(tmpgv) = GvIO(curoutgv);
+ SvMULTI_on(tmpgv);
+ curoutgv = defoutgv; /* switch back to STDOUT */
+
+ statname = NEWSV(66,0); /* last filename we did stat on */
- in_eval--;
-#ifdef DEBUGGING
- if (debug & 4) {
- char *tmps = loop_stack[loop_ptr].loop_label;
- deb("(Popping label #%d %s)\n",loop_ptr,
- tmps ? tmps : "" );
- }
-#endif
- loop_ptr--;
- tmps_base = oldtmps_base;
- curspat = oldspat;
- lastspat = oldlspat;
- curcmd = oldcurcmd;
- if (savestack->ary_fill > oldsave) /* let them use local() */
- restorelist(oldsave);
-
- return sp;
-}
+ /* now that script is parsed, we can modify record separator */
-/* This routine handles any switches that can be given during run */
+ rs = nrs;
+ rslen = nrslen;
+ rschar = nrschar;
+ rspara = (nrslen == 2);
+ sv_setpvn(GvSV(gv_fetchpv("/", TRUE)), rs, rslen);
+}
-static char *
-moreswitches(s)
-char *s;
+static void
+init_postdump_symbols(argc,argv,env)
+register int argc;
+register char **argv;
+register char **env;
{
- int numlen;
+ char *s;
+ SV *sv;
+ GV* tmpgv;
- switch (*s) {
- case '0':
- nrschar = scanoct(s, 4, &numlen);
- nrs = nsavestr("\n",1);
- *nrs = nrschar;
- if (nrschar > 0377) {
- nrslen = 0;
- nrs = "";
- }
- else if (!nrschar && numlen >= 2) {
- nrslen = 2;
- nrs = "\n\n";
- nrschar = '\n';
+ argc--,argv++; /* skip name of script */
+ if (doswitches) {
+ for (; argc > 0 && **argv == '-'; argc--,argv++) {
+ if (!argv[0][1])
+ break;
+ if (argv[0][1] == '-') {
+ argc--,argv++;
+ break;
+ }
+ if (s = index(argv[0], '=')) {
+ *s++ = '\0';
+ sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),s);
+ }
+ else
+ sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),1);
}
- return s + numlen;
- case 'a':
- minus_a = TRUE;
- s++;
- return s;
- case 'c':
- minus_c = TRUE;
- s++;
- return s;
- case 'd':
-#ifdef TAINT
- if (euid != uid || egid != gid)
- fatal("No -d allowed in setuid scripts");
-#endif
- perldb = TRUE;
- s++;
- return s;
- case 'D':
-#ifdef DEBUGGING
+ }
+ toptarget = NEWSV(0,0);
+ sv_upgrade(toptarget, SVt_PVFM);
+ sv_setpvn(toptarget, "", 0);
+ bodytarget = NEWSV(0,0);
+ sv_upgrade(bodytarget, SVt_PVFM);
+ sv_setpvn(bodytarget, "", 0);
+ formtarget = bodytarget;
+
#ifdef TAINT
- if (euid != uid || egid != gid)
- fatal("No -D allowed in setuid scripts");
-#endif
- debug = atoi(s+1) | 32768;
-#else
- warn("Recompile perl with -DDEBUGGING to use -D switch\n");
+ tainted = 1;
#endif
- /*SUPPRESS 530*/
- for (s++; isDIGIT(*s); s++) ;
- return s;
- case 'i':
- inplace = savestr(s+1);
- /*SUPPRESS 530*/
- for (s = inplace; *s && !isSPACE(*s); s++) ;
- *s = '\0';
- break;
- case 'I':
+ if (tmpgv = gv_fetchpv("0",allgvs)) {
+ sv_setpv(GvSV(tmpgv),origfilename);
+ magicname("0", "0", 1);
+ }
+ if (tmpgv = gv_fetchpv("\024",allgvs))
+ time(&basetime);
+ if (tmpgv = gv_fetchpv("\030",allgvs))
+ sv_setpv(GvSV(tmpgv),origargv[0]);
+ if (argvgv = gv_fetchpv("ARGV",allgvs)) {
+ SvMULTI_on(argvgv);
+ (void)gv_AVadd(argvgv);
+ av_clear(GvAVn(argvgv));
+ for (; argc > 0; argc--,argv++) {
+ (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
+ }
+ }
#ifdef TAINT
- if (euid != uid || egid != gid)
- fatal("No -I allowed in setuid scripts");
+ (void) gv_fetchpv("ENV",TRUE); /* must test PATH and IFS */
#endif
- if (*++s) {
- (void)apush(stab_array(incstab),str_make(s,0));
- }
- else
- fatal("No space allowed after -I");
- break;
- case 'l':
- minus_l = TRUE;
- s++;
- if (isDIGIT(*s)) {
- ors = savestr("\n");
- orslen = 1;
- *ors = scanoct(s, 3 + (*s == '0'), &numlen);
- s += numlen;
- }
- else {
- ors = nsavestr(nrs,nrslen);
- orslen = nrslen;
+ if (envgv = gv_fetchpv("ENV",allgvs)) {
+ HV *hv;
+ SvMULTI_on(envgv);
+ hv = GvHVn(envgv);
+ hv_clear(hv, FALSE);
+ hv_magic(hv, envgv, 'E');
+ if (env != environ)
+ environ[0] = Nullch;
+ for (; *env; env++) {
+ if (!(s = index(*env,'=')))
+ continue;
+ *s++ = '\0';
+ sv = newSVpv(s--,0);
+ (void)hv_store(hv, *env, s - *env, sv, 0);
+ *s = '=';
}
- return s;
- case 'n':
- minus_n = TRUE;
- s++;
- return s;
- case 'p':
- minus_p = TRUE;
- s++;
- return s;
- case 'u':
- do_undump = TRUE;
- s++;
- return s;
- case 'U':
- unsafe = TRUE;
- s++;
- return s;
- case 'v':
- fputs("\nThis is perl, version 4.0\n\n",stdout);
- fputs(rcsid,stdout);
- fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
-#ifdef MSDOS
- fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
- stdout);
-#ifdef OS2
- fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
- stdout);
-#endif
-#endif
-#ifdef atarist
- fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
-#endif
- fputs("\n\
-Perl may be copied only under the terms of either the Artistic License or the\n\
-GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
-#ifdef MSDOS
- usage(origargv[0]);
+ }
+#ifdef TAINT
+ tainted = 0;
#endif
- exit(0);
- case 'w':
- dowarn = TRUE;
- s++;
- return s;
- case ' ':
- case '\n':
- case '\t':
- break;
- default:
- fatal("Switch meaningless after -x: -%s",s);
+ if (tmpgv = gv_fetchpv("$",allgvs))
+ sv_setiv(GvSV(tmpgv),(I32)getpid());
+
+ if (dowarn) {
+ gv_check('A','Z');
+ gv_check('a','z');
}
- return Nullch;
}
-/* compliments of Tom Christiansen */
-
-/* unexec() can be found in the Gnu emacs distribution */
-
-void
-my_unexec()
+static void
+init_perllib()
{
-#ifdef UNEXEC
- int status;
- extern int etext;
- static char dumpname[BUFSIZ];
- static char perlpath[256];
-
- sprintf (dumpname, "%s.perldump", origfilename);
- sprintf (perlpath, "%s/perl", BIN);
+#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
+ incpush(getenv("PERLLIB"));
+#endif /* TAINT */
- status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
- if (status)
- fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
- exit(status);
-#else
-#ifdef DOSISH
- abort(); /* nothing else to do */
-#else /* ! MSDOS */
-# ifndef SIGABRT
-# define SIGABRT SIGILL
-# endif
-# ifndef SIGILL
-# define SIGILL 6 /* blech */
-# endif
- kill(getpid(),SIGABRT); /* for use with undump */
-#endif /* ! MSDOS */
+#ifndef PRIVLIB
+#define PRIVLIB "/usr/local/lib/perl"
#endif
+ incpush(PRIVLIB);
+ (void)av_push(GvAVn(incgv),newSVpv(".",1));
}
-
+++ /dev/null
-char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 $\nPatch level: ###\n";
-/*
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: perl.c,v $
- * Revision 4.0.1.7 92/06/08 14:50:39 lwall
- * patch20: PERLLIB now supports multiple directories
- * patch20: running taintperl explicitly now does checks even if $< == $>
- * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
- * patch20: perl -P now uses location of sed determined by Configure
- * patch20: form feed for formats is now specifiable via $^L
- * patch20: paragraph mode now skips extra newlines automatically
- * patch20: eval "1 #comment" didn't work
- * patch20: couldn't require . files
- * patch20: semantic compilation errors didn't abort execution
- *
- * Revision 4.0.1.6 91/11/11 16:38:45 lwall
- * patch19: default arg for shift was wrong after first subroutine definition
- * patch19: op/regexp.t failed from missing arg to bcmp()
- *
- * Revision 4.0.1.5 91/11/05 18:03:32 lwall
- * patch11: random cleanup
- * patch11: $0 was being truncated at times
- * patch11: cppstdin now installed outside of source directory
- * patch11: -P didn't allow use of #elif or #undef
- * patch11: prepared for ctype implementations that don't define isascii()
- * patch11: added eval {}
- * patch11: eval confused by string containing null
- *
- * Revision 4.0.1.4 91/06/10 01:23:07 lwall
- * patch10: perl -v printed incorrect copyright notice
- *
- * Revision 4.0.1.3 91/06/07 11:40:18 lwall
- * patch4: changed old $^P to $^X
- *
- * Revision 4.0.1.2 91/06/07 11:26:16 lwall
- * patch4: new copyright notice
- * patch4: added $^P variable to control calling of perldb routines
- * patch4: added $^F variable to specify maximum system fd, default 2
- * patch4: debugger lost track of lines in eval
- *
- * Revision 4.0.1.1 91/04/11 17:49:05 lwall
- * patch1: fixed undefined environ problem
- *
- * Revision 4.0 91/03/20 01:37:44 lwall
- * 4.0 baseline.
- *
- */
-
-/*SUPPRESS 560*/
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "perly.h"
-#include "patchlevel.h"
-
-char *getenv();
-
-#ifdef IAMSUID
-#ifndef DOSUID
-#define DOSUID
-#endif
-#endif
-
-#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
-#ifdef DOSUID
-#undef DOSUID
-#endif
-#endif
-
-static char* moreswitches();
-static void incpush();
-static char* cddir;
-static bool minus_c;
-static char patchlevel[6];
-static char *nrs = "\n";
-static int nrschar = '\n'; /* final char of rs, or 0777 if none */
-static int nrslen = 1;
-
-main(argc,argv,env)
-register int argc;
-register char **argv;
-register char **env;
-{
- register STR *str;
- register char *s;
- char *scriptname;
- char *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;
- origenviron = environ;
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
- sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
-#ifdef MSDOS
- /*
- * There is no way we can refer to them from Perl so close them to save
- * space. The other alternative would be to provide STDAUX and STDPRN
- * filehandles.
- */
- (void)fclose(stdaux);
- (void)fclose(stdprn);
-#endif
- if (do_undump) {
- origfilename = savestr(argv[0]);
- do_undump = 0;
- loop_ptr = -1; /* start label stack again */
- goto just_doit;
- }
-#ifdef TAINT
-#ifndef DOSUID
- if (uid == euid && gid == egid)
- taintanyway == TRUE; /* running taintperl explicitly */
-#endif
-#endif
- (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;
- defstash->tbl_name = "main";
- incstab = hadd(aadd(stabent("INC",TRUE)));
- incstab->str_pok |= SP_MULTI;
- for (argc--,argv++; argc > 0; 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 '0':
- case 'a':
- case 'c':
- case 'd':
- case 'D':
- case 'i':
- case 'l':
- case 'n':
- case 'p':
- case 'u':
- case 'U':
- case 'v':
- case 'w':
- if (s = moreswitches(s))
- goto reswitch;
- 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);
- if (!*e_tmpname)
- fatal("Can't mktemp()");
- e_fp = fopen(e_tmpname,"w");
- if (!e_fp)
- fatal("Cannot open temporary file");
- }
- if (argv[1]) {
- fputs(argv[1],e_fp);
- argc--,argv++;
- }
- (void)putc('\n', e_fp);
- 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 if (argv[1]) {
- (void)apush(stab_array(incstab),str_make(argv[1],0));
- str_cat(str,argv[1]);
- argc--,argv++;
- str_cat(str," ");
- }
- break;
- 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':
-#ifdef TAINT
- if (euid != uid || egid != gid)
- fatal("No -S allowed in setuid scripts");
-#endif
- dosearch = TRUE;
- s++;
- goto reswitch;
- case 'x':
- doextract = TRUE;
- s++;
- if (*s)
- cddir = savestr(s);
- break;
- case '-':
- argc--,argv++;
- goto switch_end;
- case 0:
- break;
- default:
- fatal("Unrecognized switch: -%s",s);
- }
- }
- switch_end:
- scriptname = argv[0];
- if (e_fp) {
- if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
- fatal("Can't write to temp file for -e: %s", strerror(errno));
- argc++,argv--;
- scriptname = e_tmpname;
- }
-
-#ifdef DOSISH
-#define PERLLIB_SEP ';'
-#else
-#define PERLLIB_SEP ':'
-#endif
-#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
- incpush(getenv("PERLLIB"));
-#endif /* TAINT */
-
-#ifndef PRIVLIB
-#define PRIVLIB "/usr/local/lib/perl"
-#endif
- incpush(PRIVLIB);
- (void)apush(stab_array(incstab),str_make(".",1));
-
- str_set(&str_no,No);
- str_set(&str_yes,Yes);
-
- /* open script */
-
- if (scriptname == Nullch)
-#ifdef MSDOS
- {
- if ( isatty(fileno(stdin)) )
- moreswitches("v");
- scriptname = "-";
- }
-#else
- scriptname = "-";
-#endif
- if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
- char *xfound = Nullch, *xfailed = Nullch;
- int len;
-
- bufend = s + strlen(s);
- while (*s) {
-#ifndef DOSISH
- s = cpytill(tokenbuf,s,bufend,':',&len);
-#else
-#ifdef atarist
- for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
- tokenbuf[len] = '\0';
-#else
- for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
- tokenbuf[len] = '\0';
-#endif
-#endif
- if (*s)
- s++;
-#ifndef DOSISH
- if (len && tokenbuf[len-1] != '/')
-#else
-#ifdef atarist
- if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
-#else
- if (len && tokenbuf[len-1] != '\\')
-#endif
-#endif
- (void)strcat(tokenbuf+len,"/");
- (void)strcat(tokenbuf+len,scriptname);
-#ifdef DEBUGGING
- if (debug & 1)
- fprintf(stderr,"Looking for %s\n",tokenbuf);
-#endif
- if (stat(tokenbuf,&statbuf) < 0) /* not there? */
- continue;
- if (S_ISREG(statbuf.st_mode)
- && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
- xfound = tokenbuf; /* bingo! */
- break;
- }
- if (!xfailed)
- xfailed = savestr(tokenbuf);
- }
- if (!xfound)
- fatal("Can't execute %s", xfailed ? xfailed : scriptname );
- if (xfailed)
- Safefree(xfailed);
- scriptname = savestr(xfound);
- }
-
- fdpid = anew(Nullstab); /* for remembering popen pids by fd */
- pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
-
- origfilename = savestr(scriptname);
- curcmd->c_filestab = fstab(origfilename);
- if (strEQ(origfilename,"-"))
- scriptname = "";
- if (preprocess) {
- char *cpp = CPPSTDIN;
-
- if (strEQ(cpp,"cppstdin"))
- sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
- else
- sprintf(tokenbuf, "%s", cpp);
- str_cat(str,"-I");
- str_cat(str,PRIVLIB);
-#ifdef MSDOS
- (void)sprintf(buf, "\
-sed %s -e \"/^[^#]/b\" \
- -e \"/^#[ ]*include[ ]/b\" \
- -e \"/^#[ ]*define[ ]/b\" \
- -e \"/^#[ ]*if[ ]/b\" \
- -e \"/^#[ ]*ifdef[ ]/b\" \
- -e \"/^#[ ]*ifndef[ ]/b\" \
- -e \"/^#[ ]*else/b\" \
- -e \"/^#[ ]*elif[ ]/b\" \
- -e \"/^#[ ]*undef[ ]/b\" \
- -e \"/^#[ ]*endif/b\" \
- -e \"s/^#.*//\" \
- %s | %s -C %s %s",
- (doextract ? "-e \"1,/^#/d\n\"" : ""),
-#else
- (void)sprintf(buf, "\
-%s %s -e '/^[^#]/b' \
- -e '/^#[ ]*include[ ]/b' \
- -e '/^#[ ]*define[ ]/b' \
- -e '/^#[ ]*if[ ]/b' \
- -e '/^#[ ]*ifdef[ ]/b' \
- -e '/^#[ ]*ifndef[ ]/b' \
- -e '/^#[ ]*else/b' \
- -e '/^#[ ]*elif[ ]/b' \
- -e '/^#[ ]*undef[ ]/b' \
- -e '/^#[ ]*endif/b' \
- -e 's/^[ ]*#.*//' \
- %s | %s -C %s %s",
-#ifdef LOC_SED
- LOC_SED,
-#else
- "sed",
-#endif
- (doextract ? "-e '1,/^#/d\n'" : ""),
-#endif
- scriptname, tokenbuf, str_get(str), CPPMINUS);
-#ifdef DEBUGGING
- if (debug & 64) {
- fputs(buf,stderr);
- fputs("\n",stderr);
- }
-#endif
- doextract = FALSE;
-#ifdef IAMSUID /* actually, this is caught earlier */
- if (euid != uid && !euid) { /* if running suidperl */
-#ifdef HAS_SETEUID
- (void)seteuid(uid); /* musn't stay setuid root */
-#else
-#ifdef HAS_SETREUID
- (void)setreuid(-1, uid);
-#else
- setuid(uid);
-#endif
-#endif
- if (geteuid() != uid)
- fatal("Can't do seteuid!\n");
- }
-#endif /* IAMSUID */
- rsfp = mypopen(buf,"r");
- }
- else if (!*scriptname) {
-#ifdef TAINT
- if (euid != uid || egid != gid)
- fatal("Can't take set-id script from stdin");
-#endif
- rsfp = stdin;
- }
- else
- rsfp = fopen(scriptname,"r");
- if ((FILE*)rsfp == Nullfp) {
-#ifdef DOSUID
-#ifndef IAMSUID /* in case script is not readable before setuid */
- if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
- statbuf.st_mode & (S_ISUID|S_ISGID)) {
- (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
- execv(buf, origargv); /* try again */
- fatal("Can't do setuid\n");
- }
-#endif
-#endif
- fatal("Can't open perl script \"%s\": %s\n",
- stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
- }
- str_free(str); /* free -I directories */
- str = Nullstr;
-
- /* 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 or sperlN.NNN. 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 or tperlN.NNN that just does the TAINT checks.
- */
-
-#ifdef DOSUID
- if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
- fatal("Can't stat script \"%s\"",origfilename);
- if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
- int len;
-
-#ifdef IAMSUID
-#ifndef HAS_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(stab_val(curcmd->c_filestab)->str_ptr,1)) /*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(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
- fatal("Permission denied"); /* testing full pathname here */
- 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,
- stab_val(curcmd->c_filestab)->str_ptr,
- 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_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
- fatal("Permission denied\n");
- }
-#endif /* HAS_SETREUID */
-#endif /* IAMSUID */
-
- if (!S_ISREG(statbuf.st_mode))
- fatal("Permission denied");
- if (statbuf.st_mode & S_IWOTH)
- fatal("Setuid/gid script is writable by world");
- doswitches = FALSE; /* -s is insecure in suid */
- curcmd->c_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) && strnNE(s-9,"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/sperl%s", BIN, patchlevel);
- execv(buf, origargv); /* try again */
-#endif
- fatal("Can't do setuid\n");
- }
-
- if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
-#ifdef HAS_SETEGID
- (void)setegid(statbuf.st_gid);
-#else
-#ifdef HAS_SETREGID
- (void)setregid((GIDTYPE)-1,statbuf.st_gid);
-#else
- setgid(statbuf.st_gid);
-#endif
-#endif
- if (getegid() != statbuf.st_gid)
- fatal("Can't do setegid!\n");
- }
- if (statbuf.st_mode & S_ISUID) {
- if (statbuf.st_uid != euid)
-#ifdef HAS_SETEUID
- (void)seteuid(statbuf.st_uid); /* all that for this */
-#else
-#ifdef HAS_SETREUID
- (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
-#else
- setuid(statbuf.st_uid);
-#endif
-#endif
- if (geteuid() != statbuf.st_uid)
- fatal("Can't do seteuid!\n");
- }
- else if (uid) { /* oops, mustn't run as root */
-#ifdef HAS_SETEUID
- (void)seteuid((UIDTYPE)uid);
-#else
-#ifdef HAS_SETREUID
- (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
-#else
- setuid((UIDTYPE)uid);
-#endif
-#endif
- if (geteuid() != uid)
- fatal("Can't do seteuid!\n");
- }
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
- if (!cando(S_IXUSR,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/tperl%s", BIN, patchlevel);
- 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/tperl%s", BIN, patchlevel);
- execv(buf, origargv); /* try again */
- fatal("Can't run setuid script with taint checks");
- }
-#endif /* TAINT */
-#endif /* DOSUID */
-
-#if !defined(IAMSUID) && !defined(TAINT)
-
- /* skip forward in input to the real script? */
-
- while (doextract) {
- if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
- fatal("No Perl script found in input\n");
- if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
- ungetc('\n',rsfp); /* to keep line count right */
- doextract = FALSE;
- if (s = instr(s,"perl -")) {
- s += 6;
- /*SUPPRESS 530*/
- while (s = moreswitches(s)) ;
- }
- if (cddir && chdir(cddir) < 0)
- fatal("Can't chdir to %s",cddir);
- }
- }
-#endif /* !defined(IAMSUID) && !defined(TAINT) */
-
- defstab = stabent("_",TRUE);
-
- subname = str_make("main",4);
- if (perldb) {
- debstash = hnew(0);
- stab_xhash(stabent("_DB",TRUE)) = debstash;
- curstash = debstash;
- dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
- tmpstab->str_pok |= SP_MULTI;
- dbargs->ary_flags = 0;
- DBstab = stabent("DB",TRUE);
- DBstab->str_pok |= SP_MULTI;
- DBline = stabent("dbline",TRUE);
- DBline->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;
- DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
- tmpstab->str_pok |= SP_MULTI;
- DBsignal = stab_val((tmpstab = stabent("signal",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 */
- afill(stack,63); afill(stack,-1); /* preextend stack */
- afill(savestack,63); afill(savestack,-1);
-
- /* now parse the script */
-
- error_count = 0;
- if (yyparse() || error_count) {
- if (minus_c)
- fatal("%s had compilation errors.\n", origfilename);
- else {
- fatal("Execution of %s aborted due to compilation errors.\n",
- origfilename);
- }
- }
-
- 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("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
- userinit(); /* in case linked C routines want magical variables */
-
- amperstab = stabent("&",allstabs);
- leftstab = stabent("`",allstabs);
- rightstab = stabent("'",allstabs);
- sawampersand = (amperstab || leftstab || rightstab);
- if (tmpstab = stabent(":",allstabs))
- str_set(stab_val(tmpstab),chopset);
- if (tmpstab = stabent("\024",allstabs))
- time(&basetime);
-
- /* these aren't necessarily magical */
- if (tmpstab = stabent("\014",allstabs)) {
- str_set(stab_val(tmpstab),"\f");
- formfeed = stab_val(tmpstab);
- }
- if (tmpstab = stabent(";",allstabs))
- str_set(STAB_STR(tmpstab),"\034");
- if (tmpstab = stabent("]",allstabs)) {
- str = STAB_STR(tmpstab);
- str_set(str,rcsid);
- str->str_u.str_nval = atof(patchlevel);
- str->str_nok = 1;
- }
- str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
-
- stdinstab = stabent("STDIN",TRUE);
- stdinstab->str_pok |= SP_MULTI;
- if (!stab_io(stdinstab))
- 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;
- if (!stab_io(tmpstab))
- 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;
- if (!stab_io(curoutstab))
- 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 */
-
- /* now that script is parsed, we can modify record separator */
-
- rs = nrs;
- rslen = nrslen;
- rschar = nrschar;
- rspara = (nrslen == 2);
- str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
-
- if (do_undump)
- my_unexec();
-
- 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;
- }
- if (s = index(argv[0], '=')) {
- *s++ = '\0';
- str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
- }
- else
- str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
- }
- }
-#ifdef TAINT
- tainted = 1;
-#endif
- if (tmpstab = stabent("0",allstabs)) {
- str_set(stab_val(tmpstab),origfilename);
- magicname("0", Nullch, 0);
- }
- if (tmpstab = stabent("\030",allstabs))
- str_set(stab_val(tmpstab),origargv[0]);
- if (argvstab = stabent("ARGV",allstabs)) {
- argvstab->str_pok |= SP_MULTI;
- (void)aadd(argvstab);
- aclear(stab_array(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);
- hclear(stab_hash(envstab), FALSE);
- if (env != environ)
- environ[0] = Nullch;
- 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 (dowarn) {
- stab_check('A','Z');
- stab_check('a','z');
- }
-
- 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
-
- if (minus_c) {
- fprintf(stderr,"%s syntax OK\n", origfilename);
- exit(0);
- }
-
- /* 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 */
-}
-
-void
-magicalize(list)
-register char *list;
-{
- char sym[2];
-
- sym[1] = '\0';
- while (*sym = *list++)
- magicname(sym, Nullch, 0);
-}
-
-void
-magicname(sym,name,namlen)
-char *sym;
-char *name;
-int namlen;
-{
- register STAB *stab;
-
- if (stab = stabent(sym,allstabs)) {
- stab_flags(stab) = SF_VMAGIC;
- str_magic(stab_val(stab), stab, 0, name, namlen);
- }
-}
-
-static void
-incpush(p)
-char *p;
-{
- char *s;
-
- if (!p)
- return;
-
- /* Break at all separators */
- while (*p) {
- /* First, skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
- /* Uncomment the next line for PATH semantics */
- /* (void)apush(stab_array(incstab), str_make(".", 1)); */
- p++;
- }
- if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
- (void)apush(stab_array(incstab), str_make(p, (int)(s - p)));
- p = s + 1;
- } else {
- (void)apush(stab_array(incstab), str_make(p, 0));
- break;
- }
- }
-}
-
-void
-savelines(array, str)
-ARRAY *array;
-STR *str;
-{
- register char *s = str->str_ptr;
- register char *send = str->str_ptr + str->str_cur;
- register char *t;
- register int line = 1;
-
- while (s && s < send) {
- STR *tmpstr = Str_new(85,0);
-
- t = index(s, '\n');
- if (t)
- t++;
- else
- t = send;
-
- str_nset(tmpstr, s, t - s);
- astore(array, line++, tmpstr);
- s = t;
- }
-}
-
-/* this routine is in perl.c by virtue of being sort of an alternate main() */
-
-int
-do_eval(str,optype,stash,savecmd,gimme,arglast)
-STR *str;
-int optype;
-HASH *stash;
-int savecmd;
-int gimme;
-int *arglast;
-{
- STR **st = stack->ary_array;
- int retval;
- CMD *myroot = Nullcmd;
- ARRAY *ar;
- int i;
- CMD * VOLATILE oldcurcmd = curcmd;
- VOLATILE int oldtmps_base = tmps_base;
- VOLATILE int oldsave = savestack->ary_fill;
- VOLATILE int oldperldb = perldb;
- SPAT * VOLATILE oldspat = curspat;
- SPAT * VOLATILE oldlspat = lastspat;
- static char *last_eval = Nullch;
- static long last_elen = 0;
- static CMD *last_root = Nullcmd;
- VOLATILE int sp = arglast[0];
- char *specfilename;
- char *tmpfilename;
- int parsing = 1;
-
- tmps_base = tmps_max;
- if (curstash != stash) {
- (void)savehptr(&curstash);
- curstash = stash;
- }
- str_set(stab_val(stabent("@",TRUE)),"");
- if (curcmd->c_line == 0) /* don't debug debugger... */
- perldb = FALSE;
- curcmd = &compiling;
- if (optype == O_EVAL) { /* normal eval */
- curcmd->c_filestab = fstab("(eval)");
- curcmd->c_line = 1;
- str_sset(linestr,str);
- str_cat(linestr,";\n;\n"); /* be kind to them */
- if (perldb)
- savelines(stab_xarray(curcmd->c_filestab), linestr);
- }
- else {
- if (last_root && !in_eval) {
- Safefree(last_eval);
- last_eval = Nullch;
- cmd_free(last_root);
- last_root = Nullcmd;
- }
- specfilename = str_get(str);
- str_set(linestr,"");
- if (optype == O_REQUIRE && &str_undef !=
- hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
- curcmd = oldcurcmd;
- tmps_base = oldtmps_base;
- st[++sp] = &str_yes;
- perldb = oldperldb;
- return sp;
- }
- tmpfilename = savestr(specfilename);
- if (*tmpfilename == '/' ||
- (*tmpfilename == '.' &&
- (tmpfilename[1] == '/' ||
- (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
- {
- rsfp = fopen(tmpfilename,"r");
- }
- else {
- ar = stab_array(incstab);
- for (i = 0; i <= ar->ary_fill; i++) {
- (void)sprintf(buf, "%s/%s",
- str_get(afetch(ar,i,TRUE)), specfilename);
- rsfp = fopen(buf,"r");
- if (rsfp) {
- char *s = buf;
-
- if (*s == '.' && s[1] == '/')
- s += 2;
- Safefree(tmpfilename);
- tmpfilename = savestr(s);
- break;
- }
- }
- }
- curcmd->c_filestab = fstab(tmpfilename);
- Safefree(tmpfilename);
- tmpfilename = Nullch;
- if (!rsfp) {
- curcmd = oldcurcmd;
- tmps_base = oldtmps_base;
- if (optype == O_REQUIRE) {
- sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
- if (instr(tokenbuf,".h "))
- strcat(tokenbuf," (change .h to .ph maybe?)");
- if (instr(tokenbuf,".ph "))
- strcat(tokenbuf," (did you run h2ph?)");
- fatal("%s",tokenbuf);
- }
- if (gimme != G_ARRAY)
- st[++sp] = &str_undef;
- perldb = oldperldb;
- return sp;
- }
- curcmd->c_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
- eval_root = Nullcmd;
- if (setjmp(loop_stack[loop_ptr].loop_env)) {
- retval = 1;
- }
- else {
- error_count = 0;
- if (rsfp) {
- retval = yyparse();
- retval |= error_count;
- }
- else if (last_root && last_elen == bufend - bufptr
- && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
- retval = 0;
- eval_root = last_root; /* no point in reparsing */
- }
- else if (in_eval == 1 && !savecmd) {
- if (last_root) {
- Safefree(last_eval);
- last_eval = Nullch;
- cmd_free(last_root);
- }
- last_root = Nullcmd;
- last_elen = bufend - bufptr;
- last_eval = nsavestr(bufptr, last_elen);
- retval = yyparse();
- retval |= error_count;
- if (!retval)
- last_root = eval_root;
- if (!last_root) {
- Safefree(last_eval);
- last_eval = Nullch;
- }
- }
- 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;
- if (parsing) {
-#ifndef MANGLEDPARSE
-#ifdef DEBUGGING
- if (debug & 128)
- fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
-#endif
- cmd_free(eval_root);
-#endif
- /*SUPPRESS 29*/ /*SUPPRESS 30*/
- if ((CMD*)eval_root == last_root)
- last_root = Nullcmd;
- eval_root = myroot = Nullcmd;
- }
- if (rsfp) {
- fclose(rsfp);
- rsfp = 0;
- }
- }
- else {
- parsing = 0;
- sp = cmd_exec(eval_root,gimme,sp);
- st = stack->ary_array;
- for (i = arglast[0] + 1; i <= sp; i++)
- st[i] = str_mortal(st[i]);
- /* if we don't save result, free zaps it */
- if (savecmd)
- eval_root = myroot;
- else if (in_eval != 1 && myroot != last_root)
- cmd_free(myroot);
- }
-
- perldb = oldperldb;
- in_eval--;
-#ifdef DEBUGGING
- if (debug & 4) {
- char *tmps = loop_stack[loop_ptr].loop_label;
- deb("(Popping label #%d %s)\n",loop_ptr,
- tmps ? tmps : "" );
- }
-#endif
- loop_ptr--;
- tmps_base = oldtmps_base;
- curspat = oldspat;
- lastspat = oldlspat;
- if (savestack->ary_fill > oldsave) /* let them use local() */
- restorelist(oldsave);
-
- if (optype != O_EVAL) {
- if (retval) {
- if (optype == O_REQUIRE)
- fatal("%s", str_get(stab_val(stabent("@",TRUE))));
- }
- else {
- curcmd = oldcurcmd;
- if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
- (void)hstore(stab_hash(incstab), specfilename,
- strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
- 0 );
- }
- else if (optype == O_REQUIRE)
- fatal("%s did not return a true value", specfilename);
- }
- }
- curcmd = oldcurcmd;
- return sp;
-}
-
-int
-do_try(cmd,gimme,arglast)
-CMD *cmd;
-int gimme;
-int *arglast;
-{
- STR **st = stack->ary_array;
-
- CMD * VOLATILE oldcurcmd = curcmd;
- VOLATILE int oldtmps_base = tmps_base;
- VOLATILE int oldsave = savestack->ary_fill;
- SPAT * VOLATILE oldspat = curspat;
- SPAT * VOLATILE oldlspat = lastspat;
- VOLATILE int sp = arglast[0];
-
- tmps_base = tmps_max;
- str_set(stab_val(stabent("@",TRUE)),"");
- in_eval++;
- 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)) {
- st = stack->ary_array;
- sp = arglast[0];
- if (gimme != G_ARRAY)
- st[++sp] = &str_undef;
- }
- else {
- sp = cmd_exec(cmd,gimme,sp);
- st = stack->ary_array;
-/* for (i = arglast[0] + 1; i <= sp; i++)
- st[i] = str_mortal(st[i]); not needed, I think */
- /* if we don't save result, free zaps it */
- }
-
- in_eval--;
-#ifdef DEBUGGING
- if (debug & 4) {
- char *tmps = loop_stack[loop_ptr].loop_label;
- deb("(Popping label #%d %s)\n",loop_ptr,
- tmps ? tmps : "" );
- }
-#endif
- loop_ptr--;
- tmps_base = oldtmps_base;
- curspat = oldspat;
- lastspat = oldlspat;
- curcmd = oldcurcmd;
- if (savestack->ary_fill > oldsave) /* let them use local() */
- restorelist(oldsave);
-
- return sp;
-}
-
-/* This routine handles any switches that can be given during run */
-
-static char *
-moreswitches(s)
-char *s;
-{
- int numlen;
-
- switch (*s) {
- case '0':
- nrschar = scanoct(s, 4, &numlen);
- nrs = nsavestr("\n",1);
- *nrs = nrschar;
- if (nrschar > 0377) {
- nrslen = 0;
- nrs = "";
- }
- else if (!nrschar && numlen >= 2) {
- nrslen = 2;
- nrs = "\n\n";
- nrschar = '\n';
- }
- return s + numlen;
- case 'a':
- minus_a = TRUE;
- s++;
- return s;
- case 'c':
- minus_c = TRUE;
- s++;
- return s;
- case 'd':
-#ifdef TAINT
- if (euid != uid || egid != gid)
- fatal("No -d allowed in setuid scripts");
-#endif
- perldb = TRUE;
- s++;
- return s;
- case 'D':
-#ifdef DEBUGGING
-#ifdef TAINT
- if (euid != uid || egid != gid)
- fatal("No -D allowed in setuid scripts");
-#endif
- debug = atoi(s+1) | 32768;
-#else
- warn("Recompile perl with -DDEBUGGING to use -D switch\n");
-#endif
- /*SUPPRESS 530*/
- for (s++; isDIGIT(*s); s++) ;
- return s;
- case 'i':
- inplace = savestr(s+1);
- /*SUPPRESS 530*/
- for (s = inplace; *s && !isSPACE(*s); s++) ;
- *s = '\0';
- break;
- case 'I':
-#ifdef TAINT
- if (euid != uid || egid != gid)
- fatal("No -I allowed in setuid scripts");
-#endif
- if (*++s) {
- (void)apush(stab_array(incstab),str_make(s,0));
- }
- else
- fatal("No space allowed after -I");
- break;
- case 'l':
- minus_l = TRUE;
- s++;
- if (isDIGIT(*s)) {
- ors = savestr("\n");
- orslen = 1;
- *ors = scanoct(s, 3 + (*s == '0'), &numlen);
- s += numlen;
- }
- else {
- ors = nsavestr(nrs,nrslen);
- orslen = nrslen;
- }
- return s;
- case 'n':
- minus_n = TRUE;
- s++;
- return s;
- case 'p':
- minus_p = TRUE;
- s++;
- return s;
- case 'u':
- do_undump = TRUE;
- s++;
- return s;
- case 'U':
- unsafe = TRUE;
- s++;
- return s;
- case 'v':
- fputs("\nThis is perl, version 4.0\n\n",stdout);
- fputs(rcsid,stdout);
- fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
-#ifdef MSDOS
- fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
- stdout);
-#ifdef OS2
- fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
- stdout);
-#endif
-#endif
-#ifdef atarist
- fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
-#endif
- fputs("\n\
-Perl may be copied only under the terms of either the Artistic License or the\n\
-GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
-#ifdef MSDOS
- usage(origargv[0]);
-#endif
- exit(0);
- case 'w':
- dowarn = TRUE;
- s++;
- return s;
- case ' ':
- case '\n':
- case '\t':
- break;
- default:
- fatal("Switch meaningless after -x: -%s",s);
- }
- return Nullch;
-}
-
-/* compliments of Tom Christiansen */
-
-/* unexec() can be found in the Gnu emacs distribution */
-
-void
-my_unexec()
-{
-#ifdef UNEXEC
- int status;
- extern int etext;
- static char dumpname[BUFSIZ];
- static char perlpath[256];
-
- sprintf (dumpname, "%s.perldump", origfilename);
- sprintf (perlpath, "%s/perl", BIN);
-
- status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
- if (status)
- fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
- exit(status);
-#else
-#ifdef DOSISH
- abort(); /* nothing else to do */
-#else /* ! MSDOS */
-# ifndef SIGABRT
-# define SIGABRT SIGILL
-# endif
-# ifndef SIGILL
-# define SIGILL 6 /* blech */
-# endif
- kill(getpid(),SIGABRT); /* for use with undump */
-#endif /* ! MSDOS */
-#endif
-}
-
+++ /dev/null
-***************
-*** 1,4 ****
-! char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 1992/06/08 14:50:39 $\nPatch level: ###\n";
- /*
- * Copyright (c) 1991, Larry Wall
- *
---- 1,4 ----
-! char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.8 $$Date: 1993/02/05 19:39:30 $\nPatch level: ###\n";
- /*
- * Copyright (c) 1991, Larry Wall
- *
-***************
-*** 6,12 ****
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: perl.c,v $
-! * Revision 4.0.1.7 1992/06/08 14:50:39 lwall
- * patch20: PERLLIB now supports multiple directories
- * patch20: running taintperl explicitly now does checks even if $< == $>
- * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
---- 6,16 ----
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: perl.c,v $
-! * Revision 4.0.1.8 1993/02/05 19:39:30 lwall
-! * patch36: the taintanyway code wasn't tainting anyway
-! * patch36: Malformed cmd links core dump apparently fixed
-! *
-! * Revision 4.0.1.7 92/06/08 14:50:39 lwall
- * patch20: PERLLIB now supports multiple directories
- * patch20: running taintperl explicitly now does checks even if $< == $>
- * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
-***************
-*** 16,22 ****
- * patch20: eval "1 #comment" didn't work
- * patch20: couldn't require . files
- * patch20: semantic compilation errors didn't abort execution
-! *
- * Revision 4.0.1.6 91/11/11 16:38:45 lwall
- * patch19: default arg for shift was wrong after first subroutine definition
- * patch19: op/regexp.t failed from missing arg to bcmp()
---- 20,26 ----
- * patch20: eval "1 #comment" didn't work
- * patch20: couldn't require . files
- * patch20: semantic compilation errors didn't abort execution
-! *
- * Revision 4.0.1.6 91/11/11 16:38:45 lwall
- * patch19: default arg for shift was wrong after first subroutine definition
- * patch19: op/regexp.t failed from missing arg to bcmp()
-/* $RCSfile: perl.h,v $$Revision: 4.0.1.6 $$Date: 92/06/08 14:55:10 $
+/* $RCSfile: perl.h,v $$Revision: 4.1 $$Date: 92/08/07 18:25:56 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: perl.h,v $
+ * Revision 4.1 92/08/07 18:25:56 lwall
+ *
* Revision 4.0.1.6 92/06/08 14:55:10 lwall
* patch20: added Atari ST portability
* patch20: bcopy() and memcpy() now tested for overlap safety
*
*/
+#include "embed.h"
+
#define VOIDWANT 1
+#ifdef __cplusplus
+#include "config_c++.h"
+#else
#include "config.h"
+#endif
+
+#ifndef BYTEORDER
+# define BYTEORDER 0x1234
+#endif
+
+/* Overall memory policy? */
+#ifndef CONSERVATIVE
+# define LIBERAL 1
+#endif
+
+/*
+ * The following contortions are brought to you on behalf of all the
+ * standards, semi-standards, de facto standards, not-so-de-facto standards
+ * of the world, as well as all the other botches anyone ever thought of.
+ * The basic theory is that if we work hard enough here, the rest of the
+ * code can be a lot prettier. Well, so much for theory. Sorry, Henry...
+ */
#ifdef MYMALLOC
# ifdef HIDEMYMALLOC
#define DOSISH 1
#endif
-#ifdef DOSISH
-/* This stuff now in the MS-DOS config.h file. */
-#else /* !MSDOS */
-
-/*
- * The following symbols are defined if your operating system supports
- * functions by that name. All Unixes I know of support them, thus they
- * are not checked by the configuration script, but are directly defined
- * here.
- */
-#define HAS_ALARM
-#define HAS_CHOWN
-#define HAS_CHROOT
-#define HAS_FORK
-#define HAS_GETLOGIN
-#define HAS_GETPPID
-#define HAS_KILL
-#define HAS_LINK
-#define HAS_PIPE
-#define HAS_WAIT
-#define HAS_UMASK
-/*
- * The following symbols are defined if your operating system supports
- * password and group functions in general. All Unix systems do.
- */
-#define HAS_GROUP
-#define HAS_PASSWD
-
-#endif /* !MSDOS */
-
-#if defined(__STDC__) || defined(_AIX) || defined(__stdc__)
+#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus)
# define STANDARD_C 1
#endif
+#if defined(STANDARD_C)
+# define P(args) args
+#else
+# define P(args) ()
+#endif
+
#if defined(HASVOLATILE) || defined(STANDARD_C)
-#define VOLATILE volatile
+# ifdef __cplusplus
+# define VOL // to temporarily suppress warnings
+# else
+# define VOL volatile
+# endif
#else
-#define VOLATILE
+# define VOL
#endif
#ifdef IAMSUID
# define TAINT
# endif
#endif
+#ifdef TAINT
+# define TAINT_IF(c) (tainted |= (c))
+# define TAINT_NOT (tainted = 0)
+# define TAINT_PROPER(s) taint_proper(no_security, s)
+# define TAINT_ENV() taint_env()
+#else
+# define TAINT_IF(c)
+# define TAINT_NOT
+# define TAINT_PROPER(s)
+# define TAINT_ENV()
+#endif
#ifndef HAS_VFORK
# define vfork fork
#include <stdio.h>
#include <ctype.h>
#include <setjmp.h>
+
#ifndef MSDOS
-#ifdef PARAM_NEEDS_TYPES
-#include <sys/types.h>
-#endif
-#include <sys/param.h>
+# ifdef PARAM_NEEDS_TYPES
+# include <sys/types.h>
+# endif
+# include <sys/param.h>
#endif
+
+
+/* Use all the "standard" definitions? */
#ifdef STANDARD_C
-/* Use all the "standard" definitions */
-#include <stdlib.h>
-#include <string.h>
-#define MEM_SIZE size_t
+# include <stdlib.h>
+# include <string.h>
+# define MEM_SIZE size_t
#else
-typedef unsigned int MEM_SIZE;
+ typedef unsigned int MEM_SIZE;
#endif /* STANDARD_C */
#if defined(HAS_MEMCMP) && defined(mips) && defined(ultrix)
-#undef HAS_MEMCMP
+# undef HAS_MEMCMP
#endif
#ifdef HAS_MEMCPY
# ifndef STANDARD_C
# ifndef memcpy
- extern char * memcpy();
+ extern char * memcpy P((char*, char*, int));
# endif
# endif
#else
#ifdef HAS_MEMSET
# ifndef STANDARD_C
# ifndef memset
- extern char *memset();
+ extern char *memset P((char*, int, int));
# endif
# endif
# define memzero(d,l) memset(d,0,l)
#ifdef HAS_MEMCMP
# ifndef STANDARD_C
# ifndef memcmp
- extern int memcmp();
+ extern int memcmp P((char*, char*, int));
# endif
# endif
#else
#endif /* HAS_BCMP */
#ifndef HAS_MEMMOVE
-#if defined(HAS_BCOPY) && defined(SAFE_BCOPY)
-#define memmove(d,s,l) bcopy(s,d,l)
-#else
-#if defined(HAS_MEMCPY) && defined(SAFE_MEMCPY)
-#define memmove(d,s,l) memcpy(d,s,l)
-#else
-#define memmove(d,s,l) my_bcopy(s,d,l)
-#endif
-#endif
+# if defined(HAS_BCOPY) && defined(SAFE_BCOPY)
+# define memmove(d,s,l) bcopy(s,d,l)
+# else
+# if defined(HAS_MEMCPY) && defined(SAFE_MEMCPY)
+# define memmove(d,s,l) memcpy(d,s,l)
+# else
+# define memmove(d,s,l) my_bcopy(s,d,l)
+# endif
+# endif
#endif
#ifndef _TYPES_ /* If types.h defines this it's easy. */
-#ifndef major /* Does everyone's types.h define this? */
-#include <sys/types.h>
-#endif
+# ifndef major /* Does everyone's types.h define this? */
+# include <sys/types.h>
+# endif
#endif
#ifdef I_NETINET_IN
-#include <netinet/in.h>
+# include <netinet/in.h>
#endif
#include <sys/stat.h>
+
#if defined(uts) || defined(UTekV)
-#undef S_ISDIR
-#undef S_ISCHR
-#undef S_ISBLK
-#undef S_ISREG
-#undef S_ISFIFO
-#undef S_ISLNK
-#define S_ISDIR(P) (((P)&S_IFMT)==S_IFDIR)
-#define S_ISCHR(P) (((P)&S_IFMT)==S_IFCHR)
-#define S_ISBLK(P) (((P)&S_IFMT)==S_IFBLK)
-#define S_ISREG(P) (((P)&S_IFMT)==S_IFREG)
-#define S_ISFIFO(P) (((P)&S_IFMT)==S_IFIFO)
-#ifdef S_IFLNK
-#define S_ISLNK(P) (((P)&S_IFMT)==S_IFLNK)
-#endif
+# undef S_ISDIR
+# undef S_ISCHR
+# undef S_ISBLK
+# undef S_ISREG
+# undef S_ISFIFO
+# undef S_ISLNK
+# define S_ISDIR(P) (((P)&S_IFMT)==S_IFDIR)
+# define S_ISCHR(P) (((P)&S_IFMT)==S_IFCHR)
+# define S_ISBLK(P) (((P)&S_IFMT)==S_IFBLK)
+# define S_ISREG(P) (((P)&S_IFMT)==S_IFREG)
+# define S_ISFIFO(P) (((P)&S_IFMT)==S_IFIFO)
+# ifdef S_IFLNK
+# define S_ISLNK(P) (((P)&S_IFMT)==S_IFLNK)
+# endif
#endif
#ifdef I_TIME
#endif
#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR))
-#undef HAS_STRERROR
+# undef HAS_STRERROR
#endif
#include <errno.h>
#ifndef MSDOS
-#ifndef errno
-extern int errno; /* ANSI allows errno to be an lvalue expr */
-#endif
+# ifndef errno
+ extern int errno; /* ANSI allows errno to be an lvalue expr */
+# endif
#endif
#ifndef strerror
-#ifdef HAS_STRERROR
-char *strerror();
-#else
-extern int sys_nerr;
-extern char *sys_errlist[];
-#define strerror(e) ((e) < 0 || (e) >= sys_nerr ? "(unknown)" : sys_errlist[e])
-#endif
+# ifdef HAS_STRERROR
+ char *strerror P((int));
+# else
+ extern int sys_nerr;
+ extern char *sys_errlist[];
+# define strerror(e) \
+ ((e) < 0 || (e) >= sys_nerr ? "(unknown)" : sys_errlist[e])
+# endif
#endif
#ifdef I_SYSIOCTL
-#ifndef _IOCTL_
-#include <sys/ioctl.h>
-#endif
+# ifndef _IOCTL_
+# include <sys/ioctl.h>
+# endif
#endif
#if defined(mc300) || defined(mc500) || defined(mc700) || defined(mc6000)
-#ifdef HAS_SOCKETPAIR
-#undef HAS_SOCKETPAIR
-#endif
-#ifdef HAS_NDBM
-#undef HAS_NDBM
-#endif
+# ifdef HAS_SOCKETPAIR
+# undef HAS_SOCKETPAIR
+# endif
+# ifdef HAS_NDBM
+# undef HAS_NDBM
+# endif
#endif
#ifdef WANT_DBZ
-#include <dbz.h>
-#define SOME_DBM
-#define dbm_fetch(db,dkey) fetch(dkey)
-#define dbm_delete(db,dkey) fatal("dbz doesn't implement delete")
-#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent)
-#define dbm_close(db) dbmclose()
-#define dbm_firstkey(db) (fatal("dbz doesn't implement traversal"),fetch())
-#define nextkey() (fatal("dbz doesn't implement traversal"),fetch())
-#define dbm_nextkey(db) (fatal("dbz doesn't implement traversal"),fetch())
-#ifdef HAS_NDBM
-#undef HAS_NDBM
-#endif
-#ifndef HAS_ODBM
-#define HAS_ODBM
-#endif
-#else
-#ifdef HAS_GDBM
-#ifdef I_GDBM
-#include <gdbm.h>
-#endif
-#define SOME_DBM
-#ifdef HAS_NDBM
-#undef HAS_NDBM
-#endif
-#ifdef HAS_ODBM
-#undef HAS_ODBM
-#endif
-#else
-#ifdef HAS_NDBM
-#include <ndbm.h>
-#define SOME_DBM
-#ifdef HAS_ODBM
-#undef HAS_ODBM
-#endif
+# include <dbz.h>
+# define SOME_DBM
+# define dbm_fetch(db,dkey) fetch(dkey)
+# define dbm_delete(db,dkey) fatal("dbz doesn't implement delete")
+# define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent)
+# define dbm_close(db) dbmclose()
+# define dbm_firstkey(db) (fatal("dbz doesn't implement traversal"),fetch())
+# define nextkey() (fatal("dbz doesn't implement traversal"),fetch())
+# define dbm_nextkey(db) (fatal("dbz doesn't implement traversal"),fetch())
+# ifdef HAS_NDBM
+# undef HAS_NDBM
+# endif
+# ifndef HAS_ODBM
+# define HAS_ODBM
+# endif
#else
-#ifdef HAS_ODBM
-#ifdef NULL
-#undef NULL /* suppress redefinition message */
-#endif
-#include <dbm.h>
-#ifdef NULL
-#undef NULL
-#endif
-#define NULL 0 /* silly thing is, we don't even use this */
-#define SOME_DBM
-#define dbm_fetch(db,dkey) fetch(dkey)
-#define dbm_delete(db,dkey) delete(dkey)
-#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent)
-#define dbm_close(db) dbmclose()
-#define dbm_firstkey(db) firstkey()
-#endif /* HAS_ODBM */
-#endif /* HAS_NDBM */
-#endif /* HAS_GDBM */
+# ifdef HAS_GDBM
+# ifdef I_GDBM
+# include <gdbm.h>
+# endif
+# define SOME_DBM
+# ifdef HAS_NDBM
+# undef HAS_NDBM
+# endif
+# ifdef HAS_ODBM
+# undef HAS_ODBM
+# endif
+# else
+# ifdef HAS_NDBM
+# include <ndbm.h>
+# define SOME_DBM
+# ifdef HAS_ODBM
+# undef HAS_ODBM
+# endif
+# else
+# ifdef HAS_ODBM
+# ifdef NULL
+# undef NULL /* suppress redefinition message */
+# endif
+# include <dbm.h>
+# ifdef NULL
+# undef NULL
+# endif
+# define NULL 0 /* silly thing is, we don't even use this... */
+# define SOME_DBM
+# define dbm_fetch(db,dkey) fetch(dkey)
+# define dbm_delete(db,dkey) delete(dkey)
+# define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent)
+# define dbm_close(db) dbmclose()
+# define dbm_firstkey(db) firstkey()
+# endif /* HAS_ODBM */
+# endif /* HAS_NDBM */
+# endif /* HAS_GDBM */
#endif /* WANT_DBZ */
-#ifdef SOME_DBM
-EXT char *dbmkey;
-EXT int dbmlen;
-#endif
#if INTSIZE == 2
-#define htoni htons
-#define ntohi ntohs
+# define htoni htons
+# define ntohi ntohs
#else
-#define htoni htonl
-#define ntohi ntohl
+# define htoni htonl
+# define ntohi ntohl
#endif
#if defined(I_DIRENT)
#ifdef FPUTS_BOTCH
/* work around botch in SunOS 4.0.1 and 4.0.2 */
# ifndef fputs
-# define fputs(str,fp) fprintf(fp,"%s",str)
+# define fputs(sv,fp) fprintf(fp,"%s",sv)
# endif
#endif
# define S_ISGID 02000
#endif
-#ifdef f_next
-#undef f_next
+#ifdef ff_next
+# undef ff_next
#endif
#if defined(cray) || defined(gould) || defined(i860)
# endif
#endif
+#ifdef VOIDSIG
+# define VOIDRET void
+#else
+# define VOIDRET int
+#endif
+
+#ifdef DOSISH
+# include "dosish.h"
+#else
+# include "unixish.h"
+#endif
+
+#ifndef HAS_PAUSE
+#define pause() sleep((32767<<16)+32767)
+#endif
+
+#ifndef IOCPARM_LEN
+# ifdef IOCPARM_MASK
+ /* on BSDish systes we're safe */
+# define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK)
+# else
+ /* otherwise guess at what's safe */
+# define IOCPARM_LEN(x) 256
+# endif
+#endif
+
typedef MEM_SIZE STRLEN;
-typedef struct arg ARG;
-typedef struct cmd CMD;
-typedef struct formcmd FCMD;
-typedef struct scanpat SPAT;
-typedef struct stio STIO;
-typedef struct sub SUBR;
-typedef struct string STR;
-typedef struct atbl ARRAY;
-typedef struct htbl HASH;
+typedef struct op OP;
+typedef struct cop COP;
+typedef struct unop UNOP;
+typedef struct binop BINOP;
+typedef struct listop LISTOP;
+typedef struct logop LOGOP;
+typedef struct condop CONDOP;
+typedef struct pmop PMOP;
+typedef struct svop SVOP;
+typedef struct gvop GVOP;
+typedef struct pvop PVOP;
+typedef struct cvop CVOP;
+typedef struct loop LOOP;
+
+typedef struct Outrec Outrec;
+typedef struct lstring Lstring;
+typedef struct interpreter Interpreter;
+typedef struct ff FF;
+typedef struct io IO;
+typedef struct sv SV;
+typedef struct av AV;
+typedef struct hv HV;
+typedef struct cv CV;
typedef struct regexp REGEXP;
-typedef struct stabptrs STBP;
-typedef struct stab STAB;
-typedef struct callsave CSV;
+typedef struct gp GP;
+typedef struct sv GV;
+typedef struct context CONTEXT;
+typedef struct block BLOCK;
+
+typedef struct magic MAGIC;
+typedef struct xpv XPV;
+typedef struct xpviv XPVIV;
+typedef struct xpvnv XPVNV;
+typedef struct xpvmg XPVMG;
+typedef struct xpvlv XPVLV;
+typedef struct xpvav XPVAV;
+typedef struct xpvhv XPVHV;
+typedef struct xpvgv XPVGV;
+typedef struct xpvcv XPVCV;
+typedef struct xpvbm XPVBM;
+typedef struct xpvfm XPVFM;
+typedef struct mgvtbl MGVTBL;
+typedef union any ANY;
#include "handy.h"
+union any {
+ void* any_ptr;
+ I32 any_i32;
+};
+
#include "regexp.h"
-#include "str.h"
+#include "sv.h"
#include "util.h"
#include "form.h"
-#include "stab.h"
-#include "spat.h"
-#include "arg.h"
-#include "cmd.h"
-#include "array.h"
-#include "hash.h"
+#include "gv.h"
+#include "cv.h"
+#include "opcode.h"
+#include "op.h"
+#include "cop.h"
+#include "av.h"
+#include "hv.h"
+#include "mg.h"
+#include "scope.h"
#if defined(iAPX286) || defined(M_I286) || defined(I80286)
# define I286
#endif
#ifndef STANDARD_C
-#ifdef CHARSPRINTF
- char *sprintf();
-#else
- int sprintf();
-#endif
-#endif
-
-EXT char *Yes INIT("1");
-EXT char *No INIT("");
-
-/* "gimme" values */
-
-/* Note: cmd.c assumes that it can use && to produce one of these values! */
-#define G_SCALAR 0
-#define G_ARRAY 1
-
-#ifdef CRIPPLED_CC
-int str_true();
-#else /* !CRIPPLED_CC */
-#define str_true(str) (Str = (str), \
- (Str->str_pok ? \
- ((*Str->str_ptr > '0' || \
- Str->str_cur > 1 || \
- (Str->str_cur && *Str->str_ptr != '0')) ? 1 : 0) \
- : \
- (Str->str_nok ? (Str->str_u.str_nval != 0.0) : 0 ) ))
-#endif /* CRIPPLED_CC */
-
-#ifdef DEBUGGING
-#define str_peek(str) (Str = (str), \
- (Str->str_pok ? \
- Str->str_ptr : \
- (Str->str_nok ? \
- (sprintf(tokenbuf,"num(%g)",Str->str_u.str_nval), \
- (char*)tokenbuf) : \
- "" )))
-#endif
-
-#ifdef CRIPPLED_CC
-char *str_get();
-#else
-#ifdef TAINT
-#define str_get(str) (Str = (str), tainted |= Str->str_tainted, \
- (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
-#else
-#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
-#endif /* TAINT */
-#endif /* CRIPPLED_CC */
-
-#ifdef CRIPPLED_CC
-double str_gnum();
-#else /* !CRIPPLED_CC */
-#ifdef TAINT
-#define str_gnum(str) (Str = (str), tainted |= Str->str_tainted, \
- (Str->str_nok ? Str->str_u.str_nval : str_2num(Str)))
-#else /* !TAINT */
-#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_u.str_nval : str_2num(Str)))
-#endif /* TAINT*/
-#endif /* CRIPPLED_CC */
-EXT STR *Str;
-
-#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
-
-#ifndef DOSISH
-#define STR_GROW(str,len) if ((str)->str_len < (len)) str_grow(str,len)
-#define Str_Grow str_grow
-#else
-/* extra parentheses intentionally NOT placed around "len"! */
-#define STR_GROW(str,len) if ((str)->str_len < (unsigned long)len) \
- str_grow(str,(unsigned long)len)
-#define Str_Grow(str,len) str_grow(str,(unsigned long)(len))
-#endif /* DOSISH */
-
-#ifndef BYTEORDER
-#define BYTEORDER 0x1234
+# ifdef CHARSPRINTF
+ char *sprintf P((char *, ...));
+# else
+ int sprintf P((char *, ...));
+# endif
#endif
#if defined(htonl) && !defined(HAS_HTONL)
#endif
#ifdef CASTNEGFLOAT
-#define U_S(what) ((unsigned short)(what))
+#define U_S(what) ((U16)(what))
#define U_I(what) ((unsigned int)(what))
-#define U_L(what) ((unsigned long)(what))
+#define U_L(what) ((U32)(what))
#else
-unsigned long castulong();
-#define U_S(what) ((unsigned int)castulong(what))
-#define U_I(what) ((unsigned int)castulong(what))
-#define U_L(what) (castulong(what))
-#endif
-
-CMD *add_label();
-CMD *block_head();
-CMD *append_line();
-CMD *make_acmd();
-CMD *make_ccmd();
-CMD *make_icmd();
-CMD *invert();
-CMD *addcond();
-CMD *addloop();
-CMD *wopt();
-CMD *over();
-
-STAB *stabent();
-STAB *genstab();
-
-ARG *stab2arg();
-ARG *op_new();
-ARG *make_op();
-ARG *make_match();
-ARG *make_split();
-ARG *rcatmaybe();
-ARG *listish();
-ARG *maybelistish();
-ARG *localize();
-ARG *fixeval();
-ARG *jmaybe();
-ARG *l();
-ARG *fixl();
-ARG *mod_match();
-ARG *make_list();
-ARG *cmd_to_arg();
-ARG *addflags();
-ARG *hide_ary();
-ARG *cval_to_arg();
-
-STR *str_new();
-STR *stab_str();
-
-int apply();
-int do_each();
-int do_subr();
-int do_match();
-int do_unpack();
-int eval(); /* this evaluates expressions */
-int do_eval(); /* this evaluates eval operator */
-int do_assign();
-
-SUBR *make_sub();
-
-FCMD *load_format();
-
-char *scanpat();
-char *scansubst();
-char *scantrans();
-char *scanstr();
-char *scanident();
-char *str_append_till();
-char *str_gets();
-char *str_grow();
-
-bool do_open();
-bool do_close();
-bool do_print();
-bool do_aprint();
-bool do_exec();
-bool do_aexec();
-
-int do_subst();
-int cando();
-int ingroup();
-int whichsig();
-int userinit();
-#ifdef CRYPTSCRIPT
-void cryptswitch();
-#endif
-
-void str_replace();
-void str_inc();
-void str_dec();
-void str_free();
-void cmd_free();
-void arg_free();
-void spat_free();
-void regfree();
-void stab_clear();
-void do_chop();
-void do_vop();
-void do_write();
-void do_join();
-void do_sprintf();
-void do_accept();
-void do_pipe();
-void do_vecset();
-void do_unshift();
-void do_execfree();
-void magicalize();
-void magicname();
-void savelist();
-void saveitem();
-void saveint();
-void savelong();
-void savesptr();
-void savehptr();
-void restorelist();
-void repeatcpy();
-void make_form();
-void dehoist();
-void format();
-void my_unexec();
-void fatal();
-void warn();
-#ifdef DEBUGGING
-void dump_all();
-void dump_cmd();
-void dump_arg();
-void dump_flags();
-void dump_stab();
-void dump_spat();
-#endif
-#ifdef MSTATS
-void mstats();
+U32 cast_ulong P((double));
+#define U_S(what) ((U16)cast_ulong(what))
+#define U_I(what) ((unsigned int)cast_ulong(what))
+#define U_L(what) (cast_ulong(what))
#endif
-HASH *savehash();
-ARRAY *saveary();
-
-EXT char **origargv;
-EXT int origargc;
-EXT char **origenviron;
-extern char **environ;
-
-EXT long subline INIT(0);
-EXT STR *subname INIT(Nullstr);
-EXT int arybase INIT(0);
-
-struct outrec {
- long o_lines;
+struct Outrec {
+ I32 o_lines;
char *o_str;
- int o_len;
+ U32 o_len;
};
-EXT struct outrec outrec;
-EXT struct outrec toprec;
-
-EXT STAB *stdinstab INIT(Nullstab);
-EXT STAB *last_in_stab INIT(Nullstab);
-EXT STAB *defstab INIT(Nullstab);
-EXT STAB *argvstab INIT(Nullstab);
-EXT STAB *envstab INIT(Nullstab);
-EXT STAB *sigstab INIT(Nullstab);
-EXT STAB *defoutstab INIT(Nullstab);
-EXT STAB *curoutstab INIT(Nullstab);
-EXT STAB *argvoutstab INIT(Nullstab);
-EXT STAB *incstab INIT(Nullstab);
-EXT STAB *leftstab INIT(Nullstab);
-EXT STAB *amperstab INIT(Nullstab);
-EXT STAB *rightstab INIT(Nullstab);
-EXT STAB *DBstab INIT(Nullstab);
-EXT STAB *DBline INIT(Nullstab);
-EXT STAB *DBsub INIT(Nullstab);
-
-EXT HASH *defstash; /* main symbol table */
-EXT HASH *curstash; /* symbol table for current package */
-EXT HASH *debstash; /* symbol table for perldb package */
-
-EXT STR *curstname; /* name of current package */
-
-EXT STR *freestrroot INIT(Nullstr);
-EXT STR *lastretstr INIT(Nullstr);
-EXT STR *DBsingle INIT(Nullstr);
-EXT STR *DBtrace INIT(Nullstr);
-EXT STR *DBsignal INIT(Nullstr);
-EXT STR *formfeed INIT(Nullstr);
-
-EXT int lastspbase;
-EXT int lastsize;
-
-EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEFx");
-EXT char *origfilename;
-EXT FILE * VOLATILE rsfp INIT(Nullfp);
-EXT char buf[1024];
-EXT char *bufptr;
-EXT char *oldbufptr;
-EXT char *oldoldbufptr;
-EXT char *bufend;
-
-EXT STR *linestr INIT(Nullstr);
-
-EXT char *rs INIT("\n");
-EXT int rschar INIT('\n'); /* final char of rs, or 0777 if none */
-EXT int rslen INIT(1);
-EXT bool rspara INIT(FALSE);
-EXT char *ofs INIT(Nullch);
-EXT int ofslen INIT(0);
-EXT char *ors INIT(Nullch);
-EXT int orslen INIT(0);
-EXT char *ofmt INIT(Nullch);
-EXT char *inplace INIT(Nullch);
-EXT char *nointrp INIT("");
-
-EXT bool preprocess INIT(FALSE);
-EXT bool minus_n INIT(FALSE);
-EXT bool minus_p INIT(FALSE);
-EXT bool minus_l INIT(FALSE);
-EXT bool minus_a INIT(FALSE);
-EXT bool doswitches INIT(FALSE);
-EXT bool dowarn INIT(FALSE);
-EXT bool doextract INIT(FALSE);
-EXT bool allstabs INIT(FALSE); /* init all customary symbols in symbol table?*/
-EXT bool sawampersand INIT(FALSE); /* must save all match strings */
-EXT bool sawstudy INIT(FALSE); /* do fbminstr on all strings */
-EXT bool sawi INIT(FALSE); /* study must assume case insensitive */
-EXT bool sawvec INIT(FALSE);
-EXT bool localizing INIT(FALSE); /* are we processing a local() list? */
-
#ifndef MAXSYSFD
# define MAXSYSFD 2
#endif
-EXT int maxsysfd INIT(MAXSYSFD); /* top fd to pass to subprocesses */
-
-#ifdef CSH
-EXT char *cshname INIT(CSH);
-EXT int cshlen INIT(0);
-#endif /* CSH */
-
-#ifdef TAINT
-EXT bool tainted INIT(FALSE); /* using variables controlled by $< */
-EXT bool taintanyway INIT(FALSE); /* force taint checks when !set?id */
-#endif
-
-EXT bool nomemok INIT(FALSE); /* let malloc context handle nomem */
#ifndef DOSISH
#define TMPPATH "/tmp/perl-eXXXXXX"
#else
#define TMPPATH "plXXXXXX"
#endif /* MSDOS */
-EXT char *e_tmpname;
-EXT FILE *e_fp INIT(Nullfp);
-
-EXT char tokenbuf[256];
-EXT int expectterm INIT(TRUE); /* how to interpret ambiguous tokens */
-EXT VOLATILE int in_eval INIT(FALSE); /* trap fatal errors? */
-EXT int multiline INIT(0); /* $*--do strings hold >1 line? */
-EXT int forkprocess; /* so do_open |- can return proc# */
-EXT int do_undump INIT(0); /* -u or dump seen? */
-EXT int error_count INIT(0); /* how many errors so far, max 10 */
-EXT int multi_start INIT(0); /* 1st line of multi-line string */
-EXT int multi_end INIT(0); /* last line of multi-line string */
-EXT int multi_open INIT(0); /* delimiter of said string */
-EXT int multi_close INIT(0); /* delimiter of said string */
-
-FILE *popen();
-/* char *str_get(); */
-STR *interp();
-void free_arg();
-STIO *stio_new();
-void hoistmust();
-void scanconst();
-
-EXT struct stat statbuf;
-EXT struct stat statcache;
-EXT STAB *statstab INIT(Nullstab);
-EXT STR *statname INIT(Nullstr);
-#ifndef MSDOS
-EXT struct tms timesbuf;
-#endif
-EXT int uid;
-EXT int euid;
-EXT int gid;
-EXT int egid;
-UIDTYPE getuid();
-UIDTYPE geteuid();
-GIDTYPE getgid();
-GIDTYPE getegid();
-EXT int unsafe;
+
+#ifndef __cplusplus
+UIDTYPE getuid P(());
+UIDTYPE geteuid P(());
+GIDTYPE getgid P(());
+GIDTYPE getegid P(());
+#endif
#ifdef DEBUGGING
-EXT VOLATILE int debug INIT(0);
-EXT int dlevel INIT(0);
-EXT int dlmax INIT(128);
-EXT char *debname;
-EXT char *debdelim;
#define YYDEBUG 1
+#define DEB(a) a
+#define DEBUG(a) if (debug) a
+#define DEBUG_p(a) if (debug & 1) a
+#define DEBUG_s(a) if (debug & 2) a
+#define DEBUG_l(a) if (debug & 4) a
+#define DEBUG_t(a) if (debug & 8) a
+#define DEBUG_o(a) if (debug & 16) a
+#define DEBUG_c(a) if (debug & 32) a
+#define DEBUG_P(a) if (debug & 64) a
+#define DEBUG_m(a) if (debug & 128) a
+#define DEBUG_f(a) if (debug & 256) a
+#define DEBUG_r(a) if (debug & 512) a
+#define DEBUG_x(a) if (debug & 1024) a
+#define DEBUG_u(a) if (debug & 2048) a
+#define DEBUG_L(a) if (debug & 4096) a
+#define DEBUG_H(a) if (debug & 8192) a
+#define DEBUG_X(a) if (debug & 16384) a
+#else
+#define DEB(a)
+#define DEBUG(a)
+#define DEBUG_p(a)
+#define DEBUG_s(a)
+#define DEBUG_l(a)
+#define DEBUG_t(a)
+#define DEBUG_o(a)
+#define DEBUG_c(a)
+#define DEBUG_P(a)
+#define DEBUG_m(a)
+#define DEBUG_f(a)
+#define DEBUG_r(a)
+#define DEBUG_x(a)
+#define DEBUG_u(a)
+#define DEBUG_L(a)
+#define DEBUG_H(a)
+#define DEBUG_X(a)
#endif
-EXT int perldb INIT(0);
#define YYMAXDEPTH 300
-EXT line_t cmdline INIT(NOLINE);
-
-EXT STR str_undef;
-EXT STR str_no;
-EXT STR str_yes;
-
-/* runtime control stuff */
-
-EXT struct loop {
- char *loop_label; /* what the loop was called, if anything */
- int loop_sp; /* stack pointer to copy stuff down to */
- jmp_buf loop_env;
-} *loop_stack;
-
-EXT int loop_ptr INIT(-1);
-EXT int loop_max INIT(128);
-
-EXT jmp_buf top_env;
-
-EXT char * VOLATILE goto_targ INIT(Nullch); /* cmd_exec gets strange when set */
+#define assert(what) DEB( { \
+ if (!(what)) { \
+ fatal("Assertion failed: file \"%s\", line %d", \
+ __FILE__, __LINE__); \
+ exit(1); \
+ }})
struct ufuncs {
- int (*uf_val)();
- int (*uf_set)();
- int uf_index;
+ I32 (*uf_val)P((I32, SV*));
+ I32 (*uf_set)P((I32, SV*));
+ I32 uf_index;
};
-EXT ARRAY *stack; /* THE STACK */
-
-EXT ARRAY * VOLATILE savestack; /* to save non-local values on */
-
-EXT ARRAY *tosave; /* strings to save on recursive subroutine */
-
-EXT ARRAY *lineary; /* lines of script for debugger */
-EXT ARRAY *dbargs; /* args to call listed by caller function */
-
-EXT ARRAY *fdpid; /* keep fd-to-pid mappings for mypopen */
-EXT HASH *pidstatus; /* keep pid-to-status mappings for waitpid */
-
-EXT int *di; /* for tmp use in debuggers */
-EXT char *dc;
-EXT short *ds;
-
/* Fix these up for __STDC__ */
-EXT time_t basetime INIT(0);
-char *mktemp();
+char *mktemp P((char*));
+double atof P((const char*));
+
#ifndef STANDARD_C
/* All of these are in stdlib.h or time.h for ANSI C */
-double atof();
long time();
struct tm *gmtime(), *localtime();
char *index(), *rindex();
char *strcpy(), *strcat();
#endif /* ! STANDARD_C */
+
+#ifdef I_MATH
+# include <math.h>
+#else
+# ifdef __cplusplus
+ extern "C" {
+# endif
+ double exp P((double));
+ double log P((double));
+ double sqrt P((double));
+ double modf P((double,int*));
+ double sin P((double));
+ double cos P((double));
+ double atan2 P((double,double));
+ double pow P((double,double));
+# ifdef __cplusplus
+ };
+# endif
+#endif
+
+
+char *crypt P((const char*, const char*));
+char *getenv P((const char*));
+long lseek P((int,int,int));
+char *getlogin P((void));
+
#ifdef EUNICE
#define UNLINK unlnk
-int unlnk();
+int unlnk P((char*));
#else
#define UNLINK unlink
#endif
#define SCAN_DEF 0
#define SCAN_TR 1
#define SCAN_REPL 2
+
+#ifdef DEBUGGING
+#define PAD_SV(po) pad_sv(po)
+#else
+#define PAD_SV(po) curpad[po]
+#endif
+
+/****************/
+/* Truly global */
+/****************/
+
+/* global state */
+EXT Interpreter *curinterp; /* currently running interpreter */
+extern char ** environ; /* environment variables supplied via exec */
+EXT int uid; /* current real user id */
+EXT int euid; /* current effective user id */
+EXT int gid; /* current real group id */
+EXT int egid; /* current effective group id */
+EXT bool nomemok; /* let malloc context handle nomem */
+EXT U32 an; /* malloc sequence number */
+EXT char ** origenviron;
+EXT U32 origalen;
+
+/* Stack for currently executing thread--context switch must handle this. */
+EXT SV ** stack_base; /* stack->array_ary */
+EXT SV ** stack_sp; /* stack pointer now */
+EXT SV ** stack_max; /* stack->array_ary + stack->array_max */
+
+/* likewise for these */
+
+EXT OP * op; /* current op--oughta be in a global register */
+
+EXT I32 * scopestack; /* blocks we've entered */
+EXT I32 scopestack_ix;
+EXT I32 scopestack_max;
+
+EXT ANY* savestack; /* to save non-local values on */
+EXT I32 savestack_ix;
+EXT I32 savestack_max;
+
+EXT OP ** retstack; /* returns we've pushed */
+EXT I32 retstack_ix;
+EXT I32 retstack_max;
+
+EXT I32 * markstack; /* stackmarks we're remembering */
+EXT I32 * markstack_ptr; /* stackmarks we're remembering */
+EXT I32 * markstack_max; /* stackmarks we're remembering */
+
+EXT SV ** curpad;
+
+/* temp space */
+EXT SV * Sv;
+EXT XPV * Xpv;
+EXT char buf[1024];
+EXT char tokenbuf[256];
+EXT struct stat statbuf;
+#ifndef MSDOS
+EXT struct tms timesbuf;
+#endif
+
+/* for tmp use in stupid debuggers */
+EXT int * di;
+EXT short * ds;
+EXT char * dc;
+
+/* handy constants */
+EXT char * Yes INIT("1");
+EXT char * No INIT("");
+EXT char * hexdigit INIT("0123456789abcdef0123456789ABCDEFx");
+EXT char * warn_nl INIT("Unsuccessful %s on filename containing newline");
+EXT char no_modify[] INIT("Modification of a read-only value attempted");
+EXT char no_mem[] INIT("Out of memory!\n");
+EXT char no_security[] INIT("Insecure dependency in %s");
+EXT char no_sock_func[]
+ INIT("Unsupported socket function \"%s\" called");
+EXT char no_dir_func[]
+ INIT("Unsupported directory function \"%s\" called");
+EXT char no_func[] INIT("The %s function is unimplemented");
+EXT char * patleave INIT("\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}");
+EXT char * vert INIT("|");
+
+EXT SV sv_undef;
+EXT SV sv_no;
+EXT SV sv_yes;
+#ifdef CSH
+ EXT char * cshname INIT(CSH);
+ EXT I32 cshlen;
+#endif
+
+#ifdef DOINIT
+EXT char *sig_name[] = {
+ SIG_NAME,0
+};
+#else
+EXT char *sig_name[];
+#endif
+
+#ifdef DOINIT
+ EXT char coeff[] = { /* hash function coefficients */
+ 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
+ EXT char coeff[];
+#endif
+
+#ifdef DOINIT
+EXT unsigned char fold[] = { /* fast case folding table */
+ 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
+};
+#else
+EXT unsigned char fold[];
+#endif
+
+#ifdef DOINIT
+EXT unsigned char freq[] = { /* letter frequencies for mixed English/C */
+ 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
+};
+#else
+EXT unsigned char freq[];
+#endif
+
+/*****************************************************************************/
+/* This lexer/parser stuff is currently global since yacc is hard to reenter */
+/*****************************************************************************/
+
+typedef enum {
+ XOPERATOR,
+ XTERM,
+ XBLOCK,
+ XREF,
+} expectation;
+
+EXT FILE * VOL rsfp INIT(Nullfp);
+EXT SV * linestr;
+EXT char * bufptr;
+EXT char * oldbufptr;
+EXT char * oldoldbufptr;
+EXT char * bufend;
+EXT expectation expect INIT(XBLOCK); /* how to interpret ambiguous tokens */
+
+EXT I32 multi_start; /* 1st line of multi-line string */
+EXT I32 multi_end; /* last line of multi-line string */
+EXT I32 multi_open; /* delimiter of said string */
+EXT I32 multi_close; /* delimiter of said string */
+
+EXT GV * scrgv;
+EXT I32 error_count; /* how many errors so far, max 10 */
+EXT I32 subline; /* line this subroutine began on */
+EXT SV * subname; /* name of current subroutine */
+
+EXT AV * pad; /* storage for lexically scoped temporaries */
+EXT AV * comppad; /* same for currently compiling routine */
+EXT I32 padix; /* max used index in current "register" pad */
+EXT COP compiling;
+
+EXT SV * evstr; /* op_fold_const() temp string cache */
+EXT I32 thisexpr; /* name id for nothing_in_common() */
+EXT char * last_uni; /* position of last named-unary operator */
+EXT char * last_lop; /* position of last list operator */
+EXT bool in_format; /* we're compiling a run_format */
+#ifdef FCRYPT
+EXT I32 cryptseen; /* has fast crypt() been initialized? */
+#endif
+
+/**************************************************************************/
+/* This regexp stuff is global since it always happens within 1 expr eval */
+/**************************************************************************/
+
+EXT char * regprecomp; /* uncompiled string. */
+EXT char * regparse; /* Input-scan pointer. */
+EXT char * regxend; /* End of input for compile */
+EXT I32 regnpar; /* () count. */
+EXT char * regcode; /* Code-emit pointer; ®dummy = don't. */
+EXT I32 regsize; /* Code size. */
+EXT I32 regfold; /* are we folding? */
+EXT I32 regsawbracket; /* Did we do {d,d} trick? */
+EXT I32 regsawback; /* Did we see \1, ...? */
+
+EXT char * reginput; /* String-input pointer. */
+EXT char regprev; /* char before regbol, \n if none */
+EXT char * regbol; /* Beginning of input, for ^ check. */
+EXT char * regeol; /* End of input, for $ check. */
+EXT char ** regstartp; /* Pointer to startp array. */
+EXT char ** regendp; /* Ditto for endp. */
+EXT char * reglastparen; /* Similarly for lastparen. */
+EXT char * regtill; /* How far we are required to go. */
+EXT I32 regmyp_size;
+EXT char ** regmystartp;
+EXT char ** regmyendp;
+
+/***********************************************/
+/* Global only to current interpreter instance */
+/***********************************************/
+
+#ifdef EMBEDDED
+#define IEXT
+#define IINIT(x)
+struct interpreter {
+#else
+#define IEXT EXT
+#define IINIT(x) INIT(x)
+#endif
+
+/* pseudo environmental stuff */
+IEXT int Iorigargc;
+IEXT char ** Iorigargv;
+IEXT GV * Ienvgv;
+IEXT GV * Isiggv;
+IEXT GV * Iincgv;
+IEXT char * Iorigfilename;
+
+/* switches */
+IEXT char * Icddir;
+IEXT bool Iminus_c;
+IEXT char Ipatchlevel[6];
+IEXT char * Inrs IINIT("\n");
+IEXT U32 Inrschar IINIT('\n'); /* final char of rs, or 0777 if none */
+IEXT I32 Inrslen IINIT(1);
+IEXT bool Ipreprocess;
+IEXT bool Iminus_n;
+IEXT bool Iminus_p;
+IEXT bool Iminus_l;
+IEXT bool Iminus_a;
+IEXT bool Idoswitches;
+IEXT bool Idowarn;
+IEXT bool Idoextract;
+IEXT bool Iallgvs; /* init all customary symbols in symbol table?*/
+IEXT bool Isawampersand; /* must save all match strings */
+IEXT bool Isawstudy; /* do fbm_instr on all strings */
+IEXT bool Isawi; /* study must assume case insensitive */
+IEXT bool Isawvec;
+IEXT bool Iunsafe;
+IEXT bool Ido_undump; /* -u or dump seen? */
+IEXT char * Iinplace;
+IEXT char * Ie_tmpname;
+IEXT FILE * Ie_fp;
+IEXT VOL U32 Idebug;
+IEXT U32 Iperldb;
+
+/* magical thingies */
+IEXT time_t Ibasetime; /* $^T */
+IEXT I32 Iarybase; /* $[ */
+IEXT SV * Iformfeed; /* $^L */
+IEXT char * Ichopset IINIT(" \n-"); /* $: */
+IEXT char * Irs IINIT("\n"); /* $/ */
+IEXT U32 Irschar IINIT('\n'); /* final char of rs, or 0777 if none */
+IEXT I32 Irslen IINIT(1);
+IEXT bool Irspara;
+IEXT char * Iofs; /* $, */
+IEXT I32 Iofslen;
+IEXT char * Iors; /* $\ */
+IEXT I32 Iorslen;
+IEXT char * Iofmt; /* $# */
+IEXT I32 Imaxsysfd IINIT(MAXSYSFD); /* top fd to pass to subprocesses */
+IEXT int Imultiline; /* $*--do strings hold >1 line? */
+IEXT U16 Istatusvalue; /* $? */
+
+IEXT struct stat Istatcache; /* _ */
+IEXT GV * Istatgv;
+IEXT SV * Istatname IINIT(Nullsv);
+
+/* shortcuts to various I/O objects */
+IEXT GV * Istdingv;
+IEXT GV * Ilast_in_gv;
+IEXT GV * Idefgv;
+IEXT GV * Iargvgv;
+IEXT GV * Idefoutgv;
+IEXT GV * Icuroutgv;
+IEXT GV * Iargvoutgv;
+
+/* shortcuts to regexp stuff */
+IEXT GV * Ileftgv;
+IEXT GV * Iampergv;
+IEXT GV * Irightgv;
+IEXT PMOP * Icurpm; /* what to do \ interps from */
+IEXT char * Ihint; /* hint from cop_exec to do_match et al */
+IEXT I32 * Iscreamfirst;
+IEXT I32 * Iscreamnext;
+IEXT I32 Imaxscream IINIT(-1);
+IEXT SV * Ilastscream;
+
+/* shortcuts to debugging objects */
+IEXT GV * IDBgv;
+IEXT GV * IDBline;
+IEXT GV * IDBsub;
+IEXT SV * IDBsingle;
+IEXT SV * IDBtrace;
+IEXT SV * IDBsignal;
+IEXT AV * Ilineary; /* lines of script for debugger */
+IEXT AV * Idbargs; /* args to call listed by caller function */
+
+/* symbol tables */
+IEXT HV * Idefstash; /* main symbol table */
+IEXT HV * Icurstash; /* symbol table for current package */
+IEXT HV * Idebstash; /* symbol table for perldb package */
+IEXT SV * Icurstname; /* name of current package */
+
+/* memory management */
+IEXT SV * Ifreestrroot;
+IEXT SV ** Itmps_stack;
+IEXT I32 Itmps_ix IINIT(-1);
+IEXT I32 Itmps_floor IINIT(-1);
+IEXT I32 Itmps_max IINIT(-1);
+
+/* funky return mechanisms */
+IEXT I32 Ilastspbase;
+IEXT I32 Ilastsize;
+IEXT int Iforkprocess; /* so do_open |- can return proc# */
+
+/* subprocess state */
+IEXT AV * Ifdpid; /* keep fd-to-pid mappings for my_popen */
+IEXT HV * Ipidstatus; /* keep pid-to-status mappings for waitpid */
+
+/* internal state */
+IEXT VOL int Iin_eval; /* trap fatal errors? */
+IEXT OP * Irestartop; /* Are we propagating an error from fatal? */
+IEXT int Idelaymagic; /* ($<,$>) = ... */
+IEXT bool Idirty; /* clean before rerunning */
+IEXT bool Ilocalizing; /* are we processing a local() list? */
+#ifdef TAINT
+IEXT bool Itainted; /* using variables controlled by $< */
+IEXT bool Itaintanyway; /* force taint checks when !set?id */
+#endif
+
+/* trace state */
+IEXT I32 Idlevel;
+IEXT I32 Idlmax IINIT(128);
+IEXT char * Idebname;
+IEXT char * Idebdelim;
+
+/* current interpreter roots */
+IEXT OP * VOL Imain_root;
+IEXT OP * VOL Imain_start;
+IEXT OP * VOL Ieval_root;
+IEXT OP * VOL Ieval_start;
+IEXT OP * Ilast_root;
+IEXT char * Ilast_eval;
+IEXT I32 Ilast_elen;
+
+/* runtime control stuff */
+IEXT COP * VOL Icurcop IINIT(&compiling);
+IEXT line_t Icopline IINIT(NOLINE);
+IEXT CONTEXT * Icxstack;
+IEXT I32 Icxstack_ix IINIT(-1);
+IEXT I32 Icxstack_max IINIT(128);
+IEXT jmp_buf Itop_env;
+
+/* stack stuff */
+IEXT AV * Istack; /* THE STACK */
+IEXT AV * Imainstack; /* the stack when nothing funny is happening */
+IEXT SV ** Imystack_base; /* stack->array_ary */
+IEXT SV ** Imystack_sp; /* stack pointer now */
+IEXT SV ** Imystack_max; /* stack->array_ary + stack->array_max */
+
+/* format accumulators */
+IEXT SV * formtarget;
+IEXT SV * bodytarget;
+IEXT SV * toptarget;
+
+/* statics moved here for shared library purposes */
+IEXT SV Istrchop; /* return value from chop */
+IEXT int Ifilemode; /* so nextargv() can preserve mode */
+IEXT int Ilastfd; /* what to preserve mode on */
+IEXT char * Ioldname; /* what to preserve mode on */
+IEXT char ** IArgv; /* stuff to free from do_aexec, vfork safe */
+IEXT char * ICmd; /* stuff to free from do_aexec, vfork safe */
+IEXT OP * Isortcop; /* user defined sort routine */
+IEXT HV * Isortstash; /* which is in some package or other */
+IEXT GV * Ifirstgv; /* $a */
+IEXT GV * Isecondgv; /* $b */
+IEXT AV * Isortstack; /* temp stack during pp_sort() */
+IEXT AV * Isignalstack; /* temp stack during sighandler() */
+IEXT SV * Imystrk; /* temp key string for do_each() */
+IEXT I32 Idumplvl; /* indentation level on syntax tree dump */
+IEXT I32 Idbmrefcnt; /* safety check for old dbm */
+IEXT PMOP * Ioldlastpm; /* for saving regexp context during debugger */
+IEXT I32 Igensym; /* next symbol for getsym() to define */
+IEXT bool Ipreambled;
+IEXT int Ilaststatval IINIT(-1);
+IEXT I32 Ilaststype IINIT(OP_STAT);
+
+#undef IEXT
+#undef IINIT
+
+#ifdef EMBEDDED
+};
+#else
+struct interpreter {
+ char broiled;
+};
+#endif
+
+#include "pp.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include "proto.h"
+
+#ifdef __cplusplus
+};
+#endif
+
+/* The follow must follow proto.h */
+
+#ifdef DOINIT
+MGVTBL vtbl_sv = {magic_get, magic_set, 0, 0, 0};
+MGVTBL vtbl_env = {0, 0, 0, 0, 0};
+MGVTBL vtbl_envelem = {0, magic_setenv, 0, 0, 0};
+MGVTBL vtbl_sig = {0, 0, 0, 0, 0};
+MGVTBL vtbl_sigelem = {0, magic_setsig, 0, 0, 0};
+MGVTBL vtbl_dbm = {0, 0, 0, 0, 0};
+MGVTBL vtbl_dbmelem = {0, magic_setdbm, 0, 0, 0};
+MGVTBL vtbl_dbline = {0, magic_setdbline, 0, 0, 0};
+MGVTBL vtbl_arylen = {magic_getarylen,magic_setarylen, 0, 0, 0};
+MGVTBL vtbl_glob = {magic_getglob, magic_setglob, 0, 0, 0};
+MGVTBL vtbl_substr = {0, magic_setsubstr, 0, 0, 0};
+MGVTBL vtbl_vec = {0, magic_setvec, 0, 0, 0};
+MGVTBL vtbl_bm = {0, magic_setbm, 0, 0, 0};
+MGVTBL vtbl_uvar = {magic_getuvar, magic_setuvar, 0, 0, 0};
+#else
+EXT MGVTBL vtbl_sv;
+EXT MGVTBL vtbl_env;
+EXT MGVTBL vtbl_envelem;
+EXT MGVTBL vtbl_sig;
+EXT MGVTBL vtbl_sigelem;
+EXT MGVTBL vtbl_dbm;
+EXT MGVTBL vtbl_dbmelem;
+EXT MGVTBL vtbl_dbline;
+EXT MGVTBL vtbl_arylen;
+EXT MGVTBL vtbl_glob;
+EXT MGVTBL vtbl_substr;
+EXT MGVTBL vtbl_vec;
+EXT MGVTBL vtbl_bm;
+EXT MGVTBL vtbl_uvar;
+#endif
+++ /dev/null
-/* $RCSfile: perl.h,v $$Revision: 4.0.1.6 $$Date: 92/06/08 14:55:10 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: perl.h,v $
- * Revision 4.0.1.6 92/06/08 14:55:10 lwall
- * patch20: added Atari ST portability
- * patch20: bcopy() and memcpy() now tested for overlap safety
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- * patch20: removed implicit int declarations on functions
- *
- * Revision 4.0.1.5 91/11/11 16:41:07 lwall
- * patch19: uts wrongly defines S_ISDIR() et al
- * patch19: too many preprocessors can't expand a macro right in #if
- * patch19: added little-endian pack/unpack options
- *
- * Revision 4.0.1.4 91/11/05 18:06:10 lwall
- * patch11: various portability fixes
- * patch11: added support for dbz
- * patch11: added some support for 64-bit integers
- * patch11: hex() didn't understand leading 0x
- *
- * Revision 4.0.1.3 91/06/10 01:25:10 lwall
- * patch10: certain pattern optimizations were botched
- *
- * Revision 4.0.1.2 91/06/07 11:28:33 lwall
- * patch4: new copyright notice
- * patch4: made some allowances for "semi-standard" C
- * patch4: many, many itty-bitty portability fixes
- *
- * Revision 4.0.1.1 91/04/11 17:49:51 lwall
- * patch1: hopefully straightened out some of the Xenix mess
- *
- * Revision 4.0 91/03/20 01:37:56 lwall
- * 4.0 baseline.
- *
- */
-
-#define VOIDWANT 1
-#include "config.h"
-
-#ifdef MYMALLOC
-# ifdef HIDEMYMALLOC
-# define malloc Mymalloc
-# define realloc Myremalloc
-# define free Myfree
-# endif
-# define safemalloc malloc
-# define saferealloc realloc
-# define safefree free
-#endif
-
-/* work around some libPW problems */
-#define fatal Myfatal
-#ifdef DOINIT
-char Error[1];
-#endif
-
-/* define this once if either system, instead of cluttering up the src */
-#if defined(MSDOS) || defined(atarist)
-#define DOSISH 1
-#endif
-
-#ifdef DOSISH
-/* This stuff now in the MS-DOS config.h file. */
-#else /* !MSDOS */
-
-/*
- * The following symbols are defined if your operating system supports
- * functions by that name. All Unixes I know of support them, thus they
- * are not checked by the configuration script, but are directly defined
- * here.
- */
-#define HAS_ALARM
-#define HAS_CHOWN
-#define HAS_CHROOT
-#define HAS_FORK
-#define HAS_GETLOGIN
-#define HAS_GETPPID
-#define HAS_KILL
-#define HAS_LINK
-#define HAS_PIPE
-#define HAS_WAIT
-#define HAS_UMASK
-/*
- * The following symbols are defined if your operating system supports
- * password and group functions in general. All Unix systems do.
- */
-#define HAS_GROUP
-#define HAS_PASSWD
-
-#endif /* !MSDOS */
-
-#if defined(__STDC__) || defined(_AIX) || defined(__stdc__)
-# define STANDARD_C 1
-#endif
-
-#if defined(HASVOLATILE) || defined(STANDARD_C)
-#define VOLATILE volatile
-#else
-#define VOLATILE
-#endif
-
-#ifdef IAMSUID
-# ifndef TAINT
-# define TAINT
-# endif
-#endif
-
-#ifndef HAS_VFORK
-# define vfork fork
-#endif
-
-#ifdef HAS_GETPGRP2
-# ifndef HAS_GETPGRP
-# define HAS_GETPGRP
-# endif
-# define getpgrp getpgrp2
-#endif
-
-#ifdef HAS_SETPGRP2
-# ifndef HAS_SETPGRP
-# define HAS_SETPGRP
-# endif
-# define setpgrp setpgrp2
-#endif
-
-#include <stdio.h>
-#include <ctype.h>
-#include <setjmp.h>
-#ifndef MSDOS
-#ifdef PARAM_NEEDS_TYPES
-#include <sys/types.h>
-#endif
-#include <sys/param.h>
-#endif
-#ifdef STANDARD_C
-/* Use all the "standard" definitions */
-#include <stdlib.h>
-#include <string.h>
-#define MEM_SIZE size_t
-#else
-typedef unsigned int MEM_SIZE;
-#endif /* STANDARD_C */
-
-#if defined(HAS_MEMCMP) && defined(mips) && defined(ultrix)
-#undef HAS_MEMCMP
-#endif
-
-#ifdef HAS_MEMCPY
-# ifndef STANDARD_C
-# ifndef memcpy
- extern char * memcpy();
-# endif
-# endif
-#else
-# ifndef memcpy
-# ifdef HAS_BCOPY
-# define memcpy(d,s,l) bcopy(s,d,l)
-# else
-# define memcpy(d,s,l) my_bcopy(s,d,l)
-# endif
-# endif
-#endif /* HAS_MEMCPY */
-
-#ifdef HAS_MEMSET
-# ifndef STANDARD_C
-# ifndef memset
- extern char *memset();
-# endif
-# endif
-# define memzero(d,l) memset(d,0,l)
-#else
-# ifndef memzero
-# ifdef HAS_BZERO
-# define memzero(d,l) bzero(d,l)
-# else
-# define memzero(d,l) my_bzero(d,l)
-# endif
-# endif
-#endif /* HAS_MEMSET */
-
-#ifdef HAS_MEMCMP
-# ifndef STANDARD_C
-# ifndef memcmp
- extern int memcmp();
-# endif
-# endif
-#else
-# ifndef memcmp
-# define memcmp(s1,s2,l) my_memcmp(s1,s2,l)
-# endif
-#endif /* HAS_MEMCMP */
-
-/* we prefer bcmp slightly for comparisons that don't care about ordering */
-#ifndef HAS_BCMP
-# ifndef bcmp
-# define bcmp(s1,s2,l) memcmp(s1,s2,l)
-# endif
-#endif /* HAS_BCMP */
-
-#ifndef HAS_MEMMOVE
-#if defined(HAS_BCOPY) && defined(SAFE_BCOPY)
-#define memmove(d,s,l) bcopy(s,d,l)
-#else
-#if defined(HAS_MEMCPY) && defined(SAFE_MEMCPY)
-#define memmove(d,s,l) memcpy(d,s,l)
-#else
-#define memmove(d,s,l) my_bcopy(s,d,l)
-#endif
-#endif
-#endif
-
-#ifndef _TYPES_ /* If types.h defines this it's easy. */
-#ifndef major /* Does everyone's types.h define this? */
-#include <sys/types.h>
-#endif
-#endif
-
-#ifdef I_NETINET_IN
-#include <netinet/in.h>
-#endif
-
-#include <sys/stat.h>
-#if defined(uts) || defined(UTekV)
-#undef S_ISDIR
-#undef S_ISCHR
-#undef S_ISBLK
-#undef S_ISREG
-#undef S_ISFIFO
-#undef S_ISLNK
-#define S_ISDIR(P) (((P)&S_IFMT)==S_IFDIR)
-#define S_ISCHR(P) (((P)&S_IFMT)==S_IFCHR)
-#define S_ISBLK(P) (((P)&S_IFMT)==S_IFBLK)
-#define S_ISREG(P) (((P)&S_IFMT)==S_IFREG)
-#define S_ISFIFO(P) (((P)&S_IFMT)==S_IFIFO)
-#ifdef S_IFLNK
-#define S_ISLNK(P) (((P)&S_IFMT)==S_IFLNK)
-#endif
-#endif
-
-#ifdef I_TIME
-# include <time.h>
-#endif
-
-#ifdef I_SYS_TIME
-# ifdef SYSTIMEKERNEL
-# define KERNEL
-# endif
-# include <sys/time.h>
-# ifdef SYSTIMEKERNEL
-# undef KERNEL
-# endif
-#endif
-
-#ifndef MSDOS
-#include <sys/times.h>
-#endif
-
-#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR))
-#undef HAS_STRERROR
-#endif
-
-#include <errno.h>
-#ifndef MSDOS
-#ifndef errno
-extern int errno; /* ANSI allows errno to be an lvalue expr */
-#endif
-#endif
-
-#ifndef strerror
-#ifdef HAS_STRERROR
-char *strerror();
-#else
-extern int sys_nerr;
-extern char *sys_errlist[];
-#define strerror(e) ((e) < 0 || (e) >= sys_nerr ? "(unknown)" : sys_errlist[e])
-#endif
-#endif
-
-#ifdef I_SYSIOCTL
-#ifndef _IOCTL_
-#include <sys/ioctl.h>
-#endif
-#endif
-
-#if defined(mc300) || defined(mc500) || defined(mc700) || defined(mc6000)
-#ifdef HAS_SOCKETPAIR
-#undef HAS_SOCKETPAIR
-#endif
-#ifdef HAS_NDBM
-#undef HAS_NDBM
-#endif
-#endif
-
-#ifdef WANT_DBZ
-#include <dbz.h>
-#define SOME_DBM
-#define dbm_fetch(db,dkey) fetch(dkey)
-#define dbm_delete(db,dkey) fatal("dbz doesn't implement delete")
-#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent)
-#define dbm_close(db) dbmclose()
-#define dbm_firstkey(db) (fatal("dbz doesn't implement traversal"),fetch())
-#define nextkey() (fatal("dbz doesn't implement traversal"),fetch())
-#define dbm_nextkey(db) (fatal("dbz doesn't implement traversal"),fetch())
-#ifdef HAS_NDBM
-#undef HAS_NDBM
-#endif
-#ifndef HAS_ODBM
-#define HAS_ODBM
-#endif
-#else
-#ifdef HAS_GDBM
-#ifdef I_GDBM
-#include <gdbm.h>
-#endif
-#define SOME_DBM
-#ifdef HAS_NDBM
-#undef HAS_NDBM
-#endif
-#ifdef HAS_ODBM
-#undef HAS_ODBM
-#endif
-#else
-#ifdef HAS_NDBM
-#include <ndbm.h>
-#define SOME_DBM
-#ifdef HAS_ODBM
-#undef HAS_ODBM
-#endif
-#else
-#ifdef HAS_ODBM
-#ifdef NULL
-#undef NULL /* suppress redefinition message */
-#endif
-#include <dbm.h>
-#ifdef NULL
-#undef NULL
-#endif
-#define NULL 0 /* silly thing is, we don't even use this */
-#define SOME_DBM
-#define dbm_fetch(db,dkey) fetch(dkey)
-#define dbm_delete(db,dkey) delete(dkey)
-#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent)
-#define dbm_close(db) dbmclose()
-#define dbm_firstkey(db) firstkey()
-#endif /* HAS_ODBM */
-#endif /* HAS_NDBM */
-#endif /* HAS_GDBM */
-#endif /* WANT_DBZ */
-#ifdef SOME_DBM
-EXT char *dbmkey;
-EXT int dbmlen;
-#endif
-
-#if INTSIZE == 2
-#define htoni htons
-#define ntohi ntohs
-#else
-#define htoni htonl
-#define ntohi ntohl
-#endif
-
-#if defined(I_DIRENT)
-# include <dirent.h>
-# define DIRENT dirent
-#else
-# ifdef I_SYS_NDIR
-# include <sys/ndir.h>
-# define DIRENT direct
-# else
-# ifdef I_SYS_DIR
-# ifdef hp9000s500
-# include <ndir.h> /* may be wrong in the future */
-# else
-# include <sys/dir.h>
-# endif
-# define DIRENT direct
-# endif
-# endif
-#endif
-
-#ifdef FPUTS_BOTCH
-/* work around botch in SunOS 4.0.1 and 4.0.2 */
-# ifndef fputs
-# define fputs(str,fp) fprintf(fp,"%s",str)
-# endif
-#endif
-
-/*
- * The following gobbledygook brought to you on behalf of __STDC__.
- * (I could just use #ifndef __STDC__, but this is more bulletproof
- * in the face of half-implementations.)
- */
-
-#ifndef S_IFMT
-# ifdef _S_IFMT
-# define S_IFMT _S_IFMT
-# else
-# define S_IFMT 0170000
-# endif
-#endif
-
-#ifndef S_ISDIR
-# define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR)
-#endif
-
-#ifndef S_ISCHR
-# define S_ISCHR(m) ((m & S_IFMT) == S_IFCHR)
-#endif
-
-#ifndef S_ISBLK
-# ifdef S_IFBLK
-# define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK)
-# else
-# define S_ISBLK(m) (0)
-# endif
-#endif
-
-#ifndef S_ISREG
-# define S_ISREG(m) ((m & S_IFMT) == S_IFREG)
-#endif
-
-#ifndef S_ISFIFO
-# ifdef S_IFIFO
-# define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO)
-# else
-# define S_ISFIFO(m) (0)
-# endif
-#endif
-
-#ifndef S_ISLNK
-# ifdef _S_ISLNK
-# define S_ISLNK(m) _S_ISLNK(m)
-# else
-# ifdef _S_IFLNK
-# define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK)
-# else
-# ifdef S_IFLNK
-# define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK)
-# else
-# define S_ISLNK(m) (0)
-# endif
-# endif
-# endif
-#endif
-
-#ifndef S_ISSOCK
-# ifdef _S_ISSOCK
-# define S_ISSOCK(m) _S_ISSOCK(m)
-# else
-# ifdef _S_IFSOCK
-# define S_ISSOCK(m) ((m & S_IFMT) == _S_IFSOCK)
-# else
-# ifdef S_IFSOCK
-# define S_ISSOCK(m) ((m & S_IFMT) == S_IFSOCK)
-# else
-# define S_ISSOCK(m) (0)
-# endif
-# endif
-# endif
-#endif
-
-#ifndef S_IRUSR
-# ifdef S_IREAD
-# define S_IRUSR S_IREAD
-# define S_IWUSR S_IWRITE
-# define S_IXUSR S_IEXEC
-# else
-# define S_IRUSR 0400
-# define S_IWUSR 0200
-# define S_IXUSR 0100
-# endif
-# define S_IRGRP (S_IRUSR>>3)
-# define S_IWGRP (S_IWUSR>>3)
-# define S_IXGRP (S_IXUSR>>3)
-# define S_IROTH (S_IRUSR>>6)
-# define S_IWOTH (S_IWUSR>>6)
-# define S_IXOTH (S_IXUSR>>6)
-#endif
-
-#ifndef S_ISUID
-# define S_ISUID 04000
-#endif
-
-#ifndef S_ISGID
-# define S_ISGID 02000
-#endif
-
-#ifdef f_next
-#undef f_next
-#endif
-
-#if defined(cray) || defined(gould) || defined(i860)
-# define SLOPPYDIVIDE
-#endif
-
-#if defined(cray) || defined(convex) || defined (uts) || BYTEORDER > 0xffff
-# define QUAD
-#endif
-
-#ifdef QUAD
-# ifdef cray
-# define quad int
-# else
-# if defined(convex) || defined (uts)
-# define quad long long
-# else
-# define quad long
-# endif
-# endif
-#endif
-
-typedef MEM_SIZE STRLEN;
-
-typedef struct arg ARG;
-typedef struct cmd CMD;
-typedef struct formcmd FCMD;
-typedef struct scanpat SPAT;
-typedef struct stio STIO;
-typedef struct sub SUBR;
-typedef struct string STR;
-typedef struct atbl ARRAY;
-typedef struct htbl HASH;
-typedef struct regexp REGEXP;
-typedef struct stabptrs STBP;
-typedef struct stab STAB;
-typedef struct callsave CSV;
-
-#include "handy.h"
-#include "regexp.h"
-#include "str.h"
-#include "util.h"
-#include "form.h"
-#include "stab.h"
-#include "spat.h"
-#include "arg.h"
-#include "cmd.h"
-#include "array.h"
-#include "hash.h"
-
-#if defined(iAPX286) || defined(M_I286) || defined(I80286)
-# define I286
-#endif
-
-#ifndef STANDARD_C
-#ifdef CHARSPRINTF
- char *sprintf();
-#else
- int sprintf();
-#endif
-#endif
-
-EXT char *Yes INIT("1");
-EXT char *No INIT("");
-
-/* "gimme" values */
-
-/* Note: cmd.c assumes that it can use && to produce one of these values! */
-#define G_SCALAR 0
-#define G_ARRAY 1
-
-#ifdef CRIPPLED_CC
-int str_true();
-#else /* !CRIPPLED_CC */
-#define str_true(str) (Str = (str), \
- (Str->str_pok ? \
- ((*Str->str_ptr > '0' || \
- Str->str_cur > 1 || \
- (Str->str_cur && *Str->str_ptr != '0')) ? 1 : 0) \
- : \
- (Str->str_nok ? (Str->str_u.str_nval != 0.0) : 0 ) ))
-#endif /* CRIPPLED_CC */
-
-#ifdef DEBUGGING
-#define str_peek(str) (Str = (str), \
- (Str->str_pok ? \
- Str->str_ptr : \
- (Str->str_nok ? \
- (sprintf(tokenbuf,"num(%g)",Str->str_u.str_nval), \
- (char*)tokenbuf) : \
- "" )))
-#endif
-
-#ifdef CRIPPLED_CC
-char *str_get();
-#else
-#ifdef TAINT
-#define str_get(str) (Str = (str), tainted |= Str->str_tainted, \
- (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
-#else
-#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
-#endif /* TAINT */
-#endif /* CRIPPLED_CC */
-
-#ifdef CRIPPLED_CC
-double str_gnum();
-#else /* !CRIPPLED_CC */
-#ifdef TAINT
-#define str_gnum(str) (Str = (str), tainted |= Str->str_tainted, \
- (Str->str_nok ? Str->str_u.str_nval : str_2num(Str)))
-#else /* !TAINT */
-#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_u.str_nval : str_2num(Str)))
-#endif /* TAINT*/
-#endif /* CRIPPLED_CC */
-EXT STR *Str;
-
-#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
-
-#ifndef DOSISH
-#define STR_GROW(str,len) if ((str)->str_len < (len)) str_grow(str,len)
-#define Str_Grow str_grow
-#else
-/* extra parentheses intentionally NOT placed around "len"! */
-#define STR_GROW(str,len) if ((str)->str_len < (unsigned long)len) \
- str_grow(str,(unsigned long)len)
-#define Str_Grow(str,len) str_grow(str,(unsigned long)(len))
-#endif /* DOSISH */
-
-#ifndef BYTEORDER
-#define BYTEORDER 0x1234
-#endif
-
-#if defined(htonl) && !defined(HAS_HTONL)
-#define HAS_HTONL
-#endif
-#if defined(htons) && !defined(HAS_HTONS)
-#define HAS_HTONS
-#endif
-#if defined(ntohl) && !defined(HAS_NTOHL)
-#define HAS_NTOHL
-#endif
-#if defined(ntohs) && !defined(HAS_NTOHS)
-#define HAS_NTOHS
-#endif
-#ifndef HAS_HTONL
-#if (BYTEORDER & 0xffff) != 0x4321
-#define HAS_HTONS
-#define HAS_HTONL
-#define HAS_NTOHS
-#define HAS_NTOHL
-#define MYSWAP
-#define htons my_swap
-#define htonl my_htonl
-#define ntohs my_swap
-#define ntohl my_ntohl
-#endif
-#else
-#if (BYTEORDER & 0xffff) == 0x4321
-#undef HAS_HTONS
-#undef HAS_HTONL
-#undef HAS_NTOHS
-#undef HAS_NTOHL
-#endif
-#endif
-
-/*
- * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
- * -DWS
- */
-#if BYTEORDER != 0x1234
-# define HAS_VTOHL
-# define HAS_VTOHS
-# define HAS_HTOVL
-# define HAS_HTOVS
-# if BYTEORDER == 0x4321
-# define vtohl(x) ((((x)&0xFF)<<24) \
- +(((x)>>24)&0xFF) \
- +(((x)&0x0000FF00)<<8) \
- +(((x)&0x00FF0000)>>8) )
-# define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF))
-# define htovl(x) vtohl(x)
-# define htovs(x) vtohs(x)
-# endif
- /* otherwise default to functions in util.c */
-#endif
-
-#ifdef CASTNEGFLOAT
-#define U_S(what) ((unsigned short)(what))
-#define U_I(what) ((unsigned int)(what))
-#define U_L(what) ((unsigned long)(what))
-#else
-unsigned long castulong();
-#define U_S(what) ((unsigned int)castulong(what))
-#define U_I(what) ((unsigned int)castulong(what))
-#define U_L(what) (castulong(what))
-#endif
-
-CMD *add_label();
-CMD *block_head();
-CMD *append_line();
-CMD *make_acmd();
-CMD *make_ccmd();
-CMD *make_icmd();
-CMD *invert();
-CMD *addcond();
-CMD *addloop();
-CMD *wopt();
-CMD *over();
-
-STAB *stabent();
-STAB *genstab();
-
-ARG *stab2arg();
-ARG *op_new();
-ARG *make_op();
-ARG *make_match();
-ARG *make_split();
-ARG *rcatmaybe();
-ARG *listish();
-ARG *maybelistish();
-ARG *localize();
-ARG *fixeval();
-ARG *jmaybe();
-ARG *l();
-ARG *fixl();
-ARG *mod_match();
-ARG *make_list();
-ARG *cmd_to_arg();
-ARG *addflags();
-ARG *hide_ary();
-ARG *cval_to_arg();
-
-STR *str_new();
-STR *stab_str();
-
-int apply();
-int do_each();
-int do_subr();
-int do_match();
-int do_unpack();
-int eval(); /* this evaluates expressions */
-int do_eval(); /* this evaluates eval operator */
-int do_assign();
-
-SUBR *make_sub();
-
-FCMD *load_format();
-
-char *scanpat();
-char *scansubst();
-char *scantrans();
-char *scanstr();
-char *scanident();
-char *str_append_till();
-char *str_gets();
-char *str_grow();
-
-bool do_open();
-bool do_close();
-bool do_print();
-bool do_aprint();
-bool do_exec();
-bool do_aexec();
-
-int do_subst();
-int cando();
-int ingroup();
-int whichsig();
-int userinit();
-#ifdef CRYPTSCRIPT
-void cryptswitch();
-#endif
-
-void str_replace();
-void str_inc();
-void str_dec();
-void str_free();
-void cmd_free();
-void arg_free();
-void spat_free();
-void regfree();
-void stab_clear();
-void do_chop();
-void do_vop();
-void do_write();
-void do_join();
-void do_sprintf();
-void do_accept();
-void do_pipe();
-void do_vecset();
-void do_unshift();
-void do_execfree();
-void magicalize();
-void magicname();
-void savelist();
-void saveitem();
-void saveint();
-void savelong();
-void savesptr();
-void savehptr();
-void restorelist();
-void repeatcpy();
-void make_form();
-void dehoist();
-void format();
-void my_unexec();
-void fatal();
-void warn();
-#ifdef DEBUGGING
-void dump_all();
-void dump_cmd();
-void dump_arg();
-void dump_flags();
-void dump_stab();
-void dump_spat();
-#endif
-#ifdef MSTATS
-void mstats();
-#endif
-
-HASH *savehash();
-ARRAY *saveary();
-
-EXT char **origargv;
-EXT int origargc;
-EXT char **origenviron;
-extern char **environ;
-
-EXT long subline INIT(0);
-EXT STR *subname INIT(Nullstr);
-EXT int arybase INIT(0);
-
-struct outrec {
- long o_lines;
- char *o_str;
- int o_len;
-};
-
-EXT struct outrec outrec;
-EXT struct outrec toprec;
-
-EXT STAB *stdinstab INIT(Nullstab);
-EXT STAB *last_in_stab INIT(Nullstab);
-EXT STAB *defstab INIT(Nullstab);
-EXT STAB *argvstab INIT(Nullstab);
-EXT STAB *envstab INIT(Nullstab);
-EXT STAB *sigstab INIT(Nullstab);
-EXT STAB *defoutstab INIT(Nullstab);
-EXT STAB *curoutstab INIT(Nullstab);
-EXT STAB *argvoutstab INIT(Nullstab);
-EXT STAB *incstab INIT(Nullstab);
-EXT STAB *leftstab INIT(Nullstab);
-EXT STAB *amperstab INIT(Nullstab);
-EXT STAB *rightstab INIT(Nullstab);
-EXT STAB *DBstab INIT(Nullstab);
-EXT STAB *DBline INIT(Nullstab);
-EXT STAB *DBsub INIT(Nullstab);
-
-EXT HASH *defstash; /* main symbol table */
-EXT HASH *curstash; /* symbol table for current package */
-EXT HASH *debstash; /* symbol table for perldb package */
-
-EXT STR *curstname; /* name of current package */
-
-EXT STR *freestrroot INIT(Nullstr);
-EXT STR *lastretstr INIT(Nullstr);
-EXT STR *DBsingle INIT(Nullstr);
-EXT STR *DBtrace INIT(Nullstr);
-EXT STR *DBsignal INIT(Nullstr);
-EXT STR *formfeed INIT(Nullstr);
-
-EXT int lastspbase;
-EXT int lastsize;
-
-EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEFx");
-EXT char *origfilename;
-EXT FILE * VOLATILE rsfp;
-EXT char buf[1024];
-EXT char *bufptr;
-EXT char *oldbufptr;
-EXT char *oldoldbufptr;
-EXT char *bufend;
-
-EXT STR *linestr INIT(Nullstr);
-
-EXT char *rs INIT("\n");
-EXT int rschar INIT('\n'); /* final char of rs, or 0777 if none */
-EXT int rslen INIT(1);
-EXT bool rspara INIT(FALSE);
-EXT char *ofs INIT(Nullch);
-EXT int ofslen INIT(0);
-EXT char *ors INIT(Nullch);
-EXT int orslen INIT(0);
-EXT char *ofmt INIT(Nullch);
-EXT char *inplace INIT(Nullch);
-EXT char *nointrp INIT("");
-
-EXT bool preprocess INIT(FALSE);
-EXT bool minus_n INIT(FALSE);
-EXT bool minus_p INIT(FALSE);
-EXT bool minus_l INIT(FALSE);
-EXT bool minus_a INIT(FALSE);
-EXT bool doswitches INIT(FALSE);
-EXT bool dowarn INIT(FALSE);
-EXT bool doextract INIT(FALSE);
-EXT bool allstabs INIT(FALSE); /* init all customary symbols in symbol table?*/
-EXT bool sawampersand INIT(FALSE); /* must save all match strings */
-EXT bool sawstudy INIT(FALSE); /* do fbminstr on all strings */
-EXT bool sawi INIT(FALSE); /* study must assume case insensitive */
-EXT bool sawvec INIT(FALSE);
-EXT bool localizing INIT(FALSE); /* are we processing a local() list? */
-
-#ifndef MAXSYSFD
-# define MAXSYSFD 2
-#endif
-EXT int maxsysfd INIT(MAXSYSFD); /* top fd to pass to subprocesses */
-
-#ifdef CSH
-EXT char *cshname INIT(CSH);
-EXT int cshlen INIT(0);
-#endif /* CSH */
-
-#ifdef TAINT
-EXT bool tainted INIT(FALSE); /* using variables controlled by $< */
-EXT bool taintanyway INIT(FALSE); /* force taint checks when !set?id */
-#endif
-
-EXT bool nomemok INIT(FALSE); /* let malloc context handle nomem */
-
-#ifndef DOSISH
-#define TMPPATH "/tmp/perl-eXXXXXX"
-#else
-#define TMPPATH "plXXXXXX"
-#endif /* MSDOS */
-EXT char *e_tmpname;
-EXT FILE *e_fp INIT(Nullfp);
-
-EXT char tokenbuf[256];
-EXT int expectterm INIT(TRUE); /* how to interpret ambiguous tokens */
-EXT VOLATILE int in_eval INIT(FALSE); /* trap fatal errors? */
-EXT int multiline INIT(0); /* $*--do strings hold >1 line? */
-EXT int forkprocess; /* so do_open |- can return proc# */
-EXT int do_undump INIT(0); /* -u or dump seen? */
-EXT int error_count INIT(0); /* how many errors so far, max 10 */
-EXT int multi_start INIT(0); /* 1st line of multi-line string */
-EXT int multi_end INIT(0); /* last line of multi-line string */
-EXT int multi_open INIT(0); /* delimiter of said string */
-EXT int multi_close INIT(0); /* delimiter of said string */
-
-FILE *popen();
-/* char *str_get(); */
-STR *interp();
-void free_arg();
-STIO *stio_new();
-void hoistmust();
-void scanconst();
-
-EXT struct stat statbuf;
-EXT struct stat statcache;
-EXT STAB *statstab INIT(Nullstab);
-EXT STR *statname;
-#ifndef MSDOS
-EXT struct tms timesbuf;
-#endif
-EXT int uid;
-EXT int euid;
-EXT int gid;
-EXT int egid;
-UIDTYPE getuid();
-UIDTYPE geteuid();
-GIDTYPE getgid();
-GIDTYPE getegid();
-EXT int unsafe;
-
-#ifdef DEBUGGING
-EXT VOLATILE int debug INIT(0);
-EXT int dlevel INIT(0);
-EXT int dlmax INIT(128);
-EXT char *debname;
-EXT char *debdelim;
-#define YYDEBUG 1
-#endif
-EXT int perldb INIT(0);
-#define YYMAXDEPTH 300
-
-EXT line_t cmdline INIT(NOLINE);
-
-EXT STR str_undef;
-EXT STR str_no;
-EXT STR str_yes;
-
-/* runtime control stuff */
-
-EXT struct loop {
- char *loop_label; /* what the loop was called, if anything */
- int loop_sp; /* stack pointer to copy stuff down to */
- jmp_buf loop_env;
-} *loop_stack;
-
-EXT int loop_ptr INIT(-1);
-EXT int loop_max INIT(128);
-
-EXT jmp_buf top_env;
-
-EXT char * VOLATILE goto_targ INIT(Nullch); /* cmd_exec gets strange when set */
-
-struct ufuncs {
- int (*uf_val)();
- int (*uf_set)();
- int uf_index;
-};
-
-EXT ARRAY *stack; /* THE STACK */
-
-EXT ARRAY * VOLATILE savestack; /* to save non-local values on */
-
-EXT ARRAY *tosave; /* strings to save on recursive subroutine */
-
-EXT ARRAY *lineary; /* lines of script for debugger */
-EXT ARRAY *dbargs; /* args to call listed by caller function */
-
-EXT ARRAY *fdpid; /* keep fd-to-pid mappings for mypopen */
-EXT HASH *pidstatus; /* keep pid-to-status mappings for waitpid */
-
-EXT int *di; /* for tmp use in debuggers */
-EXT char *dc;
-EXT short *ds;
-
-/* Fix these up for __STDC__ */
-EXT time_t basetime INIT(0);
-char *mktemp();
-#ifndef STANDARD_C
-/* All of these are in stdlib.h or time.h for ANSI C */
-double atof();
-long time();
-struct tm *gmtime(), *localtime();
-char *index(), *rindex();
-char *strcpy(), *strcat();
-#endif /* ! STANDARD_C */
-
-#ifdef EUNICE
-#define UNLINK unlnk
-int unlnk();
-#else
-#define UNLINK unlink
-#endif
-
-#ifndef HAS_SETREUID
-#ifdef HAS_SETRESUID
-#define setreuid(r,e) setresuid(r,e,-1)
-#define HAS_SETREUID
-#endif
-#endif
-#ifndef HAS_SETREGID
-#ifdef HAS_SETRESGID
-#define setregid(r,e) setresgid(r,e,-1)
-#define HAS_SETREGID
-#endif
-#endif
-
-#define SCAN_DEF 0
-#define SCAN_TR 1
-#define SCAN_REPL 2
+++ /dev/null
-***************
-*** 1,4 ****
-! /* $RCSfile: perl.h,v $$Revision: 4.0.1.6 $$Date: 1992/06/08 14:55:10 $
- *
- * Copyright (c) 1991, Larry Wall
- *
---- 1,4 ----
-! /* $RCSfile: perl.h,v $$Revision: 4.0.1.7 $$Date: 1993/02/05 19:40:30 $
- *
- * Copyright (c) 1991, Larry Wall
- *
-***************
-*** 6,17 ****
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: perl.h,v $
-! * Revision 4.0.1.6 1992/06/08 14:55:10 lwall
- * patch20: added Atari ST portability
- * patch20: bcopy() and memcpy() now tested for overlap safety
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- * patch20: removed implicit int declarations on functions
-! *
- * Revision 4.0.1.5 91/11/11 16:41:07 lwall
- * patch19: uts wrongly defines S_ISDIR() et al
- * patch19: too many preprocessors can't expand a macro right in #if
---- 6,20 ----
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: perl.h,v $
-! * Revision 4.0.1.7 1993/02/05 19:40:30 lwall
-! * patch36: worked around certain busted compilers that don't init statics right
-! *
-! * Revision 4.0.1.6 92/06/08 14:55:10 lwall
- * patch20: added Atari ST portability
- * patch20: bcopy() and memcpy() now tested for overlap safety
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- * patch20: removed implicit int declarations on functions
-! *
- * Revision 4.0.1.5 91/11/11 16:41:07 lwall
- * patch19: uts wrongly defines S_ISDIR() et al
- * patch19: too many preprocessors can't expand a macro right in #if
.rn '' }`
-''' $RCSfile: perl.man,v $$Revision: 4.0.1.6 $$Date: 92/06/08 15:07:29 $
+''' $RCSfile: perl.man,v $$Revision: 4.1 $$Date: 92/08/07 18:25:59 $
'''
''' $Log: perl.man,v $
+''' Revision 4.1 92/08/07 18:25:59 lwall
+'''
''' Revision 4.0.1.6 92/06/08 15:07:29 lwall
''' patch20: documented that numbers may contain underline
''' patch20: clarified that DATA may only be read from main script
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.
+Closes the file or pipe associated with the file handle, returning true only
+if stdio successfully flushes buffers and closes the system file descriptor.
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
.fi
.Ip "fork" 8 4
-Does a fork() call.
-Returns the child pid to the parent process and 0 to the child process.
+Does a fork() system call.
+Returns the child pid to the parent process and 0 to the child process,
+or undef if the fork is unsuccessful.
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 "keys ASSOC_ARRAY" 8
Returns a normal array consisting of all the keys of the named associative
array.
+(In a scalar context, returns the number of keys.)
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).
}
.fi
-but is more efficient.
+but is more efficient. Returns the new number of elements in the array.
.Ip "q/STRING/" 8 5
.Ip "qq/STRING/" 8
.Ip "qx/STRING/" 8
semid_ds structure or semaphore value array. Returns like ioctl: the
undefined value for error, "0 but true" for zero, or the actual return
value otherwise.
-.Ip "semget(KEY,NSEMS,SIZE,FLAGS)" 8 4
+.Ip "semget(KEY,NSEMS,FLAGS)" 8 4
Calls the System V IPC function semget. Returns the semaphore id, or
the undefined value if there is an error.
.Ip "semop(KEY,OPSTRING)" 8 4
$checksum %= 65536;
.fi
+The following efficiently counts the number of set bits in a bit vector:
+.nf
+
+ $setbits = unpack("%32b*", $selectmask);
+
+.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.
+Prepends list to the front of the array, and returns the new number of elements
+in the array.
.nf
unshift(ARGV, \'\-e\') unless $ARGV[0] =~ /^\-/;
.fi
+Note the LIST is prepended whole, not one element at a time, so the prepended
+elements stay in the same order. Use reverse to do the reverse.
.Ip "utime(LIST)" 8 2
.Ip "utime LIST" 8 2
Changes the access and modification times on each file of a list of files.
.Ip "values ASSOC_ARRAY" 8
Returns a normal array consisting of all the values of the named associative
array.
+(In a scalar context, returns the number of values.)
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().
--- /dev/null
+extern char *malloc(), *realloc();
+
+# line 39 "perly.y"
+#include "EXTERN.h"
+#include "perl.h"
+
+/*SUPPRESS 530*/
+/*SUPPRESS 593*/
+/*SUPPRESS 595*/
+
+
+# line 50 "perly.y"
+typedef union {
+ I32 ival;
+ char *pval;
+ OP *opval;
+ GV *gvval;
+} YYSTYPE;
+# define WORD 257
+# define METHOD 258
+# define THING 259
+# define PMFUNC 260
+# define LABEL 261
+# define FORMAT 262
+# define SUB 263
+# define PACKAGE 264
+# define WHILE 265
+# define UNTIL 266
+# define IF 267
+# define UNLESS 268
+# define ELSE 269
+# define ELSIF 270
+# define CONTINUE 271
+# define FOR 272
+# define LOOPEX 273
+# define DOTDOT 274
+# define FUNC0 275
+# define FUNC1 276
+# define FUNC 277
+# define RELOP 278
+# define EQOP 279
+# define MULOP 280
+# define ADDOP 281
+# define DOLSHARP 282
+# define DO 283
+# define LOCAL 284
+# define DELETE 285
+# define HASHBRACK 286
+# define LSTOP 287
+# define OROR 288
+# define ANDAND 289
+# define BITOROP 290
+# define BITANDOP 291
+# define UNIOP 292
+# define SHIFTOP 293
+# define MATCHOP 294
+# define ARROW 295
+# define UMINUS 296
+# define REFGEN 297
+# define POWOP 298
+# define PREINC 299
+# define PREDEC 300
+# define POSTINC 301
+# define POSTDEC 302
+#define yyclearin yychar = -1
+#define yyerrok yyerrflag = 0
+extern int yychar;
+extern int yyerrflag;
+#ifndef YYMAXDEPTH
+#define YYMAXDEPTH 150
+#endif
+YYSTYPE yylval, yyval;
+# define YYERRCODE 256
+
+# line 569 "perly.y"
+ /* PROGRAM */
+int yyexca[] ={
+-1, 1,
+ 0, -1,
+ -2, 0,
+-1, 3,
+ 0, 2,
+ -2, 39,
+-1, 21,
+ 295, 145,
+ -2, 25,
+-1, 40,
+ 41, 97,
+ 265, 97,
+ 266, 97,
+ 267, 97,
+ 268, 97,
+ 274, 97,
+ 278, 97,
+ 279, 97,
+ 280, 97,
+ 281, 97,
+ 44, 97,
+ 61, 97,
+ 63, 97,
+ 58, 97,
+ 288, 97,
+ 289, 97,
+ 290, 97,
+ 291, 97,
+ 293, 97,
+ 294, 97,
+ 295, 97,
+ 298, 97,
+ 301, 97,
+ 302, 97,
+ 59, 97,
+ 93, 97,
+ -2, 144,
+-1, 54,
+ 41, 133,
+ 265, 133,
+ 266, 133,
+ 267, 133,
+ 268, 133,
+ 274, 133,
+ 278, 133,
+ 279, 133,
+ 280, 133,
+ 281, 133,
+ 44, 133,
+ 61, 133,
+ 63, 133,
+ 58, 133,
+ 288, 133,
+ 289, 133,
+ 290, 133,
+ 291, 133,
+ 293, 133,
+ 294, 133,
+ 295, 133,
+ 298, 133,
+ 301, 133,
+ 302, 133,
+ 59, 133,
+ 93, 133,
+ -2, 143,
+-1, 76,
+ 59, 35,
+ -2, 0,
+-1, 112,
+ 301, 0,
+ 302, 0,
+ -2, 88,
+-1, 113,
+ 301, 0,
+ 302, 0,
+ -2, 89,
+-1, 192,
+ 278, 0,
+ -2, 71,
+-1, 193,
+ 279, 0,
+ -2, 72,
+-1, 194,
+ 274, 0,
+ -2, 75,
+-1, 310,
+ 41, 35,
+ -2, 0,
+ };
+# define YYNPROD 152
+# define YYLAST 2258
+int yyact[]={
+
+ 107, 162, 104, 105, 90, 102, 229, 103, 148, 90,
+ 21, 239, 67, 104, 105, 150, 228, 91, 25, 72,
+ 74, 240, 241, 80, 82, 78, 91, 92, 56, 31,
+ 26, 102, 56, 58, 61, 90, 37, 132, 57, 30,
+ 102, 29, 69, 68, 90, 244, 115, 117, 119, 129,
+ 98, 133, 91, 92, 324, 16, 155, 77, 91, 92,
+ 59, 14, 11, 12, 13, 93, 102, 152, 87, 153,
+ 90, 93, 102, 157, 317, 159, 90, 315, 198, 164,
+ 156, 166, 158, 168, 298, 161, 297, 38, 165, 296,
+ 167, 262, 169, 170, 171, 172, 202, 210, 26, 200,
+ 268, 215, 123, 220, 31, 81, 87, 56, 58, 61,
+ 199, 37, 121, 57, 30, 26, 29, 87, 258, 26,
+ 79, 203, 32, 73, 3, 310, 98, 99, 91, 92,
+ 211, 212, 213, 214, 124, 59, 218, 98, 99, 91,
+ 92, 93, 102, 71, 122, 223, 90, 97, 96, 95,
+ 94, 237, 93, 102, 121, 316, 154, 90, 87, 70,
+ 87, 87, 38, 87, 66, 87, 295, 31, 87, 235,
+ 56, 58, 61, 318, 37, 299, 57, 30, 293, 29,
+ 243, 14, 11, 12, 13, 327, 122, 325, 26, 98,
+ 99, 91, 92, 87, 26, 204, 87, 32, 59, 320,
+ 96, 95, 94, 26, 93, 102, 26, 255, 256, 90,
+ 292, 266, 259, 174, 265, 232, 87, 234, 314, 304,
+ 98, 99, 91, 92, 267, 38, 26, 323, 271, 273,
+ 87, 264, 281, 94, 282, 93, 102, 284, 278, 286,
+ 90, 287, 263, 289, 206, 197, 156, 56, 202, 139,
+ 207, 200, 24, 54, 65, 46, 53, 26, 231, 221,
+ 32, 18, 19, 22, 23, 209, 56, 294, 20, 49,
+ 126, 51, 52, 63, 288, 280, 254, 300, 60, 48,
+ 36, 45, 39, 62, 308, 101, 219, 160, 50, 85,
+ 86, 83, 84, 33, 285, 34, 35, 312, 311, 274,
+ 242, 313, 87, 87, 238, 233, 31, 87, 87, 56,
+ 58, 61, 322, 37, 272, 57, 30, 149, 29, 25,
+ 85, 86, 83, 84, 326, 201, 328, 24, 54, 65,
+ 46, 53, 56, 137, 136, 135, 76, 59, 329, 306,
+ 307, 127, 309, 8, 49, 7, 51, 52, 63, 163,
+ 2, 9, 55, 60, 48, 36, 45, 39, 62, 17,
+ 47, 41, 44, 50, 38, 42, 321, 43, 33, 31,
+ 34, 35, 56, 58, 61, 15, 37, 270, 57, 30,
+ 10, 29, 5, 208, 205, 88, 6, 4, 147, 1,
+ 0, 54, 65, 46, 53, 0, 26, 0, 0, 32,
+ 59, 0, 0, 0, 0, 0, 0, 49, 0, 51,
+ 52, 63, 0, 0, 0, 28, 60, 48, 36, 45,
+ 39, 62, 0, 0, 0, 0, 50, 38, 0, 150,
+ 0, 33, 31, 34, 35, 56, 58, 61, 0, 37,
+ 0, 57, 30, 0, 29, 106, 108, 109, 110, 111,
+ 112, 113, 98, 99, 91, 92, 0, 0, 261, 26,
+ 0, 0, 32, 59, 95, 94, 0, 93, 102, 0,
+ 0, 0, 90, 0, 0, 0, 31, 0, 0, 56,
+ 58, 61, 0, 37, 0, 57, 30, 236, 29, 0,
+ 38, 0, 0, 0, 0, 0, 100, 0, 0, 0,
+ 98, 99, 91, 92, 0, 0, 0, 59, 0, 0,
+ 97, 96, 95, 94, 0, 93, 102, 0, 0, 0,
+ 90, 275, 26, 0, 276, 32, 0, 0, 0, 0,
+ 54, 65, 46, 53, 38, 225, 260, 0, 227, 0,
+ 230, 89, 0, 101, 269, 0, 49, 0, 51, 52,
+ 63, 0, 0, 0, 0, 60, 48, 36, 45, 39,
+ 62, 283, 0, 0, 0, 50, 26, 0, 0, 32,
+ 33, 31, 34, 35, 56, 58, 61, 0, 37, 257,
+ 57, 30, 0, 29, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 54, 65, 46, 53, 301, 0, 302,
+ 0, 0, 59, 0, 0, 0, 0, 0, 0, 49,
+ 0, 51, 52, 63, 0, 277, 0, 279, 60, 48,
+ 36, 45, 39, 62, 319, 0, 0, 0, 50, 38,
+ 0, 0, 0, 33, 0, 34, 35, 0, 0, 0,
+ 0, 0, 0, 291, 89, 0, 101, 0, 0, 0,
+ 0, 64, 0, 0, 0, 0, 54, 65, 46, 53,
+ 0, 26, 0, 0, 32, 0, 0, 0, 0, 305,
+ 0, 0, 49, 0, 51, 52, 63, 0, 0, 0,
+ 0, 60, 48, 36, 45, 39, 62, 89, 0, 101,
+ 0, 50, 0, 0, 0, 0, 33, 0, 34, 35,
+ 54, 65, 46, 53, 0, 0, 0, 0, 138, 141,
+ 142, 143, 144, 145, 146, 0, 49, 151, 51, 52,
+ 63, 0, 0, 0, 0, 60, 48, 36, 45, 39,
+ 62, 0, 0, 0, 0, 50, 0, 0, 0, 0,
+ 33, 31, 34, 35, 56, 58, 61, 0, 37, 222,
+ 57, 30, 0, 29, 100, 0, 0, 0, 98, 99,
+ 91, 92, 0, 0, 0, 0, 0, 0, 97, 96,
+ 95, 94, 59, 93, 102, 0, 0, 0, 90, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 54, 65, 46, 53, 38,
+ 0, 226, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 49, 0, 51, 52, 63, 0, 0, 0, 0,
+ 60, 48, 36, 45, 39, 62, 0, 0, 0, 0,
+ 50, 26, 0, 0, 32, 33, 31, 34, 35, 56,
+ 58, 61, 0, 37, 217, 57, 30, 0, 29, 0,
+ 0, 0, 0, 0, 0, 0, 0, 100, 0, 0,
+ 0, 98, 99, 91, 92, 0, 0, 59, 0, 0,
+ 0, 97, 96, 95, 94, 0, 93, 102, 0, 0,
+ 31, 90, 0, 56, 58, 61, 0, 37, 0, 57,
+ 30, 0, 29, 0, 38, 0, 0, 0, 0, 0,
+ 100, 0, 0, 0, 98, 99, 91, 92, 190, 0,
+ 0, 59, 0, 0, 97, 96, 95, 94, 0, 93,
+ 102, 0, 0, 0, 90, 0, 26, 0, 0, 32,
+ 31, 0, 0, 56, 58, 61, 0, 37, 38, 57,
+ 30, 0, 29, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 188, 0,
+ 0, 59, 0, 0, 0, 54, 65, 46, 53, 0,
+ 26, 0, 0, 32, 0, 0, 0, 0, 0, 0,
+ 0, 49, 0, 51, 52, 63, 0, 0, 38, 0,
+ 60, 48, 36, 45, 39, 62, 0, 0, 0, 0,
+ 50, 0, 0, 0, 0, 33, 31, 34, 35, 56,
+ 58, 61, 0, 37, 0, 57, 30, 0, 29, 0,
+ 26, 0, 0, 32, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 186, 0, 0, 59, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 54, 65, 46, 53, 38, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 0, 51, 52,
+ 63, 0, 0, 0, 0, 60, 48, 36, 45, 39,
+ 62, 0, 0, 0, 0, 50, 26, 0, 0, 32,
+ 33, 0, 34, 35, 54, 65, 46, 53, 0, 31,
+ 0, 0, 56, 58, 61, 0, 37, 0, 57, 30,
+ 49, 29, 51, 52, 63, 0, 0, 0, 0, 60,
+ 48, 36, 45, 39, 62, 0, 0, 184, 0, 50,
+ 59, 0, 0, 0, 33, 0, 34, 35, 0, 0,
+ 0, 0, 0, 0, 54, 65, 46, 53, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 38, 0, 0,
+ 49, 0, 51, 52, 63, 0, 0, 0, 0, 60,
+ 48, 36, 45, 39, 62, 0, 0, 0, 0, 50,
+ 0, 0, 0, 0, 33, 0, 34, 35, 0, 26,
+ 0, 0, 32, 0, 0, 0, 31, 0, 0, 56,
+ 58, 61, 0, 37, 0, 57, 30, 0, 29, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 54, 65, 46, 53, 182, 0, 0, 59, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 0, 51, 52,
+ 63, 0, 0, 0, 40, 60, 48, 36, 45, 39,
+ 62, 0, 0, 0, 38, 50, 0, 0, 0, 0,
+ 33, 0, 34, 35, 31, 75, 0, 56, 58, 61,
+ 0, 37, 0, 57, 30, 0, 29, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 26, 0, 0, 32,
+ 125, 0, 180, 131, 0, 59, 0, 0, 0, 0,
+ 0, 140, 140, 140, 140, 140, 140, 0, 0, 31,
+ 140, 0, 56, 58, 61, 0, 37, 0, 57, 30,
+ 0, 29, 38, 54, 65, 46, 53, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 178, 0, 49,
+ 59, 51, 52, 63, 0, 0, 0, 0, 60, 48,
+ 36, 45, 39, 62, 26, 0, 0, 32, 50, 0,
+ 0, 0, 0, 33, 0, 34, 35, 38, 0, 0,
+ 0, 216, 0, 0, 0, 31, 0, 0, 56, 58,
+ 61, 0, 37, 0, 57, 30, 0, 29, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 26,
+ 0, 0, 32, 176, 0, 0, 59, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 54, 65, 46, 53, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 38, 0, 0, 49, 0, 51, 52,
+ 63, 0, 0, 0, 0, 60, 48, 36, 45, 39,
+ 62, 0, 0, 0, 0, 50, 253, 0, 0, 89,
+ 33, 101, 34, 35, 0, 26, 0, 0, 32, 0,
+ 0, 0, 0, 0, 31, 0, 0, 56, 58, 61,
+ 0, 37, 0, 57, 30, 0, 29, 0, 54, 65,
+ 46, 53, 0, 0, 0, 0, 0, 0, 0, 0,
+ 120, 0, 0, 0, 49, 59, 51, 52, 63, 0,
+ 0, 0, 0, 60, 48, 36, 45, 39, 62, 0,
+ 0, 0, 0, 50, 0, 0, 0, 0, 33, 0,
+ 34, 35, 38, 54, 65, 46, 53, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 49,
+ 0, 51, 52, 63, 0, 0, 0, 0, 60, 48,
+ 36, 45, 39, 62, 26, 0, 0, 32, 50, 0,
+ 0, 0, 0, 33, 0, 34, 35, 31, 0, 0,
+ 56, 58, 61, 0, 37, 0, 57, 30, 0, 29,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 54,
+ 65, 46, 53, 0, 0, 0, 0, 0, 59, 0,
+ 0, 0, 0, 0, 0, 49, 0, 51, 52, 63,
+ 0, 0, 0, 0, 60, 48, 36, 45, 39, 62,
+ 0, 0, 0, 0, 50, 38, 0, 118, 0, 33,
+ 0, 34, 35, 0, 31, 0, 0, 56, 58, 61,
+ 0, 37, 116, 57, 30, 0, 29, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 26, 0, 0,
+ 32, 0, 100, 0, 0, 59, 98, 99, 91, 92,
+ 0, 0, 0, 0, 0, 0, 97, 96, 95, 94,
+ 0, 93, 102, 0, 0, 0, 90, 0, 54, 65,
+ 46, 53, 38, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 49, 0, 51, 52, 63, 0,
+ 0, 0, 0, 60, 48, 36, 45, 39, 62, 0,
+ 0, 0, 0, 50, 26, 0, 0, 32, 33, 0,
+ 34, 35, 31, 0, 0, 56, 58, 61, 0, 37,
+ 0, 57, 30, 0, 29, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 59, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 31, 0, 0,
+ 56, 58, 61, 0, 37, 0, 57, 30, 0, 29,
+ 38, 54, 65, 46, 53, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 49, 59, 51,
+ 52, 63, 0, 0, 0, 0, 60, 48, 36, 45,
+ 39, 62, 26, 0, 0, 32, 50, 0, 0, 0,
+ 0, 33, 0, 34, 35, 38, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 54, 65,
+ 46, 53, 0, 0, 0, 0, 0, 26, 0, 0,
+ 32, 0, 0, 0, 49, 0, 51, 52, 63, 0,
+ 0, 0, 0, 60, 48, 36, 45, 39, 62, 0,
+ 0, 0, 0, 50, 0, 0, 0, 0, 33, 0,
+ 34, 35, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 54, 65, 46, 53,
+ 27, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 49, 0, 51, 52, 63, 0, 0, 0,
+ 0, 60, 48, 36, 45, 39, 62, 0, 0, 0,
+ 0, 50, 0, 0, 0, 0, 33, 114, 34, 35,
+ 0, 130, 65, 46, 53, 0, 0, 0, 0, 128,
+ 0, 134, 0, 0, 0, 0, 0, 49, 0, 51,
+ 52, 63, 0, 0, 0, 0, 60, 48, 36, 45,
+ 39, 62, 0, 0, 0, 0, 50, 0, 0, 0,
+ 0, 33, 0, 34, 35, 0, 0, 0, 173, 0,
+ 175, 177, 179, 181, 183, 185, 187, 189, 191, 192,
+ 193, 194, 195, 196, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 224, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 245, 0, 246,
+ 0, 247, 0, 248, 0, 249, 0, 250, 0, 251,
+ 0, 252, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 173, 0, 0, 0, 173, 0, 0, 173, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 290, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 303 };
+int yypact[]={
+
+ -1000, -1000, -1000, -200, -1000, -1000, -1000, -1000, -1000, -4,
+ -1000, -93, -214, -215, -1000, -1000, -1000, 100, 103, 83,
+ 296, -246, 80, 65, -1000, 24, -1000, 626, -288, 1719,
+ 1719, 1719, 1719, 1719, 1719, 1719, 1719, 1621, 1554, 1451,
+ 21, -1000, -1000, 11, -1000, 230, -1000, 301, 1764, -220,
+ 1719, 295, 294, 293, -1000, -1000, -8, -8, -8, -8,
+ -8, -8, 1719, 277, -280, -8, -25, -1000, -25, 97,
+ -1000, 1719, -25, 1719, -25, 247, 71, -1000, -25, 1719,
+ -25, 1719, -25, 1719, 1719, 1719, 1719, 1719, -1000, 1719,
+ 1352, 1286, 1241, 1173, 1076, 973, 897, 847, 1719, 1719,
+ 1719, 1719, 1719, -13, -1000, -1000, -299, -1000, -299, -299,
+ -299, -299, -1000, -1000, -222, 207, 30, 151, -1000, 206,
+ -28, 1719, 1719, 1719, 1719, -22, 211, 803, -222, -1000,
+ 246, 63, -1000, -1000, -222, 218, 708, 1719, -1000, -1000,
+ -1000, -1000, -1000, -1000, -1000, -1000, 134, -1000, 124, 1719,
+ -271, 1719, -1000, -1000, -1000, 217, 124, -246, 264, -246,
+ 1719, 55, 92, -1000, -1000, 263, -248, 259, -248, 124,
+ 124, 124, 124, 626, -80, 626, 1719, -294, 1719, -289,
+ 1719, -263, 1719, -254, 1719, -152, 1719, -58, 1719, 174,
+ 1719, -89, -222, -228, -141, 1408, -294, 236, 1719, 1719,
+ 538, 27, -1000, 1719, 443, -1000, -1000, 399, -1000, -34,
+ -1000, 149, 172, 121, 152, 1719, -23, -1000, 207, 336,
+ 273, -1000, -1000, 258, 480, -1000, 134, 197, 1719, 235,
+ -1000, -25, -1000, -25, -1000, 207, -25, 1719, -25, -1000,
+ -25, 234, -25, -1000, -1000, 626, 626, 626, 626, 626,
+ 626, 626, 626, 1719, 1719, 117, 119, -1000, 1719, 73,
+ -1000, -36, -1000, -1000, -39, -1000, -41, 116, 1719, -1000,
+ -1000, 207, -1000, 207, -1000, -1000, 1719, 178, -1000, -1000,
+ 1719, -246, -246, -25, -246, 66, -248, -1000, 1719, -248,
+ 222, 177, -1000, -48, 62, -1000, -1000, -1000, -1000, -51,
+ 114, -1000, -1000, 583, -1000, 158, -1000, -1000, -246, -1000,
+ 71, -1000, 186, -1000, -1000, -1000, -1000, -1000, -71, -1000,
+ -1000, -1000, 146, -25, 144, -25, -248, -1000, -1000, -1000 };
+int yypgo[]={
+
+ 0, 389, 387, 386, 385, 325, 384, 383, 0, 124,
+ 382, 380, 375, 1, 11, 8, 1980, 415, 1254, 367,
+ 365, 362, 361, 360, 349, 388, 651, 56, 352, 351,
+ 57, 350, 345, 343 };
+int yyr1[]={
+
+ 0, 31, 1, 8, 4, 9, 9, 9, 10, 10,
+ 10, 10, 24, 24, 24, 24, 24, 24, 14, 14,
+ 14, 12, 12, 12, 12, 30, 30, 11, 11, 11,
+ 11, 11, 11, 11, 11, 13, 13, 27, 27, 29,
+ 29, 2, 2, 2, 3, 3, 32, 33, 15, 15,
+ 28, 28, 28, 28, 28, 28, 28, 28, 16, 16,
+ 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
+ 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
+ 16, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 25, 25, 23, 18, 19,
+ 20, 21, 22, 26, 26, 26, 5, 5, 6, 6,
+ 7, 7 };
+int yyr2[]={
+
+ 0, 1, 5, 9, 1, 1, 5, 5, 5, 2,
+ 5, 7, 3, 3, 7, 7, 7, 7, 1, 5,
+ 13, 13, 13, 9, 9, 1, 5, 15, 15, 11,
+ 11, 17, 15, 21, 7, 1, 2, 1, 2, 1,
+ 2, 3, 3, 3, 7, 5, 7, 7, 7, 2,
+ 7, 11, 9, 13, 13, 7, 5, 9, 7, 9,
+ 9, 9, 9, 9, 9, 9, 9, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 11, 7,
+ 3, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+ 5, 7, 5, 7, 5, 7, 7, 3, 3, 9,
+ 11, 3, 3, 3, 11, 13, 13, 11, 9, 11,
+ 13, 17, 3, 3, 7, 9, 5, 5, 9, 11,
+ 9, 11, 3, 5, 3, 5, 5, 3, 7, 7,
+ 9, 9, 13, 2, 2, 1, 3, 5, 5, 5,
+ 5, 5, 5, 3, 3, 3, 5, 3, 5, 3,
+ 7, 5 };
+int yychk[]={
+
+ -1000, -1, -31, -9, -2, -10, -3, -32, -33, -29,
+ -11, 262, 263, 264, 261, -12, 59, -24, 265, 266,
+ 272, -8, 267, 268, 256, -15, 123, -16, -17, 45,
+ 43, 33, 126, 297, 299, 300, 284, 40, 91, 286,
+ -18, -22, -20, -19, -21, 285, 259, -23, 283, 273,
+ 292, 275, 276, 260, 257, -28, 36, 42, 37, 64,
+ 282, 38, 287, 277, -26, 258, 257, -8, 257, 257,
+ 59, 40, -8, 40, -8, -18, 40, -30, 271, 40,
+ -8, 40, -8, 267, 268, 265, 266, 44, -4, 61,
+ 298, 280, 281, 293, 291, 290, 289, 288, 278, 279,
+ 274, 63, 294, 295, 301, 302, -17, -8, -17, -17,
+ -17, -17, -17, -17, -16, -15, 41, -15, 93, -15,
+ 59, 91, 123, 91, 123, -18, 40, 40, -16, -8,
+ 257, -18, 257, -8, -16, 40, 40, 40, -26, 257,
+ -18, -26, -26, -26, -26, -26, -26, -25, -15, 40,
+ 295, -26, -8, -8, 59, -27, -15, -8, -15, -8,
+ 40, -15, -13, -24, -8, -15, -8, -15, -8, -15,
+ -15, -15, -15, -16, -9, -16, 61, -16, 61, -16,
+ 61, -16, 61, -16, 61, -16, 61, -16, 61, -16,
+ 61, -16, -16, -16, -16, -16, -16, 258, 91, 123,
+ 44, -5, 41, 91, 44, -6, 93, 44, -7, 59,
+ 125, -15, -15, -15, -15, 123, -18, 41, -15, 40,
+ 40, 41, 41, -15, -16, -25, -26, -25, 287, 277,
+ -25, 41, -30, 41, -30, -15, -5, 59, 41, -14,
+ 269, 270, 41, -14, 125, -16, -16, -16, -16, -16,
+ -16, -16, -16, 58, 40, -15, -15, 41, 91, -15,
+ 93, 59, 125, 93, 59, 93, 59, -15, 123, -5,
+ 41, -15, 41, -15, 41, 41, 44, -25, 41, -25,
+ 40, -8, -8, -5, -8, -27, -8, -8, 40, -8,
+ -16, -25, 93, 59, -15, 93, 125, 125, 125, 59,
+ -15, -5, -5, -16, 41, -25, -30, -30, -8, -30,
+ 59, -14, -15, -14, 41, 125, 93, 125, 59, 41,
+ 41, -30, -13, 41, 125, 41, -8, 41, -8, -14 };
+int yydef[]={
+
+ 1, -2, 5, -2, 6, 7, 41, 42, 43, 0,
+ 9, 0, 0, 0, 40, 8, 10, 0, 0, 0,
+ 0, -2, 0, 0, 12, 13, 4, 49, 80, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ -2, 98, 101, 102, 103, 0, 112, 113, 0, 122,
+ 124, 127, 0, 0, -2, 134, 0, 0, 0, 0,
+ 0, 0, 135, 0, 0, 0, 0, 45, 0, 0,
+ 11, 37, 0, 0, 0, 0, -2, 34, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 5, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 86, 87, 81, 145, 82, 83,
+ 84, 85, -2, -2, 90, 0, 92, 0, 94, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 116, 117,
+ 133, 97, 123, 125, 126, 0, 0, 0, 138, 143,
+ 144, 142, 140, 139, 141, 137, 135, 56, 136, 135,
+ 0, 135, 44, 46, 47, 0, 38, 25, 0, 25,
+ 0, 13, 0, 36, 26, 0, 18, 0, 18, 14,
+ 15, 16, 17, 48, 39, 58, 0, 67, 0, 68,
+ 0, 69, 0, 70, 0, 73, 0, 74, 0, 76,
+ 0, 77, -2, -2, -2, 0, 79, 0, 0, 0,
+ 0, 91, 147, 0, 0, 93, 149, 0, 95, 0,
+ 96, 0, 0, 0, 0, 0, 0, 114, 0, 0,
+ 0, 128, 129, 0, 0, 50, 135, 0, 135, 0,
+ 55, 0, 29, 0, 30, 0, 0, 37, 0, 23,
+ 0, 0, 0, 24, 3, 59, 60, 61, 62, 63,
+ 64, 65, 66, 0, 135, 0, 0, 146, 0, 0,
+ 148, 0, 151, 99, 0, 108, 0, 0, 0, 115,
+ 118, 0, 120, 0, 130, 131, 0, 0, 57, 52,
+ 135, 25, 25, 0, 25, 0, 18, 19, 0, 18,
+ 78, 0, 100, 0, 0, 107, 150, 104, 109, 0,
+ 0, 119, 121, 0, 51, 0, 27, 28, 25, 32,
+ -2, 21, 0, 22, 54, 105, 106, 110, 0, 132,
+ 53, 31, 0, 0, 0, 0, 18, 111, 33, 20 };
+typedef struct { char *t_name; int t_val; } yytoktype;
+#ifndef YYDEBUG
+# define YYDEBUG 0 /* don't allow debugging */
+#endif
+
+#if YYDEBUG
+
+yytoktype yytoks[] =
+{
+ "{", 123,
+ ")", 41,
+ "WORD", 257,
+ "METHOD", 258,
+ "THING", 259,
+ "PMFUNC", 260,
+ "LABEL", 261,
+ "FORMAT", 262,
+ "SUB", 263,
+ "PACKAGE", 264,
+ "WHILE", 265,
+ "UNTIL", 266,
+ "IF", 267,
+ "UNLESS", 268,
+ "ELSE", 269,
+ "ELSIF", 270,
+ "CONTINUE", 271,
+ "FOR", 272,
+ "LOOPEX", 273,
+ "DOTDOT", 274,
+ "FUNC0", 275,
+ "FUNC1", 276,
+ "FUNC", 277,
+ "RELOP", 278,
+ "EQOP", 279,
+ "MULOP", 280,
+ "ADDOP", 281,
+ "DOLSHARP", 282,
+ "DO", 283,
+ "LOCAL", 284,
+ "DELETE", 285,
+ "HASHBRACK", 286,
+ "LSTOP", 287,
+ ",", 44,
+ "=", 61,
+ "?", 63,
+ ":", 58,
+ "OROR", 288,
+ "ANDAND", 289,
+ "BITOROP", 290,
+ "BITANDOP", 291,
+ "UNIOP", 292,
+ "SHIFTOP", 293,
+ "MATCHOP", 294,
+ "ARROW", 295,
+ "!", 33,
+ "~", 126,
+ "UMINUS", 296,
+ "REFGEN", 297,
+ "POWOP", 298,
+ "PREINC", 299,
+ "PREDEC", 300,
+ "POSTINC", 301,
+ "POSTDEC", 302,
+ "(", 40,
+ "-unknown-", -1 /* ends search */
+};
+
+char * yyreds[] =
+{
+ "-no such reduction-",
+ "prog : /* empty */",
+ "prog : lineseq",
+ "block : '{' remember lineseq '}'",
+ "remember : /* empty */",
+ "lineseq : /* empty */",
+ "lineseq : lineseq decl",
+ "lineseq : lineseq line",
+ "line : label cond",
+ "line : loop",
+ "line : label ';'",
+ "line : label sideff ';'",
+ "sideff : error",
+ "sideff : expr",
+ "sideff : expr IF expr",
+ "sideff : expr UNLESS expr",
+ "sideff : expr WHILE expr",
+ "sideff : expr UNTIL expr",
+ "else : /* empty */",
+ "else : ELSE block",
+ "else : ELSIF '(' expr ')' block else",
+ "cond : IF '(' expr ')' block else",
+ "cond : UNLESS '(' expr ')' block else",
+ "cond : IF block block else",
+ "cond : UNLESS block block else",
+ "cont : /* empty */",
+ "cont : CONTINUE block",
+ "loop : label WHILE '(' texpr ')' block cont",
+ "loop : label UNTIL '(' expr ')' block cont",
+ "loop : label WHILE block block cont",
+ "loop : label UNTIL block block cont",
+ "loop : label FOR scalar '(' expr crp block cont",
+ "loop : label FOR '(' expr crp block cont",
+ "loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' block",
+ "loop : label block cont",
+ "nexpr : /* empty */",
+ "nexpr : sideff",
+ "texpr : /* empty */",
+ "texpr : expr",
+ "label : /* empty */",
+ "label : LABEL",
+ "decl : format",
+ "decl : subrout",
+ "decl : package",
+ "format : FORMAT WORD block",
+ "format : FORMAT block",
+ "subrout : SUB WORD block",
+ "package : PACKAGE WORD ';'",
+ "expr : expr ',' sexpr",
+ "expr : sexpr",
+ "listop : LSTOP indirob listexpr",
+ "listop : FUNC '(' indirob listexpr ')'",
+ "listop : indirob ARROW LSTOP listexpr",
+ "listop : indirob ARROW FUNC '(' listexpr ')'",
+ "listop : term ARROW METHOD '(' listexpr ')'",
+ "listop : METHOD indirob listexpr",
+ "listop : LSTOP listexpr",
+ "listop : FUNC '(' listexpr ')'",
+ "sexpr : sexpr '=' sexpr",
+ "sexpr : sexpr POWOP '=' sexpr",
+ "sexpr : sexpr MULOP '=' sexpr",
+ "sexpr : sexpr ADDOP '=' sexpr",
+ "sexpr : sexpr SHIFTOP '=' sexpr",
+ "sexpr : sexpr BITANDOP '=' sexpr",
+ "sexpr : sexpr BITOROP '=' sexpr",
+ "sexpr : sexpr ANDAND '=' sexpr",
+ "sexpr : sexpr OROR '=' sexpr",
+ "sexpr : sexpr POWOP sexpr",
+ "sexpr : sexpr MULOP sexpr",
+ "sexpr : sexpr ADDOP sexpr",
+ "sexpr : sexpr SHIFTOP sexpr",
+ "sexpr : sexpr RELOP sexpr",
+ "sexpr : sexpr EQOP sexpr",
+ "sexpr : sexpr BITANDOP sexpr",
+ "sexpr : sexpr BITOROP sexpr",
+ "sexpr : sexpr DOTDOT sexpr",
+ "sexpr : sexpr ANDAND sexpr",
+ "sexpr : sexpr OROR sexpr",
+ "sexpr : sexpr '?' sexpr ':' sexpr",
+ "sexpr : sexpr MATCHOP sexpr",
+ "sexpr : term",
+ "term : '-' term",
+ "term : '+' term",
+ "term : '!' term",
+ "term : '~' term",
+ "term : REFGEN term",
+ "term : term POSTINC",
+ "term : term POSTDEC",
+ "term : PREINC term",
+ "term : PREDEC term",
+ "term : LOCAL sexpr",
+ "term : '(' expr crp",
+ "term : '(' ')'",
+ "term : '[' expr crb",
+ "term : '[' ']'",
+ "term : HASHBRACK expr crhb",
+ "term : HASHBRACK ';' '}'",
+ "term : scalar",
+ "term : star",
+ "term : scalar '[' expr ']'",
+ "term : term ARROW '[' expr ']'",
+ "term : hsh",
+ "term : ary",
+ "term : arylen",
+ "term : scalar '{' expr ';' '}'",
+ "term : term ARROW '{' expr ';' '}'",
+ "term : '(' expr crp '[' expr ']'",
+ "term : '(' ')' '[' expr ']'",
+ "term : ary '[' expr ']'",
+ "term : ary '{' expr ';' '}'",
+ "term : DELETE scalar '{' expr ';' '}'",
+ "term : DELETE '(' scalar '{' expr ';' '}' ')'",
+ "term : THING",
+ "term : amper",
+ "term : amper '(' ')'",
+ "term : amper '(' expr crp",
+ "term : DO sexpr",
+ "term : DO block",
+ "term : DO WORD '(' ')'",
+ "term : DO WORD '(' expr crp",
+ "term : DO scalar '(' ')'",
+ "term : DO scalar '(' expr crp",
+ "term : LOOPEX",
+ "term : LOOPEX WORD",
+ "term : UNIOP",
+ "term : UNIOP block",
+ "term : UNIOP sexpr",
+ "term : FUNC0",
+ "term : FUNC0 '(' ')'",
+ "term : FUNC1 '(' ')'",
+ "term : FUNC1 '(' expr ')'",
+ "term : PMFUNC '(' sexpr ')'",
+ "term : PMFUNC '(' sexpr ',' sexpr ')'",
+ "term : WORD",
+ "term : listop",
+ "listexpr : /* empty */",
+ "listexpr : expr",
+ "amper : '&' indirob",
+ "scalar : '$' indirob",
+ "ary : '@' indirob",
+ "hsh : '%' indirob",
+ "arylen : DOLSHARP indirob",
+ "star : '*' indirob",
+ "indirob : WORD",
+ "indirob : scalar",
+ "indirob : block",
+ "crp : ',' ')'",
+ "crp : ')'",
+ "crb : ',' ']'",
+ "crb : ']'",
+ "crhb : ',' ';' '}'",
+ "crhb : ';' '}'",
+};
+#endif /* YYDEBUG */
+#line 1 "/usr/lib/yaccpar"
+/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */
+
+/*
+** Skeleton parser driver for yacc output
+*/
+
+/*
+** yacc user known macros and defines
+*/
+#define YYERROR goto yyerrlab
+#define YYACCEPT { free(yys); free(yyv); return(0); }
+#define YYABORT { free(yys); free(yyv); return(1); }
+#define YYBACKUP( newtoken, newvalue )\
+{\
+ if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\
+ {\
+ yyerror( "syntax error - cannot backup" );\
+ goto yyerrlab;\
+ }\
+ yychar = newtoken;\
+ yystate = *yyps;\
+ yylval = newvalue;\
+ goto yynewstate;\
+}
+#define YYRECOVERING() (!!yyerrflag)
+#ifndef YYDEBUG
+# define YYDEBUG 1 /* make debugging available */
+#endif
+
+/*
+** user known globals
+*/
+int yydebug; /* set to 1 to get debugging */
+
+/*
+** driver internal defines
+*/
+#define YYFLAG (-1000)
+
+/*
+** static variables used by the parser
+*/
+static YYSTYPE *yyv; /* value stack */
+static int *yys; /* state stack */
+
+static YYSTYPE *yypv; /* top of value stack */
+static int *yyps; /* top of state stack */
+
+static int yystate; /* current state */
+static int yytmp; /* extra var (lasts between blocks) */
+
+int yynerrs; /* number of errors */
+
+int yyerrflag; /* error recovery flag */
+int yychar; /* current input token number */
+
+
+/*
+** yyparse - return 0 if worked, 1 if syntax error not recovered from
+*/
+int
+yyparse()
+{
+ register YYSTYPE *yypvt; /* top of value stack for $vars */
+ unsigned yymaxdepth = YYMAXDEPTH;
+
+ /*
+ ** Initialize externals - yyparse may be called more than once
+ */
+ yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE));
+ yys = (int*)malloc(yymaxdepth*sizeof(int));
+ if (!yyv || !yys)
+ {
+ yyerror( "out of memory" );
+ return(1);
+ }
+ yypv = &yyv[-1];
+ yyps = &yys[-1];
+ yystate = 0;
+ yytmp = 0;
+ yynerrs = 0;
+ yyerrflag = 0;
+ yychar = -1;
+
+ goto yystack;
+ {
+ register YYSTYPE *yy_pv; /* top of value stack */
+ register int *yy_ps; /* top of state stack */
+ register int yy_state; /* current state */
+ register int yy_n; /* internal state number info */
+
+ /*
+ ** get globals into registers.
+ ** branch to here only if YYBACKUP was called.
+ */
+ yynewstate:
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+ goto yy_newstate;
+
+ /*
+ ** get globals into registers.
+ ** either we just started, or we just finished a reduction
+ */
+ yystack:
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+
+ /*
+ ** top of for (;;) loop while no reductions done
+ */
+ yy_stack:
+ /*
+ ** put a state and value onto the stacks
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token value in list of value vs.
+ ** name pairs. 0 and negative (-1) are special values.
+ ** Note: linear search is used since time is not a real
+ ** consideration while debugging.
+ */
+ if ( yydebug )
+ {
+ register int yy_i;
+
+ (void)printf( "State %d, token ", yy_state );
+ if ( yychar == 0 )
+ (void)printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0; yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val == yychar )
+ break;
+ }
+ (void)printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */
+ {
+ /*
+ ** reallocate and recover. Note that pointers
+ ** have to be reset, or bad things will happen
+ */
+ int yyps_index = (yy_ps - yys);
+ int yypv_index = (yy_pv - yyv);
+ int yypvt_index = (yypvt - yyv);
+ yymaxdepth += YYMAXDEPTH;
+ yyv = (YYSTYPE*)realloc((char*)yyv,
+ yymaxdepth * sizeof(YYSTYPE));
+ yys = (int*)realloc((char*)yys,
+ yymaxdepth * sizeof(int));
+ if (!yyv || !yys)
+ {
+ yyerror( "yacc stack overflow" );
+ return(1);
+ }
+ yy_ps = yys + yyps_index;
+ yy_pv = yyv + yypv_index;
+ yypvt = yyv + yypvt_index;
+ }
+ *yy_ps = yy_state;
+ *++yy_pv = yyval;
+
+ /*
+ ** we have a new state - find out what to do
+ */
+ yy_newstate:
+ if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG )
+ goto yydefault; /* simple state */
+#if YYDEBUG
+ /*
+ ** if debugging, need to mark whether new token grabbed
+ */
+ yytmp = yychar < 0;
+#endif
+ if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) )
+ yychar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( yydebug && yytmp )
+ {
+ register int yy_i;
+
+ (void)printf( " *** Received token " );
+ if ( yychar == 0 )
+ (void)printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0; yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val == yychar )
+ break;
+ }
+ (void)printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) )
+ goto yydefault;
+ if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/
+ {
+ yychar = -1;
+ yyval = yylval;
+ yy_state = yy_n;
+ if ( yyerrflag > 0 )
+ yyerrflag--;
+ goto yy_stack;
+ }
+
+ yydefault:
+ if ( ( yy_n = yydef[ yy_state ] ) == -2 )
+ {
+#if YYDEBUG
+ yytmp = yychar < 0;
+#endif
+ if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) )
+ yychar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( yydebug && yytmp )
+ {
+ register int yy_i;
+
+ (void)printf( " *** Received token " );
+ if ( yychar == 0 )
+ (void)printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0;
+ yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val
+ == yychar )
+ {
+ break;
+ }
+ }
+ (void)printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ /*
+ ** look through exception table
+ */
+ {
+ register int *yyxi = yyexca;
+
+ while ( ( *yyxi != -1 ) ||
+ ( yyxi[1] != yy_state ) )
+ {
+ yyxi += 2;
+ }
+ while ( ( *(yyxi += 2) >= 0 ) &&
+ ( *yyxi != yychar ) )
+ ;
+ if ( ( yy_n = yyxi[1] ) < 0 )
+ YYACCEPT;
+ }
+ }
+
+ /*
+ ** check for syntax error
+ */
+ if ( yy_n == 0 ) /* have an error */
+ {
+ /* no worry about speed here! */
+ switch ( yyerrflag )
+ {
+ case 0: /* new error */
+ yyerror( "syntax error" );
+ goto skip_init;
+ yyerrlab:
+ /*
+ ** get globals into registers.
+ ** we have a user generated syntax type error
+ */
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+ yynerrs++;
+ skip_init:
+ case 1:
+ case 2: /* incompletely recovered error */
+ /* try again... */
+ yyerrflag = 3;
+ /*
+ ** find state where "error" is a legal
+ ** shift action
+ */
+ while ( yy_ps >= yys )
+ {
+ yy_n = yypact[ *yy_ps ] + YYERRCODE;
+ if ( yy_n >= 0 && yy_n < YYLAST &&
+ yychk[yyact[yy_n]] == YYERRCODE) {
+ /*
+ ** simulate shift of "error"
+ */
+ yy_state = yyact[ yy_n ];
+ goto yy_stack;
+ }
+ /*
+ ** current state has no shift on
+ ** "error", pop stack
+ */
+#if YYDEBUG
+# define _POP_ "Error recovery pops state %d, uncovers state %d\n"
+ if ( yydebug )
+ (void)printf( _POP_, *yy_ps,
+ yy_ps[-1] );
+# undef _POP_
+#endif
+ yy_ps--;
+ yy_pv--;
+ }
+ /*
+ ** there is no state on stack with "error" as
+ ** a valid shift. give up.
+ */
+ YYABORT;
+ case 3: /* no shift yet; eat a token */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token in list of
+ ** pairs. 0 and negative shouldn't occur,
+ ** but since timing doesn't matter when
+ ** debugging, it doesn't hurt to leave the
+ ** tests here.
+ */
+ if ( yydebug )
+ {
+ register int yy_i;
+
+ (void)printf( "Error recovery discards " );
+ if ( yychar == 0 )
+ (void)printf( "token end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "token -none-\n" );
+ else
+ {
+ for ( yy_i = 0;
+ yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val
+ == yychar )
+ {
+ break;
+ }
+ }
+ (void)printf( "token %s\n",
+ yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( yychar == 0 ) /* reached EOF. quit */
+ YYABORT;
+ yychar = -1;
+ goto yy_newstate;
+ }
+ }/* end if ( yy_n == 0 ) */
+ /*
+ ** reduction by production yy_n
+ ** put stack tops, etc. so things right after switch
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, print the string that is the user's
+ ** specification of the reduction which is just about
+ ** to be done.
+ */
+ if ( yydebug )
+ (void)printf( "Reduce by (%d) \"%s\"\n",
+ yy_n, yyreds[ yy_n ] );
+#endif
+ yytmp = yy_n; /* value to switch over */
+ yypvt = yy_pv; /* $vars top of value stack */
+ /*
+ ** Look in goto table for next state
+ ** Sorry about using yy_state here as temporary
+ ** register variable, but why not, if it works...
+ ** If yyr2[ yy_n ] doesn't have the low order bit
+ ** set, then there is no action to be done for
+ ** this reduction. So, no saving & unsaving of
+ ** registers done. The only difference between the
+ ** code just after the if and the body of the if is
+ ** the goto yy_stack in the body. This way the test
+ ** can be made before the choice of what to do is needed.
+ */
+ {
+ /* length of production doubled with extra bit */
+ register int yy_len = yyr2[ yy_n ];
+
+ if ( !( yy_len & 01 ) )
+ {
+ yy_len >>= 1;
+ yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */
+ yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] +
+ *( yy_ps -= yy_len ) + 1;
+ if ( yy_state >= YYLAST ||
+ yychk[ yy_state =
+ yyact[ yy_state ] ] != -yy_n )
+ {
+ yy_state = yyact[ yypgo[ yy_n ] ];
+ }
+ goto yy_stack;
+ }
+ yy_len >>= 1;
+ yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */
+ yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] +
+ *( yy_ps -= yy_len ) + 1;
+ if ( yy_state >= YYLAST ||
+ yychk[ yy_state = yyact[ yy_state ] ] != -yy_n )
+ {
+ yy_state = yyact[ yypgo[ yy_n ] ];
+ }
+ }
+ /* save until reenter driver code */
+ yystate = yy_state;
+ yyps = yy_ps;
+ yypv = yy_pv;
+ }
+ /*
+ ** code supplied by user is placed in this switch
+ */
+ switch( yytmp )
+ {
+
+case 1:
+# line 100 "perly.y"
+{
+#if defined(YYDEBUG) && defined(DEBUGGING)
+ yydebug = (debug & 1);
+#endif
+ expect = XBLOCK;
+ } break;
+case 2:
+# line 107 "perly.y"
+{ if (in_eval) {
+ eval_root = newUNOP(OP_LEAVEEVAL, 0, yypvt[-0].opval);
+ eval_start = linklist(eval_root);
+ eval_root->op_next = 0;
+ peep(eval_start);
+ }
+ else
+ main_root = block_head(scalar(yypvt[-0].opval), &main_start);
+ } break;
+case 3:
+# line 119 "perly.y"
+{ yyval.opval = scalarseq(yypvt[-1].opval);
+ if (copline > (line_t)yypvt[-3].ival)
+ copline = yypvt[-3].ival;
+ if (savestack_ix > yypvt[-2].ival)
+ leave_scope(yypvt[-2].ival);
+ expect = XBLOCK; } break;
+case 4:
+# line 128 "perly.y"
+{ yyval.ival = savestack_ix; } break;
+case 5:
+# line 132 "perly.y"
+{ yyval.opval = Nullop; } break;
+case 6:
+# line 134 "perly.y"
+{ yyval.opval = yypvt[-1].opval; } break;
+case 7:
+# line 136 "perly.y"
+{ yyval.opval = append_list(OP_LINESEQ, yypvt[-1].opval, yypvt[-0].opval); pad_reset(); } break;
+case 8:
+# line 140 "perly.y"
+{ yyval.opval = newSTATEOP(0, yypvt[-1].pval, yypvt[-0].opval); } break;
+case 10:
+# line 143 "perly.y"
+{ if (yypvt[-1].pval != Nullch) {
+ yyval.opval = newSTATEOP(0, yypvt[-1].pval, newOP(OP_NULL, 0));
+ }
+ else {
+ yyval.opval = Nullop;
+ copline = NOLINE;
+ }
+ expect = XBLOCK; } break;
+case 11:
+# line 152 "perly.y"
+{ yyval.opval = newSTATEOP(0, yypvt[-2].pval, yypvt[-1].opval);
+ expect = XBLOCK; } break;
+case 12:
+# line 157 "perly.y"
+{ yyval.opval = Nullop; } break;
+case 13:
+# line 159 "perly.y"
+{ yyval.opval = yypvt[-0].opval; } break;
+case 14:
+# line 161 "perly.y"
+{ yyval.opval = newLOGOP(OP_AND, 0, yypvt[-0].opval, yypvt[-2].opval); } break;
+case 15:
+# line 163 "perly.y"
+{ yyval.opval = newLOGOP(OP_OR, 0, yypvt[-0].opval, yypvt[-2].opval); } break;
+case 16:
+# line 165 "perly.y"
+{ yyval.opval = newLOOPOP(0, 1, scalar(yypvt[-0].opval), yypvt[-2].opval, Nullop); } break;
+case 17:
+# line 167 "perly.y"
+{ yyval.opval = newLOOPOP(0, 1, invert(scalar(yypvt[-0].opval)), yypvt[-2].opval, Nullop);} break;
+case 18:
+# line 171 "perly.y"
+{ yyval.opval = Nullop; } break;
+case 19:
+# line 173 "perly.y"
+{ yyval.opval = scope(yypvt[-0].opval); } break;
+case 20:
+# line 175 "perly.y"
+{ copline = yypvt[-5].ival;
+ yyval.opval = newCONDOP(0, yypvt[-3].opval, scope(yypvt[-1].opval), yypvt[-0].opval); } break;
+case 21:
+# line 180 "perly.y"
+{ copline = yypvt[-5].ival;
+ yyval.opval = newCONDOP(0, yypvt[-3].opval, scope(yypvt[-1].opval), yypvt[-0].opval); } break;
+case 22:
+# line 183 "perly.y"
+{ copline = yypvt[-5].ival;
+ yyval.opval = newCONDOP(0,
+ invert(scalar(yypvt[-3].opval)), scope(yypvt[-1].opval), yypvt[-0].opval); } break;
+case 23:
+# line 187 "perly.y"
+{ copline = yypvt[-3].ival;
+ yyval.opval = newCONDOP(0, scope(yypvt[-2].opval), scope(yypvt[-1].opval), yypvt[-0].opval); } break;
+case 24:
+# line 190 "perly.y"
+{ copline = yypvt[-3].ival;
+ yyval.opval = newCONDOP(0, invert(scalar(scope(yypvt[-2].opval))),
+ scope(yypvt[-1].opval), yypvt[-0].opval); } break;
+case 25:
+# line 196 "perly.y"
+{ yyval.opval = Nullop; } break;
+case 26:
+# line 198 "perly.y"
+{ yyval.opval = scope(yypvt[-0].opval); } break;
+case 27:
+# line 202 "perly.y"
+{ copline = yypvt[-5].ival;
+ yyval.opval = newSTATEOP(0, yypvt[-6].pval,
+ newWHILEOP(0, 1, Nullop, yypvt[-3].opval, yypvt[-1].opval, yypvt[-0].opval) ); } break;
+case 28:
+# line 206 "perly.y"
+{ copline = yypvt[-5].ival;
+ yyval.opval = newSTATEOP(0, yypvt[-6].pval,
+ newWHILEOP(0, 1, Nullop,
+ invert(scalar(yypvt[-3].opval)), yypvt[-1].opval, yypvt[-0].opval) ); } break;
+case 29:
+# line 211 "perly.y"
+{ copline = yypvt[-3].ival;
+ yyval.opval = newSTATEOP(0, yypvt[-4].pval,
+ newWHILEOP(0, 1, Nullop,
+ scope(yypvt[-2].opval), yypvt[-1].opval, yypvt[-0].opval) ); } break;
+case 30:
+# line 216 "perly.y"
+{ copline = yypvt[-3].ival;
+ yyval.opval = newSTATEOP(0, yypvt[-4].pval,
+ newWHILEOP(0, 1, Nullop,
+ invert(scalar(scope(yypvt[-2].opval))), yypvt[-1].opval, yypvt[-0].opval)); } break;
+case 31:
+# line 221 "perly.y"
+{ yyval.opval = newFOROP(0, yypvt[-7].pval, yypvt[-6].ival, ref(yypvt[-5].opval, OP_ENTERLOOP),
+ yypvt[-3].opval, yypvt[-1].opval, yypvt[-0].opval); } break;
+case 32:
+# line 224 "perly.y"
+{ yyval.opval = newFOROP(0, yypvt[-6].pval, yypvt[-5].ival, Nullop, yypvt[-3].opval, yypvt[-1].opval, yypvt[-0].opval); } break;
+case 33:
+# line 227 "perly.y"
+{ copline = yypvt[-8].ival;
+ yyval.opval = append_elem(OP_LINESEQ,
+ newSTATEOP(0, yypvt[-9].pval, scalar(yypvt[-6].opval)),
+ newSTATEOP(0, yypvt[-9].pval,
+ newWHILEOP(0, 1, Nullop,
+ scalar(yypvt[-4].opval), yypvt[-0].opval, scalar(yypvt[-2].opval)) )); } break;
+case 34:
+# line 234 "perly.y"
+{ yyval.opval = newSTATEOP(0,
+ yypvt[-2].pval, newWHILEOP(0, 1, Nullop, Nullop, yypvt[-1].opval, yypvt[-0].opval)); } break;
+case 35:
+# line 239 "perly.y"
+{ yyval.opval = Nullop; } break;
+case 37:
+# line 244 "perly.y"
+{ (void)scan_num("1"); yyval.opval = yylval.opval; } break;
+case 39:
+# line 249 "perly.y"
+{ yyval.pval = Nullch; } break;
+case 41:
+# line 254 "perly.y"
+{ yyval.ival = 0; } break;
+case 42:
+# line 256 "perly.y"
+{ yyval.ival = 0; } break;
+case 43:
+# line 258 "perly.y"
+{ yyval.ival = 0; } break;
+case 44:
+# line 262 "perly.y"
+{ newFORM(yypvt[-2].ival, yypvt[-1].opval, yypvt[-0].opval); } break;
+case 45:
+# line 264 "perly.y"
+{ newFORM(yypvt[-1].ival, Nullop, yypvt[-0].opval); } break;
+case 46:
+# line 268 "perly.y"
+{ newSUB(yypvt[-2].ival, yypvt[-1].opval, yypvt[-0].opval); } break;
+case 47:
+# line 272 "perly.y"
+{ package(yypvt[-1].opval); } break;
+case 48:
+# line 276 "perly.y"
+{ yyval.opval = append_elem(OP_LIST, yypvt[-2].opval, yypvt[-0].opval); } break;
+case 50:
+# line 281 "perly.y"
+{ yyval.opval = convert(yypvt[-2].ival, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF(yypvt[-1].opval), yypvt[-0].opval) ); } break;
+case 51:
+# line 284 "perly.y"
+{ yyval.opval = convert(yypvt[-4].ival, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF(yypvt[-2].opval), yypvt[-1].opval) ); } break;
+case 52:
+# line 287 "perly.y"
+{ yyval.opval = convert(yypvt[-1].ival, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF(yypvt[-3].opval), yypvt[-0].opval) ); } break;
+case 53:
+# line 290 "perly.y"
+{ yyval.opval = convert(yypvt[-3].ival, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF(yypvt[-5].opval), yypvt[-1].opval) ); } break;
+case 54:
+# line 293 "perly.y"
+{ yyval.opval = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL,
+ prepend_elem(OP_LIST, newMETHOD(yypvt[-5].opval,yypvt[-3].opval), yypvt[-1].opval)); } break;
+case 55:
+# line 296 "perly.y"
+{ yyval.opval = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL,
+ prepend_elem(OP_LIST, newMETHOD(yypvt[-1].opval,yypvt[-2].opval), yypvt[-0].opval)); } break;
+case 56:
+# line 299 "perly.y"
+{ yyval.opval = convert(yypvt[-1].ival, 0, yypvt[-0].opval); } break;
+case 57:
+# line 301 "perly.y"
+{ yyval.opval = convert(yypvt[-3].ival, 0, yypvt[-1].opval); } break;
+case 58:
+# line 305 "perly.y"
+{ yyval.opval = newASSIGNOP(OPf_STACKED, yypvt[-2].opval, yypvt[-0].opval); } break;
+case 59:
+# line 307 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED,
+ ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break;
+case 60:
+# line 310 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED,
+ ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break;
+case 61:
+# line 313 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED,
+ ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval));} break;
+case 62:
+# line 316 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED,
+ ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break;
+case 63:
+# line 319 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED,
+ ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break;
+case 64:
+# line 322 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED,
+ ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break;
+case 65:
+# line 325 "perly.y"
+{ yyval.opval = newLOGOP(OP_ANDASSIGN, 0,
+ ref(scalar(yypvt[-3].opval), OP_ANDASSIGN),
+ newUNOP(OP_SASSIGN, 0, scalar(yypvt[-0].opval))); } break;
+case 66:
+# line 329 "perly.y"
+{ yyval.opval = newLOGOP(OP_ORASSIGN, 0,
+ ref(scalar(yypvt[-3].opval), OP_ORASSIGN),
+ newUNOP(OP_SASSIGN, 0, scalar(yypvt[-0].opval))); } break;
+case 67:
+# line 335 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break;
+case 68:
+# line 337 "perly.y"
+{ if (yypvt[-1].ival != OP_REPEAT)
+ scalar(yypvt[-2].opval);
+ yyval.opval = newBINOP(yypvt[-1].ival, 0, yypvt[-2].opval, scalar(yypvt[-0].opval)); } break;
+case 69:
+# line 341 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break;
+case 70:
+# line 343 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break;
+case 71:
+# line 345 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break;
+case 72:
+# line 347 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break;
+case 73:
+# line 349 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break;
+case 74:
+# line 351 "perly.y"
+{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break;
+case 75:
+# line 353 "perly.y"
+{ yyval.opval = newRANGE(yypvt[-1].ival, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval));} break;
+case 76:
+# line 355 "perly.y"
+{ yyval.opval = newLOGOP(OP_AND, 0, yypvt[-2].opval, yypvt[-0].opval); } break;
+case 77:
+# line 357 "perly.y"
+{ yyval.opval = newLOGOP(OP_OR, 0, yypvt[-2].opval, yypvt[-0].opval); } break;
+case 78:
+# line 359 "perly.y"
+{ yyval.opval = newCONDOP(0, yypvt[-4].opval, yypvt[-2].opval, yypvt[-0].opval); } break;
+case 79:
+# line 361 "perly.y"
+{ yyval.opval = bind_match(yypvt[-1].ival, yypvt[-2].opval, yypvt[-0].opval); } break;
+case 80:
+# line 363 "perly.y"
+{ yyval.opval = yypvt[-0].opval; } break;
+case 81:
+# line 367 "perly.y"
+{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yypvt[-0].opval)); } break;
+case 82:
+# line 369 "perly.y"
+{ yyval.opval = yypvt[-0].opval; } break;
+case 83:
+# line 371 "perly.y"
+{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yypvt[-0].opval)); } break;
+case 84:
+# line 373 "perly.y"
+{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yypvt[-0].opval));} break;
+case 85:
+# line 375 "perly.y"
+{ yyval.opval = newUNOP(OP_REFGEN, 0, ref(yypvt[-0].opval, OP_REFGEN)); } break;
+case 86:
+# line 377 "perly.y"
+{ yyval.opval = newUNOP(OP_POSTINC, 0,
+ ref(scalar(yypvt[-1].opval), OP_POSTINC)); } break;
+case 87:
+# line 380 "perly.y"
+{ yyval.opval = newUNOP(OP_POSTDEC, 0,
+ ref(scalar(yypvt[-1].opval), OP_POSTDEC)); } break;
+case 88:
+# line 383 "perly.y"
+{ yyval.opval = newUNOP(OP_PREINC, 0,
+ ref(scalar(yypvt[-0].opval), OP_PREINC)); } break;
+case 89:
+# line 386 "perly.y"
+{ yyval.opval = newUNOP(OP_PREDEC, 0,
+ ref(scalar(yypvt[-0].opval), OP_PREDEC)); } break;
+case 90:
+# line 389 "perly.y"
+{ yyval.opval = localize(yypvt[-0].opval); } break;
+case 91:
+# line 391 "perly.y"
+{ yyval.opval = sawparens(yypvt[-1].opval); } break;
+case 92:
+# line 393 "perly.y"
+{ yyval.opval = newNULLLIST(); } break;
+case 93:
+# line 395 "perly.y"
+{ yyval.opval = newANONLIST(yypvt[-1].opval); } break;
+case 94:
+# line 397 "perly.y"
+{ yyval.opval = newANONLIST(Nullop); } break;
+case 95:
+# line 399 "perly.y"
+{ yyval.opval = newANONHASH(yypvt[-1].opval); } break;
+case 96:
+# line 401 "perly.y"
+{ yyval.opval = newANONHASH(Nullop); } break;
+case 97:
+# line 403 "perly.y"
+{ yyval.opval = yypvt[-0].opval; } break;
+case 98:
+# line 405 "perly.y"
+{ yyval.opval = yypvt[-0].opval; } break;
+case 99:
+# line 407 "perly.y"
+{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yypvt[-3].opval), scalar(yypvt[-1].opval)); } break;
+case 100:
+# line 409 "perly.y"
+{ yyval.opval = newBINOP(OP_AELEM, 0,
+ scalar(ref(newAVREF(yypvt[-4].opval),OP_RV2AV)),
+ scalar(yypvt[-1].opval));} break;
+case 101:
+# line 413 "perly.y"
+{ yyval.opval = yypvt[-0].opval; } break;
+case 102:
+# line 415 "perly.y"
+{ yyval.opval = yypvt[-0].opval; } break;
+case 103:
+# line 417 "perly.y"
+{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yypvt[-0].opval, OP_AV2ARYLEN));} break;
+case 104:
+# line 419 "perly.y"
+{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yypvt[-4].opval), jmaybe(yypvt[-2].opval));
+ expect = XOPERATOR; } break;
+case 105:
+# line 422 "perly.y"
+{ yyval.opval = newBINOP(OP_HELEM, 0,
+ scalar(ref(newHVREF(yypvt[-5].opval),OP_RV2HV)),
+ jmaybe(yypvt[-2].opval));
+ expect = XOPERATOR; } break;
+case 106:
+# line 427 "perly.y"
+{ yyval.opval = newSLICEOP(0, yypvt[-1].opval, yypvt[-4].opval); } break;
+case 107:
+# line 429 "perly.y"
+{ yyval.opval = newSLICEOP(0, yypvt[-1].opval, Nullop); } break;
+case 108:
+# line 431 "perly.y"
+{ yyval.opval = prepend_elem(OP_ASLICE,
+ newOP(OP_PUSHMARK, 0),
+ list(
+ newLISTOP(OP_ASLICE, 0,
+ list(yypvt[-1].opval),
+ ref(yypvt[-3].opval, OP_ASLICE)))); } break;
+case 109:
+# line 438 "perly.y"
+{ yyval.opval = prepend_elem(OP_HSLICE,
+ newOP(OP_PUSHMARK, 0),
+ list(
+ newLISTOP(OP_HSLICE, 0,
+ list(yypvt[-2].opval),
+ ref(oopsHV(yypvt[-4].opval), OP_HSLICE))));
+ expect = XOPERATOR; } break;
+case 110:
+# line 446 "perly.y"
+{ yyval.opval = newBINOP(OP_DELETE, 0, oopsHV(yypvt[-4].opval), jmaybe(yypvt[-2].opval));
+ expect = XOPERATOR; } break;
+case 111:
+# line 449 "perly.y"
+{ yyval.opval = newBINOP(OP_DELETE, 0, oopsHV(yypvt[-5].opval), jmaybe(yypvt[-3].opval));
+ expect = XOPERATOR; } break;
+case 112:
+# line 452 "perly.y"
+{ yyval.opval = yypvt[-0].opval; } break;
+case 113:
+# line 454 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUBR, 0,
+ scalar(yypvt[-0].opval)); } break;
+case 114:
+# line 457 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_STACKED, scalar(yypvt[-2].opval)); } break;
+case 115:
+# line 459 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_STACKED,
+ list(prepend_elem(OP_LIST, scalar(yypvt[-3].opval), yypvt[-1].opval))); } break;
+case 116:
+# line 462 "perly.y"
+{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yypvt[-0].opval));
+ allgvs = TRUE;} break;
+case 117:
+# line 465 "perly.y"
+{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yypvt[-0].opval)); } break;
+case 118:
+# line 467 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED,
+ list(prepend_elem(OP_LIST,
+ scalar(newCVREF(scalar(yypvt[-2].opval))), newNULLLIST()))); } break;
+case 119:
+# line 471 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED,
+ list(prepend_elem(OP_LIST,
+ scalar(newCVREF(scalar(yypvt[-3].opval))),
+ yypvt[-1].opval))); } break;
+case 120:
+# line 476 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED,
+ list(prepend_elem(OP_LIST,
+ scalar(newCVREF(scalar(yypvt[-2].opval))), newNULLLIST())));} break;
+case 121:
+# line 480 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED,
+ list(prepend_elem(OP_LIST,
+ scalar(newCVREF(scalar(yypvt[-3].opval))),
+ yypvt[-1].opval))); } break;
+case 122:
+# line 485 "perly.y"
+{ yyval.opval = newOP(yypvt[-0].ival, OPf_SPECIAL); } break;
+case 123:
+# line 487 "perly.y"
+{ yyval.opval = newPVOP(yypvt[-1].ival, 0,
+ savestr(SvPVnx(((SVOP*)yypvt[-0].opval)->op_sv)));
+ op_free(yypvt[-0].opval); } break;
+case 124:
+# line 491 "perly.y"
+{ yyval.opval = newOP(yypvt[-0].ival, 0); } break;
+case 125:
+# line 493 "perly.y"
+{ yyval.opval = newUNOP(yypvt[-1].ival, 0, yypvt[-0].opval); } break;
+case 126:
+# line 495 "perly.y"
+{ yyval.opval = newUNOP(yypvt[-1].ival, 0, yypvt[-0].opval); } break;
+case 127:
+# line 497 "perly.y"
+{ yyval.opval = newOP(yypvt[-0].ival, 0); } break;
+case 128:
+# line 499 "perly.y"
+{ yyval.opval = newOP(yypvt[-2].ival, 0); } break;
+case 129:
+# line 501 "perly.y"
+{ yyval.opval = newOP(yypvt[-2].ival, OPf_SPECIAL); } break;
+case 130:
+# line 503 "perly.y"
+{ yyval.opval = newUNOP(yypvt[-3].ival, 0, yypvt[-1].opval); } break;
+case 131:
+# line 505 "perly.y"
+{ yyval.opval = pmruntime(yypvt[-3].opval, yypvt[-1].opval, Nullop); } break;
+case 132:
+# line 507 "perly.y"
+{ yyval.opval = pmruntime(yypvt[-5].opval, yypvt[-3].opval, yypvt[-1].opval); } break;
+case 135:
+# line 513 "perly.y"
+{ yyval.opval = newNULLLIST(); } break;
+case 136:
+# line 515 "perly.y"
+{ yyval.opval = yypvt[-0].opval; } break;
+case 137:
+# line 519 "perly.y"
+{ yyval.opval = newCVREF(yypvt[-0].opval); } break;
+case 138:
+# line 523 "perly.y"
+{ yyval.opval = newSVREF(yypvt[-0].opval); } break;
+case 139:
+# line 527 "perly.y"
+{ yyval.opval = newAVREF(yypvt[-0].opval); } break;
+case 140:
+# line 531 "perly.y"
+{ yyval.opval = newHVREF(yypvt[-0].opval); } break;
+case 141:
+# line 535 "perly.y"
+{ yyval.opval = newAVREF(yypvt[-0].opval); } break;
+case 142:
+# line 539 "perly.y"
+{ yyval.opval = newGVREF(yypvt[-0].opval); } break;
+case 143:
+# line 543 "perly.y"
+{ yyval.opval = scalar(yypvt[-0].opval); } break;
+case 144:
+# line 545 "perly.y"
+{ yyval.opval = scalar(yypvt[-0].opval); } break;
+case 145:
+# line 547 "perly.y"
+{ yyval.opval = scalar(scope(yypvt[-0].opval)); } break;
+case 146:
+# line 552 "perly.y"
+{ yyval.ival = 1; } break;
+case 147:
+# line 554 "perly.y"
+{ yyval.ival = 0; } break;
+case 148:
+# line 558 "perly.y"
+{ yyval.ival = 1; } break;
+case 149:
+# line 560 "perly.y"
+{ yyval.ival = 0; } break;
+case 150:
+# line 564 "perly.y"
+{ yyval.ival = 1; } break;
+case 151:
+# line 566 "perly.y"
+{ yyval.ival = 0; } break;
+ }
+ goto yystack; /* reset registers in driver code */
+}
######################################################
# Plan still unknown
- *) mv $input $output;
+ *) sed -e 's/Received token/ *** Received token/' $input >$output;
esac
rm -rf $tmp $input
--- /dev/null
+
+typedef union {
+ I32 ival;
+ char *pval;
+ OP *opval;
+ GV *gvval;
+} YYSTYPE;
+extern YYSTYPE yylval;
+# define WORD 257
+# define METHOD 258
+# define THING 259
+# define PMFUNC 260
+# define LABEL 261
+# define FORMAT 262
+# define SUB 263
+# define PACKAGE 264
+# define WHILE 265
+# define UNTIL 266
+# define IF 267
+# define UNLESS 268
+# define ELSE 269
+# define ELSIF 270
+# define CONTINUE 271
+# define FOR 272
+# define LOOPEX 273
+# define DOTDOT 274
+# define FUNC0 275
+# define FUNC1 276
+# define FUNC 277
+# define RELOP 278
+# define EQOP 279
+# define MULOP 280
+# define ADDOP 281
+# define DOLSHARP 282
+# define DO 283
+# define LOCAL 284
+# define DELETE 285
+# define HASHBRACK 286
+# define LSTOP 287
+# define OROR 288
+# define ANDAND 289
+# define BITOROP 290
+# define BITANDOP 291
+# define UNIOP 292
+# define SHIFTOP 293
+# define MATCHOP 294
+# define ARROW 295
+# define UMINUS 296
+# define REFGEN 297
+# define POWOP 298
+# define PREINC 299
+# define PREDEC 300
+# define POSTINC 301
+# define POSTDEC 302
+extern YYSTYPE yylval;
-/* $RCSfile: perly.y,v $$Revision: 4.0.1.5 $$Date: 92/06/11 21:12:50 $
+/* $RCSfile: perly.y,v $$Revision: 4.1 $$Date: 92/08/07 18:26:16 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: perly.y,v $
+ * Revision 4.1 92/08/07 18:26:16 lwall
+ *
* Revision 4.0.1.5 92/06/11 21:12:50 lwall
* patch34: expectterm incorrectly set to indicate start of program or block
*
*/
%{
-#include "INTERN.h"
+#include "EXTERN.h"
#include "perl.h"
/*SUPPRESS 530*/
/*SUPPRESS 593*/
/*SUPPRESS 595*/
-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;
+ I32 ival;
+ char *pval;
+ OP *opval;
+ GV *gvval;
}
%token <ival> '{' ')'
-%token <cval> WORD LABEL
-%token <ival> APPEND OPEN SSELECT LOOPEX DOTDOT
-%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
-%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
-%token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
-%token <ival> FUNC0 FUNC1 FUNC2 FUNC2x FUNC3 FUNC4 FUNC5 HSHFUN HSHFUN3
-%token <ival> FLIST2 SUB FILETEST LOCAL DELETE
-%token <ival> RELOP EQOP MULOP ADDOP PACKAGE AMPER
-%token <formval> FORMLIST
-%token <stabval> REG ARYLEN ARY HSH STAR
-%token <arg> SUBST PATTERN
-%token <arg> RSTRING TRANS
-
-%type <ival> prog decl format remember crp
-%type <cmdval> block lineseq line loop cond sideff nexpr else
-%type <arg> expr sexpr cexpr csexpr term handle aryword hshword
-%type <arg> texpr listop bareword
-%type <cval> label
-%type <compval> compblock
-
-%nonassoc <ival> LISTOP
+%token <opval> WORD METHOD THING PMFUNC
+%token <pval> LABEL
+%token <ival> FORMAT SUB PACKAGE
+%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
+%token <ival> LOOPEX DOTDOT
+%token <ival> FUNC0 FUNC1 FUNC
+%token <ival> RELOP EQOP MULOP ADDOP
+%token <ival> DOLSHARP DO LOCAL DELETE HASHBRACK
+
+%type <ival> prog decl format remember crp crb crhb
+%type <opval> block lineseq line loop cond nexpr else
+%type <opval> expr sexpr term scalar ary hsh arylen star amper sideff
+%type <opval> listexpr indirob
+%type <opval> texpr listop
+%type <pval> label
+%type <opval> cont
+
+%nonassoc <ival> LSTOP
%left ','
%right '='
%right '?' ':'
%nonassoc DOTDOT
%left OROR
%left ANDAND
-%left '|' '^'
-%left '&'
+%left <ival> BITOROP
+%left <ival> BITANDOP
%nonassoc EQOP
%nonassoc RELOP
%nonassoc <ival> UNIOP
-%nonassoc FILETEST
-%left LS RS
+%left <ival> SHIFTOP
%left ADDOP
%left MULOP
-%left MATCH NMATCH
-%right '!' '~' UMINUS
-%right POW
-%nonassoc INC DEC
+%left <ival> MATCHOP ARROW
+%right '!' '~' UMINUS REFGEN
+%right <ival> POWOP
+%nonassoc PREINC PREDEC POSTINC POSTDEC
%left '('
%% /* RULES */
#if defined(YYDEBUG) && defined(DEBUGGING)
yydebug = (debug & 1);
#endif
- expectterm = 2;
+ expect = XBLOCK;
}
/*CONTINUED*/ lineseq
- { if (in_eval)
- eval_root = block_head($2);
+ { if (in_eval) {
+ eval_root = newUNOP(OP_LEAVEEVAL, 0, $2);
+ eval_start = linklist(eval_root);
+ eval_root->op_next = 0;
+ peep(eval_start);
+ }
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,1,$3,$5); }
+ main_root = block_head(scalar($2), &main_start);
+ }
;
block : '{' remember lineseq '}'
- { $$ = block_head($3);
- if (cmdline > (line_t)$1)
- cmdline = $1;
- if (savestack->ary_fill > $2)
- restorelist($2);
- expectterm = 2; }
+ { $$ = scalarseq($3);
+ if (copline > (line_t)$1)
+ copline = $1;
+ if (savestack_ix > $2)
+ leave_scope($2);
+ expect = XBLOCK; }
;
remember: /* NULL */ /* in case they push a package name */
- { $$ = savestack->ary_fill; }
+ { $$ = savestack_ix; }
;
lineseq : /* NULL */
- { $$ = Nullcmd; }
+ { $$ = Nullop; }
+ | lineseq decl
+ { $$ = $1; }
| lineseq line
- { $$ = append_line($1,$2); }
+ { $$ = append_list(OP_LINESEQ, $1, $2); pad_reset(); }
;
-line : decl
- { $$ = Nullcmd; }
- | label cond
- { $$ = add_label($1,$2); }
+line : label cond
+ { $$ = newSTATEOP(0, $1, $2); }
| loop /* loops add their own labels */
| label ';'
{ if ($1 != Nullch) {
- $$ = add_label($1, make_acmd(C_EXPR, Nullstab,
- Nullarg, Nullarg) );
+ $$ = newSTATEOP(0, $1, newOP(OP_NULL, 0));
}
else {
- $$ = Nullcmd;
- cmdline = NOLINE;
+ $$ = Nullop;
+ copline = NOLINE;
}
- expectterm = 2; }
+ expect = XBLOCK; }
| label sideff ';'
- { $$ = add_label($1,$2);
- expectterm = 2; }
+ { $$ = newSTATEOP(0, $1, $2);
+ expect = XBLOCK; }
;
sideff : error
- { $$ = Nullcmd; }
+ { $$ = Nullop; }
| expr
- { $$ = make_acmd(C_EXPR, Nullstab, $1, Nullarg); }
+ { $$ = $1; }
| expr IF expr
- { $$ = addcond(
- make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); }
+ { $$ = newLOGOP(OP_AND, 0, $3, $1); }
| expr UNLESS expr
- { $$ = addcond(invert(
- make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); }
+ { $$ = newLOGOP(OP_OR, 0, $3, $1); }
| expr WHILE expr
- { $$ = addloop(
- make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); }
+ { $$ = newLOOPOP(0, 1, scalar($3), $1, Nullop); }
| 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_icmd(C_IF,cmd_to_arg($2),$3); }
- | UNLESS block compblock
- { cmdline = $1;
- $$ = invert(make_icmd(C_IF,cmd_to_arg($2),$3)); }
- ;
-
-loop : label WHILE '(' texpr ')' compblock
- { cmdline = $2;
- $$ = wopt(add_label($1,
- make_ccmd(C_WHILE,1,$4,$6) )); }
- | label UNTIL '(' expr ')' compblock
- { cmdline = $2;
- $$ = wopt(add_label($1,
- invert(make_ccmd(C_WHILE,1,$4,$6)) )); }
- | label WHILE block compblock
- { cmdline = $2;
- $$ = wopt(add_label($1,
- make_ccmd(C_WHILE, 1, cmd_to_arg($3),$4) )); }
- | label UNTIL block compblock
- { cmdline = $2;
- $$ = wopt(add_label($1,
- invert(make_ccmd(C_WHILE,1,cmd_to_arg($3),$4)) )); }
- | label FOR REG '(' expr crp 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 )),
- listish(make_list($5)),
- Nullarg)),
- Nullarg),
- wopt(over($3,add_label($1,
- make_ccmd(C_WHILE, 0,
- 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,1,$5,$7) )));
- }
- }
- | label FOR '(' expr crp 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 )),
- listish(make_list($4)),
- Nullarg)),
- Nullarg),
- wopt(over(defstab,add_label($1,
- make_ccmd(C_WHILE, 0,
- 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,1,$4,$6) )));
- }
- }
+ { $$ = newLOOPOP(0, 1, invert(scalar($3)), $1, Nullop);}
+ ;
+
+else : /* NULL */
+ { $$ = Nullop; }
+ | ELSE block
+ { $$ = scope($2); }
+ | ELSIF '(' expr ')' block else
+ { copline = $1;
+ $$ = newCONDOP(0, $3, scope($5), $6); }
+ ;
+
+cond : IF '(' expr ')' block else
+ { copline = $1;
+ $$ = newCONDOP(0, $3, scope($5), $6); }
+ | UNLESS '(' expr ')' block else
+ { copline = $1;
+ $$ = newCONDOP(0,
+ invert(scalar($3)), scope($5), $6); }
+ | IF block block else
+ { copline = $1;
+ $$ = newCONDOP(0, scope($2), scope($3), $4); }
+ | UNLESS block block else
+ { copline = $1;
+ $$ = newCONDOP(0, invert(scalar(scope($2))),
+ scope($3), $4); }
+ ;
+
+cont : /* NULL */
+ { $$ = Nullop; }
+ | CONTINUE block
+ { $$ = scope($2); }
+ ;
+
+loop : label WHILE '(' texpr ')' block cont
+ { copline = $2;
+ $$ = newSTATEOP(0, $1,
+ newWHILEOP(0, 1, Nullop, $4, $6, $7) ); }
+ | label UNTIL '(' expr ')' block cont
+ { copline = $2;
+ $$ = newSTATEOP(0, $1,
+ newWHILEOP(0, 1, Nullop,
+ invert(scalar($4)), $6, $7) ); }
+ | label WHILE block block cont
+ { copline = $2;
+ $$ = newSTATEOP(0, $1,
+ newWHILEOP(0, 1, Nullop,
+ scope($3), $4, $5) ); }
+ | label UNTIL block block cont
+ { copline = $2;
+ $$ = newSTATEOP(0, $1,
+ newWHILEOP(0, 1, Nullop,
+ invert(scalar(scope($3))), $4, $5)); }
+ | label FOR scalar '(' expr crp block cont
+ { $$ = newFOROP(0, $1, $2, ref($3, OP_ENTERLOOP),
+ $5, $7, $8); }
+ | label FOR '(' expr crp block cont
+ { $$ = newFOROP(0, $1, $2, Nullop, $4, $6, $7); }
| 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,1,$6,yyval.compval) ))); }
- | label compblock /* a block is a loop that happens once */
- { $$ = add_label($1,make_ccmd(C_BLOCK,1,Nullarg,$2)); }
+ { copline = $2;
+ $$ = append_elem(OP_LINESEQ,
+ newSTATEOP(0, $1, scalar($4)),
+ newSTATEOP(0, $1,
+ newWHILEOP(0, 1, Nullop,
+ scalar($6), $10, scalar($8)) )); }
+ | label block cont /* a block is a loop that happens once */
+ { $$ = newSTATEOP(0,
+ $1, newWHILEOP(0, 1, Nullop, Nullop, $2, $3)); }
;
nexpr : /* NULL */
- { $$ = Nullcmd; }
+ { $$ = Nullop; }
| sideff
;
texpr : /* NULL means true */
- { (void)scanstr("1",SCAN_DEF); $$ = yylval.arg; }
+ { (void)scan_num("1"); $$ = yylval.opval; }
| expr
;
{ $$ = 0; }
;
-format : FORMAT WORD '=' FORMLIST
- { if (strEQ($2,"stdout"))
- make_form(stabent("STDOUT",TRUE),$4);
- else if (strEQ($2,"stderr"))
- make_form(stabent("STDERR",TRUE),$4);
- else
- make_form(stabent($2,TRUE),$4);
- Safefree($2); $2 = Nullch; }
- | FORMAT '=' FORMLIST
- { make_form(stabent("STDOUT",TRUE),$3); }
+format : FORMAT WORD block
+ { newFORM($1, $2, $3); }
+ | FORMAT block
+ { newFORM($1, Nullop, $2); }
;
subrout : SUB WORD block
- { make_sub($2,$3);
- cmdline = NOLINE;
- if (savestack->ary_fill > $1)
- restorelist($1); }
+ { newSUB($1, $2, $3); }
;
package : PACKAGE WORD ';'
- { char tmpbuf[256];
- STAB *tmpstab;
-
- savehptr(&curstash);
- saveitem(curstname);
- str_set(curstname,$2);
- sprintf(tmpbuf,"'_%s",$2);
- tmpstab = stabent(tmpbuf,TRUE);
- if (!stab_xhash(tmpstab))
- stab_xhash(tmpstab) = hnew(0);
- curstash = stab_xhash(tmpstab);
- if (!curstash->tbl_name)
- curstash->tbl_name = savestr($2);
- curstash->tbl_coeffsize = 0;
- Safefree($2); $2 = Nullch;
- cmdline = NOLINE;
- expectterm = 2;
- }
- ;
-
-cexpr : ',' expr
- { $$ = $2; }
+ { package($2); }
;
expr : expr ',' sexpr
- { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg); }
+ { $$ = append_elem(OP_LIST, $1, $3); }
| sexpr
;
-csexpr : ',' sexpr
- { $$ = $2; }
+listop : LSTOP indirob listexpr
+ { $$ = convert($1, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF($2), $3) ); }
+ | FUNC '(' indirob listexpr ')'
+ { $$ = convert($1, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF($3), $4) ); }
+ | indirob ARROW LSTOP listexpr
+ { $$ = convert($3, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF($1), $4) ); }
+ | indirob ARROW FUNC '(' listexpr ')'
+ { $$ = convert($3, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF($1), $5) ); }
+ | term ARROW METHOD '(' listexpr ')'
+ { $$ = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL,
+ prepend_elem(OP_LIST, newMETHOD($1,$3), $5)); }
+ | METHOD indirob listexpr
+ { $$ = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL,
+ prepend_elem(OP_LIST, newMETHOD($2,$1), $3)); }
+ | LSTOP listexpr
+ { $$ = convert($1, 0, $2); }
+ | FUNC '(' listexpr ')'
+ { $$ = convert($1, 0, $3); }
;
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)); }
+ { $$ = newASSIGNOP(OPf_STACKED, $1, $3); }
+ | sexpr POWOP '=' sexpr
+ { $$ = newBINOP($2, OPf_STACKED,
+ ref(scalar($1), $2), scalar($4)); }
| sexpr MULOP '=' sexpr
- { $$ = l(make_op($2, 2, $1, $4, Nullarg)); }
+ { $$ = newBINOP($2, OPf_STACKED,
+ ref(scalar($1), $2), scalar($4)); }
| 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); }
+ { $$ = newBINOP($2, OPf_STACKED,
+ ref(scalar($1), $2), scalar($4));}
+ | sexpr SHIFTOP '=' sexpr
+ { $$ = newBINOP($2, OPf_STACKED,
+ ref(scalar($1), $2), scalar($4)); }
+ | sexpr BITANDOP '=' sexpr
+ { $$ = newBINOP($2, OPf_STACKED,
+ ref(scalar($1), $2), scalar($4)); }
+ | sexpr BITOROP '=' sexpr
+ { $$ = newBINOP($2, OPf_STACKED,
+ ref(scalar($1), $2), scalar($4)); }
+ | sexpr ANDAND '=' sexpr
+ { $$ = newLOGOP(OP_ANDASSIGN, 0,
+ ref(scalar($1), OP_ANDASSIGN),
+ newUNOP(OP_SASSIGN, 0, scalar($4))); }
+ | sexpr OROR '=' sexpr
+ { $$ = newLOGOP(OP_ORASSIGN, 0,
+ ref(scalar($1), OP_ORASSIGN),
+ newUNOP(OP_SASSIGN, 0, scalar($4))); }
+
+
+ | sexpr POWOP sexpr
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
| sexpr MULOP sexpr
- { if ($2 == O_REPEAT)
- $1 = listish($1);
- $$ = make_op($2, 2, $1, $3, Nullarg);
- if ($2 == O_REPEAT) {
- if ($$[1].arg_type != A_EXPR ||
- $$[1].arg_ptr.arg_arg->arg_type != O_LIST)
- $$[1].arg_flags &= ~AF_ARYOK;
- } }
+ { if ($2 != OP_REPEAT)
+ scalar($1);
+ $$ = newBINOP($2, 0, $1, scalar($3)); }
| 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); }
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | sexpr SHIFTOP sexpr
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
| sexpr RELOP sexpr
- { $$ = make_op($2, 2, $1, $3, Nullarg); }
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
| 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); }
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | sexpr BITANDOP sexpr
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | sexpr BITOROP sexpr
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
| sexpr DOTDOT sexpr
- { arg4 = Nullarg;
- $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg);
- $$[0].arg_flags |= $2; }
+ { $$ = newRANGE($2, scalar($1), scalar($3));}
| sexpr ANDAND sexpr
- { $$ = make_op(O_AND, 2, $1, $3, Nullarg); }
+ { $$ = newLOGOP(OP_AND, 0, $1, $3); }
| sexpr OROR sexpr
- { $$ = make_op(O_OR, 2, $1, $3, Nullarg); }
+ { $$ = newLOGOP(OP_OR, 0, $1, $3); }
| 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); }
+ { $$ = newCONDOP(0, $1, $3, $5); }
+ | sexpr MATCHOP sexpr
+ { $$ = bind_match($2, $1, $3); }
| term
{ $$ = $1; }
;
term : '-' term %prec UMINUS
- { $$ = make_op(O_NEGATE, 1, $2, Nullarg, Nullarg); }
+ { $$ = newUNOP(OP_NEGATE, 0, scalar($2)); }
| '+' term %prec UMINUS
{ $$ = $2; }
| '!' term
- { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg); }
+ { $$ = newUNOP(OP_NOT, 0, scalar($2)); }
| '~' 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);
- Safefree($2); $2 = Nullch;
- }
- | 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 crp
- { $$ = l(localize(make_op(O_ASSIGN, 1,
- localize(listish(make_list($3))),
- Nullarg,Nullarg))); }
+ { $$ = newUNOP(OP_COMPLEMENT, 0, scalar($2));}
+ | REFGEN term
+ { $$ = newUNOP(OP_REFGEN, 0, ref($2, OP_REFGEN)); }
+ | term POSTINC
+ { $$ = newUNOP(OP_POSTINC, 0,
+ ref(scalar($1), OP_POSTINC)); }
+ | term POSTDEC
+ { $$ = newUNOP(OP_POSTDEC, 0,
+ ref(scalar($1), OP_POSTDEC)); }
+ | PREINC term
+ { $$ = newUNOP(OP_PREINC, 0,
+ ref(scalar($2), OP_PREINC)); }
+ | PREDEC term
+ { $$ = newUNOP(OP_PREDEC, 0,
+ ref(scalar($2), OP_PREDEC)); }
+ | LOCAL sexpr %prec UNIOP
+ { $$ = localize($2); }
| '(' expr crp
- { $$ = make_list($2); }
+ { $$ = sawparens($2); }
| '(' ')'
- { $$ = make_list(Nullarg); }
- | DO sexpr %prec FILETEST
- { $$ = 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);
- expectterm = FALSE; }
- | '(' expr crp '[' expr ']' %prec '('
- { $$ = make_op(O_LSLICE, 3,
- Nullarg,
- listish(make_list($5)),
- listish(make_list($2))); }
- | '(' ')' '[' expr ']' %prec '('
- { $$ = make_op(O_LSLICE, 3,
- Nullarg,
- listish(make_list($4)),
- 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);
- expectterm = FALSE; }
- | DELETE REG '{' expr ';' '}' %prec '('
- { $$ = make_op(O_DELETE, 2,
- stab2arg(A_STAB,hadd($2)),
- jmaybe($4),
- Nullarg);
- expectterm = FALSE; }
- | DELETE '(' REG '{' expr ';' '}' ')' %prec '('
- { $$ = make_op(O_DELETE, 2,
- stab2arg(A_STAB,hadd($3)),
- jmaybe($5),
- Nullarg);
- expectterm = FALSE; }
- | ARYLEN %prec '('
- { $$ = stab2arg(A_ARYLEN,$1); }
- | RSTRING %prec '('
+ { $$ = newNULLLIST(); }
+ | '[' expr crb %prec '('
+ { $$ = newANONLIST($2); }
+ | '[' ']' %prec '('
+ { $$ = newANONLIST(Nullop); }
+ | HASHBRACK expr crhb %prec '('
+ { $$ = newANONHASH($2); }
+ | HASHBRACK ';' '}' %prec '('
+ { $$ = newANONHASH(Nullop); }
+ | scalar %prec '('
{ $$ = $1; }
- | PATTERN %prec '('
+ | star %prec '('
{ $$ = $1; }
- | SUBST %prec '('
+ | scalar '[' expr ']' %prec '('
+ { $$ = newBINOP(OP_AELEM, 0, oopsAV($1), scalar($3)); }
+ | term ARROW '[' expr ']' %prec '('
+ { $$ = newBINOP(OP_AELEM, 0,
+ scalar(ref(newAVREF($1),OP_RV2AV)),
+ scalar($4));}
+ | hsh %prec '('
{ $$ = $1; }
- | TRANS %prec '('
+ | ary %prec '('
{ $$ = $1; }
- | DO WORD '(' expr crp
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- make_list($4),
- Nullarg); Safefree($2); $2 = Nullch;
- $$->arg_flags |= AF_DEPR; }
- | AMPER WORD '(' expr crp
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- make_list($4),
- Nullarg); Safefree($2); $2 = Nullch; }
+ | arylen %prec '('
+ { $$ = newUNOP(OP_AV2ARYLEN, 0, ref($1, OP_AV2ARYLEN));}
+ | scalar '{' expr ';' '}' %prec '('
+ { $$ = newBINOP(OP_HELEM, 0, oopsHV($1), jmaybe($3));
+ expect = XOPERATOR; }
+ | term ARROW '{' expr ';' '}' %prec '('
+ { $$ = newBINOP(OP_HELEM, 0,
+ scalar(ref(newHVREF($1),OP_RV2HV)),
+ jmaybe($4));
+ expect = XOPERATOR; }
+ | '(' expr crp '[' expr ']' %prec '('
+ { $$ = newSLICEOP(0, $5, $2); }
+ | '(' ')' '[' expr ']' %prec '('
+ { $$ = newSLICEOP(0, $4, Nullop); }
+ | ary '[' expr ']' %prec '('
+ { $$ = prepend_elem(OP_ASLICE,
+ newOP(OP_PUSHMARK, 0),
+ list(
+ newLISTOP(OP_ASLICE, 0,
+ list($3),
+ ref($1, OP_ASLICE)))); }
+ | ary '{' expr ';' '}' %prec '('
+ { $$ = prepend_elem(OP_HSLICE,
+ newOP(OP_PUSHMARK, 0),
+ list(
+ newLISTOP(OP_HSLICE, 0,
+ list($3),
+ ref(oopsHV($1), OP_HSLICE))));
+ expect = XOPERATOR; }
+ | DELETE scalar '{' expr ';' '}' %prec '('
+ { $$ = newBINOP(OP_DELETE, 0, oopsHV($2), jmaybe($4));
+ expect = XOPERATOR; }
+ | DELETE '(' scalar '{' expr ';' '}' ')' %prec '('
+ { $$ = newBINOP(OP_DELETE, 0, oopsHV($3), jmaybe($5));
+ expect = XOPERATOR; }
+ | THING %prec '('
+ { $$ = $1; }
+ | amper
+ { $$ = newUNOP(OP_ENTERSUBR, 0,
+ scalar($1)); }
+ | amper '(' ')'
+ { $$ = newUNOP(OP_ENTERSUBR, OPf_STACKED, scalar($1)); }
+ | amper '(' expr crp
+ { $$ = newUNOP(OP_ENTERSUBR, OPf_STACKED,
+ list(prepend_elem(OP_LIST, scalar($1), $3))); }
+ | DO sexpr %prec UNIOP
+ { $$ = newUNOP(OP_DOFILE, 0, scalar($2));
+ allgvs = TRUE;}
+ | DO block %prec '('
+ { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); }
| DO WORD '(' ')'
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- make_list(Nullarg),
- Nullarg);
- Safefree($2); $2 = Nullch;
- $$->arg_flags |= AF_DEPR; }
- | AMPER WORD '(' ')'
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- make_list(Nullarg),
- Nullarg);
- Safefree($2); $2 = Nullch;
- }
- | AMPER WORD
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- Nullarg,
- Nullarg);
- Safefree($2); $2 = Nullch;
- }
- | DO REG '(' expr crp
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_STAB,$2),
- make_list($4),
- Nullarg);
- $$->arg_flags |= AF_DEPR; }
- | AMPER REG '(' expr crp
- { $$ = 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);
- $$->arg_flags |= AF_DEPR; }
- | 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); }
+ { $$ = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED,
+ list(prepend_elem(OP_LIST,
+ scalar(newCVREF(scalar($2))), newNULLLIST()))); }
+ | DO WORD '(' expr crp
+ { $$ = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED,
+ list(prepend_elem(OP_LIST,
+ scalar(newCVREF(scalar($2))),
+ $4))); }
+ | DO scalar '(' ')'
+ { $$ = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED,
+ list(prepend_elem(OP_LIST,
+ scalar(newCVREF(scalar($2))), newNULLLIST())));}
+ | DO scalar '(' expr crp
+ { $$ = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED,
+ list(prepend_elem(OP_LIST,
+ scalar(newCVREF(scalar($2))),
+ $4))); }
| LOOPEX
- { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); }
+ { $$ = newOP($1, OPf_SPECIAL); }
| LOOPEX WORD
- { $$ = make_op($1,1,cval_to_arg($2),
- Nullarg,Nullarg); }
+ { $$ = newPVOP($1, 0,
+ savestr(SvPVnx(((SVOP*)$2)->op_sv)));
+ op_free($2); }
| UNIOP
- { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); }
+ { $$ = newOP($1, 0); }
| UNIOP block
- { $$ = make_op($1,1,cmd_to_arg($2),Nullarg,Nullarg); }
+ { $$ = newUNOP($1, 0, $2); }
| UNIOP sexpr
- { $$ = make_op($1,1,$2,Nullarg,Nullarg); }
- | SSELECT
- { $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);}
- | SSELECT WORD
- { $$ = make_op(O_SELECT, 1,
- stab2arg(A_WORD,stabent($2,TRUE)),
- Nullarg,
- Nullarg);
- Safefree($2); $2 = Nullch; }
- | SSELECT '(' handle ')'
- { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg); }
- | SSELECT '(' 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);
- Safefree($2); $2 = Nullch;
- }
- | OPEN '(' WORD ')'
- { $$ = make_op(O_OPEN, 2,
- stab2arg(A_WORD,stabent($3,TRUE)),
- stab2arg(A_STAB,stabent($3,TRUE)),
- Nullarg);
- Safefree($3); $3 = Nullch;
- }
- | 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); $2 = Nullch; }
- | 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 ',' expr crp
- { $$ = make_op($1, 2,
- $3,
- make_list($5),
- 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 '('
- { static char p[]="/\\s+/";
- char *oldend = bufend;
- ARG *oldarg = yylval.arg;
-
- bufend=p+5;
- (void)scanpat(p);
- bufend=oldend;
- $$ = make_split(defstab,yylval.arg,Nullarg);
- yylval.arg = oldarg; }
- | 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 crp
- { $$ = 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)); }
+ { $$ = newUNOP($1, 0, $2); }
| FUNC0
- { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); }
+ { $$ = newOP($1, 0); }
| FUNC0 '(' ')'
- { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); }
+ { $$ = newOP($1, 0); }
| FUNC1 '(' ')'
- { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); }
+ { $$ = newOP($1, OPf_SPECIAL); }
| FUNC1 '(' expr ')'
- { $$ = make_op($1, 1, $3, Nullarg, Nullarg); }
- | 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); }
- | FUNC2x '(' sexpr csexpr ')'
- { $$ = make_op($1, 2, $3, $4, Nullarg);
- if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE)
- fbmcompile($$[2].arg_ptr.arg_str,0); }
- | FUNC2x '(' sexpr csexpr cexpr ')'
- { $$ = make_op($1, 3, $3, $4, $5);
- 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); }
- | FUNC4 '(' sexpr csexpr csexpr cexpr ')'
- { arg4 = $6;
- $$ = make_op($1, 4, $3, $4, $5); }
- | FUNC5 '(' sexpr csexpr csexpr csexpr cexpr ')'
- { arg4 = $6; arg5 = $7;
- $$ = make_op($1, 5, $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); }
- | bareword
+ { $$ = newUNOP($1, 0, $3); }
+ | PMFUNC '(' sexpr ')'
+ { $$ = pmruntime($1, $3, Nullop); }
+ | PMFUNC '(' sexpr ',' sexpr ')'
+ { $$ = pmruntime($1, $3, $5); }
+ | WORD
| 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);
- Safefree($2); $2 = Nullch;
- }
- | LISTOP WORD expr
- { $$ = make_op($1,2,
- stab2arg(A_WORD,stabent($2,TRUE)),
- maybelistish($1,make_list($3)),
- Nullarg); Safefree($2); $2 = Nullch; }
- | LISTOP REG expr
- { $$ = make_op($1,2,
- stab2arg(A_STAB,$2),
- maybelistish($1,make_list($3)),
- Nullarg); }
- | LISTOP block expr
- { $$ = make_op($1,2,
- cmd_to_arg($2),
- maybelistish($1,make_list($3)),
- Nullarg); }
- ;
-
-handle : WORD
- { $$ = stab2arg(A_WORD,stabent($1,TRUE));
- Safefree($1); $1 = Nullch;}
- | sexpr
+listexpr: /* NULL */
+ { $$ = newNULLLIST(); }
+ | expr
+ { $$ = $1; }
+ ;
+
+amper : '&' indirob
+ { $$ = newCVREF($2); }
;
-aryword : WORD
- { $$ = stab2arg(A_WORD,aadd(stabent($1,TRUE)));
- Safefree($1); $1 = Nullch; }
- | ARY
- { $$ = stab2arg(A_STAB,$1); }
+scalar : '$' indirob
+ { $$ = newSVREF($2); }
;
-hshword : WORD
- { $$ = stab2arg(A_WORD,hadd(stabent($1,TRUE)));
- Safefree($1); $1 = Nullch; }
- | HSH
- { $$ = stab2arg(A_STAB,$1); }
+ary : '@' indirob
+ { $$ = newAVREF($2); }
+ ;
+
+hsh : '%' indirob
+ { $$ = newHVREF($2); }
+ ;
+
+arylen : DOLSHARP indirob
+ { $$ = newAVREF($2); }
+ ;
+
+star : '*' indirob
+ { $$ = newGVREF($2); }
+ ;
+
+indirob : WORD
+ { $$ = scalar($1); }
+ | scalar
+ { $$ = scalar($1); }
+ | block
+ { $$ = scalar(scope($1)); }
+
;
crp : ',' ')'
{ $$ = 0; }
;
-/*
- * NOTE: The following entry must stay at the end of the file so that
- * reduce/reduce conflicts resolve to it only if it's the only option.
- */
+crb : ',' ']'
+ { $$ = 1; }
+ | ']'
+ { $$ = 0; }
+ ;
+
+crhb : ',' ';' '}'
+ { $$ = 1; }
+ | ';' '}'
+ { $$ = 0; }
+ ;
-bareword: WORD
- { char *s;
- $$ = op_new(1);
- $$->arg_type = O_ITEM;
- $$[1].arg_type = A_SINGLE;
- $$[1].arg_ptr.arg_str = str_make($1,0);
- for (s = $1; *s && isLOWER(*s); s++) ;
- if (dowarn && !*s)
- warn(
- "\"%s\" may clash with future reserved word",
- $1 );
- Safefree($1); $1 = Nullch;
- }
- ;
%% /* PROGRAM */
+++ /dev/null
-/* $RCSfile: perly.y,v $$Revision: 4.0.1.5 $$Date: 92/06/11 21:12:50 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: perly.y,v $
- * Revision 4.0.1.5 92/06/11 21:12:50 lwall
- * patch34: expectterm incorrectly set to indicate start of program or block
- *
- * Revision 4.0.1.4 92/06/08 17:33:25 lwall
- * patch20: one of the backdoors to expectterm was on the wrong reduction
- *
- * Revision 4.0.1.3 92/06/08 15:18:16 lwall
- * patch20: an expression may now start with a bareword
- * patch20: relaxed requirement for semicolon at the end of a block
- * patch20: added ... as variant on ..
- * patch20: fixed double debug break in foreach with implicit array assignment
- * patch20: if {block} {block} didn't work any more
- * patch20: deleted some minor memory leaks
- *
- * Revision 4.0.1.2 91/11/05 18:17:38 lwall
- * patch11: extra comma at end of list is now allowed in more places (Hi, Felix!)
- * patch11: once-thru blocks didn't display right in the debugger
- * patch11: debugger got confused over nested subroutine definitions
- *
- * Revision 4.0.1.1 91/06/07 11:42:34 lwall
- * patch4: new copyright notice
- *
- * Revision 4.0 91/03/20 01:38:40 lwall
- * 4.0 baseline.
- *
- */
-
-%{
-#include "INTERN.h"
-#include "perl.h"
-
-/*SUPPRESS 530*/
-/*SUPPRESS 593*/
-/*SUPPRESS 595*/
-
-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 <ival> '{' ')'
-
-%token <cval> WORD LABEL
-%token <ival> APPEND OPEN SSELECT LOOPEX DOTDOT
-%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
-%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
-%token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
-%token <ival> FUNC0 FUNC1 FUNC2 FUNC2x FUNC3 FUNC4 FUNC5 HSHFUN HSHFUN3
-%token <ival> FLIST2 SUB FILETEST LOCAL DELETE
-%token <ival> RELOP EQOP MULOP ADDOP PACKAGE AMPER
-%token <formval> FORMLIST
-%token <stabval> REG ARYLEN ARY HSH STAR
-%token <arg> SUBST PATTERN
-%token <arg> RSTRING TRANS
-
-%type <ival> prog decl format remember crp
-%type <cmdval> block lineseq line loop cond sideff nexpr else
-%type <arg> expr sexpr cexpr csexpr term handle aryword hshword
-%type <arg> texpr listop bareword
-%type <cval> label
-%type <compval> compblock
-
-%nonassoc <ival> LISTOP
-%left ','
-%right '='
-%right '?' ':'
-%nonassoc DOTDOT
-%left OROR
-%left ANDAND
-%left '|' '^'
-%left '&'
-%nonassoc EQOP
-%nonassoc RELOP
-%nonassoc <ival> 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
- expectterm = 2;
- }
- /*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,1,$3,$5); }
- ;
-
-block : '{' remember lineseq '}'
- { $$ = block_head($3);
- if (cmdline > (line_t)$1)
- cmdline = $1;
- if (savestack->ary_fill > $2)
- restorelist($2);
- expectterm = 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;
- cmdline = NOLINE;
- }
- expectterm = 2; }
- | label sideff ';'
- { $$ = add_label($1,$2);
- expectterm = 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_icmd(C_IF,cmd_to_arg($2),$3); }
- | UNLESS block compblock
- { cmdline = $1;
- $$ = invert(make_icmd(C_IF,cmd_to_arg($2),$3)); }
- ;
-
-loop : label WHILE '(' texpr ')' compblock
- { cmdline = $2;
- $$ = wopt(add_label($1,
- make_ccmd(C_WHILE,1,$4,$6) )); }
- | label UNTIL '(' expr ')' compblock
- { cmdline = $2;
- $$ = wopt(add_label($1,
- invert(make_ccmd(C_WHILE,1,$4,$6)) )); }
- | label WHILE block compblock
- { cmdline = $2;
- $$ = wopt(add_label($1,
- make_ccmd(C_WHILE, 1, cmd_to_arg($3),$4) )); }
- | label UNTIL block compblock
- { cmdline = $2;
- $$ = wopt(add_label($1,
- invert(make_ccmd(C_WHILE,1,cmd_to_arg($3),$4)) )); }
- | label FOR REG '(' expr crp 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 )),
- listish(make_list($5)),
- Nullarg)),
- Nullarg),
- wopt(over($3,add_label($1,
- make_ccmd(C_WHILE, 0,
- 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,1,$5,$7) )));
- }
- }
- | label FOR '(' expr crp 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 )),
- listish(make_list($4)),
- Nullarg)),
- Nullarg),
- wopt(over(defstab,add_label($1,
- make_ccmd(C_WHILE, 0,
- 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,1,$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,1,$6,yyval.compval) ))); }
- | label compblock /* a block is a loop that happens once */
- { $$ = add_label($1,make_ccmd(C_BLOCK,1,Nullarg,$2)); }
- ;
-
-nexpr : /* NULL */
- { $$ = Nullcmd; }
- | sideff
- ;
-
-texpr : /* NULL means true */
- { (void)scanstr("1",SCAN_DEF); $$ = yylval.arg; }
- | expr
- ;
-
-label : /* empty */
- { $$ = Nullch; }
- | LABEL
- ;
-
-decl : format
- { $$ = 0; }
- | subrout
- { $$ = 0; }
- | package
- { $$ = 0; }
- ;
-
-format : FORMAT WORD '=' FORMLIST
- { if (strEQ($2,"stdout"))
- make_form(stabent("STDOUT",TRUE),$4);
- else if (strEQ($2,"stderr"))
- make_form(stabent("STDERR",TRUE),$4);
- else
- make_form(stabent($2,TRUE),$4);
- Safefree($2); $2 = Nullch; }
- | FORMAT '=' FORMLIST
- { make_form(stabent("STDOUT",TRUE),$3); }
- ;
-
-subrout : SUB WORD block
- { make_sub($2,$3);
- cmdline = NOLINE;
- if (savestack->ary_fill > $1)
- restorelist($1); }
- ;
-
-package : PACKAGE WORD ';'
- { char tmpbuf[256];
- STAB *tmpstab;
-
- savehptr(&curstash);
- saveitem(curstname);
- str_set(curstname,$2);
- sprintf(tmpbuf,"'_%s",$2);
- tmpstab = stabent(tmpbuf,TRUE);
- if (!stab_xhash(tmpstab))
- stab_xhash(tmpstab) = hnew(0);
- curstash = stab_xhash(tmpstab);
- if (!curstash->tbl_name)
- curstash->tbl_name = savestr($2);
- curstash->tbl_coeffsize = 0;
- Safefree($2); $2 = Nullch;
- cmdline = NOLINE;
- expectterm = 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
- { if ($2 == O_REPEAT)
- $1 = listish($1);
- $$ = make_op($2, 2, $1, $3, Nullarg);
- if ($2 == O_REPEAT) {
- if ($$[1].arg_type != A_EXPR ||
- $$[1].arg_ptr.arg_arg->arg_type != O_LIST)
- $$[1].arg_flags &= ~AF_ARYOK;
- } }
- | 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);
- $$[0].arg_flags |= $2; }
- | 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);
- Safefree($2); $2 = Nullch;
- }
- | 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 crp
- { $$ = l(localize(make_op(O_ASSIGN, 1,
- localize(listish(make_list($3))),
- Nullarg,Nullarg))); }
- | '(' expr crp
- { $$ = make_list($2); }
- | '(' ')'
- { $$ = make_list(Nullarg); }
- | DO sexpr %prec FILETEST
- { $$ = 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);
- expectterm = FALSE; }
- | '(' expr crp '[' expr ']' %prec '('
- { $$ = make_op(O_LSLICE, 3,
- Nullarg,
- listish(make_list($5)),
- listish(make_list($2))); }
- | '(' ')' '[' expr ']' %prec '('
- { $$ = make_op(O_LSLICE, 3,
- Nullarg,
- listish(make_list($4)),
- 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);
- expectterm = FALSE; }
- | DELETE REG '{' expr ';' '}' %prec '('
- { $$ = make_op(O_DELETE, 2,
- stab2arg(A_STAB,hadd($2)),
- jmaybe($4),
- Nullarg);
- expectterm = FALSE; }
- | DELETE '(' REG '{' expr ';' '}' ')' %prec '('
- { $$ = make_op(O_DELETE, 2,
- stab2arg(A_STAB,hadd($3)),
- jmaybe($4),
- Nullarg);
- expectterm = FALSE; }
- | ARYLEN %prec '('
- { $$ = stab2arg(A_ARYLEN,$1); }
- | RSTRING %prec '('
- { $$ = $1; }
- | PATTERN %prec '('
- { $$ = $1; }
- | SUBST %prec '('
- { $$ = $1; }
- | TRANS %prec '('
- { $$ = $1; }
- | DO WORD '(' expr crp
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- make_list($4),
- Nullarg); Safefree($2); $2 = Nullch;
- $$->arg_flags |= AF_DEPR; }
- | AMPER WORD '(' expr crp
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- make_list($4),
- Nullarg); Safefree($2); $2 = Nullch; }
- | DO WORD '(' ')'
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- make_list(Nullarg),
- Nullarg);
- Safefree($2); $2 = Nullch;
- $$->arg_flags |= AF_DEPR; }
- | AMPER WORD '(' ')'
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- make_list(Nullarg),
- Nullarg);
- Safefree($2); $2 = Nullch;
- }
- | AMPER WORD
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,MULTI)),
- Nullarg,
- Nullarg);
- Safefree($2); $2 = Nullch;
- }
- | DO REG '(' expr crp
- { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_STAB,$2),
- make_list($4),
- Nullarg);
- $$->arg_flags |= AF_DEPR; }
- | AMPER REG '(' expr crp
- { $$ = 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);
- $$->arg_flags |= AF_DEPR; }
- | 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); }
- | UNIOP block
- { $$ = make_op($1,1,cmd_to_arg($2),Nullarg,Nullarg); }
- | UNIOP sexpr
- { $$ = make_op($1,1,$2,Nullarg,Nullarg); }
- | SSELECT
- { $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);}
- | SSELECT WORD
- { $$ = make_op(O_SELECT, 1,
- stab2arg(A_WORD,stabent($2,TRUE)),
- Nullarg,
- Nullarg);
- Safefree($2); $2 = Nullch; }
- | SSELECT '(' handle ')'
- { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg); }
- | SSELECT '(' 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);
- Safefree($2); $2 = Nullch;
- }
- | OPEN '(' WORD ')'
- { $$ = make_op(O_OPEN, 2,
- stab2arg(A_WORD,stabent($3,TRUE)),
- stab2arg(A_STAB,stabent($3,TRUE)),
- Nullarg);
- Safefree($3); $3 = Nullch;
- }
- | 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); $2 = Nullch; }
- | 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 ',' expr crp
- { $$ = make_op($1, 2,
- $3,
- make_list($5),
- 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 '('
- { static char p[]="/\\s+/";
- char *oldend = bufend;
- ARG *oldarg = yylval.arg;
-
- bufend=p+5;
- (void)scanpat(p);
- bufend=oldend;
- $$ = make_split(defstab,yylval.arg,Nullarg);
- yylval.arg = oldarg; }
- | 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 crp
- { $$ = 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); }
- | FUNC1 '(' expr ')'
- { $$ = make_op($1, 1, $3, Nullarg, Nullarg); }
- | 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); }
- | FUNC2x '(' sexpr csexpr ')'
- { $$ = make_op($1, 2, $3, $4, Nullarg);
- if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE)
- fbmcompile($$[2].arg_ptr.arg_str,0); }
- | FUNC2x '(' sexpr csexpr cexpr ')'
- { $$ = make_op($1, 3, $3, $4, $5);
- 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); }
- | FUNC4 '(' sexpr csexpr csexpr cexpr ')'
- { arg4 = $6;
- $$ = make_op($1, 4, $3, $4, $5); }
- | FUNC5 '(' sexpr csexpr csexpr csexpr cexpr ')'
- { arg4 = $6; arg5 = $7;
- $$ = make_op($1, 5, $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); }
- | bareword
- | 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);
- Safefree($2); $2 = Nullch;
- }
- | LISTOP WORD expr
- { $$ = make_op($1,2,
- stab2arg(A_WORD,stabent($2,TRUE)),
- maybelistish($1,make_list($3)),
- Nullarg); Safefree($2); $2 = Nullch; }
- | LISTOP REG expr
- { $$ = make_op($1,2,
- stab2arg(A_STAB,$2),
- maybelistish($1,make_list($3)),
- Nullarg); }
- | LISTOP block expr
- { $$ = make_op($1,2,
- cmd_to_arg($2),
- maybelistish($1,make_list($3)),
- Nullarg); }
- ;
-
-handle : WORD
- { $$ = stab2arg(A_WORD,stabent($1,TRUE));
- Safefree($1); $1 = Nullch;}
- | sexpr
- ;
-
-aryword : WORD
- { $$ = stab2arg(A_WORD,aadd(stabent($1,TRUE)));
- Safefree($1); $1 = Nullch; }
- | ARY
- { $$ = stab2arg(A_STAB,$1); }
- ;
-
-hshword : WORD
- { $$ = stab2arg(A_WORD,hadd(stabent($1,TRUE)));
- Safefree($1); $1 = Nullch; }
- | HSH
- { $$ = stab2arg(A_STAB,$1); }
- ;
-
-crp : ',' ')'
- { $$ = 1; }
- | ')'
- { $$ = 0; }
- ;
-
-/*
- * NOTE: The following entry must stay at the end of the file so that
- * reduce/reduce conflicts resolve to it only if it's the only option.
- */
-
-bareword: WORD
- { char *s;
- $$ = op_new(1);
- $$->arg_type = O_ITEM;
- $$[1].arg_type = A_SINGLE;
- $$[1].arg_ptr.arg_str = str_make($1,0);
- for (s = $1; *s && isLOWER(*s); s++) ;
- if (dowarn && !*s)
- warn(
- "\"%s\" may clash with future reserved word",
- $1 );
- Safefree($1); $1 = Nullch;
- }
- ;
-%% /* PROGRAM */
+++ /dev/null
-***************
-*** 1,4 ****
-! /* $RCSfile: perly.y,v $$Revision: 4.0.1.5 $$Date: 1992/06/11 21:12:50 $
- *
- * Copyright (c) 1991, Larry Wall
- *
---- 1,4 ----
-! /* $RCSfile: perly.y,v $$Revision: 4.0.1.6 $$Date: 1993/02/05 19:41:15 $
- *
- * Copyright (c) 1991, Larry Wall
- *
-***************
-*** 6,14 ****
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: perly.y,v $
-! * Revision 4.0.1.5 1992/06/11 21:12:50 lwall
-! * patch34: expectterm incorrectly set to indicate start of program or block
- *
- * Revision 4.0.1.4 92/06/08 17:33:25 lwall
- * patch20: one of the backdoors to expectterm was on the wrong reduction
- *
---- 6,17 ----
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: perly.y,v $
-! * Revision 4.0.1.6 1993/02/05 19:41:15 lwall
-! * patch36: delete with parens dumped core
- *
-+ * Revision 4.0.1.5 92/06/11 21:12:50 lwall
-+ * patch34: expectterm incorrectly set to indicate start of program or block
-+ *
- * Revision 4.0.1.4 92/06/08 17:33:25 lwall
- * patch20: one of the backdoors to expectterm was on the wrong reduction
- *
--- /dev/null
+/* $RCSfile: perly.y,v $$Revision: 4.1 $$Date: 92/08/07 18:26:16 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: perly.y,v $
+ * Revision 4.1 92/08/07 18:26:16 lwall
+ *
+ * Revision 4.0.1.5 92/06/11 21:12:50 lwall
+ * patch34: expectterm incorrectly set to indicate start of program or block
+ *
+ * Revision 4.0.1.4 92/06/08 17:33:25 lwall
+ * patch20: one of the backdoors to expectterm was on the wrong reduction
+ *
+ * Revision 4.0.1.3 92/06/08 15:18:16 lwall
+ * patch20: an expression may now start with a bareword
+ * patch20: relaxed requirement for semicolon at the end of a block
+ * patch20: added ... as variant on ..
+ * patch20: fixed double debug break in foreach with implicit array assignment
+ * patch20: if {block} {block} didn't work any more
+ * patch20: deleted some minor memory leaks
+ *
+ * Revision 4.0.1.2 91/11/05 18:17:38 lwall
+ * patch11: extra comma at end of list is now allowed in more places (Hi, Felix!)
+ * patch11: once-thru blocks didn't display right in the debugger
+ * patch11: debugger got confused over nested subroutine definitions
+ *
+ * Revision 4.0.1.1 91/06/07 11:42:34 lwall
+ * patch4: new copyright notice
+ *
+ * Revision 4.0 91/03/20 01:38:40 lwall
+ * 4.0 baseline.
+ *
+ */
+
+%{
+#include "EXTERN.h"
+#include "perl.h"
+
+/*SUPPRESS 530*/
+/*SUPPRESS 593*/
+/*SUPPRESS 595*/
+
+%}
+
+%start prog
+
+%union {
+ int ival;
+ char *cval;
+ OP *opval;
+ COP *copval;
+ struct compcmd compval;
+ GV *stabval;
+ FF *formval;
+}
+
+%token <ival> '{' ')'
+
+%token <opval> WORD
+%token <cval> LABEL
+%token <ival> APPEND OPEN SSELECT LOOPEX DOTDOT DOLSHARP
+%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
+%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
+%token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
+%token <ival> FUNC0 FUNC1 FUNC2 FUNC2x FUNC3 FUNC4 FUNC5 HSHFUN HSHFUN3
+%token <ival> FLIST2 SUB LOCAL DELETE FUNC
+%token <ival> RELOP EQOP MULOP ADDOP PACKAGE
+%token <formval> FORMLIST
+%token <opval> THING STRING
+
+%type <ival> prog decl format remember crp
+%type <copval> block lineseq line loop cond sideff nexpr else
+%type <opval> expr sexpr term scalar ary hsh arylen star amper
+%type <opval> listexpr indirob
+%type <opval> texpr listop
+%type <cval> label
+%type <compval> compblock
+
+%nonassoc <ival> LSTOP
+%left ','
+%right '='
+%right '?' ':'
+%nonassoc DOTDOT
+%left OROR
+%left ANDAND
+%left <ival> BITOROP
+%left <ival> BITANDOP
+%nonassoc EQOP
+%nonassoc RELOP
+%nonassoc <ival> UNIOP
+%left <ival> SHIFTOP
+%left ADDOP
+%left MULOP
+%left <ival> MATCHOP
+%right '!' '~' UMINUS
+%right <ival> POWOP
+%nonassoc INC DEC
+%left '('
+
+%% /* RULES */
+
+prog : /* NULL */
+ {
+#if defined(YYDEBUG) && defined(DEBUGGING)
+ yydebug = (debug & 1);
+#endif
+ expectterm = 2;
+ }
+ /*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 */
+ { $$ = Nullcop; }
+ | ELSE block
+ { $$ = $2; }
+ | ELSIF '(' expr ')' compblock
+ { cmdline = $1;
+ $$ = newCCOP(OP_ELSIF,1,$3,$5); }
+ ;
+
+block : '{' remember lineseq '}'
+ { $$ = block_head($3);
+ if (cmdline > (line_t)$1)
+ cmdline = $1;
+ if (savestack->av_fill > $2)
+ leave_scope($2);
+ expectterm = 2; }
+ ;
+
+remember: /* NULL */ /* in case they push a package name */
+ { $$ = savestack->av_fill; }
+ ;
+
+lineseq : /* NULL */
+ { $$ = Nullcop; }
+ | lineseq line
+ { $$ = append_elem(OP_LINESEQ,$1,$2); }
+ ;
+
+line : decl
+ { $$ = Nullcop; }
+ | label cond
+ { $$ = add_label($1,$2); }
+ | loop /* loops add their own labels */
+ | label ';'
+ { if ($1 != Nullch) {
+ $$ = add_label($1, newACOP(Nullgv, Nullop) );
+ }
+ else {
+ $$ = Nullcop;
+ cmdline = NOLINE;
+ }
+ expectterm = 2; }
+ | label sideff ';'
+ { $$ = add_label($1,$2);
+ expectterm = 2; }
+ ;
+
+sideff : error
+ { $$ = Nullcop; }
+ | expr
+ { $$ = newACOP(Nullgv, $1); }
+ | expr IF expr
+ { $$ = addcond(
+ newACOP(Nullgv, Nullop, $1), $3); }
+ | expr UNLESS expr
+ { $$ = addcond(invert(
+ newACOP(Nullgv, Nullop, $1)), $3); }
+ | expr WHILE expr
+ { $$ = addloop(
+ newACOP(Nullgv, Nullop, $1), $3); }
+ | expr UNTIL expr
+ { $$ = addloop(invert(
+ newACOP(Nullgv, Nullop, $1)), $3); }
+ ;
+
+cond : IF '(' expr ')' compblock
+ { cmdline = $1;
+ $$ = newICOP(OP_IF,$3,$5); }
+ | UNLESS '(' expr ')' compblock
+ { cmdline = $1;
+ $$ = invert(newICOP(OP_IF,$3,$5)); }
+ | IF block compblock
+ { cmdline = $1;
+ $$ = newICOP(OP_IF,$2,$3); }
+ | UNLESS block compblock
+ { cmdline = $1;
+ $$ = invert(newICOP(OP_IF,$2,$3)); }
+ ;
+
+loop : label WHILE '(' texpr ')' compblock
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
+ newCCOP(OP_WHILE,1,$4,$6) )); }
+ | label UNTIL '(' expr ')' compblock
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
+ invert(newCCOP(OP_WHILE,1,$4,$6)) )); }
+ | label WHILE block compblock
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
+ newCCOP(OP_WHILE, 1, $3,$4) )); }
+ | label UNTIL block compblock
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
+ invert(newCCOP(OP_WHILE,1,$3,$4)) )); }
+ | label FOR scalar '(' expr crp 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 newGVgen().
+ * (Note that @ary may become a local array if
+ * it is determined that it might be called
+ * recursively. See cmd_tosave().)
+ */
+ if ($5->op_type != OP_ARRAY) {
+ scrstab = gv_AVadd(newGVgen());
+ $$ = append_elem(OP_LINESEQ,
+ newACOP(Nullgv,
+ newBINOP(OP_ASSIGN,
+ listref(newUNOP(OP_ARRAY,
+ gv_to_op(A_STAB,scrstab))),
+ forcelist($5))),
+ wopt(over($3,add_label($1,
+ newCCOP(OP_WHILE, 0,
+ newUNOP(OP_ARRAY,
+ gv_to_op(A_STAB,scrstab)),
+ $7)))));
+ $$->cop_line = $2;
+ $$->cop_head->cop_line = $2;
+ }
+ else {
+ $$ = wopt(over($3,add_label($1,
+ newCCOP(OP_WHILE,1,$5,$7) )));
+ }
+ }
+ | label FOR '(' expr crp compblock
+ { cmdline = $2;
+ if ($4->op_type != OP_ARRAY) {
+ scrstab = gv_AVadd(newGVgen());
+ $$ = append_elem(OP_LINESEQ,
+ newACOP(Nullgv,
+ newBINOP(OP_ASSIGN,
+ listref(newUNOP(OP_ARRAY,
+ gv_to_op(A_STAB,scrstab))),
+ forcelist($4))),
+ wopt(over(defstab,add_label($1,
+ newCCOP(OP_WHILE, 0,
+ newUNOP(OP_ARRAY,
+ gv_to_op(A_STAB,scrstab)),
+ $6)))));
+ $$->cop_line = $2;
+ $$->cop_head->cop_line = $2;
+ }
+ else { /* lisp, anyone? */
+ $$ = wopt(over(defstab,add_label($1,
+ newCCOP(OP_WHILE,1,$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_elem(OP_LINESEQ,$4,wopt(add_label($1,
+ newCCOP(OP_WHILE,1,$6,yyval.compval) ))); }
+ | label compblock /* a block is a loop that happens once */
+ { $$ = add_label($1,newCCOP(OP_BLOCK,1,Nullop,$2)); }
+ ;
+
+nexpr : /* NULL */
+ { $$ = Nullcop; }
+ | sideff
+ ;
+
+texpr : /* NULL means true */
+ { (void)scan_num("1"); $$ = yylval.op; }
+ | expr
+ ;
+
+label : /* empty */
+ { $$ = Nullch; }
+ | LABEL
+ ;
+
+decl : format
+ { $$ = 0; }
+ | subrout
+ { $$ = 0; }
+ | package
+ { $$ = 0; }
+ ;
+
+format : FORMAT WORD '=' FORMLIST
+ { if (strEQ($2,"stdout"))
+ newFORM(newGV("STDOUT",TRUE),$4);
+ else if (strEQ($2,"stderr"))
+ newFORM(newGV("STDERR",TRUE),$4);
+ else
+ newFORM(newGV($2,TRUE),$4);
+ Safefree($2); $2 = Nullch; }
+ | FORMAT '=' FORMLIST
+ { newFORM(newGV("STDOUT",TRUE),$3); }
+ ;
+
+subrout : SUB WORD block
+ { newSUB($2,$3);
+ cmdline = NOLINE;
+ if (savestack->av_fill > $1)
+ leave_scope($1); }
+ ;
+
+package : PACKAGE WORD ';'
+ { char tmpbuf[256];
+ GV *tmpstab;
+
+ save_hptr(&curstash);
+ save_item(curstname);
+ sv_setpv(curstname,$2);
+ sprintf(tmpbuf,"'_%s",$2);
+ tmpstab = newGV(tmpbuf,TRUE);
+ if (!GvHV(tmpstab))
+ GvHV(tmpstab) = newHV(0);
+ curstash = GvHV(tmpstab);
+ if (!curstash->hv_name)
+ curstash->hv_name = savestr($2);
+ curstash->hv_coeffsize = 0;
+ Safefree($2); $2 = Nullch;
+ cmdline = NOLINE;
+ expectterm = 2;
+ }
+ ;
+
+expr : expr ',' sexpr
+ { $$ = append_elem(OP_LIST, $1, $3); }
+ | sexpr
+ ;
+
+sexpr : sexpr '=' sexpr
+ { $$ = newBINOP(OP_ASSIGN, ref($1), $3); }
+ | sexpr POWOP '=' sexpr
+ { $$ = newBINOP($2, ref($1), $4); }
+ | sexpr MULOP '=' sexpr
+ { $$ = newBINOP($2, ref($1), $4); }
+ | sexpr ADDOP '=' sexpr
+ { $$ = newBINOP($2, ref($1), $4);}
+ | sexpr SHIFTOP '=' sexpr
+ { $$ = newBINOP($2, ref($1), $4); }
+ | sexpr BITANDOP '=' sexpr
+ { $$ = newBINOP($2, ref($1), $4); }
+ | sexpr BITOROP '=' sexpr
+ { $$ = newBINOP($2, ref($1), $4); }
+
+
+ | sexpr POWOP sexpr
+ { $$ = newBINOP($2, $1, $3); }
+ | sexpr MULOP sexpr
+ { if ($2 == OP_REPEAT)
+ $1 = forcelist($1);
+ $$ = newBINOP($2, $1, $3);
+ if ($2 == OP_REPEAT) {
+ if ($$[1].op_type != A_EXPR ||
+ $$[1].op_ptr.op_op->op_type != OP_LIST)
+ $$[1].op_flags &= ~AF_ARYOK;
+ } }
+ | sexpr ADDOP sexpr
+ { $$ = newBINOP($2, $1, $3); }
+ | sexpr SHIFTOP sexpr
+ { $$ = newBINOP($2, $1, $3); }
+ | sexpr RELOP sexpr
+ { $$ = newBINOP($2, $1, $3); }
+ | sexpr EQOP sexpr
+ { $$ = newBINOP($2, $1, $3); }
+ | sexpr BITANDOP sexpr
+ { $$ = newBINOP($2, $1, $3); }
+ | sexpr BITOROP sexpr
+ { $$ = newBINOP($2, $1, $3); }
+ | sexpr DOTDOT sexpr
+ { $$ = newBINOP($2, $1, $3); }
+ | sexpr ANDAND sexpr
+ { $$ = newBINOP(OP_AND, $1, $3); }
+ | sexpr OROR sexpr
+ { $$ = newBINOP(OP_OR, $1, $3); }
+ | sexpr '?' sexpr ':' sexpr
+ { $$ = newCONDOP(OP_COND_EXPR, $1, $3, $5); }
+ | sexpr MATCHOP sexpr
+ { $$ = bind_match($2, $1, $3); }
+ | term
+ { $$ = $1; }
+ ;
+
+term : '-' term %prec UMINUS
+ { $$ = newUNOP(OP_NEGATE, $2); }
+ | '+' term %prec UMINUS
+ { $$ = $2; }
+ | '!' term
+ { $$ = newUNOP(OP_NOT, $2); }
+ | '~' term
+ { $$ = newUNOP(OP_COMPLEMENT, $2);}
+ | term INC
+ { $$ = newUNOP(OP_POSTINC,ref($1)); }
+ | term DEC
+ { $$ = newUNOP(OP_POSTDEC,ref($1)); }
+ | INC term
+ { $$ = newUNOP(OP_PREINC,ref($2)); }
+ | DEC term
+ { $$ = newUNOP(OP_PREDEC,ref($2)); }
+ | LOCAL '(' expr crp
+ { $$ = localize(forcelist($3)); }
+ | '(' expr crp
+ { $$ = $2; }
+ | '(' ')'
+ { $$ = Nullop; } /* XXX may be insufficient */
+ | scalar %prec '('
+ { $$ = gv_to_op(A_STAB,$1); }
+ | star %prec '('
+ { $$ = gv_to_op(A_STAR,$1); }
+ | scalar '[' expr ']' %prec '('
+ { $$ = newBINOP(OP_AELEM,
+ gv_to_op(A_STAB,gv_AVadd($1)), $3); }
+ | hsh %prec '('
+ { $$ = newUNOP(OP_HASH, gv_to_op(A_STAB,$1)); }
+ | ary %prec '('
+ { $$ = newUNOP(OP_ARRAY, gv_to_op(A_STAB,$1)); }
+ | arylen %prec '('
+ { $$ = newUNOP(OP_ARYLEN, gv_to_op(A_STAB,$1)); }
+ | scalar '{' expr ';' '}' %prec '('
+ { $$ = newBINOP(OP_HELEM,
+ gv_to_op(A_STAB,gv_HVadd($1)),
+ jmaybe($3));
+ expectterm = FALSE; }
+ | '(' expr crp '[' expr ']' %prec '('
+ { $$ = newSLICEOP(OP_LSLICE, Nullop,
+ forcelist($5),
+ forcelist($2)); }
+ | '(' ')' '[' expr ']' %prec '('
+ { $$ = newSLICEOP(OP_LSLICE, Nullop,
+ forcelist($4), Nullop); }
+ | ary '[' expr ']' %prec '('
+ { $$ = newBINOP(OP_ASLICE,
+ gv_to_op(A_STAB,gv_AVadd($1)),
+ forcelist($3)); }
+ | ary '{' expr ';' '}' %prec '('
+ { $$ = newBINOP(OP_HSLICE,
+ gv_to_op(A_STAB,gv_HVadd($1)),
+ forcelist($3));
+ expectterm = FALSE; }
+ | DELETE scalar '{' expr ';' '}' %prec '('
+ { $$ = newBINOP(OP_DELETE,
+ gv_to_op(A_STAB,gv_HVadd($2)),
+ jmaybe($4));
+ expectterm = FALSE; }
+ | DELETE '(' scalar '{' expr ';' '}' ')' %prec '('
+ { $$ = newBINOP(OP_DELETE,
+ gv_to_op(A_STAB,gv_HVadd($3)),
+ jmaybe($5));
+ expectterm = FALSE; }
+ | THING %prec '('
+ { $$ = $1; }
+
+ | amper
+ { $$ = newUNIOP(OP_SUBR,
+ gv_to_op(A_STAB,$1)); }
+ | amper '(' ')'
+ { $$ = newBINOP(OP_SUBR,
+ gv_to_op(A_STAB,$1),
+ flatten(Nullop)); }
+ | amper '(' expr crp
+ { $$ = newBINOP(OP_SUBR,
+ gv_to_op(A_STAB,$1),
+ $3); }
+
+ | DO sexpr %prec UNIOP
+ { $$ = newUNOP(OP_DOFILE,$2);
+ allgvs = TRUE;}
+ | DO block %prec '('
+ { $$ = $2; }
+ | DO WORD '(' ')'
+ { $$ = newBINOP(OP_SUBR,
+ gv_to_op(A_WORD,newGV($2,MULTI)),
+ Nullop);
+ Safefree($2); $2 = Nullch;
+ $$->op_flags |= AF_DEPR; }
+ | DO WORD '(' expr crp
+ { $$ = newBINOP(OP_SUBR,
+ gv_to_op(A_WORD,newGV($2,MULTI)),
+ $4); Safefree($2); $2 = Nullch;
+ $$->op_flags |= AF_DEPR; }
+ | DO scalar '(' ')'
+ { $$ = newBINOP(OP_SUBR,
+ gv_to_op(A_STAB,$2),
+ flatten(Nullop));
+ $$->op_flags |= AF_DEPR; }
+ | DO scalar '(' expr crp
+ { $$ = newBINOP(OP_SUBR,
+ gv_to_op(A_STAB,$2),
+ $4);
+ $$->op_flags |= AF_DEPR; }
+ | LOOPEX
+ { $$ = newOP($1); }
+ | LOOPEX WORD
+ { $$ = newUNIOP($1,pv_to_op($2)); }
+ | UNIOP
+ { $$ = newOP($1); }
+ | UNIOP block
+ { $$ = newUNOP($1,$2); }
+ | UNIOP sexpr
+ { $$ = newUNOP($1,$2); }
+ | FUNC0
+ { $$ = newOP($1); }
+ | FUNC0 '(' ')'
+ { $$ = newOP($1); }
+ | FUNC1 '(' ')'
+ { $$ = newOP($1); }
+ | FUNC1 '(' expr ')'
+ { $$ = newUNIOP($1,$3); }
+ | WORD
+ | listop
+ ;
+
+listop : LSTOP listexpr
+ { $$ = newUNOP($1, $2); }
+ | FUNC '(' listexpr ')'
+ { $$ = newUNOP($1, $3); }
+ ;
+
+listexpr: /* NULL */
+ { $$ = newNULLLIST(); }
+ | expr
+ { $$ = $1; }
+ | indirob expr
+ { $$ = prepend_elem(OP_LIST, $1, $2); }
+ ;
+
+amper : '&' indirob
+ { $$ = $2; }
+ ;
+
+scalar : '$' indirob
+ { $$ = $2; }
+ ;
+
+ary : '@' indirob
+ { $$ = $2; }
+ ;
+
+hsh : '%' indirob
+ { $$ = $2; }
+ ;
+
+arylen : DOLSHARP indirob
+ { $$ = $2; }
+ ;
+
+star : '*' indirob
+ { $$ = $2; }
+ ;
+
+indirob : WORD
+ { $$ = newINDIROB($1); }
+ | scalar
+ { $$ = newINDIROB($1); }
+ | block
+ { $$ = newINDIROB($1); }
+ ;
+
+crp : ',' ')'
+ { $$ = 1; }
+ | ')'
+ { $$ = 0; }
+ ;
+
+%% /* PROGRAM */
--- /dev/null
+/***********************************************************
+ *
+ * $Header: /usr/src/local/lwall/perl5/RCS/pp.c, v 4.1 92/08/07 18:26:21 lwall Exp Locker: lwall $
+ *
+ * Description:
+ * Push/Pop code.
+ *
+ * Standards:
+ *
+ * Created:
+ * Mon Jun 15 16:45:59 1992
+ *
+ * Author:
+ * Larry Wall <lwall@netlabs.com>
+ *
+ * $Log: pp.c, v $
+ * Revision 4.1 92/08/07 18:26:21 lwall
+ *
+ *
+ **********************************************************/
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef HAS_SOCKET
+#include <sys/socket.h>
+#include <netdb.h>
+#ifndef ENOTSOCK
+#include <net/errno.h>
+#endif
+#endif
+
+#ifdef HAS_SELECT
+#ifdef I_SYS_SELECT
+#ifndef I_SYS_TIME
+#include <sys/select.h>
+#endif
+#endif
+#endif
+
+#ifdef HOST_NOT_FOUND
+extern int h_errno;
+#endif
+
+#ifdef I_PWD
+#include <pwd.h>
+#endif
+#ifdef I_GRP
+#include <grp.h>
+#endif
+#ifdef I_UTIME
+#include <utime.h>
+#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+#ifdef I_VARARGS
+# include <varargs.h>
+#endif
+
+/* Nothing. */
+
+PP(pp_null)
+{
+ return NORMAL;
+}
+
+PP(pp_scalar)
+{
+ return NORMAL;
+}
+
+/* Pushy stuff. */
+
+PP(pp_pushmark)
+{
+ if (++markstack_ptr == markstack_max) {
+ I32 oldmax = markstack_max - markstack;
+ I32 newmax = oldmax * 3 / 2;
+
+ Renew(markstack, newmax, I32);
+ markstack_ptr = markstack + oldmax;
+ markstack_max = markstack + newmax;
+ }
+ *markstack_ptr = stack_sp - stack_base;
+ return NORMAL;
+}
+
+PP(pp_wantarray)
+{
+ dSP;
+ I32 cxix;
+ EXTEND(SP, 1);
+
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0)
+ RETPUSHUNDEF;
+
+ if (cxstack[cxix].blk_gimme == G_ARRAY)
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+}
+
+PP(pp_word)
+{
+ DIE("PP_WORD");
+}
+
+PP(pp_const)
+{
+ dSP;
+ XPUSHs(cSVOP->op_sv);
+ RETURN;
+}
+
+static void
+ucase(s,send)
+register char *s;
+register char *send;
+{
+ while (s < send) {
+ if (isLOWER(*s))
+ *s = toupper(*s);
+ s++;
+ }
+}
+
+static void
+lcase(s,send)
+register char *s;
+register char *send;
+{
+ while (s < send) {
+ if (isUPPER(*s))
+ *s = tolower(*s);
+ s++;
+ }
+}
+
+PP(pp_interp)
+{
+ DIE("panic: pp_interp");
+}
+
+PP(pp_gvsv)
+{
+ dSP;
+ EXTEND(sp,1);
+ if (op->op_flags & OPf_LOCAL)
+ PUSHs(save_scalar(cGVOP->op_gv));
+ else
+ PUSHs(GvSV(cGVOP->op_gv));
+ RETURN;
+}
+
+PP(pp_gv)
+{
+ dSP;
+ XPUSHs((SV*)cGVOP->op_gv);
+ RETURN;
+}
+
+PP(pp_pushre)
+{
+ dSP;
+ XPUSHs((SV*)op);
+ RETURN;
+}
+
+/* Translations. */
+
+PP(pp_rv2gv)
+{
+ dSP; dTOPss;
+ if (SvTYPE(sv) == SVt_REF) {
+ sv = (SV*)SvANY(sv);
+ if (SvTYPE(sv) != SVt_PVGV)
+ DIE("Not a glob reference");
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV)
+ sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
+ }
+ if (op->op_flags & OPf_LOCAL) {
+ GP *ogp = GvGP(sv);
+
+ SSCHECK(3);
+ SSPUSHPTR(sv);
+ SSPUSHPTR(ogp);
+ SSPUSHINT(SAVEt_GP);
+
+ if (op->op_flags & OPf_SPECIAL)
+ GvGP(sv)->gp_refcnt++; /* will soon be assigned */
+ else {
+ GP *gp;
+ Newz(602,gp, 1, GP);
+ GvGP(sv) = gp;
+ GvREFCNT(sv) = 1;
+ GvSV(sv) = NEWSV(72,0);
+ GvLINE(sv) = curcop->cop_line;
+ GvEGV(sv) = sv;
+ }
+ }
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_sv2len)
+{
+ dSP; dTARGET;
+ dPOPss;
+ PUSHi(sv_len(sv));
+ RETURN;
+}
+
+PP(pp_rv2sv)
+{
+ dSP; dTOPss;
+
+ if (SvTYPE(sv) == SVt_REF) {
+ sv = (SV*)SvANY(sv);
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ DIE("Not a scalar reference");
+ }
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV)
+ sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
+ sv = GvSV(sv);
+ }
+ if (op->op_flags & OPf_LOCAL)
+ SETs(save_scalar((GV*)TOPs));
+ else
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_av2arylen)
+{
+ dSP;
+ AV *av = (AV*)TOPs;
+ SV *sv = AvARYLEN(av);
+ if (!sv) {
+ AvARYLEN(av) = sv = NEWSV(0,0);
+ sv_upgrade(sv, SVt_IV);
+ sv_magic(sv, (SV*)av, '#', Nullch, 0);
+ }
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_rv2cv)
+{
+ dSP;
+ SV *sv;
+ GV *gv;
+ HV *stash;
+ CV *cv = sv_2cv(TOPs, &stash, &gv, 0);
+
+ SETs((SV*)cv);
+ RETURN;
+}
+
+PP(pp_refgen)
+{
+ dSP; dTOPss;
+ SV* rv;
+ if (!sv)
+ RETSETUNDEF;
+ rv = sv_mortalcopy(&sv_undef);
+ sv_upgrade(rv, SVt_REF);
+ SvANY(rv) = (void*)sv_ref(sv);
+ SETs(rv);
+ RETURN;
+}
+
+PP(pp_ref)
+{
+ dSP; dTARGET; dTOPss;
+ char *pv;
+
+ if (SvTYPE(sv) != SVt_REF)
+ RETSETUNDEF;
+
+ sv = (SV*)SvANY(sv);
+ if (SvSTORAGE(sv) == 'O')
+ pv = HvNAME(SvSTASH(sv));
+ else {
+ switch (SvTYPE(sv)) {
+ case SVt_REF: pv = "REF"; break;
+ case SVt_NULL:
+ case SVt_IV:
+ case SVt_NV:
+ case SVt_PV:
+ case SVt_PVIV:
+ case SVt_PVNV:
+ case SVt_PVMG:
+ case SVt_PVBM: pv = "SCALAR"; break;
+ case SVt_PVLV: pv = "LVALUE"; break;
+ case SVt_PVAV: pv = "ARRAY"; break;
+ case SVt_PVHV: pv = "HASH"; break;
+ case SVt_PVCV: pv = "CODE"; break;
+ case SVt_PVGV: pv = "GLOB"; break;
+ case SVt_PVFM: pv = "FORMLINE"; break;
+ default: pv = "UNKNOWN"; break;
+ }
+ }
+ SETp(pv, strlen(pv));
+ RETURN;
+}
+
+PP(pp_bless)
+{
+ dSP; dTOPss;
+ register SV* ref;
+
+ if (SvTYPE(sv) != SVt_REF)
+ RETSETUNDEF;
+
+ ref = (SV*)SvANY(sv);
+ if (SvSTORAGE(ref) && SvSTORAGE(ref) != 'O')
+ DIE("Can't bless temporary scalar");
+ SvSTORAGE(ref) = 'O';
+ SvUPGRADE(ref, SVt_PVMG);
+ SvSTASH(ref) = curcop->cop_stash;
+ RETURN;
+}
+
+/* Pushy I/O. */
+
+PP(pp_backtick)
+{
+ dSP; dTARGET;
+ FILE *fp;
+ char *tmps = POPp;
+#ifdef TAINT
+ TAINT_PROPER("``");
+#endif
+ fp = my_popen(tmps, "r");
+ if (fp) {
+ sv_setpv(TARG, ""); /* note that this preserves previous buffer */
+ if (GIMME == G_SCALAR) {
+ while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
+ /*SUPPRESS 530*/
+ ;
+ XPUSHs(TARG);
+ }
+ else {
+ SV *sv;
+
+ for (;;) {
+ sv = NEWSV(56, 80);
+ if (sv_gets(sv, fp, 0) == Nullch) {
+ sv_free(sv);
+ break;
+ }
+ XPUSHs(sv_2mortal(sv));
+ if (SvLEN(sv) - SvCUR(sv) > 20) {
+ SvLEN_set(sv, SvCUR(sv)+1);
+ Renew(SvPV(sv), SvLEN(sv), char);
+ }
+ }
+ }
+ statusvalue = my_pclose(fp);
+ }
+ else {
+ statusvalue = -1;
+ if (GIMME == G_SCALAR)
+ RETPUSHUNDEF;
+ }
+
+ RETURN;
+}
+
+OP *
+do_readline()
+{
+ dSP; dTARGETSTACKED;
+ register SV *sv;
+ STRLEN tmplen;
+ STRLEN offset;
+ FILE *fp;
+ register IO *io = GvIO(last_in_gv);
+ register I32 type = op->op_type;
+
+ fp = Nullfp;
+ if (io) {
+ fp = io->ifp;
+ if (!fp) {
+ if (io->flags & IOf_ARGV) {
+ if (io->flags & IOf_START) {
+ io->flags &= ~IOf_START;
+ io->lines = 0;
+ if (av_len(GvAVn(last_in_gv)) < 0) {
+ SV *tmpstr = newSVpv("-", 1); /* assume stdin */
+ (void)av_push(GvAVn(last_in_gv), tmpstr);
+ }
+ }
+ fp = nextargv(last_in_gv);
+ if (!fp) { /* Note: fp != io->ifp */
+ (void)do_close(last_in_gv, FALSE); /* now it does*/
+ io->flags |= IOf_START;
+ }
+ }
+ else if (type == OP_GLOB) {
+ SV *tmpcmd = NEWSV(55, 0);
+ SV *tmpglob = POPs;
+#ifdef DOSISH
+ sv_setpv(tmpcmd, "perlglob ");
+ sv_catsv(tmpcmd, tmpglob);
+ sv_catpv(tmpcmd, " |");
+#else
+#ifdef CSH
+ sv_setpvn(tmpcmd, cshname, cshlen);
+ sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
+ sv_catsv(tmpcmd, tmpglob);
+ sv_catpv(tmpcmd, "'|");
+#else
+ sv_setpv(tmpcmd, "echo ");
+ sv_catsv(tmpcmd, tmpglob);
+ sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
+#endif /* !CSH */
+#endif /* !MSDOS */
+ (void)do_open(last_in_gv, SvPV(tmpcmd), SvCUR(tmpcmd));
+ fp = io->ifp;
+ sv_free(tmpcmd);
+ }
+ }
+ else if (type == OP_GLOB)
+ SP--;
+ }
+ if (!fp) {
+ if (dowarn)
+ warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
+ if (GIMME == G_SCALAR)
+ RETPUSHUNDEF;
+ RETURN;
+ }
+ if (GIMME == G_ARRAY) {
+ sv = sv_2mortal(NEWSV(57, 80));
+ offset = 0;
+ }
+ else {
+ sv = TARG;
+ SvUPGRADE(sv, SVt_PV);
+ tmplen = SvLEN(sv); /* remember if already alloced */
+ if (!tmplen)
+ Sv_Grow(sv, 80); /* try short-buffering it */
+ if (type == OP_RCATLINE)
+ offset = SvCUR(sv);
+ else
+ offset = 0;
+ }
+ for (;;) {
+ if (!sv_gets(sv, fp, offset)) {
+ clearerr(fp);
+ if (io->flags & IOf_ARGV) {
+ fp = nextargv(last_in_gv);
+ if (fp)
+ continue;
+ (void)do_close(last_in_gv, FALSE);
+ io->flags |= IOf_START;
+ }
+ else if (type == OP_GLOB) {
+ (void)do_close(last_in_gv, FALSE);
+ }
+ if (GIMME == G_SCALAR)
+ RETPUSHUNDEF;
+ RETURN;
+ }
+ io->lines++;
+ XPUSHs(sv);
+#ifdef TAINT
+ sv->sv_tainted = 1; /* Anything from the outside world...*/
+#endif
+ if (type == OP_GLOB) {
+ char *tmps;
+
+ if (SvCUR(sv) > 0)
+ SvCUR(sv)--;
+ if (*SvEND(sv) == rschar)
+ *SvEND(sv) = '\0';
+ else
+ SvCUR(sv)++;
+ for (tmps = SvPV(sv); *tmps; tmps++)
+ if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
+ index("$&*(){}[]'\";\\|?<>~`", *tmps))
+ break;
+ if (*tmps && stat(SvPV(sv), &statbuf) < 0) {
+ POPs; /* Unmatched wildcard? Chuck it... */
+ continue;
+ }
+ }
+ if (GIMME == G_ARRAY) {
+ if (SvLEN(sv) - SvCUR(sv) > 20) {
+ SvLEN_set(sv, SvCUR(sv)+1);
+ Renew(SvPV(sv), SvLEN(sv), char);
+ }
+ sv = sv_2mortal(NEWSV(58, 80));
+ continue;
+ }
+ else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
+ /* try to reclaim a bit of scalar space (only on 1st alloc) */
+ if (SvCUR(sv) < 60)
+ SvLEN_set(sv, 80);
+ else
+ SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
+ Renew(SvPV(sv), SvLEN(sv), char);
+ }
+ RETURN;
+ }
+}
+
+PP(pp_glob)
+{
+ OP *result;
+ ENTER;
+ SAVEINT(rschar);
+ SAVEINT(rslen);
+
+ SAVESPTR(last_in_gv); /* We don't want this to be permanent. */
+ last_in_gv = (GV*)*stack_sp--;
+
+ rslen = 1;
+#ifdef DOSISH
+ rschar = 0;
+#else
+#ifdef CSH
+ rschar = 0;
+#else
+ rschar = '\n';
+#endif /* !CSH */
+#endif /* !MSDOS */
+ result = do_readline();
+ LEAVE;
+ return result;
+}
+
+PP(pp_readline)
+{
+ last_in_gv = (GV*)(*stack_sp--);
+ return do_readline();
+}
+
+PP(pp_indread)
+{
+ last_in_gv = gv_fetchpv(SvPVnx(GvSV((GV*)(*stack_sp--))), TRUE);
+ return do_readline();
+}
+
+PP(pp_rcatline)
+{
+ last_in_gv = cGVOP->op_gv;
+ return do_readline();
+}
+
+PP(pp_regcomp) {
+ dSP;
+ register PMOP *pm = (PMOP*)cLOGOP->op_other;
+ register char *t;
+ I32 global;
+ SV *tmpstr;
+ register REGEXP *rx = pm->op_pmregexp;
+
+ global = pm->op_pmflags & PMf_GLOBAL;
+ tmpstr = POPs;
+ t = SvPVn(tmpstr);
+ if (!global && rx)
+ regfree(rx);
+ pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
+ pm->op_pmregexp = regcomp(t, t+SvCUR(tmpstr),
+ pm->op_pmflags & PMf_FOLD);
+ if (!pm->op_pmregexp->prelen && curpm)
+ pm = curpm;
+ if (pm->op_pmflags & PMf_KEEP) {
+ if (!(pm->op_pmflags & PMf_FOLD))
+ scan_prefix(pm, pm->op_pmregexp->precomp,
+ pm->op_pmregexp->prelen);
+ pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
+ hoistmust(pm);
+ op->op_type = OP_NULL;
+ op->op_ppaddr = ppaddr[OP_NULL];
+ /* XXX delete push code */
+ }
+ RETURN;
+}
+
+PP(pp_match)
+{
+ dSP; dTARG;
+ register PMOP *pm = cPMOP;
+ register char *t;
+ register char *s;
+ char *strend;
+ SV *tmpstr;
+ char *myhint = hint;
+ I32 global;
+ I32 safebase;
+ char *truebase;
+ register REGEXP *rx = pm->op_pmregexp;
+ I32 gimme = GIMME;
+
+ hint = Nullch;
+ global = pm->op_pmflags & PMf_GLOBAL;
+ safebase = (gimme == G_ARRAY) || global;
+
+ if (op->op_flags & OPf_STACKED)
+ TARG = POPs;
+ else {
+ TARG = GvSV(defgv);
+ EXTEND(SP,1);
+ }
+ s = SvPVn(TARG);
+ strend = s + SvCUR(TARG);
+ if (!s)
+ DIE("panic: do_match");
+
+ if (pm->op_pmflags & PMf_USED) {
+ if (gimme == G_ARRAY)
+ RETURN;
+ RETPUSHNO;
+ }
+
+ if (!rx->prelen && curpm) {
+ pm = curpm;
+ rx = pm->op_pmregexp;
+ }
+ truebase = t = s;
+play_it_again:
+ if (global && rx->startp[0]) {
+ t = s = rx->endp[0];
+ if (s == rx->startp[0])
+ s++, t++;
+ if (s > strend)
+ goto nope;
+ }
+ if (myhint) {
+ if (myhint < s || myhint > strend)
+ DIE("panic: hint in do_match");
+ s = myhint;
+ if (rx->regback >= 0) {
+ s -= rx->regback;
+ if (s < t)
+ s = t;
+ }
+ else
+ s = t;
+ }
+ else if (pm->op_pmshort) {
+ if (pm->op_pmflags & PMf_SCANFIRST) {
+ if (SvSCREAM(TARG)) {
+ if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
+ goto nope;
+ else if (!(s = screaminstr(TARG, pm->op_pmshort)))
+ goto nope;
+ else if (pm->op_pmflags & PMf_ALL)
+ goto yup;
+ }
+ else if (!(s = fbm_instr((unsigned char*)s,
+ (unsigned char*)strend, pm->op_pmshort)))
+ goto nope;
+ else if (pm->op_pmflags & PMf_ALL)
+ goto yup;
+ if (s && rx->regback >= 0) {
+ ++BmUSEFUL(pm->op_pmshort);
+ s -= rx->regback;
+ if (s < t)
+ s = t;
+ }
+ else
+ s = t;
+ }
+ else if (!multiline) {
+ if (*SvPV(pm->op_pmshort) != *s ||
+ bcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) ) {
+ if (pm->op_pmflags & PMf_FOLD) {
+ if (ibcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) )
+ goto nope;
+ }
+ else
+ goto nope;
+ }
+ }
+ if (--BmUSEFUL(pm->op_pmshort) < 0) {
+ sv_free(pm->op_pmshort);
+ pm->op_pmshort = Nullsv; /* opt is being useless */
+ }
+ }
+ if (!rx->nparens && !global) {
+ gimme = G_SCALAR; /* accidental array context? */
+ safebase = FALSE;
+ }
+ if (regexec(rx, s, strend, truebase, 0,
+ SvSCREAM(TARG) ? TARG : Nullsv,
+ safebase)) {
+ curpm = pm;
+ if (pm->op_pmflags & PMf_ONCE)
+ pm->op_pmflags |= PMf_USED;
+ goto gotcha;
+ }
+ else {
+ if (global)
+ rx->startp[0] = Nullch;
+ if (gimme == G_ARRAY)
+ RETURN;
+ RETPUSHNO;
+ }
+ /*NOTREACHED*/
+
+ gotcha:
+ if (gimme == G_ARRAY) {
+ I32 iters, i, len;
+
+ iters = rx->nparens;
+ if (global && !iters)
+ i = 1;
+ else
+ i = 0;
+ EXTEND(SP, iters + i);
+ for (i = !i; i <= iters; i++) {
+ PUSHs(sv_mortalcopy(&sv_no));
+ /*SUPPRESS 560*/
+ if (s = rx->startp[i]) {
+ len = rx->endp[i] - s;
+ if (len > 0)
+ sv_setpvn(*SP, s, len);
+ }
+ }
+ if (global) {
+ truebase = rx->subbeg;
+ goto play_it_again;
+ }
+ RETURN;
+ }
+ else {
+ RETPUSHYES;
+ }
+
+yup:
+ ++BmUSEFUL(pm->op_pmshort);
+ curpm = pm;
+ if (pm->op_pmflags & PMf_ONCE)
+ pm->op_pmflags |= PMf_USED;
+ if (global) {
+ rx->subbeg = t;
+ rx->subend = strend;
+ rx->startp[0] = s;
+ rx->endp[0] = s + SvCUR(pm->op_pmshort);
+ goto gotcha;
+ }
+ if (sawampersand) {
+ char *tmps;
+
+ if (rx->subbase)
+ Safefree(rx->subbase);
+ tmps = rx->subbase = nsavestr(t, strend-t);
+ rx->subbeg = tmps;
+ rx->subend = tmps + (strend-t);
+ tmps = rx->startp[0] = tmps + (s - t);
+ rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
+ }
+ RETPUSHYES;
+
+nope:
+ rx->startp[0] = Nullch;
+ if (pm->op_pmshort)
+ ++BmUSEFUL(pm->op_pmshort);
+ if (gimme == G_ARRAY)
+ RETURN;
+ RETPUSHNO;
+}
+
+PP(pp_subst)
+{
+ dSP; dTARG;
+ register PMOP *pm = cPMOP;
+ PMOP *rpm = pm;
+ register SV *dstr;
+ register char *s;
+ char *strend;
+ register char *m;
+ char *c;
+ register char *d;
+ I32 clen;
+ I32 iters = 0;
+ I32 maxiters;
+ register I32 i;
+ bool once;
+ char *orig;
+ I32 safebase;
+ register REGEXP *rx = pm->op_pmregexp;
+
+ if (pm->op_pmflags & PMf_CONST) /* known replacement string? */
+ dstr = POPs;
+ if (op->op_flags & OPf_STACKED)
+ TARG = POPs;
+ else {
+ TARG = GvSV(defgv);
+ EXTEND(SP,1);
+ }
+ s = SvPVn(TARG);
+ if (!pm || !s)
+ DIE("panic: do_subst");
+
+ strend = s + SvCUR(TARG);
+ maxiters = (strend - s) + 10;
+
+ if (!rx->prelen && curpm) {
+ pm = curpm;
+ rx = pm->op_pmregexp;
+ }
+ safebase = ((!rx || !rx->nparens) && !sawampersand);
+ orig = m = s;
+ if (hint) {
+ if (hint < s || hint > strend)
+ DIE("panic: hint in do_match");
+ s = hint;
+ hint = Nullch;
+ if (rx->regback >= 0) {
+ s -= rx->regback;
+ if (s < m)
+ s = m;
+ }
+ else
+ s = m;
+ }
+ else if (pm->op_pmshort) {
+ if (pm->op_pmflags & PMf_SCANFIRST) {
+ if (SvSCREAM(TARG)) {
+ if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
+ goto nope;
+ else if (!(s = screaminstr(TARG, pm->op_pmshort)))
+ goto nope;
+ }
+ else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
+ pm->op_pmshort)))
+ goto nope;
+ if (s && rx->regback >= 0) {
+ ++BmUSEFUL(pm->op_pmshort);
+ s -= rx->regback;
+ if (s < m)
+ s = m;
+ }
+ else
+ s = m;
+ }
+ else if (!multiline) {
+ if (*SvPV(pm->op_pmshort) != *s ||
+ bcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) ) {
+ if (pm->op_pmflags & PMf_FOLD) {
+ if (ibcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) )
+ goto nope;
+ }
+ else
+ goto nope;
+ }
+ }
+ if (--BmUSEFUL(pm->op_pmshort) < 0) {
+ sv_free(pm->op_pmshort);
+ pm->op_pmshort = Nullsv; /* opt is being useless */
+ }
+ }
+ once = !(rpm->op_pmflags & PMf_GLOBAL);
+ if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */
+ c = SvPVn(dstr);
+ clen = SvCUR(dstr);
+ if (clen <= rx->minlen) {
+ /* can do inplace substitution */
+ if (regexec(rx, s, strend, orig, 0,
+ SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
+ if (rx->subbase) /* oops, no we can't */
+ goto long_way;
+ d = s;
+ curpm = pm;
+ SvSCREAM_off(TARG); /* disable possible screamer */
+ if (once) {
+ m = rx->startp[0];
+ d = rx->endp[0];
+ s = orig;
+ if (m - s > strend - d) { /* faster to shorten from end */
+ if (clen) {
+ Copy(c, m, clen, char);
+ m += clen;
+ }
+ i = strend - d;
+ if (i > 0) {
+ Move(d, m, i, char);
+ m += i;
+ }
+ *m = '\0';
+ SvCUR_set(TARG, m - s);
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(&sv_yes);
+ RETURN;
+ }
+ /*SUPPRESS 560*/
+ else if (i = m - s) { /* faster from front */
+ d -= clen;
+ m = d;
+ sv_chop(TARG, d-i);
+ s += i;
+ while (i--)
+ *--d = *--s;
+ if (clen)
+ Copy(c, m, clen, char);
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(&sv_yes);
+ RETURN;
+ }
+ else if (clen) {
+ d -= clen;
+ sv_chop(TARG, d);
+ Copy(c, d, clen, char);
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(&sv_yes);
+ RETURN;
+ }
+ else {
+ sv_chop(TARG, d);
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(&sv_yes);
+ RETURN;
+ }
+ /* NOTREACHED */
+ }
+ do {
+ if (iters++ > maxiters)
+ DIE("Substitution loop");
+ m = rx->startp[0];
+ /*SUPPRESS 560*/
+ if (i = m - s) {
+ if (s != d)
+ Move(s, d, i, char);
+ d += i;
+ }
+ if (clen) {
+ Copy(c, d, clen, char);
+ d += clen;
+ }
+ s = rx->endp[0];
+ } while (regexec(rx, s, strend, orig, s == m,
+ Nullsv, TRUE)); /* (don't match same null twice) */
+ if (s != d) {
+ i = strend - s;
+ SvCUR_set(TARG, d - SvPV(TARG) + i);
+ Move(s, d, i+1, char); /* include the Null */
+ }
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(sv_2mortal(newSVnv((double)iters)));
+ RETURN;
+ }
+ PUSHs(&sv_no);
+ RETURN;
+ }
+ }
+ else
+ c = Nullch;
+ if (regexec(rx, s, strend, orig, 0,
+ SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
+ long_way:
+ dstr = NEWSV(25, sv_len(TARG));
+ sv_setpvn(dstr, m, s-m);
+ curpm = pm;
+ if (!c) {
+ register CONTEXT *cx;
+ PUSHSUBST(cx);
+ RETURNOP(cPMOP->op_pmreplroot);
+ }
+ do {
+ if (iters++ > maxiters)
+ DIE("Substitution loop");
+ if (rx->subbase && rx->subbase != orig) {
+ m = s;
+ s = orig;
+ orig = rx->subbase;
+ s = orig + (m - s);
+ strend = s + (strend - m);
+ }
+ m = rx->startp[0];
+ sv_catpvn(dstr, s, m-s);
+ s = rx->endp[0];
+ if (clen)
+ sv_catpvn(dstr, c, clen);
+ if (once)
+ break;
+ } while (regexec(rx, s, strend, orig, s == m, Nullsv,
+ safebase));
+ sv_catpvn(dstr, s, strend - s);
+ sv_replace(TARG, dstr);
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(sv_2mortal(newSVnv((double)iters)));
+ RETURN;
+ }
+ PUSHs(&sv_no);
+ RETURN;
+
+nope:
+ ++BmUSEFUL(pm->op_pmshort);
+ PUSHs(&sv_no);
+ RETURN;
+}
+
+PP(pp_substcont)
+{
+ dSP;
+ register PMOP *pm = (PMOP*) cLOGOP->op_other;
+ register CONTEXT *cx = &cxstack[cxstack_ix];
+ register SV *dstr = cx->sb_dstr;
+ register char *s = cx->sb_s;
+ register char *m = cx->sb_m;
+ char *orig = cx->sb_orig;
+ register REGEXP *rx = pm->op_pmregexp;
+
+ if (cx->sb_iters++) {
+ if (cx->sb_iters > cx->sb_maxiters)
+ DIE("Substitution loop");
+
+ sv_catsv(dstr, POPs);
+ if (rx->subbase)
+ Safefree(rx->subbase);
+ rx->subbase = cx->sb_subbase;
+
+ /* Are we done */
+ if (cx->sb_once || !regexec(rx, s, cx->sb_strend, orig,
+ s == m, Nullsv, cx->sb_safebase))
+ {
+ SV *targ = cx->sb_targ;
+ sv_catpvn(dstr, s, cx->sb_strend - s);
+ sv_replace(targ, dstr);
+ SvNOK_off(targ);
+ SvSETMAGIC(targ);
+ PUSHs(sv_2mortal(newSVnv((double)(cx->sb_iters - 1))));
+ POPSUBST(cx);
+ RETURNOP(pm->op_next);
+ }
+ }
+ if (rx->subbase && rx->subbase != orig) {
+ m = s;
+ s = orig;
+ cx->sb_orig = orig = rx->subbase;
+ s = orig + (m - s);
+ cx->sb_strend = s + (cx->sb_strend - m);
+ }
+ cx->sb_m = m = rx->startp[0];
+ sv_catpvn(dstr, s, m-s);
+ cx->sb_s = rx->endp[0];
+ cx->sb_subbase = rx->subbase;
+
+ rx->subbase = Nullch; /* so recursion works */
+ RETURNOP(pm->op_pmreplstart);
+}
+
+PP(pp_trans)
+{
+ dSP; dTARG;
+ SV *sv;
+
+ if (op->op_flags & OPf_STACKED)
+ sv = POPs;
+ else {
+ sv = GvSV(defgv);
+ EXTEND(SP,1);
+ }
+ TARG = NEWSV(27,0);
+ PUSHi(do_trans(sv, op));
+ RETURN;
+}
+
+/* Lvalue operators. */
+
+PP(pp_sassign)
+{
+ dSP; dPOPTOPssrl;
+#ifdef TAINT
+ if (tainted && !lstr->sv_tainted)
+ TAINT_NOT;
+#endif
+ SvSetSV(rstr, lstr);
+ SvSETMAGIC(rstr);
+ SETs(rstr);
+ RETURN;
+}
+
+PP(pp_aassign)
+{
+ dSP;
+ SV **lastlelem = stack_sp;
+ SV **lastrelem = stack_base + POPMARK;
+ SV **firstrelem = stack_base + POPMARK + 1;
+ SV **firstlelem = lastrelem + 1;
+
+ register SV **relem;
+ register SV **lelem;
+
+ register SV *sv;
+ register AV *ary;
+
+ HV *hash;
+ I32 i;
+
+ 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 (op->op_private & OPpASSIGN_COMMON) {
+ for (relem = firstrelem; relem <= lastrelem; relem++) {
+ /*SUPPRESS 560*/
+ if (sv = *relem)
+ *relem = sv_mortalcopy(sv);
+ }
+ }
+
+ relem = firstrelem;
+ lelem = firstlelem;
+ ary = Null(AV*);
+ hash = Null(HV*);
+ while (lelem <= lastlelem) {
+ sv = *lelem++;
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ ary = (AV*)sv;
+ AvREAL_on(ary);
+ AvFILL(ary) = -1;
+ i = 0;
+ while (relem <= lastrelem) { /* gobble up all the rest */
+ sv = NEWSV(28,0);
+ if (*relem)
+ sv_setsv(sv,*relem);
+ *(relem++) = sv;
+ (void)av_store(ary,i++,sv);
+ }
+ break;
+ case SVt_PVHV: {
+ char *tmps;
+ SV *tmpstr;
+ MAGIC* magic = 0;
+ I32 magictype;
+
+ hash = (HV*)sv;
+ hv_clear(hash, TRUE); /* wipe any dbm file too */
+
+ while (relem < lastrelem) { /* gobble up all the rest */
+ if (*relem)
+ sv = *(relem++);
+ else
+ sv = &sv_no, relem++;
+ tmps = SvPVn(sv);
+ tmpstr = NEWSV(29,0);
+ if (*relem)
+ sv_setsv(tmpstr,*relem); /* value */
+ *(relem++) = tmpstr;
+ (void)hv_store(hash,tmps,SvCUR(sv),tmpstr,0);
+ }
+ }
+ break;
+ default:
+ if (SvREADONLY(sv)) {
+ if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
+ DIE(no_modify);
+ if (relem <= lastrelem)
+ relem++;
+ break;
+ }
+ if (relem <= lastrelem) {
+ sv_setsv(sv, *relem);
+ *(relem++) = sv;
+ }
+ else
+ sv_setsv(sv, &sv_undef);
+ SvSETMAGIC(sv);
+ break;
+ }
+ }
+ if (delaymagic & ~DM_DELAY) {
+ if (delaymagic & DM_UID) {
+#ifdef HAS_SETREUID
+ (void)setreuid(uid,euid);
+#else /* not HAS_SETREUID */
+#ifdef HAS_SETRUID
+ if ((delaymagic & DM_UID) == DM_RUID) {
+ (void)setruid(uid);
+ delaymagic =~ DM_RUID;
+ }
+#endif /* HAS_SETRUID */
+#ifdef HAS_SETEUID
+ if ((delaymagic & DM_UID) == DM_EUID) {
+ (void)seteuid(uid);
+ delaymagic =~ DM_EUID;
+ }
+#endif /* HAS_SETEUID */
+ if (delaymagic & DM_UID) {
+ if (uid != euid)
+ DIE("No setreuid available");
+ (void)setuid(uid);
+ }
+#endif /* not HAS_SETREUID */
+ uid = (int)getuid();
+ euid = (int)geteuid();
+ }
+ if (delaymagic & DM_GID) {
+#ifdef HAS_SETREGID
+ (void)setregid(gid,egid);
+#else /* not HAS_SETREGID */
+#ifdef HAS_SETRGID
+ if ((delaymagic & DM_GID) == DM_RGID) {
+ (void)setrgid(gid);
+ delaymagic =~ DM_RGID;
+ }
+#endif /* HAS_SETRGID */
+#ifdef HAS_SETEGID
+ if ((delaymagic & DM_GID) == DM_EGID) {
+ (void)setegid(gid);
+ delaymagic =~ DM_EGID;
+ }
+#endif /* HAS_SETEGID */
+ if (delaymagic & DM_GID) {
+ if (gid != egid)
+ DIE("No setregid available");
+ (void)setgid(gid);
+ }
+#endif /* not HAS_SETREGID */
+ gid = (int)getgid();
+ egid = (int)getegid();
+ }
+ }
+ delaymagic = 0;
+ if (GIMME == G_ARRAY) {
+ if (ary || hash)
+ SP = lastrelem;
+ else
+ SP = firstrelem + (lastlelem - firstlelem);
+ RETURN;
+ }
+ else {
+ dTARGET;
+ SP = firstrelem;
+ SETi(lastrelem - firstrelem + 1);
+ RETURN;
+ }
+}
+
+PP(pp_schop)
+{
+ dSP; dTARGET;
+ SV *sv;
+
+ if (MAXARG < 1)
+ sv = GvSV(defgv);
+ else
+ sv = POPs;
+ do_chop(TARG, sv);
+ PUSHTARG;
+ RETURN;
+}
+
+PP(pp_chop)
+{
+ dSP; dMARK; dTARGET;
+ while (SP > MARK)
+ do_chop(TARG, POPs);
+ PUSHTARG;
+ RETURN;
+}
+
+PP(pp_defined)
+{
+ dSP;
+ register SV* sv;
+
+ if (MAXARG < 1) {
+ sv = GvSV(defgv);
+ EXTEND(SP, 1);
+ }
+ else
+ sv = POPs;
+ if (!sv || !SvANY(sv))
+ RETPUSHNO;
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ if (AvMAX(sv) >= 0)
+ RETPUSHYES;
+ break;
+ case SVt_PVHV:
+ if (HvARRAY(sv))
+ RETPUSHYES;
+ break;
+ case SVt_PVCV:
+ if (CvROOT(sv))
+ RETPUSHYES;
+ break;
+ default:
+ if (SvOK(sv))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+}
+
+PP(pp_undef)
+{
+ dSP;
+ SV *sv;
+
+ if (!op->op_private)
+ RETPUSHUNDEF;
+
+ sv = POPs;
+ if (SvREADONLY(sv))
+ RETPUSHUNDEF;
+
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ break;
+ case SVt_PVAV:
+ av_undef((AV*)sv);
+ break;
+ case SVt_PVHV:
+ hv_undef((HV*)sv);
+ break;
+ case SVt_PVCV: {
+ CV *cv = (CV*)sv;
+ op_free(CvROOT(cv));
+ CvROOT(cv) = 0;
+ break;
+ }
+ default:
+ if (sv != GvSV(defgv)) {
+ if (SvPOK(sv) && SvLEN(sv)) {
+ SvOOK_off(sv);
+ Safefree(SvPV(sv));
+ SvPV_set(sv, Nullch);
+ SvLEN_set(sv, 0);
+ }
+ SvOK_off(sv);
+ SvSETMAGIC(sv);
+ }
+ }
+
+ RETPUSHUNDEF;
+}
+
+PP(pp_study)
+{
+ dSP; dTARGET;
+ register unsigned char *s;
+ register I32 pos;
+ register I32 ch;
+ register I32 *sfirst;
+ register I32 *snext;
+ I32 retval;
+
+ s = (unsigned char*)(SvPVn(TARG));
+ pos = SvCUR(TARG);
+ if (lastscream)
+ SvSCREAM_off(lastscream);
+ lastscream = TARG;
+ if (pos <= 0) {
+ retval = 0;
+ goto ret;
+ }
+ if (pos > maxscream) {
+ if (maxscream < 0) {
+ maxscream = pos + 80;
+ New(301, screamfirst, 256, I32);
+ New(302, screamnext, maxscream, I32);
+ }
+ else {
+ maxscream = pos + pos / 4;
+ Renew(screamnext, maxscream, I32);
+ }
+ }
+
+ sfirst = screamfirst;
+ snext = screamnext;
+
+ if (!sfirst || !snext)
+ DIE("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;
+ }
+
+ SvSCREAM_on(TARG);
+ retval = 1;
+ ret:
+ XPUSHs(sv_2mortal(newSVnv((double)retval)));
+ RETURN;
+}
+
+PP(pp_preinc)
+{
+ dSP;
+ sv_inc(TOPs);
+ SvSETMAGIC(TOPs);
+ return NORMAL;
+}
+
+PP(pp_predec)
+{
+ dSP;
+ sv_dec(TOPs);
+ SvSETMAGIC(TOPs);
+ return NORMAL;
+}
+
+PP(pp_postinc)
+{
+ dSP; dTARGET;
+ sv_setsv(TARG, TOPs);
+ sv_inc(TOPs);
+ SvSETMAGIC(TOPs);
+ SETs(TARG);
+ return NORMAL;
+}
+
+PP(pp_postdec)
+{
+ dSP; dTARGET;
+ sv_setsv(TARG, TOPs);
+ sv_dec(TOPs);
+ SvSETMAGIC(TOPs);
+ SETs(TARG);
+ return NORMAL;
+}
+
+/* Ordinary operators. */
+
+PP(pp_pow)
+{
+ dSP; dATARGET; dPOPTOPnnrl;
+ SETn( pow( left, right) );
+ RETURN;
+}
+
+PP(pp_multiply)
+{
+ dSP; dATARGET; dPOPTOPnnrl;
+ SETn( left * right );
+ RETURN;
+}
+
+PP(pp_divide)
+{
+ dSP; dATARGET; dPOPnv;
+ if (value == 0.0)
+ DIE("Illegal division by zero");
+#ifdef SLOPPYDIVIDE
+ /* insure that 20./5. == 4. */
+ {
+ double x;
+ I32 k;
+ x = POPn;
+ if ((double)(I32)x == x &&
+ (double)(I32)value == value &&
+ (k = (I32)x/(I32)value)*(I32)value == (I32)x) {
+ value = k;
+ } else {
+ value = x/value;
+ }
+ }
+#else
+ value = POPn / value;
+#endif
+ PUSHn( value );
+ RETURN;
+}
+
+PP(pp_modulo)
+{
+ dSP; dATARGET;
+ register unsigned long tmpulong;
+ register long tmplong;
+ I32 value;
+
+ tmpulong = (unsigned long) POPn;
+ if (tmpulong == 0L)
+ DIE("Illegal modulus zero");
+ value = TOPn;
+ if (value >= 0.0)
+ value = (I32)(((unsigned long)value) % tmpulong);
+ else {
+ tmplong = (long)value;
+ value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
+ }
+ SETi(value);
+ RETURN;
+}
+
+PP(pp_repeat)
+{
+ dSP; dATARGET;
+ register I32 count = POPi;
+ if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
+ dMARK;
+ I32 items = SP - MARK;
+ I32 max;
+
+ max = items * count;
+ MEXTEND(MARK, max);
+ if (count > 1) {
+ while (SP > MARK) {
+ if (*SP)
+ SvTEMP_off((*SP));
+ SP--;
+ }
+ MARK++;
+ repeatcpy(MARK + items, MARK, items * sizeof(SV*), count - 1);
+ }
+ SP += max;
+ }
+ else { /* Note: mark already snarfed by pp_list */
+ SV *tmpstr;
+ char *tmps;
+
+ tmpstr = POPs;
+ SvSetSV(TARG, tmpstr);
+ if (count >= 1) {
+ tmpstr = NEWSV(50, 0);
+ tmps = SvPVn(TARG);
+ sv_setpvn(tmpstr, tmps, SvCUR(TARG));
+ tmps = SvPVn(tmpstr); /* force to be string */
+ SvGROW(TARG, (count * SvCUR(TARG)) + 1);
+ repeatcpy(SvPV(TARG), tmps, SvCUR(tmpstr), count);
+ SvCUR(TARG) *= count;
+ *SvEND(TARG) = '\0';
+ SvNOK_off(TARG);
+ sv_free(tmpstr);
+ }
+ else {
+ if (dowarn && SvPOK(SP[1]) && !looks_like_number(SP[1]))
+ warn("Right operand of x is not numeric");
+ sv_setsv(TARG, &sv_no);
+ }
+ PUSHTARG;
+ }
+ RETURN;
+}
+
+PP(pp_add)
+{
+ dSP; dATARGET; dPOPTOPnnrl;
+ SETn( left + right );
+ RETURN;
+}
+
+PP(pp_intadd)
+{
+ dSP; dATARGET; dPOPTOPiirl;
+ SETi( left + right );
+ RETURN;
+}
+
+PP(pp_subtract)
+{
+ dSP; dATARGET; dPOPTOPnnrl;
+ SETn( left - right );
+ RETURN;
+}
+
+PP(pp_concat)
+{
+ dSP; dATARGET; dPOPTOPssrl;
+ SvSetSV(TARG, lstr);
+ sv_catsv(TARG, rstr);
+ SETTARG;
+ RETURN;
+}
+
+PP(pp_left_shift)
+{
+ dSP; dATARGET;
+ I32 anum = POPi;
+ double value = TOPn;
+ SETi( U_L(value) << anum );
+ RETURN;
+}
+
+PP(pp_right_shift)
+{
+ dSP; dATARGET;
+ I32 anum = POPi;
+ double value = TOPn;
+ SETi( U_L(value) >> anum );
+ RETURN;
+}
+
+PP(pp_lt)
+{
+ dSP; dPOPnv;
+ SETs((TOPn < value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_gt)
+{
+ dSP; dPOPnv;
+ SETs((TOPn > value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_le)
+{
+ dSP; dPOPnv;
+ SETs((TOPn <= value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_ge)
+{
+ dSP; dPOPnv;
+ SETs((TOPn >= value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_eq)
+{
+ dSP; double value;
+
+ if (dowarn) {
+ if ((!SvNIOK(SP[ 0]) && !looks_like_number(SP[ 0])) ||
+ (!SvNIOK(SP[-1]) && !looks_like_number(SP[-1])) )
+ warn("Possible use of == on string value");
+ }
+
+ value = POPn;
+ SETs((TOPn == value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_ne)
+{
+ dSP; dPOPnv;
+ SETs((TOPn != value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_ncmp)
+{
+ dSP; dTARGET; dPOPTOPnnrl;
+ I32 value;
+
+ if (left > right)
+ value = 1;
+ else if (left < right)
+ value = -1;
+ else
+ value = 0;
+ SETi(value);
+ RETURN;
+}
+
+PP(pp_slt)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_cmp(lstr, rstr) < 0 ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_sgt)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_cmp(lstr, rstr) > 0 ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_sle)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_cmp(lstr, rstr) <= 0 ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_sge)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_cmp(lstr, rstr) >= 0 ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_seq)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_sne)
+{
+ dSP; dPOPTOPssrl;
+ SETs( !sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_scmp)
+{
+ dSP; dTARGET;
+ dPOPTOPssrl;
+ SETi( sv_cmp(lstr, rstr) );
+ RETURN;
+}
+
+PP(pp_bit_and)
+{
+ dSP; dATARGET; dPOPTOPssrl;
+ if (SvNIOK(lstr) || SvNIOK(rstr)) {
+ I32 value = SvIVn(lstr);
+ value = value & SvIVn(rstr);
+ SETi(value);
+ }
+ else {
+ do_vop(op->op_type, TARG, lstr, rstr);
+ SETTARG;
+ }
+ RETURN;
+}
+
+PP(pp_xor)
+{
+ dSP; dATARGET; dPOPTOPssrl;
+ if (SvNIOK(lstr) || SvNIOK(rstr)) {
+ I32 value = SvIVn(lstr);
+ value = value ^ SvIVn(rstr);
+ SETi(value);
+ }
+ else {
+ do_vop(op->op_type, TARG, lstr, rstr);
+ SETTARG;
+ }
+ RETURN;
+}
+
+PP(pp_bit_or)
+{
+ dSP; dATARGET; dPOPTOPssrl;
+ if (SvNIOK(lstr) || SvNIOK(rstr)) {
+ I32 value = SvIVn(lstr);
+ value = value | SvIVn(rstr);
+ SETi(value);
+ }
+ else {
+ do_vop(op->op_type, TARG, lstr, rstr);
+ SETTARG;
+ }
+ RETURN;
+}
+
+PP(pp_negate)
+{
+ dSP; dTARGET;
+ SETn(-TOPn);
+ RETURN;
+}
+
+PP(pp_not)
+{
+ *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
+ return NORMAL;
+}
+
+PP(pp_complement)
+{
+ dSP; dTARGET; dTOPss;
+ register I32 anum;
+
+ if (SvNIOK(sv)) {
+ SETi( ~SvIVn(sv) );
+ }
+ else {
+ register char *tmps;
+ register long *tmpl;
+
+ SvSetSV(TARG, sv);
+ tmps = SvPVn(TARG);
+ anum = SvCUR(TARG);
+#ifdef LIBERAL
+ for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
+ *tmps = ~*tmps;
+ tmpl = (long*)tmps;
+ for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
+ *tmpl = ~*tmpl;
+ tmps = (char*)tmpl;
+#endif
+ for ( ; anum > 0; anum--, tmps++)
+ *tmps = ~*tmps;
+
+ SETs(TARG);
+ }
+ RETURN;
+}
+
+/* High falutin' math. */
+
+PP(pp_atan2)
+{
+ dSP; dTARGET; dPOPTOPnnrl;
+ SETn(atan2(left, right));
+ RETURN;
+}
+
+PP(pp_sin)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ value = sin(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_cos)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ value = cos(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_rand)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = 1.0;
+ else
+ value = POPn;
+ 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
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_srand)
+{
+ dSP;
+ I32 anum;
+ time_t when;
+
+ if (MAXARG < 1) {
+ (void)time(&when);
+ anum = when;
+ }
+ else
+ anum = POPi;
+ (void)srand(anum);
+ EXTEND(SP, 1);
+ RETPUSHYES;
+}
+
+PP(pp_exp)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ value = exp(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_log)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ if (value <= 0.0)
+ DIE("Can't take log of %g\n", value);
+ value = log(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_sqrt)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ if (value < 0.0)
+ DIE("Can't take sqrt of %g\n", value);
+ value = sqrt(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_int)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ if (value >= 0.0)
+ (void)modf(value, &value);
+ else {
+ (void)modf(-value, &value);
+ value = -value;
+ }
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_hex)
+{
+ dSP; dTARGET;
+ char *tmps;
+ I32 argtype;
+
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+ XPUSHi( scan_hex(tmps, 99, &argtype) );
+ RETURN;
+}
+
+PP(pp_oct)
+{
+ dSP; dTARGET;
+ I32 value;
+ I32 argtype;
+ char *tmps;
+
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+ while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
+ tmps++;
+ if (*tmps == 'x')
+ value = (I32)scan_hex(++tmps, 99, &argtype);
+ else
+ value = (I32)scan_oct(tmps, 99, &argtype);
+ XPUSHi(value);
+ RETURN;
+}
+
+/* String stuff. */
+
+PP(pp_length)
+{
+ dSP; dTARGET;
+ if (MAXARG < 1) {
+ XPUSHi( sv_len(GvSV(defgv)) );
+ }
+ else
+ SETi( sv_len(TOPs) );
+ RETURN;
+}
+
+PP(pp_substr)
+{
+ dSP; dTARGET;
+ SV *sv;
+ I32 len;
+ I32 curlen;
+ I32 pos;
+ I32 rem;
+ I32 lvalue = op->op_flags & OPf_LVAL;
+ char *tmps;
+
+ if (MAXARG > 2)
+ len = POPi;
+ pos = POPi - arybase;
+ sv = POPs;
+ tmps = SvPVn(sv); /* force conversion to string */
+ curlen = SvCUR(sv);
+ if (pos < 0)
+ pos += curlen + arybase;
+ if (pos < 0 || pos > curlen)
+ sv_setpvn(TARG, "", 0);
+ else {
+ if (MAXARG < 3)
+ len = curlen;
+ if (len < 0)
+ len = 0;
+ tmps += pos;
+ rem = curlen - pos; /* rem=how many bytes left*/
+ if (rem > len)
+ rem = len;
+ sv_setpvn(TARG, tmps, rem);
+ if (lvalue) { /* it's an lvalue! */
+ LvTYPE(TARG) = 's';
+ LvTARG(TARG) = sv;
+ LvTARGOFF(TARG) = tmps - SvPVn(sv);
+ LvTARGLEN(TARG) = rem;
+ }
+ }
+ PUSHs(TARG); /* avoid SvSETMAGIC here */
+ RETURN;
+}
+
+PP(pp_vec)
+{
+ dSP; dTARGET;
+ register I32 size = POPi;
+ register I32 offset = POPi;
+ register SV *src = POPs;
+ I32 lvalue = op->op_flags & OPf_LVAL;
+ unsigned char *s = (unsigned char*)SvPVn(src);
+ unsigned long retnum;
+ I32 len;
+
+ offset *= size; /* turn into bit offset */
+ len = (offset + size + 7) / 8;
+ if (offset < 0 || size < 1)
+ retnum = 0;
+ else if (!lvalue && len > SvCUR(src))
+ retnum = 0;
+ else {
+ if (len > SvCUR(src)) {
+ SvGROW(src, len);
+ (void)memzero(SvPV(src) + SvCUR(src), len - SvCUR(src));
+ SvCUR_set(src, len);
+ }
+ s = (unsigned char*)SvPVn(src);
+ 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 = ((unsigned long) s[offset] << 8) + s[offset+1];
+ else if (size == 32)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8) + s[offset+3];
+ }
+
+ if (lvalue) { /* it's an lvalue! */
+ LvTYPE(TARG) = 'v';
+ LvTARG(TARG) = src;
+ LvTARGOFF(TARG) = offset;
+ LvTARGLEN(TARG) = size;
+ }
+ }
+
+ sv_setiv(TARG, (I32)retnum);
+ PUSHs(TARG);
+ RETURN;
+}
+
+PP(pp_index)
+{
+ dSP; dTARGET;
+ SV *big;
+ SV *little;
+ I32 offset;
+ I32 retval;
+ char *tmps;
+ char *tmps2;
+
+ if (MAXARG < 3)
+ offset = 0;
+ else
+ offset = POPi - arybase;
+ little = POPs;
+ big = POPs;
+ tmps = SvPVn(big);
+ if (offset < 0)
+ offset = 0;
+ else if (offset > SvCUR(big))
+ offset = SvCUR(big);
+ if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
+ (unsigned char*)tmps + SvCUR(big), little)))
+ retval = -1 + arybase;
+ else
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
+ RETURN;
+}
+
+PP(pp_rindex)
+{
+ dSP; dTARGET;
+ SV *big;
+ SV *little;
+ SV *offstr;
+ I32 offset;
+ I32 retval;
+ char *tmps;
+ char *tmps2;
+
+ if (MAXARG == 3)
+ offstr = POPs;
+ little = POPs;
+ big = POPs;
+ tmps2 = SvPVn(little);
+ tmps = SvPVn(big);
+ if (MAXARG < 3)
+ offset = SvCUR(big);
+ else
+ offset = SvIVn(offstr) - arybase + SvCUR(little);
+ if (offset < 0)
+ offset = 0;
+ else if (offset > SvCUR(big))
+ offset = SvCUR(big);
+ if (!(tmps2 = rninstr(tmps, tmps + offset,
+ tmps2, tmps2 + SvCUR(little))))
+ retval = -1 + arybase;
+ else
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
+ RETURN;
+}
+
+PP(pp_sprintf)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ do_sprintf(TARG, SP-MARK, MARK+1);
+ SP = ORIGMARK;
+ PUSHTARG;
+ RETURN;
+}
+
+static void
+doparseform(sv)
+SV *sv;
+{
+ register char *s = SvPVn(sv);
+ register char *send = s + SvCUR(sv);
+ register char *base;
+ register I32 skipspaces = 0;
+ bool noblank;
+ bool repeat;
+ bool postspace = FALSE;
+ U16 *fops;
+ register U16 *fpc;
+ U16 *linepc;
+ register I32 arg;
+ bool ischop;
+
+ New(804, fops, send - s, U16); /* Almost certainly too long... */
+ fpc = fops;
+
+ if (s < send) {
+ linepc = fpc;
+ *fpc++ = FF_LINEMARK;
+ noblank = repeat = FALSE;
+ base = s;
+ }
+
+ while (s <= send) {
+ switch (*s++) {
+ default:
+ skipspaces = 0;
+ continue;
+
+ case '~':
+ if (*s == '~') {
+ repeat = TRUE;
+ *s = ' ';
+ }
+ noblank = TRUE;
+ s[-1] = ' ';
+ /* FALL THROUGH */
+ case ' ': case '\t':
+ skipspaces++;
+ continue;
+
+ case '\n': case 0:
+ arg = s - base;
+ skipspaces++;
+ arg -= skipspaces;
+ if (arg) {
+ if (postspace) {
+ *fpc++ = FF_SPACE;
+ postspace = FALSE;
+ }
+ *fpc++ = FF_LITERAL;
+ *fpc++ = arg;
+ }
+ if (s <= send)
+ skipspaces--;
+ if (skipspaces) {
+ *fpc++ = FF_SKIP;
+ *fpc++ = skipspaces;
+ }
+ skipspaces = 0;
+ if (s <= send)
+ *fpc++ = FF_NEWLINE;
+ if (noblank) {
+ *fpc++ = FF_BLANK;
+ if (repeat)
+ arg = fpc - linepc + 1;
+ else
+ arg = 0;
+ *fpc++ = arg;
+ }
+ if (s < send) {
+ linepc = fpc;
+ *fpc++ = FF_LINEMARK;
+ noblank = repeat = FALSE;
+ base = s;
+ }
+ else
+ s++;
+ continue;
+
+ case '@':
+ case '^':
+ ischop = s[-1] == '^';
+
+ if (postspace) {
+ *fpc++ = FF_SPACE;
+ postspace = FALSE;
+ }
+ arg = (s - base) - 1;
+ if (arg) {
+ *fpc++ = FF_LITERAL;
+ *fpc++ = arg;
+ }
+
+ base = s - 1;
+ *fpc++ = FF_FETCH;
+ if (*s == '*') {
+ s++;
+ *fpc++ = 0;
+ *fpc++ = FF_LINEGLOB;
+ }
+ else if (*s == '#' || (*s == '.' && s[1] == '#')) {
+ arg = ischop ? 512 : 0;
+ base = s - 1;
+ while (*s == '#')
+ s++;
+ if (*s == '.') {
+ char *f;
+ s++;
+ f = s;
+ while (*s == '#')
+ s++;
+ arg |= 256 + (s - f);
+ }
+ *fpc++ = s - base; /* fieldsize for FETCH */
+ *fpc++ = FF_DECIMAL;
+ *fpc++ = arg;
+ }
+ else {
+ I32 prespace = 0;
+ bool ismore = FALSE;
+
+ if (*s == '>') {
+ while (*++s == '>') ;
+ prespace = FF_SPACE;
+ }
+ else if (*s == '|') {
+ while (*++s == '|') ;
+ prespace = FF_HALFSPACE;
+ postspace = TRUE;
+ }
+ else {
+ if (*s == '<')
+ while (*++s == '<') ;
+ postspace = TRUE;
+ }
+ if (*s == '.' && s[1] == '.' && s[2] == '.') {
+ s += 3;
+ ismore = TRUE;
+ }
+ *fpc++ = s - base; /* fieldsize for FETCH */
+
+ *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
+
+ if (prespace)
+ *fpc++ = prespace;
+ *fpc++ = FF_ITEM;
+ if (ismore)
+ *fpc++ = FF_MORE;
+ if (ischop)
+ *fpc++ = FF_CHOP;
+ }
+ base = s;
+ skipspaces = 0;
+ continue;
+ }
+ }
+ *fpc++ = FF_END;
+
+ arg = fpc - fops;
+ SvGROW(sv, SvCUR(sv) + arg * sizeof(U16) + 4);
+
+ s = SvPV(sv) + SvCUR(sv);
+ s += 2 + (SvCUR(sv) & 1);
+
+ Copy(fops, s, arg, U16);
+ Safefree(fops);
+}
+
+PP(pp_formline)
+{
+ dSP; dMARK; dORIGMARK;
+ register SV *form = *++MARK;
+ register U16 *fpc;
+ register char *t;
+ register char *f;
+ register char *s;
+ register char *send;
+ register I32 arg;
+ register SV *sv;
+ I32 itemsize;
+ I32 fieldsize;
+ I32 lines = 0;
+ bool chopspace = (index(chopset, ' ') != Nullch);
+ char *chophere;
+ char *linemark;
+ char *formmark;
+ SV **markmark;
+ double value;
+ bool gotsome;
+
+ if (!SvCOMPILED(form))
+ doparseform(form);
+
+ SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
+ t = SvPVn(formtarget);
+ t += SvCUR(formtarget);
+ f = SvPVn(form);
+
+ s = f + SvCUR(form);
+ s += 2 + (SvCUR(form) & 1);
+
+ fpc = (U16*)s;
+
+ for (;;) {
+ DEBUG_f( {
+ char *name = "???";
+ arg = -1;
+ switch (*fpc) {
+ case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
+ case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
+ case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
+ case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
+ case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
+
+ case FF_CHECKNL: name = "CHECKNL"; break;
+ case FF_CHECKCHOP: name = "CHECKCHOP"; break;
+ case FF_SPACE: name = "SPACE"; break;
+ case FF_HALFSPACE: name = "HALFSPACE"; break;
+ case FF_ITEM: name = "ITEM"; break;
+ case FF_CHOP: name = "CHOP"; break;
+ case FF_LINEGLOB: name = "LINEGLOB"; break;
+ case FF_NEWLINE: name = "NEWLINE"; break;
+ case FF_MORE: name = "MORE"; break;
+ case FF_LINEMARK: name = "LINEMARK"; break;
+ case FF_END: name = "END"; break;
+ }
+ if (arg >= 0)
+ fprintf(stderr, "%-16s%d\n", name, arg);
+ else
+ fprintf(stderr, "%-16s\n", name);
+ } )
+ switch (*fpc++) {
+ case FF_LINEMARK:
+ linemark = t;
+ formmark = f;
+ markmark = MARK;
+ lines++;
+ gotsome = FALSE;
+ break;
+
+ case FF_LITERAL:
+ arg = *fpc++;
+ while (arg--)
+ *t++ = *f++;
+ break;
+
+ case FF_SKIP:
+ f += *fpc++;
+ break;
+
+ case FF_FETCH:
+ arg = *fpc++;
+ f += arg;
+ fieldsize = arg;
+
+ if (MARK < SP)
+ sv = *++MARK;
+ else {
+ sv = &sv_no;
+ if (dowarn)
+ warn("Not enough format arguments");
+ }
+ break;
+
+ case FF_CHECKNL:
+ s = SvPVn(sv);
+ itemsize = SvCUR(sv);
+ if (itemsize > fieldsize)
+ itemsize = fieldsize;
+ send = chophere = s + itemsize;
+ while (s < send) {
+ if (*s & ~31)
+ gotsome = TRUE;
+ else if (*s == '\n')
+ break;
+ s++;
+ }
+ itemsize = s - SvPV(sv);
+ break;
+
+ case FF_CHECKCHOP:
+ s = SvPVn(sv);
+ itemsize = SvCUR(sv);
+ if (itemsize > fieldsize)
+ itemsize = fieldsize;
+ send = chophere = s + itemsize;
+ while (s < send || (s == send && isSPACE(*s))) {
+ if (isSPACE(*s)) {
+ if (chopspace)
+ chophere = s;
+ if (*s == '\r')
+ break;
+ }
+ else {
+ if (*s & ~31)
+ gotsome = TRUE;
+ if (index(chopset, *s))
+ chophere = s + 1;
+ }
+ s++;
+ }
+ itemsize = chophere - SvPV(sv);
+ break;
+
+ case FF_SPACE:
+ arg = fieldsize - itemsize;
+ if (arg) {
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ break;
+
+ case FF_HALFSPACE:
+ arg = fieldsize - itemsize;
+ if (arg) {
+ arg /= 2;
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ break;
+
+ case FF_ITEM:
+ arg = itemsize;
+ s = SvPV(sv);
+ while (arg--) {
+ if ((*t++ = *s++) < ' ')
+ t[-1] = ' ';
+ }
+ break;
+
+ case FF_CHOP:
+ s = chophere;
+ if (chopspace) {
+ while (*s && isSPACE(*s))
+ s++;
+ }
+ sv_chop(sv,s);
+ break;
+
+ case FF_LINEGLOB:
+ s = SvPVn(sv);
+ itemsize = SvCUR(sv);
+ if (itemsize) {
+ gotsome = TRUE;
+ send = s + itemsize;
+ while (s < send) {
+ if (*s++ == '\n') {
+ if (s == send)
+ itemsize--;
+ else
+ lines++;
+ }
+ }
+ SvCUR_set(formtarget, t - SvPV(formtarget));
+ sv_catpvn(formtarget, SvPV(sv), itemsize);
+ SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
+ t = SvPV(formtarget) + SvCUR(formtarget);
+ }
+ break;
+
+ case FF_DECIMAL:
+ /* If the field is marked with ^ and the value is undefined,
+ blank it out. */
+ arg = *fpc++;
+ if ((arg & 512) && !SvOK(sv)) {
+ arg = fieldsize;
+ while (arg--)
+ *t++ = ' ';
+ break;
+ }
+ gotsome = TRUE;
+ value = SvNVn(sv);
+ if (arg & 256) {
+ sprintf(t, "%#*.*f", fieldsize, arg & 255, value);
+ } else {
+ sprintf(t, "%*.0f", fieldsize, value);
+ }
+ t += fieldsize;
+ break;
+
+ case FF_NEWLINE:
+ f++;
+ while (t-- > linemark && *t == ' ') ;
+ t++;
+ *t++ = '\n';
+ break;
+
+ case FF_BLANK:
+ arg = *fpc++;
+ if (gotsome) {
+ if (arg) { /* repeat until fields exhausted? */
+ fpc -= arg;
+ f = formmark;
+ MARK = markmark;
+ if (lines == 200) {
+ arg = t - linemark;
+ if (strnEQ(linemark, linemark - t, arg))
+ DIE("Runaway format");
+ }
+ arg = t - SvPV(formtarget);
+ SvGROW(formtarget,
+ (t - SvPV(formtarget)) + (f - formmark) + 1);
+ t = SvPV(formtarget) + arg;
+ }
+ }
+ else {
+ t = linemark;
+ lines--;
+ }
+ break;
+
+ case FF_MORE:
+ if (SvCUR(sv)) {
+ arg = fieldsize - itemsize;
+ if (arg) {
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ s = t - 3;
+ if (strnEQ(s," ",3)) {
+ while (s > SvPV(formtarget) && isSPACE(s[-1]))
+ s--;
+ }
+ *s++ = '.';
+ *s++ = '.';
+ *s++ = '.';
+ }
+ break;
+
+ case FF_END:
+ *t = '\0';
+ SvCUR_set(formtarget, t - SvPV(formtarget));
+ FmLINES(formtarget) += lines;
+ SP = ORIGMARK;
+ RETPUSHYES;
+ }
+ }
+}
+
+PP(pp_ord)
+{
+ dSP; dTARGET;
+ I32 value;
+ char *tmps;
+ I32 anum;
+
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+#ifndef I286
+ value = (I32) (*tmps & 255);
+#else
+ anum = (I32) *tmps;
+ value = (I32) (anum & 255);
+#endif
+ XPUSHi(value);
+ RETURN;
+}
+
+PP(pp_crypt)
+{
+ dSP; dTARGET; dPOPTOPssrl;
+#ifdef HAS_CRYPT
+ char *tmps = SvPVn(lstr);
+#ifdef FCRYPT
+ sv_setpv(TARG, fcrypt(tmps, SvPVn(rstr)));
+#else
+ sv_setpv(TARG, crypt(tmps, SvPVn(rstr)));
+#endif
+#else
+ DIE(
+ "The crypt() function is unimplemented due to excessive paranoia.");
+#endif
+ SETs(TARG);
+ RETURN;
+}
+
+PP(pp_ucfirst)
+{
+ dSP;
+ SV *sv = TOPs;
+ register char *s;
+
+ if (SvSTORAGE(sv) != 'T') {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPVn(sv);
+ if (isascii(*s) && islower(*s))
+ *s = toupper(*s);
+
+ RETURN;
+}
+
+PP(pp_lcfirst)
+{
+ dSP;
+ SV *sv = TOPs;
+ register char *s;
+
+ if (SvSTORAGE(sv) != 'T') {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPVn(sv);
+ if (isascii(*s) && isupper(*s))
+ *s = tolower(*s);
+
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_uc)
+{
+ dSP;
+ SV *sv = TOPs;
+ register char *s;
+ register char *send;
+
+ if (SvSTORAGE(sv) != 'T') {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPVn(sv);
+ send = s + SvCUR(sv);
+ while (s < send) {
+ if (isascii(*s) && islower(*s))
+ *s = toupper(*s);
+ s++;
+ }
+ RETURN;
+}
+
+PP(pp_lc)
+{
+ dSP;
+ SV *sv = TOPs;
+ register char *s;
+ register char *send;
+
+ if (SvSTORAGE(sv) != 'T') {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPVn(sv);
+ send = s + SvCUR(sv);
+ while (s < send) {
+ if (isascii(*s) && isupper(*s))
+ *s = tolower(*s);
+ s++;
+ }
+ RETURN;
+}
+
+/* Arrays. */
+
+PP(pp_rv2av)
+{
+ dSP; dPOPss;
+
+ AV *av;
+
+ if (SvTYPE(sv) == SVt_REF) {
+ av = (AV*)SvANY(sv);
+ if (SvTYPE(av) != SVt_PVAV)
+ DIE("Not an array reference");
+ if (op->op_flags & OPf_LVAL) {
+ if (op->op_flags & OPf_LOCAL)
+ av = (AV*)save_svref(sv);
+ PUSHs((SV*)av);
+ RETURN;
+ }
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV)
+ sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
+ av = GvAVn(sv);
+ if (op->op_flags & OPf_LVAL) {
+ if (op->op_flags & OPf_LOCAL)
+ av = save_ary(sv);
+ PUSHs((SV*)av);
+ RETURN;
+ }
+ }
+
+ if (GIMME == G_ARRAY) {
+ I32 maxarg = AvFILL(av) + 1;
+ EXTEND(SP, maxarg);
+ Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ SP += maxarg;
+ }
+ else {
+ dTARGET;
+ I32 maxarg = AvFILL(av) + 1;
+ PUSHi(maxarg);
+ }
+ RETURN;
+}
+
+PP(pp_aelemfast)
+{
+ dSP;
+ AV *av = (AV*)cSVOP->op_sv;
+ SV** svp = av_fetch(av, op->op_private - arybase, FALSE);
+ PUSHs(svp ? *svp : &sv_undef);
+ RETURN;
+}
+
+PP(pp_aelem)
+{
+ dSP;
+ SV** svp;
+ I32 elem = POPi - arybase;
+ AV *av = (AV*)POPs;
+
+ if (op->op_flags & OPf_LVAL) {
+ svp = av_fetch(av, elem, TRUE);
+ if (!svp || *svp == &sv_undef)
+ DIE("Assignment to non-creatable value, subscript %d", elem);
+ if (op->op_flags & OPf_LOCAL)
+ save_svref(svp);
+ else if (!SvOK(*svp)) {
+ if (op->op_private == OP_RV2HV) {
+ sv_free(*svp);
+ *svp = (SV*)newHV(COEFFSIZE);
+ }
+ else if (op->op_private == OP_RV2AV) {
+ sv_free(*svp);
+ *svp = (SV*)newAV();
+ }
+ }
+ }
+ else
+ svp = av_fetch(av, elem, FALSE);
+ PUSHs(svp ? *svp : &sv_undef);
+ RETURN;
+}
+
+PP(pp_aslice)
+{
+ dSP; dMARK; dORIGMARK;
+ register SV** svp;
+ register AV* av = (AV*)POPs;
+ register I32 lval = op->op_flags & OPf_LVAL;
+ I32 is_something_there = lval;
+
+ while (++MARK <= SP) {
+ I32 elem = SvIVnx(*MARK);
+
+ if (lval) {
+ svp = av_fetch(av, elem, TRUE);
+ if (!svp || *svp == &sv_undef)
+ DIE("Assignment to non-creatable value, subscript \"%d\"",elem);
+ if (op->op_flags & OPf_LOCAL)
+ save_svref(svp);
+ }
+ else {
+ svp = av_fetch(av, elem, FALSE);
+ if (!is_something_there && svp && SvOK(*svp))
+ is_something_there = TRUE;
+ }
+ *MARK = svp ? *svp : &sv_undef;
+ }
+ if (!is_something_there)
+ SP = ORIGMARK;
+ RETURN;
+}
+
+/* Associative arrays. */
+
+PP(pp_each)
+{
+ dSP; dTARGET;
+ HV *hash = (HV*)POPs;
+ HE *entry = hv_iternext(hash);
+ I32 i;
+ char *tmps;
+
+ if (mystrk) {
+ sv_free(mystrk);
+ mystrk = Nullsv;
+ }
+
+ EXTEND(SP, 2);
+ if (entry) {
+ if (GIMME == G_ARRAY) {
+ tmps = hv_iterkey(entry, &i);
+ if (!i)
+ tmps = "";
+ mystrk = newSVpv(tmps, i);
+ PUSHs(mystrk);
+ }
+ sv_setsv(TARG, hv_iterval(hash, entry));
+ PUSHs(TARG);
+ }
+ else if (GIMME == G_SCALAR)
+ RETPUSHUNDEF;
+
+ RETURN;
+}
+
+PP(pp_values)
+{
+ return do_kv(ARGS);
+}
+
+PP(pp_keys)
+{
+ return do_kv(ARGS);
+}
+
+PP(pp_delete)
+{
+ dSP;
+ SV *sv;
+ SV *tmpsv = POPs;
+ HV *hv = (HV*)POPs;
+ char *tmps;
+ if (!hv) {
+ DIE("Not an associative array reference");
+ }
+ tmps = SvPVn(tmpsv);
+ sv = hv_delete(hv, tmps, SvCUR(tmpsv));
+ if (!sv)
+ RETPUSHUNDEF;
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_rv2hv)
+{
+
+ dSP; dTOPss;
+
+ HV *hv;
+
+ if (SvTYPE(sv) == SVt_REF) {
+ hv = (HV*)SvANY(sv);
+ if (SvTYPE(hv) != SVt_PVHV)
+ DIE("Not an associative array reference");
+ if (op->op_flags & OPf_LVAL) {
+ if (op->op_flags & OPf_LOCAL)
+ hv = (HV*)save_svref(sv);
+ SETs((SV*)hv);
+ RETURN;
+ }
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV)
+ sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
+ hv = GvHVn(sv);
+ if (op->op_flags & OPf_LVAL) {
+ if (op->op_flags & OPf_LOCAL)
+ hv = save_hash(sv);
+ SETs((SV*)hv);
+ RETURN;
+ }
+ }
+
+ if (GIMME == G_ARRAY) { /* array wanted */
+ *stack_sp = (SV*)hv;
+ return do_kv(ARGS);
+ }
+ else {
+ dTARGET;
+ if (HvFILL(hv))
+ sv_setiv(TARG, 0);
+ else {
+ sprintf(buf, "%d/%d", HvFILL(hv),
+ HvFILL(hv)+1);
+ sv_setpv(TARG, buf);
+ }
+ SETTARG;
+ RETURN;
+ }
+}
+
+PP(pp_helem)
+{
+ dSP;
+ SV** svp;
+ SV *keysv = POPs;
+ char *key = SvPVn(keysv);
+ I32 keylen = SvPOK(keysv) ? SvCUR(keysv) : 0;
+ HV *hv = (HV*)POPs;
+
+ if (op->op_flags & OPf_LVAL) {
+ svp = hv_fetch(hv, key, keylen, TRUE);
+ if (!svp || *svp == &sv_undef)
+ DIE("Assignment to non-creatable value, subscript \"%s\"", key);
+ if (op->op_flags & OPf_LOCAL)
+ save_svref(svp);
+ else if (!SvOK(*svp)) {
+ if (op->op_private == OP_RV2HV) {
+ sv_free(*svp);
+ *svp = (SV*)newHV(COEFFSIZE);
+ }
+ else if (op->op_private == OP_RV2AV) {
+ sv_free(*svp);
+ *svp = (SV*)newAV();
+ }
+ }
+ }
+ else
+ svp = hv_fetch(hv, key, keylen, FALSE);
+ PUSHs(svp ? *svp : &sv_undef);
+ RETURN;
+}
+
+PP(pp_hslice)
+{
+ dSP; dMARK; dORIGMARK;
+ register SV **svp;
+ register HV *hv = (HV*)POPs;
+ register I32 lval = op->op_flags & OPf_LVAL;
+ I32 is_something_there = lval;
+
+ while (++MARK <= SP) {
+ char *key = SvPVnx(*MARK);
+ I32 keylen = SvPOK(*MARK) ? SvCUR(*MARK) : 0;
+
+ if (lval) {
+ svp = hv_fetch(hv, key, keylen, TRUE);
+ if (!svp || *svp == &sv_undef)
+ DIE("Assignment to non-creatable value, subscript \"%s\"", key);
+ if (op->op_flags & OPf_LOCAL)
+ save_svref(svp);
+ }
+ else {
+ svp = hv_fetch(hv, key, keylen, FALSE);
+ if (!is_something_there && svp && SvOK(*svp))
+ is_something_there = TRUE;
+ }
+ *MARK = svp ? *svp : &sv_undef;
+ }
+ if (!is_something_there)
+ SP = ORIGMARK;
+ RETURN;
+}
+
+/* Explosives and implosives. */
+
+PP(pp_unpack)
+{
+ dSP;
+ dPOPPOPssrl;
+ SV *sv;
+ register char *pat = SvPVn(lstr);
+ register char *s = SvPVn(rstr);
+ char *strend = s + SvCUR(rstr);
+ char *strbeg = s;
+ register char *patend = pat + SvCUR(lstr);
+ I32 datumtype;
+ register I32 len;
+ register I32 bits;
+
+ /* These must not be in registers: */
+ I16 ashort;
+ int aint;
+ I32 along;
+#ifdef QUAD
+ quad aquad;
+#endif
+ U16 aushort;
+ unsigned int auint;
+ U32 aulong;
+#ifdef QUAD
+ unsigned quad auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+ I32 checksum = 0;
+ register U32 culong;
+ double cdouble;
+ static char* bitcount = 0;
+
+ if (GIMME != G_ARRAY) { /* arrange to do first one only */
+ /*SUPPRESS 530*/
+ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
+ if (index("aAbBhH", *patend) || *pat == '%') {
+ patend++;
+ while (isDIGIT(*patend) || *patend == '*')
+ patend++;
+ }
+ else
+ patend++;
+ }
+ while (pat < patend) {
+ reparse:
+ datumtype = *pat++;
+ if (pat >= patend)
+ len = 1;
+ else if (*pat == '*') {
+ len = strend - strbeg; /* long enough */
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = (datumtype != '@');
+ switch(datumtype) {
+ default:
+ break;
+ case '%':
+ if (len == 1 && pat[-1] != '1')
+ len = 16;
+ checksum = len;
+ culong = 0;
+ cdouble = 0;
+ if (pat < patend)
+ goto reparse;
+ break;
+ case '@':
+ if (len > strend - strbeg)
+ DIE("@ outside of string");
+ s = strbeg + len;
+ break;
+ case 'X':
+ if (len > s - strbeg)
+ DIE("X outside of string");
+ s -= len;
+ break;
+ case 'x':
+ if (len > strend - s)
+ DIE("x outside of string");
+ s += len;
+ break;
+ case 'A':
+ case 'a':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum)
+ goto uchar_checksum;
+ sv = NEWSV(35, len);
+ sv_setpvn(sv, s, len);
+ s += len;
+ if (datumtype == 'A') {
+ aptr = s; /* borrow register */
+ s = SvPV(sv) + len - 1;
+ while (s >= SvPV(sv) && (!*s || isSPACE(*s)))
+ s--;
+ *++s = '\0';
+ SvCUR_set(sv, s - SvPV(sv));
+ s = aptr; /* unborrow register */
+ }
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'B':
+ case 'b':
+ if (pat[-1] == '*' || len > (strend - s) * 8)
+ len = (strend - s) * 8;
+ if (checksum) {
+ if (!bitcount) {
+ Newz(601, bitcount, 256, char);
+ for (bits = 1; bits < 256; bits++) {
+ if (bits & 1) bitcount[bits]++;
+ if (bits & 2) bitcount[bits]++;
+ if (bits & 4) bitcount[bits]++;
+ if (bits & 8) bitcount[bits]++;
+ if (bits & 16) bitcount[bits]++;
+ if (bits & 32) bitcount[bits]++;
+ if (bits & 64) bitcount[bits]++;
+ if (bits & 128) bitcount[bits]++;
+ }
+ }
+ while (len >= 8) {
+ culong += bitcount[*(unsigned char*)s++];
+ len -= 8;
+ }
+ if (len) {
+ bits = *s;
+ if (datumtype == 'b') {
+ while (len-- > 0) {
+ if (bits & 1) culong++;
+ bits >>= 1;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ if (bits & 128) culong++;
+ bits <<= 1;
+ }
+ }
+ }
+ break;
+ }
+ sv = NEWSV(35, len + 1);
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+ aptr = pat; /* borrow register */
+ pat = SvPV(sv);
+ if (datumtype == 'b') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7) /*SUPPRESS 595*/
+ bits >>= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + (bits & 1);
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7)
+ bits <<= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + ((bits & 128) != 0);
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'H':
+ case 'h':
+ if (pat[-1] == '*' || len > (strend - s) * 2)
+ len = (strend - s) * 2;
+ sv = NEWSV(35, len + 1);
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+ aptr = pat; /* borrow register */
+ pat = SvPV(sv);
+ if (datumtype == 'h') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits >>= 4;
+ else
+ bits = *s++;
+ *pat++ = hexdigit[bits & 15];
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits <<= 4;
+ else
+ bits = *s++;
+ *pat++ = hexdigit[(bits >> 4) & 15];
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'c':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ culong += aint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ sv = NEWSV(36, 0);
+ sv_setiv(sv, (I32)aint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'C':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ uchar_checksum:
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ sv = NEWSV(37, 0);
+ sv_setiv(sv, (I32)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 's':
+ along = (strend - s) / sizeof(I16);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &ashort, 1, I16);
+ s += sizeof(I16);
+ culong += ashort;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ Copy(s, &ashort, 1, I16);
+ s += sizeof(I16);
+ sv = NEWSV(38, 0);
+ sv_setiv(sv, (I32)ashort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'v':
+ case 'n':
+ case 'S':
+ along = (strend - s) / sizeof(U16);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &aushort, 1, U16);
+ s += sizeof(U16);
+#ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = ntohs(aushort);
+#endif
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ culong += aushort;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ Copy(s, &aushort, 1, U16);
+ s += sizeof(U16);
+ sv = NEWSV(39, 0);
+#ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = ntohs(aushort);
+#endif
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ sv_setiv(sv, (I32)aushort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'i':
+ along = (strend - s) / sizeof(int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &aint, 1, int);
+ s += sizeof(int);
+ if (checksum > 32)
+ cdouble += (double)aint;
+ else
+ culong += aint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ Copy(s, &aint, 1, int);
+ s += sizeof(int);
+ sv = NEWSV(40, 0);
+ sv_setiv(sv, (I32)aint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'I':
+ along = (strend - s) / sizeof(unsigned int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &auint, 1, unsigned int);
+ s += sizeof(unsigned int);
+ if (checksum > 32)
+ cdouble += (double)auint;
+ else
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ Copy(s, &auint, 1, unsigned int);
+ s += sizeof(unsigned int);
+ sv = NEWSV(41, 0);
+ sv_setiv(sv, (I32)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'l':
+ along = (strend - s) / sizeof(I32);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &along, 1, I32);
+ s += sizeof(I32);
+ if (checksum > 32)
+ cdouble += (double)along;
+ else
+ culong += along;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ Copy(s, &along, 1, I32);
+ s += sizeof(I32);
+ sv = NEWSV(42, 0);
+ sv_setiv(sv, (I32)along);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'V':
+ case 'N':
+ case 'L':
+ along = (strend - s) / sizeof(U32);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &aulong, 1, U32);
+ s += sizeof(U32);
+#ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = ntohl(aulong);
+#endif
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+#endif
+ if (checksum > 32)
+ cdouble += (double)aulong;
+ else
+ culong += aulong;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ Copy(s, &aulong, 1, U32);
+ s += sizeof(U32);
+ sv = NEWSV(43, 0);
+#ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = ntohl(aulong);
+#endif
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+#endif
+ sv_setnv(sv, (double)aulong);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'p':
+ along = (strend - s) / sizeof(char*);
+ if (len > along)
+ len = along;
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ if (sizeof(char*) > strend - s)
+ break;
+ else {
+ Copy(s, &aptr, 1, char*);
+ s += sizeof(char*);
+ }
+ sv = NEWSV(44, 0);
+ if (aptr)
+ sv_setpv(sv, aptr);
+ PUSHs(sv_2mortal(sv));
+ }
+ break;
+#ifdef QUAD
+ case 'q':
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ if (s + sizeof(quad) > strend)
+ aquad = 0;
+ else {
+ Copy(s, &aquad, 1, quad);
+ s += sizeof(quad);
+ }
+ sv = NEWSV(42, 0);
+ sv_setnv(sv, (double)aquad);
+ PUSHs(sv_2mortal(sv));
+ }
+ break;
+ case 'Q':
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ if (s + sizeof(unsigned quad) > strend)
+ auquad = 0;
+ else {
+ Copy(s, &auquad, 1, unsigned quad);
+ s += sizeof(unsigned quad);
+ }
+ sv = NEWSV(43, 0);
+ sv_setnv(sv, (double)auquad);
+ PUSHs(sv_2mortal(sv));
+ }
+ break;
+#endif
+ /* float and double added gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ along = (strend - s) / sizeof(float);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &afloat, 1, float);
+ s += sizeof(float);
+ cdouble += afloat;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ Copy(s, &afloat, 1, float);
+ s += sizeof(float);
+ sv = NEWSV(47, 0);
+ sv_setnv(sv, (double)afloat);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'd':
+ case 'D':
+ along = (strend - s) / sizeof(double);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &adouble, 1, double);
+ s += sizeof(double);
+ cdouble += adouble;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ Copy(s, &adouble, 1, double);
+ s += sizeof(double);
+ sv = NEWSV(48, 0);
+ sv_setnv(sv, (double)adouble);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'u':
+ along = (strend - s) * 3 / 4;
+ sv = NEWSV(42, along);
+ while (s < strend && *s > ' ' && *s < 'a') {
+ I32 a, b, c, d;
+ char hunk[4];
+
+ hunk[3] = '\0';
+ len = (*s++ - ' ') & 077;
+ while (len > 0) {
+ if (s < strend && *s >= ' ')
+ a = (*s++ - ' ') & 077;
+ else
+ a = 0;
+ if (s < strend && *s >= ' ')
+ b = (*s++ - ' ') & 077;
+ else
+ b = 0;
+ if (s < strend && *s >= ' ')
+ c = (*s++ - ' ') & 077;
+ else
+ c = 0;
+ if (s < strend && *s >= ' ')
+ d = (*s++ - ' ') & 077;
+ else
+ d = 0;
+ hunk[0] = a << 2 | b >> 4;
+ hunk[1] = b << 4 | c >> 2;
+ hunk[2] = c << 6 | d;
+ sv_catpvn(sv, hunk, len > 3 ? 3 : len);
+ len -= 3;
+ }
+ if (*s == '\n')
+ s++;
+ else if (s[1] == '\n') /* possible checksum byte */
+ s += 2;
+ }
+ XPUSHs(sv_2mortal(sv));
+ break;
+ }
+ if (checksum) {
+ sv = NEWSV(42, 0);
+ if (index("fFdD", datumtype) ||
+ (checksum > 32 && index("iIlLN", datumtype)) ) {
+ double modf();
+ double trouble;
+
+ adouble = 1.0;
+ while (checksum >= 16) {
+ checksum -= 16;
+ adouble *= 65536.0;
+ }
+ while (checksum >= 4) {
+ checksum -= 4;
+ adouble *= 16.0;
+ }
+ while (checksum--)
+ adouble *= 2.0;
+ along = (1 << checksum) - 1;
+ while (cdouble < 0.0)
+ cdouble += adouble;
+ cdouble = modf(cdouble / adouble, &trouble) * adouble;
+ sv_setnv(sv, cdouble);
+ }
+ else {
+ if (checksum < 32) {
+ along = (1 << checksum) - 1;
+ culong &= (U32)along;
+ }
+ sv_setnv(sv, (double)culong);
+ }
+ XPUSHs(sv_2mortal(sv));
+ checksum = 0;
+ }
+ }
+ RETURN;
+}
+
+static void
+doencodes(sv, s, len)
+register SV *sv;
+register char *s;
+register I32 len;
+{
+ char hunk[5];
+
+ *hunk = len + ' ';
+ sv_catpvn(sv, hunk, 1);
+ hunk[4] = '\0';
+ while (len > 0) {
+ hunk[0] = ' ' + (077 & (*s >> 2));
+ hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
+ hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
+ hunk[3] = ' ' + (077 & (s[2] & 077));
+ sv_catpvn(sv, hunk, 4);
+ s += 3;
+ len -= 3;
+ }
+ for (s = SvPV(sv); *s; s++) {
+ if (*s == ' ')
+ *s = '`';
+ }
+ sv_catpvn(sv, "\n", 1);
+}
+
+PP(pp_pack)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ register SV *cat = TARG;
+ register I32 items;
+ register char *pat = SvPVnx(*++MARK);
+ register char *patend = pat + SvCUR(*MARK);
+ register I32 len;
+ I32 datumtype;
+ SV *fromstr;
+ /*SUPPRESS 442*/
+ static char *null10 = "\0\0\0\0\0\0\0\0\0\0";
+ static char *space10 = " ";
+
+ /* These must not be in registers: */
+ char achar;
+ I16 ashort;
+ int aint;
+ unsigned int auint;
+ I32 along;
+ U32 aulong;
+#ifdef QUAD
+ quad aquad;
+ unsigned quad auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+
+ items = SP - MARK;
+ MARK++;
+ sv_setpvn(cat, "", 0);
+ while (pat < patend) {
+#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
+ datumtype = *pat++;
+ if (*pat == '*') {
+ len = index("@Xxu", datumtype) ? 0 : items;
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = 1;
+ switch(datumtype) {
+ default:
+ break;
+ case '%':
+ DIE("% may only be used in unpack");
+ case '@':
+ len -= SvCUR(cat);
+ if (len > 0)
+ goto grow;
+ len = -len;
+ if (len > 0)
+ goto shrink;
+ break;
+ case 'X':
+ shrink:
+ if (SvCUR(cat) < len)
+ DIE("X outside of string");
+ SvCUR(cat) -= len;
+ *SvEND(cat) = '\0';
+ break;
+ case 'x':
+ grow:
+ while (len >= 10) {
+ sv_catpvn(cat, null10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, null10, len);
+ break;
+ case 'A':
+ case 'a':
+ fromstr = NEXTFROM;
+ aptr = SvPVn(fromstr);
+ if (pat[-1] == '*')
+ len = SvCUR(fromstr);
+ if (SvCUR(fromstr) > len)
+ sv_catpvn(cat, aptr, len);
+ else {
+ sv_catpvn(cat, aptr, SvCUR(fromstr));
+ len -= SvCUR(fromstr);
+ if (datumtype == 'A') {
+ while (len >= 10) {
+ sv_catpvn(cat, space10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, space10, len);
+ }
+ else {
+ while (len >= 10) {
+ sv_catpvn(cat, null10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, null10, len);
+ }
+ }
+ break;
+ case 'B':
+ case 'b':
+ {
+ char *savepat = pat;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = SvPVn(fromstr);
+ if (pat[-1] == '*')
+ len = SvCUR(fromstr);
+ pat = aptr;
+ aint = SvCUR(cat);
+ SvCUR(cat) += (len+7)/8;
+ SvGROW(cat, SvCUR(cat) + 1);
+ aptr = SvPV(cat) + aint;
+ if (len > SvCUR(fromstr))
+ len = SvCUR(fromstr);
+ aint = len;
+ items = 0;
+ if (datumtype == 'B') {
+ for (len = 0; len++ < aint;) {
+ items |= *pat++ & 1;
+ if (len & 7)
+ items <<= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (*pat++ & 1)
+ items |= 128;
+ if (len & 7)
+ items >>= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 7) {
+ if (datumtype == 'B')
+ items <<= 7 - (aint & 7);
+ else
+ items >>= 7 - (aint & 7);
+ *aptr++ = items & 0xff;
+ }
+ pat = SvPV(cat) + SvCUR(cat);
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'H':
+ case 'h':
+ {
+ char *savepat = pat;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = SvPVn(fromstr);
+ if (pat[-1] == '*')
+ len = SvCUR(fromstr);
+ pat = aptr;
+ aint = SvCUR(cat);
+ SvCUR(cat) += (len+1)/2;
+ SvGROW(cat, SvCUR(cat) + 1);
+ aptr = SvPV(cat) + aint;
+ if (len > SvCUR(fromstr))
+ len = SvCUR(fromstr);
+ aint = len;
+ items = 0;
+ if (datumtype == 'H') {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*pat))
+ items |= ((*pat++ & 15) + 9) & 15;
+ else
+ items |= *pat++ & 15;
+ if (len & 1)
+ items <<= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*pat))
+ items |= (((*pat++ & 15) + 9) & 15) << 4;
+ else
+ items |= (*pat++ & 15) << 4;
+ if (len & 1)
+ items >>= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 1)
+ *aptr++ = items & 0xff;
+ pat = SvPV(cat) + SvCUR(cat);
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'C':
+ case 'c':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = SvIVn(fromstr);
+ achar = aint;
+ sv_catpvn(cat, &achar, sizeof(char));
+ }
+ break;
+ /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ afloat = (float)SvNVn(fromstr);
+ sv_catpvn(cat, (char *)&afloat, sizeof (float));
+ }
+ break;
+ case 'd':
+ case 'D':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ adouble = (double)SvNVn(fromstr);
+ sv_catpvn(cat, (char *)&adouble, sizeof (double));
+ }
+ break;
+ case 'n':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIVn(fromstr);
+#ifdef HAS_HTONS
+ ashort = htons(ashort);
+#endif
+ sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ }
+ break;
+ case 'v':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIVn(fromstr);
+#ifdef HAS_HTOVS
+ ashort = htovs(ashort);
+#endif
+ sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ }
+ break;
+ case 'S':
+ case 's':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIVn(fromstr);
+ sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ }
+ break;
+ case 'I':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auint = U_I(SvNVn(fromstr));
+ sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
+ }
+ break;
+ case 'i':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = SvIVn(fromstr);
+ sv_catpvn(cat, (char*)&aint, sizeof(int));
+ }
+ break;
+ case 'N':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(SvNVn(fromstr));
+#ifdef HAS_HTONL
+ aulong = htonl(aulong);
+#endif
+ sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ }
+ break;
+ case 'V':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(SvNVn(fromstr));
+#ifdef HAS_HTOVL
+ aulong = htovl(aulong);
+#endif
+ sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ }
+ break;
+ case 'L':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(SvNVn(fromstr));
+ sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ }
+ break;
+ case 'l':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = SvIVn(fromstr);
+ sv_catpvn(cat, (char*)&along, sizeof(I32));
+ }
+ break;
+#ifdef QUAD
+ case 'Q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auquad = (unsigned quad)SvNVn(fromstr);
+ sv_catpvn(cat, (char*)&auquad, sizeof(unsigned quad));
+ }
+ break;
+ case 'q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aquad = (quad)SvNVn(fromstr);
+ sv_catpvn(cat, (char*)&aquad, sizeof(quad));
+ }
+ break;
+#endif /* QUAD */
+ case 'p':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aptr = SvPVn(fromstr);
+ sv_catpvn(cat, (char*)&aptr, sizeof(char*));
+ }
+ break;
+ case 'u':
+ fromstr = NEXTFROM;
+ aptr = SvPVn(fromstr);
+ aint = SvCUR(fromstr);
+ SvGROW(cat, aint * 4 / 3);
+ if (len <= 1)
+ len = 45;
+ else
+ len = len / 3 * 3;
+ while (aint > 0) {
+ I32 todo;
+
+ if (aint > len)
+ todo = len;
+ else
+ todo = aint;
+ doencodes(cat, aptr, todo);
+ aint -= todo;
+ aptr += todo;
+ }
+ break;
+ }
+ }
+ SvSETMAGIC(cat);
+ SP = ORIGMARK;
+ PUSHs(cat);
+ RETURN;
+}
+#undef NEXTFROM
+
+PP(pp_split)
+{
+ dSP; dTARG;
+ AV *ary;
+ register I32 limit = POPi;
+ register char *s = SvPVn(TOPs);
+ char *strend = s + SvCURx(POPs);
+ register PMOP *pm = (PMOP*)POPs;
+ register SV *dstr;
+ register char *m;
+ I32 iters = 0;
+ I32 maxiters = (strend - s) + 10;
+ I32 i;
+ char *orig;
+ I32 origlimit = limit;
+ I32 realarray = 0;
+ I32 base;
+ AV *oldstack;
+ register REGEXP *rx = pm->op_pmregexp;
+ I32 gimme = GIMME;
+
+ if (!pm || !s)
+ DIE("panic: do_split");
+ if (pm->op_pmreplroot)
+ ary = GvAVn((GV*)pm->op_pmreplroot);
+ else
+ ary = Nullav;
+ if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
+ realarray = 1;
+ if (!AvREAL(ary)) {
+ AvREAL_on(ary);
+ for (i = AvFILL(ary); i >= 0; i--)
+ AvARRAY(ary)[i] = Nullsv; /* don't free mere refs */
+ }
+ av_fill(ary,0); /* force allocation */
+ av_fill(ary,-1);
+ /* temporarily switch stacks */
+ oldstack = stack;
+ SWITCHSTACK(stack, ary);
+ }
+ base = SP - stack_base + 1;
+ orig = s;
+ if (pm->op_pmflags & PMf_SKIPWHITE) {
+ while (isSPACE(*s))
+ s++;
+ }
+ if (!limit)
+ limit = maxiters + 2;
+ if (strEQ("\\s+", rx->precomp)) {
+ while (--limit) {
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && !isSPACE(*m); m++) ;
+ if (m >= strend)
+ break;
+ dstr = NEWSV(30, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ /*SUPPRESS 530*/
+ for (s = m + 1; s < strend && isSPACE(*s); s++) ;
+ }
+ }
+ else if (strEQ("^", rx->precomp)) {
+ while (--limit) {
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != '\n'; m++) ;
+ m++;
+ if (m >= strend)
+ break;
+ dstr = NEWSV(30, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ s = m;
+ }
+ }
+ else if (pm->op_pmshort) {
+ i = SvCUR(pm->op_pmshort);
+ if (i == 1) {
+ I32 fold = (pm->op_pmflags & PMf_FOLD);
+ i = *SvPV(pm->op_pmshort);
+ if (fold && isUPPER(i))
+ i = tolower(i);
+ while (--limit) {
+ if (fold) {
+ for ( m = s;
+ m < strend && *m != i &&
+ (!isUPPER(*m) || tolower(*m) != i);
+ m++) /*SUPPRESS 530*/
+ ;
+ }
+ else /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != i; m++) ;
+ if (m >= strend)
+ break;
+ dstr = NEWSV(30, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ s = m + 1;
+ }
+ }
+ else {
+#ifndef lint
+ while (s < strend && --limit &&
+ (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
+ pm->op_pmshort)) )
+#endif
+ {
+ dstr = NEWSV(31, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ s = m + i;
+ }
+ }
+ }
+ else {
+ maxiters += (strend - s) * rx->nparens;
+ while (s < strend && --limit &&
+ regexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) {
+ if (rx->subbase
+ && rx->subbase != orig) {
+ m = s;
+ s = orig;
+ orig = rx->subbase;
+ s = orig + (m - s);
+ strend = s + (strend - m);
+ }
+ m = rx->startp[0];
+ dstr = NEWSV(32, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ if (rx->nparens) {
+ for (i = 1; i <= rx->nparens; i++) {
+ s = rx->startp[i];
+ m = rx->endp[i];
+ dstr = NEWSV(33, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ }
+ }
+ s = rx->endp[0];
+ }
+ }
+ iters = (SP - stack_base) - base;
+ if (iters > maxiters)
+ DIE("Split loop");
+ if (s < strend || origlimit) { /* keep field after final delim? */
+ dstr = NEWSV(34, strend-s);
+ sv_setpvn(dstr, s, strend-s);
+ if (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ iters++;
+ }
+ else {
+ while (iters > 0 && SvCUR(TOPs) == 0)
+ iters--, SP--;
+ }
+ if (realarray) {
+ SWITCHSTACK(ary, oldstack);
+ if (gimme == G_ARRAY) {
+ EXTEND(SP, iters);
+ Copy(AvARRAY(ary), SP + 1, iters, SV*);
+ SP += iters;
+ RETURN;
+ }
+ }
+ else {
+ if (gimme == G_ARRAY)
+ RETURN;
+ }
+ SP = stack_base + base;
+ GETTARGET;
+ PUSHi(iters);
+ RETURN;
+}
+
+PP(pp_join)
+{
+ dSP; dMARK; dTARGET;
+ MARK++;
+ do_join(TARG, *MARK, MARK, SP);
+ SP = MARK;
+ SETs(TARG);
+ RETURN;
+}
+
+/* List operators. */
+
+PP(pp_list)
+{
+ dSP;
+ if (GIMME != G_ARRAY) {
+ dMARK;
+ if (++MARK <= SP)
+ *MARK = *SP; /* unwanted list, return last item */
+ else
+ *MARK = &sv_undef;
+ SP = MARK;
+ }
+ RETURN;
+}
+
+PP(pp_lslice)
+{
+ dSP;
+ SV **lastrelem = stack_sp;
+ SV **lastlelem = stack_base + POPMARK;
+ SV **firstlelem = stack_base + POPMARK + 1;
+ register SV **firstrelem = lastlelem + 1;
+ I32 lval = op->op_flags & OPf_LVAL;
+ I32 is_something_there = lval;
+
+ register I32 max = lastrelem - lastlelem;
+ register SV **lelem;
+ register I32 ix;
+
+ if (GIMME != G_ARRAY) {
+ ix = SvIVnx(*lastlelem) - arybase;
+ if (ix < 0 || ix >= max)
+ *firstlelem = &sv_undef;
+ else
+ *firstlelem = firstrelem[ix];
+ SP = firstlelem;
+ RETURN;
+ }
+
+ if (max == 0) {
+ SP = firstlelem;
+ RETURN;
+ }
+
+ for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
+ ix = SvIVnx(*lelem) - arybase;
+ if (ix < 0 || ix >= max || !(*lelem = firstrelem[ix]))
+ *lelem = &sv_undef;
+ if (!is_something_there && SvOK(*lelem))
+ is_something_there = TRUE;
+ }
+ if (is_something_there)
+ SP = lastlelem;
+ else
+ SP = firstlelem;
+ RETURN;
+}
+
+PP(pp_anonlist)
+{
+ dSP; dMARK;
+ I32 items = SP - MARK;
+ SP = MARK;
+ XPUSHs((SV*)av_make(items, MARK+1));
+ RETURN;
+}
+
+PP(pp_anonhash)
+{
+ dSP; dMARK; dORIGMARK;
+ HV* hv = newHV(COEFFSIZE);
+ SvREFCNT(hv) = 0;
+ while (MARK < SP) {
+ SV* key = *++MARK;
+ SV* val;
+ char *tmps;
+ if (MARK < SP)
+ val = *++MARK;
+ tmps = SvPV(key);
+ (void)hv_store(hv,tmps,SvCUR(key),val,0);
+ }
+ SP = ORIGMARK;
+ XPUSHs((SV*)hv);
+ RETURN;
+}
+
+PP(pp_splice)
+{
+ dSP; dMARK; dORIGMARK;
+ register AV *ary = (AV*)*++MARK;
+ register SV **src;
+ register SV **dst;
+ register I32 i;
+ register I32 offset;
+ register I32 length;
+ I32 newlen;
+ I32 after;
+ I32 diff;
+ SV **tmparyval;
+
+ SP++;
+
+ if (++MARK < SP) {
+ offset = SvIVnx(*MARK);
+ if (offset < 0)
+ offset += AvFILL(ary) + 1;
+ else
+ offset -= arybase;
+ if (++MARK < SP) {
+ length = SvIVnx(*MARK++);
+ if (length < 0)
+ length = 0;
+ }
+ else
+ length = AvMAX(ary) + 1; /* close enough to infinity */
+ }
+ else {
+ offset = 0;
+ length = AvMAX(ary) + 1;
+ }
+ if (offset < 0) {
+ length += offset;
+ offset = 0;
+ if (length < 0)
+ length = 0;
+ }
+ if (offset > AvFILL(ary) + 1)
+ offset = AvFILL(ary) + 1;
+ after = AvFILL(ary) + 1 - (offset + length);
+ if (after < 0) { /* not that much array */
+ length += after; /* offset+length now in array */
+ after = 0;
+ if (!AvALLOC(ary)) {
+ av_fill(ary, 0);
+ av_fill(ary, -1);
+ }
+ }
+
+ /* At this point, MARK .. SP-1 is our new LIST */
+
+ newlen = SP - MARK;
+ diff = newlen - length;
+
+ if (diff < 0) { /* shrinking the area */
+ if (newlen) {
+ New(451, tmparyval, newlen, SV*); /* so remember insertion */
+ Copy(MARK, tmparyval, newlen, SV*);
+ }
+
+ MARK = ORIGMARK + 1;
+ if (GIMME == G_ARRAY) { /* copy return vals to stack */
+ MEXTEND(MARK, length);
+ Copy(AvARRAY(ary)+offset, MARK, length, SV*);
+ if (AvREAL(ary)) {
+ for (i = length, dst = MARK; i; i--)
+ sv_2mortal(*dst++); /* free them eventualy */
+ }
+ MARK += length - 1;
+ }
+ else {
+ *MARK = AvARRAY(ary)[offset+length-1];
+ if (AvREAL(ary)) {
+ sv_2mortal(*MARK);
+ for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
+ sv_free(*dst++); /* free them now */
+ }
+ }
+ AvFILL(ary) += diff;
+
+ /* pull up or down? */
+
+ if (offset < after) { /* easier to pull up */
+ if (offset) { /* esp. if nothing to pull */
+ src = &AvARRAY(ary)[offset-1];
+ dst = src - diff; /* diff is negative */
+ for (i = offset; i > 0; i--) /* can't trust Copy */
+ *dst-- = *src--;
+ }
+ Zero(AvARRAY(ary), -diff, SV*);
+ AvARRAY(ary) -= diff; /* diff is negative */
+ AvMAX(ary) += diff;
+ }
+ else {
+ if (after) { /* anything to pull down? */
+ src = AvARRAY(ary) + offset + length;
+ dst = src + diff; /* diff is negative */
+ Move(src, dst, after, SV*);
+ }
+ Zero(&AvARRAY(ary)[AvFILL(ary)+1], -diff, SV*);
+ /* avoid later double free */
+ }
+ if (newlen) {
+ for (src = tmparyval, dst = AvARRAY(ary) + offset;
+ newlen; newlen--) {
+ *dst = NEWSV(46, 0);
+ sv_setsv(*dst++, *src++);
+ }
+ Safefree(tmparyval);
+ }
+ }
+ else { /* no, expanding (or same) */
+ if (length) {
+ New(452, tmparyval, length, SV*); /* so remember deletion */
+ Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
+ }
+
+ if (diff > 0) { /* expanding */
+
+ /* push up or down? */
+
+ if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
+ if (offset) {
+ src = AvARRAY(ary);
+ dst = src - diff;
+ Move(src, dst, offset, SV*);
+ }
+ AvARRAY(ary) -= diff; /* diff is positive */
+ AvMAX(ary) += diff;
+ AvFILL(ary) += diff;
+ }
+ else {
+ if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */
+ av_store(ary, AvFILL(ary) + diff, Nullsv);
+ else
+ AvFILL(ary) += diff;
+ dst = AvARRAY(ary) + AvFILL(ary);
+ for (i = diff; i > 0; i--) {
+ if (*dst) /* stuff was hanging around */
+ sv_free(*dst); /* after $#foo */
+ dst--;
+ }
+ if (after) {
+ dst = AvARRAY(ary) + AvFILL(ary);
+ src = dst - diff;
+ for (i = after; i; i--) {
+ *dst-- = *src--;
+ }
+ }
+ }
+ }
+
+ for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
+ *dst = NEWSV(46, 0);
+ sv_setsv(*dst++, *src++);
+ }
+ MARK = ORIGMARK + 1;
+ if (GIMME == G_ARRAY) { /* copy return vals to stack */
+ if (length) {
+ Copy(tmparyval, MARK, length, SV*);
+ if (AvREAL(ary)) {
+ for (i = length, dst = MARK; i; i--)
+ sv_2mortal(*dst++); /* free them eventualy */
+ }
+ Safefree(tmparyval);
+ }
+ MARK += length - 1;
+ }
+ else if (length--) {
+ *MARK = tmparyval[length];
+ if (AvREAL(ary)) {
+ sv_2mortal(*MARK);
+ while (length-- > 0)
+ sv_free(tmparyval[length]);
+ }
+ Safefree(tmparyval);
+ }
+ else
+ *MARK = &sv_undef;
+ }
+ SP = MARK;
+ RETURN;
+}
+
+PP(pp_push)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ register AV *ary = (AV*)*++MARK;
+ register SV *sv = &sv_undef;
+
+ for (++MARK; MARK <= SP; MARK++) {
+ sv = NEWSV(51, 0);
+ if (*MARK)
+ sv_setsv(sv, *MARK);
+ (void)av_push(ary, sv);
+ }
+ SP = ORIGMARK;
+ PUSHi( AvFILL(ary) + 1 );
+ RETURN;
+}
+
+PP(pp_pop)
+{
+ dSP;
+ AV *av = (AV*)POPs;
+ SV *sv = av_pop(av);
+ if (!sv)
+ RETPUSHUNDEF;
+ if (AvREAL(av))
+ (void)sv_2mortal(sv);
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_shift)
+{
+ dSP;
+ AV *av = (AV*)POPs;
+ SV *sv = av_shift(av);
+ EXTEND(SP, 1);
+ if (!sv)
+ RETPUSHUNDEF;
+ if (AvREAL(av))
+ (void)sv_2mortal(sv);
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_unshift)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ register AV *ary = (AV*)*++MARK;
+ register SV *sv;
+ register I32 i = 0;
+
+ av_unshift(ary, SP - MARK);
+ while (MARK < SP) {
+ sv = NEWSV(27, 0);
+ sv_setsv(sv, *++MARK);
+ (void)av_store(ary, i++, sv);
+ }
+
+ SP = ORIGMARK;
+ PUSHi( AvFILL(ary) + 1 );
+ RETURN;
+}
+
+PP(pp_grepstart)
+{
+ dSP;
+ SV *src;
+
+ if (stack_base + *markstack_ptr == sp) {
+ POPMARK;
+ RETURNOP(op->op_next->op_next);
+ }
+ stack_sp = stack_base + *markstack_ptr + 1;
+ pp_pushmark(); /* push dst */
+ pp_pushmark(); /* push src */
+ ENTER; /* enter outer scope */
+
+ SAVETMPS;
+ SAVESPTR(GvSV(defgv));
+
+ ENTER; /* enter inner scope */
+ SAVESPTR(curpm);
+
+ if (src = stack_base[*markstack_ptr]) {
+ SvTEMP_off(src);
+ GvSV(defgv) = src;
+ }
+ else
+ GvSV(defgv) = sv_mortalcopy(&sv_undef);
+
+ RETURNOP(((LOGOP*)op->op_next)->op_other);
+}
+
+PP(pp_grepwhile)
+{
+ dSP;
+
+ if (SvTRUEx(POPs))
+ stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
+ ++*markstack_ptr;
+ LEAVE; /* exit inner scope */
+
+ /* All done yet? */
+ if (stack_base + *markstack_ptr > sp) {
+ I32 items;
+
+ LEAVE; /* exit outer scope */
+ POPMARK; /* pop src */
+ items = --*markstack_ptr - markstack_ptr[-1];
+ POPMARK; /* pop dst */
+ SP = stack_base + POPMARK; /* pop original mark */
+ if (GIMME != G_ARRAY) {
+ dTARGET;
+ XPUSHi(items);
+ RETURN;
+ }
+ SP += items;
+ RETURN;
+ }
+ else {
+ SV *src;
+
+ ENTER; /* enter inner scope */
+ SAVESPTR(curpm);
+
+ if (src = stack_base[*markstack_ptr]) {
+ SvTEMP_off(src);
+ GvSV(defgv) = src;
+ }
+ else
+ GvSV(defgv) = sv_mortalcopy(&sv_undef);
+
+ RETURNOP(cLOGOP->op_other);
+ }
+}
+
+PP(pp_sort)
+{
+ dSP; dMARK; dORIGMARK;
+ register SV **up;
+ SV **myorigmark = ORIGMARK;
+ register I32 max;
+ register I32 i;
+ int sortcmp();
+ int sortcv();
+ HV *stash;
+ SV *sortcvvar;
+ GV *gv;
+ CV *cv;
+
+ if (GIMME != G_ARRAY) {
+ SP = MARK;
+ RETSETUNDEF;
+ }
+
+ if (op->op_flags & OPf_STACKED) {
+ if (op->op_flags & OPf_SPECIAL) {
+ OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
+ kid = kUNOP->op_first; /* pass rv2gv */
+ kid = kUNOP->op_first; /* pass leave */
+ sortcop = kid->op_next;
+ stash = curcop->cop_stash;
+ }
+ else {
+ cv = sv_2cv(*++MARK, &stash, &gv, 0);
+ if (!cv) {
+ if (gv) {
+ SV *tmpstr = sv_mortalcopy(&sv_undef);
+ gv_efullname(tmpstr, gv);
+ DIE("Undefined sort subroutine \"%s\" called",
+ SvPV(tmpstr));
+ }
+ DIE("Undefined subroutine in sort");
+ }
+ sortcop = CvSTART(cv);
+ SAVESPTR(CvROOT(cv)->op_ppaddr);
+ CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
+ }
+ }
+ else {
+ sortcop = Nullop;
+ stash = curcop->cop_stash;
+ }
+
+ up = myorigmark + 1;
+ while (MARK < SP) { /* This may or may not shift down one here. */
+ /*SUPPRESS 560*/
+ if (*up = *++MARK) { /* Weed out nulls. */
+ if (!SvPOK(*up))
+ (void)sv_2pv(*up);
+ else
+ SvTEMP_off(*up);
+ up++;
+ }
+ }
+ max = --up - myorigmark;
+ if (max > 1) {
+ if (sortcop) {
+ AV *oldstack;
+
+ ENTER;
+ SAVETMPS;
+ SAVESPTR(op);
+
+ oldstack = stack;
+ if (!sortstack) {
+ sortstack = newAV();
+ av_store(sortstack, 32, Nullsv);
+ av_clear(sortstack);
+ AvREAL_off(sortstack);
+ }
+ SWITCHSTACK(stack, sortstack);
+ if (sortstash != stash) {
+ firstgv = gv_fetchpv("a", TRUE);
+ secondgv = gv_fetchpv("b", TRUE);
+ sortstash = stash;
+ }
+
+ SAVESPTR(GvSV(firstgv));
+ SAVESPTR(GvSV(secondgv));
+
+ qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
+
+ SWITCHSTACK(sortstack, oldstack);
+
+ LEAVE;
+ }
+ else {
+ MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
+ qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
+ }
+ }
+ SP = ORIGMARK + max;
+ RETURN;
+}
+
+PP(pp_reverse)
+{
+ dSP; dMARK;
+ register SV *tmp;
+ SV **oldsp = SP;
+
+ if (GIMME == G_ARRAY) {
+ MARK++;
+ while (MARK < SP) {
+ tmp = *MARK;
+ *MARK++ = *SP;
+ *SP-- = tmp;
+ }
+ SP = oldsp;
+ }
+ else {
+ register char *up;
+ register char *down;
+ register I32 tmp;
+ dTARGET;
+
+ if (SP - MARK > 1)
+ do_join(TARG, sv_no, MARK, SP);
+ else
+ sv_setsv(TARG, *SP);
+ up = SvPVn(TARG);
+ if (SvCUR(TARG) > 1) {
+ down = SvPV(TARG) + SvCUR(TARG) - 1;
+ while (down > up) {
+ tmp = *up;
+ *up++ = *down;
+ *down-- = tmp;
+ }
+ }
+ SP = MARK + 1;
+ SETTARG;
+ }
+ RETURN;
+}
+
+/* Range stuff. */
+
+PP(pp_range)
+{
+ if (GIMME == G_ARRAY)
+ return cCONDOP->op_true;
+ return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
+}
+
+PP(pp_flip)
+{
+ dSP;
+
+ if (GIMME == G_ARRAY) {
+ RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
+ }
+ else {
+ dTOPss;
+ SV *targ = PAD_SV(op->op_targ);
+
+ if ((op->op_private & OPpFLIP_LINENUM)
+ ? last_in_gv && SvIVn(sv) == GvIO(last_in_gv)->lines
+ : SvTRUE(sv) ) {
+ sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
+ if (op->op_flags & OPf_SPECIAL) {
+ sv_setiv(targ, 1);
+ RETURN;
+ }
+ else {
+ sv_setiv(targ, 0);
+ sp--;
+ RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
+ }
+ }
+ sv_setpv(TARG, "");
+ SETs(targ);
+ RETURN;
+ }
+}
+
+PP(pp_flop)
+{
+ dSP;
+
+ if (GIMME == G_ARRAY) {
+ dPOPPOPssrl;
+ register I32 i;
+ register SV *sv;
+ I32 max;
+
+ if (SvNIOK(lstr) || !SvPOK(lstr) ||
+ (looks_like_number(lstr) && *SvPV(lstr) != '0') ) {
+ i = SvIVn(lstr);
+ max = SvIVn(rstr);
+ if (max > i)
+ EXTEND(SP, max - i + 1);
+ while (i <= max) {
+ sv = sv_mortalcopy(&sv_no);
+ sv_setiv(sv,i++);
+ PUSHs(sv);
+ }
+ }
+ else {
+ SV *final = sv_mortalcopy(rstr);
+ char *tmps = SvPVn(final);
+
+ sv = sv_mortalcopy(lstr);
+ while (!SvNIOK(sv) && SvCUR(sv) <= SvCUR(final) &&
+ strNE(SvPV(sv),tmps) ) {
+ XPUSHs(sv);
+ sv = sv_2mortal(newSVsv(sv));
+ sv_inc(sv);
+ }
+ if (strEQ(SvPV(sv),tmps))
+ XPUSHs(sv);
+ }
+ }
+ else {
+ dTOPss;
+ SV *targ = PAD_SV(cUNOP->op_first->op_targ);
+ sv_inc(targ);
+ if ((op->op_private & OPpFLIP_LINENUM)
+ ? last_in_gv && SvIVn(sv) == GvIO(last_in_gv)->lines
+ : SvTRUE(sv) ) {
+ sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
+ sv_catpv(targ, "E0");
+ }
+ SETs(targ);
+ }
+
+ RETURN;
+}
+
+/* Control. */
+
+static I32
+dopoptolabel(label)
+char *label;
+{
+ register I32 i;
+ register CONTEXT *cx;
+
+ for (i = cxstack_ix; i >= 0; i--) {
+ cx = &cxstack[i];
+ switch (cx->cx_type) {
+ case CXt_SUBST:
+ if (dowarn)
+ warn("Exiting substitution via %s", op_name[op->op_type]);
+ break;
+ case CXt_SUB:
+ if (dowarn)
+ warn("Exiting subroutine via %s", op_name[op->op_type]);
+ break;
+ case CXt_EVAL:
+ if (dowarn)
+ warn("Exiting eval via %s", op_name[op->op_type]);
+ break;
+ case CXt_LOOP:
+ if (!cx->blk_loop.label ||
+ strNE(label, cx->blk_loop.label) ) {
+ DEBUG_l(deb("(Skipping label #%d %s)\n",
+ i, cx->blk_loop.label));
+ continue;
+ }
+ DEBUG_l( deb("(Found label #%d %s)\n", i, label));
+ return i;
+ }
+ }
+}
+
+static I32
+dopoptosub(startingblock)
+I32 startingblock;
+{
+ I32 i;
+ register CONTEXT *cx;
+ for (i = startingblock; i >= 0; i--) {
+ cx = &cxstack[i];
+ switch (cx->cx_type) {
+ default:
+ continue;
+ case CXt_EVAL:
+ case CXt_SUB:
+ DEBUG_l( deb("(Found sub #%d)\n", i));
+ return i;
+ }
+ }
+ return i;
+}
+
+I32
+dopoptoeval(startingblock)
+I32 startingblock;
+{
+ I32 i;
+ register CONTEXT *cx;
+ for (i = startingblock; i >= 0; i--) {
+ cx = &cxstack[i];
+ switch (cx->cx_type) {
+ default:
+ continue;
+ case CXt_EVAL:
+ DEBUG_l( deb("(Found eval #%d)\n", i));
+ return i;
+ }
+ }
+ return i;
+}
+
+static I32
+dopoptoloop(startingblock)
+I32 startingblock;
+{
+ I32 i;
+ register CONTEXT *cx;
+ for (i = startingblock; i >= 0; i--) {
+ cx = &cxstack[i];
+ switch (cx->cx_type) {
+ case CXt_SUBST:
+ if (dowarn)
+ warn("Exiting substitition via %s", op_name[op->op_type]);
+ break;
+ case CXt_SUB:
+ if (dowarn)
+ warn("Exiting subroutine via %s", op_name[op->op_type]);
+ break;
+ case CXt_EVAL:
+ if (dowarn)
+ warn("Exiting eval via %s", op_name[op->op_type]);
+ break;
+ case CXt_LOOP:
+ DEBUG_l( deb("(Found loop #%d)\n", i));
+ return i;
+ }
+ }
+ return i;
+}
+
+static void
+dounwind(cxix)
+I32 cxix;
+{
+ register CONTEXT *cx;
+ SV **newsp;
+ I32 optype;
+
+ while (cxstack_ix > cxix) {
+ cx = &cxstack[cxstack_ix--];
+ DEBUG_l(fprintf(stderr, "Unwinding block %d, type %d\n", cxstack_ix+1,
+ cx->cx_type));
+ /* Note: we don't need to restore the base context info till the end. */
+ switch (cx->cx_type) {
+ case CXt_SUB:
+ POPSUB(cx);
+ break;
+ case CXt_EVAL:
+ POPEVAL(cx);
+ break;
+ case CXt_LOOP:
+ POPLOOP(cx);
+ break;
+ case CXt_SUBST:
+ break;
+ }
+ }
+}
+
+/*VARARGS0*/
+OP *
+die(va_alist)
+va_dcl
+{
+ va_list args;
+ char *tmps;
+ char *message;
+ OP *retop;
+
+ va_start(args);
+ message = mess(args);
+ va_end(args);
+ restartop = die_where(message);
+ if (stack != mainstack)
+ longjmp(top_env, 3);
+ return restartop;
+}
+
+OP *
+die_where(message)
+char *message;
+{
+ if (in_eval) {
+ I32 cxix;
+ register CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+
+ sv_setpv(GvSV(gv_fetchpv("@",TRUE)),message);
+ cxix = dopoptoeval(cxstack_ix);
+ if (cxix >= 0) {
+ I32 optype;
+
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ POPBLOCK(cx);
+ if (cx->cx_type != CXt_EVAL) {
+ fprintf(stderr, "panic: die %s", message);
+ my_exit(1);
+ }
+ POPEVAL(cx);
+
+ if (gimme == G_SCALAR)
+ *++newsp = &sv_undef;
+ stack_sp = newsp;
+
+ LEAVE;
+ if (optype == OP_REQUIRE)
+ DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
+ return pop_return();
+ }
+ }
+ fputs(message, stderr);
+ (void)fflush(stderr);
+ if (e_fp)
+ (void)UNLINK(e_tmpname);
+ statusvalue >>= 8;
+ my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+ return 0;
+}
+
+PP(pp_and)
+{
+ dSP;
+ if (!SvTRUE(TOPs))
+ RETURN;
+ else {
+ --SP;
+ RETURNOP(cLOGOP->op_other);
+ }
+}
+
+PP(pp_or)
+{
+ dSP;
+ if (SvTRUE(TOPs))
+ RETURN;
+ else {
+ --SP;
+ RETURNOP(cLOGOP->op_other);
+ }
+}
+
+PP(pp_cond_expr)
+{
+ dSP;
+ if (SvTRUEx(POPs))
+ RETURNOP(cCONDOP->op_true);
+ else
+ RETURNOP(cCONDOP->op_false);
+}
+
+PP(pp_andassign)
+{
+ dSP;
+ if (!SvTRUE(TOPs))
+ RETURN;
+ else
+ RETURNOP(cLOGOP->op_other);
+}
+
+PP(pp_orassign)
+{
+ dSP;
+ if (SvTRUE(TOPs))
+ RETURN;
+ else
+ RETURNOP(cLOGOP->op_other);
+}
+
+PP(pp_method)
+{
+ dSP; dPOPss; dTARGET;
+ SV* ob;
+ GV* gv;
+
+ if (SvTYPE(sv) != SVt_REF || !(ob = (SV*)SvANY(sv)) || SvSTORAGE(ob) != 'O')
+ DIE("Not an object reference");
+
+ if (TARG && SvTYPE(TARG) == SVt_REF) {
+ /* XXX */
+ gv = 0;
+ }
+ else
+ gv = 0;
+
+ if (!gv) { /* nothing cached */
+ char *name = SvPV(((SVOP*)cLOGOP->op_other)->op_sv);
+ if (index(name, '\''))
+ gv = gv_fetchpv(name, FALSE);
+ else
+ gv = gv_fetchmethod(SvSTASH(ob),name);
+ if (!gv)
+ DIE("Can't locate object method \"%s\" via package \"%s\"",
+ name, HvNAME(SvSTASH(ob)));
+ }
+
+ EXTEND(sp,2);
+ PUSHs(gv);
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_entersubr)
+{
+ dSP; dMARK;
+ SV *sv;
+ GV *gv;
+ HV *stash;
+ register CV *cv = sv_2cv(*++MARK, &stash, &gv, 0);
+ register I32 items = SP - MARK;
+ I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
+ register CONTEXT *cx;
+
+ ENTER;
+ SAVETMPS;
+
+ if (!cv) {
+ if (gv) {
+ SV *tmpstr = sv_mortalcopy(&sv_undef);
+ gv_efullname(tmpstr, gv);
+ DIE("Undefined subroutine \"%s\" called",SvPV(tmpstr));
+ }
+ DIE("Not a subroutine reference");
+ }
+ if ((op->op_private & OPpSUBR_DB) && !CvUSERSUB(cv)) {
+ sv = GvSV(DBsub);
+ save_item(sv);
+ gv_efullname(sv,gv);
+ cv = GvCV(DBsub);
+ if (!cv)
+ DIE("No DBsub routine");
+ }
+
+ if (CvUSERSUB(cv)) {
+ cx->blk_sub.hasargs = 0;
+ cx->blk_sub.savearray = Null(AV*);;
+ cx->blk_sub.argarray = Null(AV*);
+ if (!hasargs)
+ items = 0;
+ items = (*CvUSERSUB(cv))(CvUSERINDEX(cv), sp - stack_base, items);
+ sp = stack_base + items;
+ RETURN;
+ }
+ else {
+ I32 gimme = GIMME;
+ push_return(op->op_next);
+ PUSHBLOCK(cx, CXt_SUB, MARK - 1);
+ PUSHSUB(cx);
+ if (hasargs) {
+ cx->blk_sub.savearray = GvAV(defgv);
+ cx->blk_sub.argarray = av_fake(items, ++MARK);
+ GvAV(defgv) = cx->blk_sub.argarray;
+ }
+ CvDEPTH(cv)++;
+ if (CvDEPTH(cv) >= 2) { /* save temporaries on recursion? */
+ if (CvDEPTH(cv) == 100 && dowarn)
+ warn("Deep recursion on subroutine \"%s\"",GvENAME(gv));
+ if (CvDEPTH(cv) > AvFILL(CvPADLIST(cv))) {
+ AV *newpad = newAV();
+ I32 ix = AvFILL((AV*)*av_fetch(CvPADLIST(cv), 1, FALSE));
+ while (ix > 0)
+ av_store(newpad, ix--, NEWSV(0,0));
+ av_store(CvPADLIST(cv), CvDEPTH(cv), (SV*)newpad);
+ AvFILL(CvPADLIST(cv)) = CvDEPTH(cv);
+ }
+ }
+ SAVESPTR(curpad);
+ curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),CvDEPTH(cv),FALSE));
+ RETURNOP(CvSTART(cv));
+ }
+}
+
+PP(pp_leavesubr)
+{
+ dSP;
+ SV **mark;
+ SV **newsp;
+ I32 gimme;
+ register CONTEXT *cx;
+
+ POPBLOCK(cx);
+ POPSUB(cx);
+
+ if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP)
+ *MARK = sv_mortalcopy(TOPs);
+ else {
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
+ }
+ SP = MARK;
+ }
+ else {
+ for (mark = newsp + 1; mark <= SP; mark++)
+ *mark = sv_mortalcopy(*mark);
+ /* in case LEAVE wipes old return values */
+ }
+
+ LEAVE;
+ PUTBACK;
+ return pop_return();
+}
+
+PP(pp_done)
+{
+ return pop_return();
+}
+
+PP(pp_caller)
+{
+ dSP;
+ register I32 cxix = dopoptosub(cxstack_ix);
+ I32 nextcxix;
+ register CONTEXT *cx;
+ SV *sv;
+ I32 count = 0;
+
+ if (cxix < 0)
+ DIE("There is no caller");
+ if (MAXARG)
+ count = POPi;
+ for (;;) {
+ if (cxix < 0)
+ RETURN;
+ nextcxix = dopoptosub(cxix - 1);
+ if (DBsub && nextcxix >= 0 &&
+ cxstack[nextcxix].blk_sub.cv == GvCV(DBsub))
+ count++;
+ if (!count--)
+ break;
+ cxix = nextcxix;
+ }
+ cx = &cxstack[cxix];
+ EXTEND(SP, 6);
+ if (GIMME != G_ARRAY) {
+ dTARGET;
+
+ sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash));
+ PUSHs(TARG);
+ RETURN;
+ }
+
+ PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0)));
+ PUSHs(sv_2mortal(newSVpv(SvPV(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
+ PUSHs(sv_2mortal(newSVnv((double)cx->blk_oldcop->cop_line)));
+ if (!MAXARG)
+ RETURN;
+ sv = NEWSV(49, 0);
+ gv_efullname(sv, cx->blk_sub.gv);
+ PUSHs(sv_2mortal(sv));
+ PUSHs(sv_2mortal(newSVnv((double)cx->blk_sub.hasargs)));
+ PUSHs(sv_2mortal(newSVnv((double)cx->blk_gimme)));
+ if (cx->blk_sub.hasargs) {
+ AV *ary = cx->blk_sub.argarray;
+
+ if (!dbargs)
+ dbargs = GvAV(gv_AVadd(gv_fetchpv("DB'args", TRUE)));
+ if (AvMAX(dbargs) < AvFILL(ary))
+ av_store(dbargs, AvFILL(ary), Nullsv);
+ Copy(AvARRAY(ary), AvARRAY(dbargs), AvFILL(ary)+1, SV*);
+ AvFILL(dbargs) = AvFILL(ary);
+ }
+ RETURN;
+}
+
+static I32
+sortcv(str1, str2)
+SV **str1;
+SV **str2;
+{
+ GvSV(firstgv) = *str1;
+ GvSV(secondgv) = *str2;
+ stack_sp = stack_base;
+ op = sortcop;
+ run();
+ return SvIVnx(AvARRAY(stack)[1]);
+}
+
+static I32
+sortcmp(strp1, strp2)
+SV **strp1;
+SV **strp2;
+{
+ register SV *str1 = *strp1;
+ register SV *str2 = *strp2;
+ I32 retval;
+
+ if (SvCUR(str1) < SvCUR(str2)) {
+ /*SUPPRESS 560*/
+ if (retval = memcmp(SvPV(str1), SvPV(str2), SvCUR(str1)))
+ return retval;
+ else
+ return -1;
+ }
+ /*SUPPRESS 560*/
+ else if (retval = memcmp(SvPV(str1), SvPV(str2), SvCUR(str2)))
+ return retval;
+ else if (SvCUR(str1) == SvCUR(str2))
+ return 0;
+ else
+ return 1;
+}
+
+PP(pp_warn)
+{
+ dSP; dMARK;
+ char *tmps;
+ if (SP - MARK != 1) {
+ dTARGET;
+ do_join(TARG, sv_no, MARK, SP);
+ tmps = SvPVn(TARG);
+ SP = MARK + 1;
+ }
+ else {
+ tmps = SvPVn(TOPs);
+ }
+ if (!tmps || !*tmps) {
+ SV *error = GvSV(gv_fetchpv("@", TRUE));
+ if (SvCUR(error))
+ sv_catpv(error, "\t...caught");
+ tmps = SvPVn(error);
+ }
+ if (!tmps || !*tmps)
+ tmps = "Warning: something's wrong";
+ warn("%s", tmps);
+ RETSETYES;
+}
+
+PP(pp_die)
+{
+ dSP; dMARK;
+ char *tmps;
+ if (SP - MARK != 1) {
+ dTARGET;
+ do_join(TARG, sv_no, MARK, SP);
+ tmps = SvPVn(TARG);
+ SP = MARK + 1;
+ }
+ else {
+ tmps = SvPVn(TOPs);
+ }
+ if (!tmps || !*tmps) {
+ SV *error = GvSV(gv_fetchpv("@", TRUE));
+ if (SvCUR(error))
+ sv_catpv(error, "\t...propagated");
+ tmps = SvPVn(error);
+ }
+ if (!tmps || !*tmps)
+ tmps = "Died";
+ DIE("%s", tmps);
+}
+
+PP(pp_reset)
+{
+ dSP;
+ double value;
+ char *tmps;
+
+ if (MAXARG < 1)
+ tmps = "";
+ else
+ tmps = POPp;
+ sv_reset(tmps, curcop->cop_stash);
+ PUSHs(&sv_yes);
+ RETURN;
+}
+
+PP(pp_lineseq)
+{
+ return NORMAL;
+}
+
+PP(pp_curcop)
+{
+ curcop = (COP*)op;
+#ifdef TAINT
+ tainted = 0; /* Each statement is presumed innocent */
+#endif
+ stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
+ free_tmps();
+ return NORMAL;
+}
+
+PP(pp_unstack)
+{
+ I32 oldsave;
+#ifdef TAINT
+ tainted = 0; /* Each statement is presumed innocent */
+#endif
+ stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
+ /* XXX should tmps_floor live in cxstack? */
+ while (tmps_ix > tmps_floor) { /* clean up after last eval */
+ sv_free(tmps_stack[tmps_ix]);
+ tmps_stack[tmps_ix--] = Nullsv;
+ }
+ oldsave = scopestack[scopestack_ix - 1];
+ if (savestack_ix > oldsave)
+ leave_scope(oldsave);
+ return NORMAL;
+}
+
+PP(pp_enter)
+{
+ dSP;
+ register CONTEXT *cx;
+ I32 gimme = GIMME;
+ ENTER;
+
+ SAVETMPS;
+ PUSHBLOCK(cx,CXt_BLOCK,sp);
+
+ RETURN;
+}
+
+PP(pp_leave)
+{
+ dSP;
+ register CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+
+ POPBLOCK(cx);
+ LEAVE;
+
+ RETURN;
+}
+
+PP(pp_enteriter)
+{
+ dSP; dMARK;
+ register CONTEXT *cx;
+ SV **svp = &GvSV((GV*)POPs);
+ I32 gimme = GIMME;
+
+ ENTER;
+ SAVETMPS;
+ ENTER;
+
+ PUSHBLOCK(cx,CXt_LOOP,SP);
+ PUSHLOOP(cx, svp, MARK);
+ cx->blk_loop.iterary = stack;
+ cx->blk_loop.iterix = MARK - stack_base;
+
+ RETURN;
+}
+
+PP(pp_iter)
+{
+ dSP;
+ register CONTEXT *cx;
+ SV *sv;
+
+ EXTEND(sp, 1);
+ cx = &cxstack[cxstack_ix];
+ if (cx->cx_type != CXt_LOOP)
+ DIE("panic: pp_iter");
+
+ if (cx->blk_loop.iterix >= cx->blk_oldsp)
+ RETPUSHNO;
+
+ sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix];
+ *cx->blk_loop.itervar = sv ? sv : &sv_undef;
+
+ RETPUSHYES;
+}
+
+PP(pp_enterloop)
+{
+ dSP;
+ register CONTEXT *cx;
+ I32 gimme = GIMME;
+
+ ENTER;
+ SAVETMPS;
+ ENTER;
+
+ PUSHBLOCK(cx, CXt_LOOP, SP);
+ PUSHLOOP(cx, 0, SP);
+
+ RETURN;
+}
+
+PP(pp_leaveloop)
+{
+ dSP;
+ register CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ SV **mark;
+
+ POPBLOCK(cx);
+ mark = newsp;
+ POPLOOP(cx);
+ if (gimme == G_SCALAR) {
+ if (mark < SP)
+ *++newsp = sv_mortalcopy(*SP);
+ else
+ *++newsp = &sv_undef;
+ }
+ else {
+ while (mark < SP)
+ *++newsp = sv_mortalcopy(*++mark);
+ }
+ sp = newsp;
+ LEAVE;
+ LEAVE;
+
+ RETURN;
+}
+
+PP(pp_return)
+{
+ dSP; dMARK;
+ I32 cxix;
+ register CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ I32 optype = 0;
+
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0)
+ DIE("Can't return outside a subroutine");
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ POPBLOCK(cx);
+ switch (cx->cx_type) {
+ case CXt_SUB:
+ POPSUB(cx);
+ break;
+ case CXt_EVAL:
+ POPEVAL(cx);
+ break;
+ default:
+ DIE("panic: return");
+ break;
+ }
+
+ if (gimme == G_SCALAR) {
+ if (MARK < SP)
+ *++newsp = sv_mortalcopy(*SP);
+ else
+ *++newsp = &sv_undef;
+ if (optype == OP_REQUIRE && !SvTRUE(*newsp))
+ DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
+ }
+ else {
+ if (optype == OP_REQUIRE && MARK == SP)
+ DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
+ while (MARK < SP)
+ *++newsp = sv_mortalcopy(*++MARK);
+ }
+ stack_sp = newsp;
+
+ LEAVE;
+ return pop_return();
+}
+
+PP(pp_last)
+{
+ dSP;
+ I32 cxix;
+ register CONTEXT *cx;
+ I32 gimme;
+ I32 optype;
+ OP *nextop;
+ SV **newsp;
+ SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
+ /* XXX The sp is probably not right yet... */
+
+ if (op->op_flags & OPf_SPECIAL) {
+ cxix = dopoptoloop(cxstack_ix);
+ if (cxix < 0)
+ DIE("Can't \"last\" outside a block");
+ }
+ else {
+ cxix = dopoptolabel(cPVOP->op_pv);
+ if (cxix < 0)
+ DIE("Label not found for \"last %s\"", cPVOP->op_pv);
+ }
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ POPBLOCK(cx);
+ switch (cx->cx_type) {
+ case CXt_LOOP:
+ POPLOOP(cx);
+ nextop = cx->blk_loop.last_op->op_next;
+ LEAVE;
+ break;
+ case CXt_EVAL:
+ POPEVAL(cx);
+ nextop = pop_return();
+ break;
+ case CXt_SUB:
+ POPSUB(cx);
+ nextop = pop_return();
+ break;
+ default:
+ DIE("panic: last");
+ break;
+ }
+
+ if (gimme == G_SCALAR) {
+ if (mark < SP)
+ *++newsp = sv_mortalcopy(*SP);
+ else
+ *++newsp = &sv_undef;
+ }
+ else {
+ while (mark < SP)
+ *++newsp = sv_mortalcopy(*++mark);
+ }
+ sp = newsp;
+
+ LEAVE;
+ RETURNOP(nextop);
+}
+
+PP(pp_next)
+{
+ dSP;
+ I32 cxix;
+ register CONTEXT *cx;
+ I32 oldsave;
+
+ if (op->op_flags & OPf_SPECIAL) {
+ cxix = dopoptoloop(cxstack_ix);
+ if (cxix < 0)
+ DIE("Can't \"next\" outside a block");
+ }
+ else {
+ cxix = dopoptolabel(cPVOP->op_pv);
+ if (cxix < 0)
+ DIE("Label not found for \"next %s\"", cPVOP->op_pv);
+ }
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ TOPBLOCK(cx);
+ oldsave = scopestack[scopestack_ix - 1];
+ if (savestack_ix > oldsave)
+ leave_scope(oldsave);
+ return cx->blk_loop.next_op;
+}
+
+PP(pp_redo)
+{
+ dSP;
+ I32 cxix;
+ register CONTEXT *cx;
+ I32 oldsave;
+
+ if (op->op_flags & OPf_SPECIAL) {
+ cxix = dopoptoloop(cxstack_ix);
+ if (cxix < 0)
+ DIE("Can't \"redo\" outside a block");
+ }
+ else {
+ cxix = dopoptolabel(cPVOP->op_pv);
+ if (cxix < 0)
+ DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
+ }
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ TOPBLOCK(cx);
+ oldsave = scopestack[scopestack_ix - 1];
+ if (savestack_ix > oldsave)
+ leave_scope(oldsave);
+ return cx->blk_loop.redo_op;
+}
+
+static OP* lastgotoprobe;
+
+OP *
+dofindlabel(op,label,opstack)
+OP *op;
+char *label;
+OP **opstack;
+{
+ OP *kid;
+ OP **ops = opstack;
+
+ if (op->op_type == OP_LEAVE ||
+ op->op_type == OP_LEAVELOOP ||
+ op->op_type == OP_LEAVETRY)
+ *ops++ = cUNOP->op_first;
+ *ops = 0;
+ if (op->op_flags & OPf_KIDS) {
+ /* First try all the kids at this level, since that's likeliest. */
+ for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+ if (kid->op_type == OP_CURCOP && kCOP->cop_label &&
+ strEQ(kCOP->cop_label, label))
+ return kid;
+ }
+ for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+ if (kid == lastgotoprobe)
+ continue;
+ if (kid->op_type == OP_CURCOP) {
+ if (ops > opstack && ops[-1]->op_type == OP_CURCOP)
+ *ops = kid;
+ else
+ *ops++ = kid;
+ }
+ if (op = dofindlabel(kid,label,ops))
+ return op;
+ }
+ }
+ *ops = 0;
+ return 0;
+}
+
+PP(pp_dump)
+{
+ return pp_goto(ARGS);
+ /*NOTREACHED*/
+}
+
+PP(pp_goto)
+{
+ dSP;
+ OP *retop = 0;
+ I32 ix;
+ register CONTEXT *cx;
+ I32 entering = 0;
+ OP *enterops[64];
+ char *label;
+
+ label = 0;
+ if (op->op_flags & OPf_SPECIAL) {
+ if (op->op_type != OP_DUMP)
+ DIE("goto must have label");
+ }
+ else
+ label = cPVOP->op_pv;
+
+ if (label && *label) {
+ OP *gotoprobe;
+
+ /* find label */
+
+ lastgotoprobe = 0;
+ *enterops = 0;
+ for (ix = cxstack_ix; ix >= 0; ix--) {
+ cx = &cxstack[ix];
+ switch (cx->cx_type) {
+ case CXt_SUB:
+ gotoprobe = CvROOT(cx->blk_sub.cv);
+ break;
+ case CXt_EVAL:
+ gotoprobe = eval_root; /* XXX not good for nested eval */
+ break;
+ case CXt_LOOP:
+ gotoprobe = cx->blk_oldcop->op_sibling;
+ break;
+ case CXt_SUBST:
+ continue;
+ case CXt_BLOCK:
+ if (ix)
+ gotoprobe = cx->blk_oldcop->op_sibling;
+ else
+ gotoprobe = main_root;
+ break;
+ default:
+ if (ix)
+ DIE("panic: goto");
+ else
+ gotoprobe = main_root;
+ break;
+ }
+ retop = dofindlabel(gotoprobe, label, enterops);
+ if (retop)
+ break;
+ lastgotoprobe = gotoprobe;
+ }
+ if (!retop)
+ DIE("Can't find label %s", label);
+
+ /* pop unwanted frames */
+
+ if (ix < cxstack_ix) {
+ I32 oldsave;
+
+ if (ix < 0)
+ ix = 0;
+ dounwind(ix);
+ TOPBLOCK(cx);
+ oldsave = scopestack[scopestack_ix - 1];
+ if (savestack_ix > oldsave)
+ leave_scope(oldsave);
+ }
+
+ /* push wanted frames */
+
+ if (*enterops) {
+ OP *oldop = op;
+ for (ix = 0 + (gotoprobe == main_root); enterops[ix]; ix++) {
+ op = enterops[ix];
+ (*op->op_ppaddr)();
+ }
+ op = oldop;
+ }
+ }
+
+ if (op->op_type == OP_DUMP) {
+ restartop = retop;
+ do_undump = TRUE;
+
+ my_unexec();
+
+ restartop = 0; /* hmm, must be GNU unexec().. */
+ do_undump = FALSE;
+ }
+
+ RETURNOP(retop);
+}
+
+PP(pp_exit)
+{
+ dSP;
+ I32 anum;
+
+ if (MAXARG < 1)
+ anum = 0;
+ else
+ anum = SvIVnx(POPs);
+ my_exit(anum);
+ PUSHs(&sv_undef);
+ RETURN;
+}
+
+PP(pp_nswitch)
+{
+ dSP;
+ double value = SvNVnx(GvSV(cCOP->cop_gv));
+ register I32 match = (I32)value;
+
+ if (value < 0.0) {
+ if (((double)match) > value)
+ --match; /* was fractional--truncate other way */
+ }
+ match -= cCOP->uop.scop.scop_offset;
+ if (match < 0)
+ match = 0;
+ else if (match > cCOP->uop.scop.scop_max)
+ match = cCOP->uop.scop.scop_max;
+ op = cCOP->uop.scop.scop_next[match];
+ RETURNOP(op);
+}
+
+PP(pp_cswitch)
+{
+ dSP;
+ register I32 match;
+
+ if (multiline)
+ op = op->op_next; /* can't assume anything */
+ else {
+ match = *(SvPVnx(GvSV(cCOP->cop_gv))) & 255;
+ match -= cCOP->uop.scop.scop_offset;
+ if (match < 0)
+ match = 0;
+ else if (match > cCOP->uop.scop.scop_max)
+ match = cCOP->uop.scop.scop_max;
+ op = cCOP->uop.scop.scop_next[match];
+ }
+ RETURNOP(op);
+}
+
+/* I/O. */
+
+PP(pp_open)
+{
+ dSP; dTARGET;
+ GV *gv;
+ dPOPss;
+ char *tmps;
+
+ gv = (GV*)POPs;
+ tmps = SvPVn(sv);
+ if (do_open(gv, tmps, SvCUR(sv))) {
+ GvIO(gv)->lines = 0;
+ PUSHi( (I32)forkprocess );
+ }
+ else if (forkprocess == 0) /* we are a new child */
+ PUSHi(0);
+ else
+ RETPUSHUNDEF;
+ RETURN;
+}
+
+PP(pp_close)
+{
+ dSP;
+ GV *gv;
+
+ if (MAXARG == 0)
+ gv = defoutgv;
+ else
+ gv = (GV*)POPs;
+ EXTEND(SP, 1);
+ PUSHs( do_close(gv, TRUE) ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_pipe_op)
+{
+ dSP;
+#ifdef HAS_PIPE
+ GV *rgv;
+ GV *wgv;
+ register IO *rstio;
+ register IO *wstio;
+ int fd[2];
+
+ wgv = (GV*)POPs;
+ rgv = (GV*)POPs;
+
+ if (!rgv || !wgv)
+ goto badexit;
+
+ rstio = GvIOn(rgv);
+ wstio = GvIOn(wgv);
+
+ if (rstio->ifp)
+ do_close(rgv, FALSE);
+ if (wstio->ifp)
+ do_close(wgv, 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 = '>';
+
+ if (!rstio->ifp || !wstio->ofp) {
+ if (rstio->ifp) fclose(rstio->ifp);
+ else close(fd[0]);
+ if (wstio->ofp) fclose(wstio->ofp);
+ else close(fd[1]);
+ goto badexit;
+ }
+
+ RETPUSHYES;
+
+badexit:
+ RETPUSHUNDEF;
+#else
+ DIE(no_func, "pipe");
+#endif
+}
+
+PP(pp_fileno)
+{
+ dSP; dTARGET;
+ GV *gv;
+ IO *io;
+ FILE *fp;
+ if (MAXARG < 1)
+ RETPUSHUNDEF;
+ gv = (GV*)POPs;
+ if (!gv || !(io = GvIO(gv)) || !(fp = io->ifp))
+ RETPUSHUNDEF;
+ PUSHi(fileno(fp));
+ RETURN;
+}
+
+PP(pp_umask)
+{
+ dSP; dTARGET;
+ int anum;
+
+#ifdef HAS_UMASK
+ if (MAXARG < 1) {
+ anum = umask(0);
+ (void)umask(anum);
+ }
+ else
+ anum = umask(POPi);
+ TAINT_PROPER("umask");
+ XPUSHi(anum);
+#else
+ DIE(no_func, "Unsupported function umask");
+#endif
+ RETURN;
+}
+
+PP(pp_binmode)
+{
+ dSP;
+ GV *gv;
+ IO *io;
+ FILE *fp;
+
+ if (MAXARG < 1)
+ RETPUSHUNDEF;
+
+ gv = (GV*)POPs;
+
+ EXTEND(SP, 1);
+ if (!gv || !(io = GvIO(gv)) || !(fp = io->ifp))
+ RETSETUNDEF;
+
+#ifdef DOSISH
+#ifdef atarist
+ if (!fflush(fp) && (fp->_flag |= _IOBIN))
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+#else
+ if (setmode(fileno(fp), OP_BINARY) != -1)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+#endif
+#else
+ RETPUSHYES;
+#endif
+}
+
+PP(pp_dbmopen)
+{
+ dSP; dTARGET;
+ int anum;
+ HV *hv;
+ dPOPPOPssrl;
+
+ hv = (HV*)POPs;
+ if (SvOK(rstr))
+ anum = SvIVn(rstr);
+ else
+ anum = -1;
+#ifdef SOME_DBM
+ PUSHi( (I32)hv_dbmopen(hv, SvPVn(lstr), anum) );
+#else
+ DIE("No dbm or ndbm on this machine");
+#endif
+ RETURN;
+}
+
+PP(pp_dbmclose)
+{
+ dSP;
+ I32 anum;
+ HV *hv;
+
+ hv = (HV*)POPs;
+#ifdef SOME_DBM
+ hv_dbmclose(hv);
+ RETPUSHYES;
+#else
+ DIE("No dbm or ndbm on this machine");
+#endif
+}
+
+PP(pp_sselect)
+{
+ dSP; dTARGET;
+#ifdef HAS_SELECT
+ register I32 i;
+ register I32 j;
+ register char *s;
+ register SV *sv;
+ double value;
+ I32 maxlen = 0;
+ I32 nfound;
+ struct timeval timebuf;
+ struct timeval *tbuf = &timebuf;
+ I32 growsize;
+ char *fd_sets[4];
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ I32 masksize;
+ I32 offset;
+ I32 k;
+
+# if BYTEORDER & 0xf0000
+# define ORDERBYTE (0x88888888 - BYTEORDER)
+# else
+# define ORDERBYTE (0x4444 - BYTEORDER)
+# endif
+
+#endif
+
+ SP -= 4;
+ for (i = 1; i <= 3; i++) {
+ if (!SvPOK(SP[i]))
+ continue;
+ j = SvCUR(SP[i]);
+ 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
+
+ sv = SP[4];
+ if (SvOK(sv)) {
+ value = SvNVn(sv);
+ 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*);
+
+ for (i = 1; i <= 3; i++) {
+ sv = SP[i];
+ if (!SvPOK(sv)) {
+ fd_sets[i] = 0;
+ continue;
+ }
+ j = SvLEN(sv);
+ if (j < growsize) {
+ Sv_Grow(sv, growsize);
+ s = SvPVn(sv) + j;
+ while (++j <= growsize) {
+ *s++ = '\0';
+ }
+ }
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ s = SvPV(sv);
+ 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];
+ }
+#else
+ fd_sets[i] = SvPV(sv);
+#endif
+ }
+
+ nfound = select(
+ maxlen * 8,
+ fd_sets[1],
+ fd_sets[2],
+ fd_sets[3],
+ tbuf);
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ for (i = 1; i <= 3; i++) {
+ if (fd_sets[i]) {
+ sv = SP[i];
+ s = SvPV(sv);
+ 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];
+ }
+ Safefree(fd_sets[i]);
+ }
+ }
+#endif
+
+ PUSHi(nfound);
+ if (GIMME == G_ARRAY && tbuf) {
+ value = (double)(timebuf.tv_sec) +
+ (double)(timebuf.tv_usec) / 1000000.0;
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setnv(sv, value);
+ }
+ RETURN;
+#else
+ DIE("select not implemented");
+#endif
+}
+
+PP(pp_select)
+{
+ dSP; dTARGET;
+ GV *oldgv = defoutgv;
+ if (op->op_private > 0) {
+ defoutgv = (GV*)POPs;
+ if (!GvIO(defoutgv))
+ GvIO(defoutgv) = newIO();
+ curoutgv = defoutgv;
+ }
+ gv_efullname(TARG, oldgv);
+ XPUSHTARG;
+ RETURN;
+}
+
+PP(pp_getc)
+{
+ dSP; dTARGET;
+ GV *gv;
+
+ if (MAXARG <= 0)
+ gv = stdingv;
+ else
+ gv = (GV*)POPs;
+ if (!gv)
+ gv = argvgv;
+ if (!gv || do_eof(gv)) /* make sure we have fp with something */
+ RETPUSHUNDEF;
+ TAINT_IF(1);
+ sv_setpv(TARG, " ");
+ *SvPV(TARG) = getc(GvIO(gv)->ifp); /* should never be EOF */
+ PUSHTARG;
+ RETURN;
+}
+
+PP(pp_read)
+{
+ return pp_sysread(ARGS);
+}
+
+static OP *
+doform(cv,gv,retop)
+CV *cv;
+GV *gv;
+OP *retop;
+{
+ register CONTEXT *cx;
+ I32 gimme = GIMME;
+ ENTER;
+ SAVETMPS;
+
+ push_return(retop);
+ PUSHBLOCK(cx, CXt_SUB, stack_sp);
+ PUSHFORMAT(cx);
+ defoutgv = gv; /* locally select filehandle so $% et al work */
+ return CvSTART(cv);
+}
+
+PP(pp_enterwrite)
+{
+ dSP;
+ register GV *gv;
+ register IO *io;
+ GV *fgv;
+ FILE *fp;
+ CV *cv;
+
+ if (MAXARG == 0)
+ gv = defoutgv;
+ else {
+ gv = (GV*)POPs;
+ if (!gv)
+ gv = defoutgv;
+ }
+ EXTEND(SP, 1);
+ io = GvIO(gv);
+ if (!io) {
+ RETPUSHNO;
+ }
+ curoutgv = gv;
+ if (io->fmt_gv)
+ fgv = io->fmt_gv;
+ else
+ fgv = gv;
+
+ cv = GvFORM(fgv);
+
+ if (!cv) {
+ if (fgv) {
+ SV *tmpstr = sv_mortalcopy(&sv_undef);
+ gv_efullname(tmpstr, gv);
+ DIE("Undefined format \"%s\" called",SvPV(tmpstr));
+ }
+ DIE("Not a format reference");
+ }
+
+ return doform(cv,gv,op->op_next);
+}
+
+PP(pp_leavewrite)
+{
+ dSP;
+ GV *gv = cxstack[cxstack_ix].blk_sub.gv;
+ register IO *io = GvIO(gv);
+ FILE *ofp = io->ofp;
+ FILE *fp;
+ SV **mark;
+ SV **newsp;
+ I32 gimme;
+ register CONTEXT *cx;
+
+ DEBUG_f(fprintf(stderr,"left=%ld, todo=%ld\n",
+ (long)io->lines_left, (long)FmLINES(formtarget)));
+ if (io->lines_left < FmLINES(formtarget) &&
+ formtarget != toptarget)
+ {
+ if (!io->top_gv) {
+ GV *topgv;
+ char tmpbuf[256];
+
+ if (!io->top_name) {
+ if (!io->fmt_name)
+ io->fmt_name = savestr(GvNAME(gv));
+ sprintf(tmpbuf, "%s_TOP", io->fmt_name);
+ topgv = gv_fetchpv(tmpbuf,FALSE);
+ if (topgv && GvFORM(topgv))
+ io->top_name = savestr(tmpbuf);
+ else
+ io->top_name = savestr("top");
+ }
+ topgv = gv_fetchpv(io->top_name,FALSE);
+ if (!topgv || !GvFORM(topgv)) {
+ io->lines_left = 100000000;
+ goto forget_top;
+ }
+ io->top_gv = topgv;
+ }
+ if (io->lines_left >= 0 && io->page > 0)
+ fwrite(SvPV(formfeed), SvCUR(formfeed), 1, ofp);
+ io->lines_left = io->page_len;
+ io->page++;
+ formtarget = toptarget;
+ return doform(GvFORM(io->top_gv),gv,op);
+ }
+
+ forget_top:
+ POPBLOCK(cx);
+ POPFORMAT(cx);
+ LEAVE;
+
+ fp = io->ofp;
+ if (!fp) {
+ if (dowarn) {
+ if (io->ifp)
+ warn("Filehandle only opened for input");
+ else
+ warn("Write on closed filehandle");
+ }
+ PUSHs(&sv_no);
+ }
+ else {
+ if ((io->lines_left -= FmLINES(formtarget)) < 0) {
+ if (dowarn)
+ warn("page overflow");
+ }
+ if (!fwrite(SvPV(formtarget), 1, SvCUR(formtarget), ofp) ||
+ ferror(fp))
+ PUSHs(&sv_no);
+ else {
+ FmLINES(formtarget) = 0;
+ SvCUR_set(formtarget, 0);
+ if (io->flags & IOf_FLUSH)
+ (void)fflush(fp);
+ PUSHs(&sv_yes);
+ }
+ }
+ formtarget = bodytarget;
+ PUTBACK;
+ return pop_return();
+}
+
+PP(pp_prtf)
+{
+ dSP; dMARK; dORIGMARK;
+ GV *gv;
+ IO *io;
+ FILE *fp;
+ SV *sv = NEWSV(0,0);
+
+ if (op->op_flags & OPf_STACKED)
+ gv = (GV*)*++MARK;
+ else
+ gv = defoutgv;
+ if (!(io = GvIO(gv))) {
+ if (dowarn)
+ warn("Filehandle never opened");
+ errno = EBADF;
+ goto just_say_no;
+ }
+ else if (!(fp = io->ofp)) {
+ if (dowarn) {
+ if (io->ifp)
+ warn("Filehandle opened only for input");
+ else
+ warn("printf on closed filehandle");
+ }
+ errno = EBADF;
+ goto just_say_no;
+ }
+ else {
+ do_sprintf(sv, SP - MARK, MARK + 1);
+ if (!do_print(sv, fp))
+ goto just_say_no;
+
+ if (io->flags & IOf_FLUSH)
+ if (fflush(fp) == EOF)
+ goto just_say_no;
+ }
+ sv_free(sv);
+ SP = ORIGMARK;
+ PUSHs(&sv_yes);
+ RETURN;
+
+ just_say_no:
+ sv_free(sv);
+ SP = ORIGMARK;
+ PUSHs(&sv_undef);
+ RETURN;
+}
+
+PP(pp_print)
+{
+ dSP; dMARK; dORIGMARK;
+ GV *gv;
+ IO *io;
+ register FILE *fp;
+
+ if (op->op_flags & OPf_STACKED)
+ gv = (GV*)*++MARK;
+ else
+ gv = defoutgv;
+ if (!(io = GvIO(gv))) {
+ if (dowarn)
+ warn("Filehandle never opened");
+ errno = EBADF;
+ goto just_say_no;
+ }
+ else if (!(fp = io->ofp)) {
+ if (dowarn) {
+ if (io->ifp)
+ warn("Filehandle opened only for input");
+ else
+ warn("print on closed filehandle");
+ }
+ errno = EBADF;
+ goto just_say_no;
+ }
+ else {
+ MARK++;
+ if (ofslen) {
+ while (MARK <= SP) {
+ if (!do_print(*MARK, fp))
+ break;
+ MARK++;
+ if (MARK <= SP) {
+ if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
+ MARK--;
+ break;
+ }
+ }
+ }
+ }
+ else {
+ while (MARK <= SP) {
+ if (!do_print(*MARK, fp))
+ break;
+ MARK++;
+ }
+ }
+ if (MARK <= SP)
+ goto just_say_no;
+ else {
+ if (orslen)
+ if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp))
+ goto just_say_no;
+
+ if (io->flags & IOf_FLUSH)
+ if (fflush(fp) == EOF)
+ goto just_say_no;
+ }
+ }
+ SP = ORIGMARK;
+ PUSHs(&sv_yes);
+ RETURN;
+
+ just_say_no:
+ SP = ORIGMARK;
+ PUSHs(&sv_undef);
+ RETURN;
+}
+
+PP(pp_sysread)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ int offset;
+ GV *gv;
+ IO *io;
+ char *buffer;
+ int length;
+ int bufsize;
+ SV *bufstr;
+
+ gv = (GV*)*++MARK;
+ if (!gv)
+ goto say_undef;
+ bufstr = *++MARK;
+ buffer = SvPVn(bufstr);
+ length = SvIVnx(*++MARK);
+ errno = 0;
+ if (MARK < SP)
+ offset = SvIVnx(*++MARK);
+ else
+ offset = 0;
+ if (MARK < SP)
+ warn("Too many args on read");
+ io = GvIO(gv);
+ if (!io || !io->ifp)
+ goto say_undef;
+#ifdef HAS_SOCKET
+ if (op->op_type == OP_RECV) {
+ bufsize = sizeof buf;
+ SvGROW(bufstr, length+1), (buffer = SvPVn(bufstr)); /* sneaky */
+ length = recvfrom(fileno(io->ifp), buffer, length, offset,
+ buf, &bufsize);
+ if (length < 0)
+ RETPUSHUNDEF;
+ SvCUR_set(bufstr, length);
+ *SvEND(bufstr) = '\0';
+ SvNOK_off(bufstr);
+ SP = ORIGMARK;
+ sv_setpvn(TARG, buf, bufsize);
+ PUSHs(TARG);
+ RETURN;
+ }
+#else
+ if (op->op_type == OP_RECV)
+ DIE(no_sock_func, "recv");
+#endif
+ SvGROW(bufstr, length+offset+1), (buffer = SvPVn(bufstr)); /* sneaky */
+ if (op->op_type == OP_SYSREAD) {
+ length = read(fileno(io->ifp), buffer+offset, length);
+ }
+ else
+#ifdef HAS_SOCKET
+ if (io->type == 's') {
+ bufsize = sizeof buf;
+ length = recvfrom(fileno(io->ifp), buffer+offset, length, 0,
+ buf, &bufsize);
+ }
+ else
+#endif
+ length = fread(buffer+offset, 1, length, io->ifp);
+ if (length < 0)
+ goto say_undef;
+ SvCUR_set(bufstr, length+offset);
+ *SvEND(bufstr) = '\0';
+ SvNOK_off(bufstr);
+ SP = ORIGMARK;
+ PUSHi(length);
+ RETURN;
+
+ say_undef:
+ SP = ORIGMARK;
+ RETPUSHUNDEF;
+}
+
+PP(pp_syswrite)
+{
+ return pp_send(ARGS);
+}
+
+PP(pp_send)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ GV *gv;
+ IO *io;
+ int offset;
+ SV *bufstr;
+ char *buffer;
+ int length;
+
+ gv = (GV*)*++MARK;
+ if (!gv)
+ goto say_undef;
+ bufstr = *++MARK;
+ buffer = SvPVn(bufstr);
+ length = SvIVnx(*++MARK);
+ errno = 0;
+ io = GvIO(gv);
+ if (!io || !io->ifp) {
+ length = -1;
+ if (dowarn) {
+ if (op->op_type == OP_SYSWRITE)
+ warn("Syswrite on closed filehandle");
+ else
+ warn("Send on closed socket");
+ }
+ }
+ else if (op->op_type == OP_SYSWRITE) {
+ if (MARK < SP)
+ offset = SvIVnx(*++MARK);
+ else
+ offset = 0;
+ if (MARK < SP)
+ warn("Too many args on syswrite");
+ length = write(fileno(io->ifp), buffer+offset, length);
+ }
+#ifdef HAS_SOCKET
+ else if (SP >= MARK) {
+ if (SP > MARK)
+ warn("Too many args on send");
+ buffer = SvPVnx(*++MARK);
+ length = sendto(fileno(io->ifp), buffer, SvCUR(bufstr),
+ length, buffer, SvCUR(*MARK));
+ }
+ else
+ length = send(fileno(io->ifp), buffer, SvCUR(bufstr), length);
+#else
+ else
+ DIE(no_sock_func, "send");
+#endif
+ if (length < 0)
+ goto say_undef;
+ SP = ORIGMARK;
+ PUSHi(length);
+ RETURN;
+
+ say_undef:
+ SP = ORIGMARK;
+ RETPUSHUNDEF;
+}
+
+PP(pp_recv)
+{
+ return pp_sysread(ARGS);
+}
+
+PP(pp_eof)
+{
+ dSP;
+ GV *gv;
+
+ if (MAXARG <= 0)
+ gv = last_in_gv;
+ else
+ gv = (GV*)POPs;
+ PUSHs(do_eof(gv) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_tell)
+{
+ dSP; dTARGET;
+ GV *gv;
+
+ if (MAXARG <= 0)
+ gv = last_in_gv;
+ else
+ gv = (GV*)POPs;
+ PUSHi( do_tell(gv) );
+ RETURN;
+}
+
+PP(pp_seek)
+{
+ dSP;
+ GV *gv;
+ int whence = POPi;
+ long offset = POPl;
+
+ gv = (GV*)POPs;
+ PUSHs( do_seek(gv, offset, whence) ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_truncate)
+{
+ dSP;
+ off_t len = (off_t)POPn;
+ int result = 1;
+ GV *tmpgv;
+
+ errno = 0;
+#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE)
+#ifdef HAS_TRUNCATE
+ if (op->op_flags & OPf_SPECIAL) {
+ tmpgv = gv_fetchpv(POPp,FALSE);
+ if (!tmpgv || !GvIO(tmpgv) || !GvIO(tmpgv)->ifp ||
+ ftruncate(fileno(GvIO(tmpgv)->ifp), len) < 0)
+ result = 0;
+ }
+ else if (truncate(POPp, len) < 0)
+ result = 0;
+#else
+ if (op->op_flags & OPf_SPECIAL) {
+ tmpgv = gv_fetchpv(POPp,FALSE);
+ if (!tmpgv || !GvIO(tmpgv) || !GvIO(tmpgv)->ifp ||
+ chsize(fileno(GvIO(tmpgv)->ifp), len) < 0)
+ result = 0;
+ }
+ else {
+ int tmpfd;
+
+ if ((tmpfd = open(POPp, 0)) < 0)
+ result = 0;
+ else {
+ if (chsize(tmpfd, len) < 0)
+ result = 0;
+ close(tmpfd);
+ }
+ }
+#endif
+
+ if (result)
+ RETPUSHYES;
+ if (!errno)
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE("truncate not implemented");
+#endif
+}
+
+PP(pp_fcntl)
+{
+ return pp_ioctl(ARGS);
+}
+
+PP(pp_ioctl)
+{
+ dSP; dTARGET;
+ SV *argstr = POPs;
+ unsigned int func = U_I(POPn);
+ int optype = op->op_type;
+ char *s;
+ int retval;
+ GV *gv = (GV*)POPs;
+ IO *io = GvIOn(gv);
+
+ TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
+
+ if (!io || !argstr || !io->ifp) {
+ errno = EBADF; /* well, sort of... */
+ RETPUSHUNDEF;
+ }
+
+ if (SvPOK(argstr) || !SvNIOK(argstr)) {
+ if (!SvPOK(argstr))
+ s = SvPVn(argstr);
+ retval = IOCPARM_LEN(func);
+ if (SvCUR(argstr) < retval) {
+ Sv_Grow(argstr, retval+1);
+ SvCUR_set(argstr, retval);
+ }
+
+ s = SvPV(argstr);
+ s[SvCUR(argstr)] = 17; /* a little sanity check here */
+ }
+ else {
+ retval = SvIVn(argstr);
+#ifdef DOSISH
+ s = (char*)(long)retval; /* ouch */
+#else
+ s = (char*)retval; /* ouch */
+#endif
+ }
+
+ if (optype == OP_IOCTL)
+ retval = ioctl(fileno(io->ifp), func, s);
+ else
+#ifdef DOSISH
+ DIE("fcntl is not implemented");
+#else
+# ifdef HAS_FCNTL
+ retval = fcntl(fileno(io->ifp), func, s);
+# else
+ DIE("fcntl is not implemented");
+# endif
+#endif
+
+ if (SvPOK(argstr)) {
+ if (s[SvCUR(argstr)] != 17)
+ DIE("Return value overflowed string");
+ s[SvCUR(argstr)] = 0; /* put our null back */
+ }
+
+ if (retval == -1)
+ RETPUSHUNDEF;
+ if (retval != 0) {
+ PUSHi(retval);
+ }
+ else {
+ PUSHp("0 but true", 10);
+ }
+ RETURN;
+}
+
+PP(pp_flock)
+{
+ dSP; dTARGET;
+ I32 value;
+ int argtype;
+ GV *gv;
+ FILE *fp;
+#ifdef HAS_FLOCK
+ argtype = POPi;
+ if (MAXARG <= 0)
+ gv = last_in_gv;
+ else
+ gv = (GV*)POPs;
+ if (gv && GvIO(gv))
+ fp = GvIO(gv)->ifp;
+ else
+ fp = Nullfp;
+ if (fp) {
+ value = (I32)(flock(fileno(fp), argtype) >= 0);
+ }
+ else
+ value = 0;
+ PUSHi(value);
+ RETURN;
+#else
+ DIE(no_func, "flock()");
+#endif
+}
+
+/* Sockets. */
+
+PP(pp_socket)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ GV *gv;
+ register IO *io;
+ int protocol = POPi;
+ int type = POPi;
+ int domain = POPi;
+ int fd;
+
+ gv = (GV*)POPs;
+
+ if (!gv) {
+ errno = EBADF;
+ RETPUSHUNDEF;
+ }
+
+ io = GvIOn(gv);
+ if (io->ifp)
+ do_close(gv, FALSE);
+
+ TAINT_PROPER("socket");
+ fd = socket(domain, type, protocol);
+ if (fd < 0)
+ RETPUSHUNDEF;
+ io->ifp = fdopen(fd, "r"); /* stdio gets confused about sockets */
+ io->ofp = fdopen(fd, "w");
+ io->type = 's';
+ if (!io->ifp || !io->ofp) {
+ if (io->ifp) fclose(io->ifp);
+ if (io->ofp) fclose(io->ofp);
+ if (!io->ifp && !io->ofp) close(fd);
+ RETPUSHUNDEF;
+ }
+
+ RETPUSHYES;
+#else
+ DIE(no_sock_func, "socket");
+#endif
+}
+
+PP(pp_sockpair)
+{
+ dSP;
+#ifdef HAS_SOCKETPAIR
+ GV *gv1;
+ GV *gv2;
+ register IO *io1;
+ register IO *io2;
+ int protocol = POPi;
+ int type = POPi;
+ int domain = POPi;
+ int fd[2];
+
+ gv2 = (GV*)POPs;
+ gv1 = (GV*)POPs;
+ if (!gv1 || !gv2)
+ RETPUSHUNDEF;
+
+ io1 = GvIOn(gv1);
+ io2 = GvIOn(gv2);
+ if (io1->ifp)
+ do_close(gv1, FALSE);
+ if (io2->ifp)
+ do_close(gv2, FALSE);
+
+ TAINT_PROPER("socketpair");
+ if (socketpair(domain, type, protocol, fd) < 0)
+ RETPUSHUNDEF;
+ io1->ifp = fdopen(fd[0], "r");
+ io1->ofp = fdopen(fd[0], "w");
+ io1->type = 's';
+ io2->ifp = fdopen(fd[1], "r");
+ io2->ofp = fdopen(fd[1], "w");
+ io2->type = 's';
+ if (!io1->ifp || !io1->ofp || !io2->ifp || !io2->ofp) {
+ if (io1->ifp) fclose(io1->ifp);
+ if (io1->ofp) fclose(io1->ofp);
+ if (!io1->ifp && !io1->ofp) close(fd[0]);
+ if (io2->ifp) fclose(io2->ifp);
+ if (io2->ofp) fclose(io2->ofp);
+ if (!io2->ifp && !io2->ofp) close(fd[1]);
+ RETPUSHUNDEF;
+ }
+
+ RETPUSHYES;
+#else
+ DIE(no_sock_func, "socketpair");
+#endif
+}
+
+PP(pp_bind)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ SV *addrstr = POPs;
+ char *addr;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->ifp)
+ goto nuts;
+
+ addr = SvPVn(addrstr);
+ TAINT_PROPER("bind");
+ if (bind(fileno(io->ifp), addr, SvCUR(addrstr)) >= 0)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+
+nuts:
+ if (dowarn)
+ warn("bind() on closed fd");
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE(no_sock_func, "bind");
+#endif
+}
+
+PP(pp_connect)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ SV *addrstr = POPs;
+ char *addr;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->ifp)
+ goto nuts;
+
+ addr = SvPVn(addrstr);
+ TAINT_PROPER("connect");
+ if (connect(fileno(io->ifp), addr, SvCUR(addrstr)) >= 0)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+
+nuts:
+ if (dowarn)
+ warn("connect() on closed fd");
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE(no_sock_func, "connect");
+#endif
+}
+
+PP(pp_listen)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ int backlog = POPi;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->ifp)
+ goto nuts;
+
+ if (listen(fileno(io->ifp), backlog) >= 0)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+
+nuts:
+ if (dowarn)
+ warn("listen() on closed fd");
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE(no_sock_func, "listen");
+#endif
+}
+
+PP(pp_accept)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ GV *ngv;
+ GV *ggv;
+ register IO *nstio;
+ register IO *gstio;
+ int len = sizeof buf;
+ int fd;
+
+ ggv = (GV*)POPs;
+ ngv = (GV*)POPs;
+
+ if (!ngv)
+ goto badexit;
+ if (!ggv)
+ goto nuts;
+
+ gstio = GvIO(ggv);
+ if (!gstio || !gstio->ifp)
+ goto nuts;
+
+ nstio = GvIOn(ngv);
+ if (nstio->ifp)
+ do_close(ngv, FALSE);
+
+ fd = accept(fileno(gstio->ifp), (struct sockaddr *)buf, &len);
+ if (fd < 0)
+ goto badexit;
+ nstio->ifp = fdopen(fd, "r");
+ nstio->ofp = fdopen(fd, "w");
+ nstio->type = 's';
+ if (!nstio->ifp || !nstio->ofp) {
+ if (nstio->ifp) fclose(nstio->ifp);
+ if (nstio->ofp) fclose(nstio->ofp);
+ if (!nstio->ifp && !nstio->ofp) close(fd);
+ goto badexit;
+ }
+
+ PUSHp(buf, len);
+ RETURN;
+
+nuts:
+ if (dowarn)
+ warn("accept() on closed fd");
+ errno = EBADF;
+
+badexit:
+ RETPUSHUNDEF;
+
+#else
+ DIE(no_sock_func, "accept");
+#endif
+}
+
+PP(pp_shutdown)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ int how = POPi;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->ifp)
+ goto nuts;
+
+ PUSHi( shutdown(fileno(io->ifp), how) >= 0 );
+ RETURN;
+
+nuts:
+ if (dowarn)
+ warn("shutdown() on closed fd");
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE(no_sock_func, "shutdown");
+#endif
+}
+
+PP(pp_gsockopt)
+{
+#ifdef HAS_SOCKET
+ return pp_ssockopt(ARGS);
+#else
+ DIE(no_sock_func, "getsockopt");
+#endif
+}
+
+PP(pp_ssockopt)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ int optype = op->op_type;
+ SV *sv;
+ int fd;
+ unsigned int optname;
+ unsigned int lvl;
+ GV *gv;
+ register IO *io;
+
+ if (optype == OP_GSOCKOPT)
+ sv = sv_2mortal(NEWSV(22, 257));
+ else
+ sv = POPs;
+ optname = (unsigned int) POPi;
+ lvl = (unsigned int) POPi;
+
+ gv = (GV*)POPs;
+ io = GvIOn(gv);
+ if (!io || !io->ifp)
+ goto nuts;
+
+ fd = fileno(io->ifp);
+ switch (optype) {
+ case OP_GSOCKOPT:
+ SvCUR_set(sv, 256);
+ SvPOK_on(sv);
+ if (getsockopt(fd, lvl, optname, SvPV(sv), (int*)&SvCUR(sv)) < 0)
+ goto nuts2;
+ PUSHs(sv);
+ break;
+ case OP_SSOCKOPT:
+ if (setsockopt(fd, lvl, optname, SvPV(sv), SvCUR(sv)) < 0)
+ goto nuts2;
+ PUSHs(&sv_yes);
+ break;
+ }
+ RETURN;
+
+nuts:
+ if (dowarn)
+ warn("[gs]etsockopt() on closed fd");
+ errno = EBADF;
+nuts2:
+ RETPUSHUNDEF;
+
+#else
+ DIE(no_sock_func, "setsockopt");
+#endif
+}
+
+PP(pp_getsockname)
+{
+#ifdef HAS_SOCKET
+ return pp_getpeername(ARGS);
+#else
+ DIE(no_sock_func, "getsockname");
+#endif
+}
+
+PP(pp_getpeername)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ int optype = op->op_type;
+ SV *sv;
+ int fd;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->ifp)
+ goto nuts;
+
+ sv = sv_2mortal(NEWSV(22, 257));
+ SvCUR_set(sv, 256);
+ SvPOK_on(sv);
+ fd = fileno(io->ifp);
+ switch (optype) {
+ case OP_GETSOCKNAME:
+ if (getsockname(fd, SvPV(sv), (int*)&SvCUR(sv)) < 0)
+ goto nuts2;
+ break;
+ case OP_GETPEERNAME:
+ if (getpeername(fd, SvPV(sv), (int*)&SvCUR(sv)) < 0)
+ goto nuts2;
+ break;
+ }
+ PUSHs(sv);
+ RETURN;
+
+nuts:
+ if (dowarn)
+ warn("get{sock, peer}name() on closed fd");
+ errno = EBADF;
+nuts2:
+ RETPUSHUNDEF;
+
+#else
+ DIE(no_sock_func, "getpeername");
+#endif
+}
+
+/* Stat calls. */
+
+PP(pp_lstat)
+{
+ return pp_stat(ARGS);
+}
+
+PP(pp_stat)
+{
+ dSP;
+ GV *tmpgv;
+ I32 max = 13;
+
+ if (op->op_flags & OPf_SPECIAL) {
+ tmpgv = cGVOP->op_gv;
+ if (tmpgv != defgv) {
+ laststype = OP_STAT;
+ statgv = tmpgv;
+ sv_setpv(statname, "");
+ if (!GvIO(tmpgv) || !GvIO(tmpgv)->ifp ||
+ fstat(fileno(GvIO(tmpgv)->ifp), &statcache) < 0) {
+ max = 0;
+ laststatval = -1;
+ }
+ }
+ else if (laststatval < 0)
+ max = 0;
+ }
+ else {
+ sv_setpv(statname, POPp);
+ statgv = Nullgv;
+#ifdef HAS_LSTAT
+ laststype = op->op_type;
+ if (op->op_type == OP_LSTAT)
+ laststatval = lstat(SvPVn(statname), &statcache);
+ else
+#endif
+ laststatval = stat(SvPVn(statname), &statcache);
+ if (laststatval < 0) {
+ if (dowarn && index(SvPVn(statname), '\n'))
+ warn(warn_nl, "stat");
+ max = 0;
+ }
+ }
+
+ EXTEND(SP, 13);
+ if (GIMME != G_ARRAY) {
+ if (max)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+ }
+ if (max) {
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_dev)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_ino)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_mode)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_nlink)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_uid)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_gid)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_rdev)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_size)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_atime)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_mtime)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_ctime)));
+#ifdef STATBLOCKS
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_blksize)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_blocks)));
+#else
+ PUSHs(sv_2mortal(newSVpv("", 0)));
+ PUSHs(sv_2mortal(newSVpv("", 0)));
+#endif
+ }
+ RETURN;
+}
+
+PP(pp_ftrread)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IRUSR, 0, &statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftrwrite)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IWUSR, 0, &statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftrexec)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IXUSR, 0, &statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_fteread)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IRUSR, 1, &statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftewrite)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IWUSR, 1, &statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_fteexec)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IXUSR, 1, &statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftis)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHYES;
+}
+
+PP(pp_fteowned)
+{
+ return pp_ftrowned(ARGS);
+}
+
+PP(pp_ftrowned)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftzero)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (!statcache.st_size)
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftsize)
+{
+ I32 result = my_stat(ARGS);
+ dSP; dTARGET;
+ if (result < 0)
+ RETPUSHUNDEF;
+ PUSHi(statcache.st_size);
+ RETURN;
+}
+
+PP(pp_ftmtime)
+{
+ I32 result = my_stat(ARGS);
+ dSP; dTARGET;
+ if (result < 0)
+ RETPUSHUNDEF;
+ PUSHn( (basetime - statcache.st_mtime) / 86400.0 );
+ RETURN;
+}
+
+PP(pp_ftatime)
+{
+ I32 result = my_stat(ARGS);
+ dSP; dTARGET;
+ if (result < 0)
+ RETPUSHUNDEF;
+ PUSHn( (basetime - statcache.st_atime) / 86400.0 );
+ RETURN;
+}
+
+PP(pp_ftctime)
+{
+ I32 result = my_stat(ARGS);
+ dSP; dTARGET;
+ if (result < 0)
+ RETPUSHUNDEF;
+ PUSHn( (basetime - statcache.st_ctime) / 86400.0 );
+ RETURN;
+}
+
+PP(pp_ftsock)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISSOCK(statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftchr)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISCHR(statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftblk)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISBLK(statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftfile)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISREG(statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftdir)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISDIR(statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftpipe)
+{
+ I32 result = my_stat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISFIFO(statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftlink)
+{
+ I32 result = my_lstat(ARGS);
+ dSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISLNK(statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftsuid)
+{
+ dSP;
+#ifdef S_ISUID
+ I32 result = my_stat(ARGS);
+ SPAGAIN;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (statcache.st_mode & S_ISUID)
+ RETPUSHYES;
+#endif
+ RETPUSHNO;
+}
+
+PP(pp_ftsgid)
+{
+ dSP;
+#ifdef S_ISGID
+ I32 result = my_stat(ARGS);
+ SPAGAIN;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (statcache.st_mode & S_ISGID)
+ RETPUSHYES;
+#endif
+ RETPUSHNO;
+}
+
+PP(pp_ftsvtx)
+{
+ dSP;
+#ifdef S_ISVTX
+ I32 result = my_stat(ARGS);
+ SPAGAIN;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (statcache.st_mode & S_ISVTX)
+ RETPUSHYES;
+#endif
+ RETPUSHNO;
+}
+
+PP(pp_fttty)
+{
+ dSP;
+ int fd;
+ GV *gv;
+ char *tmps;
+ if (op->op_flags & OPf_SPECIAL) {
+ gv = cGVOP->op_gv;
+ tmps = "";
+ }
+ else
+ gv = gv_fetchpv(tmps = POPp, FALSE);
+ if (gv && GvIO(gv) && GvIO(gv)->ifp)
+ fd = fileno(GvIO(gv)->ifp);
+ else if (isDIGIT(*tmps))
+ fd = atoi(tmps);
+ else
+ RETPUSHUNDEF;
+ if (isatty(fd))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_fttext)
+{
+ dSP;
+ I32 i;
+ I32 len;
+ I32 odd = 0;
+ STDCHAR tbuf[512];
+ register STDCHAR *s;
+ register IO *io;
+ SV *sv;
+
+ if (op->op_flags & OPf_SPECIAL) {
+ EXTEND(SP, 1);
+ if (cGVOP->op_gv == defgv) {
+ if (statgv)
+ io = GvIO(statgv);
+ else {
+ sv = statname;
+ goto really_filename;
+ }
+ }
+ else {
+ statgv = cGVOP->op_gv;
+ sv_setpv(statname, "");
+ io = GvIO(statgv);
+ }
+ if (io && io->ifp) {
+#if defined(STDSTDIO) || defined(atarist) /* this will work with atariST */
+ fstat(fileno(io->ifp), &statcache);
+ if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
+ if (op->op_type == OP_FTTEXT)
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+ if (io->ifp->_cnt <= 0) {
+ i = getc(io->ifp);
+ if (i != EOF)
+ (void)ungetc(i, io->ifp);
+ }
+ if (io->ifp->_cnt <= 0) /* null file is anything */
+ RETPUSHYES;
+ len = io->ifp->_cnt + (io->ifp->_ptr - io->ifp->_base);
+ s = io->ifp->_base;
+#else
+ DIE("-T and -B not implemented on filehandles");
+#endif
+ }
+ else {
+ if (dowarn)
+ warn("Test on unopened file <%s>",
+ GvENAME(cGVOP->op_gv));
+ errno = EBADF;
+ RETPUSHUNDEF;
+ }
+ }
+ else {
+ sv = POPs;
+ statgv = Nullgv;
+ sv_setpv(statname, SvPVn(sv));
+ really_filename:
+ i = open(SvPVn(sv), 0);
+ if (i < 0) {
+ if (dowarn && index(SvPVn(sv), '\n'))
+ warn(warn_nl, "open");
+ RETPUSHUNDEF;
+ }
+ fstat(i, &statcache);
+ len = read(i, tbuf, 512);
+ (void)close(i);
+ if (len <= 0) {
+ if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
+ RETPUSHNO; /* special case NFS directories */
+ RETPUSHYES; /* null file is anything */
+ }
+ 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) == (op->op_type == OP_FTTEXT)) /* allow 10% odd */
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+}
+
+PP(pp_ftbinary)
+{
+ return pp_fttext(ARGS);
+}
+
+/* File calls. */
+
+PP(pp_chdir)
+{
+ dSP; dTARGET;
+ double value;
+ char *tmps;
+ SV **svp;
+
+ if (MAXARG < 1)
+ tmps = Nullch;
+ else
+ tmps = POPp;
+ if (!tmps || !*tmps) {
+ svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
+ if (svp)
+ tmps = SvPVn(*svp);
+ }
+ if (!tmps || !*tmps) {
+ svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
+ if (svp)
+ tmps = SvPVn(*svp);
+ }
+ TAINT_PROPER("chdir");
+ PUSHi( chdir(tmps) >= 0 );
+ RETURN;
+}
+
+PP(pp_chown)
+{
+ dSP; dMARK; dTARGET;
+ I32 value;
+#ifdef HAS_CHOWN
+ value = (I32)apply(op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function chown");
+#endif
+}
+
+PP(pp_chroot)
+{
+ dSP; dTARGET;
+ char *tmps;
+#ifdef HAS_CHROOT
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+ TAINT_PROPER("chroot");
+ PUSHi( chroot(tmps) >= 0 );
+ RETURN;
+#else
+ DIE(no_func, "chroot");
+#endif
+}
+
+PP(pp_unlink)
+{
+ dSP; dMARK; dTARGET;
+ I32 value;
+ value = (I32)apply(op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+}
+
+PP(pp_chmod)
+{
+ dSP; dMARK; dTARGET;
+ I32 value;
+ value = (I32)apply(op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+}
+
+PP(pp_utime)
+{
+ dSP; dMARK; dTARGET;
+ I32 value;
+ value = (I32)apply(op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+}
+
+PP(pp_rename)
+{
+ dSP; dTARGET;
+ int anum;
+
+ char *tmps2 = POPp;
+ char *tmps = SvPVn(TOPs);
+ TAINT_PROPER("rename");
+#ifdef HAS_RENAME
+ anum = rename(tmps, tmps2);
+#else
+ if (same_dirent(tmps2, tmps)) /* can always rename to same name */
+ anum = 1;
+ else {
+ if (euid || stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
+ (void)UNLINK(tmps2);
+ if (!(anum = link(tmps, tmps2)))
+ anum = UNLINK(tmps);
+ }
+#endif
+ SETi( anum >= 0 );
+ RETURN;
+}
+
+PP(pp_link)
+{
+ dSP; dTARGET;
+#ifdef HAS_LINK
+ char *tmps2 = POPp;
+ char *tmps = SvPVn(TOPs);
+ TAINT_PROPER("link");
+ SETi( link(tmps, tmps2) >= 0 );
+#else
+ DIE(no_func, "Unsupported function link");
+#endif
+ RETURN;
+}
+
+PP(pp_symlink)
+{
+ dSP; dTARGET;
+#ifdef HAS_SYMLINK
+ char *tmps2 = POPp;
+ char *tmps = SvPVn(TOPs);
+ TAINT_PROPER("symlink");
+ SETi( symlink(tmps, tmps2) >= 0 );
+ RETURN;
+#else
+ DIE(no_func, "symlink");
+#endif
+}
+
+PP(pp_readlink)
+{
+ dSP; dTARGET;
+#ifdef HAS_SYMLINK
+ char *tmps;
+ int len;
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+ len = readlink(tmps, buf, sizeof buf);
+ EXTEND(SP, 1);
+ if (len < 0)
+ RETPUSHUNDEF;
+ PUSHp(buf, len);
+ RETURN;
+#else
+ EXTEND(SP, 1);
+ RETSETUNDEF; /* just pretend it's a normal file */
+#endif
+}
+
+#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
+static void
+dooneliner(cmd, filename)
+char *cmd;
+char *filename;
+{
+ char mybuf[8192];
+ char *s;
+ int anum = 1;
+ FILE *myfp;
+
+ strcpy(mybuf, cmd);
+ strcat(mybuf, " ");
+ for (s = mybuf+strlen(mybuf); *filename; ) {
+ *s++ = '\\';
+ *s++ = *filename++;
+ }
+ strcpy(s, " 2>&1");
+ myfp = my_popen(mybuf, "r");
+ if (myfp) {
+ *mybuf = '\0';
+ s = fgets(mybuf, sizeof mybuf, myfp);
+ (void)my_pclose(myfp);
+ if (s != Nullch) {
+ for (errno = 1; errno < sys_nerr; errno++) {
+ if (instr(mybuf, sys_errlist[errno])) /* you don't see this */
+ return 0;
+ }
+ errno = 0;
+#ifndef EACCES
+#define EACCES EPERM
+#endif
+ if (instr(mybuf, "cannot make"))
+ errno = EEXIST;
+ else if (instr(mybuf, "existing file"))
+ errno = EEXIST;
+ else if (instr(mybuf, "ile exists"))
+ errno = EEXIST;
+ else if (instr(mybuf, "non-exist"))
+ errno = ENOENT;
+ else if (instr(mybuf, "does not exist"))
+ errno = ENOENT;
+ else if (instr(mybuf, "not empty"))
+ errno = EBUSY;
+ else if (instr(mybuf, "cannot access"))
+ errno = EACCES;
+ else
+ errno = EPERM;
+ return 0;
+ }
+ else { /* some mkdirs return no failure indication */
+ tmps = SvPVnx(st[1]);
+ anum = (stat(tmps, &statbuf) >= 0);
+ if (op->op_type == OP_RMDIR)
+ anum = !anum;
+ if (anum)
+ errno = 0;
+ else
+ errno = EACCES; /* a guess */
+ }
+ return anum;
+ }
+ else
+ return 0;
+}
+#endif
+
+PP(pp_mkdir)
+{
+ dSP; dTARGET;
+ int mode = POPi;
+ int oldumask;
+ char *tmps = SvPVn(TOPs);
+
+ TAINT_PROPER("mkdir");
+#ifdef HAS_MKDIR
+ SETi( mkdir(tmps, mode) >= 0 );
+#else
+ SETi( dooneliner("mkdir", tmps) );
+ oldumask = umask(0)
+ umask(oldumask);
+ chmod(tmps, (mode & ~oldumask) & 0777);
+#endif
+ RETURN;
+}
+
+PP(pp_rmdir)
+{
+ dSP; dTARGET;
+ char *tmps;
+
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+ TAINT_PROPER("rmdir");
+#ifdef HAS_RMDIR
+ XPUSHi( rmdir(tmps) >= 0 );
+#else
+ XPUSHi( dooneliner("rmdir", tmps) );
+#endif
+ RETURN;
+}
+
+/* Directory calls. */
+
+PP(pp_open_dir)
+{
+ dSP;
+#if defined(DIRENT) && defined(HAS_READDIR)
+ char *dirname = POPp;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io)
+ goto nope;
+
+ if (io->dirp)
+ closedir(io->dirp);
+ if (!(io->dirp = opendir(dirname)))
+ goto nope;
+
+ RETPUSHYES;
+nope:
+ if (!errno)
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "opendir");
+#endif
+}
+
+PP(pp_readdir)
+{
+ dSP;
+#if defined(DIRENT) && defined(HAS_READDIR)
+#ifndef apollo
+ struct DIRENT *readdir();
+#endif
+ register struct DIRENT *dp;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->dirp)
+ goto nope;
+
+ if (GIMME == G_ARRAY) {
+ /*SUPPRESS 560*/
+ while (dp = readdir(io->dirp)) {
+#ifdef DIRNAMLEN
+ XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
+#else
+ XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
+#endif
+ }
+ }
+ else {
+ if (!(dp = readdir(io->dirp)))
+ goto nope;
+#ifdef DIRNAMLEN
+ XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
+#else
+ XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
+#endif
+ }
+ RETURN;
+
+nope:
+ if (!errno)
+ errno = EBADF;
+ if (GIMME == G_ARRAY)
+ RETURN;
+ else
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "readdir");
+#endif
+}
+
+PP(pp_telldir)
+{
+ dSP; dTARGET;
+#if defined(HAS_TELLDIR) || defined(telldir)
+#ifndef telldir
+ long telldir();
+#endif
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->dirp)
+ goto nope;
+
+ PUSHi( telldir(io->dirp) );
+ RETURN;
+nope:
+ if (!errno)
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "telldir");
+#endif
+}
+
+PP(pp_seekdir)
+{
+ dSP;
+#if defined(HAS_SEEKDIR) || defined(seekdir)
+ long along = POPl;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->dirp)
+ goto nope;
+
+ (void)seekdir(io->dirp, along);
+
+ RETPUSHYES;
+nope:
+ if (!errno)
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "seekdir");
+#endif
+}
+
+PP(pp_rewinddir)
+{
+ dSP;
+#if defined(HAS_REWINDDIR) || defined(rewinddir)
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->dirp)
+ goto nope;
+
+ (void)rewinddir(io->dirp);
+ RETPUSHYES;
+nope:
+ if (!errno)
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "rewinddir");
+#endif
+}
+
+PP(pp_closedir)
+{
+ dSP;
+#if defined(DIRENT) && defined(HAS_READDIR)
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !io->dirp)
+ goto nope;
+
+ if (closedir(io->dirp) < 0)
+ goto nope;
+ io->dirp = 0;
+
+ RETPUSHYES;
+nope:
+ if (!errno)
+ errno = EBADF;
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "closedir");
+#endif
+}
+
+/* Process control. */
+
+PP(pp_fork)
+{
+ dSP; dTARGET;
+ int childpid;
+ GV *tmpgv;
+
+ EXTEND(SP, 1);
+#ifdef HAS_FORK
+ childpid = fork();
+ if (childpid < 0)
+ RETSETUNDEF;
+ if (!childpid) {
+ /*SUPPRESS 560*/
+ if (tmpgv = gv_fetchpv("$", allgvs))
+ sv_setiv(GvSV(tmpgv), (I32)getpid());
+ hv_clear(pidstatus, FALSE); /* no kids, so don't wait for 'em */
+ }
+ PUSHi(childpid);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function fork");
+#endif
+}
+
+PP(pp_wait)
+{
+ dSP; dTARGET;
+ int childpid;
+ int argflags;
+ I32 value;
+
+ EXTEND(SP, 1);
+#ifdef HAS_WAIT
+ childpid = wait(&argflags);
+ if (childpid > 0)
+ pidgone(childpid, argflags);
+ value = (I32)childpid;
+ statusvalue = (U16)argflags;
+ PUSHi(value);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function wait");
+#endif
+}
+
+PP(pp_waitpid)
+{
+ dSP; dTARGET;
+ int childpid;
+ int optype;
+ int argflags;
+ I32 value;
+
+#ifdef HAS_WAIT
+ optype = POPi;
+ childpid = TOPi;
+ childpid = wait4pid(childpid, &argflags, optype);
+ value = (I32)childpid;
+ statusvalue = (U16)argflags;
+ SETi(value);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function wait");
+#endif
+}
+
+PP(pp_system)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ I32 value;
+ int childpid;
+ int result;
+ int status;
+ VOIDRET (*ihand)(); /* place to save signal during system() */
+ VOIDRET (*qhand)(); /* place to save signal during system() */
+
+#ifdef HAS_FORK
+ if (SP - MARK == 1) {
+ TAINT_ENV();
+ TAINT_IF(TOPs->sv_tainted);
+ TAINT_PROPER("system");
+ }
+ while ((childpid = vfork()) == -1) {
+ if (errno != EAGAIN) {
+ value = -1;
+ SP = ORIGMARK;
+ PUSHi(value);
+ RETURN;
+ }
+ sleep(5);
+ }
+ if (childpid > 0) {
+ ihand = signal(SIGINT, SIG_IGN);
+ qhand = signal(SIGQUIT, SIG_IGN);
+ result = wait4pid(childpid, &status, 0);
+ (void)signal(SIGINT, ihand);
+ (void)signal(SIGQUIT, qhand);
+ statusvalue = (U16)status;
+ if (result < 0)
+ value = -1;
+ else {
+ value = (I32)((unsigned int)status & 0xffff);
+ }
+ do_execfree(); /* free any memory child malloced on vfork */
+ SP = ORIGMARK;
+ PUSHi(value);
+ RETURN;
+ }
+ if (op->op_flags & OPf_STACKED) {
+ SV *really = *++MARK;
+ value = (I32)do_aexec(really, MARK, SP);
+ }
+ else if (SP - MARK != 1)
+ value = (I32)do_aexec(Nullsv, MARK, SP);
+ else {
+ value = (I32)do_exec(SvPVnx(sv_mortalcopy(*SP)));
+ }
+ _exit(-1);
+#else /* ! FORK */
+ if ((op[1].op_type & A_MASK) == A_GV)
+ value = (I32)do_aspawn(st[1], arglast);
+ else if (arglast[2] - arglast[1] != 1)
+ value = (I32)do_aspawn(Nullsv, arglast);
+ else {
+ value = (I32)do_spawn(SvPVnx(sv_mortalcopy(st[2])));
+ }
+ PUSHi(value);
+#endif /* FORK */
+ RETURN;
+}
+
+PP(pp_exec)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ I32 value;
+
+ if (op->op_flags & OPf_STACKED) {
+ SV *really = *++MARK;
+ value = (I32)do_aexec(really, MARK, SP);
+ }
+ else if (SP - MARK != 1)
+ value = (I32)do_aexec(Nullsv, MARK, SP);
+ else {
+ TAINT_ENV();
+ TAINT_IF((*SP)->sv_tainted);
+ TAINT_PROPER("exec");
+ value = (I32)do_exec(SvPVnx(sv_mortalcopy(*SP)));
+ }
+ SP = ORIGMARK;
+ PUSHi(value);
+ RETURN;
+}
+
+PP(pp_kill)
+{
+ dSP; dMARK; dTARGET;
+ I32 value;
+#ifdef HAS_KILL
+ value = (I32)apply(op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function kill");
+#endif
+}
+
+PP(pp_getppid)
+{
+#ifdef HAS_GETPPID
+ dSP; dTARGET;
+ XPUSHi( getppid() );
+ RETURN;
+#else
+ DIE(no_func, "getppid");
+#endif
+}
+
+PP(pp_getpgrp)
+{
+#ifdef HAS_GETPGRP
+ dSP; dTARGET;
+ int pid;
+ I32 value;
+
+ if (MAXARG < 1)
+ pid = 0;
+ else
+ pid = SvIVnx(POPs);
+#ifdef _POSIX_SOURCE
+ if (pid != 0)
+ DIE("POSIX getpgrp can't take an argument");
+ value = (I32)getpgrp();
+#else
+ value = (I32)getpgrp(pid);
+#endif
+ XPUSHi(value);
+ RETURN;
+#else
+ DIE(no_func, "getpgrp()");
+#endif
+}
+
+PP(pp_setpgrp)
+{
+#ifdef HAS_SETPGRP
+ dSP; dTARGET;
+ int pgrp = POPi;
+ int pid = TOPi;
+
+ TAINT_PROPER("setpgrp");
+ SETi( setpgrp(pid, pgrp) >= 0 );
+ RETURN;
+#else
+ DIE(no_func, "setpgrp()");
+#endif
+}
+
+PP(pp_getpriority)
+{
+ dSP; dTARGET;
+ int which;
+ int who;
+#ifdef HAS_GETPRIORITY
+ who = POPi;
+ which = TOPi;
+ SETi( getpriority(which, who) );
+ RETURN;
+#else
+ DIE(no_func, "getpriority()");
+#endif
+}
+
+PP(pp_setpriority)
+{
+ dSP; dTARGET;
+ int which;
+ int who;
+ int niceval;
+#ifdef HAS_SETPRIORITY
+ niceval = POPi;
+ who = POPi;
+ which = TOPi;
+ TAINT_PROPER("setpriority");
+ SETi( setpriority(which, who, niceval) >= 0 );
+ RETURN;
+#else
+ DIE(no_func, "setpriority()");
+#endif
+}
+
+/* Time calls. */
+
+PP(pp_time)
+{
+ dSP; dTARGET;
+ XPUSHi( time(Null(long*)) );
+ RETURN;
+}
+
+#ifndef HZ
+#define HZ 60
+#endif
+
+PP(pp_tms)
+{
+ dSP;
+
+#ifdef MSDOS
+ DIE("times not implemented");
+#else
+ EXTEND(SP, 4);
+
+ (void)times(×buf);
+
+ PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
+ if (GIMME == G_ARRAY) {
+ PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
+ }
+ RETURN;
+#endif /* MSDOS */
+}
+
+PP(pp_localtime)
+{
+ return pp_gmtime(ARGS);
+}
+
+PP(pp_gmtime)
+{
+ dSP;
+ time_t when;
+ struct tm *tmbuf;
+ static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
+ static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
+
+ if (MAXARG < 1)
+ (void)time(&when);
+ else
+ when = (time_t)SvIVnx(POPs);
+
+ if (op->op_type == OP_LOCALTIME)
+ tmbuf = localtime(&when);
+ else
+ tmbuf = gmtime(&when);
+
+ EXTEND(SP, 9);
+ if (GIMME != G_ARRAY) {
+ dTARGET;
+ char mybuf[30];
+ if (!tmbuf)
+ RETPUSHUNDEF;
+ sprintf(mybuf, "%s %s %2d %02d:%02d:%02d %d",
+ dayname[tmbuf->tm_wday],
+ monname[tmbuf->tm_mon],
+ tmbuf->tm_mday,
+ tmbuf->tm_hour,
+ tmbuf->tm_min,
+ tmbuf->tm_sec,
+ tmbuf->tm_year + 1900);
+ PUSHp(mybuf, strlen(mybuf));
+ }
+ else if (tmbuf) {
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_sec)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_min)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_hour)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_mday)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_mon)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_year)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_wday)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_yday)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_isdst)));
+ }
+ RETURN;
+}
+
+PP(pp_alarm)
+{
+ dSP; dTARGET;
+ int anum;
+ char *tmps;
+#ifdef HAS_ALARM
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+ if (!tmps)
+ tmps = "0";
+ anum = alarm((unsigned int)atoi(tmps));
+ EXTEND(SP, 1);
+ if (anum < 0)
+ RETPUSHUNDEF;
+ PUSHi((I32)anum);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function alarm");
+ break;
+#endif
+}
+
+PP(pp_sleep)
+{
+ dSP; dTARGET;
+ char *tmps;
+ I32 duration;
+ time_t lasttime;
+ time_t when;
+
+ (void)time(&lasttime);
+ if (MAXARG < 1)
+ pause();
+ else {
+ duration = POPi;
+ sleep((unsigned int)duration);
+ }
+ (void)time(&when);
+ XPUSHi(when - lasttime);
+ RETURN;
+}
+
+/* Shared memory. */
+
+PP(pp_shmget)
+{
+ return pp_semget(ARGS);
+}
+
+PP(pp_shmctl)
+{
+ return pp_semctl(ARGS);
+}
+
+PP(pp_shmread)
+{
+ return pp_shmwrite(ARGS);
+}
+
+PP(pp_shmwrite)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ dSP; dMARK; dTARGET;
+ I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ pp_semget(ARGS);
+#endif
+}
+
+/* Message passing. */
+
+PP(pp_msgget)
+{
+ return pp_semget(ARGS);
+}
+
+PP(pp_msgctl)
+{
+ return pp_semctl(ARGS);
+}
+
+PP(pp_msgsnd)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ dSP; dMARK; dTARGET;
+ I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ pp_semget(ARGS);
+#endif
+}
+
+PP(pp_msgrcv)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ dSP; dMARK; dTARGET;
+ I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ pp_semget(ARGS);
+#endif
+}
+
+/* Semaphores. */
+
+PP(pp_semget)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ dSP; dMARK; dTARGET;
+ int anum = do_ipcget(op->op_type, MARK, SP);
+ SP = MARK;
+ if (anum == -1)
+ RETPUSHUNDEF;
+ PUSHi(anum);
+ RETURN;
+#else
+ DIE("System V IPC is not implemented on this machine");
+#endif
+}
+
+PP(pp_semctl)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ dSP; dMARK; dTARGET;
+ int anum = do_ipcctl(op->op_type, MARK, SP);
+ SP = MARK;
+ if (anum == -1)
+ RETSETUNDEF;
+ if (anum != 0) {
+ PUSHi(anum);
+ }
+ else {
+ PUSHp("0 but true",10);
+ }
+ RETURN;
+#else
+ pp_semget(ARGS);
+#endif
+}
+
+PP(pp_semop)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ dSP; dMARK; dTARGET;
+ I32 value = (I32)(do_semop(MARK, SP) >= 0);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ pp_semget(ARGS);
+#endif
+}
+
+/* Eval. */
+
+static void
+save_lines(array, sv)
+AV *array;
+SV *sv;
+{
+ register char *s = SvPV(sv);
+ register char *send = SvPV(sv) + SvCUR(sv);
+ register char *t;
+ register I32 line = 1;
+
+ while (s && s < send) {
+ SV *tmpstr = NEWSV(85,0);
+
+ t = index(s, '\n');
+ if (t)
+ t++;
+ else
+ t = send;
+
+ sv_setpvn(tmpstr, s, t - s);
+ av_store(array, line++, tmpstr);
+ s = t;
+ }
+}
+
+OP *
+doeval()
+{
+ dSP;
+ OP *saveop = op;
+ HV *newstash;
+
+ in_eval = 1;
+ reinit_lexer();
+
+ /* set up a scratch pad */
+
+ SAVEINT(padix);
+ SAVESPTR(curpad);
+ SAVESPTR(comppad);
+ comppad = newAV();
+ av_push(comppad, Nullsv);
+ curpad = AvARRAY(comppad);
+ padix = 0;
+
+ /* make sure we compile in the right package */
+
+ newstash = curcop->cop_stash;
+ if (curstash != newstash) {
+ SAVESPTR(curstash);
+ curstash = newstash;
+ }
+
+ /* try to compile it */
+
+ eval_root = Nullop;
+ error_count = 0;
+ curcop = &compiling;
+ if (yyparse() || error_count || !eval_root) {
+ SV **newsp;
+ I32 gimme;
+ CONTEXT *cx;
+ I32 optype;
+
+ op = saveop;
+ POPBLOCK(cx);
+ POPEVAL(cx);
+ pop_return();
+ LEAVE;
+ if (eval_root) {
+ op_free(eval_root);
+ eval_root = Nullop;
+ }
+ if (optype == OP_REQUIRE)
+ DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
+ RETPUSHUNDEF;
+ }
+ compiling.cop_line = 0;
+
+ DEBUG_x(dump_eval(eval_root, eval_start));
+
+ /* compiled okay, so do it */
+
+ sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
+ RETURNOP(eval_start);
+}
+
+PP(pp_require)
+{
+ dSP;
+ register CONTEXT *cx;
+ dPOPss;
+ char *name = SvPVn(sv);
+ char *tmpname;
+ SV** svp;
+ I32 gimme = G_SCALAR;
+
+ if (op->op_type == OP_REQUIRE &&
+ (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
+ *svp != &sv_undef)
+ RETPUSHYES;
+
+ /* prepare to compile file */
+
+ sv_setpv(linestr,"");
+
+ tmpname = savestr(name);
+ if (*tmpname == '/' ||
+ (*tmpname == '.' &&
+ (tmpname[1] == '/' ||
+ (tmpname[1] == '.' && tmpname[2] == '/'))))
+ {
+ rsfp = fopen(tmpname,"r");
+ }
+ else {
+ AV *ar = GvAVn(incgv);
+ I32 i;
+
+ for (i = 0; i <= AvFILL(ar); i++) {
+ (void)sprintf(buf, "%s/%s", SvPVnx(*av_fetch(ar, i, TRUE)), name);
+ rsfp = fopen(buf, "r");
+ if (rsfp) {
+ char *s = buf;
+
+ if (*s == '.' && s[1] == '/')
+ s += 2;
+ Safefree(tmpname);
+ tmpname = savestr(s);
+ break;
+ }
+ }
+ }
+ compiling.cop_filegv = gv_fetchfile(tmpname);
+ Safefree(tmpname);
+ tmpname = Nullch;
+ if (!rsfp) {
+ if (op->op_type == OP_REQUIRE) {
+ sprintf(tokenbuf,"Can't locate %s in @INC", name);
+ if (instr(tokenbuf,".h "))
+ strcat(tokenbuf," (change .h to .ph maybe?)");
+ if (instr(tokenbuf,".ph "))
+ strcat(tokenbuf," (did you run h2ph?)");
+ DIE("%s",tokenbuf);
+ }
+
+ RETPUSHUNDEF;
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ /* switch to eval mode */
+
+ push_return(op->op_next);
+ PUSHBLOCK(cx,CXt_EVAL,SP);
+ PUSHEVAL(cx,savestr(name));
+
+ if (curcop->cop_line == 0) /* don't debug debugger... */
+ perldb = FALSE;
+ compiling.cop_line = 0;
+
+ PUTBACK;
+ return doeval();
+}
+
+PP(pp_dofile)
+{
+ return pp_require(ARGS);
+}
+
+PP(pp_entereval)
+{
+ dSP;
+ register CONTEXT *cx;
+ dPOPss;
+ I32 gimme = GIMME;
+
+ ENTER;
+ SAVETMPS;
+
+ /* switch to eval mode */
+
+ push_return(op->op_next);
+ PUSHBLOCK(cx,CXt_EVAL,SP);
+ PUSHEVAL(cx,0);
+
+ /* prepare to compile string */
+
+ save_item(linestr);
+ sv_setsv(linestr, sv);
+ sv_catpv(linestr, "\n;");
+ compiling.cop_filegv = gv_fetchfile("(eval)");
+ compiling.cop_line = 1;
+ if (perldb)
+ save_lines(GvAV(curcop->cop_filegv), linestr);
+ PUTBACK;
+ return doeval();
+}
+
+PP(pp_leaveeval)
+{
+ dSP;
+ register SV **mark;
+ SV **newsp;
+ I32 gimme;
+ register CONTEXT *cx;
+ OP *retop;
+ I32 optype;
+ OP *eroot = eval_root;
+
+ POPBLOCK(cx);
+ POPEVAL(cx);
+ retop = pop_return();
+
+ if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP)
+ *MARK = sv_mortalcopy(TOPs);
+ else {
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
+ }
+ SP = MARK;
+ }
+ else {
+ for (mark = newsp + 1; mark <= SP; mark++)
+ *mark = sv_mortalcopy(*mark);
+ /* in case LEAVE wipes old return values */
+ }
+
+ if (optype != OP_ENTEREVAL) {
+ char *name = cx->blk_eval.old_name;
+
+ if (gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp) {
+ (void)hv_store(GvHVn(incgv), name,
+ strlen(name), newSVsv(GvSV(curcop->cop_filegv)), 0 );
+ }
+ else if (optype == OP_REQUIRE)
+ retop = die("%s did not return a true value", name);
+ Safefree(name);
+ }
+ op_free(eroot);
+ av_free(comppad);
+
+ LEAVE;
+ sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
+
+ RETURNOP(retop);
+}
+
+PP(pp_evalonce)
+{
+ dSP;
+#ifdef NOTDEF
+ SP = do_eval(st[1], OP_EVAL, curcop->cop_stash, TRUE,
+ GIMME, arglast);
+ if (eval_root) {
+ sv_free(cSVOP->op_sv);
+ op[1].arg_ptr.arg_cmd = eval_root;
+ op[1].op_type = (A_CMD|A_DONT);
+ op[0].op_type = OP_TRY;
+ }
+ RETURN;
+
+#endif
+ RETURN;
+}
+
+PP(pp_entertry)
+{
+ dSP;
+ register CONTEXT *cx;
+ I32 gimme = GIMME;
+
+ ENTER;
+ SAVETMPS;
+
+ push_return(cLOGOP->op_other->op_next);
+ PUSHBLOCK(cx,CXt_EVAL,SP);
+ PUSHEVAL(cx,0);
+
+ in_eval = 1;
+ sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
+ RETURN;
+}
+
+PP(pp_leavetry)
+{
+ dSP;
+ register SV **mark;
+ SV **newsp;
+ I32 gimme;
+ register CONTEXT *cx;
+ I32 optype;
+
+ POPBLOCK(cx);
+ POPEVAL(cx);
+ pop_return();
+
+ if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP)
+ *MARK = sv_mortalcopy(TOPs);
+ else {
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
+ }
+ SP = MARK;
+ }
+ else {
+ for (mark = newsp + 1; mark <= SP; mark++)
+ *mark = sv_mortalcopy(*mark);
+ /* in case LEAVE wipes old return values */
+ }
+
+ LEAVE;
+ sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
+ RETURN;
+}
+
+/* Get system info. */
+
+PP(pp_ghbyname)
+{
+#ifdef HAS_SOCKET
+ return pp_ghostent(ARGS);
+#else
+ DIE(no_sock_func, "gethostbyname");
+#endif
+}
+
+PP(pp_ghbyaddr)
+{
+#ifdef HAS_SOCKET
+ return pp_ghostent(ARGS);
+#else
+ DIE(no_sock_func, "gethostbyaddr");
+#endif
+}
+
+PP(pp_ghostent)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ I32 which = op->op_type;
+ register char **elem;
+ register SV *sv;
+ struct hostent *gethostbyname();
+ struct hostent *gethostbyaddr();
+#ifdef HAS_GETHOSTENT
+ struct hostent *gethostent();
+#endif
+ struct hostent *hent;
+ unsigned long len;
+
+ EXTEND(SP, 10);
+ if (which == OP_GHBYNAME) {
+ hent = gethostbyname(POPp);
+ }
+ else if (which == OP_GHBYADDR) {
+ int addrtype = POPi;
+ SV *addrstr = POPs;
+ char *addr = SvPVn(addrstr);
+
+ hent = gethostbyaddr(addr, SvCUR(addrstr), addrtype);
+ }
+ else
+#ifdef HAS_GETHOSTENT
+ hent = gethostent();
+#else
+ DIE("gethostent not implemented");
+#endif
+
+#ifdef HOST_NOT_FOUND
+ if (!hent)
+ statusvalue = (U16)h_errno & 0xffff;
+#endif
+
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (hent) {
+ if (which == OP_GHBYNAME) {
+ sv_setpvn(sv, hent->h_addr, hent->h_length);
+ }
+ else
+ sv_setpv(sv, hent->h_name);
+ }
+ RETURN;
+ }
+
+ if (hent) {
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, hent->h_name);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ for (elem = hent->h_aliases; *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setiv(sv, (I32)hent->h_addrtype);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ len = hent->h_length;
+ sv_setiv(sv, (I32)len);
+#ifdef h_addr
+ for (elem = hent->h_addr_list; *elem; elem++) {
+ XPUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpvn(sv, *elem, len);
+ }
+#else
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpvn(sv, hent->h_addr, len);
+#endif /* h_addr */
+ }
+ RETURN;
+#else
+ DIE(no_sock_func, "gethostent");
+#endif
+}
+
+PP(pp_gnbyname)
+{
+#ifdef HAS_SOCKET
+ return pp_gnetent(ARGS);
+#else
+ DIE(no_sock_func, "getnetbyname");
+#endif
+}
+
+PP(pp_gnbyaddr)
+{
+#ifdef HAS_SOCKET
+ return pp_gnetent(ARGS);
+#else
+ DIE(no_sock_func, "getnetbyaddr");
+#endif
+}
+
+PP(pp_gnetent)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ I32 which = op->op_type;
+ register char **elem;
+ register SV *sv;
+ struct netent *getnetbyname();
+ struct netent *getnetbyaddr();
+ struct netent *getnetent();
+ struct netent *nent;
+
+ if (which == OP_GNBYNAME)
+ nent = getnetbyname(POPp);
+ else if (which == OP_GNBYADDR) {
+ int addrtype = POPi;
+ unsigned long addr = U_L(POPn);
+ nent = getnetbyaddr((long)addr, addrtype);
+ }
+ else
+ nent = getnetent();
+
+ EXTEND(SP, 4);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (nent) {
+ if (which == OP_GNBYNAME)
+ sv_setiv(sv, (I32)nent->n_net);
+ else
+ sv_setpv(sv, nent->n_name);
+ }
+ RETURN;
+ }
+
+ if (nent) {
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, nent->n_name);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ for (elem = nent->n_aliases; *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setiv(sv, (I32)nent->n_addrtype);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setiv(sv, (I32)nent->n_net);
+ }
+
+ RETURN;
+#else
+ DIE(no_sock_func, "getnetent");
+#endif
+}
+
+PP(pp_gpbyname)
+{
+#ifdef HAS_SOCKET
+ return pp_gprotoent(ARGS);
+#else
+ DIE(no_sock_func, "getprotobyname");
+#endif
+}
+
+PP(pp_gpbynumber)
+{
+#ifdef HAS_SOCKET
+ return pp_gprotoent(ARGS);
+#else
+ DIE(no_sock_func, "getprotobynumber");
+#endif
+}
+
+PP(pp_gprotoent)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ I32 which = op->op_type;
+ register char **elem;
+ register SV *sv;
+ struct protoent *getprotobyname();
+ struct protoent *getprotobynumber();
+ struct protoent *getprotoent();
+ struct protoent *pent;
+
+ if (which == OP_GPBYNAME)
+ pent = getprotobyname(POPp);
+ else if (which == OP_GPBYNUMBER)
+ pent = getprotobynumber(POPi);
+ else
+ pent = getprotoent();
+
+ EXTEND(SP, 3);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (pent) {
+ if (which == OP_GPBYNAME)
+ sv_setiv(sv, (I32)pent->p_proto);
+ else
+ sv_setpv(sv, pent->p_name);
+ }
+ RETURN;
+ }
+
+ if (pent) {
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, pent->p_name);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ for (elem = pent->p_aliases; *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setiv(sv, (I32)pent->p_proto);
+ }
+
+ RETURN;
+#else
+ DIE(no_sock_func, "getprotoent");
+#endif
+}
+
+PP(pp_gsbyname)
+{
+#ifdef HAS_SOCKET
+ return pp_gservent(ARGS);
+#else
+ DIE(no_sock_func, "getservbyname");
+#endif
+}
+
+PP(pp_gsbyport)
+{
+#ifdef HAS_SOCKET
+ return pp_gservent(ARGS);
+#else
+ DIE(no_sock_func, "getservbyport");
+#endif
+}
+
+PP(pp_gservent)
+{
+ dSP;
+#ifdef HAS_SOCKET
+ I32 which = op->op_type;
+ register char **elem;
+ register SV *sv;
+ struct servent *getservbyname();
+ struct servent *getservbynumber();
+ struct servent *getservent();
+ struct servent *sent;
+
+ if (which == OP_GSBYNAME) {
+ char *proto = POPp;
+ char *name = POPp;
+
+ if (proto && !*proto)
+ proto = Nullch;
+
+ sent = getservbyname(name, proto);
+ }
+ else if (which == OP_GSBYPORT) {
+ char *proto = POPp;
+ int port = POPi;
+
+ sent = getservbyport(port, proto);
+ }
+ else
+ sent = getservent();
+
+ EXTEND(SP, 4);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (sent) {
+ if (which == OP_GSBYNAME) {
+#ifdef HAS_NTOHS
+ sv_setiv(sv, (I32)ntohs(sent->s_port));
+#else
+ sv_setiv(sv, (I32)(sent->s_port));
+#endif
+ }
+ else
+ sv_setpv(sv, sent->s_name);
+ }
+ RETURN;
+ }
+
+ if (sent) {
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, sent->s_name);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ for (elem = sent->s_aliases; *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+#ifdef HAS_NTOHS
+ sv_setiv(sv, (I32)ntohs(sent->s_port));
+#else
+ sv_setiv(sv, (I32)(sent->s_port));
+#endif
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, sent->s_proto);
+ }
+
+ RETURN;
+#else
+ DIE(no_sock_func, "getservent");
+#endif
+}
+
+PP(pp_shostent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ SETi( sethostent(TOPi) );
+ RETURN;
+#else
+ DIE(no_sock_func, "sethostent");
+#endif
+}
+
+PP(pp_snetent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ SETi( setnetent(TOPi) );
+ RETURN;
+#else
+ DIE(no_sock_func, "setnetent");
+#endif
+}
+
+PP(pp_sprotoent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ SETi( setprotoent(TOPi) );
+ RETURN;
+#else
+ DIE(no_sock_func, "setprotoent");
+#endif
+}
+
+PP(pp_sservent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ SETi( setservent(TOPi) );
+ RETURN;
+#else
+ DIE(no_sock_func, "setservent");
+#endif
+}
+
+PP(pp_ehostent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ XPUSHi( endhostent() );
+ RETURN;
+#else
+ DIE(no_sock_func, "endhostent");
+#endif
+}
+
+PP(pp_enetent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ XPUSHi( endnetent() );
+ RETURN;
+#else
+ DIE(no_sock_func, "endnetent");
+#endif
+}
+
+PP(pp_eprotoent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ XPUSHi( endprotoent() );
+ RETURN;
+#else
+ DIE(no_sock_func, "endprotoent");
+#endif
+}
+
+PP(pp_eservent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ XPUSHi( endservent() );
+ RETURN;
+#else
+ DIE(no_sock_func, "endservent");
+#endif
+}
+
+PP(pp_gpwnam)
+{
+#ifdef HAS_PASSWD
+ return pp_gpwent(ARGS);
+#else
+ DIE(no_func, "getpwnam");
+#endif
+}
+
+PP(pp_gpwuid)
+{
+#ifdef HAS_PASSWD
+ return pp_gpwent(ARGS);
+#else
+ DIE(no_func, "getpwuid");
+#endif
+}
+
+PP(pp_gpwent)
+{
+ dSP;
+#ifdef HAS_PASSWD
+ I32 which = op->op_type;
+ register AV *ary = stack;
+ register SV *sv;
+ struct passwd *getpwnam();
+ struct passwd *getpwuid();
+ struct passwd *getpwent();
+ struct passwd *pwent;
+
+ if (which == OP_GPWNAM)
+ pwent = getpwnam(POPp);
+ else if (which == OP_GPWUID)
+ pwent = getpwuid(POPi);
+ else
+ pwent = getpwent();
+
+ EXTEND(SP, 10);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (pwent) {
+ if (which == OP_GPWNAM)
+ sv_setiv(sv, (I32)pwent->pw_uid);
+ else
+ sv_setpv(sv, pwent->pw_name);
+ }
+ RETURN;
+ }
+
+ if (pwent) {
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, pwent->pw_name);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, pwent->pw_passwd);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setiv(sv, (I32)pwent->pw_uid);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setiv(sv, (I32)pwent->pw_gid);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+#ifdef PWCHANGE
+ sv_setiv(sv, (I32)pwent->pw_change);
+#else
+#ifdef PWQUOTA
+ sv_setiv(sv, (I32)pwent->pw_quota);
+#else
+#ifdef PWAGE
+ sv_setpv(sv, pwent->pw_age);
+#endif
+#endif
+#endif
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+#ifdef PWCLASS
+ sv_setpv(sv, pwent->pw_class);
+#else
+#ifdef PWCOMMENT
+ sv_setpv(sv, pwent->pw_comment);
+#endif
+#endif
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, pwent->pw_gecos);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, pwent->pw_dir);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, pwent->pw_shell);
+#ifdef PWEXPIRE
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setiv(sv, (I32)pwent->pw_expire);
+#endif
+ }
+ RETURN;
+#else
+ DIE(no_func, "getpwent");
+#endif
+}
+
+PP(pp_spwent)
+{
+ dSP; dTARGET;
+#ifdef HAS_PASSWD
+ setpwent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "setpwent");
+#endif
+}
+
+PP(pp_epwent)
+{
+ dSP; dTARGET;
+#ifdef HAS_PASSWD
+ endpwent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "endpwent");
+#endif
+}
+
+PP(pp_ggrnam)
+{
+#ifdef HAS_GROUP
+ return pp_ggrent(ARGS);
+#else
+ DIE(no_func, "getgrnam");
+#endif
+}
+
+PP(pp_ggrgid)
+{
+#ifdef HAS_GROUP
+ return pp_ggrent(ARGS);
+#else
+ DIE(no_func, "getgrgid");
+#endif
+}
+
+PP(pp_ggrent)
+{
+ dSP;
+#ifdef HAS_GROUP
+ I32 which = op->op_type;
+ register char **elem;
+ register SV *sv;
+ struct group *getgrnam();
+ struct group *getgrgid();
+ struct group *getgrent();
+ struct group *grent;
+
+ if (which == OP_GGRNAM)
+ grent = getgrnam(POPp);
+ else if (which == OP_GGRGID)
+ grent = getgrgid(POPi);
+ else
+ grent = getgrent();
+
+ EXTEND(SP, 4);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (grent) {
+ if (which == OP_GGRNAM)
+ sv_setiv(sv, (I32)grent->gr_gid);
+ else
+ sv_setpv(sv, grent->gr_name);
+ }
+ RETURN;
+ }
+
+ if (grent) {
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, grent->gr_name);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpv(sv, grent->gr_passwd);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setiv(sv, (I32)grent->gr_gid);
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ for (elem = grent->gr_mem; *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ }
+
+ RETURN;
+#else
+ DIE(no_func, "getgrent");
+#endif
+}
+
+PP(pp_sgrent)
+{
+ dSP; dTARGET;
+#ifdef HAS_GROUP
+ setgrent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "setgrent");
+#endif
+}
+
+PP(pp_egrent)
+{
+ dSP; dTARGET;
+#ifdef HAS_GROUP
+ endgrent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "endgrent");
+#endif
+}
+
+PP(pp_getlogin)
+{
+ dSP; dTARGET;
+#ifdef HAS_GETLOGIN
+ char *tmps;
+ EXTEND(SP, 1);
+ if (!(tmps = getlogin()))
+ RETPUSHUNDEF;
+ PUSHp(tmps, strlen(tmps));
+ RETURN;
+#else
+ DIE(no_func, "getlogin");
+#endif
+}
+
+/* Miscellaneous. */
+
+PP(pp_syscall)
+{
+#ifdef HAS_SYSCALL
+ dSP; dMARK; dORIGMARK; dTARGET;
+ register I32 items = SP - MARK;
+ unsigned long a[20];
+ register I32 i = 0;
+ I32 retval = -1;
+
+#ifdef TAINT
+ while (++MARK <= SP)
+ TAINT_IF((*MARK)->sv_tainted);
+ MARK = ORIGMARK;
+ TAINT_PROPER("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 (++MARK <= SP) {
+ if (SvNIOK(*MARK) || !i)
+ a[i++] = SvIVn(*MARK);
+ else
+ a[i++] = (unsigned long)SvPV(*MARK);
+ if (i > 15)
+ break;
+ }
+ switch (items) {
+ default:
+ DIE("Too many args to syscall");
+ case 0:
+ DIE("Too few args to syscall");
+ case 1:
+ retval = syscall(a[0]);
+ break;
+ case 2:
+ retval = syscall(a[0],a[1]);
+ break;
+ case 3:
+ retval = syscall(a[0],a[1],a[2]);
+ break;
+ case 4:
+ retval = syscall(a[0],a[1],a[2],a[3]);
+ break;
+ case 5:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4]);
+ break;
+ case 6:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
+ break;
+ case 7:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
+ break;
+ case 8:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
+ break;
+#ifdef atarist
+ case 9:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
+ break;
+ case 10:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
+ break;
+ case 11:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
+ a[10]);
+ break;
+ case 12:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
+ a[10],a[11]);
+ break;
+ case 13:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
+ a[10],a[11],a[12]);
+ break;
+ case 14:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
+ a[10],a[11],a[12],a[13]);
+ break;
+#endif /* atarist */
+ }
+ SP = ORIGMARK;
+ PUSHi(retval);
+ RETURN;
+#else
+ DIE(no_func, "syscall");
+#endif
+}
--- /dev/null
+/***********************************************************
+ *
+ * $Header: /usr/src/local/lwall/perl5/RCS/pp.h,v 4.1 92/08/07 18:26:20 lwall Exp Locker: lwall $
+ *
+ * Description:
+ * Push/Pop code defs.
+ *
+ * Standards:
+ *
+ * Created:
+ * Mon Jun 15 16:47:20 1992
+ *
+ * Author:
+ * Larry Wall <lwall@netlabs.com>
+ *
+ * $Log: pp.h,v $
+ * Revision 4.1 92/08/07 18:26:20 lwall
+ *
+ *
+ **********************************************************/
+
+#define ARGS
+#define ARGSproto
+#define dARGS
+#define PP(s) OP* s(ARGS) dARGS
+
+#define SP sp
+#define MARK mark
+#define TARG targ
+
+#define POPMARK (*markstack_ptr--)
+#define dSP register SV **sp = stack_sp
+#define dMARK register SV **mark = stack_base + POPMARK
+#define dORIGMARK I32 origmark = mark - stack_base
+#define SETORIGMARK origmark = mark - stack_base
+#define ORIGMARK stack_base + origmark
+
+#define SPAGAIN sp = stack_sp
+#define MSPAGAIN sp = stack_sp; mark = ORIGMARK
+
+#define GETTARGETSTACKED targ = (op->op_flags & OPf_STACKED ? POPs : PAD_SV(op->op_targ))
+#define dTARGETSTACKED SV * GETTARGETSTACKED
+
+#define GETTARGET targ = PAD_SV(op->op_targ)
+#define dTARGET SV * GETTARGET
+
+#define GETATARGET targ = (op->op_flags & OPf_STACKED ? sp[-1] : PAD_SV(op->op_targ))
+#define dATARGET SV * GETATARGET
+
+#define dTARG SV *targ
+
+#define GETavn(a,g,st) \
+ a = sv_2av(cGVOP->op_gv ? (SV*)cGVOP->op_gv : POPs, &st, &g, 1)
+#define GEThvn(h,g,st) \
+ h = sv_2hv(cGVOP->op_gv ? (SV*)cGVOP->op_gv : POPs, &st, &g, 1)
+#define GETav(a,g,st) \
+ a = sv_2av(cGVOP->op_gv ? (SV*)cGVOP->op_gv : POPs, &st, &g, 0)
+#define GEThv(h,g,st) \
+ h = sv_2hv(cGVOP->op_gv ? (SV*)cGVOP->op_gv : POPs, &st, &g, 0)
+#define GETcv(r,g,st) \
+ r = sv_2cv(POPs, &st, &g, 0)
+
+#define NORMAL op->op_next
+#define DIE return die
+#define PROP if (dying) return die("%s", dying);
+
+#define PUTBACK stack_sp = sp
+#define RETURN return PUTBACK, NORMAL
+#define RETURNOP(o) return PUTBACK, o
+#define RETURNX(x) return x, PUTBACK, NORMAL
+
+#define POPs (*sp--)
+#define POPp (SvPVnx(POPs))
+#define POPn (SvNVnx(POPs))
+#define POPi ((int)SvIVnx(POPs))
+#define POPl ((long)SvIVnx(POPs))
+
+#define TOPs (*sp)
+#define TOPp (SvPVn(TOPs))
+#define TOPn (SvNVn(TOPs))
+#define TOPi ((int)SvIVn(TOPs))
+#define TOPl ((long)SvNVn(TOPs))
+
+/* Go to some pains in the rare event that we must extend the stack. */
+#define EXTEND(p,n) do { if (stack_max - p < (n)) { \
+ av_fill(stack, (p - stack_base) + (n)); \
+ sp = AvARRAY(stack) + (sp - stack_base); \
+ stack_base = AvARRAY(stack); \
+ stack_max = stack_base + AvMAX(stack); \
+ } } while (0)
+/* Same thing, but update mark register too. */
+#define MEXTEND(p,n) do {if (stack_max - p < (n)) { \
+ av_fill(stack, (p - stack_base) + (n)); \
+ sp = AvARRAY(stack) + (sp - stack_base); \
+ mark = AvARRAY(stack) + (mark - stack_base); \
+ stack_base = AvARRAY(stack); \
+ stack_max = stack_base + AvMAX(stack); \
+ } } while (0)
+
+#define PUSHs(s) (*++sp = (s))
+#define PUSHTARG do { SvSETMAGIC(TARG); PUSHs(TARG); } while (0)
+#define PUSHp(p,l) do { sv_setpvn(TARG, (p), (l)); PUSHTARG; } while (0)
+#define PUSHn(n) do { sv_setnv(TARG, (n)); PUSHTARG; } while (0)
+#define PUSHi(i) do { sv_setiv(TARG, (i)); PUSHTARG; } while (0)
+
+#define XPUSHs(s) do { EXTEND(sp,1); (*++sp = (s)); } while (0)
+#define XPUSHTARG do { SvSETMAGIC(TARG); XPUSHs(TARG); } while (0)
+#define XPUSHp(p,l) do { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } while (0)
+#define XPUSHn(n) do { sv_setnv(TARG, (n)); XPUSHTARG; } while (0)
+#define XPUSHi(i) do { sv_setiv(TARG, (i)); XPUSHTARG; } while (0)
+
+#define MXPUSHs(s) do { MEXTEND(sp,1); (*++sp = (s)); } while (0)
+#define MXPUSHTARG do { SvSETMAGIC(TARG); XPUSHs(TARG); } while (0)
+#define MXPUSHp(p,l) do { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } while (0)
+#define MXPUSHn(n) do { sv_setnv(TARG, (n)); XPUSHTARG; } while (0)
+#define MXPUSHi(i) do { sv_setiv(TARG, (i)); XPUSHTARG; } while (0)
+
+#define SETs(s) (*sp = s)
+#define SETTARG do { SvSETMAGIC(TARG); SETs(TARG); } while (0)
+#define SETp(p,l) do { sv_setpvn(TARG, (p), (l)); SETTARG; } while (0)
+#define SETn(n) do { sv_setnv(TARG, (n)); SETTARG; } while (0)
+#define SETi(i) do { sv_setiv(TARG, (i)); SETTARG; } while (0)
+
+#define dTOPss SV *sv = TOPs
+#define dPOPss SV *sv = POPs
+#define dTOPnv double value = TOPn
+#define dPOPnv double value = POPn
+#define dTOPiv I32 value = TOPi
+#define dPOPiv I32 value = POPi
+
+#define dPOPPOPssrl SV *rstr = POPs; SV *lstr = POPs
+#define dPOPPOPnnrl double right = POPn; double left = POPn
+#define dPOPPOPiirl I32 right = POPi; I32 left = POPi
+
+#define dPOPTOPssrl SV *rstr = POPs; SV *lstr = TOPs
+#define dPOPTOPnnrl double right = POPn; double left = TOPn
+#define dPOPTOPiirl I32 right = POPi; I32 left = TOPi
+
+#define RETPUSHYES RETURNX(PUSHs(&sv_yes))
+#define RETPUSHNO RETURNX(PUSHs(&sv_no))
+#define RETPUSHUNDEF RETURNX(PUSHs(&sv_undef))
+
+#define RETSETYES RETURNX(SETs(&sv_yes))
+#define RETSETNO RETURNX(SETs(&sv_no))
+#define RETSETUNDEF RETURNX(SETs(&sv_undef))
+
+#define ARGTARG op->op_targ
+#define MAXARG op->op_private
+
+#define SWITCHSTACK(f,t) AvFILL(f) = sp - stack_base; \
+ stack_base = AvARRAY(t); \
+ stack_max = stack_base + AvMAX(t); \
+ sp = stack_base + AvFILL(t); \
+ stack = t;
+
+/* XXX need to diffentiate on marked operators? */
+#define FETCH_GV(s) PUTBACK, s = fetch_gv(op,1), SPAGAIN
+#define FETCH_GV1(s) PUTBACK, s = fetch_gv(op,1), SPAGAIN
+#define FETCH_GV2(s) PUTBACK, s = fetch_gv(op,2), SPAGAIN
+#define FETCH_IO(s) PUTBACK, s = fetch_io(op,1), SPAGAIN
+#define FETCH_IO1(s) PUTBACK, s = fetch_io(op,1), SPAGAIN
+#define FETCH_IO2(s) PUTBACK, s = fetch_io(op,2), SPAGAIN
+
+#define ENTER push_scope()
+#define LEAVE pop_scope()
+
+#define SAVEINT(i) save_int((int*)(&i));
+#define SAVEI32(i) save_int((I32*)(&i));
+#define SAVELONG(l) save_int((long*)(&l));
+#define SAVESPTR(s) save_sptr((SV**)(&s))
+#define SAVETMPS save_int(&tmps_floor), tmps_floor = tmps_ix
--- /dev/null
+OP * CopDBadd P((OP *cur));
+OP * add_label P((char *lbl, OP *cmd));
+OP * addcond P((OP *cmd, OP *arg));
+OP * addflags P((I32 i, I32 flags, OP *arg));
+OP * addloop P((OP *cmd, OP *arg));
+OP * append_elem P((I32 optype, OP *head, OP *tail));
+OP * append_list P((I32 optype, OP *head, OP *tail));
+I32 apply P((I32 type, SV **mark, SV **sp));
+void av_clear P((AV *ar));
+AV * av_fake P((I32 size, SV **strp));
+SV ** av_fetch P((AV *ar, I32 key, I32 lval));
+void av_fill P((AV *ar, I32 fill));
+void av_free P((AV *ar));
+I32 av_len P((AV *ar));
+AV * av_make P((I32 size, SV **strp));
+SV * av_pop P((AV *ar));
+void av_popnulls P((AV *ar));
+bool av_push P((AV *ar, SV *val));
+SV * av_shift P((AV *ar));
+SV ** av_store P((AV *ar, I32 key, SV *val));
+void av_undef P((AV *ar));
+void av_unshift P((AV *ar, I32 num));
+OP * bind_match P((I32 type, OP *left, OP *pat));
+OP * block_head P((OP *tail));
+I32 cando P((I32 bit, I32 effective, struct stat *statbufp));
+unsigned long cast_ulong P((double f));
+void checkcomma P((char *s, char *name, char *what));
+I32 chsize P((int fd, off_t length));
+OP * convert P((I32 optype, I32 flags, OP *op));
+OP * cop_to_arg P((OP *cmd));
+I32 copyopt P((OP *cmd, OP *which));
+void cpy7bit P((char *d, char *s, I32 l));
+char * cpytill P((char *to, char *from, char *fromend, I32 delim, I32 *retlen));
+void cryptfilter P((FILE *fil));
+void cryptswitch P((void));
+void deb P((char *pat, ...));
+void deb_growlevel P((void));
+OP * die P((const char* pat, ...));
+OP * die_where P((char *message));
+void do_accept P((SV *sv, GV *ngv, GV *ggv));
+bool do_aexec P((SV *really, SV **mark, SV **sp));
+void do_chop P((SV *astr, SV *sv));
+bool do_close P((GV *gv, bool explicit));
+int do_ctl P((I32 optype, GV *gv, I32 func, SV *argstr));
+bool do_eof P((GV *gv));
+bool do_exec P((char *cmd));
+void do_execfree P((void));
+SV * do_fttext P((OP *arg, SV *sv));
+I32 do_ipcctl P((I32 optype, SV **mark, SV **sp));
+I32 do_ipcget P((I32 optype, SV **mark, SV **sp));
+void do_join P((SV *sv, SV *del, SV **mark, SV **sp));
+OP * do_kv P((SV*,OP*,I32));
+I32 do_msgrcv P((SV **mark, SV **sp));
+I32 do_msgsnd P((SV **mark, SV **sp));
+bool do_open P((GV *gv, char *name, I32 len));
+void do_pipe P((SV *sv, GV *rgv, GV *wgv));
+bool do_print P((SV *sv, FILE *fp));
+I32 do_repeatary P((SV*,OP*,I32));
+bool do_seek P((GV *gv, long pos, int whence));
+I32 do_semop P((SV **mark, SV **sp));
+I32 do_shmio P((I32 optype, SV **mark, SV **sp));
+void do_sprintf P((SV *sv, int len, SV **sarg));
+OP * do_subr P((void));
+long do_tell P((GV *gv));
+I32 do_trans P((SV *sv, OP *arg));
+void do_vecset P((SV *sv));
+void do_vop P((I32 optype, SV *sv, SV *left, SV *right));
+void do_write P((struct Outrec *orec, GV *gv));
+void dump_all P((void));
+void dump_cop P((OP *cmd, OP *alt));
+void dump_eval P((OP *root, OP *start));
+ dump_fds P((char *s));
+void dump_flags P((char *b, U32 flags));
+void dump_gv P((GV *gv));
+void dump_op P((OP *arg));
+void dump_pm P((PM *pm));
+ dup2 P((int oldfd, int newfd));
+void fbm_compile P((SV *sv, I32 iflag));
+char * fbm_instr P((unsigned char *big, unsigned char *bigend, SV *littlestr));
+IO * fetch_io P((OP* op, I32 num));
+GV * fetch_gv P((OP* op, I32 num));
+OP * flatten P((OP *arg));
+void force_ident P((char *s));
+char * force_word P((char *s));
+OP * forcelist P((OP *arg));
+void free_tmps P((void));
+OP * gen_constant_list P((OP *op));
+I32 getgimme P((OP*op));
+void gp_free P((GV* gv));
+GP * gp_ref P((GP* gp));
+GV * gv_AVadd P((GV *gv));
+GV * gv_HVadd P((GV *gv));
+void gv_check P((I32 min, I32 max));
+void gv_efullname P((SV *sv, GV *gv));
+GV * gv_fetchfile P((char *name));
+GV * gv_fetchmethod P((HV* stash, char *name));
+GV * gv_fetchpv P((char *name, I32 add));
+void gv_fullname P((SV *sv, GV *gv));
+STRLEN gv_len P((SV *sv));
+SV * gv_str P((SV *sv));
+OP * gv_to_op P((I32 atype, GV *gv));
+void he_delayfree P((HE *hent));
+void he_free P((HE *hent));
+void hoistmust P((PM *pm));
+void hv_clear P((HV *tb, I32 dodbm));
+void hv_dbmclose P((HV *tb));
+bool hv_dbmopen P((HV *tb, char *fname, int mode));
+bool hv_dbmstore P((HV *tb, char *key, U32 klen, SV *sv));
+SV * hv_delete P((HV *tb, char *key, U32 klen));
+SV ** hv_fetch P((HV *tb, char *key, U32 klen, I32 lval));
+void hv_free P((HV *tb, I32 dodbm));
+I32 hv_iterinit P((HV *tb));
+char * hv_iterkey P((HE *entry, I32 *retlen));
+HE * hv_iternext P((HV *tb));
+SV * hv_iterval P((HV *tb, HE *entry));
+void hv_magic P((SV *sv, GV *gv, I32 how));
+SV ** hv_store P((HV *tb, char *key, U32 klen, SV *val, U32 hash));
+void hv_undef P((HV *tb, I32 dodbm));
+I32 ibcmp P((char *a, char *b, I32 len));
+I32 ingroup P((int testgid, I32 effective));
+char * instr P((char *big, char *little));
+OP * invert P((OP *cmd));
+OP * jmaybe P((OP *arg));
+I32 keyword P((char *d));
+void leave_scope P((I32 base));
+OP * linklist P((OP *op));
+OP * list P((OP *o));
+OP * listkids P((OP *o));
+OP * localize P((OP *arg));
+I32 looks_like_number P((SV *sv));
+OP * loopscope P((OP *o));
+I32 lop P((I32 f, char *s));
+int magic_get P((SV* sv, MAGIC* mg));
+int magic_getarylen P((SV* sv, MAGIC* mg));
+int magic_getglob P((SV* sv, MAGIC* mg));
+int magic_getuvar P((SV* sv, MAGIC* mg));
+int magic_set P((SV* sv, MAGIC* mg));
+int magic_setarylen P((SV* sv, MAGIC* mg));
+int magic_setbm P((SV* sv, MAGIC* mg));
+int magic_setdbline P((SV* sv, MAGIC* mg));
+int magic_setdbm P((SV* sv, MAGIC* mg));
+int magic_setenv P((SV* sv, MAGIC* mg));
+int magic_setglob P((SV* sv, MAGIC* mg));
+int magic_setsig P((SV* sv, MAGIC* mg));
+int magic_setsubstr P((SV* sv, MAGIC* mg));
+int magic_setuvar P((SV* sv, MAGIC* mg));
+int magic_setvec P((SV* sv, MAGIC* mg));
+void magicalize P((char *list));
+void magicname P((char *sym, char *name, I32 namlen));
+ main P((int argc, char **argv, char **env));
+MALLOCPTRTYPE * malloc P((MEM_SIZE nbytes));
+OP * maybeforcelist P((I32 optype, OP *arg));
+char * mess P((char *pat, ...));
+int mg_clear P((SV *sv));
+int mg_free P((SV *sv, char type));
+int mg_freeall P((SV *sv));
+int mg_get P((SV *sv));
+U32 mg_len P((SV *sv));
+int mg_set P((SV *sv));
+char * moreswitches P((char *s));
+void mstats P((char *s));
+char * my_bcopy P((char *from, char *to, I32 len));
+char * my_bzero P((char *loc, I32 len));
+void my_exit P((I32 status));
+I32 my_lstat P((OP *arg, SV *sv));
+I32 my_memcmp P((unsigned char *s1, unsigned char *s2, I32 len));
+I32 my_pclose P((FILE *ptr));
+FILE * my_pfiopen P((FILE *fil, VOID (*func)()));
+FILE * my_popen P((char *cmd, char *mode));
+void my_setenv P((char *nam, char *val));
+I32 my_stat P((OP *arg, SV *sv));
+short my_swap P((short s));
+void my_unexec P((void));
+OP * newANONLIST P((OP *op));
+OP * newANONHASH P((OP *op));
+OP * newASSIGNOP P((I32 flags, OP *left, OP *right));
+OP * newBINOP P((I32 optype, I32 flags, OP *left, OP *right));
+OP * newCONDOP P((I32 flags, OP *expr, OP *true, OP *false));
+void newFORM P((OP *name, OP *block));
+OP * newFOROP P((I32 flags, char *label, line_t forline, OP* scalar, OP* expr, OP*block, OP*cont));
+HV * newHV P((U32 lookat));
+OP * newLOGOP P((I32 optype, I32 flags, OP *left, OP *right));
+OP * newLOOPOP P((I32 flags, I32 debuggable, OP *expr, OP *block, OP *cont));
+OP * newMETHOD P((OP *ref, OP* name));
+OP * newNAMEOP P((OP *o));
+OP * newNULLLIST P((void));
+OP * newOP P((I32 optype, I32 flags));
+OP * newRANGE P((I32 flags, OP *left, OP *right));
+OP * newSLICEOP P((I32 flags, OP *subscript, OP *list));
+OP * newSTATEOP P((I32 flags, char *label, OP *o));
+void newSUB P((OP *name, OP *block));
+OP * newUNOP P((I32 optype, I32 flags, OP *child));
+AV * newAV P((void));
+OP * newAVREF P((OP *o));
+OP * newBINOP P((I32 type, I32 flags, OP *first, OP *last));
+OP * newCVREF P((OP *o));
+OP * newGVOP P((I32 type, I32 flags, GV *gv));
+GV * newGVgen P((void));
+OP * newGVREF P((OP *o));
+OP * newHVREF P((OP *o));
+HV * newHV P((U32 lookat));
+IO * newIO P((void));
+OP * newLISTOP P((I32 type, I32 flags, first, last));
+OP * newPMOP P((I32 type, I32 flags));
+OP * newPVOP P((I32 type, I32 flags, PV *pv));
+#ifdef LEAKTEST
+SV * newSV P((I32 x, STRLEN len));
+#else
+SV * newSV P((STRLEN len));
+#endif
+OP * newSVREF P((OP *o));
+OP * newSVOP P((I32 type, I32 flags, SV *sv));
+SV * newSViv P((I32 i));
+SV * newSVnv P((double n));
+SV * newSVpv P((char *s, STRLEN len));
+SV * newSVsv P((SV *old));
+OP * newUNOP P((I32 type, I32 flags, OP *first));
+FILE * nextargv P((GV *gv));
+char * ninstr P((char *big, char *bigend, char *little, char *lend));
+char * nsavestr P((char *sv, I32 len));
+void op_behead P((OP *arg));
+OP * op_fold_const P((OP *arg));
+void op_free P((OP *arg));
+void op_optimize P((OP *cmd, I32 fliporflop, I32 acmd));
+OP * over P((GV *eachgv, OP *cmd));
+PADOFFSET pad_alloc P((void));
+SV * pad_sv P((PADOFFSET po));
+void pad_free P((PADOFFSET po));
+void pad_reset P((void));
+void pad_swipe P((PADOFFSET po));
+OP * parse_list P((SV *sv));
+void peep P((OP *op));
+Interpreter * perl_alloc P((void));
+I32 perl_callback P((char *subname, I32 sp, I32 gimme, I32 hasargs, I32 numargs));
+I32 perl_callv P((char *subname, I32 sp, I32 gimme, char **argv));
+void perl_construct P((Interpreter *sv_interp));
+void perl_destruct P((Interpreter *sv_interp));
+void perl_free P((Interpreter *sv_interp));
+I32 perl_parse P((Interpreter *sv_interp, int argc, char **argv, char **env));
+I32 perl_run P((Interpreter *sv_interp));
+void pidgone P((int pid, int status));
+OP * pmruntime P((OP *pm, OP *expr));
+OP * pop_return P((void));
+OP * prepend_elem P((I32 optype, OP *head, OP *tail));
+void push_return P((OP* op));
+void pv_grow P((char **strptr, I32 *curlen, I32 newlen));
+OP * rcatmaybe P((OP *arg));
+regexp * regcomp P((char *exp, char *xend, I32 fold));
+OP * ref P((OP *op, I32 type));
+OP * refkids P((OP *op, I32 type));
+void regdump P((regexp *r));
+I32 regexec P((regexp *prog, char *stringarg, char *strend, char *strbeg, I32 minend, SV *screamer, I32 safebase));
+void regfree P((struct regexp *r));
+char * regnext P((char *p));
+char * regprop P((char *op));
+void reinit_lexer P((void));
+void repeatcpy P((char *to, char *from, I32 len, I32 count));
+char * rninstr P((char *big, char *bigend, char *little, char *lend));
+void run_format P((struct Outrec *orec, FF *fcmd));
+#ifndef safemalloc
+void safefree P((char *where));
+char * safemalloc P((MEM_SIZE size));
+char * saferealloc P((char *where, unsigned long size));
+#endif
+void safexfree P((char *where));
+char * safexmalloc P((I32 x, MEM_SIZE size));
+char * safexrealloc P((char *where, MEM_SIZE size));
+I32 same_dirent P((char *a, char *b));
+void savestack_grow P((void));
+void save_aptr P((AV **aptr));
+AV * save_ary P((GV *gv));
+HV * save_hash P((GV *gv));
+void save_hptr P((HV **hptr));
+void save_I32 P((I32 *intp));
+void save_int P((int *intp));
+void save_item P((SV *item));
+void save_lines P((AV *array, SV *sv));
+void save_list P((SV **sarg, I32 maxsarg));
+void save_nogv P((GV *gv));
+SV * save_scalar P((GV *gv));
+void save_sptr P((SV **sptr));
+SV * save_svref P((SV **sptr));
+char * savestr P((char *sv));
+OP * sawparens P((OP *o));
+OP * scalar P((OP *o));
+OP * scalarkids P((OP *op));
+OP * scalarseq P((OP *o));
+OP * scalarvoid P((OP *op));
+char * scan_formline P((char *s));
+unsigned long scan_hex P((char *start, I32 len, I32 *retlen));
+char * scan_heredoc P((char *s));
+char * scan_inputsymbol P((char *s));
+char * scan_ident P((char *s, char *send, char *dest));
+char * scan_num P((char *s));
+unsigned long scan_oct P((char *start, I32 len, I32 *retlen));
+char * scan_pat P((char *s));
+void scan_prefix P((PM *pm, char *string, I32 len));
+char * scan_str P((char *start));
+char * scan_subst P((char *start));
+char * scan_trans P((char *start));
+OP * scope P((OP *o));
+char * screaminstr P((SV *bigstr, SV *littlestr));
+I32 setenv_getix P((char *nam));
+char * skipspace P((char *s));
+AV * sv_2av P((SV *sv, STASH **st, GV **gvp, I32 lref));
+CV * sv_2cv P((SV *sv, STASH **st, GV **gvp, I32 lref));
+HV * sv_2hv P((SV *sv, STASH **st, GV **gvp, I32 lref));
+I32 sv_2iv P((SV *sv));
+SV * sv_2mortal P((SV *sv));
+double sv_2nv P((SV *sv));
+char * sv_2pv P((SV *sv));
+char * sv_append_till P((SV *sv, char *from, char *fromend, I32 delim, char *keeplist));
+int sv_backoff P((SV *sv));
+void sv_catpv P((SV *sv, char *ptr));
+void sv_catpvn P((SV *sv, char *ptr, STRLEN len));
+void sv_catsv P((SV *dstr, SV *sstr));
+void sv_chop P((SV *sv, char *ptr));
+void sv_clear P((SV *sv));
+I32 sv_cmp P((SV *str1, SV *str2));
+void sv_dec P((SV *sv));
+I32 sv_eq P((SV *str1, SV *str2));
+void sv_free P((SV *sv));
+char * sv_gets P((SV *sv, FILE *fp, I32 append));
+char * sv_grow P((SV *sv, unsigned long newlen));
+void sv_inc P((SV *sv));
+void sv_insert P((SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen));
+SV * sv_interp P((SV *sv, SV *src, I32 sp));
+void sv_intrpcompile P((SV *src));
+STRLEN sv_len P((SV *sv));
+void sv_magic P((SV *sv, SV *sv, char how, char *name, STRLEN namlen));
+SV * sv_mortalcopy P((SV *oldstr));
+SV * sv_ref P((SV *sv));
+void sv_replace P((SV *sv, SV *nstr));
+void sv_reset P((char *s, HV *stash));
+void sv_setiv P((SV *sv, I32 num));
+void sv_setnv P((SV *sv, double num));
+void sv_setpv P((SV *sv, char *ptr));
+void sv_setpvn P((SV *sv, char *ptr, STRLEN len));
+void sv_setsv P((SV *dstr, SV *sstr));
+void taint_env P((void));
+void taint_proper P((char *f, char *s));
+I32 uni P((I32 f, char *s));
+I32 unlnk P((char *f));
+I32 userinit P((void));
+I32 wait4pid P((int pid, int *statusp, int flags));
+void warn P((const char* pat, ...));
+I32 whichsig P((char *sig));
+void while_io P((OP *cmd));
+OP * wopt P((OP *cmd));
+int yyerror P((char *s));
+int yylex P((void));
+int yyparse P((void));
--- /dev/null
+#!/usr/bin/perl
+
+$/ = "\n{\n";
+
+while (<>) {
+ chop; next unless chop($_) eq "{";
+ s/[^\0]*\n\n//;
+ $* = 1;
+ s/^#.*\n//g;
+ $* = 0;
+ tr/\n/ /;
+ s#\*/#\200#g;
+ s#/\*[^\200]*\200##g;
+ /\b\w+\(/ || next;
+ $funtype = $`;
+ $name = $&;
+ $_ = $';
+ /\)\s*/ || next;
+ $args = $`;
+ $types = $';
+ $args =~ tr/ \t//d;
+ @args = split(/,/,$args);
+ @types = split(/;\s*/, $types);
+ %type = ();
+ foreach $type (@types) {
+ $type =~ /.*\b(\w+)/;
+ $type{$1} = $type;
+ }
+ foreach $arg (@args) {
+ $arg = $type{$arg} || $arg;
+ $arg =~ s/register //;
+ }
+ $funtype =~ s/\* $/*/;
+ $funtype =~ s/^ *//;
+ chop $name;
+ if (@args) {
+ print $funtype, $name, " P((", join(', ', @args), "));\n";
+ }
+ else {
+ print $funtype, $name, " P((void));\n";
+ }
+}
# See the usage message for more. If this isn't enough, read the code.
#
-$RCSID = '$RCSfile: pstruct,v $$Revision: 4.0.1.1 $$Date: 92/06/08 15:19:40 $';
+$RCSID = '$RCSfile: c2ph.SH,v $$Revision: 4.1 $$Date: 92/08/07 17:19:10 $';
######################################################################
--- /dev/null
+'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS
* blame Henry for some of the lack of readability.
*/
-/* $RCSfile: regcomp.c,v $$Revision: 4.0.1.5 $$Date: 92/06/08 15:23:36 $
+/* $RCSfile: regcomp.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:28 $
*
* $Log: regcomp.c,v $
+ * Revision 4.1 92/08/07 18:26:28 lwall
+ *
* Revision 4.0.1.5 92/06/08 15:23:36 lwall
* patch20: Perl now distinguishes overlapped copies from non-overlapped
* patch20: /^stuff/ wrongly assumed an implicit $* == 1
#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? */
-static int regsawback; /* Did we see \1, ...? */
-
-/*
* Forward declarations for regcomp()'s friends.
*/
-STATIC int regcurly();
+STATIC I32 regcurly();
STATIC char *reg();
STATIC char *regbranch();
STATIC char *regpiece();
regcomp(exp,xend,fold)
char *exp;
char *xend;
-int fold;
+I32 fold;
{
register regexp *r;
register char *scan;
- register STR *longish;
- STR *longest;
- register int len;
+ register SV *longish;
+ SV *longest;
+ register I32 len;
register char *first;
- int flags;
- int backish;
- int backest;
- int curback;
- int minlen;
- int sawplus = 0;
- int sawopen = 0;
+ I32 flags;
+ I32 backish;
+ I32 backest;
+ I32 curback;
+ I32 minlen;
+ I32 sawplus = 0;
+ I32 sawopen = 0;
if (exp == NULL)
fatal("NULL regexp argument");
return(NULL);
/* Dig out information for optimizations. */
- r->regstart = Nullstr; /* Worst-case defaults. */
+ r->regstart = Nullsv; /* Worst-case defaults. */
r->reganch = 0;
- r->regmust = Nullstr;
+ r->regmust = Nullsv;
r->regback = -1;
r->regstclass = Nullch;
scan = r->program+1; /* First BRANCH. */
again:
if (OP(first) == EXACTLY) {
r->regstart =
- str_make(OPERAND(first)+1,*OPERAND(first));
- if (r->regstart->str_cur > !(sawstudy|fold))
- fbmcompile(r->regstart,fold);
+ newSVpv(OPERAND(first)+1,*OPERAND(first));
+ if (SvCUR(r->regstart) > !(sawstudy|fold))
+ fbm_compile(r->regstart,fold);
+ else
+ sv_upgrade(r->regstart, SVt_PVBM);
}
else if ((exp = index(simple,OP(first))) && exp > simple)
r->regstclass = first;
if (sawplus && (!sawopen || !regsawback))
r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */
-#ifdef DEBUGGING
- if (debug & 512)
- fprintf(stderr,"first %d next %d offset %d\n",
- OP(first), OP(NEXTOPER(first)), first - scan);
-#endif
+ DEBUG_r(fprintf(stderr,"first %d next %d offset %d\n",
+ OP(first), OP(NEXTOPER(first)), first - scan));
/*
* If there's something expensive in the r.e., find the
* longest literal string that must appear and make it the
* it happens that curback has been invalidated, since the
* earlier string may buy us something the later one won't.]
*/
- longish = str_make("",0);
- longest = str_make("",0);
+ longish = newSVpv("",0);
+ longest = newSVpv("",0);
len = 0;
minlen = 0;
curback = 0;
scan = t;
minlen += *OPERAND(first);
if (curback - backish == len) {
- str_ncat(longish, OPERAND(first)+1,
+ sv_catpvn(longish, OPERAND(first)+1,
*OPERAND(first));
len += *OPERAND(first);
curback += *OPERAND(first);
}
else if (*OPERAND(first) >= len + (curback >= 0)) {
len = *OPERAND(first);
- str_nset(longish, OPERAND(first)+1,len);
+ sv_setpvn(longish, OPERAND(first)+1,len);
backish = curback;
curback += len;
first = regnext(scan);
else if (index(varies,OP(scan))) {
curback = -30000;
len = 0;
- if (longish->str_cur > longest->str_cur) {
- str_sset(longest,longish);
+ if (SvCUR(longish) > SvCUR(longest)) {
+ sv_setsv(longest,longish);
backest = backish;
}
- str_nset(longish,"",0);
+ sv_setpvn(longish,"",0);
if (OP(scan) == PLUS &&
index(simple,OP(NEXTOPER(scan))))
minlen++;
curback++;
minlen++;
len = 0;
- if (longish->str_cur > longest->str_cur) {
- str_sset(longest,longish);
+ if (SvCUR(longish) > SvCUR(longest)) {
+ sv_setsv(longest,longish);
backest = backish;
}
- str_nset(longish,"",0);
+ sv_setpvn(longish,"",0);
}
scan = regnext(scan);
}
/* Prefer earlier on tie, unless we can tail match latter */
- if (longish->str_cur + (OP(first) == EOL) > longest->str_cur) {
- str_sset(longest,longish);
+ if (SvCUR(longish) + (OP(first) == EOL) > SvCUR(longest)) {
+ sv_setsv(longest,longish);
backest = backish;
}
else
- str_nset(longish,"",0);
- if (longest->str_cur
+ sv_setpvn(longish,"",0);
+ if (SvCUR(longest)
&&
(!r->regstart
||
- !fbminstr((unsigned char*) r->regstart->str_ptr,
- (unsigned char *) r->regstart->str_ptr
- + r->regstart->str_cur,
+ !fbm_instr((unsigned char*) SvPV(r->regstart),
+ (unsigned char *) SvPV(r->regstart)
+ + SvCUR(r->regstart),
longest)
)
)
if (backest < 0)
backest = -1;
r->regback = backest;
- if (longest->str_cur
+ if (SvCUR(longest)
> !(sawstudy || fold || OP(first) == EOL) )
- fbmcompile(r->regmust,fold);
- r->regmust->str_u.str_useful = 100;
- if (OP(first) == EOL && longish->str_cur)
- r->regmust->str_pok |= SP_TAIL;
+ fbm_compile(r->regmust,fold);
+ SvUPGRADE(r->regmust, SVt_PVBM);
+ BmUSEFUL(r->regmust) = 100;
+ if (OP(first) == EOL && SvCUR(longish))
+ SvTAIL_on(r->regmust);
}
else {
- str_free(longest);
- longest = Nullstr;
+ sv_free(longest);
+ longest = Nullsv;
}
- str_free(longish);
+ sv_free(longish);
}
r->do_folding = fold;
r->minlen = minlen;
Newz(1002, r->startp, regnpar, char*);
Newz(1002, r->endp, regnpar, char*);
-#ifdef DEBUGGING
- if (debug & 512)
- regdump(r);
-#endif
+ DEBUG_r(regdump(r));
return(r);
}
*/
static char *
reg(paren, flagp)
-int paren; /* Parenthesized? */
-int *flagp;
+I32 paren; /* Parenthesized? */
+I32 *flagp;
{
register char *ret;
register char *br;
register char *ender;
- register int parno;
- int flags;
+ register I32 parno;
+ I32 flags;
*flagp = HASWIDTH; /* Tentatively. */
*/
static char *
regbranch(flagp)
-int *flagp;
+I32 *flagp;
{
register char *ret;
register char *chain;
register char *latest;
- int flags;
+ I32 flags;
*flagp = WORST; /* Tentatively. */
*/
static char *
regpiece(flagp)
-int *flagp;
+I32 *flagp;
{
register char *ret;
register char op;
register char *next;
- int flags;
+ I32 flags;
char *origparse = regparse;
- int orignpar = regnpar;
+ I32 orignpar = regnpar;
char *max;
- int iter;
+ I32 iter;
char ch;
ret = regatom(&flags);
regparse++;
iter = atoi(regparse);
if (flags&SIMPLE) { /* we can do it right after all */
- int tmp;
+ I32 tmp;
reginsert(CURLY, ret);
if (iter > 0)
*/
static char *
regatom(flagp)
-int *flagp;
+I32 *flagp;
{
register char *ret;
- int flags;
+ I32 flags;
*flagp = WORST; /* Tentatively. */
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
{
- int num = atoi(regparse);
+ I32 num = atoi(regparse);
if (num > 9 && num >= regnpar)
goto defchar;
}
break;
default: {
- register int len;
+ register I32 len;
register char ender;
register char *p;
char *oldp;
- int numlen;
+ I32 numlen;
defchar:
ret = regnode(EXACTLY);
p++;
break;
case 'x':
- ender = scanhex(++p, 2, &numlen);
+ ender = scan_hex(++p, 2, &numlen);
p += numlen;
break;
case 'c':
case '5': case '6': case '7': case '8':case '9':
if (*p == '0' ||
(isDIGIT(p[1]) && atoi(p) >= regnpar) ) {
- ender = scanoct(p, 3, &numlen);
+ ender = scan_oct(p, 3, &numlen);
p += numlen;
}
else {
static void
regset(bits,def,c)
char *bits;
-int def;
-register int c;
+I32 def;
+register I32 c;
{
if (regcode == ®dummy)
return;
regclass()
{
register char *bits;
- register int class;
- register int lastclass;
- register int range = 0;
+ register I32 class;
+ register I32 lastclass;
+ register I32 range = 0;
register char *ret;
- register int def;
- int numlen;
+ register I32 def;
+ I32 numlen;
ret = regnode(ANYOF);
if (*regparse == '^') { /* Complement of range. */
class = '\007';
break;
case 'x':
- class = scanhex(regparse, 2, &numlen);
+ class = scan_hex(regparse, 2, &numlen);
regparse += numlen;
break;
case 'c':
break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
- class = scanoct(--regparse, 3, &numlen);
+ class = scan_oct(--regparse, 3, &numlen);
regparse += numlen;
break;
}
{
register char *scan;
register char *temp;
- register int offset;
+ register I32 offset;
if (p == ®dummy)
return;
/*
- regcurly - a little FSA that accepts {\d+,?\d*}
*/
-STATIC int
+STATIC I32
regcurly(s)
register char *s;
{
/* Literal string, where present. */
s++;
while (*s != '\0') {
- (void)putchar(*s);
+ (void)putc(*s, stderr);
s++;
}
s++;
}
- (void)putchar('\n');
+ (void)putc('\n', stderr);
}
/* Header fields of interest. */
if (r->regstart)
- fprintf(stderr,"start `%s' ", r->regstart->str_ptr);
+ fprintf(stderr,"start `%s' ", SvPV(r->regstart));
if (r->regstclass)
fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
if (r->reganch & ROPT_ANCH)
if (r->reganch & ROPT_IMPLICIT)
fprintf(stderr,"implicit ");
if (r->regmust != NULL)
- fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
+ fprintf(stderr,"must have \"%s\" back %d ", SvPV(r->regmust),
r->regback);
fprintf(stderr, "minlen %d ", r->minlen);
fprintf(stderr,"\n");
r->subbase = Nullch;
}
if (r->regmust) {
- str_free(r->regmust);
- r->regmust = Nullstr;
+ sv_free(r->regmust);
+ r->regmust = Nullsv;
}
if (r->regstart) {
- str_free(r->regstart);
- r->regstart = Nullstr;
+ sv_free(r->regstart);
+ r->regstart = Nullsv;
}
Safefree(r->startp);
Safefree(r->endp);
-/* $RCSfile: regcomp.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:49:40 $
+/* $RCSfile: regcomp.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:31 $
*
* $Log: regcomp.h,v $
+ * Revision 4.1 92/08/07 18:26:31 lwall
+ *
* Revision 4.0.1.1 91/06/07 11:49:40 lwall
* patch4: no change
*
* 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
+ * regstart sv 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]
+ * [regmust changed to SV* for bminstr()--law]
* regmlen length of regmust string
* [regmlen not used currently]
*
#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 character in (or not in) this class. */
-#define CURLY 5 /* str Match this simple thing {n,m} times. */
+#define ANYOF 4 /* sv Match character in (or not in) this class. */
+#define CURLY 5 /* sv Match this simple thing {n,m} times. */
#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 EXACTLY 8 /* sv 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. */
#endif /* lint */
#define FAIL(m) fatal("/%s/: %s",regprecomp,m)
-
-char *regnext();
-#ifdef DEBUGGING
-void regdump();
-char *regprop();
-#endif
-
* blame Henry for some of the lack of readability.
*/
-/* $RCSfile: regexec.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 15:25:50 $
+/* $RCSfile: regexec.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:32 $
*
* $Log: regexec.c,v $
+ * Revision 4.1 92/08/07 18:26:32 lwall
+ *
* Revision 4.0.1.4 92/06/08 15:25:50 lwall
* patch20: pattern modifiers i and g didn't interact right
* patch20: in some cases $` and $' didn't get set by match
#endif
#ifdef DEBUGGING
-int regnarrate = 0;
+I32 regnarrate = 0;
#endif
/*
*/
/*
- * Global work variables for regexec().
- */
-static char *regprecomp;
-static char *reginput; /* String-input pointer. */
-static char regprev; /* char before regbol, \n if none */
-static char *regbol; /* Beginning of input, for ^ check. */
-static char *regeol; /* End of input, for $ check. */
-static char **regstartp; /* Pointer to startp array. */
-static char **regendp; /* Ditto for endp. */
-static char *reglastparen; /* Similarly for lastparen. */
-static char *regtill;
-
-static int regmyp_size = 0;
-static char **regmystartp = Null(char**);
-static char **regmyendp = Null(char**);
-
-/*
* Forwards.
*/
-STATIC int regtry();
-STATIC int regmatch();
-STATIC int regrepeat();
-
-extern int multiline;
+STATIC I32 regtry();
+STATIC I32 regmatch();
+STATIC I32 regrepeat();
/*
- regexec - match a regexp against a string
*/
-int
+I32
regexec(prog, stringarg, strend, strbeg, minend, screamer, safebase)
register regexp *prog;
char *stringarg;
register char *strend; /* pointer to null at end of string */
char *strbeg; /* real beginning of string */
-int minend; /* end of match must be at least minend after stringarg */
-STR *screamer;
-int safebase; /* no need to remember string in subbase */
+I32 minend; /* end of match must be at least minend after stringarg */
+SV *screamer;
+I32 safebase; /* no need to remember string in subbase */
{
register char *s;
- register int i;
+ register I32 i;
register char *c;
register char *string = stringarg;
- register int tmp;
- int minlen = 0; /* must match at least this many chars */
- int dontbother = 0; /* how many characters not to try at end */
+ register I32 tmp;
+ I32 minlen = 0; /* must match at least this many chars */
+ I32 dontbother = 0; /* how many characters not to try at end */
/* Be paranoid... */
if (prog == NULL || string == NULL) {
/* If there is a "must appear" string, look for it. */
s = string;
- if (prog->regmust != Nullstr &&
+ if (prog->regmust != Nullsv &&
(!(prog->reganch & ROPT_ANCH)
|| (multiline && prog->regback >= 0)) ) {
if (stringarg == strbeg && screamer) {
- if (screamfirst[prog->regmust->str_rare] >= 0)
+ if (screamfirst[BmRARE(prog->regmust)] >= 0)
s = screaminstr(screamer,prog->regmust);
else
s = Nullch;
}
#ifndef lint
else
- s = fbminstr((unsigned char*)s, (unsigned char*)strend,
+ s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
prog->regmust);
#endif
if (!s) {
- ++prog->regmust->str_u.str_useful; /* hooray */
+ ++BmUSEFUL(prog->regmust); /* hooray */
goto phooey; /* not present */
}
else if (prog->regback >= 0) {
s -= prog->regback;
if (s < string)
s = string;
- minlen = prog->regback + prog->regmust->str_cur;
+ minlen = prog->regback + SvCUR(prog->regmust);
}
- else if (--prog->regmust->str_u.str_useful < 0) { /* boo */
- str_free(prog->regmust);
- prog->regmust = Nullstr; /* disable regmust */
+ else if (--BmUSEFUL(prog->regmust) < 0) { /* boo */
+ sv_free(prog->regmust);
+ prog->regmust = Nullsv; /* disable regmust */
s = string;
}
else {
s = string;
- minlen = prog->regmust->str_cur;
+ minlen = SvCUR(prog->regmust);
}
}
if (prog->regstart) {
if (prog->reganch & ROPT_SKIP) { /* we have /x+whatever/ */
/* it must be a one character string */
- i = prog->regstart->str_ptr[0];
+ i = SvPV(prog->regstart)[0];
while (s < strend) {
if (*s == i) {
if (regtry(prog, s))
s++;
}
}
- else if (prog->regstart->str_pok == 3) {
+ else if (SvPOK(prog->regstart) == 3) {
/* We know what string it must start with. */
#ifndef lint
- while ((s = fbminstr((unsigned char*)s,
+ while ((s = fbm_instr((unsigned char*)s,
(unsigned char*)strend, prog->regstart)) != NULL)
#else
while (s = Nullch)
}
}
else {
- c = prog->regstart->str_ptr;
+ c = SvPV(prog->regstart);
while ((s = ninstr(s, strend,
- c, c + prog->regstart->str_cur )) != NULL) {
+ c, c + SvCUR(prog->regstart) )) != NULL) {
if (regtry(prog, s))
goto got_it;
s++;
}
/*SUPPRESS 560*/
if (c = prog->regstclass) {
- int doevery = (prog->reganch & ROPT_SKIP) == 0;
+ I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
if (minlen)
dontbother = minlen - 1;
/*
- regtry - try match at specific point
*/
-static int /* 0 failure, 1 success */
+static I32 /* 0 failure, 1 success */
regtry(prog, string)
regexp *prog;
char *string;
{
- register int i;
+ register I32 i;
register char **sp;
register char **ep;
* maybe save a little bit of pushing and popping on the stack. It also takes
* advantage of machines that use a register save mask on subroutine entry.
*/
-static int /* 0 failure, 1 success */
+static I32 /* 0 failure, 1 success */
regmatch(prog)
char *prog;
{
register char *scan; /* Current node. */
char *next; /* Next node. */
- register int nextchar;
- register int n; /* no or next */
- register int ln; /* len or last */
+ register I32 nextchar;
+ register I32 n; /* no or next */
+ register I32 ln; /* len or last */
register char *s; /* operand or save */
register char *locinput = reginput;
}
}
break;
+#ifdef NOTYET
+ case MINCURLY:
+ ln = ARG1(scan); /* min to match */
+ n = -ARG2(scan); /* max to match */
+ scan = NEXTOPER(scan) + 4;
+ goto repeat;
+#endif
case CURLY:
ln = ARG1(scan); /* min to match */
n = ARG2(scan); /* max to match */
else
nextchar = -1000;
reginput = locinput;
- n = regrepeat(scan, n);
- if (!multiline && OP(next) == EOL && ln < n)
- ln = n; /* why back off? */
- while (n >= ln) {
- /* If it could work, try it. */
- if (nextchar == -1000 || *reginput == nextchar)
- if (regmatch(next))
- return(1);
- /* Couldn't or didn't -- back up. */
- n--;
- reginput = locinput + n;
+ if (n < 0) {
+ n = -n;
+ while (n >= ln) {
+ /* If it could work, try it. */
+ if (nextchar == -1000 ||
+ *reginput == nextchar)
+ if (regmatch(next))
+ return(1);
+ /* Couldn't or didn't -- back up. */
+ ln++;
+ reginput = locinput + ln;
+ }
+ }
+ else {
+ n = regrepeat(scan, n);
+ if (!multiline && OP(next) == EOL && ln < n)
+ ln = n; /* why back off? */
+ while (n >= ln) {
+ /* If it could work, try it. */
+ if (nextchar == -1000 ||
+ *reginput == nextchar)
+ if (regmatch(next))
+ return(1);
+ /* Couldn't or didn't -- back up. */
+ n--;
+ reginput = locinput + n;
+ }
}
return(0);
case END:
* That was true before, but now we assume scan - reginput is the count,
* rather than incrementing count on every character.]
*/
-static int
+static I32
regrepeat(p, max)
char *p;
-int max;
+I32 max;
{
register char *scan;
register char *opnd;
- register int c;
+ register I32 c;
register char *loceol = regeol;
scan = reginput;
regnext(p)
register char *p;
{
- register int offset;
+ register I32 offset;
if (p == ®dummy)
return(NULL);
* not the System V one.
*/
-/* $RCSfile: regexp.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:24:31 $
+/* $RCSfile: regexp.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:35 $
*
* $Log: regexp.h,v $
+ * Revision 4.1 92/08/07 18:26:35 lwall
+ *
* Revision 4.0.1.2 91/11/05 18:24:31 lwall
* patch11: minimum match length calculation in regexp is now cumulative
* patch11: initial .* in pattern had dependency on value of $*
typedef struct regexp {
char **startp;
char **endp;
- STR *regstart; /* Internal use only. */
+ SV *regstart; /* Internal use only. */
char *regstclass;
- STR *regmust; /* Internal use only. */
- int regback; /* Can regmust locate first try? */
- int minlen; /* mininum possible length of $& */
- int prelen; /* length of precomp */
+ SV *regmust; /* Internal use only. */
+ I32 regback; /* Can regmust locate first try? */
+ I32 minlen; /* mininum possible length of $& */
+ I32 prelen; /* length of precomp */
char *precomp; /* pre-compilation regular expression */
char *subbase; /* saved string so \digit works forever */
char *subbeg; /* same, but not responsible for allocation */
#define ROPT_ANCH 1
#define ROPT_SKIP 2
#define ROPT_IMPLICIT 4
-
-regexp *regcomp();
-int regexec();
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+
+char **watchaddr = 0;
+char *watchok;
+
+#ifndef DEBUGGING
+
+run() {
+ while ( op = (*op->op_ppaddr)() ) ;
+}
+
+#else
+
+run() {
+ if (!op) {
+ warn("NULL OP IN RUN");
+ return;
+ }
+ do {
+ if (debug) {
+ if (watchaddr != 0 && *watchaddr != watchok)
+ fprintf(stderr, "WARNING: %lx changed from %lx to %lx\n",
+ watchaddr, watchok, *watchaddr);
+ DEBUG_s(debstack());
+ DEBUG_t(debop(op));
+ }
+ } while ( op = (*op->op_ppaddr)() );
+}
+
+#endif
+
+I32
+getgimme(op)
+OP *op;
+{
+ return cxstack[cxstack_ix].blk_gimme;
+}
+
+I32
+debop(op)
+OP *op;
+{
+ SV *sv;
+ deb("%s", op_name[op->op_type]);
+ switch (op->op_type) {
+ case OP_CONST:
+ fprintf(stderr, "(%s)", SvPEEK(cSVOP->op_sv));
+ break;
+ case OP_GVSV:
+ case OP_GV:
+ if (cGVOP->op_gv) {
+ sv = NEWSV(0,0);
+ gv_fullname(sv, cGVOP->op_gv);
+ fprintf(stderr, "(%s)", SvPVn(sv));
+ sv_free(sv);
+ }
+ else
+ fprintf(stderr, "(NULL)");
+ break;
+ }
+ fprintf(stderr, "\n");
+ return 0;
+}
+
+void
+watch(addr)
+char **addr;
+{
+ watchaddr = addr;
+ watchok = *addr;
+ fprintf(stderr, "WATCHING, %lx is currently %lx\n",
+ watchaddr, watchok);
+}
--- /dev/null
+AV *
+save_ary(av)
+AV *av;
+{
+ register SV *sv;
+
+ sv = NEWSV(10,0);
+ sv->sv_state = SVs_SARY;
+ sv_setpv(sv, (char*)av, sizeof(AV));
+
+ av->av_sv.sv_rare = AVf_REAL;
+ av->av_magic = NEWSV(7,0);
+ av->av_alloc = av->av_array = 0;
+ /* sv_magic(av->av_magic, gv, '#', Nullch, 0); */
+ av->av_max = av->av_fill = -1;
+
+ sv->sv_u.sv_av = av;
+ (void)av_push(savestack,sv); /* save array ptr */
+ return av;
+}
+
+HV *
+save_hash(hv)
+HV *hv;
+{
+ register SV *sv;
+
+ sv = NEWSV(11,0);
+ sv->sv_state = SVs_SHASH;
+ sv_setpv(sv, (char*)hv, sizeof(HV));
+
+ hv->hv_array = 0;
+ hv->hv_max = 7;
+ hv->hv_dosplit = hv->hv_max * FILLPCT / 100;
+ hv->hv_fill = 0;
+#ifdef SOME_DBM
+ hv->hv_dbm = 0;
+#endif
+ (void)hv_iterinit(hv); /* so each() will start off right */
+
+ sv->sv_u.sv_hv = hv;
+ (void)av_push(savestack,sv); /* save hash ptr */
+ return hv;
+}
--- /dev/null
+/* $RCSfile: op.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:16 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: op.c,v $
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+I32
+cxinc()
+{
+ cxstack_max = cxstack_max * 3 / 2;
+ Renew(cxstack, cxstack_max, CONTEXT);
+ return cxstack_ix + 1;
+}
+
+void
+push_return(retop)
+OP *retop;
+{
+ if (retstack_ix == retstack_max) {
+ retstack_max = retstack_max * 3 / 2;
+ Renew(retstack, retstack_max, OP*);
+ }
+ retstack[retstack_ix++] = retop;
+}
+
+OP *
+pop_return()
+{
+ if (retstack_ix > 0)
+ return retstack[--retstack_ix];
+ else
+ return Nullop;
+}
+
+void
+push_scope()
+{
+ if (scopestack_ix == scopestack_max) {
+ scopestack_max = scopestack_max * 3 / 2;
+ Renew(scopestack, scopestack_max, I32);
+ }
+ scopestack[scopestack_ix++] = savestack_ix;
+
+}
+
+void
+pop_scope()
+{
+ I32 oldsave = scopestack[--scopestack_ix];
+ if (savestack_ix > oldsave)
+ leave_scope(oldsave);
+}
+
+void
+savestack_grow()
+{
+ savestack_max = savestack_max * 3 / 2;
+ Renew(savestack, savestack_max, ANY);
+}
+
+void
+free_tmps()
+{
+ /* XXX should tmps_floor live in cxstack? */
+ I32 myfloor = tmps_floor;
+ while (tmps_ix > myfloor) { /* clean up after last statement */
+ SV* sv = tmps_stack[tmps_ix];
+ tmps_stack[tmps_ix--] = Nullsv;
+ if (sv)
+ sv_free(sv); /* note, can modify tmps_ix!!! */
+ }
+}
+
+SV *
+save_scalar(gv)
+GV *gv;
+{
+ register SV *sv;
+ SV *osv = GvSV(gv);
+
+ SSCHECK(3);
+ SSPUSHPTR(gv);
+ SSPUSHPTR(osv);
+ SSPUSHINT(SAVEt_SV);
+
+ sv = GvSV(gv) = NEWSV(0,0);
+ if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(sv)) {
+ sv_upgrade(sv, SvTYPE(osv));
+ SvMAGIC(sv) = SvMAGIC(osv);
+ localizing = TRUE;
+ SvSETMAGIC(sv);
+ localizing = FALSE;
+ }
+ return sv;
+}
+
+#ifdef INLINED_ELSEWHERE
+void
+save_gp(gv)
+GV *gv;
+{
+ register GP *gp;
+ GP *ogp = GvGP(gv);
+
+ SSCHECK(3);
+ SSPUSHPTR(gv);
+ SSPUSHPTR(ogp);
+ SSPUSHINT(SAVEt_GP);
+
+ Newz(602,gp, 1, GP);
+ GvGP(gv) = gp;
+ GvREFCNT(gv) = 1;
+ GvSV(gv) = NEWSV(72,0);
+ GvLINE(gv) = curcop->cop_line;
+ GvEGV(gv) = gv;
+}
+#endif
+
+SV*
+save_svref(sptr)
+SV **sptr;
+{
+ register SV *sv;
+ SV *osv = *sptr;
+
+ SSCHECK(3);
+ SSPUSHPTR(*sptr);
+ SSPUSHPTR(sptr);
+ SSPUSHINT(SAVEt_SVREF);
+
+ sv = *sptr = NEWSV(0,0);
+ if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(sv)) {
+ sv_upgrade(sv, SvTYPE(osv));
+ SvMAGIC(sv) = SvMAGIC(osv);
+ localizing = TRUE;
+ SvSETMAGIC(sv);
+ localizing = FALSE;
+ }
+ return sv;
+}
+
+AV *
+save_ary(gv)
+GV *gv;
+{
+ SSCHECK(3);
+ SSPUSHPTR(gv);
+ SSPUSHPTR(GvAVn(gv));
+ SSPUSHINT(SAVEt_AV);
+
+ GvAV(gv) = Null(AV*);
+ return GvAVn(gv);
+}
+
+HV *
+save_hash(gv)
+GV *gv;
+{
+ SSCHECK(3);
+ SSPUSHPTR(gv);
+ SSPUSHPTR(GvHVn(gv));
+ SSPUSHINT(SAVEt_HV);
+
+ GvHV(gv) = Null(HV*);
+ return GvHVn(gv);
+}
+
+void
+save_item(item)
+register SV *item;
+{
+ register SV *sv;
+
+ SSCHECK(3);
+ SSPUSHPTR(item); /* remember the pointer */
+ sv = NEWSV(0,0);
+ sv_setsv(sv,item);
+ SSPUSHPTR(sv); /* remember the value */
+ SSPUSHINT(SAVEt_ITEM);
+}
+
+void
+save_int(intp)
+int *intp;
+{
+ SSCHECK(3);
+ SSPUSHINT(*intp);
+ SSPUSHPTR(intp);
+ SSPUSHINT(SAVEt_INT);
+}
+
+void
+save_I32(intp)
+I32 *intp;
+{
+ SSCHECK(3);
+ SSPUSHINT(*intp);
+ SSPUSHPTR(intp);
+ SSPUSHINT(SAVEt_I32);
+}
+
+void
+save_sptr(sptr)
+SV **sptr;
+{
+ SSCHECK(3);
+ SSPUSHPTR(*sptr);
+ SSPUSHPTR(sptr);
+ SSPUSHINT(SAVEt_SPTR);
+}
+
+void
+save_nogv(gv)
+GV *gv;
+{
+ SSCHECK(2);
+ SSPUSHPTR(gv);
+ SSPUSHINT(SAVEt_NSTAB);
+}
+
+void
+save_hptr(hptr)
+HV **hptr;
+{
+ SSCHECK(3);
+ SSPUSHINT(*hptr);
+ SSPUSHPTR(hptr);
+ SSPUSHINT(SAVEt_HPTR);
+}
+
+void
+save_aptr(aptr)
+AV **aptr;
+{
+ SSCHECK(3);
+ SSPUSHINT(*aptr);
+ SSPUSHPTR(aptr);
+ SSPUSHINT(SAVEt_APTR);
+}
+
+void
+save_list(sarg,maxsarg)
+register SV **sarg;
+I32 maxsarg;
+{
+ register SV *sv;
+ register I32 i;
+
+ SSCHECK(3 * maxsarg);
+ for (i = 1; i <= maxsarg; i++) {
+ SSPUSHPTR(sarg[i]); /* remember the pointer */
+ sv = NEWSV(0,0);
+ sv_setsv(sv,sarg[i]);
+ SSPUSHPTR(sv); /* remember the value */
+ SSPUSHINT(SAVEt_ITEM);
+ }
+}
+
+void
+leave_scope(base)
+I32 base;
+{
+ register SV *sv;
+ register SV *value;
+ register GV *gv;
+ register AV *av;
+ register HV *hv;
+ register void* ptr;
+
+ if (base < -1)
+ fatal("panic: corrupt saved stack index");
+ while (savestack_ix > base) {
+ switch (SSPOPINT) {
+ case SAVEt_ITEM: /* normal string */
+ value = (SV*)SSPOPPTR;
+ sv = (SV*)SSPOPPTR;
+ sv_replace(sv,value);
+ SvSETMAGIC(sv);
+ break;
+ case SAVEt_SV: /* scalar reference */
+ value = (SV*)SSPOPPTR;
+ gv = (GV*)SSPOPPTR;
+ sv = GvSV(gv);
+ if (SvTYPE(sv) >= SVt_PVMG)
+ SvMAGIC(sv) = 0;
+ sv_free(sv);
+ GvSV(gv) = sv = value;
+ SvSETMAGIC(sv);
+ break;
+ case SAVEt_SVREF: /* scalar reference */
+ ptr = SSPOPPTR;
+ sv = *(SV**)ptr;
+ if (SvTYPE(sv) >= SVt_PVMG)
+ SvMAGIC(sv) = 0;
+ sv_free(sv);
+ *(SV**)ptr = sv = (SV*)SSPOPPTR;
+ SvSETMAGIC(sv);
+ break;
+ case SAVEt_AV: /* array reference */
+ av = (AV*)SSPOPPTR;
+ gv = (GV*)SSPOPPTR;
+ av_free(GvAV(gv));
+ GvAV(gv) = av;
+ break;
+ case SAVEt_HV: /* hash reference */
+ hv = (HV*)SSPOPPTR;
+ gv = (GV*)SSPOPPTR;
+ (void)hv_free(GvHV(gv), FALSE);
+ GvHV(gv) = hv;
+ break;
+ case SAVEt_INT: /* int reference */
+ ptr = SSPOPPTR;
+ *(int*)ptr = (int)SSPOPINT;
+ break;
+ case SAVEt_I32: /* I32 reference */
+ ptr = SSPOPPTR;
+ *(I32*)ptr = (I32)SSPOPINT;
+ break;
+ case SAVEt_SPTR: /* SV* reference */
+ ptr = SSPOPPTR;
+ *(SV**)ptr = (SV*)SSPOPPTR;
+ break;
+ case SAVEt_HPTR: /* HV* reference */
+ ptr = SSPOPPTR;
+ *(HV**)ptr = (HV*)SSPOPPTR;
+ break;
+ case SAVEt_APTR: /* AV* reference */
+ ptr = SSPOPPTR;
+ *(AV**)ptr = (AV*)SSPOPPTR;
+ break;
+ case SAVEt_NSTAB:
+ gv = (GV*)SSPOPPTR;
+ (void)sv_clear(gv);
+ break;
+ case SAVEt_GP: /* scalar reference */
+ ptr = SSPOPPTR;
+ gv = (GV*)SSPOPPTR;
+ gp_free(gv);
+ GvGP(gv) = (GP*)ptr;
+ break;
+ default:
+ fatal("panic: leave_scope inconsistency");
+ }
+ }
+}
--- /dev/null
+#define SAVEt_ITEM 0
+#define SAVEt_SV 1
+#define SAVEt_AV 2
+#define SAVEt_HV 3
+#define SAVEt_INT 4
+#define SAVEt_I32 5
+#define SAVEt_SPTR 6
+#define SAVEt_HPTR 7
+#define SAVEt_APTR 8
+#define SAVEt_NSTAB 9
+#define SAVEt_SVREF 10
+#define SAVEt_GP 11
+
+#define SSCHECK(need) if (savestack_ix + need > savestack_max) savestack_grow()
+#define SSPUSHINT(i) (savestack[savestack_ix++].any_i32 = (I32)(i))
+#define SSPUSHPTR(p) (savestack[savestack_ix++].any_ptr = (void*)(p))
+#define SSPOPINT (savestack[--savestack_ix].any_i32)
+#define SSPOPPTR (savestack[--savestack_ix].any_ptr)
--- /dev/null
+#!/usr/bin/perl
+
+print sort byfuncname <>;
+
+sub byfuncname {
+ ($A) = $a =~ /\b(\w+) P\(/;
+ ($B) = $b =~ /\b(\w+) P\(/;
+ $A cmp $B;
+}
+++ /dev/null
-/* $RCSfile: spat.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:51:59 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: spat.h,v $
- * Revision 4.0.1.1 91/06/07 11:51:59 lwall
- * patch4: new copyright notice
- * patch4: added global modifier for pattern matches
- *
- * Revision 4.0 91/03/20 01:39:36 lwall
- * 4.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() */
- short 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 */
-#define SPAT_GLOBAL 256 /* pattern had a g modifier */
-
-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*)
+++ /dev/null
-/* $RCSfile: stab.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 15:32:19 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: stab.c,v $
- * Revision 4.0.1.4 92/06/08 15:32:19 lwall
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: the debugger now warns you on lines that can't set a breakpoint
- * patch20: the debugger made perl forget the last pattern used by //
- * patch20: paragraph mode now skips extra newlines automatically
- * patch20: ($<,$>) = ... didn't work on some architectures
- *
- * Revision 4.0.1.3 91/11/05 18:35:33 lwall
- * patch11: length($x) was sometimes wrong for numeric $x
- * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
- * patch11: *foo = undef coredumped
- * patch11: solitary subroutine references no longer trigger typo warnings
- * patch11: local(*FILEHANDLE) had a memory leak
- *
- * Revision 4.0.1.2 91/06/07 11:55:53 lwall
- * patch4: new copyright notice
- * patch4: added $^P variable to control calling of perldb routines
- * patch4: added $^F variable to specify maximum system fd, default 2
- * patch4: $` was busted inside s///
- * patch4: default top-of-form format is now FILEHANDLE_TOP
- * patch4: length($`), length($&), length($') now optimized to avoid string copy
- * patch4: $^D |= 1024 now does syntax tree dump at run-time
- *
- * Revision 4.0.1.1 91/04/12 09:10:24 lwall
- * patch1: Configure now differentiates getgroups() type from getgid() type
- * patch1: you may now use "die" and "caller" in a signal handler
- *
- * Revision 4.0 91/03/20 01:39:41 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
-#include <signal.h>
-#endif
-
-static char *sig_name[] = {
- SIG_NAME,0
-};
-
-#ifdef VOIDSIG
-#define handlertype void
-#else
-#define handlertype int
-#endif
-
-static handlertype sighandler();
-
-static int origalen = 0;
-
-STR *
-stab_str(str)
-STR *str;
-{
- STAB *stab = str->str_u.str_stab;
- register int paren;
- register char *s;
- register int i;
-
- if (str->str_rare)
- return stab_val(stab);
-
- switch (*stab->str_magic->str_ptr) {
- case '\004': /* ^D */
-#ifdef DEBUGGING
- str_numset(stab_val(stab),(double)(debug & 32767));
-#endif
- break;
- case '\006': /* ^F */
- str_numset(stab_val(stab),(double)maxsysfd);
- break;
- case '\t': /* ^I */
- if (inplace)
- str_set(stab_val(stab), inplace);
- else
- str_sset(stab_val(stab),&str_undef);
- break;
- case '\020': /* ^P */
- str_numset(stab_val(stab),(double)perldb);
- break;
- case '\024': /* ^T */
- str_numset(stab_val(stab),(double)basetime);
- break;
- case '\027': /* ^W */
- str_numset(stab_val(stab),(double)dowarn);
- break;
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9': case '&':
- if (curspat) {
- paren = atoi(stab_ename(stab));
- getparen:
- if (curspat->spat_regexp &&
- paren <= curspat->spat_regexp->nparens &&
- (s = curspat->spat_regexp->startp[paren]) ) {
- i = curspat->spat_regexp->endp[paren] - s;
- if (i >= 0)
- str_nset(stab_val(stab),s,i);
- else
- str_sset(stab_val(stab),&str_undef);
- }
- else
- str_sset(stab_val(stab),&str_undef);
- }
- break;
- case '+':
- if (curspat) {
- paren = curspat->spat_regexp->lastparen;
- goto getparen;
- }
- break;
- case '`':
- if (curspat) {
- if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->subbeg) ) {
- i = curspat->spat_regexp->startp[0] - s;
- if (i >= 0)
- str_nset(stab_val(stab),s,i);
- else
- str_nset(stab_val(stab),"",0);
- }
- else
- str_nset(stab_val(stab),"",0);
- }
- break;
- case '\'':
- if (curspat) {
- if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->endp[0]) ) {
- str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s);
- }
- else
- str_nset(stab_val(stab),"",0);
- }
- break;
- case '.':
-#ifndef lint
- if (last_in_stab && stab_io(last_in_stab)) {
- str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
- }
-#endif
- break;
- case '?':
- str_numset(stab_val(stab),(double)statusvalue);
- break;
- case '^':
- s = stab_io(curoutstab)->top_name;
- if (s)
- str_set(stab_val(stab),s);
- else {
- str_set(stab_val(stab),stab_ename(curoutstab));
- str_cat(stab_val(stab),"_TOP");
- }
- break;
- case '~':
- s = stab_io(curoutstab)->fmt_name;
- if (!s)
- s = stab_ename(curoutstab);
- str_set(stab_val(stab),s);
- break;
-#ifndef lint
- case '=':
- str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
- break;
- case '-':
- str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
- break;
- case '%':
- str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
- break;
-#endif
- case ':':
- break;
- case '/':
- break;
- case '[':
- str_numset(stab_val(stab),(double)arybase);
- break;
- case '|':
- if (!stab_io(curoutstab))
- stab_io(curoutstab) = stio_new();
- str_numset(stab_val(stab),
- (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
- break;
- case ',':
- str_nset(stab_val(stab),ofs,ofslen);
- break;
- case '\\':
- str_nset(stab_val(stab),ors,orslen);
- break;
- case '#':
- str_set(stab_val(stab),ofmt);
- break;
- case '!':
- str_numset(stab_val(stab), (double)errno);
- str_set(stab_val(stab), errno ? strerror(errno) : "");
- stab_val(stab)->str_nok = 1; /* what a wonderful hack! */
- break;
- case '<':
- str_numset(stab_val(stab),(double)uid);
- break;
- case '>':
- str_numset(stab_val(stab),(double)euid);
- break;
- case '(':
- s = buf;
- (void)sprintf(s,"%d",(int)gid);
- goto add_groups;
- case ')':
- s = buf;
- (void)sprintf(s,"%d",(int)egid);
- add_groups:
- while (*s) s++;
-#ifdef HAS_GETGROUPS
-#ifndef NGROUPS
-#define NGROUPS 32
-#endif
- {
- GROUPSTYPE gary[NGROUPS];
-
- i = getgroups(NGROUPS,gary);
- while (--i >= 0) {
- (void)sprintf(s," %ld", (long)gary[i]);
- while (*s) s++;
- }
- }
-#endif
- str_set(stab_val(stab),buf);
- break;
- case '*':
- break;
- case '0':
- break;
- default:
- {
- struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
-
- if (uf && uf->uf_val)
- (*uf->uf_val)(uf->uf_index, stab_val(stab));
- }
- break;
- }
- return stab_val(stab);
-}
-
-STRLEN
-stab_len(str)
-STR *str;
-{
- STAB *stab = str->str_u.str_stab;
- int paren;
- int i;
- char *s;
-
- if (str->str_rare)
- return str_len(stab_val(stab));
-
- switch (*stab->str_magic->str_ptr) {
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9': case '&':
- if (curspat) {
- paren = atoi(stab_ename(stab));
- getparen:
- if (curspat->spat_regexp &&
- paren <= curspat->spat_regexp->nparens &&
- (s = curspat->spat_regexp->startp[paren]) ) {
- i = curspat->spat_regexp->endp[paren] - s;
- if (i >= 0)
- return i;
- else
- return 0;
- }
- else
- return 0;
- }
- break;
- case '+':
- if (curspat) {
- paren = curspat->spat_regexp->lastparen;
- goto getparen;
- }
- break;
- case '`':
- if (curspat) {
- if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->subbeg) ) {
- i = curspat->spat_regexp->startp[0] - s;
- if (i >= 0)
- return i;
- else
- return 0;
- }
- else
- return 0;
- }
- break;
- case '\'':
- if (curspat) {
- if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->endp[0]) ) {
- return (STRLEN) (curspat->spat_regexp->subend - s);
- }
- else
- return 0;
- }
- break;
- case ',':
- return (STRLEN)ofslen;
- case '\\':
- return (STRLEN)orslen;
- }
- return str_len(stab_str(str));
-}
-
-void
-stabset(mstr,str)
-register STR *mstr;
-STR *str;
-{
- STAB *stab;
- register char *s;
- int i;
-
- switch (mstr->str_rare) {
- case 'E':
- my_setenv(mstr->str_ptr,str_get(str));
- /* And you'll never guess what the dog had */
- /* in its mouth... */
-#ifdef TAINT
- if (strEQ(mstr->str_ptr,"PATH")) {
- char *strend = str->str_ptr + str->str_cur;
-
- s = str->str_ptr;
- while (s < strend) {
- s = cpytill(tokenbuf,s,strend,':',&i);
- s++;
- if (*tokenbuf != '/'
- || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
- str->str_tainted = 2;
- }
- }
-#endif
- break;
- case 'S':
- s = str_get(str);
- i = whichsig(mstr->str_ptr); /* ...no, a brick */
- if (!i && (dowarn || strEQ(mstr->str_ptr,"ALARM")))
- warn("No such signal: SIG%s", mstr->str_ptr);
- if (strEQ(s,"IGNORE"))
-#ifndef lint
- (void)signal(i,SIG_IGN);
-#else
- ;
-#endif
- else if (strEQ(s,"DEFAULT") || !*s)
- (void)signal(i,SIG_DFL);
- else {
- (void)signal(i,sighandler);
- if (!index(s,'\'')) {
- sprintf(tokenbuf, "main'%s",s);
- str_set(str,tokenbuf);
- }
- }
- break;
-#ifdef SOME_DBM
- case 'D':
- stab = mstr->str_u.str_stab;
- hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
- break;
-#endif
- case 'L':
- {
- CMD *cmd;
-
- stab = mstr->str_u.str_stab;
- i = str_true(str);
- str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
- if (str->str_magic && (cmd = str->str_magic->str_u.str_cmd)) {
- cmd->c_flags &= ~CF_OPTIMIZE;
- cmd->c_flags |= i? CFT_D1 : CFT_D0;
- }
- else
- warn("Can't break at that line\n");
- }
- break;
- case '#':
- stab = mstr->str_u.str_stab;
- afill(stab_array(stab), (int)str_gnum(str) - arybase);
- break;
- case 'X': /* merely a copy of a * string */
- break;
- case '*':
- s = str->str_pok ? str_get(str) : "";
- if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
- stab = mstr->str_u.str_stab;
- if (!*s) {
- STBP *stbp;
-
- /*SUPPRESS 701*/
- (void)savenostab(stab); /* schedule a free of this stab */
- if (stab->str_len)
- Safefree(stab->str_ptr);
- Newz(601,stbp, 1, STBP);
- stab->str_ptr = stbp;
- stab->str_len = stab->str_cur = sizeof(STBP);
- stab->str_pok = 1;
- strcpy(stab_magic(stab),"StB");
- stab_val(stab) = Str_new(70,0);
- stab_line(stab) = curcmd->c_line;
- stab_estab(stab) = stab;
- }
- else {
- stab = stabent(s,TRUE);
- if (!stab_xarray(stab))
- aadd(stab);
- if (!stab_xhash(stab))
- hadd(stab);
- if (!stab_io(stab))
- stab_io(stab) = stio_new();
- }
- str_sset(str, (STR*) stab);
- }
- break;
- case 's': {
- struct lstring *lstr = (struct lstring*)str;
- char *tmps;
-
- mstr->str_rare = 0;
- str->str_magic = Nullstr;
- tmps = str_get(str);
- str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
- tmps,str->str_cur);
- }
- break;
-
- case 'v':
- do_vecset(mstr,str);
- break;
-
- case 0:
- /*SUPPRESS 560*/
- if (!(stab = mstr->str_u.str_stab))
- break;
- switch (*stab->str_magic->str_ptr) {
- case '\004': /* ^D */
-#ifdef DEBUGGING
- debug = (int)(str_gnum(str)) | 32768;
- if (debug & 1024)
- dump_all();
-#endif
- break;
- case '\006': /* ^F */
- maxsysfd = (int)str_gnum(str);
- break;
- case '\t': /* ^I */
- if (inplace)
- Safefree(inplace);
- if (str->str_pok || str->str_nok)
- inplace = savestr(str_get(str));
- else
- inplace = Nullch;
- break;
- case '\020': /* ^P */
- i = (int)str_gnum(str);
- if (i != perldb) {
- static SPAT *oldlastspat;
-
- if (perldb)
- oldlastspat = lastspat;
- else
- lastspat = oldlastspat;
- }
- perldb = i;
- break;
- case '\024': /* ^T */
- basetime = (time_t)str_gnum(str);
- break;
- case '\027': /* ^W */
- dowarn = (bool)str_gnum(str);
- break;
- case '.':
- if (localizing)
- savesptr((STR**)&last_in_stab);
- break;
- case '^':
- Safefree(stab_io(curoutstab)->top_name);
- stab_io(curoutstab)->top_name = s = savestr(str_get(str));
- stab_io(curoutstab)->top_stab = stabent(s,TRUE);
- break;
- case '~':
- Safefree(stab_io(curoutstab)->fmt_name);
- stab_io(curoutstab)->fmt_name = s = savestr(str_get(str));
- stab_io(curoutstab)->fmt_stab = stabent(s,TRUE);
- break;
- case '=':
- stab_io(curoutstab)->page_len = (long)str_gnum(str);
- break;
- case '-':
- stab_io(curoutstab)->lines_left = (long)str_gnum(str);
- if (stab_io(curoutstab)->lines_left < 0L)
- stab_io(curoutstab)->lines_left = 0L;
- break;
- case '%':
- stab_io(curoutstab)->page = (long)str_gnum(str);
- break;
- case '|':
- if (!stab_io(curoutstab))
- stab_io(curoutstab) = stio_new();
- stab_io(curoutstab)->flags &= ~IOF_FLUSH;
- if (str_gnum(str) != 0.0) {
- stab_io(curoutstab)->flags |= IOF_FLUSH;
- }
- break;
- case '*':
- i = (int)str_gnum(str);
- multiline = (i != 0);
- break;
- case '/':
- if (str->str_pok) {
- rs = str_get(str);
- rslen = str->str_cur;
- if (rspara = !rslen) {
- rs = "\n\n";
- rslen = 2;
- }
- rschar = rs[rslen - 1];
- }
- else {
- rschar = 0777; /* fake a non-existent char */
- rslen = 1;
- }
- break;
- case '\\':
- if (ors)
- Safefree(ors);
- ors = savestr(str_get(str));
- orslen = str->str_cur;
- break;
- case ',':
- if (ofs)
- Safefree(ofs);
- ofs = savestr(str_get(str));
- ofslen = str->str_cur;
- break;
- case '#':
- if (ofmt)
- Safefree(ofmt);
- ofmt = savestr(str_get(str));
- break;
- case '[':
- arybase = (int)str_gnum(str);
- break;
- case '?':
- statusvalue = U_S(str_gnum(str));
- break;
- case '!':
- errno = (int)str_gnum(str); /* will anyone ever use this? */
- break;
- case '<':
- uid = (int)str_gnum(str);
- if (delaymagic) {
- delaymagic |= DM_RUID;
- break; /* don't do magic till later */
- }
-#ifdef HAS_SETRUID
- (void)setruid((UIDTYPE)uid);
-#else
-#ifdef HAS_SETREUID
- (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1);
-#else
- if (uid == euid) /* special case $< = $> */
- (void)setuid(uid);
- else
- fatal("setruid() not implemented");
-#endif
-#endif
- uid = (int)getuid();
- break;
- case '>':
- euid = (int)str_gnum(str);
- if (delaymagic) {
- delaymagic |= DM_EUID;
- break; /* don't do magic till later */
- }
-#ifdef HAS_SETEUID
- (void)seteuid((UIDTYPE)euid);
-#else
-#ifdef HAS_SETREUID
- (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid);
-#else
- if (euid == uid) /* special case $> = $< */
- setuid(euid);
- else
- fatal("seteuid() not implemented");
-#endif
-#endif
- euid = (int)geteuid();
- break;
- case '(':
- gid = (int)str_gnum(str);
- if (delaymagic) {
- delaymagic |= DM_RGID;
- break; /* don't do magic till later */
- }
-#ifdef HAS_SETRGID
- (void)setrgid((GIDTYPE)gid);
-#else
-#ifdef HAS_SETREGID
- (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
-#else
- if (gid == egid) /* special case $( = $) */
- (void)setgid(gid);
- else
- fatal("setrgid() not implemented");
-#endif
-#endif
- gid = (int)getgid();
- break;
- case ')':
- egid = (int)str_gnum(str);
- if (delaymagic) {
- delaymagic |= DM_EGID;
- break; /* don't do magic till later */
- }
-#ifdef HAS_SETEGID
- (void)setegid((GIDTYPE)egid);
-#else
-#ifdef HAS_SETREGID
- (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
-#else
- if (egid == gid) /* special case $) = $( */
- (void)setgid(egid);
- else
- fatal("setegid() not implemented");
-#endif
-#endif
- egid = (int)getegid();
- break;
- case ':':
- chopset = str_get(str);
- break;
- case '0':
- if (!origalen) {
- s = origargv[0];
- s += strlen(s);
- /* See if all the arguments are contiguous in memory */
- for (i = 1; i < origargc; i++) {
- if (origargv[i] == s + 1)
- s += strlen(++s); /* this one is ok too */
- }
- if (origenviron[0] == s + 1) { /* can grab env area too? */
- my_setenv("NoNeSuCh", Nullch);
- /* force copy of environment */
- for (i = 0; origenviron[i]; i++)
- if (origenviron[i] == s + 1)
- s += strlen(++s);
- }
- origalen = s - origargv[0];
- }
- s = str_get(str);
- i = str->str_cur;
- if (i >= origalen) {
- i = origalen;
- str->str_cur = i;
- str->str_ptr[i] = '\0';
- Copy(s, origargv[0], i, char);
- }
- else {
- Copy(s, origargv[0], i, char);
- s = origargv[0]+i;
- *s++ = '\0';
- while (++i < origalen)
- *s++ = ' ';
- }
- break;
- default:
- {
- struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
-
- if (uf && uf->uf_set)
- (*uf->uf_set)(uf->uf_index, str);
- }
- break;
- }
- break;
- }
-}
-
-int
-whichsig(sig)
-char *sig;
-{
- register char **sigv;
-
- for (sigv = sig_name+1; *sigv; sigv++)
- if (strEQ(sig,*sigv))
- return sigv - sig_name;
-#ifdef SIGCLD
- if (strEQ(sig,"CHLD"))
- return SIGCLD;
-#endif
-#ifdef SIGCHLD
- if (strEQ(sig,"CLD"))
- return SIGCHLD;
-#endif
- return 0;
-}
-
-static handlertype
-sighandler(sig)
-int sig;
-{
- STAB *stab;
- STR *str;
- int oldsave = savestack->ary_fill;
- int oldtmps_base = tmps_base;
- register CSV *csv;
- SUBR *sub;
-
-#ifdef OS2 /* or anybody else who requires SIG_ACK */
- signal(sig, SIG_ACK);
-#endif
- stab = stabent(
- str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
- TRUE)), TRUE);
- sub = stab_sub(stab);
- if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
- if (sig_name[sig][1] == 'H')
- stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)),
- TRUE);
- else
- stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)),
- TRUE);
- sub = stab_sub(stab); /* gag */
- }
- if (!sub) {
- if (dowarn)
- warn("SIG%s handler \"%s\" not defined.\n",
- sig_name[sig], stab_ename(stab) );
- return;
- }
- /*SUPPRESS 701*/
- saveaptr(&stack);
- str = Str_new(15, sizeof(CSV));
- str->str_state = SS_SCSV;
- (void)apush(savestack,str);
- csv = (CSV*)str->str_ptr;
- csv->sub = sub;
- csv->stab = stab;
- csv->curcsv = curcsv;
- csv->curcmd = curcmd;
- csv->depth = sub->depth;
- csv->wantarray = G_SCALAR;
- csv->hasargs = TRUE;
- csv->savearray = stab_xarray(defstab);
- csv->argarray = stab_xarray(defstab) = stack = anew(defstab);
- stack->ary_flags = 0;
- curcsv = csv;
- str = str_mortal(&str_undef);
- str_set(str,sig_name[sig]);
- (void)apush(stab_xarray(defstab),str);
- sub->depth++;
- if (sub->depth >= 2) { /* save temporaries on recursion? */
- if (sub->depth == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",stab_ename(stab));
- savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
- }
-
- tmps_base = tmps_max; /* protect our mortal string */
- (void)cmd_exec(sub->cmd,G_SCALAR,0); /* so do it already */
- tmps_base = oldtmps_base;
-
- restorelist(oldsave); /* put everything back */
-}
-
-STAB *
-aadd(stab)
-register STAB *stab;
-{
- if (!stab_xarray(stab))
- stab_xarray(stab) = anew(stab);
- return stab;
-}
-
-STAB *
-hadd(stab)
-register STAB *stab;
-{
- if (!stab_xhash(stab))
- stab_xhash(stab) = hnew(COEFFSIZE);
- return stab;
-}
-
-STAB *
-fstab(name)
-char *name;
-{
- char tmpbuf[1200];
- STAB *stab;
-
- sprintf(tmpbuf,"'_<%s", name);
- stab = stabent(tmpbuf, TRUE);
- str_set(stab_val(stab), name);
- if (perldb)
- (void)hadd(aadd(stab));
- return stab;
-}
-
-STAB *
-stabent(name,add)
-register char *name;
-int add;
-{
- register STAB *stab;
- register STBP *stbp;
- int len;
- register char *namend;
- HASH *stash;
- char *sawquote = Nullch;
- char *prevquote = Nullch;
- bool global = FALSE;
-
- if (isUPPER(*name)) {
- if (*name > 'I') {
- if (*name == 'S' && (
- strEQ(name, "SIG") ||
- strEQ(name, "STDIN") ||
- strEQ(name, "STDOUT") ||
- strEQ(name, "STDERR") ))
- global = TRUE;
- }
- else if (*name > 'E') {
- if (*name == 'I' && strEQ(name, "INC"))
- global = TRUE;
- }
- else if (*name > 'A') {
- if (*name == 'E' && strEQ(name, "ENV"))
- global = TRUE;
- }
- else if (*name == 'A' && (
- strEQ(name, "ARGV") ||
- strEQ(name, "ARGVOUT") ))
- global = TRUE;
- }
- for (namend = name; *namend; namend++) {
- if (*namend == '\'' && namend[1])
- prevquote = sawquote, sawquote = namend;
- }
- if (sawquote == name && name[1]) {
- stash = defstash;
- sawquote = Nullch;
- name++;
- }
- else if (!isALPHA(*name) || global)
- stash = defstash;
- else if ((CMD*)curcmd == &compiling)
- stash = curstash;
- else
- stash = curcmd->c_stash;
- if (sawquote) {
- char tmpbuf[256];
- char *s, *d;
-
- *sawquote = '\0';
- /*SUPPRESS 560*/
- if (s = prevquote) {
- strncpy(tmpbuf,name,s-name+1);
- d = tmpbuf+(s-name+1);
- *d++ = '_';
- strcpy(d,s+1);
- }
- else {
- *tmpbuf = '_';
- strcpy(tmpbuf+1,name);
- }
- stab = stabent(tmpbuf,TRUE);
- if (!(stash = stab_xhash(stab)))
- stash = stab_xhash(stab) = hnew(0);
- if (!stash->tbl_name)
- stash->tbl_name = savestr(name);
- name = sawquote+1;
- *sawquote = '\'';
- }
- len = namend - name;
- stab = (STAB*)hfetch(stash,name,len,add);
- if (stab == (STAB*)&str_undef)
- return Nullstab;
- if (stab->str_pok) {
- stab->str_pok |= SP_MULTI;
- return stab;
- }
- else {
- if (stab->str_len)
- Safefree(stab->str_ptr);
- Newz(602,stbp, 1, STBP);
- stab->str_ptr = stbp;
- stab->str_len = stab->str_cur = sizeof(STBP);
- stab->str_pok = 1;
- strcpy(stab_magic(stab),"StB");
- stab_val(stab) = Str_new(72,0);
- stab_line(stab) = curcmd->c_line;
- stab_estab(stab) = stab;
- str_magic((STR*)stab, stab, '*', name, len);
- stab_stash(stab) = stash;
- if (isDIGIT(*name) && *name != '0') {
- stab_flags(stab) = SF_VMAGIC;
- str_magic(stab_val(stab), stab, 0, Nullch, 0);
- }
- if (add & 2)
- stab->str_pok |= SP_MULTI;
- return stab;
- }
-}
-
-void
-stab_fullname(str,stab)
-STR *str;
-STAB *stab;
-{
- HASH *tb = stab_stash(stab);
-
- if (!tb)
- return;
- str_set(str,tb->tbl_name);
- str_ncat(str,"'", 1);
- str_scat(str,stab->str_magic);
-}
-
-void
-stab_efullname(str,stab)
-STR *str;
-STAB *stab;
-{
- HASH *tb = stab_estash(stab);
-
- if (!tb)
- return;
- str_set(str,tb->tbl_name);
- str_ncat(str,"'", 1);
- str_scat(str,stab_estab(stab)->str_magic);
-}
-
-STIO *
-stio_new()
-{
- STIO *stio;
-
- Newz(603,stio,1,STIO);
- stio->page_len = 60;
- return stio;
-}
-
-void
-stab_check(min,max)
-int min;
-register int max;
-{
- register HENT *entry;
- register int i;
- register STAB *stab;
-
- for (i = min; i <= max; i++) {
- for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
- stab = (STAB*)entry->hent_val;
- if (stab->str_pok & SP_MULTI)
- continue;
- curcmd->c_line = stab_line(stab);
- warn("Possible typo: \"%s\"", stab_name(stab));
- }
- }
-}
-
-static int gensym = 0;
-
-STAB *
-genstab()
-{
- (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
- return stabent(tokenbuf,TRUE);
-}
-
-/* hopefully this is only called on local symbol table entries */
-
-void
-stab_clear(stab)
-register STAB *stab;
-{
- STIO *stio;
- SUBR *sub;
-
- if (!stab || !stab->str_ptr)
- return;
- afree(stab_xarray(stab));
- stab_xarray(stab) = Null(ARRAY*);
- (void)hfree(stab_xhash(stab), FALSE);
- stab_xhash(stab) = Null(HASH*);
- str_free(stab_val(stab));
- stab_val(stab) = Nullstr;
- /*SUPPRESS 560*/
- if (stio = stab_io(stab)) {
- do_close(stab,FALSE);
- Safefree(stio->top_name);
- Safefree(stio->fmt_name);
- Safefree(stio);
- }
- /*SUPPRESS 560*/
- if (sub = stab_sub(stab)) {
- afree(sub->tosave);
- cmd_free(sub->cmd);
- }
- Safefree(stab->str_ptr);
- stab->str_ptr = Null(STBP*);
- stab->str_len = 0;
- stab->str_cur = 0;
-}
-
-#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
-#define MICROPORT
-#endif
-
-#ifdef MICROPORT /* Microport 2.4 hack */
-ARRAY *stab_array(stab)
-register STAB *stab;
-{
- if (((STBP*)(stab->str_ptr))->stbp_array)
- return ((STBP*)(stab->str_ptr))->stbp_array;
- else
- return ((STBP*)(aadd(stab)->str_ptr))->stbp_array;
-}
-
-HASH *stab_hash(stab)
-register STAB *stab;
-{
- if (((STBP*)(stab->str_ptr))->stbp_hash)
- return ((STBP*)(stab->str_ptr))->stbp_hash;
- else
- return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash;
-}
-#endif /* Microport 2.4 hack */
+++ /dev/null
-/* $RCSfile: stab.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 15:32:19 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: stab.c,v $
- * Revision 4.0.1.4 92/06/08 15:32:19 lwall
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: the debugger now warns you on lines that can't set a breakpoint
- * patch20: the debugger made perl forget the last pattern used by //
- * patch20: paragraph mode now skips extra newlines automatically
- * patch20: ($<,$>) = ... didn't work on some architectures
- *
- * Revision 4.0.1.3 91/11/05 18:35:33 lwall
- * patch11: length($x) was sometimes wrong for numeric $x
- * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
- * patch11: *foo = undef coredumped
- * patch11: solitary subroutine references no longer trigger typo warnings
- * patch11: local(*FILEHANDLE) had a memory leak
- *
- * Revision 4.0.1.2 91/06/07 11:55:53 lwall
- * patch4: new copyright notice
- * patch4: added $^P variable to control calling of perldb routines
- * patch4: added $^F variable to specify maximum system fd, default 2
- * patch4: $` was busted inside s///
- * patch4: default top-of-form format is now FILEHANDLE_TOP
- * patch4: length($`), length($&), length($') now optimized to avoid string copy
- * patch4: $^D |= 1024 now does syntax tree dump at run-time
- *
- * Revision 4.0.1.1 91/04/12 09:10:24 lwall
- * patch1: Configure now differentiates getgroups() type from getgid() type
- * patch1: you may now use "die" and "caller" in a signal handler
- *
- * Revision 4.0 91/03/20 01:39:41 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
-#include <signal.h>
-#endif
-
-static char *sig_name[] = {
- SIG_NAME,0
-};
-
-#ifdef VOIDSIG
-#define handlertype void
-#else
-#define handlertype int
-#endif
-
-static handlertype sighandler();
-
-static int origalen = 0;
-
-STR *
-stab_str(str)
-STR *str;
-{
- STAB *stab = str->str_u.str_stab;
- register int paren;
- register char *s;
- register int i;
-
- if (str->str_rare)
- return stab_val(stab);
-
- switch (*stab->str_magic->str_ptr) {
- case '\004': /* ^D */
-#ifdef DEBUGGING
- str_numset(stab_val(stab),(double)(debug & 32767));
-#endif
- break;
- case '\006': /* ^F */
- str_numset(stab_val(stab),(double)maxsysfd);
- break;
- case '\t': /* ^I */
- if (inplace)
- str_set(stab_val(stab), inplace);
- else
- str_sset(stab_val(stab),&str_undef);
- break;
- case '\020': /* ^P */
- str_numset(stab_val(stab),(double)perldb);
- break;
- case '\024': /* ^T */
- str_numset(stab_val(stab),(double)basetime);
- break;
- case '\027': /* ^W */
- str_numset(stab_val(stab),(double)dowarn);
- break;
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9': case '&':
- if (curspat) {
- paren = atoi(stab_ename(stab));
- getparen:
- if (curspat->spat_regexp &&
- paren <= curspat->spat_regexp->nparens &&
- (s = curspat->spat_regexp->startp[paren]) ) {
- i = curspat->spat_regexp->endp[paren] - s;
- if (i >= 0)
- str_nset(stab_val(stab),s,i);
- else
- str_sset(stab_val(stab),&str_undef);
- }
- else
- str_sset(stab_val(stab),&str_undef);
- }
- break;
- case '+':
- if (curspat) {
- paren = curspat->spat_regexp->lastparen;
- goto getparen;
- }
- break;
- case '`':
- if (curspat) {
- if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->subbeg) ) {
- i = curspat->spat_regexp->startp[0] - s;
- if (i >= 0)
- str_nset(stab_val(stab),s,i);
- else
- str_nset(stab_val(stab),"",0);
- }
- else
- str_nset(stab_val(stab),"",0);
- }
- break;
- case '\'':
- if (curspat) {
- if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->endp[0]) ) {
- str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s);
- }
- else
- str_nset(stab_val(stab),"",0);
- }
- break;
- case '.':
-#ifndef lint
- if (last_in_stab && stab_io(last_in_stab)) {
- str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
- }
-#endif
- break;
- case '?':
- str_numset(stab_val(stab),(double)statusvalue);
- break;
- case '^':
- s = stab_io(curoutstab)->top_name;
- if (s)
- str_set(stab_val(stab),s);
- else {
- str_set(stab_val(stab),stab_ename(curoutstab));
- str_cat(stab_val(stab),"_TOP");
- }
- break;
- case '~':
- s = stab_io(curoutstab)->fmt_name;
- if (!s)
- s = stab_ename(curoutstab);
- str_set(stab_val(stab),s);
- break;
-#ifndef lint
- case '=':
- str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
- break;
- case '-':
- str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
- break;
- case '%':
- str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
- break;
-#endif
- case ':':
- break;
- case '/':
- break;
- case '[':
- str_numset(stab_val(stab),(double)arybase);
- break;
- case '|':
- if (!stab_io(curoutstab))
- stab_io(curoutstab) = stio_new();
- str_numset(stab_val(stab),
- (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
- break;
- case ',':
- str_nset(stab_val(stab),ofs,ofslen);
- break;
- case '\\':
- str_nset(stab_val(stab),ors,orslen);
- break;
- case '#':
- str_set(stab_val(stab),ofmt);
- break;
- case '!':
- str_numset(stab_val(stab), (double)errno);
- str_set(stab_val(stab), errno ? strerror(errno) : "");
- stab_val(stab)->str_nok = 1; /* what a wonderful hack! */
- break;
- case '<':
- str_numset(stab_val(stab),(double)uid);
- break;
- case '>':
- str_numset(stab_val(stab),(double)euid);
- break;
- case '(':
- s = buf;
- (void)sprintf(s,"%d",(int)gid);
- goto add_groups;
- case ')':
- s = buf;
- (void)sprintf(s,"%d",(int)egid);
- add_groups:
- while (*s) s++;
-#ifdef HAS_GETGROUPS
-#ifndef NGROUPS
-#define NGROUPS 32
-#endif
- {
- GROUPSTYPE gary[NGROUPS];
-
- i = getgroups(NGROUPS,gary);
- while (--i >= 0) {
- (void)sprintf(s," %ld", (long)gary[i]);
- while (*s) s++;
- }
- }
-#endif
- str_set(stab_val(stab),buf);
- break;
- case '*':
- break;
- case '0':
- break;
- default:
- {
- struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
-
- if (uf && uf->uf_val)
- (*uf->uf_val)(uf->uf_index, stab_val(stab));
- }
- break;
- }
- return stab_val(stab);
-}
-
-STRLEN
-stab_len(str)
-STR *str;
-{
- STAB *stab = str->str_u.str_stab;
- int paren;
- int i;
- char *s;
-
- if (str->str_rare)
- return str_len(stab_val(stab));
-
- switch (*stab->str_magic->str_ptr) {
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9': case '&':
- if (curspat) {
- paren = atoi(stab_ename(stab));
- getparen:
- if (curspat->spat_regexp &&
- paren <= curspat->spat_regexp->nparens &&
- (s = curspat->spat_regexp->startp[paren]) ) {
- i = curspat->spat_regexp->endp[paren] - s;
- if (i >= 0)
- return i;
- else
- return 0;
- }
- else
- return 0;
- }
- break;
- case '+':
- if (curspat) {
- paren = curspat->spat_regexp->lastparen;
- goto getparen;
- }
- break;
- case '`':
- if (curspat) {
- if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->subbeg) ) {
- i = curspat->spat_regexp->startp[0] - s;
- if (i >= 0)
- return i;
- else
- return 0;
- }
- else
- return 0;
- }
- break;
- case '\'':
- if (curspat) {
- if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->endp[0]) ) {
- return (STRLEN) (curspat->spat_regexp->subend - s);
- }
- else
- return 0;
- }
- break;
- case ',':
- return (STRLEN)ofslen;
- case '\\':
- return (STRLEN)orslen;
- default:
- return str_len(stab_str(str));
- }
-}
-
-void
-stabset(mstr,str)
-register STR *mstr;
-STR *str;
-{
- STAB *stab;
- register char *s;
- int i;
-
- switch (mstr->str_rare) {
- case 'E':
- my_setenv(mstr->str_ptr,str_get(str));
- /* And you'll never guess what the dog had */
- /* in its mouth... */
-#ifdef TAINT
- if (strEQ(mstr->str_ptr,"PATH")) {
- char *strend = str->str_ptr + str->str_cur;
-
- s = str->str_ptr;
- while (s < strend) {
- s = cpytill(tokenbuf,s,strend,':',&i);
- s++;
- if (*tokenbuf != '/'
- || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
- str->str_tainted = 2;
- }
- }
-#endif
- break;
- case 'S':
- s = str_get(str);
- i = whichsig(mstr->str_ptr); /* ...no, a brick */
- if (!i && (dowarn || strEQ(mstr->str_ptr,"ALARM")))
- warn("No such signal: SIG%s", mstr->str_ptr);
- if (strEQ(s,"IGNORE"))
-#ifndef lint
- (void)signal(i,SIG_IGN);
-#else
- ;
-#endif
- else if (strEQ(s,"DEFAULT") || !*s)
- (void)signal(i,SIG_DFL);
- else {
- (void)signal(i,sighandler);
- if (!index(s,'\'')) {
- sprintf(tokenbuf, "main'%s",s);
- str_set(str,tokenbuf);
- }
- }
- break;
-#ifdef SOME_DBM
- case 'D':
- stab = mstr->str_u.str_stab;
- hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
- break;
-#endif
- case 'L':
- {
- CMD *cmd;
-
- stab = mstr->str_u.str_stab;
- i = str_true(str);
- str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
- if (str->str_magic && (cmd = str->str_magic->str_u.str_cmd)) {
- cmd->c_flags &= ~CF_OPTIMIZE;
- cmd->c_flags |= i? CFT_D1 : CFT_D0;
- }
- else
- warn("Can't break at that line\n");
- }
- break;
- case '#':
- stab = mstr->str_u.str_stab;
- afill(stab_array(stab), (int)str_gnum(str) - arybase);
- break;
- case 'X': /* merely a copy of a * string */
- break;
- case '*':
- s = str->str_pok ? str_get(str) : "";
- if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
- stab = mstr->str_u.str_stab;
- if (!*s) {
- STBP *stbp;
-
- /*SUPPRESS 701*/
- (void)savenostab(stab); /* schedule a free of this stab */
- if (stab->str_len)
- Safefree(stab->str_ptr);
- Newz(601,stbp, 1, STBP);
- stab->str_ptr = stbp;
- stab->str_len = stab->str_cur = sizeof(STBP);
- stab->str_pok = 1;
- strcpy(stab_magic(stab),"StB");
- stab_val(stab) = Str_new(70,0);
- stab_line(stab) = curcmd->c_line;
- stab_estab(stab) = stab;
- }
- else {
- stab = stabent(s,TRUE);
- if (!stab_xarray(stab))
- aadd(stab);
- if (!stab_xhash(stab))
- hadd(stab);
- if (!stab_io(stab))
- stab_io(stab) = stio_new();
- }
- str_sset(str, (STR*) stab);
- }
- break;
- case 's': {
- struct lstring *lstr = (struct lstring*)str;
- char *tmps;
-
- mstr->str_rare = 0;
- str->str_magic = Nullstr;
- tmps = str_get(str);
- str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
- tmps,str->str_cur);
- }
- break;
-
- case 'v':
- do_vecset(mstr,str);
- break;
-
- case 0:
- /*SUPPRESS 560*/
- if (!(stab = mstr->str_u.str_stab))
- break;
- switch (*stab->str_magic->str_ptr) {
- case '\004': /* ^D */
-#ifdef DEBUGGING
- debug = (int)(str_gnum(str)) | 32768;
- if (debug & 1024)
- dump_all();
-#endif
- break;
- case '\006': /* ^F */
- maxsysfd = (int)str_gnum(str);
- break;
- case '\t': /* ^I */
- if (inplace)
- Safefree(inplace);
- if (str->str_pok || str->str_nok)
- inplace = savestr(str_get(str));
- else
- inplace = Nullch;
- break;
- case '\020': /* ^P */
- i = (int)str_gnum(str);
- if (i != perldb) {
- static SPAT *oldlastspat;
-
- if (perldb)
- oldlastspat = lastspat;
- else
- lastspat = oldlastspat;
- }
- perldb = i;
- break;
- case '\024': /* ^T */
- basetime = (time_t)str_gnum(str);
- break;
- case '\027': /* ^W */
- dowarn = (bool)str_gnum(str);
- break;
- case '.':
- if (localizing)
- savesptr((STR**)&last_in_stab);
- break;
- case '^':
- Safefree(stab_io(curoutstab)->top_name);
- stab_io(curoutstab)->top_name = s = savestr(str_get(str));
- stab_io(curoutstab)->top_stab = stabent(s,TRUE);
- break;
- case '~':
- Safefree(stab_io(curoutstab)->fmt_name);
- stab_io(curoutstab)->fmt_name = s = savestr(str_get(str));
- stab_io(curoutstab)->fmt_stab = stabent(s,TRUE);
- break;
- case '=':
- stab_io(curoutstab)->page_len = (long)str_gnum(str);
- break;
- case '-':
- stab_io(curoutstab)->lines_left = (long)str_gnum(str);
- if (stab_io(curoutstab)->lines_left < 0L)
- stab_io(curoutstab)->lines_left = 0L;
- break;
- case '%':
- stab_io(curoutstab)->page = (long)str_gnum(str);
- break;
- case '|':
- if (!stab_io(curoutstab))
- stab_io(curoutstab) = stio_new();
- stab_io(curoutstab)->flags &= ~IOF_FLUSH;
- if (str_gnum(str) != 0.0) {
- stab_io(curoutstab)->flags |= IOF_FLUSH;
- }
- break;
- case '*':
- i = (int)str_gnum(str);
- multiline = (i != 0);
- break;
- case '/':
- if (str->str_pok) {
- rs = str_get(str);
- rslen = str->str_cur;
- if (rspara = !rslen) {
- rs = "\n\n";
- rslen = 2;
- }
- rschar = rs[rslen - 1];
- }
- else {
- rschar = 0777; /* fake a non-existent char */
- rslen = 1;
- }
- break;
- case '\\':
- if (ors)
- Safefree(ors);
- ors = savestr(str_get(str));
- orslen = str->str_cur;
- break;
- case ',':
- if (ofs)
- Safefree(ofs);
- ofs = savestr(str_get(str));
- ofslen = str->str_cur;
- break;
- case '#':
- if (ofmt)
- Safefree(ofmt);
- ofmt = savestr(str_get(str));
- break;
- case '[':
- arybase = (int)str_gnum(str);
- break;
- case '?':
- statusvalue = U_S(str_gnum(str));
- break;
- case '!':
- errno = (int)str_gnum(str); /* will anyone ever use this? */
- break;
- case '<':
- uid = (int)str_gnum(str);
- if (delaymagic) {
- delaymagic |= DM_RUID;
- break; /* don't do magic till later */
- }
-#ifdef HAS_SETRUID
- (void)setruid((UIDTYPE)uid);
-#else
-#ifdef HAS_SETREUID
- (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1);
-#else
- if (uid == euid) /* special case $< = $> */
- (void)setuid(uid);
- else
- fatal("setruid() not implemented");
-#endif
-#endif
- uid = (int)getuid();
- break;
- case '>':
- euid = (int)str_gnum(str);
- if (delaymagic) {
- delaymagic |= DM_EUID;
- break; /* don't do magic till later */
- }
-#ifdef HAS_SETEUID
- (void)seteuid((UIDTYPE)euid);
-#else
-#ifdef HAS_SETREUID
- (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid);
-#else
- if (euid == uid) /* special case $> = $< */
- setuid(euid);
- else
- fatal("seteuid() not implemented");
-#endif
-#endif
- euid = (int)geteuid();
- break;
- case '(':
- gid = (int)str_gnum(str);
- if (delaymagic) {
- delaymagic |= DM_RGID;
- break; /* don't do magic till later */
- }
-#ifdef HAS_SETRGID
- (void)setrgid((GIDTYPE)gid);
-#else
-#ifdef HAS_SETREGID
- (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
-#else
- if (gid == egid) /* special case $( = $) */
- (void)setgid(gid);
- else
- fatal("setrgid() not implemented");
-#endif
-#endif
- gid = (int)getgid();
- break;
- case ')':
- egid = (int)str_gnum(str);
- if (delaymagic) {
- delaymagic |= DM_EGID;
- break; /* don't do magic till later */
- }
-#ifdef HAS_SETEGID
- (void)setegid((GIDTYPE)egid);
-#else
-#ifdef HAS_SETREGID
- (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
-#else
- if (egid == gid) /* special case $) = $( */
- (void)setgid(egid);
- else
- fatal("setegid() not implemented");
-#endif
-#endif
- egid = (int)getegid();
- break;
- case ':':
- chopset = str_get(str);
- break;
- case '0':
- if (!origalen) {
- s = origargv[0];
- s += strlen(s);
- /* See if all the arguments are contiguous in memory */
- for (i = 1; i < origargc; i++) {
- if (origargv[i] == s + 1)
- s += strlen(++s); /* this one is ok too */
- }
- if (origenviron[0] == s + 1) { /* can grab env area too? */
- my_setenv("NoNeSuCh", Nullch);
- /* force copy of environment */
- for (i = 0; origenviron[i]; i++)
- if (origenviron[i] == s + 1)
- s += strlen(++s);
- }
- origalen = s - origargv[0];
- }
- s = str_get(str);
- i = str->str_cur;
- if (i >= origalen) {
- i = origalen;
- str->str_cur = i;
- str->str_ptr[i] = '\0';
- Copy(s, origargv[0], i, char);
- }
- else {
- Copy(s, origargv[0], i, char);
- s = origargv[0]+i;
- *s++ = '\0';
- while (++i < origalen)
- *s++ = ' ';
- }
- break;
- default:
- {
- struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
-
- if (uf && uf->uf_set)
- (*uf->uf_set)(uf->uf_index, str);
- }
- break;
- }
- break;
- }
-}
-
-int
-whichsig(sig)
-char *sig;
-{
- register char **sigv;
-
- for (sigv = sig_name+1; *sigv; sigv++)
- if (strEQ(sig,*sigv))
- return sigv - sig_name;
-#ifdef SIGCLD
- if (strEQ(sig,"CHLD"))
- return SIGCLD;
-#endif
-#ifdef SIGCHLD
- if (strEQ(sig,"CLD"))
- return SIGCHLD;
-#endif
- return 0;
-}
-
-static handlertype
-sighandler(sig)
-int sig;
-{
- STAB *stab;
- STR *str;
- int oldsave = savestack->ary_fill;
- int oldtmps_base = tmps_base;
- register CSV *csv;
- SUBR *sub;
-
-#ifdef OS2 /* or anybody else who requires SIG_ACK */
- signal(sig, SIG_ACK);
-#endif
- stab = stabent(
- str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
- TRUE)), TRUE);
- sub = stab_sub(stab);
- if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
- if (sig_name[sig][1] == 'H')
- stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)),
- TRUE);
- else
- stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)),
- TRUE);
- sub = stab_sub(stab); /* gag */
- }
- if (!sub) {
- if (dowarn)
- warn("SIG%s handler \"%s\" not defined.\n",
- sig_name[sig], stab_ename(stab) );
- return;
- }
- /*SUPPRESS 701*/
- saveaptr(&stack);
- str = Str_new(15, sizeof(CSV));
- str->str_state = SS_SCSV;
- (void)apush(savestack,str);
- csv = (CSV*)str->str_ptr;
- csv->sub = sub;
- csv->stab = stab;
- csv->curcsv = curcsv;
- csv->curcmd = curcmd;
- csv->depth = sub->depth;
- csv->wantarray = G_SCALAR;
- csv->hasargs = TRUE;
- csv->savearray = stab_xarray(defstab);
- csv->argarray = stab_xarray(defstab) = stack = anew(defstab);
- stack->ary_flags = 0;
- curcsv = csv;
- str = str_mortal(&str_undef);
- str_set(str,sig_name[sig]);
- (void)apush(stab_xarray(defstab),str);
- sub->depth++;
- if (sub->depth >= 2) { /* save temporaries on recursion? */
- if (sub->depth == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",stab_ename(stab));
- savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
- }
-
- tmps_base = tmps_max; /* protect our mortal string */
- (void)cmd_exec(sub->cmd,G_SCALAR,0); /* so do it already */
- tmps_base = oldtmps_base;
-
- restorelist(oldsave); /* put everything back */
-}
-
-STAB *
-aadd(stab)
-register STAB *stab;
-{
- if (!stab_xarray(stab))
- stab_xarray(stab) = anew(stab);
- return stab;
-}
-
-STAB *
-hadd(stab)
-register STAB *stab;
-{
- if (!stab_xhash(stab))
- stab_xhash(stab) = hnew(COEFFSIZE);
- return stab;
-}
-
-STAB *
-fstab(name)
-char *name;
-{
- char tmpbuf[1200];
- STAB *stab;
-
- sprintf(tmpbuf,"'_<%s", name);
- stab = stabent(tmpbuf, TRUE);
- str_set(stab_val(stab), name);
- if (perldb)
- (void)hadd(aadd(stab));
- return stab;
-}
-
-STAB *
-stabent(name,add)
-register char *name;
-int add;
-{
- register STAB *stab;
- register STBP *stbp;
- int len;
- register char *namend;
- HASH *stash;
- char *sawquote = Nullch;
- char *prevquote = Nullch;
- bool global = FALSE;
-
- if (isUPPER(*name)) {
- if (*name > 'I') {
- if (*name == 'S' && (
- strEQ(name, "SIG") ||
- strEQ(name, "STDIN") ||
- strEQ(name, "STDOUT") ||
- strEQ(name, "STDERR") ))
- global = TRUE;
- }
- else if (*name > 'E') {
- if (*name == 'I' && strEQ(name, "INC"))
- global = TRUE;
- }
- else if (*name > 'A') {
- if (*name == 'E' && strEQ(name, "ENV"))
- global = TRUE;
- }
- else if (*name == 'A' && (
- strEQ(name, "ARGV") ||
- strEQ(name, "ARGVOUT") ))
- global = TRUE;
- }
- for (namend = name; *namend; namend++) {
- if (*namend == '\'' && namend[1])
- prevquote = sawquote, sawquote = namend;
- }
- if (sawquote == name && name[1]) {
- stash = defstash;
- sawquote = Nullch;
- name++;
- }
- else if (!isALPHA(*name) || global)
- stash = defstash;
- else if ((CMD*)curcmd == &compiling)
- stash = curstash;
- else
- stash = curcmd->c_stash;
- if (sawquote) {
- char tmpbuf[256];
- char *s, *d;
-
- *sawquote = '\0';
- /*SUPPRESS 560*/
- if (s = prevquote) {
- strncpy(tmpbuf,name,s-name+1);
- d = tmpbuf+(s-name+1);
- *d++ = '_';
- strcpy(d,s+1);
- }
- else {
- *tmpbuf = '_';
- strcpy(tmpbuf+1,name);
- }
- stab = stabent(tmpbuf,TRUE);
- if (!(stash = stab_xhash(stab)))
- stash = stab_xhash(stab) = hnew(0);
- if (!stash->tbl_name)
- stash->tbl_name = savestr(name);
- name = sawquote+1;
- *sawquote = '\'';
- }
- len = namend - name;
- stab = (STAB*)hfetch(stash,name,len,add);
- if (stab == (STAB*)&str_undef)
- return Nullstab;
- if (stab->str_pok) {
- stab->str_pok |= SP_MULTI;
- return stab;
- }
- else {
- if (stab->str_len)
- Safefree(stab->str_ptr);
- Newz(602,stbp, 1, STBP);
- stab->str_ptr = stbp;
- stab->str_len = stab->str_cur = sizeof(STBP);
- stab->str_pok = 1;
- strcpy(stab_magic(stab),"StB");
- stab_val(stab) = Str_new(72,0);
- stab_line(stab) = curcmd->c_line;
- stab_estab(stab) = stab;
- str_magic((STR*)stab, stab, '*', name, len);
- stab_stash(stab) = stash;
- if (isDIGIT(*name) && *name != '0') {
- stab_flags(stab) = SF_VMAGIC;
- str_magic(stab_val(stab), stab, 0, Nullch, 0);
- }
- if (add & 2)
- stab->str_pok |= SP_MULTI;
- return stab;
- }
-}
-
-void
-stab_fullname(str,stab)
-STR *str;
-STAB *stab;
-{
- HASH *tb = stab_stash(stab);
-
- if (!tb)
- return;
- str_set(str,tb->tbl_name);
- str_ncat(str,"'", 1);
- str_scat(str,stab->str_magic);
-}
-
-void
-stab_efullname(str,stab)
-STR *str;
-STAB *stab;
-{
- HASH *tb = stab_estash(stab);
-
- if (!tb)
- return;
- str_set(str,tb->tbl_name);
- str_ncat(str,"'", 1);
- str_scat(str,stab_estab(stab)->str_magic);
-}
-
-STIO *
-stio_new()
-{
- STIO *stio;
-
- Newz(603,stio,1,STIO);
- stio->page_len = 60;
- return stio;
-}
-
-void
-stab_check(min,max)
-int min;
-register int max;
-{
- register HENT *entry;
- register int i;
- register STAB *stab;
-
- for (i = min; i <= max; i++) {
- for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
- stab = (STAB*)entry->hent_val;
- if (stab->str_pok & SP_MULTI)
- continue;
- curcmd->c_line = stab_line(stab);
- warn("Possible typo: \"%s\"", stab_name(stab));
- }
- }
-}
-
-static int gensym = 0;
-
-STAB *
-genstab()
-{
- (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
- return stabent(tokenbuf,TRUE);
-}
-
-/* hopefully this is only called on local symbol table entries */
-
-void
-stab_clear(stab)
-register STAB *stab;
-{
- STIO *stio;
- SUBR *sub;
-
- if (!stab || !stab->str_ptr)
- return;
- afree(stab_xarray(stab));
- stab_xarray(stab) = Null(ARRAY*);
- (void)hfree(stab_xhash(stab), FALSE);
- stab_xhash(stab) = Null(HASH*);
- str_free(stab_val(stab));
- stab_val(stab) = Nullstr;
- /*SUPPRESS 560*/
- if (stio = stab_io(stab)) {
- do_close(stab,FALSE);
- Safefree(stio->top_name);
- Safefree(stio->fmt_name);
- Safefree(stio);
- }
- /*SUPPRESS 560*/
- if (sub = stab_sub(stab)) {
- afree(sub->tosave);
- cmd_free(sub->cmd);
- }
- Safefree(stab->str_ptr);
- stab->str_ptr = Null(STBP*);
- stab->str_len = 0;
- stab->str_cur = 0;
-}
-
-#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
-#define MICROPORT
-#endif
-
-#ifdef MICROPORT /* Microport 2.4 hack */
-ARRAY *stab_array(stab)
-register STAB *stab;
-{
- if (((STBP*)(stab->str_ptr))->stbp_array)
- return ((STBP*)(stab->str_ptr))->stbp_array;
- else
- return ((STBP*)(aadd(stab)->str_ptr))->stbp_array;
-}
-
-HASH *stab_hash(stab)
-register STAB *stab;
-{
- if (((STBP*)(stab->str_ptr))->stbp_hash)
- return ((STBP*)(stab->str_ptr))->stbp_hash;
- else
- return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash;
-}
-#endif /* Microport 2.4 hack */
+++ /dev/null
-***************
-*** 1,4 ****
-! /* $RCSfile: stab.c,v $$Revision: 4.0.1.4 $$Date: 1992/06/08 15:32:19 $
- *
- * Copyright (c) 1991, Larry Wall
- *
---- 1,4 ----
-! /* $RCSfile: stab.c,v $$Revision: 4.0.1.5 $$Date: 1993/02/05 19:42:47 $
- *
- * Copyright (c) 1991, Larry Wall
- *
-***************
-*** 6,18 ****
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: stab.c,v $
-! * Revision 4.0.1.4 1992/06/08 15:32:19 lwall
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: the debugger now warns you on lines that can't set a breakpoint
- * patch20: the debugger made perl forget the last pattern used by //
- * patch20: paragraph mode now skips extra newlines automatically
- * patch20: ($<,$>) = ... didn't work on some architectures
-! *
- * Revision 4.0.1.3 91/11/05 18:35:33 lwall
- * patch11: length($x) was sometimes wrong for numeric $x
- * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
---- 6,21 ----
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: stab.c,v $
-! * Revision 4.0.1.5 1993/02/05 19:42:47 lwall
-! * patch36: length returned wrong value on certain semi-magical variables
-! *
-! * Revision 4.0.1.4 92/06/08 15:32:19 lwall
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: the debugger now warns you on lines that can't set a breakpoint
- * patch20: the debugger made perl forget the last pattern used by //
- * patch20: paragraph mode now skips extra newlines automatically
- * patch20: ($<,$>) = ... didn't work on some architectures
-! *
- * Revision 4.0.1.3 91/11/05 18:35:33 lwall
- * patch11: length($x) was sometimes wrong for numeric $x
- * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
+++ /dev/null
-/* $RCSfile: stab.h,v $$Revision: 4.0.1.3 $$Date: 92/06/08 15:33:44 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: stab.h,v $
- * Revision 4.0.1.3 92/06/08 15:33:44 lwall
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: ($<,$>) = ... didn't work on some architectures
- *
- * Revision 4.0.1.2 91/11/05 18:36:15 lwall
- * patch11: length($x) was sometimes wrong for numeric $x
- *
- * Revision 4.0.1.1 91/06/07 11:56:35 lwall
- * patch4: new copyright notice
- * patch4: length($`), length($&), length($') now optimized to avoid string copy
- *
- * Revision 4.0 91/03/20 01:39:49 lwall
- * 4.0 baseline.
- *
- */
-
-struct stabptrs {
- char stbp_magic[4];
- STR *stbp_val; /* scalar value */
- struct stio *stbp_io; /* filehandle value */
- FCMD *stbp_form; /* format value */
- ARRAY *stbp_array; /* array value */
- HASH *stbp_hash; /* associative array value */
- STAB *stbp_stab; /* effective stab, if *glob */
- SUBR *stbp_sub; /* subroutine value */
- int stbp_lastexpr; /* used by nothing_in_common() */
- line_t stbp_line; /* line first declared at (for -w) */
- char stbp_flags;
-};
-
-#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
-#define MICROPORT
-#endif
-
-#define stab_magic(stab) (((STBP*)(stab->str_ptr))->stbp_magic)
-#define stab_val(stab) (((STBP*)(stab->str_ptr))->stbp_val)
-#define stab_io(stab) (((STBP*)(stab->str_ptr))->stbp_io)
-#define stab_form(stab) (((STBP*)(stab->str_ptr))->stbp_form)
-#define stab_xarray(stab) (((STBP*)(stab->str_ptr))->stbp_array)
-#ifdef MICROPORT /* Microport 2.4 hack */
-ARRAY *stab_array();
-#else
-#define stab_array(stab) (((STBP*)(stab->str_ptr))->stbp_array ? \
- ((STBP*)(stab->str_ptr))->stbp_array : \
- ((STBP*)(aadd(stab)->str_ptr))->stbp_array)
-#endif
-#define stab_xhash(stab) (((STBP*)(stab->str_ptr))->stbp_hash)
-#ifdef MICROPORT /* Microport 2.4 hack */
-HASH *stab_hash();
-#else
-#define stab_hash(stab) (((STBP*)(stab->str_ptr))->stbp_hash ? \
- ((STBP*)(stab->str_ptr))->stbp_hash : \
- ((STBP*)(hadd(stab)->str_ptr))->stbp_hash)
-#endif /* Microport 2.4 hack */
-#define stab_sub(stab) (((STBP*)(stab->str_ptr))->stbp_sub)
-#define stab_lastexpr(stab) (((STBP*)(stab->str_ptr))->stbp_lastexpr)
-#define stab_line(stab) (((STBP*)(stab->str_ptr))->stbp_line)
-#define stab_flags(stab) (((STBP*)(stab->str_ptr))->stbp_flags)
-
-#define stab_stab(stab) (stab->str_magic->str_u.str_stab)
-#define stab_estab(stab) (((STBP*)(stab->str_ptr))->stbp_stab)
-
-#define stab_name(stab) (stab->str_magic->str_ptr)
-#define stab_ename(stab) stab_name(stab_estab(stab))
-
-#define stab_stash(stab) (stab->str_magic->str_u.str_stash)
-#define stab_estash(stab) stab_stash(stab_estab(stab))
-
-#define SF_VMAGIC 1 /* call routine to dereference STR val */
-#define SF_MULTI 2 /* seen more than once */
-
-struct stio {
- FILE *ifp; /* ifp and ofp are normally the same */
- FILE *ofp; /* but sockets need separate streams */
-#ifdef HAS_READDIR
- DIR *dirp; /* for opendir, readdir, etc */
-#endif
- long lines; /* $. */
- long page; /* $% */
- long page_len; /* $= */
- long lines_left; /* $- */
- char *top_name; /* $^ */
- STAB *top_stab; /* $^ */
- char *fmt_name; /* $~ */
- STAB *fmt_stab; /* $~ */
- short subprocess; /* -| or |- */
- char type;
- char flags;
-};
-
-#define IOF_ARGV 1 /* this fp iterates over ARGV */
-#define IOF_START 2 /* check for null ARGV and substitute '-' */
-#define IOF_FLUSH 4 /* this fp wants a flush after write op */
-
-struct sub {
- CMD *cmd;
- int (*usersub)();
- int userindex;
- STAB *filestab;
- long depth; /* >= 2 indicates recursive call */
- ARRAY *tosave;
-};
-
-#define Nullstab Null(STAB*)
-
-STRLEN stab_len();
-
-#define STAB_STR(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_str(stab_val(tmpstab)->str_magic) : stab_val(tmpstab))
-#define STAB_LEN(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_len(stab_val(tmpstab)->str_magic) : str_len(stab_val(tmpstab)))
-#define STAB_GET(s) (tmpstab = (s), str_get(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
-#define STAB_GNUM(s) (tmpstab = (s), str_gnum(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
-
-EXT STAB *tmpstab;
-
-EXT STAB *stab_index[128];
-
-EXT unsigned short statusvalue;
-
-EXT int delaymagic INIT(0);
-#define DM_UID 0x003
-#define DM_RUID 0x001
-#define DM_EUID 0x002
-#define DM_GID 0x030
-#define DM_RGID 0x010
-#define DM_EGID 0x020
-#define DM_DELAY 0x100
-
-STAB *aadd();
-STAB *hadd();
-STAB *fstab();
-void stabset();
-void stab_fullname();
-void stab_efullname();
-void stab_check();
+++ /dev/null
-/* $RCSfile: str.c,v $$Revision: 4.0.1.6 $$Date: 92/06/11 21:14:21 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: str.c,v $
- * Revision 4.0.1.6 92/06/11 21:14:21 lwall
- * patch34: quotes containing subscripts containing variables didn't parse right
- *
- * Revision 4.0.1.5 92/06/08 15:40:43 lwall
- * patch20: removed implicit int declarations on functions
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- * patch20: paragraph mode now skips extra newlines automatically
- * patch20: fixed memory leak in doube-quote interpretation
- * patch20: made /\$$foo/ look for literal '$foo'
- * patch20: "$var{$foo'bar}" didn't scan subscript correctly
- * patch20: a splice on non-existent array elements could dump core
- * patch20: running taintperl explicitly now does checks even if $< == $>
- *
- * Revision 4.0.1.4 91/11/05 18:40:51 lwall
- * patch11: $foo .= <BAR> could overrun malloced memory
- * patch11: \$ didn't always make it through double-quoter to regexp routines
- * patch11: prepared for ctype implementations that don't define isascii()
- *
- * Revision 4.0.1.3 91/06/10 01:27:54 lwall
- * patch10: $) and $| incorrectly handled in run-time patterns
- *
- * Revision 4.0.1.2 91/06/07 11:58:13 lwall
- * patch4: new copyright notice
- * patch4: taint check on undefined string could cause core dump
- *
- * Revision 4.0.1.1 91/04/12 09:15:30 lwall
- * patch1: fixed undefined environ problem
- * patch1: substr($ENV{"PATH"},0,0) = "/foo:" didn't modify environment
- * patch1: $foo .= <BAR> could cause core dump for certain lengths of $foo
- *
- * Revision 4.0 91/03/20 01:39:55 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "perly.h"
-
-static void ucase();
-static void lcase();
-
-#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
-int
-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;
-#ifndef DOSISH
-register int newlen;
-#else
-unsigned long newlen;
-#endif
-{
- register char *s = str->str_ptr;
-
-#ifdef MSDOS
- if (newlen >= 0x10000) {
- fprintf(stderr, "Allocation too large: %lx\n", newlen);
- exit(1);
- }
-#endif /* MSDOS */
- 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;
- Move(s, str->str_ptr, str->str_cur+1, char);
- 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;
-}
-
-void
-str_numset(str,num)
-register STR *str;
-double num;
-{
- if (str->str_pok) {
- str->str_pok = 0; /* invalidate pointer */
- if (str->str_state == SS_INCR)
- Str_Grow(str,0);
- }
- str->str_u.str_nval = num;
- str->str_state = SS_NORM;
- 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) {
- STR_GROW(str, 30);
- 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");
- STR_GROW(str, 30);
- 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;
- if (str->str_state == SS_INCR)
- Str_Grow(str,0); /* just force copy down */
- 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;
-}
-
-/* Note: str_sset() should not be called with a source string that needs
- * be reused, since it may destroy the source string if it is marked
- * as temporary.
- */
-
-void
-str_sset(dstr,sstr)
-STR *dstr;
-register STR *sstr;
-{
-#ifdef TAINT
- if (sstr)
- tainted |= sstr->str_tainted;
-#endif
- if (sstr == dstr || dstr == &str_undef)
- return;
- if (!sstr)
- dstr->str_pok = dstr->str_nok = 0;
- else if (sstr->str_pok) {
-
- /*
- * Check to see if we can just swipe the string. If so, it's a
- * possible small lose on short strings, but a big win on long ones.
- * It might even be a win on short strings if dstr->str_ptr
- * has to be allocated and sstr->str_ptr has to be freed.
- */
-
- if (sstr->str_pok & SP_TEMP) { /* slated for free anyway? */
- if (dstr->str_ptr) {
- if (dstr->str_state == SS_INCR)
- dstr->str_ptr -= dstr->str_u.str_useful;
- Safefree(dstr->str_ptr);
- }
- dstr->str_ptr = sstr->str_ptr;
- dstr->str_len = sstr->str_len;
- dstr->str_cur = sstr->str_cur;
- dstr->str_state = sstr->str_state;
- dstr->str_pok = sstr->str_pok & ~SP_TEMP;
-#ifdef TAINT
- dstr->str_tainted = sstr->str_tainted;
-#endif
- sstr->str_ptr = Nullch;
- sstr->str_len = 0;
- sstr->str_pok = 0; /* wipe out any weird flags */
- sstr->str_state = 0; /* so sstr frees uneventfully */
- }
- else { /* have to copy actual string */
- if (dstr->str_ptr) {
- if (dstr->str_state == SS_INCR) {
- Str_Grow(dstr,0);
- }
- }
- str_nset(dstr,sstr->str_ptr,sstr->str_cur);
- }
- /*SUPPRESS 560*/
- if (dstr->str_nok = sstr->str_nok)
- dstr->str_u.str_nval = 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
- if (dstr->str_cur == sizeof(STBP)) {
- char *tmps = dstr->str_ptr;
-
- if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) {
- if (dstr->str_magic && dstr->str_magic->str_rare == 'X') {
- str_free(dstr->str_magic);
- dstr->str_magic = Nullstr;
- }
- if (!dstr->str_magic) {
- 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 {
- if (dstr->str_state == SS_INCR)
- Str_Grow(dstr,0); /* just force copy down */
-
-#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;
- }
-}
-
-void
-str_nset(str,ptr,len)
-register STR *str;
-register char *ptr;
-register STRLEN len;
-{
- if (str == &str_undef)
- return;
- STR_GROW(str, len + 1);
- if (ptr)
- Move(ptr,str->str_ptr,len,char);
- 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
-}
-
-void
-str_set(str,ptr)
-register STR *str;
-register char *ptr;
-{
- register STRLEN len;
-
- if (str == &str_undef)
- return;
- if (!ptr)
- ptr = "";
- len = strlen(ptr);
- STR_GROW(str, len + 1);
- Move(ptr,str->str_ptr,len+1,char);
- str->str_cur = len;
- str->str_nok = 0; /* invalidate number */
- str->str_pok = 1; /* validate pointer */
-#ifdef TAINT
- str->str_tainted = tainted;
-#endif
-}
-
-void
-str_chop(str,ptr) /* like set but assuming ptr is in str */
-register STR *str;
-register char *ptr;
-{
- register STRLEN delta;
-
- if (!ptr || !(str->str_pok))
- return;
- 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) */
-}
-
-void
-str_ncat(str,ptr,len)
-register STR *str;
-register char *ptr;
-register STRLEN len;
-{
- if (str == &str_undef)
- return;
- if (!(str->str_pok))
- (void)str_2ptr(str);
- STR_GROW(str, str->str_cur + len + 1);
- Move(ptr,str->str_ptr+str->str_cur,len,char);
- 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
-}
-
-void
-str_scat(dstr,sstr)
-STR *dstr;
-register STR *sstr;
-{
- if (!sstr)
- return;
-#ifdef TAINT
- tainted |= sstr->str_tainted;
-#endif
- if (!(sstr->str_pok))
- (void)str_2ptr(sstr);
- if (sstr)
- str_ncat(dstr,sstr->str_ptr,sstr->str_cur);
-}
-
-void
-str_cat(str,ptr)
-register STR *str;
-register char *ptr;
-{
- register STRLEN len;
-
- if (str == &str_undef)
- return;
- if (!ptr)
- return;
- if (!(str->str_pok))
- (void)str_2ptr(str);
- len = strlen(ptr);
- STR_GROW(str, str->str_cur + len + 1);
- Move(ptr,str->str_ptr+str->str_cur,len+1,char);
- 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 STRLEN len;
-
- if (str == &str_undef)
- return Nullch;
- 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
-STRLEN 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;
-STRLEN namlen;
-{
- if (str == &str_undef || 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;
-STRLEN offset;
-STRLEN len;
-char *little;
-STRLEN littlelen;
-{
- register char *big;
- register char *mid;
- register char *midend;
- register char *bigend;
- register int i;
-
- if (bigstr == &str_undef)
- return;
- bigstr->str_nok = 0;
- bigstr->str_pok = SP_VALID; /* disable possible screamer */
-
- 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;
- Move(little,big+offset,littlelen,char);
- bigstr->str_cur += i;
- STABSET(bigstr);
- return;
- }
- else if (i == 0) {
- Move(little,bigstr->str_ptr+offset,len,char);
- STABSET(bigstr);
- return;
- }
-
- big = bigstr->str_ptr;
- mid = big + offset;
- midend = mid + len;
- bigend = big + bigstr->str_cur;
-
- if (midend > bigend)
- fatal("panic: str_insert");
-
- if (mid - big > bigend - midend) { /* faster to shorten from end */
- if (littlelen) {
- Move(little, mid, littlelen,char);
- mid += littlelen;
- }
- i = bigend - midend;
- if (i > 0) {
- Move(midend, mid, i,char);
- mid += i;
- }
- *mid = '\0';
- bigstr->str_cur = mid - big;
- }
- /*SUPPRESS 560*/
- 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)
- Move(little, mid, littlelen,char);
- }
- else if (littlelen) {
- midend -= littlelen;
- str_chop(bigstr,midend);
- Move(little,midend,littlelen,char);
- }
- 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_undef)
- return;
- 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
- if (nstr->str_magic)
- str_free(nstr->str_magic);
- Safefree(nstr);
-}
-
-void
-str_free(str)
-register STR *str;
-{
- if (!str || str == &str_undef)
- 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);
- str->str_magic = freestrroot;
-#ifdef LEAKTEST
- if (str->str_len) {
- Safefree(str->str_ptr);
- str->str_ptr = Nullch;
- }
- 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
- freestrroot = str;
-#endif /* LEAKTEST */
-}
-
-STRLEN
-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;
-}
-
-int
-str_eq(str1,str2)
-register STR *str1;
-register STR *str2;
-{
- if (!str1 || str1 == &str_undef)
- return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur);
- if (!str2 || str2 == &str_undef)
- return !str1->str_cur;
-
- 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);
-}
-
-int
-str_cmp(str1,str2)
-register STR *str1;
-register STR *str2;
-{
- int retval;
-
- if (!str1 || str1 == &str_undef)
- return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur)?0:-1;
- if (!str2 || str2 == &str_undef)
- return str1->str_cur != 0;
-
- if (!str1->str_pok)
- (void)str_2ptr(str1);
- if (!str2->str_pok)
- (void)str_2ptr(str2);
-
- if (str1->str_cur < str2->str_cur) {
- /*SUPPRESS 560*/
- if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
- return retval < 0 ? -1 : 1;
- else
- return -1;
- }
- /*SUPPRESS 560*/
- else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
- return retval < 0 ? -1 : 1;
- 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 = rschar;/* (assuming >= 6 registers) */
- int i;
- STRLEN bpx;
- int shortbuffered;
-
- if (str == &str_undef)
- return Nullch;
- if (rspara) { /* have to do this both before and after */
- do { /* to make sure file boundaries work right */
- i = getc(fp);
- if (i != '\n') {
- ungetc(i,fp);
- break;
- }
- } while (i != EOF);
- }
-#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 - append <= cnt + 1) { /* make sure we have the room */
- if (cnt > 80 && str->str_len > append) {
- shortbuffered = cnt - str->str_len + append + 1;
- cnt -= shortbuffered;
- }
- else {
- shortbuffered = 0;
- STR_GROW(str, append+cnt+2);/* (remembering cnt can be -1) */
- }
- }
- else
- shortbuffered = 0;
- 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 :-) */
- }
-
- if (shortbuffered) { /* oh well, must extend */
- cnt = shortbuffered;
- shortbuffered = 0;
- bpx = bp - str->str_ptr; /* prepare for possible relocation */
- str->str_cur = bpx;
- STR_GROW(str, str->str_len + append + cnt + 2);
- bp = str->str_ptr + bpx; /* reconstitute our pointer */
- continue;
- }
-
- 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 */
- str->str_cur = bpx;
- STR_GROW(str, bpx + cnt + 2);
- 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_really_all_folks;
- *bp++ = i; /* now go back to screaming loop */
- }
-
-thats_all_folks:
- if (rslen > 1 && (bp - str->str_ptr < rslen || bcmp(bp - rslen, rs, rslen)))
- goto screamer; /* go back to the fray */
-thats_really_all_folks:
- if (shortbuffered)
- cnt += shortbuffered;
- 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;
- while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) ;
-
- if (append)
- str_ncat(str, buf, bp - buf);
- else
- str_nset(str, buf, bp - buf);
- if (i != EOF /* joy */
- &&
- (i != newline
- ||
- (rslen > 1
- &&
- (str->str_cur < rslen
- ||
- bcmp(str->str_ptr + str->str_cur - rslen, rs, rslen)
- )
- )
- )
- )
- {
- append = -1;
- goto screamer;
- }
- }
-
-#endif /* STDSTDIO */
-
- if (rspara) {
- while (i != EOF) {
- i = getc(fp);
- if (i != '\n') {
- ungetc(i,fp);
- break;
- }
- }
- }
- return str->str_cur - append ? str->str_ptr : Nullch;
-}
-
-ARG *
-parselist(str)
-STR *str;
-{
- register CMD *cmd;
- register ARG *arg;
- CMD *oldcurcmd = curcmd;
- int oldperldb = perldb;
- int retval;
-
- perldb = 0;
- 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--;
- perldb = oldperldb;
- fatal("%s\n",stab_val(stabent("@",TRUE))->str_ptr);
- }
-#ifdef DEBUGGING
- if (debug & 4) {
- char *tmps = loop_stack[loop_ptr].loop_label;
- deb("(Popping label #%d %s)\n",loop_ptr,
- tmps ? tmps : "" );
- }
-#endif
- loop_ptr--;
- error_count = 0;
- curcmd = &compiling;
- curcmd->c_line = oldcurcmd->c_line;
- retval = yyparse();
- curcmd = oldcurcmd;
- perldb = oldperldb;
- 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);
- cmd->c_expr = Nullarg;
- cmd_free(cmd);
- eval_root = Nullcmd;
- 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;
- STRLEN len;
- register int brackets;
- register char *d;
- STAB *stab;
- char *checkpoint;
- int sawcase = 0;
-
- 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("$@[{\\]}lLuUE",s[1])) {
- str_ncat(str, t, s - t);
- ++s;
- if (isALPHA(*s)) {
- str_ncat(str, "$c", 2);
- sawcase = (*s != 'E');
- }
- else {
- if (*nointrp) { /* in a regular expression */
- if (*s == '@') /* always strip \@ */ /*SUPPRESS 530*/
- ;
- else /* don't strip \\, \[, \{ etc. */
- str_ncat(str,s-1,1);
- }
- str_ncat(str, "$b", 2);
- }
- str_ncat(str, s, 1);
- ++s;
- t = s;
- }
- else if (*s == '$' && s+1 < send && *nointrp && index(nointrp,s[1])) {
- str_ncat(str, t, s - t);
- str_ncat(str, "$b", 2);
- str_ncat(str, s, 2);
- s += 2;
- t = s;
- }
- else if ((*s == '@' || *s == '$') && s+1 < send) {
- str_ncat(str,t,s-t);
- t = s;
- if (*s == '$' && s[1] == '#' && (isALPHA(s[2]) || s[2] == '_'))
- s++;
- s = scanident(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 '[':
- brackets++;
- break;
- case '{':
- brackets++;
- break;
- case ']':
- brackets--;
- break;
- case '}':
- brackets--;
- break;
- case '$':
- case '%':
- case '@':
- case '&':
- case '*':
- s = scanident(s,send,tokenbuf);
- continue;
- case '\'':
- case '"':
- /*SUPPRESS 68*/
- 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 (isALNUM(d[1])) {
- d = scanident(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 < (unsigned 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 (sawcase)
- str_ncat(str, "$cE", 3);
- 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;
- int docase = 0;
- int l = 0;
- int u = 0;
- int L = 0;
- int U = 0;
-
- if (str == &str_undef)
- return Nullstr;
- if (!(src->str_pok & SP_INTRP)) {
- int oldsave = savestack->ary_fill;
-
- (void)savehptr(&curstash);
- curstash = curcmd->c_stash; /* 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) {
- if (s-t > 0)
- str_ncat(str,t,s-t);
- switch(*++s) {
- default:
- fatal("panic: unknown interp cookie\n");
- break;
- case 'a':
- str_scat(str,*++elem);
- break;
- case 'b':
- str_ncat(str,++s,1);
- break;
- case 'c':
- if (docase && str->str_cur >= docase) {
- char *b = str->str_ptr + --docase;
-
- if (L)
- lcase(b, str->str_ptr + str->str_cur);
- else if (U)
- ucase(b, str->str_ptr + str->str_cur);
-
- if (u) /* note that l & u are independent of L & U */
- ucase(b, b+1);
- else if (l)
- lcase(b, b+1);
- l = u = 0;
- }
- docase = str->str_cur + 1;
- switch (*++s) {
- case 'u':
- u = 1;
- l = 0;
- break;
- case 'U':
- U = 1;
- L = 0;
- break;
- case 'l':
- l = 1;
- u = 0;
- break;
- case 'L':
- L = 1;
- U = 0;
- break;
- case 'E':
- docase = L = U = l = u = 0;
- break;
- }
- break;
- }
- t = ++s;
- }
- else
- s++;
- }
- if (s-t > 0)
- str_ncat(str,t,s-t);
- return str;
-}
-
-static void
-ucase(s,send)
-register char *s;
-register char *send;
-{
- while (s < send) {
- if (isLOWER(*s))
- *s = toupper(*s);
- s++;
- }
-}
-
-static void
-lcase(s,send)
-register char *s;
-register char *send;
-{
- while (s < send) {
- if (isUPPER(*s))
- *s = tolower(*s);
- s++;
- }
-}
-
-void
-str_inc(str)
-register STR *str;
-{
- register char *d;
-
- if (!str || str == &str_undef)
- 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 || str == &str_undef)
- 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_mortal(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;
- if (str->str_pok)
- str->str_pok |= SP_TEMP;
- return str;
-}
-
-/* same thing without the copying */
-
-STR *
-str_2mortal(str)
-register STR *str;
-{
- if (!str || str == &str_undef)
- return 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;
- if (str->str_pok)
- str->str_pok |= SP_TEMP;
- return str;
-}
-
-STR *
-str_make(s,len)
-char *s;
-STRLEN 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);
- StructCopy(old,new,STR);
- if (old->str_ptr) {
- new->str_ptr = nsavestr(old->str_ptr,old->str_len);
- new->str_pok &= ~SP_TEMP;
- }
- return new;
-}
-
-void
-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 */
-
- if (!stash->tbl_array)
- return;
- 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), FALSE);
- if (stab == envstab)
- environ[0] = Nullch;
- }
- }
- }
- }
-}
-
-#ifdef TAINT
-void
-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 || egid != gid || taintanyway)) {
- if (!unsafe)
- fatal("%s", s);
- else if (dowarn)
- warn("%s", s);
- }
-}
-
-void
-taintenv()
-{
- register STR *envstr;
-
- envstr = hfetch(stab_hash(envstab),"PATH",4,FALSE);
- if (envstr == &str_undef || envstr->str_tainted) {
- tainted = 1;
- if (envstr->str_tainted == 2)
- taintproper("Insecure directory in PATH");
- else
- taintproper("Insecure PATH");
- }
- envstr = hfetch(stab_hash(envstab),"IFS",3,FALSE);
- if (envstr != &str_undef && envstr->str_tainted) {
- tainted = 1;
- taintproper("Insecure IFS");
- }
-}
-#endif /* TAINT */
+++ /dev/null
-/* $RCSfile: str.c,v $$Revision: 4.0.1.6 $$Date: 92/06/11 21:14:21 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: str.c,v $
- * Revision 4.0.1.6 92/06/11 21:14:21 lwall
- * patch34: quotes containing subscripts containing variables didn't parse right
- *
- * Revision 4.0.1.5 92/06/08 15:40:43 lwall
- * patch20: removed implicit int declarations on functions
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
- * patch20: paragraph mode now skips extra newlines automatically
- * patch20: fixed memory leak in doube-quote interpretation
- * patch20: made /\$$foo/ look for literal '$foo'
- * patch20: "$var{$foo'bar}" didn't scan subscript correctly
- * patch20: a splice on non-existent array elements could dump core
- * patch20: running taintperl explicitly now does checks even if $< == $>
- *
- * Revision 4.0.1.4 91/11/05 18:40:51 lwall
- * patch11: $foo .= <BAR> could overrun malloced memory
- * patch11: \$ didn't always make it through double-quoter to regexp routines
- * patch11: prepared for ctype implementations that don't define isascii()
- *
- * Revision 4.0.1.3 91/06/10 01:27:54 lwall
- * patch10: $) and $| incorrectly handled in run-time patterns
- *
- * Revision 4.0.1.2 91/06/07 11:58:13 lwall
- * patch4: new copyright notice
- * patch4: taint check on undefined string could cause core dump
- *
- * Revision 4.0.1.1 91/04/12 09:15:30 lwall
- * patch1: fixed undefined environ problem
- * patch1: substr($ENV{"PATH"},0,0) = "/foo:" didn't modify environment
- * patch1: $foo .= <BAR> could cause core dump for certain lengths of $foo
- *
- * Revision 4.0 91/03/20 01:39:55 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "perly.h"
-
-static void ucase();
-static void lcase();
-
-#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
-int
-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;
-#ifndef DOSISH
-register int newlen;
-#else
-unsigned long newlen;
-#endif
-{
- register char *s = str->str_ptr;
-
-#ifdef MSDOS
- if (newlen >= 0x10000) {
- fprintf(stderr, "Allocation too large: %lx\n", newlen);
- exit(1);
- }
-#endif /* MSDOS */
- 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;
- Move(s, str->str_ptr, str->str_cur+1, char);
- 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;
-}
-
-void
-str_numset(str,num)
-register STR *str;
-double num;
-{
- if (str->str_pok) {
- str->str_pok = 0; /* invalidate pointer */
- if (str->str_state == SS_INCR)
- Str_Grow(str,0);
- }
- str->str_u.str_nval = num;
- str->str_state = SS_NORM;
- 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) {
- STR_GROW(str, 30);
- 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");
- STR_GROW(str, 30);
- 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;
- if (str->str_state == SS_INCR)
- Str_Grow(str,0); /* just force copy down */
- 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;
-}
-
-/* Note: str_sset() should not be called with a source string that needs
- * be reused, since it may destroy the source string if it is marked
- * as temporary.
- */
-
-void
-str_sset(dstr,sstr)
-STR *dstr;
-register STR *sstr;
-{
-#ifdef TAINT
- if (sstr)
- tainted |= sstr->str_tainted;
-#endif
- if (sstr == dstr || dstr == &str_undef)
- return;
- if (!sstr)
- dstr->str_pok = dstr->str_nok = 0;
- else if (sstr->str_pok) {
-
- /*
- * Check to see if we can just swipe the string. If so, it's a
- * possible small lose on short strings, but a big win on long ones.
- * It might even be a win on short strings if dstr->str_ptr
- * has to be allocated and sstr->str_ptr has to be freed.
- */
-
- if (sstr->str_pok & SP_TEMP) { /* slated for free anyway? */
- if (dstr->str_ptr) {
- if (dstr->str_state == SS_INCR)
- dstr->str_ptr -= dstr->str_u.str_useful;
- Safefree(dstr->str_ptr);
- }
- dstr->str_ptr = sstr->str_ptr;
- dstr->str_len = sstr->str_len;
- dstr->str_cur = sstr->str_cur;
- dstr->str_state = sstr->str_state;
- dstr->str_pok = sstr->str_pok & ~SP_TEMP;
-#ifdef TAINT
- dstr->str_tainted = sstr->str_tainted;
-#endif
- sstr->str_ptr = Nullch;
- sstr->str_len = 0;
- sstr->str_pok = 0; /* wipe out any weird flags */
- sstr->str_state = 0; /* so sstr frees uneventfully */
- }
- else { /* have to copy actual string */
- if (dstr->str_ptr) {
- if (dstr->str_state == SS_INCR) {
- Str_Grow(dstr,0);
- }
- }
- str_nset(dstr,sstr->str_ptr,sstr->str_cur);
- }
- /*SUPPRESS 560*/
- if (dstr->str_nok = sstr->str_nok)
- dstr->str_u.str_nval = 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
- if (dstr->str_cur == sizeof(STBP)) {
- char *tmps = dstr->str_ptr;
-
- if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) {
- if (dstr->str_magic && dstr->str_magic->str_rare == 'X') {
- str_free(dstr->str_magic);
- dstr->str_magic = Nullstr;
- }
- if (!dstr->str_magic) {
- 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 {
- if (dstr->str_state == SS_INCR)
- Str_Grow(dstr,0); /* just force copy down */
-
-#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;
- }
-}
-
-void
-str_nset(str,ptr,len)
-register STR *str;
-register char *ptr;
-register STRLEN len;
-{
- if (str == &str_undef)
- return;
- STR_GROW(str, len + 1);
- if (ptr)
- Move(ptr,str->str_ptr,len,char);
- 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
-}
-
-void
-str_set(str,ptr)
-register STR *str;
-register char *ptr;
-{
- register STRLEN len;
-
- if (str == &str_undef)
- return;
- if (!ptr)
- ptr = "";
- len = strlen(ptr);
- STR_GROW(str, len + 1);
- Move(ptr,str->str_ptr,len+1,char);
- str->str_cur = len;
- str->str_nok = 0; /* invalidate number */
- str->str_pok = 1; /* validate pointer */
-#ifdef TAINT
- str->str_tainted = tainted;
-#endif
-}
-
-void
-str_chop(str,ptr) /* like set but assuming ptr is in str */
-register STR *str;
-register char *ptr;
-{
- register STRLEN delta;
-
- if (!ptr || !(str->str_pok))
- return;
- 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) */
-}
-
-void
-str_ncat(str,ptr,len)
-register STR *str;
-register char *ptr;
-register STRLEN len;
-{
- if (str == &str_undef)
- return;
- if (!(str->str_pok))
- (void)str_2ptr(str);
- STR_GROW(str, str->str_cur + len + 1);
- Move(ptr,str->str_ptr+str->str_cur,len,char);
- 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
-}
-
-void
-str_scat(dstr,sstr)
-STR *dstr;
-register STR *sstr;
-{
- if (!sstr)
- return;
-#ifdef TAINT
- tainted |= sstr->str_tainted;
-#endif
- if (!(sstr->str_pok))
- (void)str_2ptr(sstr);
- if (sstr)
- str_ncat(dstr,sstr->str_ptr,sstr->str_cur);
-}
-
-void
-str_cat(str,ptr)
-register STR *str;
-register char *ptr;
-{
- register STRLEN len;
-
- if (str == &str_undef)
- return;
- if (!ptr)
- return;
- if (!(str->str_pok))
- (void)str_2ptr(str);
- len = strlen(ptr);
- STR_GROW(str, str->str_cur + len + 1);
- Move(ptr,str->str_ptr+str->str_cur,len+1,char);
- 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 STRLEN len;
-
- if (str == &str_undef)
- return Nullch;
- 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
-STRLEN 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;
-STRLEN namlen;
-{
- if (str == &str_undef || 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;
-STRLEN offset;
-STRLEN len;
-char *little;
-STRLEN littlelen;
-{
- register char *big;
- register char *mid;
- register char *midend;
- register char *bigend;
- register int i;
-
- if (bigstr == &str_undef)
- return;
- bigstr->str_nok = 0;
- bigstr->str_pok = SP_VALID; /* disable possible screamer */
-
- 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;
- Move(little,big+offset,littlelen,char);
- bigstr->str_cur += i;
- STABSET(bigstr);
- return;
- }
- else if (i == 0) {
- Move(little,bigstr->str_ptr+offset,len,char);
- STABSET(bigstr);
- return;
- }
-
- big = bigstr->str_ptr;
- mid = big + offset;
- midend = mid + len;
- bigend = big + bigstr->str_cur;
-
- if (midend > bigend)
- fatal("panic: str_insert");
-
- if (mid - big > bigend - midend) { /* faster to shorten from end */
- if (littlelen) {
- Move(little, mid, littlelen,char);
- mid += littlelen;
- }
- i = bigend - midend;
- if (i > 0) {
- Move(midend, mid, i,char);
- mid += i;
- }
- *mid = '\0';
- bigstr->str_cur = mid - big;
- }
- /*SUPPRESS 560*/
- 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)
- Move(little, mid, littlelen,char);
- }
- else if (littlelen) {
- midend -= littlelen;
- str_chop(bigstr,midend);
- Move(little,midend,littlelen,char);
- }
- 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_undef)
- return;
- 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
- if (nstr->str_magic)
- str_free(nstr->str_magic);
- Safefree(nstr);
-}
-
-void
-str_free(str)
-register STR *str;
-{
- if (!str || str == &str_undef)
- 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);
- str->str_magic = freestrroot;
-#ifdef LEAKTEST
- if (str->str_len) {
- Safefree(str->str_ptr);
- str->str_ptr = Nullch;
- }
- 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
- freestrroot = str;
-#endif /* LEAKTEST */
-}
-
-STRLEN
-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;
-}
-
-int
-str_eq(str1,str2)
-register STR *str1;
-register STR *str2;
-{
- if (!str1 || str1 == &str_undef)
- return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur);
- if (!str2 || str2 == &str_undef)
- return !str1->str_cur;
-
- 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);
-}
-
-int
-str_cmp(str1,str2)
-register STR *str1;
-register STR *str2;
-{
- int retval;
-
- if (!str1 || str1 == &str_undef)
- return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur)?0:-1;
- if (!str2 || str2 == &str_undef)
- return str1->str_cur != 0;
-
- if (!str1->str_pok)
- (void)str_2ptr(str1);
- if (!str2->str_pok)
- (void)str_2ptr(str2);
-
- if (str1->str_cur < str2->str_cur) {
- /*SUPPRESS 560*/
- if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
- return retval < 0 ? -1 : 1;
- else
- return -1;
- }
- /*SUPPRESS 560*/
- else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
- return retval < 0 ? -1 : 1;
- 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 = rschar;/* (assuming >= 6 registers) */
- int i;
- STRLEN bpx;
- int shortbuffered;
-
- if (str == &str_undef)
- return Nullch;
- if (rspara) { /* have to do this both before and after */
- do { /* to make sure file boundaries work right */
- i = getc(fp);
- if (i != '\n') {
- ungetc(i,fp);
- break;
- }
- } while (i != EOF);
- }
-#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 - append <= cnt + 1) { /* make sure we have the room */
- if (cnt > 80 && str->str_len > append) {
- shortbuffered = cnt - str->str_len + append + 1;
- cnt -= shortbuffered;
- }
- else {
- shortbuffered = 0;
- STR_GROW(str, append+cnt+2);/* (remembering cnt can be -1) */
- }
- }
- else
- shortbuffered = 0;
- 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 :-) */
- }
-
- if (shortbuffered) { /* oh well, must extend */
- cnt = shortbuffered;
- shortbuffered = 0;
- bpx = bp - str->str_ptr; /* prepare for possible relocation */
- str->str_cur = bpx;
- STR_GROW(str, str->str_len + append + cnt + 2);
- bp = str->str_ptr + bpx; /* reconstitute our pointer */
- continue;
- }
-
- 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 */
- str->str_cur = bpx;
- STR_GROW(str, bpx + cnt + 2);
- 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_really_all_folks;
- *bp++ = i; /* now go back to screaming loop */
- }
-
-thats_all_folks:
- if (rslen > 1 && (bp - str->str_ptr < rslen || bcmp(bp - rslen, rs, rslen)))
- goto screamer; /* go back to the fray */
-thats_really_all_folks:
- if (shortbuffered)
- cnt += shortbuffered;
- 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;
- while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) ;
-
- *bp = '\0';
- if (append)
- str_cat(str, buf);
- else
- str_set(str, buf);
- if (i != EOF /* joy */
- &&
- (i != newline
- ||
- (rslen > 1
- &&
- (str->str_cur < rslen
- ||
- bcmp(str->str_ptr + str->str_cur - rslen, rs, rslen)
- )
- )
- )
- )
- {
- append = -1;
- goto screamer;
- }
- }
-
-#endif /* STDSTDIO */
-
- if (rspara) {
- while (i != EOF) {
- i = getc(fp);
- if (i != '\n') {
- ungetc(i,fp);
- break;
- }
- }
- }
- return str->str_cur - append ? str->str_ptr : Nullch;
-}
-
-ARG *
-parselist(str)
-STR *str;
-{
- register CMD *cmd;
- register ARG *arg;
- CMD *oldcurcmd = curcmd;
- int oldperldb = perldb;
- int retval;
-
- perldb = 0;
- 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--;
- perldb = oldperldb;
- fatal("%s\n",stab_val(stabent("@",TRUE))->str_ptr);
- }
-#ifdef DEBUGGING
- if (debug & 4) {
- char *tmps = loop_stack[loop_ptr].loop_label;
- deb("(Popping label #%d %s)\n",loop_ptr,
- tmps ? tmps : "" );
- }
-#endif
- loop_ptr--;
- error_count = 0;
- curcmd = &compiling;
- curcmd->c_line = oldcurcmd->c_line;
- retval = yyparse();
- curcmd = oldcurcmd;
- perldb = oldperldb;
- 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);
- cmd->c_expr = Nullarg;
- cmd_free(cmd);
- eval_root = Nullcmd;
- 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;
- STRLEN len;
- register int brackets;
- register char *d;
- STAB *stab;
- char *checkpoint;
- int sawcase = 0;
-
- 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("$@[{\\]}lLuUE",s[1])) {
- str_ncat(str, t, s - t);
- ++s;
- if (isALPHA(*s)) {
- str_ncat(str, "$c", 2);
- sawcase = (*s != 'E');
- }
- else {
- if (*nointrp) { /* in a regular expression */
- if (*s == '@') /* always strip \@ */ /*SUPPRESS 530*/
- ;
- else /* don't strip \\, \[, \{ etc. */
- str_ncat(str,s-1,1);
- }
- str_ncat(str, "$b", 2);
- }
- str_ncat(str, s, 1);
- ++s;
- t = s;
- }
- else if (*s == '$' && s+1 < send && *nointrp && index(nointrp,s[1])) {
- str_ncat(str, t, s - t);
- str_ncat(str, "$b", 2);
- str_ncat(str, s, 2);
- s += 2;
- t = s;
- }
- else if ((*s == '@' || *s == '$') && s+1 < send) {
- str_ncat(str,t,s-t);
- t = s;
- if (*s == '$' && s[1] == '#' && (isALPHA(s[2]) || s[2] == '_'))
- s++;
- s = scanident(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 '[':
- brackets++;
- break;
- case '{':
- brackets++;
- break;
- case ']':
- brackets--;
- break;
- case '}':
- brackets--;
- break;
- case '$':
- case '%':
- case '@':
- case '&':
- case '*':
- s = scanident(s,send,tokenbuf);
- continue;
- case '\'':
- case '"':
- /*SUPPRESS 68*/
- 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 (isALNUM(d[1])) {
- d = scanident(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 < (unsigned 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 (sawcase)
- str_ncat(str, "$cE", 3);
- 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;
- int docase = 0;
- int l = 0;
- int u = 0;
- int L = 0;
- int U = 0;
-
- if (str == &str_undef)
- return Nullstr;
- if (!(src->str_pok & SP_INTRP)) {
- int oldsave = savestack->ary_fill;
-
- (void)savehptr(&curstash);
- curstash = curcmd->c_stash; /* 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) {
- if (s-t > 0)
- str_ncat(str,t,s-t);
- switch(*++s) {
- default:
- fatal("panic: unknown interp cookie\n");
- break;
- case 'a':
- str_scat(str,*++elem);
- break;
- case 'b':
- str_ncat(str,++s,1);
- break;
- case 'c':
- if (docase && str->str_cur >= docase) {
- char *b = str->str_ptr + --docase;
-
- if (L)
- lcase(b, str->str_ptr + str->str_cur);
- else if (U)
- ucase(b, str->str_ptr + str->str_cur);
-
- if (u) /* note that l & u are independent of L & U */
- ucase(b, b+1);
- else if (l)
- lcase(b, b+1);
- l = u = 0;
- }
- docase = str->str_cur + 1;
- switch (*++s) {
- case 'u':
- u = 1;
- l = 0;
- break;
- case 'U':
- U = 1;
- L = 0;
- break;
- case 'l':
- l = 1;
- u = 0;
- break;
- case 'L':
- L = 1;
- U = 0;
- break;
- case 'E':
- docase = L = U = l = u = 0;
- break;
- }
- break;
- }
- t = ++s;
- }
- else
- s++;
- }
- if (s-t > 0)
- str_ncat(str,t,s-t);
- return str;
-}
-
-static void
-ucase(s,send)
-register char *s;
-register char *send;
-{
- while (s < send) {
- if (isLOWER(*s))
- *s = toupper(*s);
- s++;
- }
-}
-
-static void
-lcase(s,send)
-register char *s;
-register char *send;
-{
- while (s < send) {
- if (isUPPER(*s))
- *s = tolower(*s);
- s++;
- }
-}
-
-void
-str_inc(str)
-register STR *str;
-{
- register char *d;
-
- if (!str || str == &str_undef)
- 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 || str == &str_undef)
- 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_mortal(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;
- if (str->str_pok)
- str->str_pok |= SP_TEMP;
- return str;
-}
-
-/* same thing without the copying */
-
-STR *
-str_2mortal(str)
-register STR *str;
-{
- if (!str || str == &str_undef)
- return 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;
- if (str->str_pok)
- str->str_pok |= SP_TEMP;
- return str;
-}
-
-STR *
-str_make(s,len)
-char *s;
-STRLEN 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);
- StructCopy(old,new,STR);
- if (old->str_ptr) {
- new->str_ptr = nsavestr(old->str_ptr,old->str_len);
- new->str_pok &= ~SP_TEMP;
- }
- return new;
-}
-
-void
-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 */
-
- if (!stash->tbl_array)
- return;
- 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), FALSE);
- if (stab == envstab)
- environ[0] = Nullch;
- }
- }
- }
- }
-}
-
-#ifdef TAINT
-void
-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 || egid != gid || taintanyway)) {
- if (!unsafe)
- fatal("%s", s);
- else if (dowarn)
- warn("%s", s);
- }
-}
-
-void
-taintenv()
-{
- register STR *envstr;
-
- envstr = hfetch(stab_hash(envstab),"PATH",4,FALSE);
- if (envstr == &str_undef || envstr->str_tainted) {
- tainted = 1;
- if (envstr->str_tainted == 2)
- taintproper("Insecure directory in PATH");
- else
- taintproper("Insecure PATH");
- }
- envstr = hfetch(stab_hash(envstab),"IFS",3,FALSE);
- if (envstr != &str_undef && envstr->str_tainted) {
- tainted = 1;
- taintproper("Insecure IFS");
- }
-}
-#endif /* TAINT */
+++ /dev/null
-***************
-*** 1,4 ****
-! /* $RCSfile: str.c,v $$Revision: 4.0.1.6 $$Date: 1992/06/11 21:14:21 $
- *
- * Copyright (c) 1991, Larry Wall
- *
---- 1,4 ----
-! /* $RCSfile: str.c,v $$Revision: 4.0.1.7 $$Date: 1993/02/05 19:43:47 $
- *
- * Copyright (c) 1991, Larry Wall
- *
-***************
-*** 6,14 ****
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: str.c,v $
-! * Revision 4.0.1.6 1992/06/11 21:14:21 lwall
-! * patch34: quotes containing subscripts containing variables didn't parse right
- *
- * Revision 4.0.1.5 92/06/08 15:40:43 lwall
- * patch20: removed implicit int declarations on functions
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
---- 6,17 ----
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: str.c,v $
-! * Revision 4.0.1.7 1993/02/05 19:43:47 lwall
-! * patch36: the non-std stdio input code wasn't null-proof
- *
-+ * Revision 4.0.1.6 92/06/11 21:14:21 lwall
-+ * patch34: quotes containing subscripts containing variables didn't parse right
-+ *
- * Revision 4.0.1.5 92/06/08 15:40:43 lwall
- * patch20: removed implicit int declarations on functions
- * patch20: Perl now distinguishes overlapped copies from non-overlapped
+++ /dev/null
-/* $RCSfile: str.h,v $$Revision: 4.0.1.4 $$Date: 92/06/08 15:41:45 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: str.h,v $
- * Revision 4.0.1.4 92/06/08 15:41:45 lwall
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: removed implicit int declarations on functions
- *
- * Revision 4.0.1.3 91/11/05 18:41:47 lwall
- * patch11: random cleanup
- * patch11: solitary subroutine references no longer trigger typo warnings
- *
- * Revision 4.0.1.2 91/06/07 11:58:33 lwall
- * patch4: new copyright notice
- *
- * Revision 4.0.1.1 91/04/12 09:16:12 lwall
- * patch1: you may now use "die" and "caller" in a signal handler
- *
- * Revision 4.0 91/03/20 01:40:04 lwall
- * 4.0 baseline.
- *
- */
-
-struct string {
- char * str_ptr; /* pointer to malloced string */
- STRLEN str_len; /* allocated size */
- union {
- double str_nval; /* numeric value, if any */
- 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 */
- CMD *str_cmd; /* command for this source line */
- struct {
- STAB *stb_stab; /* magic stab for magic "key" string */
- HASH *stb_stash; /* which symbol table this stab is in */
- } stb_u;
- } str_u;
- STRLEN 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 */
- unsigned char str_pok; /* state of str_ptr */
- unsigned 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 */
- STRLEN str_len; /* allocated size */
- union {
- double str_nval; /* numeric value, if any */
- 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 */
- CMD *str_cmd; /* command for this source line */
- struct {
- STAB *stb_stab; /* magic stab for magic "key" string */
- HASH *stb_stash; /* which symbol table this stab is in */
- } stb_u;
- } str_u;
- STRLEN 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 */
- unsigned char str_pok; /* state of str_ptr */
- unsigned 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
-};
-
-#define str_stab stb_u.stb_stab
-#define str_stash stb_u.stb_stash
-
-/* some extra info tacked to some lvalue strings */
-
-struct lstring {
- struct string lstr;
- STRLEN lstr_offset;
- STRLEN 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 SP_TEMP 128 /* string slated to die, so can be plundered */
-
-#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_SCSV 9 /* callsave structure on save stack */
-#define SS_SAPTR 10 /* ARRAY* 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_mortal();
-STR *str_2mortal();
-STR *str_make();
-STR *str_nmake();
-STR *str_smake();
-int str_cmp();
-int str_eq();
-void str_magic();
-void str_insert();
-void str_numset();
-void str_sset();
-void str_nset();
-void str_set();
-void str_chop();
-void str_cat();
-void str_scat();
-void str_ncat();
-void str_reset();
-void str_taintproper();
-void str_taintenv();
-STRLEN str_len();
-
-#define MULTI (3)
--- /dev/null
+/* $RCSfile: sv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:45 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: sv.c,v $
+ * Revision 4.1 92/08/07 18:26:45 lwall
+ *
+ * Revision 4.0.1.6 92/06/11 21:14:21 lwall
+ * patch34: quotes containing subscripts containing variables didn't parse right
+ *
+ * Revision 4.0.1.5 92/06/08 15:40:43 lwall
+ * patch20: removed implicit int declarations on functions
+ * patch20: Perl now distinguishes overlapped copies from non-overlapped
+ * patch20: paragraph mode now skips extra newlines automatically
+ * patch20: fixed memory leak in doube-quote interpretation
+ * patch20: made /\$$foo/ look for literal '$foo'
+ * patch20: "$var{$foo'bar}" didn't scan subscript correctly
+ * patch20: a splice on non-existent array elements could dump core
+ * patch20: running taintperl explicitly now does checks even if $< == $>
+ *
+ * Revision 4.0.1.4 91/11/05 18:40:51 lwall
+ * patch11: $foo .= <BAR> could overrun malloced memory
+ * patch11: \$ didn't always make it through double-quoter to regexp routines
+ * patch11: prepared for ctype implementations that don't define isascii()
+ *
+ * Revision 4.0.1.3 91/06/10 01:27:54 lwall
+ * patch10: $) and $| incorrectly handled in run-time patterns
+ *
+ * Revision 4.0.1.2 91/06/07 11:58:13 lwall
+ * patch4: new copyright notice
+ * patch4: taint check on undefined string could cause core dump
+ *
+ * Revision 4.0.1.1 91/04/12 09:15:30 lwall
+ * patch1: fixed undefined environ problem
+ * patch1: substr($ENV{"PATH"},0,0) = "/foo:" didn't modify environment
+ * patch1: $foo .= <BAR> could cause core dump for certain lengths of $foo
+ *
+ * Revision 4.0 91/03/20 01:39:55 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "perly.h"
+
+static void ucase();
+static void lcase();
+
+bool
+sv_upgrade(sv, mt)
+register SV* sv;
+U32 mt;
+{
+ char* pv;
+ U32 cur;
+ U32 len;
+ I32 iv;
+ double nv;
+ MAGIC* magic;
+ HV* stash;
+
+ if (SvTYPE(sv) == mt)
+ return TRUE;
+
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ pv = 0;
+ cur = 0;
+ len = 0;
+ iv = 0;
+ nv = 0.0;
+ magic = 0;
+ stash = 0;
+ break;
+ case SVt_REF:
+ sv_free((SV*)SvANY(sv));
+ pv = 0;
+ cur = 0;
+ len = 0;
+ iv = SvANYI32(sv);
+ nv = (double)SvANYI32(sv);
+ SvNOK_only(sv);
+ magic = 0;
+ stash = 0;
+ if (mt == SVt_PV)
+ mt = SVt_PVIV;
+ break;
+ case SVt_IV:
+ pv = 0;
+ cur = 0;
+ len = 0;
+ iv = SvIV(sv);
+ nv = (double)SvIV(sv);
+ del_XIV(SvANY(sv));
+ magic = 0;
+ stash = 0;
+ if (mt == SVt_PV)
+ mt = SVt_PVIV;
+ break;
+ case SVt_NV:
+ pv = 0;
+ cur = 0;
+ len = 0;
+ if (SvIOK(sv))
+ iv = SvIV(sv);
+ else
+ iv = (I32)SvNV(sv);
+ nv = SvNV(sv);
+ magic = 0;
+ stash = 0;
+ del_XNV(SvANY(sv));
+ SvANY(sv) = 0;
+ if (mt == SVt_PV || mt == SVt_PVIV)
+ mt = SVt_PVNV;
+ break;
+ case SVt_PV:
+ nv = 0.0;
+ pv = SvPV(sv);
+ cur = SvCUR(sv);
+ len = SvLEN(sv);
+ iv = 0;
+ nv = 0.0;
+ magic = 0;
+ stash = 0;
+ del_XPV(SvANY(sv));
+ break;
+ case SVt_PVIV:
+ nv = 0.0;
+ pv = SvPV(sv);
+ cur = SvCUR(sv);
+ len = SvLEN(sv);
+ iv = SvIV(sv);
+ nv = 0.0;
+ magic = 0;
+ stash = 0;
+ del_XPVIV(SvANY(sv));
+ break;
+ case SVt_PVNV:
+ nv = SvNV(sv);
+ pv = SvPV(sv);
+ cur = SvCUR(sv);
+ len = SvLEN(sv);
+ iv = SvIV(sv);
+ nv = SvNV(sv);
+ magic = 0;
+ stash = 0;
+ del_XPVNV(SvANY(sv));
+ break;
+ case SVt_PVMG:
+ pv = SvPV(sv);
+ cur = SvCUR(sv);
+ len = SvLEN(sv);
+ iv = SvIV(sv);
+ nv = SvNV(sv);
+ magic = SvMAGIC(sv);
+ stash = SvSTASH(sv);
+ del_XPVMG(SvANY(sv));
+ break;
+ default:
+ fatal("Can't upgrade that kind of scalar");
+ }
+
+ switch (mt) {
+ case SVt_NULL:
+ fatal("Can't upgrade to undef");
+ case SVt_REF:
+ SvIOK_on(sv);
+ break;
+ case SVt_IV:
+ SvANY(sv) = new_XIV();
+ SvIV(sv) = iv;
+ break;
+ case SVt_NV:
+ SvANY(sv) = new_XNV();
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ break;
+ case SVt_PV:
+ SvANY(sv) = new_XPV();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ break;
+ case SVt_PVIV:
+ SvANY(sv) = new_XPVIV();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ if (SvNIOK(sv))
+ SvIOK_on(sv);
+ SvNOK_off(sv);
+ break;
+ case SVt_PVNV:
+ SvANY(sv) = new_XPVNV();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ break;
+ case SVt_PVMG:
+ SvANY(sv) = new_XPVMG();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ break;
+ case SVt_PVLV:
+ SvANY(sv) = new_XPVLV();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ LvTARGOFF(sv) = 0;
+ LvTARGLEN(sv) = 0;
+ LvTARG(sv) = 0;
+ LvTYPE(sv) = 0;
+ break;
+ case SVt_PVAV:
+ SvANY(sv) = new_XPVAV();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ AvMAGIC(sv) = 0;
+ AvARRAY(sv) = 0;
+ AvALLOC(sv) = 0;
+ AvMAX(sv) = 0;
+ AvFILL(sv) = 0;
+ AvARYLEN(sv) = 0;
+ AvFLAGS(sv) = 0;
+ break;
+ case SVt_PVHV:
+ SvANY(sv) = new_XPVHV();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ HvMAGIC(sv) = 0;
+ HvARRAY(sv) = 0;
+ HvMAX(sv) = 0;
+ HvDOSPLIT(sv) = 0;
+ HvFILL(sv) = 0;
+ HvRITER(sv) = 0;
+ HvEITER(sv) = 0;
+ HvPMROOT(sv) = 0;
+ HvNAME(sv) = 0;
+ HvDBM(sv) = 0;
+ HvCOEFFSIZE(sv) = 0;
+ break;
+ case SVt_PVCV:
+ SvANY(sv) = new_XPVCV();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ CvSTASH(sv) = 0;
+ CvSTART(sv) = 0;
+ CvROOT(sv) = 0;
+ CvUSERSUB(sv) = 0;
+ CvUSERINDEX(sv) = 0;
+ CvFILEGV(sv) = 0;
+ CvDEPTH(sv) = 0;
+ CvPADLIST(sv) = 0;
+ CvDELETED(sv) = 0;
+ break;
+ case SVt_PVGV:
+ SvANY(sv) = new_XPVGV();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ GvNAME(sv) = 0;
+ GvNAMELEN(sv) = 0;
+ GvSTASH(sv) = 0;
+ break;
+ case SVt_PVBM:
+ SvANY(sv) = new_XPVBM();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ BmRARE(sv) = 0;
+ BmUSEFUL(sv) = 0;
+ BmPREVIOUS(sv) = 0;
+ break;
+ case SVt_PVFM:
+ SvANY(sv) = new_XPVFM();
+ SvPV(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIV(sv) = iv;
+ SvNV(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ FmLINES(sv) = 0;
+ break;
+ }
+ SvTYPE(sv) = mt;
+ return TRUE;
+}
+
+char *
+sv_peek(sv)
+register SV *sv;
+{
+ char *t = tokenbuf;
+ *t = '\0';
+
+ retry:
+ if (!sv) {
+ strcpy(t, "VOID");
+ return tokenbuf;
+ }
+ else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
+ strcpy(t, "WILD");
+ return tokenbuf;
+ }
+ else if (SvREFCNT(sv) == 0 && !SvREADONLY(sv)) {
+ strcpy(t, "UNREF");
+ return tokenbuf;
+ }
+ else {
+ switch (SvTYPE(sv)) {
+ default:
+ strcpy(t,"FREED");
+ return tokenbuf;
+ break;
+
+ case SVt_NULL:
+ return "UNDEF";
+ case SVt_REF:
+ strcpy(t, "\\");
+ t += strlen(t);
+ sv = (SV*)SvANY(sv);
+ goto retry;
+ case SVt_IV:
+ strcpy(t,"IV");
+ break;
+ case SVt_NV:
+ strcpy(t,"NV");
+ break;
+ case SVt_PV:
+ strcpy(t,"PV");
+ break;
+ case SVt_PVIV:
+ strcpy(t,"PVIV");
+ break;
+ case SVt_PVNV:
+ strcpy(t,"PVNV");
+ break;
+ case SVt_PVMG:
+ strcpy(t,"PVMG");
+ break;
+ case SVt_PVLV:
+ strcpy(t,"PVLV");
+ break;
+ case SVt_PVAV:
+ strcpy(t,"AV");
+ break;
+ case SVt_PVHV:
+ strcpy(t,"HV");
+ break;
+ case SVt_PVCV:
+ strcpy(t,"CV");
+ break;
+ case SVt_PVGV:
+ strcpy(t,"GV");
+ break;
+ case SVt_PVBM:
+ strcpy(t,"BM");
+ break;
+ case SVt_PVFM:
+ strcpy(t,"FM");
+ break;
+ }
+ }
+ t += strlen(t);
+
+ if (SvPOK(sv)) {
+ if (!SvPV(sv))
+ return "(null)";
+ if (SvOOK(sv))
+ sprintf(t,"(%d+\"%0.127s\")",SvIV(sv),SvPV(sv));
+ else
+ sprintf(t,"(\"%0.127s\")",SvPV(sv));
+ }
+ else if (SvNOK(sv))
+ sprintf(t,"(%g)",SvNV(sv));
+ else if (SvIOK(sv))
+ sprintf(t,"(%ld)",(long)SvIV(sv));
+ else
+ strcpy(t,"()");
+ return tokenbuf;
+}
+
+int
+sv_backoff(sv)
+register SV *sv;
+{
+ assert(SvOOK(sv));
+ if (SvIV(sv)) {
+ char *s = SvPV(sv);
+ SvLEN(sv) += SvIV(sv);
+ SvPV(sv) -= SvIV(sv);
+ SvIV_set(sv, 0);
+ Move(s, SvPV(sv), SvCUR(sv)+1, char);
+ }
+ SvFLAGS(sv) &= ~SVf_OOK;
+}
+
+char *
+sv_grow(sv,newlen)
+register SV *sv;
+#ifndef DOSISH
+register I32 newlen;
+#else
+unsigned long newlen;
+#endif
+{
+ register char *s;
+
+#ifdef MSDOS
+ if (newlen >= 0x10000) {
+ fprintf(stderr, "Allocation too large: %lx\n", newlen);
+ my_exit(1);
+ }
+#endif /* MSDOS */
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (SvTYPE(sv) < SVt_PV) {
+ sv_upgrade(sv, SVt_PV);
+ s = SvPV(sv);
+ }
+ else if (SvOOK(sv)) { /* pv is offset? */
+ sv_backoff(sv);
+ s = SvPV(sv);
+ if (newlen > SvLEN(sv))
+ newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
+ }
+ else
+ s = SvPV(sv);
+ if (newlen > SvLEN(sv)) { /* need more room? */
+ if (SvLEN(sv))
+ Renew(s,newlen,char);
+ else
+ New(703,s,newlen,char);
+ SvPV_set(sv, s);
+ SvLEN_set(sv, newlen);
+ }
+ return s;
+}
+
+void
+sv_setiv(sv,i)
+register SV *sv;
+I32 i;
+{
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (SvTYPE(sv) < SVt_IV)
+ sv_upgrade(sv, SVt_IV);
+ else if (SvTYPE(sv) == SVt_PV)
+ sv_upgrade(sv, SVt_PVIV);
+ SvIV(sv) = i;
+ SvIOK_only(sv); /* validate number */
+ SvTDOWN(sv);
+}
+
+void
+sv_setnv(sv,num)
+register SV *sv;
+double num;
+{
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (SvTYPE(sv) < SVt_NV)
+ sv_upgrade(sv, SVt_NV);
+ else if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ else if (SvPOK(sv)) {
+ SvOOK_off(sv);
+ }
+ SvNV(sv) = num;
+ SvNOK_only(sv); /* validate number */
+ SvTDOWN(sv);
+}
+
+I32
+sv_2iv(sv)
+register SV *sv;
+{
+ if (!sv)
+ return 0;
+ if (SvREADONLY(sv)) {
+ if (SvNOK(sv))
+ return (I32)SvNV(sv);
+ if (SvPOK(sv) && SvLEN(sv))
+ return atof(SvPV(sv));
+ if (dowarn)
+ warn("Use of uninitialized variable");
+ return 0;
+ }
+ if (SvTYPE(sv) < SVt_IV) {
+ if (SvTYPE(sv) == SVt_REF)
+ return (I32)SvANYI32(sv);
+ sv_upgrade(sv, SVt_IV);
+ DEBUG_c((stderr,"0x%lx num(%g)\n",sv,SvIV(sv)));
+ return SvIV(sv);
+ }
+ else if (SvTYPE(sv) == SVt_PV)
+ sv_upgrade(sv, SVt_PVIV);
+ if (SvNOK(sv))
+ SvIV(sv) = (I32)SvNV(sv);
+ else if (SvPOK(sv) && SvLEN(sv))
+ SvIV(sv) = atol(SvPV(sv));
+ else {
+ if (dowarn)
+ warn("Use of uninitialized variable");
+ SvUPGRADE(sv, SVt_IV);
+ SvIV(sv) = 0;
+ }
+ SvIOK_on(sv);
+ DEBUG_c((stderr,"0x%lx 2iv(%d)\n",sv,SvIV(sv)));
+ return SvIV(sv);
+}
+
+double
+sv_2nv(sv)
+register SV *sv;
+{
+ if (!sv)
+ return 0.0;
+ if (SvREADONLY(sv)) {
+ if (SvPOK(sv) && SvLEN(sv))
+ return atof(SvPV(sv));
+ if (dowarn)
+ warn("Use of uninitialized variable");
+ return 0.0;
+ }
+ if (SvTYPE(sv) < SVt_NV) {
+ if (SvTYPE(sv) == SVt_REF)
+ return (double)SvANYI32(sv);
+ sv_upgrade(sv, SVt_NV);
+ DEBUG_c((stderr,"0x%lx num(%g)\n",sv,SvNV(sv)));
+ return SvNV(sv);
+ }
+ else if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ if (SvPOK(sv) && SvLEN(sv))
+ SvNV(sv) = atof(SvPV(sv));
+ else if (SvIOK(sv))
+ SvNV(sv) = (double)SvIV(sv);
+ else {
+ if (dowarn)
+ warn("Use of uninitialized variable");
+ SvNV(sv) = 0.0;
+ }
+ SvNOK_on(sv);
+ DEBUG_c((stderr,"0x%lx 2nv(%g)\n",sv,SvNV(sv)));
+ return SvNV(sv);
+}
+
+char *
+sv_2pv(sv)
+register SV *sv;
+{
+ register char *s;
+ int olderrno;
+
+ if (!sv)
+ return "";
+ if (SvTYPE(sv) == SVt_REF) {
+ sv = (SV*)SvANY(sv);
+ if (!sv)
+ return "<Empty reference>";
+ switch (SvTYPE(sv)) {
+ case SVt_NULL: s = "an undefined value"; break;
+ case SVt_REF: s = "a reference"; break;
+ case SVt_IV: s = "an integer value"; break;
+ case SVt_NV: s = "a numeric value"; break;
+ case SVt_PV: s = "a string value"; break;
+ case SVt_PVIV: s = "a string+integer value"; break;
+ case SVt_PVNV: s = "a scalar value"; break;
+ case SVt_PVMG: s = "a magic value"; break;
+ case SVt_PVLV: s = "an lvalue"; break;
+ case SVt_PVAV: s = "an array value"; break;
+ case SVt_PVHV: s = "an associative array value"; break;
+ case SVt_PVCV: s = "a code value"; break;
+ case SVt_PVGV: s = "a glob value"; break;
+ case SVt_PVBM: s = "a search string"; break;
+ case SVt_PVFM: s = "a formatline"; break;
+ default: s = "something weird"; break;
+ }
+ sprintf(tokenbuf,"<Reference to %s at 0x%lx>", s, (unsigned long)sv);
+ return tokenbuf;
+ }
+ if (SvREADONLY(sv)) {
+ if (SvIOK(sv)) {
+ (void)sprintf(tokenbuf,"%ld",SvIV(sv));
+ return tokenbuf;
+ }
+ if (SvNOK(sv)) {
+ (void)sprintf(tokenbuf,"%.20g",SvNV(sv));
+ return tokenbuf;
+ }
+ if (dowarn)
+ warn("Use of uninitialized variable");
+ return "";
+ }
+ if (!SvUPGRADE(sv, SVt_PV))
+ return 0;
+ if (SvNOK(sv)) {
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvGROW(sv, 28);
+ s = SvPV(sv);
+ olderrno = errno; /* some Xenix systems wipe out errno here */
+#if defined(scs) && defined(ns32000)
+ gcvt(SvNV(sv),20,s);
+#else
+#ifdef apollo
+ if (SvNV(sv) == 0.0)
+ (void)strcpy(s,"0");
+ else
+#endif /*apollo*/
+ (void)sprintf(s,"%.20g",SvNV(sv));
+#endif /*scs*/
+ errno = olderrno;
+ while (*s) s++;
+#ifdef hcx
+ if (s[-1] == '.')
+ s--;
+#endif
+ }
+ else if (SvIOK(sv)) {
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ SvGROW(sv, 11);
+ s = SvPV(sv);
+ olderrno = errno; /* some Xenix systems wipe out errno here */
+ (void)sprintf(s,"%ld",SvIV(sv));
+ errno = olderrno;
+ while (*s) s++;
+ }
+ else {
+ if (dowarn)
+ warn("Use of uninitialized variable");
+ sv_grow(sv, 1);
+ s = SvPV(sv);
+ }
+ *s = '\0';
+ SvCUR_set(sv, s - SvPV(sv));
+ SvPOK_on(sv);
+ DEBUG_c((stderr,"0x%lx 2pv(%s)\n",sv,SvPV(sv)));
+ return SvPV(sv);
+}
+
+/* Note: sv_setsv() should not be called with a source string that needs
+ * be reused, since it may destroy the source string if it is marked
+ * as temporary.
+ */
+
+void
+sv_setsv(dstr,sstr)
+SV *dstr;
+register SV *sstr;
+{
+ if (sstr == dstr)
+ return;
+ if (SvREADONLY(dstr))
+ fatal(no_modify);
+ if (!sstr)
+ sstr = &sv_undef;
+
+ if (SvTYPE(dstr) < SvTYPE(sstr))
+ sv_upgrade(dstr, SvTYPE(sstr));
+ else if (SvTYPE(dstr) == SVt_PV && SvTYPE(sstr) <= SVt_NV) {
+ if (SvTYPE(sstr) <= SVt_IV)
+ sv_upgrade(dstr, SVt_PVIV); /* handle discontinuities */
+ else
+ sv_upgrade(dstr, SVt_PVNV);
+ }
+ else if (SvTYPE(dstr) == SVt_PVIV && SvTYPE(sstr) == SVt_NV)
+ sv_upgrade(dstr, SVt_PVNV);
+
+ switch (SvTYPE(sstr)) {
+ case SVt_NULL:
+ if (SvTYPE(dstr) == SVt_REF) {
+ sv_free((SV*)SvANY(dstr));
+ SvANY(dstr) = 0;
+ SvTYPE(dstr) = SVt_NULL;
+ }
+ else
+ SvOK_off(dstr);
+ return;
+ case SVt_REF:
+ SvTUP(sstr);
+ if (SvTYPE(dstr) == SVt_REF) {
+ SvANY(dstr) = (void*)sv_ref((SV*)SvANY(sstr));
+ }
+ else {
+ if (SvMAGICAL(dstr))
+ fatal("Can't assign a reference to a magical variable");
+ sv_clear(dstr);
+ SvTYPE(dstr) = SVt_REF;
+ SvANY(dstr) = (void*)sv_ref((SV*)SvANY(sstr));
+ SvOK_off(dstr);
+ }
+ SvTDOWN(sstr);
+ return;
+ case SVt_PVGV:
+ SvTUP(sstr);
+ if (SvTYPE(dstr) == SVt_PVGV) {
+ SvOK_off(dstr);
+ if (!GvAV(sstr))
+ gv_AVadd(sstr);
+ if (!GvHV(sstr))
+ gv_HVadd(sstr);
+ if (!GvIO(sstr))
+ GvIO(sstr) = newIO();
+ if (GvGP(dstr))
+ gp_free(dstr);
+ GvGP(dstr) = gp_ref(GvGP(sstr));
+ SvTDOWN(sstr);
+ return;
+ }
+ /* FALL THROUGH */
+
+ default:
+ if (SvMAGICAL(sstr))
+ mg_get(sstr);
+ /* XXX */
+ break;
+ }
+
+ SvPRIVATE(dstr) = SvPRIVATE(sstr);
+ SvSTORAGE(dstr) = SvSTORAGE(sstr);
+
+ if (SvPOK(sstr)) {
+
+ SvTUP(sstr);
+
+ /*
+ * Check to see if we can just swipe the string. If so, it's a
+ * possible small lose on short strings, but a big win on long ones.
+ * It might even be a win on short strings if SvPV(dstr)
+ * has to be allocated and SvPV(sstr) has to be freed.
+ */
+
+ if (SvTEMP(sstr)) { /* slated for free anyway? */
+ if (SvPOK(dstr)) {
+ SvOOK_off(dstr);
+ Safefree(SvPV(dstr));
+ }
+ SvPV_set(dstr, SvPV(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvTYPE(dstr) = SvTYPE(sstr);
+ SvPOK_only(dstr);
+ SvTEMP_off(dstr);
+ SvPV_set(sstr, Nullch);
+ SvLEN_set(sstr, 0);
+ SvPOK_off(sstr); /* wipe out any weird flags */
+ SvTYPE(sstr) = 0; /* so sstr frees uneventfully */
+ }
+ else { /* have to copy actual string */
+ if (SvPV(dstr)) { /* XXX ck type */
+ SvOOK_off(dstr);
+ }
+ sv_setpvn(dstr,SvPV(sstr),SvCUR(sstr));
+ }
+ /*SUPPRESS 560*/
+ if (SvNOK(sstr)) {
+ SvNOK_on(dstr);
+ SvNV(dstr) = SvNV(sstr);
+ }
+ if (SvIOK(sstr)) {
+ SvIOK_on(dstr);
+ SvIV(dstr) = SvIV(sstr);
+ }
+ }
+ else if (SvNOK(sstr)) {
+ SvTUP(sstr);
+ SvNV(dstr) = SvNV(sstr);
+ SvNOK_only(dstr);
+ if (SvIOK(sstr)) {
+ SvIOK_on(dstr);
+ SvIV(dstr) = SvIV(sstr);
+ }
+ }
+ else if (SvIOK(sstr)) {
+ SvTUP(sstr);
+ SvIOK_only(dstr);
+ SvIV(dstr) = SvIV(sstr);
+ }
+ else {
+ SvTUP(sstr);
+ SvOK_off(dstr);
+ }
+ SvTDOWN(dstr);
+}
+
+void
+sv_setpvn(sv,ptr,len)
+register SV *sv;
+register char *ptr;
+register STRLEN len;
+{
+ if (!SvUPGRADE(sv, SVt_PV))
+ return;
+ SvGROW(sv, len + 1);
+ if (ptr)
+ Move(ptr,SvPV(sv),len,char);
+ SvCUR_set(sv, len);
+ *SvEND(sv) = '\0';
+ SvPOK_only(sv); /* validate pointer */
+ SvTDOWN(sv);
+}
+
+void
+sv_setpv(sv,ptr)
+register SV *sv;
+register char *ptr;
+{
+ register STRLEN len;
+
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (!ptr)
+ ptr = "";
+ len = strlen(ptr);
+ if (!SvUPGRADE(sv, SVt_PV))
+ return;
+ SvGROW(sv, len + 1);
+ Move(ptr,SvPV(sv),len+1,char);
+ SvCUR_set(sv, len);
+ SvPOK_only(sv); /* validate pointer */
+ SvTDOWN(sv);
+}
+
+void
+sv_chop(sv,ptr) /* like set but assuming ptr is in sv */
+register SV *sv;
+register char *ptr;
+{
+ register STRLEN delta;
+
+ if (!ptr || !SvPOK(sv))
+ return;
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv,SVt_PVIV);
+
+ if (!SvOOK(sv)) {
+ SvIV(sv) = 0;
+ SvFLAGS(sv) |= SVf_OOK;
+ }
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
+ delta = ptr - SvPV(sv);
+ SvLEN(sv) -= delta;
+ SvCUR(sv) -= delta;
+ SvPV(sv) += delta;
+ SvIV(sv) += delta;
+}
+
+void
+sv_catpvn(sv,ptr,len)
+register SV *sv;
+register char *ptr;
+register STRLEN len;
+{
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (!(SvPOK(sv)))
+ (void)sv_2pv(sv);
+ SvGROW(sv, SvCUR(sv) + len + 1);
+ Move(ptr,SvPV(sv)+SvCUR(sv),len,char);
+ SvCUR(sv) += len;
+ *SvEND(sv) = '\0';
+ SvPOK_only(sv); /* validate pointer */
+ SvTDOWN(sv);
+}
+
+void
+sv_catsv(dstr,sstr)
+SV *dstr;
+register SV *sstr;
+{
+ char *s;
+ if (!sstr)
+ return;
+ if (s = SvPVn(sstr)) {
+ if (SvPOK(sstr))
+ sv_catpvn(dstr,s,SvCUR(sstr));
+ else
+ sv_catpv(dstr,s);
+ }
+}
+
+void
+sv_catpv(sv,ptr)
+register SV *sv;
+register char *ptr;
+{
+ register STRLEN len;
+
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (!ptr)
+ return;
+ if (!(SvPOK(sv)))
+ (void)sv_2pv(sv);
+ len = strlen(ptr);
+ SvGROW(sv, SvCUR(sv) + len + 1);
+ Move(ptr,SvPV(sv)+SvCUR(sv),len+1,char);
+ SvCUR(sv) += len;
+ SvPOK_only(sv); /* validate pointer */
+ SvTDOWN(sv);
+}
+
+char *
+sv_append_till(sv,from,fromend,delim,keeplist)
+register SV *sv;
+register char *from;
+register char *fromend;
+register I32 delim;
+char *keeplist;
+{
+ register char *to;
+ register STRLEN len;
+
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (!from)
+ return Nullch;
+ len = fromend - from;
+ if (!SvUPGRADE(sv, SVt_PV))
+ return 0;
+ SvGROW(sv, SvCUR(sv) + len + 1);
+ SvPOK_only(sv); /* validate pointer */
+ to = SvPV(sv)+SvCUR(sv);
+ for (; from < fromend; from++,to++) {
+ if (*from == '\\' && from+1 < fromend && delim != '\\') {
+ if (!keeplist)
+ *to++ = *from++;
+ else if (from[1] && index(keeplist,from[1]))
+ *to++ = *from++;
+ else
+ from++;
+ }
+ else if (*from == delim)
+ break;
+ *to = *from;
+ }
+ *to = '\0';
+ SvCUR_set(sv, to - SvPV(sv));
+ return from;
+}
+
+SV *
+#ifdef LEAKTEST
+newSV(x,len)
+I32 x;
+#else
+newSV(len)
+#endif
+STRLEN len;
+{
+ register SV *sv;
+
+ sv = (SV*)new_SV();
+ Zero(sv, 1, SV);
+ SvREFCNT(sv)++;
+ if (len) {
+ sv_upgrade(sv, SVt_PV);
+ SvGROW(sv, len + 1);
+ }
+ return sv;
+}
+
+void
+sv_magic(sv, obj, how, name, namlen)
+register SV *sv;
+SV *obj;
+char how;
+char *name;
+STRLEN namlen;
+{
+ MAGIC* mg;
+
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (!SvUPGRADE(sv, SVt_PVMG))
+ return;
+ Newz(702,mg, 1, MAGIC);
+ mg->mg_moremagic = SvMAGIC(sv);
+ SvMAGICAL_on(sv);
+ SvMAGIC(sv) = mg;
+ mg->mg_obj = obj;
+ mg->mg_type = how;
+ if (name) {
+ mg->mg_ptr = nsavestr(name, namlen);
+ mg->mg_len = namlen;
+ }
+ switch (how) {
+ case 0:
+ mg->mg_virtual = &vtbl_sv;
+ break;
+ case 'B':
+ mg->mg_virtual = &vtbl_bm;
+ break;
+ case 'D':
+ mg->mg_virtual = &vtbl_dbm;
+ break;
+ case 'd':
+ mg->mg_virtual = &vtbl_dbmelem;
+ break;
+ case 'E':
+ mg->mg_virtual = &vtbl_env;
+ break;
+ case 'e':
+ mg->mg_virtual = &vtbl_envelem;
+ break;
+ case 'L':
+ mg->mg_virtual = &vtbl_dbline;
+ break;
+ case 'S':
+ mg->mg_virtual = &vtbl_sig;
+ break;
+ case 's':
+ mg->mg_virtual = &vtbl_sigelem;
+ break;
+ case 'U':
+ mg->mg_virtual = &vtbl_uvar;
+ break;
+ case 'v':
+ mg->mg_virtual = &vtbl_vec;
+ break;
+ case 'x':
+ mg->mg_virtual = &vtbl_substr;
+ break;
+ case '*':
+ mg->mg_virtual = &vtbl_glob;
+ break;
+ case '#':
+ mg->mg_virtual = &vtbl_arylen;
+ break;
+ default:
+ fatal("Don't know how to handle magic of type '%c'", how);
+ }
+}
+
+void
+sv_insert(bigstr,offset,len,little,littlelen)
+SV *bigstr;
+STRLEN offset;
+STRLEN len;
+char *little;
+STRLEN littlelen;
+{
+ register char *big;
+ register char *mid;
+ register char *midend;
+ register char *bigend;
+ register I32 i;
+
+ if (SvREADONLY(bigstr))
+ fatal(no_modify);
+ SvPOK_only(bigstr);
+
+ i = littlelen - len;
+ if (i > 0) { /* string might grow */
+ if (!SvUPGRADE(bigstr, SVt_PV))
+ return;
+ SvGROW(bigstr, SvCUR(bigstr) + i + 1);
+ big = SvPV(bigstr);
+ mid = big + offset + len;
+ midend = bigend = big + SvCUR(bigstr);
+ bigend += i;
+ *bigend = '\0';
+ while (midend > mid) /* shove everything down */
+ *--bigend = *--midend;
+ Move(little,big+offset,littlelen,char);
+ SvCUR(bigstr) += i;
+ SvSETMAGIC(bigstr);
+ return;
+ }
+ else if (i == 0) {
+ Move(little,SvPV(bigstr)+offset,len,char);
+ SvSETMAGIC(bigstr);
+ return;
+ }
+
+ big = SvPV(bigstr);
+ mid = big + offset;
+ midend = mid + len;
+ bigend = big + SvCUR(bigstr);
+
+ if (midend > bigend)
+ fatal("panic: sv_insert");
+
+ if (mid - big > bigend - midend) { /* faster to shorten from end */
+ if (littlelen) {
+ Move(little, mid, littlelen,char);
+ mid += littlelen;
+ }
+ i = bigend - midend;
+ if (i > 0) {
+ Move(midend, mid, i,char);
+ mid += i;
+ }
+ *mid = '\0';
+ SvCUR_set(bigstr, mid - big);
+ }
+ /*SUPPRESS 560*/
+ else if (i = mid - big) { /* faster from front */
+ midend -= littlelen;
+ mid = midend;
+ sv_chop(bigstr,midend-i);
+ big += i;
+ while (i--)
+ *--midend = *--big;
+ if (littlelen)
+ Move(little, mid, littlelen,char);
+ }
+ else if (littlelen) {
+ midend -= littlelen;
+ sv_chop(bigstr,midend);
+ Move(little,midend,littlelen,char);
+ }
+ else {
+ sv_chop(bigstr,midend);
+ }
+ SvSETMAGIC(bigstr);
+}
+
+/* make sv point to what nstr did */
+
+void
+sv_replace(sv,nsv)
+register SV *sv;
+register SV *nsv;
+{
+ U32 refcnt = SvREFCNT(sv);
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (SvREFCNT(nsv) != 1)
+ warn("Reference miscount in sv_replace()");
+ SvREFCNT(sv) = 0;
+ sv_clear(sv);
+ StructCopy(nsv,sv,SV);
+ SvREFCNT(sv) = refcnt;
+ Safefree(nsv);
+}
+
+void
+sv_clear(sv)
+register SV *sv;
+{
+ assert(sv);
+ assert(SvREFCNT(sv) == 0);
+
+ switch (SvTYPE(sv)) {
+ case SVt_PVFM:
+ goto freemagic;
+ case SVt_PVBM:
+ goto freemagic;
+ case SVt_PVGV:
+ gp_free(sv);
+ goto freemagic;
+ case SVt_PVCV:
+ op_free(CvSTART(sv));
+ goto freemagic;
+ case SVt_PVHV:
+ hv_clear(sv, FALSE);
+ goto freemagic;
+ case SVt_PVAV:
+ av_clear(sv);
+ goto freemagic;
+ case SVt_PVLV:
+ goto freemagic;
+ case SVt_PVMG:
+ freemagic:
+ if (SvMAGICAL(sv))
+ mg_freeall(sv);
+ case SVt_PVNV:
+ case SVt_PVIV:
+ SvOOK_off(sv);
+ /* FALL THROUGH */
+ case SVt_PV:
+ if (SvPV(sv))
+ Safefree(SvPV(sv));
+ break;
+ case SVt_NV:
+ break;
+ case SVt_IV:
+ break;
+ case SVt_REF:
+ sv_free((SV*)SvANY(sv));
+ break;
+ case SVt_NULL:
+ break;
+ }
+
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ break;
+ case SVt_REF:
+ break;
+ case SVt_IV:
+ del_XIV(SvANY(sv));
+ break;
+ case SVt_NV:
+ del_XNV(SvANY(sv));
+ break;
+ case SVt_PV:
+ del_XPV(SvANY(sv));
+ break;
+ case SVt_PVIV:
+ del_XPVIV(SvANY(sv));
+ break;
+ case SVt_PVNV:
+ del_XPVNV(SvANY(sv));
+ break;
+ case SVt_PVMG:
+ del_XPVMG(SvANY(sv));
+ break;
+ case SVt_PVLV:
+ del_XPVLV(SvANY(sv));
+ break;
+ case SVt_PVAV:
+ del_XPVAV(SvANY(sv));
+ break;
+ case SVt_PVHV:
+ del_XPVHV(SvANY(sv));
+ break;
+ case SVt_PVCV:
+ del_XPVCV(SvANY(sv));
+ break;
+ case SVt_PVGV:
+ del_XPVGV(SvANY(sv));
+ break;
+ case SVt_PVBM:
+ del_XPVBM(SvANY(sv));
+ break;
+ case SVt_PVFM:
+ del_XPVFM(SvANY(sv));
+ break;
+ }
+ DEB(SvTYPE(sv) = 0xff;)
+}
+
+SV *
+sv_ref(sv)
+SV* sv;
+{
+ SvREFCNT(sv)++;
+ return sv;
+}
+
+void
+sv_free(sv)
+SV *sv;
+{
+ if (!sv)
+ return;
+ if (SvREADONLY(sv)) {
+ if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no)
+ return;
+ }
+ if (SvREFCNT(sv) == 0) {
+ warn("Attempt to free unreferenced scalar");
+ return;
+ }
+ if (--SvREFCNT(sv) > 0)
+ return;
+ if (SvSTORAGE(sv) == 'O') {
+ dSP;
+ BINOP myop; /* fake syntax tree node */
+ GV* destructor;
+
+ SvSTORAGE(sv) = 0; /* Curse the object. */
+
+ ENTER;
+ SAVESPTR(curcop);
+ SAVESPTR(op);
+ curcop = &compiling;
+ curstash = SvSTASH(sv);
+ destructor = gv_fetchpv("DESTROY", FALSE);
+
+ if (GvCV(destructor)) {
+ SV* ref = sv_mortalcopy(&sv_undef);
+ SvREFCNT(ref) = 1;
+ sv_upgrade(ref, SVt_REF);
+ SvANY(ref) = (void*)sv_ref(sv);
+
+ op = (OP*)&myop;
+ Zero(op, 1, OP);
+ myop.op_last = (OP*)&myop;
+ myop.op_flags = OPf_STACKED;
+ myop.op_next = Nullop;
+
+ EXTEND(SP, 2);
+ PUSHs((SV*)destructor);
+ pp_pushmark();
+ PUSHs(ref);
+ PUTBACK;
+ op = pp_entersubr();
+ run();
+ stack_sp--;
+ LEAVE; /* Will eventually free sv as ordinary item. */
+ return;
+ }
+ LEAVE;
+ }
+ sv_clear(sv);
+ DEB(SvTYPE(sv) = 0xff;)
+ del_SV(sv);
+}
+
+STRLEN
+sv_len(sv)
+register SV *sv;
+{
+ I32 paren;
+ I32 i;
+ char *s;
+
+ if (!sv)
+ return 0;
+
+ if (SvMAGICAL(sv))
+ return mg_len(sv, SvMAGIC(sv));
+
+ if (!(SvPOK(sv))) {
+ (void)sv_2pv(sv);
+ if (!SvOK(sv))
+ return 0;
+ }
+ if (SvPV(sv))
+ return SvCUR(sv);
+ else
+ return 0;
+}
+
+I32
+sv_eq(str1,str2)
+register SV *str1;
+register SV *str2;
+{
+ char *pv1;
+ U32 cur1;
+ char *pv2;
+ U32 cur2;
+
+ if (!str1) {
+ pv1 = "";
+ cur1 = 0;
+ }
+ else {
+ if (SvMAGICAL(str1))
+ mg_get(str1);
+ if (!SvPOK(str1)) {
+ (void)sv_2pv(str1);
+ if (!SvPOK(str1))
+ str1 = &sv_no;
+ }
+ pv1 = SvPV(str1);
+ cur1 = SvCUR(str1);
+ }
+
+ if (!str2)
+ return !cur1;
+ else {
+ if (SvMAGICAL(str2))
+ mg_get(str2);
+ if (!SvPOK(str2)) {
+ (void)sv_2pv(str2);
+ if (!SvPOK(str2))
+ return !cur1;
+ }
+ pv2 = SvPV(str2);
+ cur2 = SvCUR(str2);
+ }
+
+ if (cur1 != cur2)
+ return 0;
+
+ return !bcmp(pv1, pv2, cur1);
+}
+
+I32
+sv_cmp(str1,str2)
+register SV *str1;
+register SV *str2;
+{
+ I32 retval;
+ char *pv1;
+ U32 cur1;
+ char *pv2;
+ U32 cur2;
+
+ if (!str1) {
+ pv1 = "";
+ cur1 = 0;
+ }
+ else {
+ if (SvMAGICAL(str1))
+ mg_get(str1);
+ if (!SvPOK(str1)) {
+ (void)sv_2pv(str1);
+ if (!SvPOK(str1))
+ str1 = &sv_no;
+ }
+ pv1 = SvPV(str1);
+ cur1 = SvCUR(str1);
+ }
+
+ if (!str2) {
+ pv2 = "";
+ cur2 = 0;
+ }
+ else {
+ if (SvMAGICAL(str2))
+ mg_get(str2);
+ if (!SvPOK(str2)) {
+ (void)sv_2pv(str2);
+ if (!SvPOK(str2))
+ str2 = &sv_no;
+ }
+ pv2 = SvPV(str2);
+ cur2 = SvCUR(str2);
+ }
+
+ if (!cur1)
+ return cur2 ? -1 : 0;
+ if (!cur2)
+ return 1;
+
+ if (cur1 < cur2) {
+ /*SUPPRESS 560*/
+ if (retval = memcmp(pv1, pv2, cur1))
+ return retval < 0 ? -1 : 1;
+ else
+ return -1;
+ }
+ /*SUPPRESS 560*/
+ else if (retval = memcmp(pv1, pv2, cur2))
+ return retval < 0 ? -1 : 1;
+ else if (cur1 == cur2)
+ return 0;
+ else
+ return 1;
+}
+
+char *
+sv_gets(sv,fp,append)
+register SV *sv;
+register FILE *fp;
+I32 append;
+{
+ register char *bp; /* we're going to steal some values */
+ register I32 cnt; /* from the stdio struct and put EVERYTHING */
+ register STDCHAR *ptr; /* in the innermost loop into registers */
+ register I32 newline = rschar;/* (assuming >= 6 registers) */
+ I32 i;
+ STRLEN bpx;
+ I32 shortbuffered;
+
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (!SvUPGRADE(sv, SVt_PV))
+ return;
+ if (rspara) { /* have to do this both before and after */
+ do { /* to make sure file boundaries work right */
+ i = getc(fp);
+ if (i != '\n') {
+ ungetc(i,fp);
+ break;
+ }
+ } while (i != EOF);
+ }
+#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */
+ cnt = fp->_cnt; /* get count into register */
+ SvPOK_only(sv); /* validate pointer */
+ if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
+ if (cnt > 80 && SvLEN(sv) > append) {
+ shortbuffered = cnt - SvLEN(sv) + append + 1;
+ cnt -= shortbuffered;
+ }
+ else {
+ shortbuffered = 0;
+ SvGROW(sv, append+cnt+2);/* (remembering cnt can be -1) */
+ }
+ }
+ else
+ shortbuffered = 0;
+ bp = SvPV(sv) + 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 :-) */
+ }
+
+ if (shortbuffered) { /* oh well, must extend */
+ cnt = shortbuffered;
+ shortbuffered = 0;
+ bpx = bp - SvPV(sv); /* prepare for possible relocation */
+ SvCUR_set(sv, bpx);
+ SvGROW(sv, SvLEN(sv) + append + cnt + 2);
+ bp = SvPV(sv) + bpx; /* reconstitute our pointer */
+ continue;
+ }
+
+ 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 - SvPV(sv); /* prepare for possible relocation */
+ SvCUR_set(sv, bpx);
+ SvGROW(sv, bpx + cnt + 2);
+ bp = SvPV(sv) + 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_really_all_folks;
+ *bp++ = i; /* now go back to screaming loop */
+ }
+
+thats_all_folks:
+ if (rslen > 1 && (bp - SvPV(sv) < rslen || bcmp(bp - rslen, rs, rslen)))
+ goto screamer; /* go back to the fray */
+thats_really_all_folks:
+ if (shortbuffered)
+ cnt += shortbuffered;
+ fp->_cnt = cnt; /* put these back or we're in trouble */
+ fp->_ptr = ptr;
+ *bp = '\0';
+ SvCUR_set(sv, bp - SvPV(sv)); /* set length */
+
+#else /* !STDSTDIO */ /* The big, slow, and stupid way */
+
+ {
+ char buf[8192];
+ register char * bpe = buf + sizeof(buf) - 3;
+
+screamer:
+ bp = buf;
+ while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) ;
+
+ if (append)
+ sv_catpvn(sv, buf, bp - buf);
+ else
+ sv_setpvn(sv, buf, bp - buf);
+ if (i != EOF /* joy */
+ &&
+ (i != newline
+ ||
+ (rslen > 1
+ &&
+ (SvCUR(sv) < rslen
+ ||
+ bcmp(SvPV(sv) + SvCUR(sv) - rslen, rs, rslen)
+ )
+ )
+ )
+ )
+ {
+ append = -1;
+ goto screamer;
+ }
+ }
+
+#endif /* STDSTDIO */
+
+ if (rspara) {
+ while (i != EOF) {
+ i = getc(fp);
+ if (i != '\n') {
+ ungetc(i,fp);
+ break;
+ }
+ }
+ }
+ return SvCUR(sv) - append ? SvPV(sv) : Nullch;
+}
+
+void
+sv_inc(sv)
+register SV *sv;
+{
+ register char *d;
+
+ if (!sv)
+ return;
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if (SvIOK(sv)) {
+ ++SvIV(sv);
+ SvIOK_only(sv);
+ return;
+ }
+ if (SvNOK(sv)) {
+ SvNV(sv) += 1.0;
+ SvNOK_only(sv);
+ return;
+ }
+ if (!SvPOK(sv) || !*SvPV(sv)) {
+ if (!SvUPGRADE(sv, SVt_NV))
+ return;
+ SvNV(sv) = 1.0;
+ SvNOK_only(sv);
+ return;
+ }
+ d = SvPV(sv);
+ while (isALPHA(*d)) d++;
+ while (isDIGIT(*d)) d++;
+ if (*d) {
+ sv_setnv(sv,atof(SvPV(sv)) + 1.0); /* punt */
+ return;
+ }
+ d--;
+ while (d >= SvPV(sv)) {
+ if (isDIGIT(*d)) {
+ if (++*d <= '9')
+ return;
+ *(d--) = '0';
+ }
+ else {
+ ++*d;
+ if (isALPHA(*d))
+ return;
+ *(d--) -= 'z' - 'a' + 1;
+ }
+ }
+ /* oh,oh, the number grew */
+ SvGROW(sv, SvCUR(sv) + 2);
+ SvCUR(sv)++;
+ for (d = SvPV(sv) + SvCUR(sv); d > SvPV(sv); d--)
+ *d = d[-1];
+ if (isDIGIT(d[1]))
+ *d = '1';
+ else
+ *d = d[1];
+}
+
+void
+sv_dec(sv)
+register SV *sv;
+{
+ if (!sv)
+ return;
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if (SvIOK(sv)) {
+ --SvIV(sv);
+ SvIOK_only(sv);
+ return;
+ }
+ if (SvNOK(sv)) {
+ SvNV(sv) -= 1.0;
+ SvNOK_only(sv);
+ return;
+ }
+ if (!SvPOK(sv)) {
+ if (!SvUPGRADE(sv, SVt_NV))
+ return;
+ SvNV(sv) = -1.0;
+ SvNOK_only(sv);
+ return;
+ }
+ sv_setnv(sv,atof(SvPV(sv)) - 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 we won't free it until it has been assigned to a
+ * permanent location. */
+
+SV *
+sv_mortalcopy(oldstr)
+SV *oldstr;
+{
+ register SV *sv = NEWSV(78,0);
+
+ sv_setsv(sv,oldstr);
+ if (++tmps_ix > tmps_max) {
+ tmps_max = tmps_ix;
+ if (!(tmps_max & 127)) {
+ if (tmps_max)
+ Renew(tmps_stack, tmps_max + 128, SV*);
+ else
+ New(702,tmps_stack, 128, SV*);
+ }
+ }
+ tmps_stack[tmps_ix] = sv;
+ if (SvPOK(sv))
+ SvTEMP_on(sv);
+ return sv;
+}
+
+/* same thing without the copying */
+
+SV *
+sv_2mortal(sv)
+register SV *sv;
+{
+ if (!sv)
+ return sv;
+ if (SvREADONLY(sv))
+ fatal(no_modify);
+ if (++tmps_ix > tmps_max) {
+ tmps_max = tmps_ix;
+ if (!(tmps_max & 127)) {
+ if (tmps_max)
+ Renew(tmps_stack, tmps_max + 128, SV*);
+ else
+ New(704,tmps_stack, 128, SV*);
+ }
+ }
+ tmps_stack[tmps_ix] = sv;
+ if (SvPOK(sv))
+ SvTEMP_on(sv);
+ return sv;
+}
+
+SV *
+newSVpv(s,len)
+char *s;
+STRLEN len;
+{
+ register SV *sv = NEWSV(79,0);
+
+ if (!len)
+ len = strlen(s);
+ sv_setpvn(sv,s,len);
+ return sv;
+}
+
+SV *
+newSVnv(n)
+double n;
+{
+ register SV *sv = NEWSV(80,0);
+
+ sv_setnv(sv,n);
+ return sv;
+}
+
+SV *
+newSViv(i)
+I32 i;
+{
+ register SV *sv = NEWSV(80,0);
+
+ sv_setiv(sv,i);
+ return sv;
+}
+
+/* make an exact duplicate of old */
+
+SV *
+newSVsv(old)
+register SV *old;
+{
+ register SV *new;
+
+ if (!old)
+ return Nullsv;
+ if (SvTYPE(old) == 0xff) {
+ warn("semi-panic: attempt to dup freed string");
+ return Nullsv;
+ }
+ new = NEWSV(80,0);
+ if (SvTEMP(old)) {
+ SvTEMP_off(old);
+ sv_setsv(new,old);
+ SvTEMP_on(old);
+ }
+ else
+ sv_setsv(new,old);
+ return new;
+}
+
+void
+sv_reset(s,stash)
+register char *s;
+HV *stash;
+{
+ register HE *entry;
+ register GV *gv;
+ register SV *sv;
+ register I32 i;
+ register PMOP *pm;
+ register I32 max;
+
+ if (!*s) { /* reset ?? searches */
+ for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
+ pm->op_pmflags &= ~PMf_USED;
+ }
+ return;
+ }
+
+ /* reset variables */
+
+ if (!HvARRAY(stash))
+ return;
+ while (*s) {
+ i = *s;
+ if (s[1] == '-') {
+ s += 2;
+ }
+ max = *s++;
+ for ( ; i <= max; i++) {
+ for (entry = HvARRAY(stash)[i];
+ entry;
+ entry = entry->hent_next) {
+ gv = (GV*)entry->hent_val;
+ sv = GvSV(gv);
+ SvOK_off(sv);
+ if (SvTYPE(sv) >= SVt_PV) {
+ SvCUR_set(sv, 0);
+ SvTDOWN(sv);
+ if (SvPV(sv) != Nullch)
+ *SvPV(sv) = '\0';
+ }
+ if (GvAV(gv)) {
+ av_clear(GvAV(gv));
+ }
+ if (GvHV(gv)) {
+ hv_clear(GvHV(gv), FALSE);
+ if (gv == envgv)
+ environ[0] = Nullch;
+ }
+ }
+ }
+ }
+}
+
+#ifdef OLD
+AV *
+sv_2av(sv, st, gvp, lref)
+SV *sv;
+HV **st;
+GV **gvp;
+I32 lref;
+{
+ GV *gv;
+
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ *st = sv->sv_u.sv_stash;
+ *gvp = Nullgv;
+ return sv->sv_u.sv_av;
+ case SVt_PVHV:
+ case SVt_PVCV:
+ *gvp = Nullgv;
+ return Nullav;
+ default:
+ if (isGV(sv))
+ gv = (GV*)sv;
+ else
+ gv = gv_fetchpv(SvPVn(sv), lref);
+ *gvp = gv;
+ if (!gv)
+ return Nullav;
+ *st = GvESTASH(gv);
+ if (lref)
+ return GvAVn(gv);
+ else
+ return GvAV(gv);
+ }
+}
+
+HV *
+sv_2hv(sv, st, gvp, lref)
+SV *sv;
+HV **st;
+GV **gvp;
+I32 lref;
+{
+ GV *gv;
+
+ switch (SvTYPE(sv)) {
+ case SVt_PVHV:
+ *st = sv->sv_u.sv_stash;
+ *gvp = Nullgv;
+ return sv->sv_u.sv_hv;
+ case SVt_PVAV:
+ case SVt_PVCV:
+ *gvp = Nullgv;
+ return Nullhv;
+ default:
+ if (isGV(sv))
+ gv = (GV*)sv;
+ else
+ gv = gv_fetchpv(SvPVn(sv), lref);
+ *gvp = gv;
+ if (!gv)
+ return Nullhv;
+ *st = GvESTASH(gv);
+ if (lref)
+ return GvHVn(gv);
+ else
+ return GvHV(gv);
+ }
+}
+#endif;
+
+CV *
+sv_2cv(sv, st, gvp, lref)
+SV *sv;
+HV **st;
+GV **gvp;
+I32 lref;
+{
+ GV *gv;
+ CV *cv;
+
+ if (!sv)
+ return Nullcv;
+ switch (SvTYPE(sv)) {
+ case SVt_REF:
+ cv = (CV*)SvANY(sv);
+ if (SvTYPE(cv) != SVt_PVCV)
+ fatal("Not a subroutine reference");
+ *gvp = Nullgv;
+ *st = CvSTASH(cv);
+ return cv;
+ case SVt_PVCV:
+ *st = CvSTASH(sv);
+ *gvp = Nullgv;
+ return (CV*)sv;
+ case SVt_PVHV:
+ case SVt_PVAV:
+ *gvp = Nullgv;
+ return Nullcv;
+ default:
+ if (isGV(sv))
+ gv = (GV*)sv;
+ else
+ gv = gv_fetchpv(SvPVn(sv), lref);
+ *gvp = gv;
+ if (!gv)
+ return Nullcv;
+ *st = GvESTASH(gv);
+ return GvCV(gv);
+ }
+}
+
+#ifndef SvTRUE
+I32
+SvTRUE(sv)
+register SV *sv;
+{
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if (SvPOK(sv)) {
+ register XPV* Xpv;
+ if ((Xpv = (XPV*)SvANY(sv)) &&
+ (*Xpv->xpv_pv > '0' ||
+ Xpv->xpv_cur > 1 ||
+ (Xpv->xpv_cur && *Xpv->xpv_pv != '0')))
+ return 1;
+ else
+ return 0;
+ }
+ else {
+ if (SvIOK(sv))
+ return SvIV(sv) != 0;
+ else {
+ if (SvNOK(sv))
+ return SvNV(sv) != 0.0;
+ else
+ return 0;
+ }
+ }
+}
+#endif /* SvTRUE */
+
+#ifndef SvNVn
+double SvNVn(Sv)
+register SV *Sv;
+{
+ SvTUP(Sv);
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if (SvNOK(Sv))
+ return SvNV(Sv);
+ if (SvIOK(Sv))
+ return (double)SvIV(Sv);
+ return sv_2nv(Sv);
+}
+#endif /* SvNVn */
+
+#ifndef SvPVn
+char *
+SvPVn(sv)
+SV *sv;
+{
+ SvTUP(sv);
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ return SvPOK(sv) ? SvPV(sv) : sv_2pv(sv);
+}
+#endif
+
--- /dev/null
+/* $RCSfile: sv.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:57 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: sv.h,v $
+ * Revision 4.1 92/08/07 18:26:57 lwall
+ *
+ * Revision 4.0.1.4 92/06/08 15:41:45 lwall
+ * patch20: fixed confusion between a *var's real name and its effective name
+ * patch20: removed implicit int declarations on functions
+ *
+ * Revision 4.0.1.3 91/11/05 18:41:47 lwall
+ * patch11: random cleanup
+ * patch11: solitary subroutine references no longer trigger typo warnings
+ *
+ * Revision 4.0.1.2 91/06/07 11:58:33 lwall
+ * patch4: new copyright notice
+ *
+ * Revision 4.0.1.1 91/04/12 09:16:12 lwall
+ * patch1: you may now use "die" and "caller" in a signal handler
+ *
+ * Revision 4.0 91/03/20 01:40:04 lwall
+ * 4.0 baseline.
+ *
+ */
+
+typedef enum {
+ SVt_NULL,
+ SVt_REF,
+ SVt_IV,
+ SVt_NV,
+ SVt_PV,
+ SVt_PVIV,
+ SVt_PVNV,
+ SVt_PVMG,
+ SVt_PVLV,
+ SVt_PVAV,
+ SVt_PVHV,
+ SVt_PVCV,
+ SVt_PVGV,
+ SVt_PVBM,
+ SVt_PVFM,
+} svtype;
+
+/* Compensate for ANSI C misdesign... */
+#ifdef DEBUGGING
+#define SVTYPE svtype
+#else
+#define SVTYPE U8
+#endif
+
+/* Using C's structural equivalence to help emulate C++ inheritance here... */
+
+struct sv {
+ ANY sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ SVTYPE sv_type; /* what sort of thing pointer points to */
+ U8 sv_flags; /* extra flags, some depending on type */
+ U8 sv_storage; /* storage class */
+ U8 sv_private; /* extra value, depending on type */
+};
+
+struct gv {
+ ANY sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ SVTYPE sv_type; /* what sort of thing pointer points to */
+ U8 sv_flags; /* extra flags, some depending on type */
+ U8 sv_storage; /* storage class */
+ U8 sv_private; /* extra value, depending on type */
+};
+
+struct cv {
+ ANY sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ SVTYPE sv_type; /* what sort of thing pointer points to */
+ U8 sv_flags; /* extra flags, some depending on type */
+ U8 sv_storage; /* storage class */
+ U8 sv_private; /* extra value, depending on type */
+};
+
+struct av {
+ ANY sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ SVTYPE sv_type; /* what sort of thing pointer points to */
+ U8 sv_flags; /* extra flags, some depending on type */
+ U8 sv_storage; /* storage class */
+ U8 sv_private; /* extra value, depending on type */
+};
+
+struct hv {
+ ANY sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ SVTYPE sv_type; /* what sort of thing pointer points to */
+ U8 sv_flags; /* extra flags, some depending on type */
+ U8 sv_storage; /* storage class */
+ U8 sv_private; /* extra value, depending on type */
+};
+
+#define SvANY(sv) (sv)->sv_any.any_ptr
+#define SvANYI32(sv) (sv)->sv_any.any_i32
+#define SvTYPE(sv) (sv)->sv_type
+#define SvREFCNT(sv) (sv)->sv_refcnt
+#define SvFLAGS(sv) (sv)->sv_flags
+#define SvSTORAGE(sv) (sv)->sv_storage
+#define SvPRIVATE(sv) (sv)->sv_private
+
+#define SvUPGRADE(sv, mt) (SvTYPE(sv) >= mt || sv_upgrade(sv, mt))
+
+#define SVf_IOK 1 /* has valid integer value */
+#define SVf_NOK 2 /* has valid numeric value */
+#define SVf_POK 4 /* has valid pointer value */
+#define SVf_OOK 8 /* has valid offset value */
+#define SVf_MAGICAL 16 /* has special methods */
+#define SVf_SCREAM 32 /* eventually in sv_private? */
+#define SVf_TEMP 64 /* eventually in sv_private? */
+#define SVf_READONLY 128 /* may not be modified */
+
+#define SVp_TAINTED 128 /* is a security risk */
+
+#define SVpfm_COMPILED 1
+
+#define SVpbm_TAIL 1
+#define SVpbm_CASEFOLD 2
+#define SVpbm_VALID 4
+
+#define SVpgv_MULTI 1
+
+struct xpv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+};
+
+struct xpviv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+};
+
+struct xpvnv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+};
+
+struct xpvmg {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+};
+
+struct xpvlv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+ STRLEN xlv_targoff;
+ STRLEN xlv_targlen;
+ SV* xlv_targ;
+ char xlv_type;
+};
+
+struct xpvgv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+ GP* xgv_gp;
+ char* xgv_name;
+ STRLEN xgv_namelen;
+ HV* xgv_stash;
+};
+
+struct xpvbm {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+ I32 xbm_useful; /* is this constant pattern being useful? */
+ U16 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_rare; /* rarest character in string */
+};
+
+struct xpvfm {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+ HV * xcv_stash;
+ OP * xcv_start;
+ OP * xcv_root;
+ I32 (*xcv_usersub)();
+ I32 xcv_userindex;
+ GV * xcv_filegv;
+ long xcv_depth; /* >= 2 indicates recursive call */
+ AV * xcv_padlist;
+ bool xcv_deleted;
+ I32 xfm_lines;
+};
+
+/* XXX need to write custom routines for some of these */
+#define new_SV() (void*)malloc(sizeof(SV))
+#define del_SV(p) free((char*)p)
+
+#define new_XIV() (void*)malloc(sizeof(XPVIV))
+#define del_XIV(p) free((char*)p)
+
+#define new_XNV() (void*)malloc(sizeof(XPVNV))
+#define del_XNV(p) free((char*)p)
+
+#define new_XPV() (void*)malloc(sizeof(XPV))
+#define del_XPV(p) free((char*)p)
+
+#define new_XPVIV() (void*)malloc(sizeof(XPVIV))
+#define del_XPVIV(p) free((char*)p)
+
+#define new_XPVNV() (void*)malloc(sizeof(XPVNV))
+#define del_XPVNV(p) free((char*)p)
+
+#define new_XPVMG() (void*)malloc(sizeof(XPVMG))
+#define del_XPVMG(p) free((char*)p)
+
+#define new_XPVLV() (void*)malloc(sizeof(XPVLV))
+#define del_XPVLV(p) free((char*)p)
+
+#define new_XPVAV() (void*)malloc(sizeof(XPVAV))
+#define del_XPVAV(p) free((char*)p)
+
+#define new_XPVHV() (void*)malloc(sizeof(XPVHV))
+#define del_XPVHV(p) free((char*)p)
+
+#define new_XPVCV() (void*)malloc(sizeof(XPVCV))
+#define del_XPVCV(p) free((char*)p)
+
+#define new_XPVGV() (void*)malloc(sizeof(XPVGV))
+#define del_XPVGV(p) free((char*)p)
+
+#define new_XPVBM() (void*)malloc(sizeof(XPVBM))
+#define del_XPVBM(p) free((char*)p)
+
+#define new_XPVFM() (void*)malloc(sizeof(XPVFM))
+#define del_XPVFM(p) free((char*)p)
+
+#define SvNIOK(sv) (SvFLAGS(sv) & (SVf_IOK|SVf_NOK))
+
+#define SvOK(sv) (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))
+#define SvOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK), \
+ SvOOK_off(sv))
+
+#define SvIOK(sv) (SvFLAGS(sv) & SVf_IOK)
+#define SvIOK_on(sv) (SvOOK_off(sv), SvFLAGS(sv) |= SVf_IOK)
+#define SvIOK_off(sv) (SvFLAGS(sv) &= ~SVf_IOK)
+#define SvIOK_only(sv) (SvOK_off(sv), SvFLAGS(sv) |= SVf_IOK)
+
+#define SvNOK(sv) (SvFLAGS(sv) & SVf_NOK)
+#define SvNOK_on(sv) (SvFLAGS(sv) |= SVf_NOK)
+#define SvNOK_off(sv) (SvFLAGS(sv) &= ~SVf_NOK)
+#define SvNOK_only(sv) (SvOK_off(sv), SvFLAGS(sv) |= SVf_NOK)
+
+#define SvPOK(sv) (SvFLAGS(sv) & SVf_POK)
+#define SvPOK_on(sv) (SvFLAGS(sv) |= SVf_POK)
+#define SvPOK_off(sv) (SvFLAGS(sv) &= ~SVf_POK)
+#define SvPOK_only(sv) (SvOK_off(sv), SvFLAGS(sv) |= SVf_POK)
+
+#define SvOOK(sv) (SvFLAGS(sv) & SVf_OOK)
+#define SvOOK_on(sv) (SvIOK_off(sv), SvFLAGS(sv) |= SVf_OOK)
+#define SvOOK_off(sv) (SvOOK(sv) && sv_backoff(sv))
+#define SvOOK_only(sv) (SvOK_off(sv), SvFLAGS(sv) |= SVf_OOK)
+
+#define SvREADONLY(sv) (SvFLAGS(sv) & SVf_READONLY)
+#define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
+#define SvREADONLY_off(sv) (SvFLAGS(sv) &= ~SVf_READONLY)
+
+#define SvMAGICAL(sv) (SvFLAGS(sv) & SVf_MAGICAL)
+#define SvMAGICAL_on(sv) (SvFLAGS(sv) |= SVf_MAGICAL)
+#define SvMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVf_MAGICAL)
+
+#define SvSCREAM(sv) (SvFLAGS(sv) & SVf_SCREAM)
+#define SvSCREAM_on(sv) (SvFLAGS(sv) |= SVf_SCREAM)
+#define SvSCREAM_off(sv) (SvFLAGS(sv) &= ~SVf_SCREAM)
+
+#define SvTEMP(sv) (SvFLAGS(sv) & SVf_TEMP)
+#define SvTEMP_on(sv) (SvFLAGS(sv) |= SVf_TEMP)
+#define SvTEMP_off(sv) (SvFLAGS(sv) &= ~SVf_TEMP)
+
+#define SvTAINTED(sv) (SvPRIVATE(sv) & SVp_TAINTED)
+#define SvTAINTED_on(sv) (SvPRIVATE(sv) |= SVp_TAINTED)
+#define SvTAINTED_off(sv) (SvPRIVATE(sv) &= ~SVp_TAINTED)
+
+#define SvCOMPILED(sv) (SvPRIVATE(sv) & SVpfm_COMPILED)
+#define SvCOMPILED_on(sv) (SvPRIVATE(sv) |= SVpfm_COMPILED)
+#define SvCOMPILED_off(sv) (SvPRIVATE(sv) &= ~SVpfm_COMPILED)
+
+#define SvTAIL(sv) (SvPRIVATE(sv) & SVpbm_TAIL)
+#define SvTAIL_on(sv) (SvPRIVATE(sv) |= SVpbm_TAIL)
+#define SvTAIL_off(sv) (SvPRIVATE(sv) &= ~SVpbm_TAIL)
+
+#define SvCASEFOLD(sv) (SvPRIVATE(sv) & SVpbm_CASEFOLD)
+#define SvCASEFOLD_on(sv) (SvPRIVATE(sv) |= SVpbm_CASEFOLD)
+#define SvCASEFOLD_off(sv) (SvPRIVATE(sv) &= ~SVpbm_CASEFOLD)
+
+#define SvVALID(sv) (SvPRIVATE(sv) & SVpbm_VALID)
+#define SvVALID_on(sv) (SvPRIVATE(sv) |= SVpbm_VALID)
+#define SvVALID_off(sv) (SvPRIVATE(sv) &= ~SVpbm_VALID)
+
+#define SvMULTI(sv) (SvPRIVATE(sv) & SVpgv_MULTI)
+#define SvMULTI_on(sv) (SvPRIVATE(sv) |= SVpgv_MULTI)
+#define SvMULTI_off(sv) (SvPRIVATE(sv) &= ~SVpgv_MULTI)
+
+#define SvIV(sv) ((XPVIV*) SvANY(sv))->xiv_iv
+#define SvIVx(sv) SvIV(sv)
+#define SvNV(sv) ((XPVNV*)SvANY(sv))->xnv_nv
+#define SvNVx(sv) SvNV(sv)
+#define SvPV(sv) ((XPV*) SvANY(sv))->xpv_pv
+#define SvPVx(sv) SvPV(sv)
+#define SvCUR(sv) ((XPV*) SvANY(sv))->xpv_cur
+#define SvCURx(sv) SvCUR(sv)
+#define SvLEN(sv) ((XPV*) SvANY(sv))->xpv_len
+#define SvLENx(sv) SvLEN(sv)
+#define SvEND(sv)(((XPV*) SvANY(sv))->xpv_pv + ((XPV*)SvANY(sv))->xpv_cur)
+#define SvENDx(sv) ((Sv = sv), SvEND(Sv))
+#define SvMAGIC(sv) ((XPVMG*) SvANY(sv))->xmg_magic
+#define SvSTASH(sv) ((XPVMG*) SvANY(sv))->xmg_stash
+
+#define SvIV_set(sv, val) \
+ do { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
+ (((XPVIV*) SvANY(sv))->xiv_iv = val); } while (0)
+#define SvNV_set(sv, val) \
+ do { assert(SvTYPE(sv) == SVt_NV || SvTYPE(sv) >= SVt_PVNV); \
+ (((XPVNV*) SvANY(sv))->xnv_nv = val); } while (0)
+#define SvPV_set(sv, val) \
+ do { assert(SvTYPE(sv) >= SVt_PV); \
+ (((XPV*) SvANY(sv))->xpv_pv = val); } while (0)
+#define SvCUR_set(sv, val) \
+ do { assert(SvTYPE(sv) >= SVt_PV); \
+ (((XPV*) SvANY(sv))->xpv_cur = val); } while (0)
+#define SvLEN_set(sv, val) \
+ do { assert(SvTYPE(sv) >= SVt_PV); \
+ (((XPV*) SvANY(sv))->xpv_len = val); } while (0)
+#define SvEND_set(sv, val) \
+ do { assert(SvTYPE(sv) >= SVt_PV); \
+ (((XPV*) SvANY(sv))->xpv_cur = val - SvPV(sv)); } while (0)
+
+#define BmRARE(sv) ((XPVBM*) SvANY(sv))->xbm_rare
+#define BmUSEFUL(sv) ((XPVBM*) SvANY(sv))->xbm_useful
+#define BmPREVIOUS(sv) ((XPVBM*) SvANY(sv))->xbm_previous
+
+#define FmLINES(sv) ((XPVFM*) SvANY(sv))->xfm_lines
+
+#define LvTYPE(sv) ((XPVLV*) SvANY(sv))->xlv_type
+#define LvTARG(sv) ((XPVLV*) SvANY(sv))->xlv_targ
+#define LvTARGOFF(sv) ((XPVLV*) SvANY(sv))->xlv_targoff
+#define LvTARGLEN(sv) ((XPVLV*) SvANY(sv))->xlv_targlen
+
+#ifdef TAINT
+#define SvTUP(sv) (tainted |= (SvPRIVATE(sv) & SVp_TAINTED))
+#define SvTUPc(sv) (tainted |= (SvPRIVATE(sv) & SVp_TAINTED)),
+#define SvTDOWN(sv) (SvPRIVATE(sv) |= tainted ? SVp_TAINTED : 0)
+#define SvTDOWNc(sv) (SvPRIVATE(sv) |= tainted ? SVp_TAINTED : 0),
+#else
+#define SvTUP(sv)
+#define SvTUPc(sv)
+#define SvTDOWN(sv)
+#define SvTDOWNc(sv)
+#endif
+
+#ifdef CRIPPLED_CC
+
+double SvIVn();
+double SvNVn();
+char *SvPVn();
+I32 SvTRUE();
+
+#define SvIVnx(sv) SvIVn(sv)
+#define SvNVnx(sv) SvNVn(sv)
+#define SvPVnx(sv) SvPVn(sv)
+#define SvTRUEx(sv) SvTRUE(sv)
+
+#else /* !CRIPPLED_CC */
+
+#define SvIVn(sv) (SvTUPc(sv) (SvMAGICAL(sv) && mg_get(sv)), \
+ SvIOK(sv) ? SvIV(sv) : sv_2iv(sv))
+
+#define SvNVn(sv) (SvTUPc(sv) (SvMAGICAL(sv) && mg_get(sv)), \
+ SvNOK(sv) ? SvNV(sv) : sv_2nv(sv))
+
+#define SvPVn(sv) (SvTUPc(sv) (SvMAGICAL(sv) && mg_get(sv)), \
+ SvPOK(sv) ? SvPV(sv) : sv_2pv(sv))
+
+#define SvTRUE(sv) ((SvMAGICAL(sv) && mg_get(sv)), \
+ SvPOK(sv) \
+ ? ((Xpv = (XPV*)SvANY(sv)) && \
+ (*Xpv->xpv_pv > '0' || \
+ Xpv->xpv_cur > 1 || \
+ (Xpv->xpv_cur && *Xpv->xpv_pv != '0')) \
+ ? 1 \
+ : 0) \
+ : \
+ SvIOK(sv) \
+ ? SvIV(sv) != 0 \
+ : SvNOK(sv) \
+ ? SvNV(sv) != 0.0 \
+ : 0 )
+
+#define SvIVnx(sv) ((Sv = sv), SvIVn(Sv))
+#define SvNVnx(sv) ((Sv = sv), SvNVn(Sv))
+#define SvPVnx(sv) ((Sv = sv), SvPVn(Sv))
+#define SvTRUEx(sv) ((Sv = sv), SvTRUE(Sv))
+
+#endif /* CRIPPLED_CC */
+
+/* the following macro updates any magic values this sv is associated with */
+
+#define SvGETMAGIC(x) \
+ SvTUP(x); \
+ if (SvMAGICAL(x)) mg_get(x)
+
+#define SvSETMAGIC(x) \
+ SvTDOWN(x); \
+ if (SvMAGICAL(x)) \
+ mg_set(x)
+
+#define SvSetSV(dst,src) if (dst != src) sv_setsv(dst,src)
+
+#define SvPEEK(sv) sv_peek(sv)
+
+#define isGV(sv) (SvTYPE(sv) == SVt_PVGV)
+
+#define GROWSTR(pp,lp,len) if (*(lp) < (len)) pv_grow(pp, lp, (len) * 3 / 2)
+
+#ifndef DOSISH
+# define SvGROW(sv,len) if (SvLEN(sv) < (len)) sv_grow(sv,len)
+# define Sv_Grow sv_grow
+#else
+ /* extra parentheses intentionally NOT placed around "len"! */
+# define SvGROW(sv,len) if (SvLEN(sv) < (unsigned long)len) \
+ sv_grow(sv,(unsigned long)len)
+# define Sv_Grow(sv,len) sv_grow(sv,(unsigned long)(len))
+#endif /* DOSISH */
+
#!./perl
-# $RCSfile: TEST,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:59:30 $
+# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
# This is written in a peculiar style, since we're trying to avoid
# most of the constructs we'll be testing for.
}
}
$bad = 0;
+$good = 0;
+$total = @ARGV;
while ($test = shift) {
if ($test =~ /^$/) {
next;
$next = $next - 1;
if ($ok && $next == $max) {
print "ok\n";
+ $good = $good + 1;
} else {
$next += 1;
print "FAILED on test $next\n";
die "FAILED--no tests were run for some reason.\n";
}
} else {
+ $pct = sprintf("%.2f", $good / $total * 100);
if ($bad == 1) {
- die "Failed 1 test.\n";
+ warn "Failed 1 test, $pct% okay.\n";
} else {
- die "Failed $bad tests.\n";
+ die "Failed $bad/$total tests, $pct% okay.\n";
}
}
($user,$sys,$cuser,$csys) = times;
--- /dev/null
+#!./perl -Dxst
+require "../lib/bigint.pl";
+
+$test = 0;
+$| = 1;
+print "1..246\n";
+while (<DATA>) {
+ chop;
+ if (/^&/) {
+ $f = $_;
+ } else {
+ ++$test;
+ @args = split(/:/,$_,99);
+ $ans = pop(@args);
+ $try = "$f('" . join("','", @args) . "');";
+ if (($ans1 = eval($try)) eq $ans) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ print "# '$try' expected: '$ans' got: '$ans1'\n";
+ }
+ }
+}
+__END__
+&bdiv
+abc:abc:NaN
+abc:+1:abc:NaN
++1:abc:NaN
++0:+0:NaN
++0:+1:+0
++1:+0:NaN
++0:-1:+0
+-1:+0:NaN
++1:+1:+1
+-1:-1:+1
++1:-1:-1
+-1:+1:-1
++1:+2:+0
++2:+1:+2
++1000000000:+9:+111111111
++2000000000:+9:+222222222
++3000000000:+9:+333333333
++4000000000:+9:+444444444
++5000000000:+9:+555555555
++6000000000:+9:+666666666
++7000000000:+9:+777777777
++8000000000:+9:+888888888
++9000000000:+9:+1000000000
++35500000:+113:+314159
++71000000:+226:+314159
++106500000:+339:+314159
++1000000000:+3:+333333333
++10:+5:+2
++100:+4:+25
++1000:+8:+125
++10000:+16:+625
++999999999999:+9:+111111111111
++999999999999:+99:+10101010101
++999999999999:+999:+1001001001
++999999999999:+9999:+100010001
++999999999999999:+99999:+10000100001
+&bmod
+abc:abc:NaN
+abc:+1:abc:NaN
++1:abc:NaN
++0:+0:NaN
++0:+1:+0
++1:+0:NaN
++0:-1:+0
+-1:+0:NaN
++1:+1:+0
+-1:-1:+0
++1:-1:+0
+-1:+1:+0
++1:+2:+1
++2:+1:+0
++1000000000:+9:+1
++2000000000:+9:+2
++3000000000:+9:+3
++4000000000:+9:+4
++5000000000:+9:+5
++6000000000:+9:+6
++7000000000:+9:+7
++8000000000:+9:+8
++9000000000:+9:+0
++35500000:+113:+33
++71000000:+226:+66
++106500000:+339:+99
++1000000000:+3:+1
++10:+5:+0
++100:+4:+0
++1000:+8:+0
++10000:+16:+0
++999999999999:+9:+0
++999999999999:+99:+0
++999999999999:+999:+0
++999999999999:+9999:+0
++999999999999999:+99999:+0
+&bgcd
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++0:+1:+1
++1:+0:+1
++1:+1:+1
++2:+3:+1
++3:+2:+1
++100:+625:+25
++4096:+81:+1
#!./perl
-# $Header: cond.t,v 4.0 91/03/20 01:48:54 lwall Locked $
+# $RCSfile: cond.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:02 $
# make sure conditional operators work
#!./perl
-# $Header: if.t,v 4.0 91/03/20 01:49:03 lwall Locked $
+# $RCSfile: if.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:03 $
print "1..2\n";
#!./perl
-# $Header: lex.t,v 4.0 91/03/20 01:49:08 lwall Locked $
+# $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $
-print "1..18\n";
+print "1..24\n";
-$ # this is the register <space>
-= 'x';
+$x = 'x';
-print "#1 :$ : eq :x:\n";
-if ($ eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
+print "#1 :$x: eq :x:\n";
+if ($x eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
$x = $#; # this is the register $#
';
eval '$foo{1} / 1;';
-if (!$@) {print "ok 6\n";} else {print "not ok 6\n";}
+if (!$@) {print "ok 6\n";} else {print "not ok 6 $@\n";}
eval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
ok 18
# previous line intentionally left blank.
+
+$foo = FOO;
+$bar = BAR;
+$foo{$bar} = BAZ;
+$ary[0] = ABC;
+
+print "$foo{$bar}" eq "BAZ" ? "ok 19\n" : "not ok 19\n";
+
+print "${foo}{$bar}" eq "FOO{BAR}" ? "ok 20\n" : "not ok 20\n";
+print "${foo{$bar}}" eq "BAZ" ? "ok 21\n" : "not ok 21\n";
+
+print "FOO:" =~ /$foo[:]/ ? "ok 22\n" : "not ok 22\n";
+print "ABC" =~ /^$ary[$A]$/ ? "ok 23\n" : "not ok 23\n";
+print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 24\n" : "not ok 24\n";
#!./perl
-# $Header: pat.t,v 4.0 91/03/20 01:49:12 lwall Locked $
+# $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:05 $
print "1..2\n";
#!./perl
-# $Header: term.t,v 4.0 91/03/20 01:49:17 lwall Locked $
+# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:07 $
print "1..6\n";
--- /dev/null
+TEST
\ No newline at end of file
#!./perl
-# $Header: elsif.t,v 4.0 91/03/20 01:49:21 lwall Locked $
+# $RCSfile: elsif.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:08 $
sub foo {
if ($_[0] == 1) {
#!./perl
-# $Header: for.t,v 4.0 91/03/20 01:49:26 lwall Locked $
+# $RCSfile: for.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:09 $
print "1..7\n";
#!./perl
-# $Header: mod.t,v 4.0 91/03/20 01:49:33 lwall Locked $
+# $RCSfile: mod.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:11 $
print "1..7\n";
if (join(' ',@x) eq '0 1 2 3 4 5 6 7 8 9 10') {
print "ok 5\n";
} else {
- print "not ok 5\n";
+ print "not ok 5 @x\n";
}
$x = 15;
#!./perl
-# $RCSfile: subval.t,v $$Revision: 4.0.1.1 $$Date: 91/11/05 18:42:31 $
+# $RCSfile: subval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:13 $
sub foo1 {
'true1';
#!./perl
-# $Header: switch.t,v 4.0 91/03/20 01:49:44 lwall Locked $
+# $RCSfile: switch.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:14 $
print "1..18\n";
return $_;
}
-print do foo2(0) == 20 ? "ok 7\n" : "not ok 1\n";
+print do foo2(0) == 20 ? "ok 7\n" : "not ok 7\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";
#!./perl
-# $Header: while.t,v 4.0 91/03/20 01:49:51 lwall Locked $
+# $RCSfile: while.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:15 $
print "1..10\n";
#!./perl
-# $Header: cmdopt.t,v 4.0 91/03/20 01:49:58 lwall Locked $
+# $RCSfile: cmdopt.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:17 $
print "1..40\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";}
+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";}
#!./perl -P
-# $RCSfile: cpp.t,v $$Revision: 4.0.1.1 $$Date: 92/06/08 15:42:08 $
+# $RCSfile: cpp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:18 $
open(CONFIG,"../config.sh") || die;
while (<CONFIG>) {
if (/^cppstdin/) {
if (/^cppstdin='(.*cppstdin)'/ && ! -e $1) {
print "1..0\n";
- exit; # Can't test till after install, alas.
+ exit; # Cannot test till after install, alas.
}
last;
}
#!./perl
-# $Header: decl.t,v 4.0 91/03/20 01:50:09 lwall Locked $
+# $RCSfile: decl.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:19 $
# check to see if subroutine declarations work everwhere
#!./perl
-# $Header: multiline.t,v 4.0 91/03/20 01:50:15 lwall Locked $
+# $RCSfile: multiline.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:20 $
print "1..5\n";
#!./perl
-# $Header: script.t,v 4.0 91/03/20 01:50:26 lwall Locked $
+# $RCSfile: script.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:23 $
print "1..3\n";
#!./perl
-# $Header: term.t,v 4.0 91/03/20 01:50:36 lwall Locked $
+# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:24 $
# tests that aren't important enough for base.term
--- /dev/null
+#!./perl
+
+$_ = 'aaabbbccc';
+if (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
+ print "ok 14\n";
+} else {
+ print "not ok 14\n";
+}
--- /dev/null
+'((a))'i ABC y $&-$1-$2 A-A-A
#!./perl
-# $Header: argv.t,v 4.0 91/03/20 01:50:46 lwall Locked $
+# $RCSfile: argv.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:25 $
print "1..5\n";
#!./perl
-# $Header: dup.t,v 4.0 91/03/20 01:50:49 lwall Locked $
+# $RCSfile: dup.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:27 $
print "1..6\n";
#!./perl
-# $Header: fs.t,v 4.0 91/03/20 01:50:55 lwall Locked $
+# $RCSfile: fs.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:28 $
print "1..22\n";
+++ /dev/null
-#!./perl
-
-# $Header: fs.t,v 4.0 91/03/20 01:50:55 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) || $wd =~ m#/afs/#)
- {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";
-}
+++ /dev/null
-***************
-*** 1,6 ****
- #!./perl
-
-! # $Header: fs.t,v 4.0 1991/03/20 01:50:55 lwall Locked $
-
- print "1..22\n";
-
---- 1,6 ----
- #!./perl
-
-! # $RCSfile: fs.t,v $$Revision: 4.0.1.1 $$Date: 1993/02/05 19:44:34 $
-
- print "1..22\n";
-
$^I = '.bak';
-# $Header: inplace.t,v 4.0 91/03/20 01:50:59 lwall Locked $
+# $RCSfile: inplace.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:29 $
print "1..2\n";
#!./perl
-# $Header: pipe.t,v 4.0 91/03/20 01:51:02 lwall Locked $
+# $RCSfile: pipe.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:31 $
$| = 1;
print "1..8\n";
#!./perl
-# $Header: print.t,v 4.0 91/03/20 01:51:08 lwall Locked $
+# $RCSfile: print.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:32 $
print "1..16\n";
#!./perl
-# $Header: tell.t,v 4.0 91/03/20 01:51:14 lwall Locked $
+# $RCSfile: tell.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:33 $
print "1..13\n";
--- /dev/null
+forceme 'cd ..; make'
--- /dev/null
+all:
+ forceme 'cd ..; $(MAKE)'
+
+perl: fooperl
+
+fooperl:
+ forceme 'cd ..; $(MAKE) perl'
#!./perl
-# $Header: append.t,v 4.0 91/03/20 01:51:23 lwall Locked $
+# $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $
print "1..3\n";
#!./perl
-# $Header: array.t,v 4.0 91/03/20 01:51:31 lwall Locked $
+# $RCSfile: array.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:37 $
print "1..36\n";
#!./perl
-# $Header: auto.t,v 4.0 91/03/20 01:51:35 lwall Locked $
+# $RCSfile: auto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:39 $
print "1..34\n";
#!./perl
-# $Header: chop.t,v 4.0 91/03/20 01:51:42 lwall Locked $
+# $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $
print "1..4\n";
#!./perl
-# $Header: cond.t,v 4.0 91/03/20 01:51:47 lwall Locked $
+# $RCSfile: cond.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:41 $
print "1..4\n";
#!./perl
-# $RCSfile: dbm.t,v $$Revision: 4.0.1.1 $$Date: 92/06/08 15:43:02 $
+# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h'
&& !-r '/usr/include/rpcsvc/dbm.h') {
print "1..12\n";
unlink <Op.dbmx.*>;
+unlink Op.dbmx; # in case we're running gdbm
+
umask(0);
print (dbmopen(h,'Op.dbmx',0640) ? "ok 1\n" : "not ok 1\n");
+
+$Dfile = "Op.dbmx.pag";
+if (! -e $Dfile) {
+ $Dfile = "Op.dbmx";
+ print "# Probably a gdbm database\n";
+}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat('Op.dbmx.pag');
+ $blksize,$blocks) = stat($Dfile);
print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
while (($key,$value) = each(h)) {
$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');
+ $blksize,$blocks) = stat($Dfile);
print ($size > 0 ? "ok 9\n" : "not ok 9\n");
@h{0..200} = 200..400;
print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
-unlink 'Op.dbmx.dir', 'Op.dbmx.pag';
+unlink 'Op.dbmx.dir', $Dfile;
#!./perl
-# $Header: delete.t,v 4.0 91/03/20 01:51:56 lwall Locked $
+# $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $
print "1..6\n";
#!./perl
-# $Header: do.t,v 4.0 91/03/20 01:52:08 lwall Locked $
+# $RCSfile: do.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:45 $
sub foo1
{
#!./perl
-# $Header: each.t,v 4.0 91/03/20 01:52:14 lwall Locked $
+# $RCSfile: each.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:47 $
print "1..3\n";
#!./perl
-# $RCSfile: eval.t,v $$Revision: 4.0.1.1 $$Date: 91/11/05 18:43:19 $
+# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $
print "1..16\n";
print $foo;
print eval '
-$foo ='; # this tests for a call through yyerror()
+$foo =;'; # this tests for a call through yyerror()
if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
print eval '$foo = /'; # this tests for a call through fatal()
#!./perl
-# $Header: exec.t,v 4.0 91/03/20 01:52:25 lwall Locked $
+# $RCSfile: exec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:49 $
$| = 1; # flush stdout
print "1..8\n";
#!./perl
-# $Header: exp.t,v 4.0 91/03/20 01:52:31 lwall Locked $
+# $RCSfile: exp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:50 $
print "1..6\n";
#!./perl
-# $Header: flip.t,v 4.0 91/03/20 01:52:36 lwall Locked $
+# $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $
print "1..8\n";
#!./perl
-# $Header: fork.t,v 4.0 91/03/20 01:52:43 lwall Locked $
+# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $
$| = 1;
print "1..2\n";
#!./perl
-# $Header: glob.t,v 4.0 91/03/20 01:52:49 lwall Locked $
+# $RCSfile: glob.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:55 $
print "1..4\n";
#!./perl
-# $RCSfile: goto.t,v $$Revision: 4.0.1.1 $$Date: 92/06/08 15:43:25 $
+# $RCSfile: goto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:56 $
-print "1..3\n";
+print "1..5\n";
-while (0) {
+while ($?) {
$foo = 1;
label1:
$foo = 2;
$x = `./perl -e 'goto foo;' 2>&1`;
if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";}
+
+sub foo {
+ goto bar;
+ print "not ok 4\n";
+ return;
+bar:
+ print "ok 4\n";
+}
+
+&foo;
+
+sub bar {
+ $x = 'exitcode';
+ eval "goto $x"; # Do not take this as exemplary code!!!
+}
+
+&bar;
+exit;
+exitcode:
+print "ok 5\n";
$gr1 = join(' ', sort @gr);
-$gr2 = join(' ', grep(!$basegroup{$_}, sort split(' ',`/usr/ucb/groups`)));
+$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',`/usr/ucb/groups`)));
if ($gr1 eq $gr2) {
print "ok 1\n";
#!./perl
-# $Header: index.t,v 4.0 91/03/20 01:53:05 lwall Locked $
+# $RCSfile: index.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:59 $
print "1..20\n";
#!./perl
-# $Header: int.t,v 4.0 91/03/20 01:53:08 lwall Locked $
+# $RCSfile: int.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:00 $
print "1..4\n";
#!./perl
-# $Header: join.t,v 4.0 91/03/20 01:53:17 lwall Locked $
+# $RCSfile: join.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:01 $
print "1..3\n";
#!./perl
-# $Header: list.t,v 4.0 91/03/20 01:53:24 lwall Locked $
+# $RCSfile: list.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:02 $
print "1..27\n";
#!./perl
-# $Header: local.t,v 4.0 91/03/20 01:53:29 lwall Locked $
+# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
print "1..20\n";
#!./perl
-# $Header: magic.t,v 4.0 91/03/20 01:53:35 lwall Locked $
+# $RCSfile: magic.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:05 $
$| = 1; # command buffering
# the next tests are embedded inside system simply because sh spits out
# a newline onto stderr when a child process kills itself with SIGINT.
-system './perl',
-'-e', '$| = 1; # command buffering',
+system './perl', '-e', <<'END';
-'-e', '$SIG{"INT"} = "ok3"; kill 2,$$;',
-'-e', '$SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";',
-'-e', '$SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";',
+ $| = 1; # command buffering
-'-e', 'sub ok3 { print "ok 3\n" if pop(@_) eq "INT"; }';
+ $SIG{"INT"} = "ok3"; kill "INT",$$;
+ $SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";
+ $SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";
+
+ sub ok3 {
+ if (($x = pop(@_)) eq "INT") {
+ print "ok 3\n";
+ }
+ else {
+ print "not ok 3 $a\n";
+ }
+ }
+
+END
@val1 = @ENV{keys(%ENV)}; # can we slice ENV?
@val2 = values(%ENV);
#!./perl
-# $Header: mkdir.t,v 4.0 91/03/20 01:53:39 lwall Locked $
+# $RCSfile: mkdir.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:06 $
print "1..7\n";
#!./perl
-# $Header: oct.t,v 4.0 91/03/20 01:53:43 lwall Locked $
+# $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $
print "1..3\n";
#!./perl
-# $Header: ord.t,v 4.0 91/03/20 01:53:50 lwall Locked $
+# $RCSfile: ord.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:09 $
print "1..2\n";
#!./perl
-# $Header: pack.t,v 4.0 91/03/20 01:53:57 lwall Locked $
+# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
-print "1..3\n";
+print "1..8\n";
$format = "c2x5CCxsdila6";
# Need the expression in here to force ary[5] to be numeric. This avoids
print ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n");
print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n");
+
+# How about counting bits?
+
+print +($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16
+ ? "ok 4\n" : "not ok 4 $x\n";
+
+print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12
+ ? "ok 5\n" : "not ok 5 $x\n";
+
+print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
+ ? "ok 6\n" : "not ok 6 $x\n";
+
+print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == 129
+ ? "ok 7\n" : "not ok 7 $x\n";
+
+open(BIN, "./perl") || die "Can't open ../perl: $!\n";
+sysread BIN, $foo, 8192;
+close BIN;
+
+$sum = unpack("%32b*", $foo);
+$longway = unpack("b*", $foo);
+print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n";
#!./perl
-# $RCSfile: pat.t,v $$Revision: 4.0.1.2 $$Date: 91/06/10 01:29:34 $
+# $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $
print "1..51\n";
#!./perl
-# $Header: push.t,v 4.0 91/03/20 01:54:07 lwall Locked $
+# $RCSfile: push.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:13 $
@tests = split(/\n/, <<EOF);
0 3, 0 1 2, 3 4 5 6 7
$test = 3;
foreach $line (@tests) {
($list,$get,$leave) = split(/,\t*/,$line);
- @list = split(' ',$list);
+ ($pos, $len, @list) = split(' ',$list);
@get = split(' ',$get);
@leave = split(' ',$leave);
@x = (0,1,2,3,4,5,6,7);
- @got = splice(@x,@list);
+ if (defined $len) {
+ @got = splice(@x, $pos, $len, @list);
+ }
+ else {
+ @got = splice(@x, $pos);
+ }
if (join(':',@got) eq join(':',@get) &&
join(':',@x) eq join(':',@leave)) {
print "ok ",$test++,"\n";
#!./perl
-# $Header: range.t,v 4.0 91/03/20 01:54:11 lwall Locked $
+# $RCSfile: range.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:14 $
print "1..8\n";
#!./perl
-# $Header: read.t,v 4.0 91/03/20 01:54:16 lwall Locked $
+# $RCSfile: read.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:17 $
print "1..4\n";
--- /dev/null
+#!./perl
+
+print "1..37\n";
+
+# Test glob operations.
+
+$bar = "ok 1\n";
+$foo = "ok 2\n";
+{
+ local(*foo) = *bar;
+ print $foo;
+}
+print $foo;
+
+$baz = "ok 3\n";
+$foo = "ok 4\n";
+{
+ local(*foo) = 'baz';
+ print $foo;
+}
+print $foo;
+
+$foo = "ok 6\n";
+{
+ local(*foo);
+ print $foo;
+ $foo = "ok 5\n";
+ print $foo;
+}
+print $foo;
+
+# Test fake references.
+
+$baz = "ok 7\n";
+$bar = 'baz';
+$foo = 'bar';
+print $$$foo;
+
+# Test real references.
+
+$FOO = \$BAR;
+$BAR = \$BAZ;
+$BAZ = "ok 8\n";
+print $$$FOO;
+
+# Test references to real arrays.
+
+@ary = (9,10,11,12);
+$ref[0] = \@a;
+$ref[1] = \@b;
+$ref[2] = \@c;
+$ref[3] = \@d;
+for $i (3,1,2,0) {
+ push(@{$ref[$i]}, "ok $ary[$i]\n");
+}
+print @a;
+print ${$ref[1]}[0];
+print @{$ref[2]}[0];
+print @{'d'};
+
+# Test references to references.
+
+$refref = \\$x;
+$x = "ok 13\n";
+print $$$refref;
+
+# Test nested anonymous lists.
+
+$ref = [[],2,[3,4,5,]];
+print scalar @$ref == 3 ? "ok 14\n" : "not ok 14\n";
+print $$ref[1] == 2 ? "ok 15\n" : "not ok 15\n";
+print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n";
+print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n";
+
+print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n";
+print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 18\n";
+
+# Test references to hashes of references.
+
+$refref = \%whatever;
+$refref->{"key"} = $ref;
+print $refref->{"key"}->[2]->[0] == 3 ? "ok 20\n" : "not ok 20\n";
+
+# Test to see if anonymous subarrays sprint into existence.
+
+$spring[5]->[0] = 123;
+$spring[5]->[1] = 456;
+push(@{$spring[5]}, 789);
+print join(':',@{$spring[5]}) eq "123:456:789" ? "ok 21\n" : "not ok 21\n";
+
+# Test to see if anonymous subhashes sprint into existence.
+
+@{$spring2{"foo"}} = (1,2,3);
+$spring2{"foo"}->[3] = 4;
+print join(':',@{$spring2{"foo"}}) eq "1:2:3:4" ? "ok 22\n" : "not ok 22\n";
+
+# Test references to subroutines.
+
+sub mysub { print "ok 23\n" }
+$subref = \&mysub;
+&$subref;
+
+$subrefref = \\&mysub2;
+&$$subrefref("ok 24\n");
+sub mysub2 { print shift }
+
+# Test the ref operator.
+
+print ref $subref eq CODE ? "ok 25\n" : "not ok 25\n";
+print ref $ref eq ARRAY ? "ok 26\n" : "not ok 26\n";
+print ref $refref eq HASH ? "ok 27\n" : "not ok 27\n";
+
+# Test anonymous hash syntax.
+
+$anonhash = {};
+print ref $anonhash eq HASH ? "ok 28\n" : "not ok 28\n";
+$anonhash2 = {FOO => BAR, ABC => XYZ,};
+print join('', sort values %$anonhash2) eq BARXYZ ? "ok 29\n" : "not ok 29\n";
+
+# Test bless operator.
+
+package MYHASH;
+
+$object = bless $main'anonhash2;
+print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n";
+print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n";
+
+$object2 = bless {};
+print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n";
+
+# Test ordinary call on object method.
+
+&mymethod($object,33);
+
+sub mymethod {
+ local($THIS, @ARGS) = @_;
+ die "Not a MYHASH" unless ref $THIS eq MYHASH;
+ print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n";
+}
+
+# Test automatic destructor call.
+
+$string = "not ok 34\n";
+$object = "foo";
+$string = "ok 34\n";
+$main'anonhash2 = "foo";
+$string = "not ok 34\n";
+
+sub DESTROY {
+ print $string;
+
+ # Test that the object has already been "cursed".
+ print ref shift eq HASH ? "ok 35\n" : "not ok 35\n";
+}
+
+# Now test inheritance of methods.
+
+package OBJ;
+
+@ISA = (BASEOBJ);
+
+$main'object = bless {FOO => foo, BAR => bar};
+
+package main;
+
+# Test arrow-style method invocation.
+
+print $object->doit("BAR") eq bar ? "ok 36\n" : "not ok 36\n";
+
+# Test indirect-object-style method invocation.
+
+$foo = doit $object "FOO";
+print $foo eq foo ? "ok 37\n" : "not ok 37\n";
+
+sub BASEOBJ'doit {
+ local $ref = shift;
+ die "Not an OBJ" unless ref $ref eq OBJ;
+ $ref->{shift};
+}
#!./perl
-# $RCSfile: regexp.t,v $$Revision: 4.0.1.1 $$Date: 91/06/10 01:30:29 $
+# $RCSfile: regexp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:20 $
open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
|| die "Can't open re_tests";
#!./perl
-# $Header: repeat.t,v 4.0 91/03/20 01:54:26 lwall Locked $
+# $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $
print "1..19\n";
#!./perl
-# $Header: s.t,v 4.0 91/03/20 01:54:30 lwall Locked $
+# $RCSfile: s.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:22 $
-print "1..51\n";
+print "1..56\n";
$x = 'foo';
$_ = "x";
if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";}
$b = 'cd';
-($a = 'abcdef') =~ s'(b${b}e)'\n$1';
+($a = 'abcdef') =~ s<(b${b}e)>'\n$1';
print "#4\t:$1: eq :bcde:\n";
print "#4\t:$a: eq :a\\n\$1f:\n";
if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";}
print (($x=(y/a-zA-Z //cd)) == 7 ? "ok 50\n" : "not ok 50\n");
print y/ / /s == 8 ? "ok 51\n" : "not ok 51\n";
+$_ = 'abcdefghijklmnopqrstuvwxyz0123456789';
+tr/a-z/A-Z/;
+
+print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n";
+
+# same as tr/A-Z/a-z/;
+y[\101-\132][\141-\172];
+
+print $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ? "ok 53\n" : "not ok 53\n";
+
+$_ = '+,-';
+tr/+--/a-c/;
+print $_ eq 'abc' ? "ok 54\n" : "not ok 54\n";
+
+$_ = '+,-';
+tr/+\--/a\/c/;
+print $_ eq 'a,/' ? "ok 55\n" : "not ok 55\n";
+
+$_ = '+,-';
+tr/-+,/ab\-/;
+print $_ eq 'b-a' ? "ok 56\n" : "not ok 56\n";
#!./perl
-# $Header: sleep.t,v 4.0 91/03/20 01:54:34 lwall Locked $
+# $RCSfile: sleep.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:23 $
print "1..1\n";
#!./perl
-# $RCSfile: sort.t,v $$Revision: 4.0.1.2 $$Date: 91/11/11 16:43:47 $
+# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $
print "1..10\n";
#!./perl
-# $Header: split.t,v 4.0 91/03/20 01:54:42 lwall Locked $
+# $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $
print "1..12\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";
+print $foo =~ /DEBUGGING/ || $foo =~ /SV = IV\(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);
#!./perl
-# $Header: sprintf.t,v 4.0 91/03/20 01:54:46 lwall Locked $
+# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $
print "1..1\n";
#!./perl
-# $RCSfile: stat.t,v $$Revision: 4.0.1.3 $$Date: 91/11/11 16:44:49 $
+# $RCSfile: stat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:28 $
print "1..56\n";
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";}
+if ($uid > 0 && $uid < $cnt)
+ {print "ok 35\n";}
+else
+ {print "not ok 35 ($uid $cnt)\n";}
unless (open(tty,"/dev/tty")) {
print STDERR "Can't open /dev/tty--run t/TEST outside of make.\n";
#!./perl
-# $Header: study.t,v 4.0 91/03/20 01:54:59 lwall Locked $
+# $RCSfile: study.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:30 $
print "1..24\n";
#!./perl
-# $Header: substr.t,v 4.0 91/03/20 01:55:05 lwall Locked $
+# $RCSfile: substr.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:31 $
print "1..22\n";
#!./perl
-# $Header: time.t,v 4.0 91/03/20 01:55:09 lwall Locked $
+# $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $
print "1..5\n";
#!./perl
-# $Header: undef.t,v 4.0 91/03/20 01:55:16 lwall Locked $
+# $RCSfile: undef.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:34 $
print "1..21\n";
#!./perl
-# $Header: unshift.t,v 4.0 91/03/20 01:55:21 lwall Locked $
+# $RCSfile: unshift.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:35 $
print "1..2\n";
#!./perl
-# $Header: vec.t,v 4.0 91/03/20 01:55:28 lwall Locked $
+# $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $
print "1..13\n";
#!./perl
-# $Header: write.t,v 4.0 91/03/20 01:55:34 lwall Locked $
+# $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $
print "1..3\n";
--- /dev/null
+../perl
\ No newline at end of file
--- /dev/null
+
+ Upgrades to obed
+
+ * design high-level API and use it
+ * minimize oidtypes usage and boot time
+ * use more metadata (read-only attributes, etc.)
+ * use compiled types
+ * collection generators and filters
+ * type-directed entry
+ * event interlocking
+ * cloning app window
+ * add accelerators
+ * study scaling and psychology (does it feel fast?)
--- /dev/null
+#!./perl -Dx
+
+$foo !~ /foo/;
--- /dev/null
+AOP toke.c /^#define AOP(f) return(yylval.ival=f,expectterm = T/
+ASSERT malloc.c /^#define ASSERT(p) if (!(p)) botch("p"); else$/
+BAOP toke.c /^#define BAOP(f) return(yylval.ival=f,expectterm = /
+BOOP toke.c /^#define BOOP(f) return(yylval.ival=f,expectterm = /
+CHKLEN form.c /^#define CHKLEN(allow) \\$/
+EOP toke.c /^#define EOP(f) return(yylval.ival=f,expectterm = T/
+EXTEND pp.c /^#define EXTEND(n) if (n > 0 && stack->ary_fill + n/
+FL toke.c /^#define FL(f) return(yylval.ival=f,expectterm = FA/
+FL2 toke.c /^#define FL2(f) return(yylval.ival=f,expectterm = F/
+FOP toke.c /^#define FOP(f) return(yylval.ival=f,expectterm = F/
+FOP2 toke.c /^#define FOP2(f) return(yylval.ival=f,expectterm = /
+FOP22 toke.c /^#define FOP22(f) return(yylval.ival=f,expectterm =/
+FOP25 toke.c /^#define FOP25(f) return(yylval.ival=f,expectterm =/
+FOP3 toke.c /^#define FOP3(f) return(yylval.ival=f,expectterm = /
+FOP4 toke.c /^#define FOP4(f) return(yylval.ival=f,expectterm = /
+FTST toke.c /^#define FTST(f) return(yylval.ival=f,expectterm = /
+FUN0 toke.c /^#define FUN0(f) return(yylval.ival = f,expectterm /
+FUN1 toke.c /^#define FUN1(f) return(yylval.ival = f,expectterm /
+FUN2 toke.c /^#define FUN2(f) return(yylval.ival = f,expectterm /
+FUN2x toke.c /^#define FUN2x(f) return(yylval.ival = f,expectterm/
+FUN3 toke.c /^#define FUN3(f) return(yylval.ival = f,expectterm /
+FUN4 toke.c /^#define FUN4(f) return(yylval.ival = f,expectterm /
+FUN5 toke.c /^#define FUN5(f) return(yylval.ival = f,expectterm /
+HFUN toke.c /^#define HFUN(f) return(yylval.ival=f,expectterm = /
+HFUN3 toke.c /^#define HFUN3(f) return(yylval.ival=f,expectterm =/
+HTOV util.c /^#define HTOV(name,type) \\$/
+ISMULT1 regcomp.c /^#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c/
+ISMULT2 regcomp.c /^#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || /
+LFUN toke.c /^#define LFUN(f) return(yylval.ival=f,expectterm = /
+LOOPX toke.c /^#define LOOPX(f) return(yylval.ival=f,expectterm =/
+LOP toke.c /^#define LOP(f) return(yylval.ival = f, \\$/
+META toke.c /^#define META(c) ((c) | 128)$/
+MOP toke.c /^#define MOP(f) return(yylval.ival=f,expectterm = T/
+Mmain main.c /^main(argc, argv, env)$/
+OLDLOP toke.c /^#define OLDLOP(f) return(yylval.ival=f,expectterm /
+OPERATOR toke.c /^#define OPERATOR(retval) return (expectterm = TRUE/
+PERL_META toke.c /^#define PERL_META(c) ((c) | 128)$/
+PMOP toke.c /^#define PMOP(f) return(yylval.ival=f,expectterm = /
+PUSHc pp.c /^#define PUSHc(c,l) str_nset(TMP, (c), (l)); PUSHTM/
+PUSHn pp.c /^#define PUSHn(n) str_numset(TMP, (n)); PUSHTMP$/
+PUSHs pp.c /^#define PUSHs(s) (*++SP = (s))$/
+PWOP toke.c /^#define PWOP(f) return(yylval.ival=f,expectterm = /
+RETURN toke.c /^#define RETURN(retval) return (bufptr = s,(int)ret/
+ROP toke.c /^#define ROP(f) return(yylval.ival=f,expectterm = T/
+SETc pp.c /^#define SETc(c,l) str_set(TMP, (c), (l)); SETTMP$/
+SETn pp.c /^#define SETn(n) str_numset(TMP, (n)); SETTMP$/
+SETs pp.c /^#define SETs(s) *SP = s$/
+SHOP toke.c /^#define SHOP(f) return(yylval.ival=f,expectterm = /
+TERM toke.c /^#define TERM(retval) return (CLINE, expectterm = F/
+UNI toke.c /^#define UNI(f) return(yylval.ival = f, \\$/
+VTOH util.c /^#define VTOH(name,type) \\$/
+YYBACKUP perly.c /^#define YYBACKUP( newtoken, newvalue )\\$/
+YYRECOVERING perly.c /^#define YYRECOVERING() (!!yyerrflag)$/
+aadd stab.c /^aadd(stab)$/
+aclear array.c /^aclear(ar)$/
+add_label cons.c /^add_label(lbl,cmd)$/
+addcond cons.c /^addcond(cmd, arg)$/
+addflags consarg.c /^addflags(i,flags,arg)$/
+addloop cons.c /^addloop(cmd, arg)$/
+afake array.c /^afake(stab,size,strp)$/
+afetch array.c /^afetch(ar,key,lval)$/
+afill array.c /^afill(ar, fill)$/
+afree array.c /^afree(ar)$/
+alen array.c /^alen(ar)$/
+anew array.c /^anew(stab)$/
+apop array.c /^apop(ar)$/
+append_line cons.c /^append_line(head,tail)$/
+apply doio.c /^apply(type,arglast)$/
+apush array.c /^apush(ar,val)$/
+arg_common consarg.c /^arg_common(arg,exprnum,marking)$/
+arg_free cons.c /^arg_free(arg)$/
+arg_tosave cons.c /^arg_tosave(arg,willsave)$/
+ashift array.c /^ashift(ar)$/
+astore array.c /^astore(ar,key,val)$/
+aunshift array.c /^aunshift(ar,num)$/
+block_head cons.c /^block_head(tail)$/
+botch malloc.c /^botch(s)$/
+cando doio.c /^cando(bit, effective, statbufp)$/
+castulong util.c /^castulong(f)$/
+check_uni toke.c /^check_uni() {$/
+checkcomma toke.c /^checkcomma(s,name,what)$/
+chsize doio.c /^int chsize(fd, length)$/
+cmd_exec cmd.c /^cmd_exec(cmdparm,gimme,sp)$/
+cmd_free cons.c /^cmd_free(cmd)$/
+cmd_to_arg consarg.c /^cmd_to_arg(cmd)$/
+cmd_tosave cons.c /^cmd_tosave(cmd,willsave)$/
+copyopt cmd.c /^copyopt(cmd,which)$/
+countlines form.c /^countlines(s,size)$/
+cpy7bit cons.c /^cpy7bit(d,s,l)$/
+cpytill util.c /^cpytill(to,from,fromend,delim,retlen)$/
+cryptfilter usersub.c /^cryptfilter( fil )$/
+cryptswitch usersub.c /^cryptswitch()$/
+cval_to_arg consarg.c /^cval_to_arg(cval)$/
+deb cmd.c /^void deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)$/
+dehoist consarg.c /^dehoist(arg,i)$/
+do_accept doio.c /^do_accept(str, nstab, gstab)$/
+do_aexec doio.c /^do_aexec(really,arglast)$/
+do_aprint doio.c /^do_aprint(arg,fp,arglast)$/
+do_assign doarg.c /^do_assign(arg,gimme,arglast)$/
+do_bind doio.c /^do_bind(stab, arglast)$/
+do_caller dolist.c /^do_caller(arg,maxarg,gimme,arglast)$/
+do_chop doarg.c /^do_chop(astr,str)$/
+do_close doio.c /^do_close(stab,explicit)$/
+do_connect doio.c /^do_connect(stab, arglast)$/
+do_ctl doio.c /^do_ctl(optype,stab,func,argstr)$/
+do_defined doarg.c /^do_defined(str,arg,gimme,arglast)$/
+do_dirop doio.c /^do_dirop(optype,stab,gimme,arglast)$/
+do_each dolist.c /^do_each(str,hash,gimme,arglast)$/
+do_eof doio.c /^do_eof(stab)$/
+do_eval perl.c /^do_eval(str,optype,stash,savecmd,gimme,arglast)$/
+do_exec doio.c /^do_exec(cmd)$/
+do_execfree doio.c /^do_execfree()$/
+do_fttext doio.c /^do_fttext(arg,str)$/
+do_getsockname doio.c /^do_getsockname(optype, stab, arglast)$/
+do_ggrent doio.c /^do_ggrent(which,gimme,arglast)$/
+do_ghent doio.c /^do_ghent(which,gimme,arglast)$/
+do_gnent doio.c /^do_gnent(which,gimme,arglast)$/
+do_gpent doio.c /^do_gpent(which,gimme,arglast)$/
+do_gpwent doio.c /^do_gpwent(which,gimme,arglast)$/
+do_grep dolist.c /^do_grep(arg,str,gimme,arglast)$/
+do_gsent doio.c /^do_gsent(which,gimme,arglast)$/
+do_ipcctl doio.c /^do_ipcctl(optype, arglast)$/
+do_ipcget doio.c /^do_ipcget(optype, arglast)$/
+do_join doarg.c /^do_join(str,arglast)$/
+do_kv dolist.c /^do_kv(str,hash,kv,gimme,arglast)$/
+do_listen doio.c /^do_listen(stab, arglast)$/
+do_match dolist.c /^do_match(str,arg,gimme,arglast)$/
+do_msgrcv doio.c /^do_msgrcv(arglast)$/
+do_msgsnd doio.c /^do_msgsnd(arglast)$/
+do_open doio.c /^do_open(stab,name,len)$/
+do_pack doarg.c /^do_pack(str,arglast)$/
+do_pipe doio.c /^do_pipe(str, rstab, wstab)$/
+do_print doio.c /^do_print(str,fp)$/
+do_push doarg.c /^do_push(ary,arglast)$/
+do_range dolist.c /^do_range(gimme,arglast)$/
+do_repeatary dolist.c /^do_repeatary(arglast)$/
+do_reverse dolist.c /^do_reverse(arglast)$/
+do_seek doio.c /^do_seek(stab, pos, whence)$/
+do_select doio.c /^do_select(gimme,arglast)$/
+do_semop doio.c /^do_semop(arglast)$/
+do_shmio doio.c /^do_shmio(optype, arglast)$/
+do_shutdown doio.c /^do_shutdown(stab, arglast)$/
+do_slice dolist.c /^do_slice(stab,str,numarray,lval,gimme,arglast)$/
+do_socket doio.c /^do_socket(stab, arglast)$/
+do_sopt doio.c /^do_sopt(optype, stab, arglast)$/
+do_sort dolist.c /^do_sort(str,arg,gimme,arglast)$/
+do_spair doio.c /^do_spair(stab1, stab2, arglast)$/
+do_splice dolist.c /^do_splice(ary,gimme,arglast)$/
+do_split dolist.c /^do_split(str,spat,limit,gimme,arglast)$/
+do_sprintf doarg.c /^do_sprintf(str,len,sarg)$/
+do_sreverse dolist.c /^do_sreverse(str,arglast)$/
+do_stat doio.c /^do_stat(str,arg,gimme,arglast)$/
+do_study doarg.c /^do_study(str,arg,gimme,arglast)$/
+do_subr doarg.c /^do_subr(arg,gimme,arglast)$/
+do_subst doarg.c /^do_subst(str,arg,sp)$/
+do_syscall doarg.c /^do_syscall(arglast)$/
+do_tell doio.c /^do_tell(stab)$/
+do_time dolist.c /^do_time(str,tmbuf,gimme,arglast)$/
+do_tms dolist.c /^do_tms(str,gimme,arglast)$/
+do_trans doarg.c /^do_trans(str,arg)$/
+do_truncate doio.c /^do_truncate(str,arg,gimme,arglast)$/
+do_try perl.c /^do_try(cmd,gimme,arglast)$/
+do_undef doarg.c /^do_undef(str,arg,gimme,arglast)$/
+do_unpack dolist.c /^do_unpack(str,gimme,arglast)$/
+do_unshift doarg.c /^do_unshift(ary,arglast)$/
+do_vec doarg.c /^do_vec(lvalue,astr,arglast)$/
+do_vecset doarg.c /^do_vecset(mstr,str)$/
+do_vop doarg.c /^do_vop(optype,str,left,right)$/
+do_write form.c /^do_write(orec,stab,sp)$/
+dodb cons.c /^dodb(cur)$/
+doencodes doarg.c /^doencodes(str, s, len)$/
+dump dump.c /^static void dump(arg1,arg2,arg3,arg4,arg5)$/
+dump_all dump.c /^dump_all()$/
+dump_arg dump.c /^dump_arg(arg)$/
+dump_cmd dump.c /^dump_cmd(cmd,alt)$/
+dump_flags dump.c /^dump_flags(b,flags)$/
+dump_spat dump.c /^dump_spat(spat)$/
+dump_stab dump.c /^dump_stab(stab)$/
+dumpfds util.c /^dumpfds(s)$/
+dup2 util.c /^dup2(oldfd,newfd)$/
+envix util.c /^envix(nam)$/
+eval eval.c /^eval(arg,gimme,sp)$/
+evalstatic consarg.c /^evalstatic(arg)$/
+fatal util.c /^void fatal(pat,a1,a2,a3,a4)$/
+fbmcompile util.c /^fbmcompile(str, iflag)$/
+fbminstr util.c /^fbminstr(big, bigend, littlestr)$/
+find_beginning perl.c /^find_beginning()$/
+findbucket malloc.c /^findbucket(freep, srchlen)$/
+fixl consarg.c /^fixl(type,arg)$/
+forceword toke.c /^forceword(s)$/
+form_parseargs form.c /^form_parseargs(fcmd)$/
+format form.c /^format(orec,fcmd,sp)$/
+free malloc.c /^free(mp)$/
+free_arg consarg.c /^free_arg(arg)$/
+fstab stab.c /^fstab(name)$/
+function doarg.c /^ #pragma function(memcmp)$/
+genstab stab.c /^genstab()$/
+grow_dlevel cmd.c /^grow_dlevel()$/
+growstr util.c /^growstr(strptr,curlen,newlen)$/
+hadd stab.c /^hadd(stab)$/
+hclear hash.c /^hclear(tb,dodbm)$/
+hdbmclose hash.c /^hdbmclose(tb)$/
+hdbmopen hash.c /^hdbmopen(tb,fname,mode)$/
+hdbmstore hash.c /^hdbmstore(tb,key,klen,str)$/
+hdelete hash.c /^hdelete(tb,key,klen)$/
+hentdelayfree hash.c /^hentdelayfree(hent)$/
+hentfree hash.c /^hentfree(hent)$/
+hfetch hash.c /^hfetch(tb,key,klen,lval)$/
+hfree hash.c /^hfree(tb,dodbm)$/
+hfreeentries hash.c /^hfreeentries(tb,dodbm)$/
+hide_ary consarg.c /^hide_ary(arg)$/
+hiterinit hash.c /^hiterinit(tb)$/
+hiterkey hash.c /^hiterkey(entry,retlen)$/
+hiternext hash.c /^hiternext(tb)$/
+hiterval hash.c /^hiterval(tb,entry)$/
+hnew hash.c /^hnew(lookat)$/
+hoistmust toke.c /^hoistmust(spat)$/
+hsplit hash.c /^hsplit(tb)$/
+hstore hash.c /^hstore(tb,key,klen,val,hash)$/
+htonl util.c /^htonl(l)$/
+if pp.c /^ if (debug) {$/
+incpush perl.c /^incpush(p)$/
+ingroup doio.c /^ingroup(testgid,effective)$/
+init_debugger perl.c /^init_debugger()$/
+init_lexer perl.c /^init_lexer()$/
+init_loop_stack perl.c /^init_loop_stack()$/
+init_main_stash perl.c /^init_main_stash()$/
+init_perllib perl.c /^init_perllib()$/
+init_postdump_symbols perl.c /^init_postdump_symbols(argc,argv,env)$/
+init_predump_symbols perl.c /^init_predump_symbols()$/
+init_stack perl.c /^init_stack()$/
+instr util.c /^instr(big, little)$/
+interp str.c /^interp(str,src,sp)$/
+intrinsic doarg.c /^ #pragma intrinsic(memcmp)$/
+intrpcompile str.c /^intrpcompile(src)$/
+invert cons.c /^invert(cmd)$/
+jmaybe consarg.c /^jmaybe(arg)$/
+keyword toke.c /^keyword(d)$/
+l consarg.c /^l(arg)$/
+lcase str.c /^lcase(s,send)$/
+listish consarg.c /^listish(arg)$/
+load_format toke.c /^load_format()$/
+localize consarg.c /^localize(arg)$/
+looks_like_number doio.c /^looks_like_number(str)$/
+lop toke.c /^lop(f,s)$/
+magicalize perl.c /^magicalize(list)$/
+magicname perl.c /^magicname(sym,name,namlen)$/
+make_acmd cons.c /^make_acmd(type,stab,cond,arg)$/
+make_ccmd cons.c /^make_ccmd(type,debuggable,arg,cblock)$/
+make_cswitch cons.c /^make_cswitch(head,count)$/
+make_form cons.c /^make_form(stab,fcmd)$/
+make_icmd cons.c /^make_icmd(type,arg,cblock)$/
+make_list consarg.c /^make_list(arg)$/
+make_match consarg.c /^make_match(type,expr,spat)$/
+make_nswitch cons.c /^make_nswitch(head,count)$/
+make_op consarg.c /^make_op(type,newlen,arg1,arg2,arg3)$/
+make_split consarg.c /^make_split(stab,arg,limarg)$/
+make_sub cons.c /^make_sub(name,cmd)$/
+make_usub cons.c /^make_usub(name, ix, subaddr, filename)$/
+malloc malloc.c /^malloc(nbytes)$/
+maybelistish consarg.c /^maybelistish(optype, arg)$/
+mess util.c /^mess(pat,a1,a2,a3,a4)$/
+mod_match consarg.c /^mod_match(type,left,pat)$/
+morecore malloc.c /^morecore(bucket)$/
+moreswitches perl.c /^moreswitches(s)$/
+mstats malloc.c /^mstats(s)$/
+my_bcopy util.c /^my_bcopy(from,to,len)$/
+my_bzero util.c /^my_bzero(loc,len)$/
+my_exit perl.c /^my_exit(status)$/
+my_memcmp util.c /^my_memcmp(s1,s2,len)$/
+my_setenv util.c /^my_setenv(nam,val)$/
+my_swap util.c /^my_swap(s)$/
+my_unexec perl.c /^my_unexec()$/
+mylstat doio.c /^mylstat(arg,str)$/
+mypclose util.c /^mypclose(ptr)$/
+mypfiopen usersub.c /^mypfiopen(fil,func) \/* open a pipe to function ca/
+mypopen util.c /^mypopen(cmd,mode)$/
+mystat doio.c /^mystat(arg,str)$/
+nextargv doio.c /^nextargv(stab)$/
+ninstr util.c /^ninstr(big, bigend, little, lend)$/
+nothing_in_common consarg.c /^nothing_in_common(arg1,arg2)$/
+nsavestr util.c /^nsavestr(str, len)$/
+ntohl util.c /^ntohl(l)$/
+op_new consarg.c /^op_new(numargs)$/
+open_script perl.c /^open_script(scriptname,dosearch,str)$/
+opt_arg cons.c /^opt_arg(cmd,fliporflop,acmd)$/
+over cons.c /^over(eachstab,cmd)$/
+parselist str.c /^parselist(str)$/
+perl_alloc perl.c /^perl_alloc()$/
+perl_callback perl.c /^perl_callback(subname, sp, gimme, hasargs, numargs/
+perl_callv perl.c /^perl_callv(subname, sp, gimme, argv)$/
+perl_construct perl.c /^perl_construct( interp )$/
+perl_destruct perl.c /^perl_destruct(interp)$/
+perl_free perl.c /^perl_free(interp)$/
+perl_parse perl.c /^perl_parse(interp, argc, argv, env)$/
+perl_run perl.c /^perl_run(interp)$/
+pidgone util.c /^pidgone(pid,status)$/
+pp_aassign pp.c /^pp_aassign(ARGS)$/
+pp_accept pp.c /^pp_accept(ARGS)$/
+pp_add pp.c /^pp_add(ARGS)$/
+pp_aelem pp.c /^pp_aelem(ARGS)$/
+pp_alarm pp.c /^pp_alarm(ARGS)$/
+pp_and pp.c /^pp_and(ARGS)$/
+pp_array pp.c /^pp_array(ARGS)$/
+pp_aslice pp.c /^pp_aslice(ARGS)$/
+pp_assign pp.c /^pp_assign(ARGS)$/
+pp_atan pp.c /^pp_atan(ARGS)$/
+pp_bind pp.c /^pp_bind(ARGS)$/
+pp_binmode pp.c /^pp_binmode(ARGS)$/
+pp_bit_and pp.c /^pp_bit_and(ARGS)$/
+pp_bit_or pp.c /^pp_bit_or(ARGS)$/
+pp_caller pp.c /^pp_caller(ARGS)$/
+pp_chdir pp.c /^pp_chdir(ARGS)$/
+pp_chmod pp.c /^pp_chmod(ARGS)$/
+pp_chop pp.c /^pp_chop(ARGS)$/
+pp_chown pp.c /^pp_chown(ARGS)$/
+pp_chroot pp.c /^pp_chroot(ARGS)$/
+pp_close pp.c /^pp_close(ARGS)$/
+pp_closedir pp.c /^pp_closedir(ARGS)$/
+pp_comma pp.c /^pp_comma(ARGS)$/
+pp_complement pp.c /^pp_complement(ARGS)$/
+pp_concat pp.c /^pp_concat(ARGS)$/
+pp_cond_expr pp.c /^pp_cond_expr(ARGS)$/
+pp_connect pp.c /^pp_connect(ARGS)$/
+pp_cos pp.c /^pp_cos(ARGS)$/
+pp_crypt pp.c /^pp_crypt(ARGS)$/
+pp_dbmclose pp.c /^pp_dbmclose(ARGS)$/
+pp_dbmopen pp.c /^pp_dbmopen(ARGS)$/
+pp_dbsubr pp.c /^pp_dbsubr(ARGS)$/
+pp_defined pp.c /^pp_defined(ARGS)$/
+pp_delete pp.c /^pp_delete(ARGS)$/
+pp_die pp.c /^pp_die(ARGS)$/
+pp_divide pp.c /^pp_divide(ARGS)$/
+pp_dofile pp.c /^pp_dofile(ARGS)$/
+pp_dump pp.c /^pp_dump(ARGS)$/
+pp_each pp.c /^pp_each(ARGS)$/
+pp_egrent pp.c /^pp_egrent(ARGS)$/
+pp_ehostent pp.c /^pp_ehostent(ARGS)$/
+pp_enetent pp.c /^pp_enetent(ARGS)$/
+pp_eof pp.c /^pp_eof(ARGS)$/
+pp_eprotoent pp.c /^pp_eprotoent(ARGS)$/
+pp_epwent pp.c /^pp_epwent(ARGS)$/
+pp_eq pp.c /^pp_eq(ARGS)$/
+pp_eservent pp.c /^pp_eservent(ARGS)$/
+pp_eval pp.c /^pp_eval(ARGS)$/
+pp_evalonce pp.c /^pp_evalonce(ARGS)$/
+pp_exec_op pp.c /^pp_exec_op(ARGS)$/
+pp_exit pp.c /^pp_exit(ARGS)$/
+pp_exp pp.c /^pp_exp(ARGS)$/
+pp_f_or_r pp.c /^pp_f_or_r(ARGS)$/
+pp_fcntl pp.c /^pp_fcntl(ARGS)$/
+pp_fileno pp.c /^pp_fileno(ARGS)$/
+pp_flip pp.c /^pp_flip(ARGS)$/
+pp_flock pp.c /^pp_flock(ARGS)$/
+pp_flop pp.c /^pp_flop(ARGS)$/
+pp_fork pp.c /^pp_fork(ARGS)$/
+pp_ftatime pp.c /^pp_ftatime(ARGS)$/
+pp_ftbinary pp.c /^pp_ftbinary(ARGS)$/
+pp_ftblk pp.c /^pp_ftblk(ARGS)$/
+pp_ftchr pp.c /^pp_ftchr(ARGS)$/
+pp_ftctime pp.c /^pp_ftctime(ARGS)$/
+pp_ftdir pp.c /^pp_ftdir(ARGS)$/
+pp_fteexec pp.c /^pp_fteexec(ARGS)$/
+pp_fteowned pp.c /^pp_fteowned(ARGS)$/
+pp_fteread pp.c /^pp_fteread(ARGS)$/
+pp_ftewrite pp.c /^pp_ftewrite(ARGS)$/
+pp_ftfile pp.c /^pp_ftfile(ARGS)$/
+pp_ftis pp.c /^pp_ftis(ARGS)$/
+pp_ftlink pp.c /^pp_ftlink(ARGS)$/
+pp_ftmtime pp.c /^pp_ftmtime(ARGS)$/
+pp_ftpipe pp.c /^pp_ftpipe(ARGS)$/
+pp_ftrexec pp.c /^pp_ftrexec(ARGS)$/
+pp_ftrowned pp.c /^pp_ftrowned(ARGS)$/
+pp_ftrread pp.c /^pp_ftrread(ARGS)$/
+pp_ftrwrite pp.c /^pp_ftrwrite(ARGS)$/
+pp_ftsgid pp.c /^pp_ftsgid(ARGS)$/
+pp_ftsize pp.c /^pp_ftsize(ARGS)$/
+pp_ftsock pp.c /^pp_ftsock(ARGS)$/
+pp_ftsuid pp.c /^pp_ftsuid(ARGS)$/
+pp_ftsvtx pp.c /^pp_ftsvtx(ARGS)$/
+pp_fttext pp.c /^pp_fttext(ARGS)$/
+pp_fttty pp.c /^pp_fttty(ARGS)$/
+pp_ftzero pp.c /^pp_ftzero(ARGS)$/
+pp_ge pp.c /^pp_ge(ARGS)$/
+pp_getc pp.c /^pp_getc(ARGS)$/
+pp_getlogin pp.c /^pp_getlogin(ARGS)$/
+pp_getpeername pp.c /^pp_getpeername(ARGS)$/
+pp_getpgrp pp.c /^pp_getpgrp(ARGS)$/
+pp_getppid pp.c /^pp_getppid(ARGS)$/
+pp_getpriority pp.c /^pp_getpriority(ARGS)$/
+pp_getsockname pp.c /^pp_getsockname(ARGS)$/
+pp_ggrent pp.c /^pp_ggrent(ARGS)$/
+pp_ggrgid pp.c /^pp_ggrgid(ARGS)$/
+pp_ggrnam pp.c /^pp_ggrnam(ARGS)$/
+pp_ghbyaddr pp.c /^pp_ghbyaddr(ARGS)$/
+pp_ghbyname pp.c /^pp_ghbyname(ARGS)$/
+pp_ghostent pp.c /^pp_ghostent(ARGS)$/
+pp_gmtime pp.c /^pp_gmtime(ARGS)$/
+pp_gnbyaddr pp.c /^pp_gnbyaddr(ARGS)$/
+pp_gnbyname pp.c /^pp_gnbyname(ARGS)$/
+pp_gnetent pp.c /^pp_gnetent(ARGS)$/
+pp_goto pp.c /^pp_goto(ARGS)$/
+pp_gpbyname pp.c /^pp_gpbyname(ARGS)$/
+pp_gpbynumber pp.c /^pp_gpbynumber(ARGS)$/
+pp_gprotoent pp.c /^pp_gprotoent(ARGS)$/
+pp_gpwent pp.c /^pp_gpwent(ARGS)$/
+pp_gpwnam pp.c /^pp_gpwnam(ARGS)$/
+pp_gpwuid pp.c /^pp_gpwuid(ARGS)$/
+pp_grep pp.c /^pp_grep(ARGS)$/
+pp_gsbyname pp.c /^pp_gsbyname(ARGS)$/
+pp_gsbyport pp.c /^pp_gsbyport(ARGS)$/
+pp_gservent pp.c /^pp_gservent(ARGS)$/
+pp_gsockopt pp.c /^pp_gsockopt(ARGS)$/
+pp_gt pp.c /^pp_gt(ARGS)$/
+pp_hash pp.c /^pp_hash(ARGS)$/
+pp_helem pp.c /^pp_helem(ARGS)$/
+pp_hex pp.c /^pp_hex(ARGS)$/
+pp_hslice pp.c /^pp_hslice(ARGS)$/
+pp_index pp.c /^pp_index(ARGS)$/
+pp_int pp.c /^pp_int(ARGS)$/
+pp_ioctl pp.c /^pp_ioctl(ARGS)$/
+pp_item pp.c /^pp_item(ARGS)$/
+pp_item2 pp.c /^pp_item2(ARGS)$/
+pp_item3 pp.c /^pp_item3(ARGS)$/
+pp_join pp.c /^pp_join(ARGS)$/
+pp_keys pp.c /^pp_keys(ARGS)$/
+pp_kill pp.c /^pp_kill(ARGS)$/
+pp_laelem pp.c /^pp_laelem(ARGS)$/
+pp_larray pp.c /^pp_larray(ARGS)$/
+pp_laslice pp.c /^pp_laslice(ARGS)$/
+pp_last pp.c /^pp_last(ARGS)$/
+pp_le pp.c /^pp_le(ARGS)$/
+pp_left_shift pp.c /^pp_left_shift(ARGS)$/
+pp_length pp.c /^pp_length(ARGS)$/
+pp_lhash pp.c /^pp_lhash(ARGS)$/
+pp_lhelem pp.c /^pp_lhelem(ARGS)$/
+pp_lhslice pp.c /^pp_lhslice(ARGS)$/
+pp_link pp.c /^pp_link(ARGS)$/
+pp_list pp.c /^pp_list(ARGS)$/
+pp_listen pp.c /^pp_listen(ARGS)$/
+pp_local pp.c /^pp_local(ARGS)$/
+pp_localtime pp.c /^pp_localtime(ARGS)$/
+pp_log pp.c /^pp_log(ARGS)$/
+pp_lslice pp.c /^pp_lslice(ARGS)$/
+pp_lstat pp.c /^pp_lstat(ARGS)$/
+pp_lt pp.c /^pp_lt(ARGS)$/
+pp_match pp.c /^pp_match(ARGS)$/
+pp_mkdir pp.c /^pp_mkdir(ARGS)$/
+pp_modulo pp.c /^pp_modulo(ARGS)$/
+pp_msgctl pp.c /^pp_msgctl(ARGS)$/
+pp_msgget pp.c /^pp_msgget(ARGS)$/
+pp_msgrcv pp.c /^pp_msgrcv(ARGS)$/
+pp_msgsnd pp.c /^pp_msgsnd(ARGS)$/
+pp_multiply pp.c /^pp_multiply(ARGS)$/
+pp_ncmp pp.c /^pp_ncmp(ARGS)$/
+pp_ne pp.c /^pp_ne(ARGS)$/
+pp_negate pp.c /^pp_negate(ARGS)$/
+pp_next pp.c /^pp_next(ARGS)$/
+pp_nmatch pp.c /^pp_nmatch(ARGS)$/
+pp_not pp.c /^pp_not(ARGS)$/
+pp_nsubst pp.c /^pp_nsubst(ARGS)$/
+pp_ntrans pp.c /^pp_ntrans(ARGS)$/
+pp_null pp.c /^pp_null(ARGS)$/
+pp_oct pp.c /^pp_oct(ARGS)$/
+pp_open pp.c /^pp_open(ARGS)$/
+pp_open_dir pp.c /^pp_open_dir(ARGS)$/
+pp_or pp.c /^pp_or(ARGS)$/
+pp_ord pp.c /^pp_ord(ARGS)$/
+pp_pack pp.c /^pp_pack(ARGS)$/
+pp_pipe_op pp.c /^pp_pipe_op(ARGS)$/
+pp_pop pp.c /^pp_pop(ARGS)$/
+pp_pow pp.c /^pp_pow(ARGS)$/
+pp_print pp.c /^pp_print(ARGS)$/
+pp_prtf pp.c /^pp_prtf(ARGS)$/
+pp_push pp.c /^pp_push(ARGS)$/
+pp_rand pp.c /^pp_rand(ARGS)$/
+pp_range pp.c /^pp_range(ARGS)$/
+pp_rcat pp.c /^pp_rcat(ARGS)$/
+pp_read pp.c /^pp_read(ARGS)$/
+pp_readdir pp.c /^pp_readdir(ARGS)$/
+pp_readlink pp.c /^pp_readlink(ARGS)$/
+pp_recv pp.c /^pp_recv(ARGS)$/
+pp_redo pp.c /^pp_redo(ARGS)$/
+pp_rename pp.c /^pp_rename(ARGS)$/
+pp_repeat pp.c /^pp_repeat(ARGS)$/
+pp_require pp.c /^pp_require(ARGS)$/
+pp_reset pp.c /^pp_reset(ARGS)$/
+pp_return pp.c /^pp_return(ARGS)$/
+pp_reverse pp.c /^pp_reverse(ARGS)$/
+pp_rewinddir pp.c /^pp_rewinddir(ARGS)$/
+pp_right_shift pp.c /^pp_right_shift(ARGS)$/
+pp_rindex pp.c /^pp_rindex(ARGS)$/
+pp_rmdir pp.c /^pp_rmdir(ARGS)$/
+pp_sassign pp.c /^pp_sassign(ARGS)$/
+pp_scalar pp.c /^pp_scalar(ARGS)$/
+pp_scmp pp.c /^pp_scmp(ARGS)$/
+pp_seek pp.c /^pp_seek(ARGS)$/
+pp_seekdir pp.c /^pp_seekdir(ARGS)$/
+pp_select pp.c /^pp_select(ARGS)$/
+pp_semctl pp.c /^pp_semctl(ARGS)$/
+pp_semget pp.c /^pp_semget(ARGS)$/
+pp_semop pp.c /^pp_semop(ARGS)$/
+pp_send pp.c /^pp_send(ARGS)$/
+pp_seq pp.c /^pp_seq(ARGS)$/
+pp_setpgrp pp.c /^pp_setpgrp(ARGS)$/
+pp_setpriority pp.c /^pp_setpriority(ARGS)$/
+pp_sge pp.c /^pp_sge(ARGS)$/
+pp_sgrent pp.c /^pp_sgrent(ARGS)$/
+pp_sgt pp.c /^pp_sgt(ARGS)$/
+pp_shift pp.c /^pp_shift(ARGS)$/
+pp_shmctl pp.c /^pp_shmctl(ARGS)$/
+pp_shmget pp.c /^pp_shmget(ARGS)$/
+pp_shmread pp.c /^pp_shmread(ARGS)$/
+pp_shmwrite pp.c /^pp_shmwrite(ARGS)$/
+pp_shostent pp.c /^pp_shostent(ARGS)$/
+pp_shutdown pp.c /^pp_shutdown(ARGS)$/
+pp_sin pp.c /^pp_sin(ARGS)$/
+pp_sle pp.c /^pp_sle(ARGS)$/
+pp_sleep pp.c /^pp_sleep(ARGS)$/
+pp_slt pp.c /^pp_slt(ARGS)$/
+pp_sne pp.c /^pp_sne(ARGS)$/
+pp_snetent pp.c /^pp_snetent(ARGS)$/
+pp_socket pp.c /^pp_socket(ARGS)$/
+pp_sockpair pp.c /^pp_sockpair(ARGS)$/
+pp_sort pp.c /^pp_sort(ARGS)$/
+pp_splice pp.c /^pp_splice(ARGS)$/
+pp_split pp.c /^pp_split(ARGS)$/
+pp_sprintf pp.c /^pp_sprintf(ARGS)$/
+pp_sprotoent pp.c /^pp_sprotoent(ARGS)$/
+pp_spwent pp.c /^pp_spwent(ARGS)$/
+pp_sqrt pp.c /^pp_sqrt(ARGS)$/
+pp_srand pp.c /^pp_srand(ARGS)$/
+pp_sselect pp.c /^pp_sselect(ARGS)$/
+pp_sservent pp.c /^pp_sservent(ARGS)$/
+pp_ssockopt pp.c /^pp_ssockopt(ARGS)$/
+pp_stat pp.c /^pp_stat(ARGS)$/
+pp_study pp.c /^pp_study(ARGS)$/
+pp_subr pp.c /^pp_subr(ARGS)$/
+pp_subst pp.c /^pp_subst(ARGS)$/
+pp_substr pp.c /^pp_substr(ARGS)$/
+pp_subtract pp.c /^pp_subtract(ARGS)$/
+pp_symlink pp.c /^pp_symlink(ARGS)$/
+pp_syscall pp.c /^pp_syscall(ARGS)$/
+pp_sysread pp.c /^pp_sysread(ARGS)$/
+pp_system pp.c /^pp_system(ARGS)$/
+pp_syswrite pp.c /^pp_syswrite(ARGS)$/
+pp_tell pp.c /^pp_tell(ARGS)$/
+pp_telldir pp.c /^pp_telldir(ARGS)$/
+pp_time pp.c /^pp_time(ARGS)$/
+pp_tms pp.c /^pp_tms(ARGS)$/
+pp_trans pp.c /^pp_trans(ARGS)$/
+pp_truncate pp.c /^pp_truncate(ARGS)$/
+pp_try pp.c /^pp_try(ARGS)$/
+pp_umask pp.c /^pp_umask(ARGS)$/
+pp_undef pp.c /^pp_undef(ARGS)$/
+pp_unlink pp.c /^pp_unlink(ARGS)$/
+pp_unpack pp.c /^pp_unpack(ARGS)$/
+pp_unshift pp.c /^pp_unshift(ARGS)$/
+pp_utime pp.c /^pp_utime(ARGS)$/
+pp_values pp.c /^pp_values(ARGS)$/
+pp_vec pp.c /^pp_vec(ARGS)$/
+pp_wait pp.c /^pp_wait(ARGS)$/
+pp_waitpid pp.c /^pp_waitpid(ARGS)$/
+pp_warn pp.c /^pp_warn(ARGS)$/
+pp_write pp.c /^pp_write(ARGS)$/
+pp_xor pp.c /^pp_xor(ARGS)$/
+rcatmaybe consarg.c /^rcatmaybe(arg)$/
+realloc malloc.c /^realloc(mp, nbytes)$/
+reg regcomp.c /^reg(paren, flagp)$/
+reganode regcomp.c /^reganode(op, arg)$/
+regatom regcomp.c /^regatom(flagp)$/
+regbranch regcomp.c /^regbranch(flagp)$/
+regc regcomp.c /^regc(b)$/
+regclass regcomp.c /^regclass()$/
+regcomp regcomp.c /^regcomp(exp,xend,fold)$/
+regcurly regcomp.c /^regcurly(s)$/
+regdump regcomp.c /^regdump(r)$/
+regexec regexec.c /^regexec(prog, stringarg, strend, strbeg, minend, s/
+regfree regcomp.c /^regfree(r)$/
+reginsert regcomp.c /^reginsert(op, opnd)$/
+regmatch regexec.c /^regmatch(prog)$/
+regnext regexec.c /^regnext(p)$/
+regnode regcomp.c /^regnode(op)$/
+regoptail regcomp.c /^regoptail(p, val)$/
+regpiece regcomp.c /^regpiece(flagp)$/
+regprop regcomp.c /^regprop(op)$/
+regrepeat regexec.c /^regrepeat(p, max)$/
+regset regcomp.c /^regset(bits,def,c)$/
+regtail regcomp.c /^regtail(p, val)$/
+regtry regexec.c /^regtry(prog, string)$/
+repeatcpy util.c /^repeatcpy(to,from,len,count)$/
+restorelist cmd.c /^restorelist(base)$/
+rninstr util.c /^rninstr(big, bigend, little, lend)$/
+safefree util.c /^safefree(where)$/
+safemalloc util.c /^safemalloc(size)$/
+saferealloc util.c /^saferealloc(where,size)$/
+safexfree util.c /^safexfree(where)$/
+safexmalloc util.c /^safexmalloc(x,size)$/
+safexrealloc util.c /^safexrealloc(where,size)$/
+same_dirent util.c /^same_dirent(a,b)$/
+saveaptr cmd.c /^saveaptr(aptr)$/
+saveary cmd.c /^saveary(stab)$/
+savehash cmd.c /^savehash(stab)$/
+savehptr cmd.c /^savehptr(hptr)$/
+saveint cmd.c /^saveint(intp)$/
+saveitem cmd.c /^saveitem(item)$/
+savelines perl.c /^savelines(array, str)$/
+savelist cmd.c /^savelist(sarg,maxsarg)$/
+savelong cmd.c /^savelong(longp)$/
+savenostab cmd.c /^savenostab(stab)$/
+savesptr cmd.c /^savesptr(sptr)$/
+savestr util.c /^savestr(str)$/
+scanconst toke.c /^scanconst(spat,string,len)$/
+scanhex util.c /^scanhex(start, len, retlen)$/
+scanident toke.c /^scanident(s,send,dest)$/
+scanoct util.c /^scanoct(start, len, retlen)$/
+scanpat toke.c /^scanpat(s)$/
+scanstr toke.c /^scanstr(start, in_what)$/
+scansubst toke.c /^scansubst(start)$/
+scantrans toke.c /^scantrans(start)$/
+screaminstr util.c /^screaminstr(bigstr, littlestr)$/
+set_csh toke.c /^set_csh()$/
+sighandler stab.c /^sighandler(sig)$/
+skipspace toke.c /^skipspace(s)$/
+sortcmp dolist.c /^sortcmp(strp1,strp2)$/
+sortsub dolist.c /^sortsub(str1,str2)$/
+spat_common consarg.c /^spat_common(spat,exprnum,marking)$/
+spat_free cons.c /^spat_free(spat)$/
+spat_tosave cons.c /^spat_tosave(spat)$/
+stab2arg consarg.c /^stab2arg(atype,stab)$/
+stab_array stab.c /^ARRAY *stab_array(stab)$/
+stab_check stab.c /^stab_check(min,max)$/
+stab_clear stab.c /^stab_clear(stab)$/
+stab_efullname stab.c /^stab_efullname(str,stab)$/
+stab_fullname stab.c /^stab_fullname(str,stab)$/
+stab_hash stab.c /^HASH *stab_hash(stab)$/
+stab_len stab.c /^stab_len(str)$/
+stab_str stab.c /^stab_str(str)$/
+stabent stab.c /^stabent(name,add)$/
+stabset stab.c /^stabset(mstr,str)$/
+stio_new stab.c /^stio_new()$/
+str_2mortal str.c /^str_2mortal(str)$/
+str_2num str.c /^str_2num(str)$/
+str_2ptr str.c /^str_2ptr(str)$/
+str_append_till str.c /^str_append_till(str,from,fromend,delim,keeplist)$/
+str_cat str.c /^str_cat(str,ptr)$/
+str_chop str.c /^str_chop(str,ptr) \/* like set but assuming ptr is /
+str_cmp str.c /^str_cmp(str1,str2)$/
+str_dec str.c /^str_dec(str)$/
+str_eq str.c /^str_eq(str1,str2)$/
+str_free str.c /^str_free(str)$/
+str_get str.c /^str_get(str)$/
+str_gets str.c /^str_gets(str,fp,append)$/
+str_gnum str.c /^double str_gnum(Str)$/
+str_grow str.c /^str_grow(str,newlen)$/
+str_inc str.c /^str_inc(str)$/
+str_insert str.c /^str_insert(bigstr,offset,len,little,littlelen)$/
+str_len str.c /^str_len(str)$/
+str_magic str.c /^str_magic(str, stab, how, name, namlen)$/
+str_make str.c /^str_make(s,len)$/
+str_mortal str.c /^str_mortal(oldstr)$/
+str_ncat str.c /^str_ncat(str,ptr,len)$/
+str_new str.c /^str_new(x,len)$/
+str_nmake str.c /^str_nmake(n)$/
+str_nset str.c /^str_nset(str,ptr,len)$/
+str_numset str.c /^str_numset(str,num)$/
+str_replace str.c /^str_replace(str,nstr)$/
+str_reset str.c /^str_reset(s,stash)$/
+str_scat str.c /^str_scat(dstr,sstr)$/
+str_set str.c /^str_set(str,ptr)$/
+str_smake str.c /^str_smake(old)$/
+str_sset str.c /^str_sset(dstr,sstr)$/
+str_true str.c /^str_true(Str)$/
+switch pp.c /^ switch (optype) {$/
+taintenv str.c /^taintenv()$/
+taintproper str.c /^taintproper(s)$/
+ucase str.c /^ucase(s,send)$/
+uni toke.c /^uni(f,s)$/
+unlnk util.c /^unlnk(f) \/* unlink all versions of a file *\/$/
+userinit usersub.c /^userinit()$/
+validate_suid perl.c /^validate_suid(validarg)$/
+vfprintf util.c /^vfprintf(fd, pat, args)$/
+vsprintf util.c /^vsprintf(dest, pat, args)$/
+wait4pid util.c /^wait4pid(pid,statusp,flags)$/
+warn util.c /^void warn(pat,a1,a2,a3,a4)$/
+whichsig stab.c /^whichsig(sig)$/
+while_io cons.c /^while_io(cmd)$/
+wopt cons.c /^wopt(cmd)$/
+xstat util.c /^xstat()$/
+yyerror cons.c /^yyerror(s)$/
+yylex toke.c /^yylex()$/
+yyparse perly.c /^yyparse()$/
--- /dev/null
+void
+taint_proper(f, s)
+char *f;
+char *s;
+{
+ DEBUG_u(fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid));
+ if (tainted && (!euid || euid != uid || egid != gid || taintanyway)) {
+ if (!unsafe)
+ fatal(f, s);
+ else if (dowarn)
+ warn(f, s);
+ }
+}
+
+void
+taint_env()
+{
+ SV** svp;
+
+ svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE);
+ if (!svp || *svp == &sv_undef || (*svp)->sv_tainted) {
+ tainted = 1;
+ if ((*svp)->sv_tainted == 2)
+ taint_proper("Insecure directory in %s", "PATH");
+ else
+ taint_proper("Insecure %s", "PATH");
+ }
+ svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE);
+ if (svp && *svp != &sv_undef && (*svp)->sv_tainted) {
+ tainted = 1;
+ taint_proper("Insecure %s", "IFS");
+ }
+}
+
--- /dev/null
+foo
+--
+bar
+--
+baz
+--
--- /dev/null
+$* = 1;
+undef $/;
+$input = <>;
+@records = split(/^--\n/, $input);
+print @records + 0, "\n";
+print $records[0], "\n";
-/* $RCSfile: toke.c,v $$Revision: 4.0.1.8 $$Date: 92/06/23 12:33:45 $
+/* $RCSfile: toke.c,v $$Revision: 4.1 $$Date: 92/08/07 18:28:39 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: toke.c,v $
- * Revision 4.0.1.8 92/06/23 12:33:45 lwall
- * patch35: bad interaction between backslash and hyphen in tr///
+ * Revision 4.1 92/08/07 18:28:39 lwall
*
* Revision 4.0.1.7 92/06/11 21:16:30 lwall
- * patch34: expectterm incorrectly set to indicate start of program or block
+ * patch34: expect incorrectly set to indicate start of program or block
*
* Revision 4.0.1.6 92/06/08 16:03:49 lwall
* patch20: an EXPR may now start with a bareword
static void set_csh();
+/* The following are arranged oddly so that the guard on the switch statement
+ * can get by with a single comparison (if the compiler is smart enough).
+ */
+
+#define LEX_NORMAL 8
+#define LEX_INTERPNORMAL 7
+#define LEX_INTERPCASEMOD 6
+#define LEX_INTERPSTART 5
+#define LEX_INTERPEND 4
+#define LEX_INTERPENDMAYBE 3
+#define LEX_INTERPCONCAT 2
+#define LEX_INTERPCONST 1
+#define LEX_KNOWNEXT 0
+
+static U32 lex_state = LEX_NORMAL; /* next token is determined */
+static U32 lex_defer; /* state after determined token */
+static I32 lex_brackets; /* bracket count */
+static I32 lex_fakebrack; /* outer bracket is mere delimiter */
+static I32 lex_casemods; /* casemod count */
+static I32 lex_dojoin; /* doing an array interpolation */
+static I32 lex_starts; /* how many interps done on level */
+static SV * lex_stuff; /* runtime pattern from m// or s/// */
+static SV * lex_repl; /* runtime replacement from s/// */
+static OP * lex_op; /* extra info to pass back on op */
+static I32 lex_inpat; /* in pattern $) and $| are special */
+static I32 lex_inwhat; /* what kind of quoting are we in */
+
+/* What we know when we're in LEX_KNOWNEXT state. */
+static YYSTYPE nextval[5]; /* value of next token, if any */
+static I32 nexttype[5]; /* type of next token */
+static I32 nexttoke = 0;
+
#ifdef I_FCNTL
#include <fcntl.h>
#endif
#include <sys/file.h>
#endif
-#ifdef f_next
-#undef f_next
+#ifdef ff_next
+#undef ff_next
#endif
-/* which backslash sequences to keep in m// or s// */
-
-static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}";
-
-char *reparse; /* if non-null, scanident found ${foo[$bar]} */
+#include "keywords.h"
void checkcomma();
#ifdef CLINE
#undef CLINE
#endif
-#define CLINE (cmdline = (curcmd->c_line < cmdline ? curcmd->c_line : cmdline))
+#define CLINE (copline = (curcop->cop_line < copline ? curcop->cop_line : copline))
#ifdef atarist
#define PERL_META(c) ((c) | 128)
#define META(c) ((c) | 128)
#endif
-#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 FUN2x(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2x)
-#define FUN3(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC3)
-#define FUN4(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC4)
-#define FUN5(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC5)
-#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 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)
-
-static char *last_uni;
+#define TOKEN(retval) return (bufptr = s,(int)retval)
+#define OPERATOR(retval) return (expect = XTERM,bufptr = s,(int)retval)
+#define PREBLOCK(retval) return (expect = XBLOCK,bufptr = s,(int)retval)
+#define PREREF(retval) return (expect = XREF,bufptr = s,(int)retval)
+#define TERM(retval) return (CLINE, expect = XOPERATOR,bufptr = s,(int)retval)
+#define LOOPX(f) return(yylval.ival=f,expect = XOPERATOR,bufptr = s,(int)LOOPEX)
+#define FTST(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)UNIOP)
+#define FUN0(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC0)
+#define FUN1(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC1)
+#define BOop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP)
+#define BAop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP)
+#define SHop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP)
+#define PWop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP)
+#define PMop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MATCHOP)
+#define Aop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP)
+#define Mop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP)
+#define Eop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)EQOP)
+#define Rop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)RELOP)
/* 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, \
+ expect = XTERM, \
bufptr = s, \
last_uni = oldbufptr, \
(*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.
- */
-#ifdef atarist
-#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \
- (*s = (char) PERL_META('('), bufptr = oldbufptr, '(') : \
- (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
-#else
-#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \
- (*s = (char) META('('), bufptr = oldbufptr, '(') : \
- (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
-#endif
+#define UNIBRACK(f) return(yylval.ival = f, \
+ bufptr = s, \
+ last_uni = oldbufptr, \
+ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
+
+/* This does similarly for list operators */
+#define LOP(f) return(yylval.ival = f, \
+ CLINE, \
+ expect = XREF, \
+ bufptr = s, \
+ last_lop = oldbufptr, \
+ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC : (int)LSTOP) )
+
/* grandfather return to old style */
-#define OLDLOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP)
+#define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
+
+#define SNARFWORD \
+ *d++ = *s++; \
+ while (s < bufend && isALNUM(*s)) \
+ *d++ = *s++; \
+ *d = '\0';
+
+void
+reinit_lexer()
+{
+ lex_state = LEX_NORMAL;
+ lex_defer = 0;
+ lex_brackets = 0;
+ lex_fakebrack = 0;
+ lex_casemods = 0;
+ lex_dojoin = 0;
+ lex_starts = 0;
+ if (lex_stuff)
+ sv_free(lex_stuff);
+ lex_stuff = Nullsv;
+ if (lex_repl)
+ sv_free(lex_repl);
+ lex_repl = Nullsv;
+ lex_inpat = 0;
+ lex_inwhat = 0;
+ oldoldbufptr = oldbufptr = bufptr = SvPVn(linestr);
+ bufend = bufptr + SvCUR(linestr);
+}
char *
skipspace(s)
int
uni(f,s)
-int f;
+I32 f;
char *s;
{
yylval.ival = f;
- expectterm = TRUE;
+ expect = XTERM;
bufptr = s;
last_uni = oldbufptr;
if (*s == '(')
return UNIOP;
}
-int
+I32
lop(f,s)
-int f;
+I32 f;
char *s;
{
+ yylval.ival = f;
CLINE;
- if (*s != '(')
- s = skipspace(s);
- if (*s == '(') {
-#ifdef atarist
- *s = PERL_META('(');
-#else
- *s = META('(');
-#endif
- bufptr = oldbufptr;
- return '(';
+ expect = XREF;
+ bufptr = s;
+ last_uni = oldbufptr;
+ if (*s == '(')
+ return FUNC;
+ s = skipspace(s);
+ if (*s == '(')
+ return FUNC;
+ else
+ return LSTOP;
+}
+
+#endif /* CRIPPLED_CC */
+
+void
+force_next(type)
+I32 type;
+{
+ nexttype[nexttoke] = type;
+ nexttoke++;
+ if (lex_state != LEX_KNOWNEXT) {
+ lex_defer = lex_state;
+ lex_state = LEX_KNOWNEXT;
+ }
+}
+
+char *
+force_word(s,token)
+register char *s;
+int token;
+{
+ register char *d;
+
+ s = skipspace(s);
+ if (isIDFIRST(*s) || *s == '\'') {
+ d = tokenbuf;
+ SNARFWORD;
+ while (s < bufend && *s == '\'' && isIDFIRST(s[1])) {
+ *d++ = *s++;
+ SNARFWORD;
+ }
+ nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
+ force_next(token);
+ }
+ return s;
+}
+
+void
+force_ident(s)
+register char *s;
+{
+ if (s && *s) {
+ nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
+ force_next(WORD);
+ }
+}
+
+SV *
+q(sv)
+SV *sv;
+{
+ register char *s;
+ register char *send;
+ register char *d;
+ register char delim;
+
+ if (!SvLEN(sv))
+ return sv;
+
+ s = SvPVn(sv);
+ send = s + SvCUR(sv);
+ while (s < send && *s != '\\')
+ s++;
+ if (s == send)
+ return sv;
+ d = s;
+ delim = SvSTORAGE(sv);
+ while (s < send) {
+ if (*s == '\\') {
+ if (s + 1 < send && (s[1] == '\\' || s[1] == delim))
+ s++; /* all that, just for this */
+ }
+ *d++ = *s++;
+ }
+ *d = '\0';
+ SvCUR_set(sv, d - SvPV(sv));
+
+ return sv;
+}
+
+I32
+sublex_start()
+{
+ register I32 op_type = yylval.ival;
+ SV *sv;
+
+ if (op_type == OP_NULL) {
+ yylval.opval = lex_op;
+ lex_op = Nullop;
+ return THING;
+ }
+ if (op_type == OP_CONST || op_type == OP_READLINE) {
+ yylval.opval = (OP*)newSVOP(op_type, 0, q(lex_stuff));
+ lex_stuff = Nullsv;
+ return THING;
+ }
+
+ push_scope();
+ SAVEINT(lex_dojoin);
+ SAVEINT(lex_brackets);
+ SAVEINT(lex_fakebrack);
+ SAVEINT(lex_casemods);
+ SAVEINT(lex_starts);
+ SAVEINT(lex_state);
+ SAVEINT(lex_inpat);
+ SAVEINT(lex_inwhat);
+ SAVEINT(curcop->cop_line);
+ SAVESPTR(bufptr);
+ SAVESPTR(oldbufptr);
+ SAVESPTR(oldoldbufptr);
+ SAVESPTR(linestr);
+
+ linestr = lex_stuff;
+ lex_stuff = Nullsv;
+
+ bufend = bufptr = oldbufptr = oldoldbufptr = SvPVn(linestr);
+ bufend += SvCUR(linestr);
+
+ lex_dojoin = FALSE;
+ lex_brackets = 0;
+ lex_fakebrack = 0;
+ lex_casemods = 0;
+ lex_starts = 0;
+ lex_state = LEX_INTERPCONCAT;
+ curcop->cop_line = multi_start;
+
+ lex_inwhat = op_type;
+ if (op_type == OP_MATCH || op_type == OP_SUBST)
+ lex_inpat = op_type;
+ else
+ lex_inpat = 0;
+
+ force_next('(');
+ if (lex_op) {
+ yylval.opval = lex_op;
+ lex_op = Nullop;
+ return PMFUNC;
+ }
+ else
+ return FUNC;
+}
+
+I32
+sublex_done()
+{
+ if (!lex_starts++) {
+ expect = XOPERATOR;
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, NEWSV(94,1));
+ return THING;
+ }
+
+ if (lex_casemods) { /* oops, we've got some unbalanced parens */
+ lex_state = LEX_INTERPCASEMOD;
+ return yylex();
+ }
+
+ sv_free(linestr);
+ /* Is there a right-hand side to take care of? */
+ if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
+ linestr = lex_repl;
+ lex_inpat = 0;
+ bufend = bufptr = oldbufptr = oldoldbufptr = SvPVn(linestr);
+ bufend += SvCUR(linestr);
+ lex_dojoin = FALSE;
+ lex_brackets = 0;
+ lex_fakebrack = 0;
+ lex_casemods = 0;
+ lex_starts = 0;
+ if (SvCOMPILED(lex_repl)) {
+ lex_state = LEX_INTERPNORMAL;
+ lex_starts++;
+ }
+ else
+ lex_state = LEX_INTERPCONCAT;
+ lex_repl = Nullsv;
+ return ',';
}
else {
- yylval.ival=f;
- expectterm = TRUE;
- bufptr = s;
- return LISTOP;
+ pop_scope();
+ bufend = SvPVn(linestr);
+ bufend += SvCUR(linestr);
+ expect = XOPERATOR;
+ return ')';
}
}
-#endif /* CRIPPLED_CC */
+char *
+scan_const(start)
+char *start;
+{
+ register char *send = bufend;
+ SV *sv = NEWSV(93, send - start);
+ register char *s = start;
+ register char *d = SvPV(sv);
+ char delim = SvSTORAGE(linestr);
+ bool dorange = FALSE;
+ I32 len;
+ char *leave =
+ lex_inpat
+ ? "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}"
+ : (lex_inwhat & OP_TRANS)
+ ? ""
+ : "";
+
+ while (s < send || dorange) {
+ if (lex_inwhat == OP_TRANS) {
+ if (dorange) {
+ I32 i;
+ I32 max;
+ i = d - SvPV(sv);
+ SvGROW(sv, SvLEN(sv) + 256);
+ d = SvPV(sv) + i;
+ d -= 2;
+ max = d[1] & 0377;
+ for (i = (*d & 0377); i <= max; i++)
+ *d++ = i;
+ dorange = FALSE;
+ continue;
+ }
+ else if (*s == '-' && s+1 < send && s != start) {
+ dorange = TRUE;
+ s++;
+ }
+ }
+ else if (*s == '@')
+ break;
+ else if (*s == '$') {
+ if (!lex_inpat) /* not a regexp, so $ must be var */
+ break;
+ if (s + 1 < send && s[1] != ')' && s[1] != '|')
+ break; /* in regexp, $ might be tail anchor */
+ }
+ if (*s == '\\' && s+1 < send) {
+ s++;
+ if (*s == delim) {
+ *d++ = *s++;
+ continue;
+ }
+ if (*s && index(leave, *s)) {
+ *d++ = '\\';
+ *d++ = *s++;
+ continue;
+ }
+ if (lex_inwhat == OP_SUBST && !lex_inpat &&
+ isDIGIT(*s) && !isDIGIT(s[1]))
+ {
+ *--s = '$';
+ break;
+ }
+ if (lex_inwhat != OP_TRANS && *s && index("lLuUE", *s)) {
+ --s;
+ break;
+ }
+ switch (*s) {
+ case '-':
+ if (lex_inwhat == OP_TRANS) {
+ *d++ = *s++;
+ continue;
+ }
+ /* FALL THROUGH */
+ default:
+ *d++ = *s++;
+ continue;
+ case '0': case '1': case '2': case '3':
+ case '4': case '5': case '6': case '7':
+ *d++ = scan_oct(s, 3, &len);
+ s += len;
+ continue;
+ case 'x':
+ *d++ = scan_hex(++s, 2, &len);
+ s += len;
+ continue;
+ case 'c':
+ s++;
+ *d = *s++;
+ if (isLOWER(*d))
+ *d = toupper(*d);
+ *d++ ^= 64;
+ 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;
+ case 'e':
+ *d++ = '\033';
+ break;
+ case 'a':
+ *d++ = '\007';
+ break;
+ }
+ s++;
+ continue;
+ }
+ *d++ = *s++;
+ }
+ *d = '\0';
+ SvCUR_set(sv, d - SvPV(sv));
+ SvPOK_on(sv);
+
+ if (SvCUR(sv) + 5 < SvLEN(sv)) {
+ SvLEN_set(sv, SvCUR(sv) + 1);
+ Renew(SvPV(sv), SvLEN(sv), char);
+ }
+ if (s > bufptr)
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ else
+ sv_free(sv);
+ return s;
+}
+
+/* This is the one truly awful dwimmer necessary to conflate C and sed. */
+int
+intuit_more(s)
+register char *s;
+{
+ if (lex_brackets)
+ return TRUE;
+ if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
+ return TRUE;
+ if (*s != '{' && *s != '[')
+ return FALSE;
+ if (!lex_inpat)
+ return TRUE;
+
+ /* In a pattern, so maybe we have {n,m}. */
+ if (*s == '{') {
+ s++;
+ if (!isDIGIT(*s))
+ return TRUE;
+ while (isDIGIT(*s))
+ s++;
+ if (*s == ',')
+ s++;
+ while (isDIGIT(*s))
+ s++;
+ if (*s == '}')
+ return FALSE;
+ return TRUE;
+
+ }
+
+ /* On the other hand, maybe we have a character class */
+
+ s++;
+ if (*s == ']' || *s == '^')
+ return FALSE;
+ else {
+ int weight = 2; /* let's weigh the evidence */
+ char seen[256];
+ unsigned char un_char = 0, last_un_char;
+ char *send = index(s,']');
+ char tmpbuf[512];
+
+ if (!send) /* has to be an expression */
+ return TRUE;
+
+ Zero(seen,256,char);
+ if (*s == '$')
+ weight -= 3;
+ else if (isDIGIT(*s)) {
+ if (s[1] != ']') {
+ if (isDIGIT(s[1]) && s[2] == ']')
+ weight -= 10;
+ }
+ else
+ weight -= 100;
+ }
+ for (; s < send; s++) {
+ last_un_char = un_char;
+ un_char = (unsigned char)*s;
+ switch (*s) {
+ case '@':
+ case '&':
+ case '$':
+ weight -= seen[un_char] * 10;
+ if (isALNUM(s[1])) {
+ scan_ident(s,send,tmpbuf,FALSE);
+ if (strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE))
+ weight -= 100;
+ else
+ weight -= 10;
+ }
+ else if (*s == '$' && s[1] &&
+ index("[#!%*<>()-=",s[1])) {
+ if (/*{*/ index("])} =",s[2]))
+ weight -= 10;
+ else
+ weight -= 1;
+ }
+ break;
+ case '\\':
+ un_char = 254;
+ if (s[1]) {
+ if (index("wds]",s[1]))
+ weight += 100;
+ else if (seen['\''] || seen['"'])
+ weight += 1;
+ else if (index("rnftbxcav",s[1]))
+ weight += 40;
+ else if (isDIGIT(s[1])) {
+ weight += 40;
+ while (s[1] && isDIGIT(s[1]))
+ s++;
+ }
+ }
+ else
+ weight += 100;
+ break;
+ case '-':
+ if (s[1] == '\\')
+ weight += 50;
+ if (index("aA01! ",last_un_char))
+ weight += 30;
+ if (index("zZ79~",s[1]))
+ weight += 30;
+ break;
+ default:
+ if (!isALNUM(last_un_char) && !index("$@&",last_un_char) &&
+ isALPHA(*s) && s[1] && isALPHA(s[1])) {
+ char *d = tmpbuf;
+ while (isALPHA(*s))
+ *d++ = *s++;
+ *d = '\0';
+ if (keyword(tmpbuf, d - tmpbuf))
+ weight -= 150;
+ }
+ if (un_char == last_un_char + 1)
+ weight += 5;
+ weight -= seen[un_char];
+ break;
+ }
+ seen[un_char]++;
+ }
+ if (weight >= 0) /* probably a character class */
+ return FALSE;
+ }
+
+ return TRUE;
+}
int
yylex()
{
- register char *s = bufptr;
+ register char *s;
register char *d;
- register int tmp;
- static bool in_format = FALSE;
- static bool firstline = TRUE;
+ register I32 tmp;
extern int yychar; /* last token */
+ switch (lex_state) {
+#ifdef COMMENTARY
+ case LEX_NORMAL: /* Some compilers will produce faster */
+ case LEX_INTERPNORMAL: /* code if we comment these out. */
+ break;
+#endif
+
+ case LEX_KNOWNEXT:
+ nexttoke--;
+ yylval = nextval[nexttoke];
+ if (!nexttoke)
+ lex_state = lex_defer;
+ return(nexttype[nexttoke]);
+
+ case LEX_INTERPCASEMOD:
+#ifdef DEBUGGING
+ if (bufptr != bufend && *bufptr != '\\')
+ fatal("panic: INTERPCASEMOD");
+#endif
+ if (bufptr == bufend || bufptr[1] == 'E') {
+ if (lex_casemods <= 1) {
+ if (bufptr != bufend)
+ bufptr += 2;
+ lex_state = LEX_INTERPSTART;
+ }
+ if (lex_casemods) {
+ --lex_casemods;
+ return ')';
+ }
+ return yylex();
+ }
+ else {
+ s = bufptr + 1;
+ if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
+ tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
+ ++lex_casemods;
+ lex_state = LEX_INTERPCONCAT;
+ nextval[nexttoke].ival = 0;
+ force_next('(');
+ if (*s == 'l')
+ nextval[nexttoke].ival = OP_LCFIRST;
+ else if (*s == 'u')
+ nextval[nexttoke].ival = OP_UCFIRST;
+ else if (*s == 'L')
+ nextval[nexttoke].ival = OP_LC;
+ else if (*s == 'U')
+ nextval[nexttoke].ival = OP_UC;
+ else
+ fatal("panic: yylex");
+ bufptr = s + 1;
+ force_next(FUNC);
+ if (lex_starts) {
+ s = bufptr;
+ Aop(OP_CONCAT);
+ }
+ else
+ return yylex();
+ }
+
+ case LEX_INTERPSTART:
+ if (bufptr == bufend)
+ return sublex_done();
+ expect = XTERM;
+ lex_dojoin = (*bufptr == '@');
+ lex_state = LEX_INTERPNORMAL;
+ if (lex_dojoin) {
+ nextval[nexttoke].ival = 0;
+ force_next(',');
+ force_ident("\"");
+ nextval[nexttoke].ival = 0;
+ force_next('$');
+ nextval[nexttoke].ival = 0;
+ force_next('(');
+ nextval[nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
+ force_next(FUNC);
+ }
+ if (lex_starts++) {
+ s = bufptr;
+ Aop(OP_CONCAT);
+ }
+ else
+ return yylex();
+ break;
+
+ case LEX_INTERPENDMAYBE:
+ if (intuit_more(bufptr)) {
+ lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
+ break;
+ }
+ /* FALL THROUGH */
+
+ case LEX_INTERPEND:
+ if (lex_dojoin) {
+ lex_dojoin = FALSE;
+ lex_state = LEX_INTERPCONCAT;
+ return ')';
+ }
+ /* FALLTHROUGH */
+ case LEX_INTERPCONCAT:
+#ifdef DEBUGGING
+ if (lex_brackets)
+ fatal("panic: INTERPCONCAT");
+#endif
+ if (bufptr == bufend)
+ return sublex_done();
+
+ if (SvSTORAGE(linestr) == '\'') {
+ SV *sv = newSVsv(linestr);
+ if (!lex_inpat)
+ sv = q(sv);
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ s = bufend;
+ }
+ else {
+ s = scan_const(bufptr);
+ if (*s == '\\')
+ lex_state = LEX_INTERPCASEMOD;
+ else
+ lex_state = LEX_INTERPSTART;
+ }
+
+ if (s != bufptr) {
+ nextval[nexttoke] = yylval;
+ force_next(THING);
+ if (lex_starts++)
+ Aop(OP_CONCAT);
+ else {
+ bufptr = s;
+ return yylex();
+ }
+ }
+
+ return yylex();
+ }
+
+ s = bufptr;
oldoldbufptr = oldbufptr;
oldbufptr = s;
retry:
-#ifdef YYDEBUG
- if (debug & 1)
+ DEBUG_p( {
if (index(s,'\n'))
fprintf(stderr,"Tokener at %s",s);
else
fprintf(stderr,"Tokener at %s\n",s);
-#endif
+ } )
#ifdef BADSWITCH
if (*s & 128) {
- if ((*s & 127) == '(') {
- *s++ = '(';
- oldbufptr = s;
- }
- else if ((*s & 127) == '}') {
+ if ((*s & 127) == '}') {
*s++ = '}';
- RETURN('}');
+ TOKEN('}');
}
else
warn("Unrecognized character \\%03o ignored", *s++ & 255);
#endif
switch (*s) {
default:
- if ((*s & 127) == '(') {
- *s++ = '(';
- oldbufptr = s;
- }
- else if ((*s & 127) == '}') {
+ if ((*s & 127) == '}') {
*s++ = '}';
- RETURN('}');
+ TOKEN('}');
}
else
warn("Unrecognized character \\%03o ignored", *s++ & 255);
goto fake_eof; /* emulate EOF on ^D or ^Z */
case 0:
if (!rsfp)
- RETURN(0);
+ TOKEN(0);
if (s++ < bufend)
goto retry; /* ignore stray nulls */
last_uni = 0;
- if (firstline) {
- firstline = FALSE;
- if (minus_n || minus_p || perldb) {
- str_set(linestr,"");
- if (perldb) {
- char *getenv();
- char *pdb = getenv("PERLDB");
-
- str_cat(linestr, pdb ? pdb : "require 'perldb.pl'");
- str_cat(linestr, ";");
- }
- if (minus_n || minus_p) {
- str_cat(linestr,"line: while (<>) {");
- if (minus_l)
- str_cat(linestr,"chop;");
- if (minus_a)
- str_cat(linestr,"@F=split(' ');");
- }
- oldoldbufptr = oldbufptr = s = str_get(linestr);
- bufend = linestr->str_ptr + linestr->str_cur;
- goto retry;
+ last_lop = 0;
+ if (!preambled) {
+ preambled = TRUE;
+ sv_setpv(linestr,"");
+ if (perldb) {
+ char *pdb = getenv("PERLDB");
+
+ sv_catpv(linestr, pdb ? pdb : "require 'perldb.pl'");
+ sv_catpv(linestr, ";");
}
+ sv_catpv(linestr, "&BEGIN if defined &BEGIN;");
+ if (minus_n || minus_p) {
+ sv_catpv(linestr, "LINE: while (<>) {");
+ if (minus_l)
+ sv_catpv(linestr,"chop;");
+ if (minus_a)
+ sv_catpv(linestr,"@F=split(' ');");
+ }
+ oldoldbufptr = oldbufptr = s = SvPVn(linestr);
+ bufend = SvPV(linestr) + SvCUR(linestr);
+ goto retry;
}
- if (in_format) {
- bufptr = bufend;
- yylval.formval = load_format();
- in_format = FALSE;
- oldoldbufptr = oldbufptr = s = str_get(linestr) + 1;
- bufend = linestr->str_ptr + linestr->str_cur;
- OPERATOR(FORMLIST);
- }
- curcmd->c_line++;
#ifdef CRYPTSCRIPT
cryptswitch();
#endif /* CRYPTSCRIPT */
do {
- if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
+ if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) {
fake_eof:
if (rsfp) {
if (preprocess)
- (void)mypclose(rsfp);
+ (void)my_pclose(rsfp);
else if ((FILE*)rsfp == stdin)
clearerr(stdin);
else
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;
+ sv_setpv(linestr,minus_p ? ";}continue{print" : "");
+ sv_catpv(linestr,";}");
+ oldoldbufptr = oldbufptr = s = SvPVn(linestr);
+ bufend = SvPV(linestr) + SvCUR(linestr);
minus_n = minus_p = 0;
goto retry;
}
- oldoldbufptr = oldbufptr = s = str_get(linestr);
- str_set(linestr,"");
- RETURN(';'); /* not infinite loop because rsfp is NULL now */
+ oldoldbufptr = oldbufptr = s = SvPVn(linestr);
+ sv_setpv(linestr,"");
+ TOKEN(';'); /* not infinite loop because rsfp is NULL now */
}
- if (doextract && *linestr->str_ptr == '#')
+ if (doextract && *SvPV(linestr) == '#')
doextract = FALSE;
+ curcop->cop_line++;
} while (doextract);
oldoldbufptr = oldbufptr = bufptr = s;
if (perldb) {
- STR *str = Str_new(85,0);
+ SV *sv = NEWSV(85,0);
- str_sset(str,linestr);
- astore(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str);
+ sv_setsv(sv,linestr);
+ av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
}
-#ifdef DEBUG
- if (firstline) {
- char *showinput();
- s = showinput();
- }
-#endif
- bufend = linestr->str_ptr + linestr->str_cur;
- if (curcmd->c_line == 1) {
+ bufend = SvPV(linestr) + SvCUR(linestr);
+ if (curcop->cop_line == 1) {
+ while (s < bufend && isSPACE(*s))
+ s++;
+ if (*s == ':') /* for csh's that have to exec sh scripts */
+ s++;
if (*s == '#' && s[1] == '!') {
if (!in_eval && !instr(s,"perl") && instr(origargv[0],"perl")) {
char **newargv;
execv(cmd,newargv);
fatal("Can't exec %s", cmd);
}
+ if (d = instr(s, "perl -")) {
+ d += 6;
+ /*SUPPRESS 530*/
+ while (d = moreswitches(d)) ;
+ }
}
- else {
- while (s < bufend && isSPACE(*s))
- s++;
- if (*s == ':') /* for csh's that have to exec sh scripts */
- s++;
- }
+ }
+ if (in_format && lex_brackets <= 1) {
+ s = scan_formline(s);
+ if (!in_format)
+ goto rightbracket;
+ OPERATOR(';');
}
goto retry;
case ' ': case '\t': case '\f': case '\r': case 013:
s++;
goto retry;
case '#':
- if (preprocess && s == str_get(linestr) &&
+ if (preprocess && s == SvPVn(linestr) &&
s[1] == ' ' && (isDIGIT(s[2]) || strnEQ(s+2,"line ",5)) ) {
while (*s && !isDIGIT(*s))
s++;
- curcmd->c_line = atoi(s)-1;
+ curcop->cop_line = atoi(s)-1;
while (isDIGIT(*s))
s++;
- d = bufend;
- while (s < d && isSPACE(*s)) s++;
+ s = skipspace(s);
s[strlen(s)-1] = '\0'; /* wipe out newline */
if (*s == '"') {
s++;
s[strlen(s)-1] = '\0'; /* wipe out trailing quote */
}
if (*s)
- curcmd->c_filestab = fstab(s);
+ curcop->cop_filegv = gv_fetchfile(s);
else
- curcmd->c_filestab = fstab(origfilename);
- oldoldbufptr = oldbufptr = s = str_get(linestr);
+ curcop->cop_filegv = gv_fetchfile(origfilename);
+ oldoldbufptr = oldbufptr = s = SvPVn(linestr);
}
/* FALL THROUGH */
case '\n':
- if (in_eval && !rsfp) {
+ if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
d = bufend;
while (s < d && *s != '\n')
s++;
if (s < d)
s++;
- if (in_format) {
- bufptr = s;
- yylval.formval = load_format();
- in_format = FALSE;
- oldoldbufptr = oldbufptr = s = bufptr + 1;
- TERM(FORMLIST);
+ curcop->cop_line++;
+ if (in_format && lex_brackets <= 1) {
+ s = scan_formline(s);
+ if (!in_format)
+ goto rightbracket;
+ OPERATOR(';');
}
- curcmd->c_line++;
}
else {
*s = '\0';
}
goto retry;
case '-':
- if (s[1] && isALPHA(s[1]) && !isALPHA(s[2])) {
+ if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
s++;
last_uni = oldbufptr;
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);
- case 'M': stabent("\024",TRUE); FTST(O_FTMTIME);
- case 'A': stabent("\024",TRUE); FTST(O_FTATIME);
- case 'C': stabent("\024",TRUE); FTST(O_FTCTIME);
+ case 'r': FTST(OP_FTEREAD);
+ case 'w': FTST(OP_FTEWRITE);
+ case 'x': FTST(OP_FTEEXEC);
+ case 'o': FTST(OP_FTEOWNED);
+ case 'R': FTST(OP_FTRREAD);
+ case 'W': FTST(OP_FTRWRITE);
+ case 'X': FTST(OP_FTREXEC);
+ case 'O': FTST(OP_FTROWNED);
+ case 'e': FTST(OP_FTIS);
+ case 'z': FTST(OP_FTZERO);
+ case 's': FTST(OP_FTSIZE);
+ case 'f': FTST(OP_FTFILE);
+ case 'd': FTST(OP_FTDIR);
+ case 'l': FTST(OP_FTLINK);
+ case 'p': FTST(OP_FTPIPE);
+ case 'S': FTST(OP_FTSOCK);
+ case 'u': FTST(OP_FTSUID);
+ case 'g': FTST(OP_FTSGID);
+ case 'k': FTST(OP_FTSVTX);
+ case 'b': FTST(OP_FTBLK);
+ case 'c': FTST(OP_FTCHR);
+ case 't': FTST(OP_FTTTY);
+ case 'T': FTST(OP_FTTEXT);
+ case 'B': FTST(OP_FTBINARY);
+ case 'M': gv_fetchpv("\024",TRUE); FTST(OP_FTMTIME);
+ case 'A': gv_fetchpv("\024",TRUE); FTST(OP_FTATIME);
+ case 'C': gv_fetchpv("\024",TRUE); FTST(OP_FTCTIME);
default:
s -= 2;
break;
tmp = *s++;
if (*s == tmp) {
s++;
- RETURN(DEC);
+ if (expect == XOPERATOR)
+ TERM(POSTDEC);
+ else
+ OPERATOR(PREDEC);
+ }
+ else if (*s == '>') {
+ s++;
+ s = skipspace(s);
+ if (isIDFIRST(*s)) {
+ /*SUPPRESS 530*/
+ for (d = s; isALNUM(*d); d++) ;
+ strncpy(tokenbuf,s,d-s);
+ tokenbuf[d-s] = '\0';
+ if (!keyword(tokenbuf, d - s))
+ s = force_word(s,METHOD);
+ }
+ PREBLOCK(ARROW);
}
- if (expectterm) {
+ if (expect == XOPERATOR)
+ Aop(OP_SUBTRACT);
+ else {
if (isSPACE(*s) || !isSPACE(*bufptr))
check_uni();
- OPERATOR('-');
+ OPERATOR('-'); /* unary minus */
}
- else
- AOP(O_SUBTRACT);
+
case '+':
tmp = *s++;
if (*s == tmp) {
s++;
- RETURN(INC);
+ if (expect == XOPERATOR)
+ TERM(POSTINC);
+ else
+ OPERATOR(PREINC);
}
- if (expectterm) {
+ if (expect == XOPERATOR)
+ Aop(OP_ADD);
+ else {
if (isSPACE(*s) || !isSPACE(*bufptr))
check_uni();
OPERATOR('+');
}
- else
- AOP(O_ADD);
case '*':
- if (expectterm) {
- check_uni();
- s = scanident(s,bufend,tokenbuf);
- yylval.stabval = stabent(tokenbuf,TRUE);
- TERM(STAR);
+ if (expect != XOPERATOR) {
+ s = scan_ident(s, bufend, tokenbuf, TRUE);
+ force_ident(tokenbuf);
+ TERM('*');
}
- tmp = *s++;
- if (*s == tmp) {
+ s++;
+ if (*s == '*') {
s++;
- OPERATOR(POW);
+ PWop(OP_POW);
}
- MOP(O_MULTIPLY);
+ Mop(OP_MULTIPLY);
+
case '%':
- if (expectterm) {
- if (!isALPHA(s[1]))
- check_uni();
- s = scanident(s,bufend,tokenbuf);
- yylval.stabval = hadd(stabent(tokenbuf,TRUE));
- TERM(HSH);
+ if (expect != XOPERATOR) {
+ s = scan_ident(s, bufend, tokenbuf, TRUE);
+ force_ident(tokenbuf);
+ TERM('%');
}
- s++;
- MOP(O_MODULO);
+ ++s;
+ Mop(OP_MODULO);
case '^':
+ s++;
+ BOop(OP_XOR);
+ case '[':
+ lex_brackets++;
+ /* FALL THROUGH */
case '~':
case '(':
case ',':
case ':':
- case '[':
tmp = *s++;
OPERATOR(tmp);
- case '{':
- tmp = *s++;
- yylval.ival = curcmd->c_line;
- if (isSPACE(*s) || *s == '#')
- cmdline = NOLINE; /* invalidate current command line number */
- expectterm = 2;
- RETURN(tmp);
case ';':
- if (curcmd->c_line < cmdline)
- cmdline = curcmd->c_line;
+ if (curcop->cop_line < copline)
+ copline = curcop->cop_line;
tmp = *s++;
OPERATOR(tmp);
case ')':
- case ']':
tmp = *s++;
TERM(tmp);
+ case ']':
+ s++;
+ if (lex_state == LEX_INTERPNORMAL) {
+ if (--lex_brackets == 0) {
+ if (*s != '-' || s[1] != '>')
+ lex_state = LEX_INTERPEND;
+ }
+ }
+ TOKEN(']');
+ case '{':
+ leftbracket:
+ if (in_format == 2)
+ in_format = 0;
+ s++;
+ lex_brackets++;
+ if (expect == XTERM)
+ OPERATOR(HASHBRACK);
+ yylval.ival = curcop->cop_line;
+ if (isSPACE(*s) || *s == '#')
+ copline = NOLINE; /* invalidate current command line number */
+ expect = XBLOCK;
+ TOKEN('{');
case '}':
- *s |= 128;
- RETURN(';');
+ rightbracket:
+ s++;
+ if (lex_state == LEX_INTERPNORMAL) {
+ if (--lex_brackets == 0) {
+ if (lex_fakebrack) {
+ lex_state = LEX_INTERPEND;
+ bufptr = s;
+ return yylex(); /* ignore fake brackets */
+ }
+ if (*s != '-' || s[1] != '>')
+ lex_state = LEX_INTERPEND;
+ }
+ }
+ force_next('}');
+ TOKEN(';');
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 */
- else
- check_uni();
- OPERATOR(AMPER);
- }
- OPERATOR('&');
+ if (expect == XOPERATOR)
+ BAop(OP_BIT_AND);
+
+ s = scan_ident(s-1, bufend, tokenbuf, TRUE);
+ if (*tokenbuf)
+ force_ident(tokenbuf);
+ else
+ PREREF('&');
+ TERM('&');
+
case '|':
s++;
tmp = *s++;
if (tmp == '|')
OPERATOR(OROR);
s--;
- OPERATOR('|');
+ BOop(OP_BIT_OR);
case '=':
s++;
tmp = *s++;
if (tmp == '=')
- EOP(O_EQ);
+ Eop(OP_EQ);
+ if (tmp == '>')
+ OPERATOR(',');
if (tmp == '~')
- OPERATOR(MATCH);
+ PMop(OP_MATCH);
s--;
+ if (in_format == 2 && (tmp == '\n' || s[1] == '\n')) {
+ in_format = 1;
+ s--;
+ expect = XBLOCK;
+ goto leftbracket;
+ }
OPERATOR('=');
case '!':
s++;
tmp = *s++;
if (tmp == '=')
- EOP(O_NE);
+ Eop(OP_NE);
if (tmp == '~')
- OPERATOR(NMATCH);
+ PMop(OP_NOT);
s--;
OPERATOR('!');
case '<':
- if (expectterm) {
+ if (expect != XOPERATOR) {
if (s[1] != '<' && !index(s,'>'))
check_uni();
- s = scanstr(s, SCAN_DEF);
- TERM(RSTRING);
+ if (s[1] == '<')
+ s = scan_heredoc(s);
+ else
+ s = scan_inputsymbol(s);
+ TERM(sublex_start());
}
s++;
tmp = *s++;
if (tmp == '<')
- OPERATOR(LS);
+ SHop(OP_LEFT_SHIFT);
if (tmp == '=') {
tmp = *s++;
if (tmp == '>')
- EOP(O_NCMP);
+ Eop(OP_NCMP);
s--;
- ROP(O_LE);
+ Rop(OP_LE);
}
s--;
- ROP(O_LT);
+ Rop(OP_LT);
case '>':
s++;
tmp = *s++;
if (tmp == '>')
- OPERATOR(RS);
+ SHop(OP_RIGHT_SHIFT);
if (tmp == '=')
- ROP(O_GE);
+ Rop(OP_GE);
s--;
- ROP(O_GT);
-
-#define SNARFWORD \
- d = tokenbuf; \
- while (isALNUM(*s) || *s == '\'') \
- *d++ = *s++; \
- while (d[-1] == '\'') \
- d--,s--; \
- *d = '\0'; \
- d = tokenbuf;
+ Rop(OP_GT);
case '$':
- if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_')) {
- s++;
- s = scanident(s,bufend,tokenbuf);
- yylval.stabval = aadd(stabent(tokenbuf,TRUE));
- TERM(ARYLEN);
- }
- d = s;
- s = scanident(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);
- expectterm = FALSE;
- if (isSPACE(*s) && oldoldbufptr && oldoldbufptr < bufptr) {
+ if (in_format && expect == XOPERATOR)
+ OPERATOR(','); /* grandfather non-comma-format format */
+ if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_')) {
+ s = scan_ident(s+1, bufend, tokenbuf, FALSE);
+ force_ident(tokenbuf);
+ TERM(DOLSHARP);
+ }
+ s = scan_ident(s, bufend, tokenbuf, FALSE);
+ if (*tokenbuf)
+ force_ident(tokenbuf);
+ else
+ PREREF('$');
+ expect = XOPERATOR;
+ if (lex_state == LEX_NORMAL &&
+ *tokenbuf &&
+ isSPACE(*s) &&
+ oldoldbufptr &&
+ oldoldbufptr < bufptr)
+ {
s++;
while (isSPACE(*oldoldbufptr))
oldoldbufptr++;
if (*oldoldbufptr == 'p' && strnEQ(oldoldbufptr,"print",5)) {
- if (index("&*<%", *s) && isALPHA(s[1]))
- expectterm = TRUE; /* e.g. print $fh &sub */
+ if (index("&*<%", *s) && isIDFIRST(s[1]))
+ expect = XTERM; /* e.g. print $fh &sub */
else if (*s == '.' && isDIGIT(s[1]))
- expectterm = TRUE; /* e.g. print $fh .3 */
+ expect = XTERM; /* e.g. print $fh .3 */
else if (index("/?-+", *s) && !isSPACE(s[1]))
- expectterm = TRUE; /* e.g. print $fh -1 */
+ expect = XTERM; /* e.g. print $fh -1 */
}
}
- RETURN(REG);
+ TOKEN('$');
case '@':
- d = s;
- s = scanident(s,bufend,tokenbuf);
- if (reparse)
- goto do_reparse;
- yylval.stabval = aadd(stabent(tokenbuf,TRUE));
- TERM(ARY);
+ s = scan_ident(s, bufend, tokenbuf, FALSE);
+ if (*tokenbuf)
+ force_ident(tokenbuf);
+ else
+ PREREF('@');
+ TERM('@');
case '/': /* may either be division or pattern */
case '?': /* may either be conditional or pattern */
- if (expectterm) {
+ if (expect != XOPERATOR) {
check_uni();
- s = scanpat(s);
- TERM(PATTERN);
+ s = scan_pat(s);
+ TERM(sublex_start());
}
tmp = *s++;
if (tmp == '/')
- MOP(O_DIVIDE);
+ Mop(OP_DIVIDE);
OPERATOR(tmp);
case '.':
- if (!expectterm || !isDIGIT(s[1])) {
+ if (in_format == 2) {
+ in_format = 0;
+ goto rightbracket;
+ }
+ if (expect == XOPERATOR || !isDIGIT(s[1])) {
tmp = *s++;
if (*s == tmp) {
s++;
if (*s == tmp) {
s++;
- yylval.ival = 0;
+ yylval.ival = OPf_SPECIAL;
}
else
- yylval.ival = AF_COMMON;
+ yylval.ival = 0;
OPERATOR(DOTDOT);
}
- if (expectterm)
+ if (expect != XOPERATOR)
check_uni();
- AOP(O_CONCAT);
+ Aop(OP_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, SCAN_DEF);
- TERM(RSTRING);
-
- case '\\': /* some magic to force next word to be a WORD */
- s++; /* used by do and sub to force a separate namespace */
- if (!isALPHA(*s) && *s != '_' && *s != '\'') {
- warn("Spurious backslash ignored");
- goto retry;
+ s = scan_num(s);
+ TERM(THING);
+
+ case '\'':
+ if (in_format && expect == XOPERATOR)
+ OPERATOR(','); /* grandfather non-comma-format format */
+ s = scan_str(s);
+ if (!s)
+ fatal("EOF in string");
+ yylval.ival = OP_CONST;
+ TERM(sublex_start());
+
+ case '"':
+ if (in_format && expect == XOPERATOR)
+ OPERATOR(','); /* grandfather non-comma-format format */
+ s = scan_str(s);
+ if (!s)
+ fatal("EOF in string");
+ yylval.ival = OP_SCALAR;
+ TERM(sublex_start());
+
+ case '`':
+ s = scan_str(s);
+ if (!s)
+ fatal("EOF in backticks");
+ yylval.ival = OP_BACKTICK;
+ set_csh();
+ TERM(sublex_start());
+
+ case '\\':
+ s++;
+ OPERATOR(REFGEN);
+
+ case 'x':
+ if (isDIGIT(s[1]) && expect == XOPERATOR) {
+ s++;
+ Mop(OP_REPEAT);
}
- /* FALL THROUGH */
+ goto keylookup;
+
case '_':
+ case 'a': case 'A':
+ case 'b': case 'B':
+ case 'c': case 'C':
+ case 'd': case 'D':
+ case 'e': case 'E':
+ case 'f': case 'F':
+ case 'g': case 'G':
+ case 'h': case 'H':
+ case 'i': case 'I':
+ case 'j': case 'J':
+ case 'k': case 'K':
+ case 'l': case 'L':
+ case 'm': case 'M':
+ case 'n': case 'N':
+ case 'o': case 'O':
+ case 'p': case 'P':
+ case 'q': case 'Q':
+ case 'r': case 'R':
+ case 's': case 'S':
+ case 't': case 'T':
+ case 'u': case 'U':
+ case 'v': case 'V':
+ case 'w': case 'W':
+ case 'X':
+ case 'y': case 'Y':
+ case 'z': case 'Z':
+
+ keylookup:
+ d = tokenbuf;
SNARFWORD;
- if (d[1] == '_') {
- if (strEQ(d,"__LINE__") || strEQ(d,"__FILE__")) {
- ARG *arg = op_new(1);
- yylval.arg = arg;
- arg->arg_type = O_ITEM;
- if (d[2] == 'L')
- (void)sprintf(tokenbuf,"%ld",(long)curcmd->c_line);
- else
- strcpy(tokenbuf, stab_val(curcmd->c_filestab)->str_ptr);
- arg[1].arg_type = A_SINGLE;
- arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
- TERM(RSTRING);
+ switch (tmp = keyword(tokenbuf, d - tokenbuf)) {
+
+ default: /* not a keyword */
+ just_a_word:
+ while (*s == '\'' && isIDFIRST(s[1])) {
+ *d++ = *s++;
+ SNARFWORD;
}
- else if (strEQ(d,"__END__")) {
- STAB *stab;
- int fd;
-
- /*SUPPRESS 560*/
- if (!in_eval && (stab = stabent("DATA",FALSE))) {
- stab->str_pok |= SP_MULTI;
- if (!stab_io(stab))
- stab_io(stab) = stio_new();
- stab_io(stab)->ifp = rsfp;
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- fd = fileno(rsfp);
- fcntl(fd,F_SETFD,fd >= 3);
-#endif
- if (preprocess)
- stab_io(stab)->type = '|';
- else if ((FILE*)rsfp == stdin)
- stab_io(stab)->type = '-';
- else
- stab_io(stab)->type = '<';
- rsfp = Nullfp;
+ if (expect == XBLOCK) { /* special case: start of statement */
+ yylval.pval = savestr(tokenbuf);
+ while (isSPACE(*s)) s++;
+ if (*s == ':') {
+ s++;
+ CLINE;
+ OPERATOR(LABEL);
}
- goto fake_eof;
}
+ expect = XOPERATOR;
+ if (oldoldbufptr && oldoldbufptr < bufptr) {
+ if (oldoldbufptr == last_lop) {
+ expect = XTERM;
+ CLINE;
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ newSVpv(tokenbuf,0));
+ yylval.opval->op_private = OPpCONST_BARE;
+ for (d = tokenbuf; *d && isLOWER(*d); d++) ;
+ if (dowarn && !*d)
+ warn(
+ "\"%s\" may clash with future reserved word",
+ tokenbuf );
+ TOKEN(WORD);
+ }
+ }
+ while (s < bufend && isSPACE(*s))
+ s++;
+#ifdef OLD
+ if (*s == '(') {
+ CLINE;
+ nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
+ nextval[nexttoke].opval->op_private = OPpCONST_BARE;
+ force_next(WORD);
+ LOP( OP_ENTERSUBR );
+ }
+#endif
+ CLINE;
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
+ yylval.opval->op_private = OPpCONST_BARE;
+
+ if (*s == '$' || *s == '{')
+ PREBLOCK(METHOD);
+
+ for (d = tokenbuf; *d && isLOWER(*d); d++) ;
+ if (dowarn && !*d)
+ warn(
+ "\"%s\" may clash with future reserved word",
+ tokenbuf );
+ TOKEN(WORD);
+
+ case KEY___LINE__:
+ case KEY___FILE__: {
+ if (tokenbuf[2] == 'L')
+ (void)sprintf(tokenbuf,"%ld",(long)curcop->cop_line);
+ else
+ strcpy(tokenbuf, SvPV(GvSV(curcop->cop_filegv)));
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
+ TERM(THING);
+ }
+
+ case KEY___END__: {
+ GV *gv;
+ int fd;
+
+ /*SUPPRESS 560*/
+ if (!in_eval && (gv = gv_fetchpv("DATA",FALSE))) {
+ SvMULTI_on(gv);
+ if (!GvIO(gv))
+ GvIO(gv) = newIO();
+ GvIO(gv)->ifp = rsfp;
+#if defined(HAS_FCNTL) && defined(FFt_SETFD)
+ fd = fileno(rsfp);
+ fcntl(fd,FFt_SETFD,fd >= 3);
+#endif
+ if (preprocess)
+ GvIO(gv)->type = '|';
+ else if ((FILE*)rsfp == stdin)
+ GvIO(gv)->type = '-';
+ else
+ GvIO(gv)->type = '<';
+ rsfp = Nullfp;
+ }
+ goto fake_eof;
}
- break;
- case 'a': case 'A':
- SNARFWORD;
- if (strEQ(d,"alarm"))
- UNI(O_ALARM);
- 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);
- if (strEQ(d,"binmode"))
- FOP(O_BINMODE);
- 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,"cmp"))
- EOP(O_SCMP);
- if (strEQ(d,"caller"))
- UNI(O_CALLER);
- if (strEQ(d,"crypt")) {
-#ifdef FCRYPT
- static int cryptseen = 0;
+ case KEY_BEGIN:
+ case KEY_END:
+ s = skipspace(s);
+ if (minus_p || minus_n || *s == '{' ) {
+ nextval[nexttoke].opval =
+ (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
+ force_next(WORD);
+ OPERATOR(SUB);
+ }
+ goto just_a_word;
+
+ case KEY_alarm:
+ UNI(OP_ALARM);
+
+ case KEY_accept:
+ LOP(OP_ACCEPT);
+
+ case KEY_atan2:
+ LOP(OP_ATAN2);
+
+ case KEY_bind:
+ LOP(OP_BIND);
+
+ case KEY_binmode:
+ UNI(OP_BINMODE);
+
+ case KEY_bless:
+ UNI(OP_BLESS);
+
+ case KEY_chop:
+ UNI(OP_CHOP);
+
+ case KEY_continue:
+ PREBLOCK(CONTINUE);
+
+ case KEY_chdir:
+ (void)gv_fetchpv("ENV",TRUE); /* may use HOME */
+ UNI(OP_CHDIR);
+
+ case KEY_close:
+ UNI(OP_CLOSE);
+
+ case KEY_closedir:
+ UNI(OP_CLOSEDIR);
+
+ case KEY_cmp:
+ Eop(OP_SCMP);
+
+ case KEY_caller:
+ UNI(OP_CALLER);
+
+ case KEY_crypt:
+#ifdef FCRYPT
if (!cryptseen++)
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 */
+ LOP(OP_CRYPT);
+
+ case KEY_chmod:
+ LOP(OP_CHMOD);
+
+ case KEY_chown:
+ LOP(OP_CHOWN);
+
+ case KEY_connect:
+ LOP(OP_CONNECT);
+
+ case KEY_cos:
+ UNI(OP_COS);
+
+ case KEY_chroot:
+ UNI(OP_CHROOT);
+
+ case KEY_do:
+ s = skipspace(s);
+ if (*s == '{')
+ PREBLOCK(DO);
+ if (*s != '\'')
+ s = force_word(s,WORD);
OPERATOR(DO);
+
+ case KEY_die:
+ LOP(OP_DIE);
+
+ case KEY_defined:
+ UNI(OP_DEFINED);
+
+ case KEY_delete:
+ OPERATOR(DELETE);
+
+ case KEY_dbmopen:
+ LOP(OP_DBMOPEN);
+
+ case KEY_dbmclose:
+ UNI(OP_DBMCLOSE);
+
+ case KEY_dump:
+ LOOPX(OP_DUMP);
+
+ case KEY_else:
+ PREBLOCK(ELSE);
+
+ case KEY_elsif:
+ yylval.ival = curcop->cop_line;
+ OPERATOR(ELSIF);
+
+ case KEY_eq:
+ Eop(OP_SEQ);
+
+ case KEY_exit:
+ UNI(OP_EXIT);
+
+ case KEY_eval:
+ allgvs = TRUE; /* must initialize everything since */
+ s = skipspace(s);
+ expect = (*s == '{') ? XBLOCK : XTERM;
+ UNIBRACK(OP_ENTEREVAL); /* we don't know what will be used */
+
+ case KEY_eof:
+ UNI(OP_EOF);
+
+ case KEY_exp:
+ UNI(OP_EXP);
+
+ case KEY_each:
+ UNI(OP_EACH);
+
+ case KEY_exec:
+ set_csh();
+ LOP(OP_EXEC);
+
+ case KEY_endhostent:
+ FUN0(OP_EHOSTENT);
+
+ case KEY_endnetent:
+ FUN0(OP_ENETENT);
+
+ case KEY_endservent:
+ FUN0(OP_ESERVENT);
+
+ case KEY_endprotoent:
+ FUN0(OP_EPROTOENT);
+
+ case KEY_endpwent:
+ FUN0(OP_EPWENT);
+
+ case KEY_endgrent:
+ FUN0(OP_EGRENT);
+
+ case KEY_for:
+ case KEY_foreach:
+ yylval.ival = curcop->cop_line;
+ while (s < bufend && isSPACE(*s))
+ s++;
+ if (isIDFIRST(*s))
+ fatal("Missing $ on loop variable");
+ OPERATOR(FOR);
+
+ case KEY_formline:
+ LOP(OP_FORMLINE);
+
+ case KEY_fork:
+ FUN0(OP_FORK);
+
+ case KEY_fcntl:
+ LOP(OP_FCNTL);
+
+ case KEY_fileno:
+ UNI(OP_FILENO);
+
+ case KEY_flock:
+ LOP(OP_FLOCK);
+
+ case KEY_gt:
+ Rop(OP_SGT);
+
+ case KEY_ge:
+ Rop(OP_SGE);
+
+ case KEY_grep:
+ LOP(OP_GREPSTART);
+
+ case KEY_goto:
+ LOOPX(OP_GOTO);
+
+ case KEY_gmtime:
+ UNI(OP_GMTIME);
+
+ case KEY_getc:
+ UNI(OP_GETC);
+
+ case KEY_getppid:
+ FUN0(OP_GETPPID);
+
+ case KEY_getpgrp:
+ UNI(OP_GETPGRP);
+
+ case KEY_getpriority:
+ LOP(OP_GETPRIORITY);
+
+ case KEY_getprotobyname:
+ UNI(OP_GPBYNAME);
+
+ case KEY_getprotobynumber:
+ LOP(OP_GPBYNUMBER);
+
+ case KEY_getprotoent:
+ FUN0(OP_GPROTOENT);
+
+ case KEY_getpwent:
+ FUN0(OP_GPWENT);
+
+ case KEY_getpwnam:
+ FUN1(OP_GPWNAM);
+
+ case KEY_getpwuid:
+ FUN1(OP_GPWUID);
+
+ case KEY_getpeername:
+ UNI(OP_GETPEERNAME);
+
+ case KEY_gethostbyname:
+ UNI(OP_GHBYNAME);
+
+ case KEY_gethostbyaddr:
+ LOP(OP_GHBYADDR);
+
+ case KEY_gethostent:
+ FUN0(OP_GHOSTENT);
+
+ case KEY_getnetbyname:
+ UNI(OP_GNBYNAME);
+
+ case KEY_getnetbyaddr:
+ LOP(OP_GNBYADDR);
+
+ case KEY_getnetent:
+ FUN0(OP_GNETENT);
+
+ case KEY_getservbyname:
+ LOP(OP_GSBYNAME);
+
+ case KEY_getservbyport:
+ LOP(OP_GSBYPORT);
+
+ case KEY_getservent:
+ FUN0(OP_GSERVENT);
+
+ case KEY_getsockname:
+ UNI(OP_GETSOCKNAME);
+
+ case KEY_getsockopt:
+ LOP(OP_GSOCKOPT);
+
+ case KEY_getgrent:
+ FUN0(OP_GGRENT);
+
+ case KEY_getgrnam:
+ FUN1(OP_GGRNAM);
+
+ case KEY_getgrgid:
+ FUN1(OP_GGRGID);
+
+ case KEY_getlogin:
+ FUN0(OP_GETLOGIN);
+
+ case KEY_hex:
+ UNI(OP_HEX);
+
+ case KEY_if:
+ yylval.ival = curcop->cop_line;
+ OPERATOR(IF);
+
+ case KEY_index:
+ LOP(OP_INDEX);
+
+ case KEY_int:
+ UNI(OP_INT);
+
+ case KEY_ioctl:
+ LOP(OP_IOCTL);
+
+ case KEY_join:
+ LOP(OP_JOIN);
+
+ case KEY_keys:
+ UNI(OP_KEYS);
+
+ case KEY_kill:
+ LOP(OP_KILL);
+
+ case KEY_last:
+ LOOPX(OP_LAST);
+
+ case KEY_lc:
+ UNI(OP_LC);
+
+ case KEY_lcfirst:
+ UNI(OP_LCFIRST);
+
+ case KEY_local:
+ OPERATOR(LOCAL);
+
+ case KEY_length:
+ UNI(OP_LENGTH);
+
+ case KEY_lt:
+ Rop(OP_SLT);
+
+ case KEY_le:
+ Rop(OP_SLE);
+
+ case KEY_localtime:
+ UNI(OP_LOCALTIME);
+
+ case KEY_log:
+ UNI(OP_LOG);
+
+ case KEY_link:
+ LOP(OP_LINK);
+
+ case KEY_listen:
+ LOP(OP_LISTEN);
+
+ case KEY_lstat:
+ UNI(OP_LSTAT);
+
+ case KEY_m:
+ s = scan_pat(s);
+ TERM(sublex_start());
+
+ case KEY_mkdir:
+ LOP(OP_MKDIR);
+
+ case KEY_msgctl:
+ LOP(OP_MSGCTL);
+
+ case KEY_msgget:
+ LOP(OP_MSGGET);
+
+ case KEY_msgrcv:
+ LOP(OP_MSGRCV);
+
+ case KEY_msgsnd:
+ LOP(OP_MSGSND);
+
+ case KEY_next:
+ LOOPX(OP_NEXT);
+
+ case KEY_ne:
+ Eop(OP_SNE);
+
+ case KEY_open:
+ LOP(OP_OPEN);
+
+ case KEY_ord:
+ UNI(OP_ORD);
+
+ case KEY_oct:
+ UNI(OP_OCT);
+
+ case KEY_opendir:
+ LOP(OP_OPEN_DIR);
+
+ case KEY_print:
+ checkcomma(s,tokenbuf,"filehandle");
+ LOP(OP_PRINT);
+
+ case KEY_printf:
+ checkcomma(s,tokenbuf,"filehandle");
+ LOP(OP_PRTF);
+
+ case KEY_push:
+ LOP(OP_PUSH);
+
+ case KEY_pop:
+ UNI(OP_POP);
+
+ case KEY_pack:
+ LOP(OP_PACK);
+
+ case KEY_package:
+ s = force_word(s,WORD);
+ OPERATOR(PACKAGE);
+
+ case KEY_pipe:
+ LOP(OP_PIPE_OP);
+
+ case KEY_q:
+ s = scan_str(s);
+ if (!s)
+ fatal("EOF in string");
+ yylval.ival = OP_CONST;
+ TERM(sublex_start());
+
+ case KEY_qq:
+ s = scan_str(s);
+ if (!s)
+ fatal("EOF in string");
+ yylval.ival = OP_SCALAR;
+ if (SvSTORAGE(lex_stuff) == '\'')
+ SvSTORAGE(lex_stuff) = 0; /* qq'$foo' should intepolate */
+ TERM(sublex_start());
+
+ case KEY_qx:
+ s = scan_str(s);
+ if (!s)
+ fatal("EOF in string");
+ yylval.ival = OP_BACKTICK;
+ set_csh();
+ TERM(sublex_start());
+
+ case KEY_return:
+ OLDLOP(OP_RETURN);
+
+ case KEY_require:
+ allgvs = TRUE; /* must initialize everything since */
+ UNI(OP_REQUIRE); /* we don't know what will be used */
+
+ case KEY_reset:
+ UNI(OP_RESET);
+
+ case KEY_redo:
+ LOOPX(OP_REDO);
+
+ case KEY_rename:
+ LOP(OP_RENAME);
+
+ case KEY_rand:
+ UNI(OP_RAND);
+
+ case KEY_rmdir:
+ UNI(OP_RMDIR);
+
+ case KEY_rindex:
+ LOP(OP_RINDEX);
+
+ case KEY_read:
+ LOP(OP_READ);
+
+ case KEY_readdir:
+ UNI(OP_READDIR);
+
+ case KEY_rewinddir:
+ UNI(OP_REWINDDIR);
+
+ case KEY_recv:
+ LOP(OP_RECV);
+
+ case KEY_reverse:
+ LOP(OP_REVERSE);
+
+ case KEY_readlink:
+ UNI(OP_READLINK);
+
+ case KEY_ref:
+ UNI(OP_REF);
+
+ case KEY_s:
+ s = scan_subst(s);
+ if (yylval.opval)
+ TERM(sublex_start());
+ else
+ TOKEN(1); /* force error */
+
+ case KEY_scalar:
+ UNI(OP_SCALAR);
+
+ case KEY_select:
+ LOP(OP_SELECT);
+
+ case KEY_seek:
+ LOP(OP_SEEK);
+
+ case KEY_semctl:
+ LOP(OP_SEMCTL);
+
+ case KEY_semget:
+ LOP(OP_SEMGET);
+
+ case KEY_semop:
+ LOP(OP_SEMOP);
+
+ case KEY_send:
+ LOP(OP_SEND);
+
+ case KEY_setpgrp:
+ LOP(OP_SETPGRP);
+
+ case KEY_setpriority:
+ LOP(OP_SETPRIORITY);
+
+ case KEY_sethostent:
+ FUN1(OP_SHOSTENT);
+
+ case KEY_setnetent:
+ FUN1(OP_SNETENT);
+
+ case KEY_setservent:
+ FUN1(OP_SSERVENT);
+
+ case KEY_setprotoent:
+ FUN1(OP_SPROTOENT);
+
+ case KEY_setpwent:
+ FUN0(OP_SPWENT);
+
+ case KEY_setgrent:
+ FUN0(OP_SGRENT);
+
+ case KEY_seekdir:
+ LOP(OP_SEEKDIR);
+
+ case KEY_setsockopt:
+ LOP(OP_SSOCKOPT);
+
+ case KEY_shift:
+ UNI(OP_SHIFT);
+
+ case KEY_shmctl:
+ LOP(OP_SHMCTL);
+
+ case KEY_shmget:
+ LOP(OP_SHMGET);
+
+ case KEY_shmread:
+ LOP(OP_SHMREAD);
+
+ case KEY_shmwrite:
+ LOP(OP_SHMWRITE);
+
+ case KEY_shutdown:
+ LOP(OP_SHUTDOWN);
+
+ case KEY_sin:
+ UNI(OP_SIN);
+
+ case KEY_sleep:
+ UNI(OP_SLEEP);
+
+ case KEY_socket:
+ LOP(OP_SOCKET);
+
+ case KEY_socketpair:
+ LOP(OP_SOCKPAIR);
+
+ case KEY_sort:
+ checkcomma(s,tokenbuf,"subroutine name");
+ s = skipspace(s);
+ if (*s == ';' || *s == ')') /* probably a close */
+ fatal("sort is now a reserved word");
+ if (isIDFIRST(*s)) {
+ /*SUPPRESS 530*/
+ for (d = s; isALNUM(*d); d++) ;
+ strncpy(tokenbuf,s,d-s);
+ tokenbuf[d-s] = '\0';
+ if (!keyword(tokenbuf, d - s) || strEQ(tokenbuf,"reverse"))
+ s = force_word(s,WORD);
+ }
+ LOP(OP_SORT);
+
+ case KEY_split:
+ LOP(OP_SPLIT);
+
+ case KEY_sprintf:
+ LOP(OP_SPRINTF);
+
+ case KEY_splice:
+ LOP(OP_SPLICE);
+
+ case KEY_sqrt:
+ UNI(OP_SQRT);
+
+ case KEY_srand:
+ UNI(OP_SRAND);
+
+ case KEY_stat:
+ UNI(OP_STAT);
+
+ case KEY_study:
+ sawstudy++;
+ UNI(OP_STUDY);
+
+ case KEY_substr:
+ LOP(OP_SUBSTR);
+
+ case KEY_format:
+ case KEY_sub:
+ yylval.ival = savestack_ix; /* restore stuff on reduce */
+ save_I32(&subline);
+ save_item(subname);
+ SAVEINT(padix);
+ SAVESPTR(curpad);
+ SAVESPTR(comppad);
+ comppad = newAV();
+ av_push(comppad, Nullsv);
+ curpad = AvARRAY(comppad);
+ padix = 0;
+
+ subline = curcop->cop_line;
+ s = skipspace(s);
+ if (isIDFIRST(*s) || *s == '\'') {
+ sv_setsv(subname,curstname);
+ sv_catpvn(subname,"'",1);
+ for (d = s+1; isALNUM(*d) || *d == '\''; d++)
+ /*SUPPRESS 530*/
+ ;
+ if (d[-1] == '\'')
+ d--;
+ sv_catpvn(subname,s,d-s);
+ s = force_word(s,WORD);
+ }
+ else
+ sv_setpv(subname,"?");
+
+ if (tmp == KEY_sub)
+ PREBLOCK(SUB);
+
+ in_format = 2;
+ lex_brackets = 0;
+ OPERATOR(FORMAT);
+
+ case KEY_system:
+ set_csh();
+ LOP(OP_SYSTEM);
+
+ case KEY_symlink:
+ LOP(OP_SYMLINK);
+
+ case KEY_syscall:
+ LOP(OP_SYSCALL);
+
+ case KEY_sysread:
+ LOP(OP_SYSREAD);
+
+ case KEY_syswrite:
+ LOP(OP_SYSWRITE);
+
+ case KEY_tr:
+ s = scan_trans(s);
+ TERM(sublex_start());
+
+ case KEY_tell:
+ UNI(OP_TELL);
+
+ case KEY_telldir:
+ UNI(OP_TELLDIR);
+
+ case KEY_time:
+ FUN0(OP_TIME);
+
+ case KEY_times:
+ FUN0(OP_TMS);
+
+ case KEY_truncate:
+ LOP(OP_TRUNCATE);
+
+ case KEY_uc:
+ UNI(OP_UC);
+
+ case KEY_ucfirst:
+ UNI(OP_UCFIRST);
+
+ case KEY_until:
+ yylval.ival = curcop->cop_line;
+ OPERATOR(UNTIL);
+
+ case KEY_unless:
+ yylval.ival = curcop->cop_line;
+ OPERATOR(UNLESS);
+
+ case KEY_unlink:
+ LOP(OP_UNLINK);
+
+ case KEY_undef:
+ UNI(OP_UNDEF);
+
+ case KEY_unpack:
+ LOP(OP_UNPACK);
+
+ case KEY_utime:
+ LOP(OP_UTIME);
+
+ case KEY_umask:
+ UNI(OP_UMASK);
+
+ case KEY_unshift:
+ LOP(OP_UNSHIFT);
+
+ case KEY_values:
+ UNI(OP_VALUES);
+
+ case KEY_vec:
+ sawvec = TRUE;
+ LOP(OP_VEC);
+
+ case KEY_while:
+ yylval.ival = curcop->cop_line;
+ OPERATOR(WHILE);
+
+ case KEY_warn:
+ LOP(OP_WARN);
+
+ case KEY_wait:
+ FUN0(OP_WAIT);
+
+ case KEY_waitpid:
+ LOP(OP_WAITPID);
+
+ case KEY_wantarray:
+ FUN0(OP_WANTARRAY);
+
+ case KEY_write:
+ UNI(OP_ENTERWRITE);
+
+ case KEY_x:
+ if (expect == XOPERATOR)
+ Mop(OP_REPEAT);
+ check_uni();
+ goto just_a_word;
+
+ case KEY_y:
+ s = scan_trans(s);
+ TERM(sublex_start());
+ }
+ }
+}
+
+I32
+keyword(d, len)
+register char *d;
+I32 len;
+{
+ switch (*d) {
+ case '_':
+ if (d[1] == '_') {
+ if (strEQ(d,"__LINE__")) return KEY___LINE__;
+ if (strEQ(d,"__FILE__")) return KEY___FILE__;
+ if (strEQ(d,"__END__")) return KEY___END__;
+ }
+ break;
+ case 'a':
+ if (strEQ(d,"alarm")) return KEY_alarm;
+ if (strEQ(d,"accept")) return KEY_accept;
+ if (strEQ(d,"atan2")) return KEY_atan2;
+ break;
+ case 'B':
+ if (strEQ(d,"BEGIN")) return KEY_BEGIN;
+ case 'b':
+ if (strEQ(d,"bless")) return KEY_bless;
+ if (strEQ(d,"bind")) return KEY_bind;
+ if (strEQ(d,"binmode")) return KEY_binmode;
+ break;
+ case 'c':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"cmp")) return KEY_cmp;
+ if (strEQ(d,"cos")) return KEY_cos;
+ break;
+ case 4:
+ if (strEQ(d,"chop")) return KEY_chop;
+ break;
+ case 5:
+ if (strEQ(d,"close")) return KEY_close;
+ if (strEQ(d,"chdir")) return KEY_chdir;
+ if (strEQ(d,"chmod")) return KEY_chmod;
+ if (strEQ(d,"chown")) return KEY_chown;
+ if (strEQ(d,"crypt")) return KEY_crypt;
+ break;
+ case 6:
+ if (strEQ(d,"chroot")) return KEY_chroot;
+ if (strEQ(d,"caller")) return KEY_caller;
+ break;
+ case 7:
+ if (strEQ(d,"connect")) return KEY_connect;
+ break;
+ case 8:
+ if (strEQ(d,"closedir")) return KEY_closedir;
+ if (strEQ(d,"continue")) return KEY_continue;
+ break;
+ }
+ break;
+ case 'd':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"do")) return KEY_do;
+ break;
+ case 3:
+ if (strEQ(d,"die")) return KEY_die;
+ break;
+ case 4:
+ if (strEQ(d,"dump")) return KEY_dump;
+ break;
+ case 6:
+ if (strEQ(d,"delete")) return KEY_delete;
+ break;
+ case 7:
+ if (strEQ(d,"defined")) return KEY_defined;
+ if (strEQ(d,"dbmopen")) return KEY_dbmopen;
+ break;
+ case 8:
+ if (strEQ(d,"dbmclose")) return KEY_dbmclose;
+ break;
+ }
+ break;
+ case 'E':
+ if (strEQ(d,"EQ")) return KEY_eq;
+ if (strEQ(d,"END")) return KEY_END;
+ break;
+ case 'e':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"eq")) return KEY_eq;
+ break;
+ case 3:
+ if (strEQ(d,"eof")) return KEY_eof;
+ if (strEQ(d,"exp")) return KEY_exp;
+ break;
+ case 4:
+ if (strEQ(d,"else")) return KEY_else;
+ if (strEQ(d,"exit")) return KEY_exit;
+ if (strEQ(d,"eval")) return KEY_eval;
+ if (strEQ(d,"exec")) return KEY_exec;
+ if (strEQ(d,"each")) return KEY_each;
+ break;
+ case 5:
+ if (strEQ(d,"elsif")) return KEY_elsif;
+ break;
+ case 8:
+ if (strEQ(d,"endgrent")) return KEY_endgrent;
+ if (strEQ(d,"endpwent")) return KEY_endpwent;
+ break;
+ case 9:
+ if (strEQ(d,"endnetent")) return KEY_endnetent;
+ break;
+ case 10:
+ if (strEQ(d,"endhostent")) return KEY_endhostent;
+ if (strEQ(d,"endservent")) return KEY_endservent;
+ break;
+ case 11:
+ if (strEQ(d,"endprotoent")) return KEY_endprotoent;
+ break;
}
- 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 = curcmd->c_line;
- OPERATOR(ELSIF);
+ case 'f':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"for")) return KEY_for;
+ break;
+ case 4:
+ if (strEQ(d,"fork")) return KEY_fork;
+ break;
+ case 5:
+ if (strEQ(d,"fcntl")) return KEY_fcntl;
+ if (strEQ(d,"flock")) return KEY_flock;
+ break;
+ case 6:
+ if (strEQ(d,"format")) return KEY_format;
+ if (strEQ(d,"fileno")) return KEY_fileno;
+ break;
+ case 7:
+ if (strEQ(d,"foreach")) return KEY_foreach;
+ break;
+ case 8:
+ if (strEQ(d,"formline")) return KEY_formline;
+ break;
}
- 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_OP);
- }
- 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 = curcmd->c_line;
- while (s < bufend && isSPACE(*s))
- s++;
- if (isALPHA(*s))
- fatal("Missing $ on loop variable");
- OPERATOR(FOR);
+ case 'G':
+ if (len == 2) {
+ if (strEQ(d,"GT")) return KEY_gt;
+ if (strEQ(d,"GE")) return KEY_ge;
}
- 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);
+ case 'g':
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);
+ switch (len) {
+ case 7:
+ if (strEQ(d,"ppid")) return KEY_getppid;
+ if (strEQ(d,"pgrp")) return KEY_getpgrp;
+ break;
+ case 8:
+ if (strEQ(d,"pwent")) return KEY_getpwent;
+ if (strEQ(d,"pwnam")) return KEY_getpwnam;
+ if (strEQ(d,"pwuid")) return KEY_getpwuid;
+ break;
+ case 11:
+ if (strEQ(d,"peername")) return KEY_getpeername;
+ if (strEQ(d,"protoent")) return KEY_getprotoent;
+ if (strEQ(d,"priority")) return KEY_getpriority;
+ break;
+ case 14:
+ if (strEQ(d,"protobyname")) return KEY_getprotobyname;
+ break;
+ case 16:
+ if (strEQ(d,"protobynumber"))return KEY_getprotobynumber;
+ break;
+ }
}
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);
+ if (strEQ(d,"hostbyname")) return KEY_gethostbyname;
+ if (strEQ(d,"hostbyaddr")) return KEY_gethostbyaddr;
+ if (strEQ(d,"hostent")) return KEY_gethostent;
}
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);
+ if (strEQ(d,"netbyname")) return KEY_getnetbyname;
+ if (strEQ(d,"netbyaddr")) return KEY_getnetbyaddr;
+ if (strEQ(d,"netent")) return KEY_getnetent;
}
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);
+ if (strEQ(d,"servbyname")) return KEY_getservbyname;
+ if (strEQ(d,"servbyport")) return KEY_getservbyport;
+ if (strEQ(d,"servent")) return KEY_getservent;
+ if (strEQ(d,"sockname")) return KEY_getsockname;
+ if (strEQ(d,"sockopt")) return KEY_getsockopt;
}
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);
+ if (strEQ(d,"grent")) return KEY_getgrent;
+ if (strEQ(d,"grnam")) return KEY_getgrnam;
+ if (strEQ(d,"grgid")) return KEY_getgrgid;
}
else if (*d == 'l') {
- if (strEQ(d,"login"))
- FUN0(O_GETLOGIN);
+ if (strEQ(d,"login")) return KEY_getlogin;
}
- d -= 3;
+ break;
}
- 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 = curcmd->c_line;
- OPERATOR(IF);
+ switch (len) {
+ case 2:
+ if (strEQ(d,"gt")) return KEY_gt;
+ if (strEQ(d,"ge")) return KEY_ge;
+ break;
+ case 4:
+ if (strEQ(d,"grep")) return KEY_grep;
+ if (strEQ(d,"goto")) return KEY_goto;
+ if (strEQ(d,"getc")) return KEY_getc;
+ break;
+ case 6:
+ if (strEQ(d,"gmtime")) return KEY_gmtime;
+ break;
}
- if (strEQ(d,"index"))
- FUN2x(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);
+ case 'h':
+ if (strEQ(d,"hex")) return KEY_hex;
break;
- case 'k': case 'K':
- SNARFWORD;
- if (strEQ(d,"keys"))
- HFUN(O_KEYS);
- if (strEQ(d,"kill"))
- LOP(O_KILL);
+ case 'i':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"if")) return KEY_if;
+ break;
+ case 3:
+ if (strEQ(d,"int")) return KEY_int;
+ break;
+ case 5:
+ if (strEQ(d,"index")) return KEY_index;
+ if (strEQ(d,"ioctl")) return KEY_ioctl;
+ break;
+ }
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);
+ case 'j':
+ if (strEQ(d,"join")) return KEY_join;
break;
- case 'm': case 'M':
- if (s[1] == '\'') {
- d = "m";
- s++;
- }
- else {
- SNARFWORD;
+ case 'k':
+ if (len == 4) {
+ if (strEQ(d,"keys")) return KEY_keys;
+ if (strEQ(d,"kill")) return KEY_kill;
}
- if (strEQ(d,"m")) {
- s = scanpat(s-1);
- if (yylval.arg)
- TERM(PATTERN);
- else
- RETURN(1); /* force error */
+ break;
+ case 'L':
+ if (len == 2) {
+ if (strEQ(d,"LT")) return KEY_lt;
+ if (strEQ(d,"LE")) return KEY_le;
}
- switch (d[1]) {
- case 'k':
- if (strEQ(d,"mkdir"))
- FUN2(O_MKDIR);
+ break;
+ case 'l':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"lt")) return KEY_lt;
+ if (strEQ(d,"le")) return KEY_le;
+ if (strEQ(d,"lc")) return KEY_lc;
+ break;
+ case 3:
+ if (strEQ(d,"log")) return KEY_log;
+ break;
+ case 4:
+ if (strEQ(d,"last")) return KEY_last;
+ if (strEQ(d,"link")) return KEY_link;
break;
- case 's':
- if (strEQ(d,"msgctl"))
- FUN3(O_MSGCTL);
- if (strEQ(d,"msgget"))
- FUN2(O_MSGGET);
- if (strEQ(d,"msgrcv"))
- FUN5(O_MSGRCV);
- if (strEQ(d,"msgsnd"))
- FUN3(O_MSGSND);
+ case 5:
+ if (strEQ(d,"local")) return KEY_local;
+ if (strEQ(d,"lstat")) return KEY_lstat;
+ break;
+ case 6:
+ if (strEQ(d,"length")) return KEY_length;
+ if (strEQ(d,"listen")) return KEY_listen;
+ break;
+ case 7:
+ if (strEQ(d,"lcfirst")) return KEY_lcfirst;
+ break;
+ case 9:
+ if (strEQ(d,"localtime")) return KEY_localtime;
break;
}
break;
- case 'n': case 'N':
- SNARFWORD;
- if (strEQ(d,"next"))
- LOOPX(O_NEXT);
- if (strEQ(d,"ne") || strEQ(d,"NE"))
- EOP(O_SNE);
+ case 'm':
+ switch (len) {
+ case 1: return KEY_m;
+ case 5:
+ if (strEQ(d,"mkdir")) return KEY_mkdir;
+ break;
+ case 6:
+ if (strEQ(d,"msgctl")) return KEY_msgctl;
+ if (strEQ(d,"msgget")) return KEY_msgget;
+ if (strEQ(d,"msgrcv")) return KEY_msgrcv;
+ if (strEQ(d,"msgsnd")) return KEY_msgsnd;
+ break;
+ }
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_OPEN_DIR);
+ case 'N':
+ if (strEQ(d,"NE")) return KEY_ne;
break;
- case 'p': case 'P':
- SNARFWORD;
- if (strEQ(d,"print")) {
- checkcomma(s,d,"filehandle");
- LOP(O_PRINT);
- }
- if (strEQ(d,"printf")) {
- checkcomma(s,d,"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_OP);
+ case 'n':
+ if (strEQ(d,"next")) return KEY_next;
+ if (strEQ(d,"ne")) return KEY_ne;
break;
- case 'q': case 'Q':
- SNARFWORD;
- if (strEQ(d,"q")) {
- s = scanstr(s-1, SCAN_DEF);
- TERM(RSTRING);
- }
- if (strEQ(d,"qq")) {
- s = scanstr(s-2, SCAN_DEF);
- TERM(RSTRING);
- }
- if (strEQ(d,"qx")) {
- s = scanstr(s-2, SCAN_DEF);
- TERM(RSTRING);
+ case 'o':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"ord")) return KEY_ord;
+ if (strEQ(d,"oct")) return KEY_oct;
+ break;
+ case 4:
+ if (strEQ(d,"open")) return KEY_open;
+ break;
+ case 7:
+ if (strEQ(d,"opendir")) return KEY_opendir;
+ break;
}
break;
- case 'r': case 'R':
- SNARFWORD;
- if (strEQ(d,"return"))
- OLDLOP(O_RETURN);
- if (strEQ(d,"require")) {
- allstabs = TRUE; /* must initialize everything since */
- UNI(O_REQUIRE); /* we don't know what will be used */
- }
- 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"))
- FUN2x(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++;
+ case 'p':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"pop")) return KEY_pop;
+ break;
+ case 4:
+ if (strEQ(d,"push")) return KEY_push;
+ if (strEQ(d,"pack")) return KEY_pack;
+ if (strEQ(d,"pipe")) return KEY_pipe;
+ break;
+ case 5:
+ if (strEQ(d,"print")) return KEY_print;
+ break;
+ case 6:
+ if (strEQ(d,"printf")) return KEY_printf;
+ break;
+ case 7:
+ if (strEQ(d,"package")) return KEY_package;
+ break;
}
- else {
- SNARFWORD;
+ break;
+ case 'q':
+ if (len <= 2) {
+ if (strEQ(d,"q")) return KEY_q;
+ if (strEQ(d,"qq")) return KEY_qq;
+ if (strEQ(d,"qx")) return KEY_qx;
}
- if (strEQ(d,"s")) {
- s = scansubst(s);
- if (yylval.arg)
- TERM(SUBST);
- else
- RETURN(1); /* force error */
+ break;
+ case 'r':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"ref")) return KEY_ref;
+ break;
+ case 4:
+ if (strEQ(d,"read")) return KEY_read;
+ if (strEQ(d,"rand")) return KEY_rand;
+ if (strEQ(d,"recv")) return KEY_recv;
+ if (strEQ(d,"redo")) return KEY_redo;
+ break;
+ case 5:
+ if (strEQ(d,"rmdir")) return KEY_rmdir;
+ if (strEQ(d,"reset")) return KEY_reset;
+ break;
+ case 6:
+ if (strEQ(d,"return")) return KEY_return;
+ if (strEQ(d,"rename")) return KEY_rename;
+ if (strEQ(d,"rindex")) return KEY_rindex;
+ break;
+ case 7:
+ if (strEQ(d,"require")) return KEY_require;
+ if (strEQ(d,"reverse")) return KEY_reverse;
+ if (strEQ(d,"readdir")) return KEY_readdir;
+ break;
+ case 8:
+ if (strEQ(d,"readlink")) return KEY_readlink;
+ break;
+ case 9:
+ if (strEQ(d,"rewinddir")) return KEY_rewinddir;
+ break;
}
+ break;
+ case 's':
switch (d[1]) {
- case 'a':
- case 'b':
- break;
+ case 0: return KEY_s;
case 'c':
- if (strEQ(d,"scalar"))
- UNI(O_SCALAR);
- break;
- case 'd':
+ if (strEQ(d,"scalar")) return KEY_scalar;
break;
case 'e':
- if (strEQ(d,"select"))
- OPERATOR(SSELECT);
- if (strEQ(d,"seek"))
- FOP3(O_SEEK);
- if (strEQ(d,"semctl"))
- FUN4(O_SEMCTL);
- if (strEQ(d,"semget"))
- FUN3(O_SEMGET);
- if (strEQ(d,"semop"))
- FUN2(O_SEMOP);
- 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':
+ switch (len) {
+ case 4:
+ if (strEQ(d,"seek")) return KEY_seek;
+ if (strEQ(d,"send")) return KEY_send;
+ break;
+ case 5:
+ if (strEQ(d,"semop")) return KEY_semop;
+ break;
+ case 6:
+ if (strEQ(d,"select")) return KEY_select;
+ if (strEQ(d,"semctl")) return KEY_semctl;
+ if (strEQ(d,"semget")) return KEY_semget;
+ break;
+ case 7:
+ if (strEQ(d,"setpgrp")) return KEY_setpgrp;
+ if (strEQ(d,"seekdir")) return KEY_seekdir;
+ break;
+ case 8:
+ if (strEQ(d,"setpwent")) return KEY_setpwent;
+ if (strEQ(d,"setgrent")) return KEY_setgrent;
+ break;
+ case 9:
+ if (strEQ(d,"setnetent")) return KEY_setnetent;
+ break;
+ case 10:
+ if (strEQ(d,"setsockopt")) return KEY_setsockopt;
+ if (strEQ(d,"sethostent")) return KEY_sethostent;
+ if (strEQ(d,"setservent")) return KEY_setservent;
+ break;
+ case 11:
+ if (strEQ(d,"setpriority")) return KEY_setpriority;
+ if (strEQ(d,"setprotoent")) return KEY_setprotoent;
+ break;
+ }
break;
case 'h':
- if (strEQ(d,"shift"))
- TERM(SHIFT);
- if (strEQ(d,"shmctl"))
- FUN3(O_SHMCTL);
- if (strEQ(d,"shmget"))
- FUN3(O_SHMGET);
- if (strEQ(d,"shmread"))
- FUN4(O_SHMREAD);
- if (strEQ(d,"shmwrite"))
- FUN4(O_SHMWRITE);
- if (strEQ(d,"shutdown"))
- FOP2(O_SHUTDOWN);
+ switch (len) {
+ case 5:
+ if (strEQ(d,"shift")) return KEY_shift;
+ break;
+ case 6:
+ if (strEQ(d,"shmctl")) return KEY_shmctl;
+ if (strEQ(d,"shmget")) return KEY_shmget;
+ break;
+ case 7:
+ if (strEQ(d,"shmread")) return KEY_shmread;
+ break;
+ case 8:
+ if (strEQ(d,"shmwrite")) return KEY_shmwrite;
+ if (strEQ(d,"shutdown")) return KEY_shutdown;
+ break;
+ }
break;
case 'i':
- if (strEQ(d,"sin"))
- UNI(O_SIN);
- break;
- case 'j':
- case 'k':
+ if (strEQ(d,"sin")) return KEY_sin;
break;
case 'l':
- if (strEQ(d,"sleep"))
- UNI(O_SLEEP);
- break;
- case 'm':
- case 'n':
+ if (strEQ(d,"sleep")) return KEY_sleep;
break;
case 'o':
- if (strEQ(d,"socket"))
- FOP4(O_SOCKET);
- if (strEQ(d,"socketpair"))
- FOP25(O_SOCKPAIR);
- if (strEQ(d,"sort")) {
- checkcomma(s,d,"subroutine name");
- d = bufend;
- while (s < d && isSPACE(*s)) s++;
- if (*s == ';' || *s == ')') /* probably a close */
- fatal("sort is now a reserved word");
- if (isALPHA(*s) || *s == '_') {
- /*SUPPRESS 530*/
- for (d = s; isALNUM(*d); d++) ;
- strncpy(tokenbuf,s,d-s);
- tokenbuf[d-s] = '\0';
- if (strNE(tokenbuf,"keys") &&
- strNE(tokenbuf,"values") &&
- strNE(tokenbuf,"split") &&
- strNE(tokenbuf,"grep") &&
- strNE(tokenbuf,"readdir") &&
- strNE(tokenbuf,"unpack") &&
- strNE(tokenbuf,"do") &&
- strNE(tokenbuf,"eval") &&
- (d >= bufend || isSPACE(*d)) )
- *(--s) = '\\'; /* force next ident to WORD */
- }
- LOP(O_SORT);
- }
+ if (strEQ(d,"sort")) return KEY_sort;
+ if (strEQ(d,"socket")) return KEY_socket;
+ if (strEQ(d,"socketpair")) return KEY_socketpair;
break;
case 'p':
- if (strEQ(d,"split"))
- TERM(SPLIT);
- if (strEQ(d,"sprintf"))
- FL(O_SPRINTF);
- if (strEQ(d,"splice")) {
- yylval.ival = O_SPLICE;
- OPERATOR(PUSH);
- }
+ if (strEQ(d,"split")) return KEY_split;
+ if (strEQ(d,"sprintf")) return KEY_sprintf;
+ if (strEQ(d,"splice")) return KEY_splice;
break;
case 'q':
- if (strEQ(d,"sqrt"))
- UNI(O_SQRT);
+ if (strEQ(d,"sqrt")) return KEY_sqrt;
break;
case 'r':
- if (strEQ(d,"srand"))
- UNI(O_SRAND);
- break;
- case 's':
+ if (strEQ(d,"srand")) return KEY_srand;
break;
case 't':
- if (strEQ(d,"stat"))
- FOP(O_STAT);
- if (strEQ(d,"study")) {
- sawstudy++;
- LFUN(O_STUDY);
- }
+ if (strEQ(d,"stat")) return KEY_stat;
+ if (strEQ(d,"study")) return KEY_study;
break;
case 'u':
- if (strEQ(d,"substr"))
- FUN2x(O_SUBSTR);
- if (strEQ(d,"sub")) {
- yylval.ival = savestack->ary_fill; /* restore stuff on reduce */
- savelong(&subline);
- saveitem(subname);
-
- subline = curcmd->c_line;
- d = bufend;
- while (s < d && isSPACE(*s))
- s++;
- if (isALPHA(*s) || *s == '_' || *s == '\'') {
- str_sset(subname,curstname);
- str_ncat(subname,"'",1);
- for (d = s+1; isALNUM(*d) || *d == '\''; d++)
- /*SUPPRESS 530*/
- ;
- if (d[-1] == '\'')
- d--;
- str_ncat(subname,s,d-s);
- *(--s) = '\\'; /* force next ident to WORD */
- }
- else
- str_set(subname,"?");
- OPERATOR(SUB);
- }
- break;
- case 'v':
- case 'w':
- case 'x':
+ if (strEQ(d,"substr")) return KEY_substr;
+ if (strEQ(d,"sub")) return KEY_sub;
break;
case 'y':
- if (strEQ(d,"system")) {
- set_csh();
- LOP(O_SYSTEM);
+ switch (len) {
+ case 6:
+ if (strEQ(d,"system")) return KEY_system;
+ break;
+ case 7:
+ if (strEQ(d,"sysread")) return KEY_sysread;
+ if (strEQ(d,"symlink")) return KEY_symlink;
+ if (strEQ(d,"syscall")) return KEY_syscall;
+ break;
+ case 8:
+ if (strEQ(d,"syswrite")) return KEY_syswrite;
+ break;
}
- if (strEQ(d,"symlink"))
- FUN2(O_SYMLINK);
- if (strEQ(d,"syscall"))
- LOP(O_SYSCALL);
- if (strEQ(d,"sysread"))
- FOP3(O_SYSREAD);
- if (strEQ(d,"syswrite"))
- FOP3(O_SYSWRITE);
- 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);
- if (strEQ(d,"truncate"))
- FOP2(O_TRUNCATE);
- break;
- case 'u': case 'U':
- SNARFWORD;
- if (strEQ(d,"using"))
- OPERATOR(USING);
- if (strEQ(d,"until")) {
- yylval.ival = curcmd->c_line;
- OPERATOR(UNTIL);
- }
- if (strEQ(d,"unless")) {
- yylval.ival = curcmd->c_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);
+ case 't':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"tr")) return KEY_tr;
+ break;
+ case 4:
+ if (strEQ(d,"tell")) return KEY_tell;
+ if (strEQ(d,"time")) return KEY_time;
+ break;
+ case 5:
+ if (strEQ(d,"times")) return KEY_times;
+ break;
+ case 7:
+ if (strEQ(d,"telldir")) return KEY_telldir;
+ break;
+ case 8:
+ if (strEQ(d,"truncate")) return KEY_truncate;
+ break;
}
break;
- case 'v': case 'V':
- SNARFWORD;
- if (strEQ(d,"values"))
- HFUN(O_VALUES);
- if (strEQ(d,"vec")) {
- sawvec = TRUE;
- FUN3(O_VEC);
+ case 'u':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"uc")) return KEY_uc;
+ break;
+ case 5:
+ if (strEQ(d,"undef")) return KEY_undef;
+ if (strEQ(d,"until")) return KEY_until;
+ if (strEQ(d,"utime")) return KEY_utime;
+ if (strEQ(d,"umask")) return KEY_umask;
+ break;
+ case 6:
+ if (strEQ(d,"unless")) return KEY_unless;
+ if (strEQ(d,"unpack")) return KEY_unpack;
+ if (strEQ(d,"unlink")) return KEY_unlink;
+ break;
+ case 7:
+ if (strEQ(d,"unshift")) return KEY_unshift;
+ if (strEQ(d,"ucfirst")) return KEY_ucfirst;
+ break;
}
break;
- case 'w': case 'W':
- SNARFWORD;
- if (strEQ(d,"while")) {
- yylval.ival = curcmd->c_line;
- OPERATOR(WHILE);
- }
- if (strEQ(d,"warn"))
- LOP(O_WARN);
- if (strEQ(d,"wait"))
- FUN0(O_WAIT);
- if (strEQ(d,"waitpid"))
- FUN2(O_WAITPID);
- 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);
+ case 'v':
+ if (strEQ(d,"values")) return KEY_values;
+ if (strEQ(d,"vec")) return KEY_vec;
break;
- case 'x': case 'X':
- if (*s == 'x' && isDIGIT(s[1]) && !expectterm) {
- s++;
- MOP(O_REPEAT);
- }
- SNARFWORD;
- if (strEQ(d,"x")) {
- if (!expectterm)
- MOP(O_REPEAT);
- check_uni();
+ case 'w':
+ switch (len) {
+ case 4:
+ if (strEQ(d,"warn")) return KEY_warn;
+ if (strEQ(d,"wait")) return KEY_wait;
+ break;
+ case 5:
+ if (strEQ(d,"while")) return KEY_while;
+ if (strEQ(d,"write")) return KEY_write;
+ break;
+ case 7:
+ if (strEQ(d,"waitpid")) return KEY_waitpid;
+ break;
+ case 9:
+ if (strEQ(d,"wantarray")) return KEY_wantarray;
+ break;
}
break;
- case 'y': case 'Y':
- if (s[1] == '\'') {
- d = "y";
- s++;
- }
- else {
- SNARFWORD;
- }
- if (strEQ(d,"y")) {
- s = scantrans(s);
- TERM(TRANS);
- }
+ case 'x':
+ if (len == 1) return KEY_x;
break;
- case 'z': case 'Z':
- SNARFWORD;
+ case 'y':
+ if (len == 1) return KEY_y;
+ break;
+ case 'z':
break;
}
- yylval.cval = savestr(d);
- if (expectterm == 2) { /* special case: start of statement */
- while (isSPACE(*s)) s++;
- if (*s == ':') {
- s++;
- CLINE;
- OPERATOR(LABEL);
- }
- TERM(WORD);
- }
- 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);
+ return 0;
}
void
s++;
while (s < bufend && isSPACE(*s))
s++;
- if (isALPHA(*s) || *s == '_') {
+ if (isIDFIRST(*s)) {
w = s++;
while (isALNUM(*s))
s++;
}
char *
-scanident(s,send,dest)
+scan_ident(s,send,dest,ck_uni)
register char *s;
register char *send;
char *dest;
+I32 ck_uni;
{
register char *d;
- int brackets = 0;
+ char *bracket = 0;
- reparse = Nullch;
+ if (lex_brackets == 0)
+ lex_fakebrack = 0;
s++;
d = dest;
if (isDIGIT(*s)) {
d--,s--;
*d = '\0';
d = dest;
- if (!*d) {
- *d = *s++;
- if (*d == '{' /* } */ ) {
- d = dest;
- brackets++;
- while (s < send && brackets) {
- if (!reparse && (d == dest || (*s && isALNUM(*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) {
+ if (lex_state != LEX_NORMAL)
+ lex_state = LEX_INTERPENDMAYBE;
+ return s;
}
+ if (isSPACE(*s) ||
+ (*s == '$' && (isALPHA(s[1]) || s[1] == '$' || s[1] == '_')))
+ return s;
+ if (*s == '{') {
+ bracket = s;
+ s++;
+ }
+ else if (ck_uni)
+ check_uni();
+ if (s < send);
+ *d = *s++;
+ d[1] = '\0';
if (*d == '^' && (isUPPER(*s) || index("[\\]^_?", *s))) {
-#ifdef DEBUGGING
if (*s == 'D')
debug |= 32768;
-#endif
*d = *s++ ^ 64;
}
+ if (bracket) {
+ if (isALPHA(*d) || *d == '_') {
+ d++;
+ while (isALNUM(*s))
+ *d++ = *s++;
+ *d = '\0';
+ if (*s == '[' || *s == '{') {
+ if (lex_brackets)
+ fatal("Can't use delimiter brackets within expression");
+ lex_fakebrack = TRUE;
+ bracket++;
+ lex_brackets++;
+ return s;
+ }
+ }
+ if (*s == '}') {
+ s++;
+ if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
+ lex_state = LEX_INTERPEND;
+ }
+ else {
+ s = bracket; /* let the parser handle it */
+ *d = '\0';
+ }
+ }
+ else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
+ lex_state = LEX_INTERPEND;
return s;
}
void
-scanconst(spat,string,len)
-SPAT *spat;
+scan_prefix(pm,string,len)
+PMOP *pm;
char *string;
-int len;
+I32 len;
{
- register STR *tmpstr;
+ register SV *tmpstr;
register char *t;
register char *d;
register char *e;
char *origstring = string;
- static char *vert = "|";
if (ninstr(string, string+len, vert, vert+1))
return;
if (*string == '^')
string++, len--;
- tmpstr = Str_new(86,len);
- str_nset(tmpstr,string,len);
- t = str_get(tmpstr);
+ tmpstr = NEWSV(86,len);
+ sv_upgrade(tmpstr, SVt_PVBM);
+ sv_setpvn(tmpstr,string,len);
+ t = SvPVn(tmpstr);
e = t + len;
- tmpstr->str_u.str_useful = 100;
+ BmUSEFUL(tmpstr) = 100;
for (d=t; d < e; ) {
switch (*d) {
case '{':
}
}
if (d == t) {
- str_free(tmpstr);
+ sv_free(tmpstr);
return;
}
*d = '\0';
- tmpstr->str_cur = d - t;
+ SvCUR_set(tmpstr, d - t);
if (d == t+len)
- spat->spat_flags |= SPAT_ALL;
+ pm->op_pmflags |= PMf_ALL;
if (*origstring != '^')
- spat->spat_flags |= SPAT_SCANFIRST;
- spat->spat_short = tmpstr;
- spat->spat_slen = d - t;
+ pm->op_pmflags |= PMf_SCANFIRST;
+ pm->op_pmshort = tmpstr;
+ pm->op_pmslen = d - t;
}
char *
-scanpat(s)
-register char *s;
+scan_pat(start)
+char *start;
{
- register SPAT *spat;
- register char *d;
- register char *e;
- int len;
- SPAT savespat;
- STR *str = Str_new(93,0);
- char delim;
+ PMOP *pm;
+ char *s;
- Newz(801,spat,1,SPAT);
- spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
- curstash->tbl_spatroot = spat;
+ multi_start = curcop->cop_line;
- switch (*s++) {
- case 'm':
- s++;
- break;
- case '/':
- break;
- case '?':
- spat->spat_flags |= SPAT_ONCE;
- break;
- default:
- fatal("panic: scanpat");
+ s = scan_str(start);
+ if (!s) {
+ if (lex_stuff)
+ sv_free(lex_stuff);
+ lex_stuff = Nullsv;
+ fatal("Search pattern not terminated");
}
- s = str_append_till(str,s,bufend,s[-1],patleave);
- if (s >= bufend) {
- str_free(str);
- yyerror("Search pattern not terminated");
- yylval.arg = Nullarg;
- return s;
- }
- delim = *s++;
+ pm = (PMOP*)newPMOP(OP_MATCH, 0);
+ if (*start == '?')
+ pm->op_pmflags |= PMf_ONCE;
+
while (*s == 'i' || *s == 'o' || *s == 'g') {
if (*s == 'i') {
s++;
sawi = TRUE;
- spat->spat_flags |= SPAT_FOLD;
+ pm->op_pmflags |= PMf_FOLD;
}
if (*s == 'o') {
s++;
- spat->spat_flags |= SPAT_KEEP;
+ pm->op_pmflags |= PMf_KEEP;
}
if (*s == 'g') {
s++;
- spat->spat_flags |= SPAT_GLOBAL;
- }
- }
- len = str->str_cur;
- e = str->str_ptr + len;
- if (delim == '\'')
- d = e;
- else
- d = str->str_ptr;
- for (; d < e; d++) {
- if (*d == '\\')
- d++;
- else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') ||
- (*d == '@')) {
- 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_smake(str);
- d = scanident(d,bufend,buf);
- (void)stabent(buf,TRUE); /* make sure it's created */
- for (; d < e; d++) {
- if (*d == '\\')
- d++;
- else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') {
- d = scanident(d,bufend,buf);
- (void)stabent(buf,TRUE);
- }
- else if (*d == '@') {
- d = scanident(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 */
+ pm->op_pmflags |= PMf_GLOBAL;
}
}
- if (spat->spat_flags & SPAT_FOLD)
- StructCopy(spat, &savespat, SPAT);
- scanconst(spat,str->str_ptr,len);
- if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) {
- fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
- spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
- spat->spat_flags & SPAT_FOLD);
- /* 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)
- StructCopy(&savespat, spat, SPAT);
- if (spat->spat_short)
- fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
- spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
- spat->spat_flags & SPAT_FOLD);
- hoistmust(spat);
- }
- got_pat:
- str_free(str);
- yylval.arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
+
+ lex_op = (OP*)pm;
+ yylval.ival = OP_MATCH;
return s;
}
char *
-scansubst(start)
+scan_subst(start)
char *start;
-{
- register char *s = start;
- register SPAT *spat;
- register char *d;
- register char *e;
- int len;
- STR *str = Str_new(93,0);
- char term = *s;
-
- if (term && (d = index("([{< )]}> )]}>",term)))
- term = d[5];
-
- Newz(802,spat,1,SPAT);
- spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
- curstash->tbl_spatroot = spat;
-
- s = str_append_till(str,s+1,bufend,term,patleave);
- if (s >= bufend) {
- str_free(str);
- yyerror("Substitution pattern not terminated");
- yylval.arg = Nullarg;
- return s;
- }
- len = str->str_cur;
- e = str->str_ptr + len;
- for (d = str->str_ptr; d < e; d++) {
- if (*d == '\\')
- d++;
- else if ((*d == '$' && d[1] && d[1] != '|' && /*(*/ d[1] != ')') ||
- *d == '@' ) {
- 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_smake(str);
- d = scanident(d,e,buf);
- (void)stabent(buf,TRUE); /* make sure it's created */
- for (; *d; d++) {
- if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
- d = scanident(d,e,buf);
- (void)stabent(buf,TRUE);
- }
- else if (*d == '@' && d[-1] != '\\') {
- d = scanident(d,e,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 */
- }
- }
- scanconst(spat,str->str_ptr,len);
-get_repl:
- if (term != *start)
- s++;
- s = scanstr(s, SCAN_REPL);
- if (s >= bufend) {
- str_free(str);
- yyerror("Substitution replacement not terminated");
- yylval.arg = Nullarg;
- return s;
+{
+ register char *s = start;
+ register PMOP *pm;
+ I32 es = 0;
+
+ multi_start = curcop->cop_line;
+ yylval.ival = OP_NULL;
+
+ s = scan_str(s);
+
+ if (!s) {
+ if (lex_stuff)
+ sv_free(lex_stuff);
+ lex_stuff = Nullsv;
+ fatal("Substitution pattern not terminated");
}
- spat->spat_repl = yylval.arg;
- 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;
- }
+
+ if (s[-1] == *start)
+ s--;
+
+ s = scan_str(s);
+ if (!s) {
+ if (lex_stuff)
+ sv_free(lex_stuff);
+ lex_stuff = Nullsv;
+ if (lex_repl)
+ sv_free(lex_repl);
+ lex_repl = Nullsv;
+ fatal("Substitution replacement not terminated");
}
- while (*s == 'g' || *s == 'i' || *s == 'e' || *s == 'o') {
- int es = 0;
+ pm = (PMOP*)newPMOP(OP_SUBST, 0);
+ while (*s == 'g' || *s == 'i' || *s == 'e' || *s == 'o') {
if (*s == 'e') {
s++;
es++;
- if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE)
- spat->spat_repl[1].arg_type = A_SINGLE;
- spat->spat_repl = make_op(
- (!es && spat->spat_repl[1].arg_type == A_SINGLE
- ? O_EVALONCE
- : O_EVAL),
- 2,
- spat->spat_repl,
- Nullarg,
- Nullarg);
- spat->spat_flags &= ~SPAT_CONST;
}
if (*s == 'g') {
s++;
- spat->spat_flags |= SPAT_GLOBAL;
+ pm->op_pmflags |= PMf_GLOBAL;
}
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;
- }
+ pm->op_pmflags |= PMf_FOLD;
}
if (*s == 'o') {
s++;
- spat->spat_flags |= SPAT_KEEP;
+ pm->op_pmflags |= PMf_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(str->str_ptr,str->str_ptr+len,
- spat->spat_flags & SPAT_FOLD);
- hoistmust(spat);
+
+ if (es) {
+ SV *repl;
+ pm->op_pmflags |= PMf_EVAL;
+ repl = NEWSV(93,0);
+ while (es-- > 0) {
+ es--;
+ sv_catpvn(repl, "eval ", 5);
+ }
+ sv_catpvn(repl, "{ ", 2);
+ sv_catsv(repl, lex_repl);
+ sv_catpvn(repl, " };", 2);
+ SvCOMPILED_on(repl);
+ sv_free(lex_repl);
+ lex_repl = repl;
}
- yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat);
- str_free(str);
+
+ lex_op = (OP*)pm;
+ yylval.ival = OP_SUBST;
return s;
}
void
-hoistmust(spat)
-register SPAT *spat;
+hoistmust(pm)
+register PMOP *pm;
{
- if (!spat->spat_short && spat->spat_regexp->regstart &&
- (!spat->spat_regexp->regmust || spat->spat_regexp->reganch & ROPT_ANCH)
+ if (!pm->op_pmshort && pm->op_pmregexp->regstart &&
+ (!pm->op_pmregexp->regmust || pm->op_pmregexp->reganch & ROPT_ANCH)
) {
- if (!(spat->spat_regexp->reganch & ROPT_ANCH))
- spat->spat_flags |= SPAT_SCANFIRST;
- else if (spat->spat_flags & SPAT_FOLD)
+ if (!(pm->op_pmregexp->reganch & ROPT_ANCH))
+ pm->op_pmflags |= PMf_SCANFIRST;
+ else if (pm->op_pmflags & PMf_FOLD)
return;
- spat->spat_short = str_smake(spat->spat_regexp->regstart);
+ pm->op_pmshort = sv_ref(pm->op_pmregexp->regstart);
}
- else if (spat->spat_regexp->regmust) {/* is there a better short-circuit? */
- if (spat->spat_short &&
- str_eq(spat->spat_short,spat->spat_regexp->regmust))
+ else if (pm->op_pmregexp->regmust) {/* is there a better short-circuit? */
+ if (pm->op_pmshort &&
+ sv_eq(pm->op_pmshort,pm->op_pmregexp->regmust))
{
- if (spat->spat_flags & SPAT_SCANFIRST) {
- str_free(spat->spat_short);
- spat->spat_short = Nullstr;
+ if (pm->op_pmflags & PMf_SCANFIRST) {
+ sv_free(pm->op_pmshort);
+ pm->op_pmshort = Nullsv;
}
else {
- str_free(spat->spat_regexp->regmust);
- spat->spat_regexp->regmust = Nullstr;
+ sv_free(pm->op_pmregexp->regmust);
+ pm->op_pmregexp->regmust = Nullsv;
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;
+ if (!pm->op_pmshort || /* promote the better string */
+ ((pm->op_pmflags & PMf_SCANFIRST) &&
+ (SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)) )){
+ sv_free(pm->op_pmshort); /* ok if null */
+ pm->op_pmshort = pm->op_pmregexp->regmust;
+ pm->op_pmregexp->regmust = Nullsv;
+ pm->op_pmflags |= PMf_SCANFIRST;
}
}
}
char *
-scantrans(start)
+scan_trans(start)
char *start;
{
register char *s = start;
- ARG *arg =
- l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg));
- STR *tstr;
- STR *rstr;
- register char *t;
- register char *r;
- register short *tbl;
- register int i;
- register int j;
- int tlen, rlen;
- int squash;
- int delete;
- int complement;
-
- New(803,tbl,256,short);
- arg[2].arg_type = A_NULL;
- arg[2].arg_ptr.arg_cval = (char*) tbl;
-
- s = scanstr(s, SCAN_TR);
- if (s >= bufend) {
- yyerror("Translation pattern not terminated");
- yylval.arg = Nullarg;
- return s;
+ OP *op;
+ short *tbl;
+ I32 squash;
+ I32 delete;
+ I32 complement;
+
+ yylval.ival = OP_NULL;
+
+ s = scan_str(s);
+ if (!s) {
+ if (lex_stuff)
+ sv_free(lex_stuff);
+ lex_stuff = Nullsv;
+ fatal("Translation pattern not terminated");
}
- tstr = yylval.arg[1].arg_ptr.arg_str;
- yylval.arg[1].arg_ptr.arg_str = Nullstr;
- arg_free(yylval.arg);
- t = tstr->str_ptr;
- tlen = tstr->str_cur;
-
if (s[-1] == *start)
s--;
- s = scanstr(s, SCAN_TR|SCAN_REPL);
- if (s >= bufend) {
- yyerror("Translation replacement not terminated");
- yylval.arg = Nullarg;
- return s;
+ s = scan_str(s, SCAN_TR|SCAN_REPL);
+ if (!s) {
+ if (lex_stuff)
+ sv_free(lex_stuff);
+ lex_stuff = Nullsv;
+ if (lex_repl)
+ sv_free(lex_repl);
+ lex_repl = Nullsv;
+ fatal("Translation replacement not terminated");
}
- rstr = yylval.arg[1].arg_ptr.arg_str;
- yylval.arg[1].arg_ptr.arg_str = Nullstr;
- arg_free(yylval.arg);
- r = rstr->str_ptr;
- rlen = rstr->str_cur;
+
+ New(803,tbl,256,short);
+ op = newPVOP(OP_TRANS, 0, (char*)tbl);
complement = delete = squash = 0;
while (*s == 'c' || *s == 'd' || *s == 's') {
if (*s == 'c')
- complement = 1;
+ complement = OPpTRANS_COMPLEMENT;
else if (*s == 'd')
- delete = 2;
+ delete = OPpTRANS_DELETE;
else
- squash = 1;
+ squash = OPpTRANS_SQUASH;
s++;
}
- arg[2].arg_len = delete|squash;
- yylval.arg = arg;
- if (complement) {
- Zero(tbl, 256, short);
- for (i = 0; i < tlen; i++)
- tbl[t[i] & 0377] = -1;
- for (i = 0, j = 0; i < 256; i++) {
- if (!tbl[i]) {
- if (j >= rlen) {
- if (delete)
- tbl[i] = -2;
- else if (rlen)
- tbl[i] = r[j-1] & 0377;
- else
- tbl[i] = i;
- }
- else
- tbl[i] = r[j++] & 0377;
- }
+ op->op_private = delete|squash|complement;
+
+ lex_op = op;
+ yylval.ival = OP_TRANS;
+ return s;
+}
+
+char *
+scan_heredoc(s)
+register char *s;
+{
+ SV *herewas;
+ I32 op_type = OP_SCALAR;
+ I32 len;
+ SV *tmpstr;
+ char term;
+ register char *d;
+
+ s += 2;
+ 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 (isALNUM(*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 = newSVpv(s,bufend-s);
+ else
+ s--, herewas = newSVpv(s,d-s);
+ s += SvCUR(herewas);
+ if (term == '\'')
+ op_type = OP_CONST;
+ if (term == '`')
+ op_type = OP_BACKTICK;
+
+ CLINE;
+ multi_start = curcop->cop_line;
+ multi_open = multi_close = '<';
+ tmpstr = NEWSV(87,80);
+ term = *tokenbuf;
+ if (!rsfp) {
+ d = s;
+ while (s < bufend &&
+ (*s != term || bcmp(s,tokenbuf,len) != 0) ) {
+ if (*s++ == '\n')
+ curcop->cop_line++;
+ }
+ if (s >= bufend) {
+ curcop->cop_line = multi_start;
+ fatal("EOF in string");
+ }
+ sv_setpvn(tmpstr,d+1,s-d);
+ s += len - 1;
+ sv_catpvn(herewas,s,bufend-s);
+ sv_setsv(linestr,herewas);
+ oldoldbufptr = oldbufptr = bufptr = s = SvPVn(linestr);
+ bufend = SvPV(linestr) + SvCUR(linestr);
+ }
+ else
+ sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
+ while (s >= bufend) { /* multiple line string? */
+ if (!rsfp ||
+ !(oldoldbufptr = oldbufptr = s = sv_gets(linestr, rsfp, 0))) {
+ curcop->cop_line = multi_start;
+ fatal("EOF in string");
+ }
+ curcop->cop_line++;
+ if (perldb) {
+ SV *sv = NEWSV(88,0);
+
+ sv_setsv(sv,linestr);
+ av_store(GvAV(curcop->cop_filegv),
+ (I32)curcop->cop_line,sv);
+ }
+ bufend = SvPV(linestr) + SvCUR(linestr);
+ if (*s == term && bcmp(s,tokenbuf,len) == 0) {
+ s = bufend - 1;
+ *s = ' ';
+ sv_catsv(linestr,herewas);
+ bufend = SvPV(linestr) + SvCUR(linestr);
+ }
+ else {
+ s = bufend;
+ sv_catsv(tmpstr,linestr);
}
}
+ multi_end = curcop->cop_line;
+ s++;
+ if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
+ SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
+ Renew(SvPV(tmpstr), SvLEN(tmpstr), char);
+ }
+ sv_free(herewas);
+ lex_stuff = tmpstr;
+ yylval.ival = op_type;
+ return s;
+}
+
+char *
+scan_inputsymbol(start)
+char *start;
+{
+ register char *s = start;
+ register char *d;
+ I32 len;
+
+ d = tokenbuf;
+ s = cpytill(d, s+1, bufend, '>', &len);
+ if (s < bufend)
+ s++;
+ else
+ fatal("Unterminated <> operator");
+
+ if (*d == '$') d++;
+ while (*d && (isALNUM(*d) || *d == '\''))
+ d++;
+ if (d - tokenbuf != len) {
+ yylval.ival = OP_GLOB;
+ set_csh();
+ s = scan_str(start);
+ if (!s)
+ fatal("Glob not terminated");
+ return s;
+ }
else {
- if (!rlen && !delete) {
- r = t; rlen = tlen;
- }
- for (i = 0; i < 256; i++)
- tbl[i] = -1;
- for (i = 0, j = 0; i < tlen; i++,j++) {
- if (j >= rlen) {
- if (delete) {
- if (tbl[t[i] & 0377] == -1)
- tbl[t[i] & 0377] = -2;
- continue;
- }
- --j;
+ d = tokenbuf;
+ if (!len)
+ (void)strcpy(d,"ARGV");
+ if (*d == '$') {
+ GV *gv = gv_fetchpv(d+1,TRUE);
+ lex_op = (OP*)newUNOP(OP_READLINE, 0,
+ newUNOP(OP_RV2GV, 0,
+ newUNOP(OP_RV2SV, 0,
+ newGVOP(OP_GV, 0, gv))));
+ yylval.ival = OP_NULL;
+ }
+ else {
+ IO *io;
+
+ GV *gv = gv_fetchpv(d,TRUE);
+ io = GvIOn(gv);
+ if (strEQ(d,"ARGV")) {
+ GvAVn(gv);
+ io->flags |= IOf_ARGV|IOf_START;
}
- if (tbl[t[i] & 0377] == -1)
- tbl[t[i] & 0377] = r[j] & 0377;
+ lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
+ yylval.ival = OP_NULL;
+ }
+ }
+ return s;
+}
+
+char *
+scan_str(start)
+char *start;
+{
+ SV *tmpstr;
+ char *tmps;
+ register char *s = start;
+ register char term = *s;
+
+ CLINE;
+ multi_start = curcop->cop_line;
+ multi_open = term;
+ if (term && (tmps = index("([{< )]}> )]}>",term)))
+ term = tmps[5];
+ multi_close = term;
+
+ tmpstr = NEWSV(87,80);
+ SvSTORAGE(tmpstr) = term;
+ s = sv_append_till(tmpstr, s+1, bufend, term, Nullch);
+
+ while (s >= bufend) { /* multiple line string? */
+ if (!rsfp ||
+ !(oldoldbufptr = oldbufptr = s = sv_gets(linestr, rsfp, 0))) {
+ curcop->cop_line = multi_start;
+ return Nullch;
+ }
+ curcop->cop_line++;
+ if (perldb) {
+ SV *sv = NEWSV(88,0);
+
+ sv_setsv(sv,linestr);
+ av_store(GvAV(curcop->cop_filegv),
+ (I32)curcop->cop_line, sv);
}
+ bufend = SvPV(linestr) + SvCUR(linestr);
+ s = sv_append_till(tmpstr, s, bufend, term, Nullch);
}
- str_free(tstr);
- str_free(rstr);
+ multi_end = curcop->cop_line;
+ s++;
+ if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
+ SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
+ Renew(SvPV(tmpstr), SvLEN(tmpstr), char);
+ }
+ if (lex_stuff)
+ lex_repl = tmpstr;
+ else
+ lex_stuff = tmpstr;
return s;
}
char *
-scanstr(start, in_what)
+scan_num(start)
char *start;
-int in_what;
{
register char *s = start;
- 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;
- STR *str;
- /* which backslash sequences to keep */
- char *leave = (in_what & SCAN_TR)
- ? "\\$@nrtfbeacx0123456789-"
- : "\\$@nrtfbeacx0123456789[{]}lLuUE";
- int len;
-
- arg = op_new(1);
- yylval.arg = arg;
- arg->arg_type = O_ITEM;
+ I32 tryi32;
+ double value;
+ SV *sv;
+ I32 floatit;
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;
+ default:
+ fatal("panic: scan_num");
case '0':
{
- unsigned long i;
- int shift;
+ U32 i;
+ I32 shift;
- arg[1].arg_type = A_SINGLE;
if (s[1] == 'x') {
shift = 4;
s += 2;
}
}
out:
- str = Str_new(92,0);
- str_numset(str,(double)i);
- if (str->str_ptr) {
- Safefree(str->str_ptr);
- str->str_ptr = Nullch;
- str->str_len = str->str_cur = 0;
- }
- arg[1].arg_ptr.arg_str = str;
+ sv = NEWSV(92,0);
+ tryi32 = i;
+ if (tryi32 == i && tryi32 >= 0)
+ sv_setiv(sv,tryi32);
+ else
+ sv_setnv(sv,(double)i);
}
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;
+ floatit = FALSE;
while (isDIGIT(*s) || *s == '_') {
if (*s == '_')
s++;
*d++ = *s++;
}
if (*s == '.' && s[1] != '.') {
+ floatit = TRUE;
*d++ = *s++;
while (isDIGIT(*s) || *s == '_') {
if (*s == '_')
}
}
if (*s && index("eE",*s) && index("+-0123456789",s[1])) {
- *d++ = *s++;
+ floatit = TRUE;
+ s++;
+ *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
if (*s == '+' || *s == '-')
*d++ = *s++;
while (isDIGIT(*s))
*d++ = *s++;
}
*d = '\0';
- str = Str_new(92,0);
- str_numset(str,atof(tokenbuf));
- if (str->str_ptr) {
- Safefree(str->str_ptr);
- str->str_ptr = Nullch;
- str->str_len = str->str_cur = 0;
- }
- arg[1].arg_ptr.arg_str = str;
- break;
- case '<':
- if (in_what & (SCAN_REPL|SCAN_TR))
- goto do_double;
- 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 (isALNUM(*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++;
+ sv = NEWSV(92,0);
+ value = atof(tokenbuf);
+ tryi32 = (I32)value;
+ if (!floatit && (double)tryi32 == value)
+ sv_setiv(sv,tryi32);
else
- fatal("Unterminated <> operator");
-
- if (*d == '$') d++;
- while (*d && (isALNUM(*d) || *d == '\''))
- d++;
- if (d - tokenbuf != len) {
- s = start;
- term = *s;
- arg[1].arg_type = A_GLOB;
- set_csh();
- alwaysdollar = TRUE; /* treat $) and $| as variables */
- goto snarf_it;
- }
- 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;
- 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;
- }
- }
- }
+ sv_setnv(sv,value);
break;
+ }
- case 'q':
- s++;
- if (*s == 'q') {
- s++;
- goto do_double;
- }
- if (*s == 'x') {
- s++;
- goto do_back;
- }
- /* 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;
- STR *tmpstr2 = Nullstr;
- char *tmps;
- char *start;
- bool dorange = FALSE;
-
- CLINE;
- multi_start = curcmd->c_line;
- if (hereis)
- multi_open = multi_close = '<';
- else {
- multi_open = term;
- if (term && (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')
- curcmd->c_line++;
- }
- if (s >= bufend) {
- curcmd->c_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
- str_nset(tmpstr,"",0); /* avoid "uninitialized" warning */
- }
- 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))) {
- curcmd->c_line = multi_start;
- fatal("EOF in string");
- }
- curcmd->c_line++;
- if (perldb) {
- STR *str = Str_new(88,0);
-
- str_sset(str,linestr);
- astore(stab_xarray(curcmd->c_filestab),
- (int)curcmd->c_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 = curcmd->c_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_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[1] != '0')
- *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) {
- if (index("lLuUE",s[1]))
- makesingle = FALSE;
- s++;
- }
- s++;
- }
- s = d = start = tmpstr->str_ptr; /* assuming shrinkage only */
- while (s < send || dorange) {
- if (in_what & SCAN_TR) {
- if (dorange) {
- int i;
- int max;
- if (!tmpstr2) { /* oops, have to grow */
- tmpstr2 = str_smake(tmpstr);
- s = tmpstr2->str_ptr + (s - tmpstr->str_ptr);
- send = tmpstr2->str_ptr + (send - tmpstr->str_ptr);
- }
- i = d - tmpstr->str_ptr;
- STR_GROW(tmpstr, tmpstr->str_len + 256);
- d = tmpstr->str_ptr + i;
- d -= 2;
- max = d[1] & 0377;
- for (i = (*d & 0377); i <= max; i++)
- *d++ = i;
- start = s;
- dorange = FALSE;
- continue;
- }
- else if (*s == '-' && s+1 < send && s != start) {
- dorange = TRUE;
- s++;
- }
- }
- else {
- if ((*s == '$' && s+1 < send &&
- (alwaysdollar || /*(*/(s[1] != ')' && s[1] != '|')) ) ||
- (*s == '@' && s+1 < send) ) {
- if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_'))
- *d++ = *s++;
- len = scanident(s,send,tokenbuf) - s;
- if (*s == '$' || strEQ(tokenbuf,"ARGV")
- || strEQ(tokenbuf,"ENV")
- || strEQ(tokenbuf,"SIG")
- || strEQ(tokenbuf,"INC") )
- (void)stabent(tokenbuf,TRUE); /* add symbol */
- while (len--)
- *d++ = *s++;
- continue;
- }
- }
- if (*s == '\\' && s+1 < send) {
- s++;
- switch (*s) {
- case '-':
- if (in_what & SCAN_TR) {
- *d++ = *s++;
- continue;
- }
- /* FALL THROUGH */
- 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++ = scanoct(s, 3, &len);
- s += len;
- continue;
- case 'x':
- *d++ = scanhex(++s, 2, &len);
- s += len;
- continue;
- case 'c':
- s++;
- *d = *s++;
- if (isLOWER(*d))
- *d = toupper(*d);
- *d++ ^= 64;
- 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;
- case 'e':
- *d++ = '\033';
- break;
- case 'a':
- *d++ = '\007';
- break;
- }
- s++;
- continue;
- }
- *d++ = *s++;
- }
- *d = '\0';
-
- if (arg[1].arg_type == A_DOUBLE && makesingle)
- arg[1].arg_type = A_SINGLE; /* now we can optimize on it */
+ yylval.opval = newSVOP(OP_CONST, 0, sv);
- tmpstr->str_cur = d - tmpstr->str_ptr;
- if (arg[1].arg_type == A_GLOB) {
- arg[1].arg_ptr.arg_stab = stab = genstab();
- stab_io(stab) = stio_new();
- str_sset(stab_val(stab), tmpstr);
- }
- else
- arg[1].arg_ptr.arg_str = tmpstr;
- s = tmps;
- if (tmpstr2)
- str_free(tmpstr2);
- break;
- }
- }
- if (hereis)
- str_free(herewas);
return s;
}
-FCMD *
-load_format()
+char *
+scan_formline(s)
+register char *s;
{
- FCMD froot;
- FCMD *flinebeg;
- char *eol;
- register FCMD *fprev = &froot;
- register FCMD *fcmd;
- register char *s;
+ register char *eol;
register char *t;
- register STR *str;
- bool noblank;
- bool repeater;
+ SV *stuff = NEWSV(0,0);
+ bool needargs = FALSE;
- Zero(&froot, 1, FCMD);
- s = bufptr;
- while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) {
- curcmd->c_line++;
+ while (!needargs) {
+ if (*s == '.') {
+ /*SUPPRESS 530*/
+ for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
+ if (*t == '\n')
+ break;
+ }
if (in_eval && !rsfp) {
eol = index(s,'\n');
if (!eol++)
eol = bufend;
}
else
- eol = bufend = linestr->str_ptr + linestr->str_cur;
- if (perldb) {
- STR *tmpstr = Str_new(89,0);
-
- str_nset(tmpstr, s, eol-s);
- astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr);
- }
- if (*s == '.') {
- /*SUPPRESS 530*/
- for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
- if (*t == '\n') {
- bufptr = s;
- return froot.f_next;
- }
- }
- if (*s == '#') {
- s = eol;
- continue;
- }
- flinebeg = Nullfcmd;
- noblank = FALSE;
- repeater = FALSE;
- while (s < eol) {
- Newz(804,fcmd,1,FCMD);
- fprev->f_next = fcmd;
- fprev = fcmd;
- for (t=s; t < eol && *t != '@' && *t != '^'; t++) {
- if (*t == '~') {
- noblank = TRUE;
- *t = ' ';
- if (t[1] == '~') {
- repeater = TRUE;
- t[1] = ' ';
- }
+ eol = bufend = SvPV(linestr) + SvCUR(linestr);
+ if (*s != '#') {
+ sv_catpvn(stuff, s, eol-s);
+ while (s < eol) {
+ if (*s == '@' || *s == '^') {
+ needargs = TRUE;
+ break;
}
+ s++;
}
- fcmd->f_pre = nsavestr(s, t-s);
- fcmd->f_presize = t-s;
- s = t;
- if (s >= eol) {
- 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;
- case '#':
- case '.':
- /* Catch the special case @... and handle it as a string
- field. */
- if (*s == '.' && s[1] == '.') {
- goto default_format;
- }
- fcmd->f_type = F_DECIMAL;
- {
- char *p;
-
- /* Read a format in the form @####.####, where either group
- of ### may be empty, or the final .### may be missing. */
- while (*s == '#')
- s++;
- if (*s == '.') {
- s++;
- p = s;
- while (*s == '#')
- s++;
- fcmd->f_decimals = s-p;
- fcmd->f_flags |= FC_DP;
- } else {
- fcmd->f_decimals = 0;
- }
- }
- break;
- default:
- default_format:
- fcmd->f_type = F_LEFT;
+ }
+ s = eol;
+ if (rsfp) {
+ s = sv_gets(linestr, rsfp, 0);
+ oldoldbufptr = oldbufptr = bufptr = SvPVn(linestr);
+ if (!s) {
+ s = bufptr;
+ yyerror("Format not terminated");
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 >= bufend &&
- (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) )
- goto badform;
- curcmd->c_line++;
- if (in_eval && !rsfp) {
- eol = index(s,'\n');
- if (!eol++)
- eol = bufend;
- }
- else
- eol = bufend = linestr->str_ptr + linestr->str_cur;
- if (perldb) {
- STR *tmpstr = Str_new(90,0);
-
- str_nset(tmpstr, s, eol-s);
- astore(stab_xarray(curcmd->c_filestab),
- (int)curcmd->c_line,tmpstr);
- }
- if (strnEQ(s,".\n",2)) {
- bufptr = s;
- yyerror("Missing values line");
- return froot.f_next;
- }
- if (*s == '#') {
- s = eol;
- goto again;
- }
- str = flinebeg->f_unparsed = Str_new(91,eol - s);
- str->str_u.str_hash = curstash;
- str_nset(str,"(",1);
- flinebeg->f_line = curcmd->c_line;
- eol[-1] = '\0';
- if (!flinebeg->f_next->f_type || index(s, ',')) {
- eol[-1] = '\n';
- str_ncat(str, s, eol - s - 1);
- str_ncat(str,",$$);",5);
- s = eol;
- }
- else {
- eol[-1] = '\n';
- while (s < eol && isSPACE(*s))
- s++;
- t = s;
- while (s < eol) {
- switch (*s) {
- case ' ': case '\t': case '\n': case ';':
- str_ncat(str, t, s - t);
- str_ncat(str, "," ,1);
- while (s < eol && (isSPACE(*s) || *s == ';'))
- s++;
- t = s;
- break;
- case '$':
- str_ncat(str, t, s - t);
- t = s;
- s = scanident(s,eol,tokenbuf);
- str_ncat(str, t, s - t);
- t = s;
- if (s < eol && *s && index("$'\"",*s))
- str_ncat(str, ",", 1);
- break;
- case '"': case '\'':
- str_ncat(str, t, s - t);
- t = s;
- s++;
- while (s < eol && (*s != *t || s[-1] == '\\'))
- s++;
- if (s < eol)
- s++;
- str_ncat(str, t, s - t);
- t = s;
- if (s < eol && *s && index("$'\"",*s))
- str_ncat(str, ",", 1);
- break;
- default:
- yyerror("Please use commas to separate fields");
- }
- }
- str_ncat(str,"$$);",4);
- }
}
+ curcop->cop_line++;
+ }
+ if (SvPOK(stuff)) {
+ if (needargs) {
+ nextval[nexttoke].ival = 0;
+ force_next(',');
+ }
+ else
+ in_format = 2;
+ nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
+ force_next(THING);
+ nextval[nexttoke].ival = OP_FORMLINE;
+ force_next(LSTOP);
}
- badform:
- bufptr = str_get(linestr);
- yyerror("Format not terminated");
- return froot.f_next;
+ else {
+ sv_free(stuff);
+ in_format = 0;
+ bufptr = s;
+ }
+ return s;
}
static void
+++ /dev/null
-/* $RCSfile: toke.c,v $$Revision: 4.0.1.8 $$Date: 92/06/23 12:33:45 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: toke.c,v $
- * Revision 4.0.1.8 92/06/23 12:33:45 lwall
- * patch35: bad interaction between backslash and hyphen in tr///
- *
- * Revision 4.0.1.7 92/06/11 21:16:30 lwall
- * patch34: expectterm incorrectly set to indicate start of program or block
- *
- * Revision 4.0.1.6 92/06/08 16:03:49 lwall
- * patch20: an EXPR may now start with a bareword
- * patch20: print $fh EXPR can now expect term rather than operator in EXPR
- * patch20: added ... as variant on ..
- * patch20: new warning on spurious backslash
- * patch20: new warning on missing $ for foreach variable
- * patch20: "foo"x1024 now legal without space after x
- * patch20: new warning on print accidentally used as function
- * patch20: tr/stuff// wasn't working right
- * patch20: 2. now eats the dot
- * patch20: <@ARGV> now notices @ARGV
- * patch20: tr/// now lets you say \-
- *
- * Revision 4.0.1.5 91/11/11 16:45:51 lwall
- * patch19: default arg for shift was wrong after first subroutine definition
- *
- * Revision 4.0.1.4 91/11/05 19:02:48 lwall
- * patch11: \x and \c were subject to double interpretation in regexps
- * patch11: prepared for ctype implementations that don't define isascii()
- * patch11: nested list operators could miscount parens
- * patch11: once-thru blocks didn't display right in the debugger
- * patch11: sort eval "whatever" didn't work
- * patch11: underscore is now allowed within literal octal and hex numbers
- *
- * Revision 4.0.1.3 91/06/10 01:32:26 lwall
- * patch10: m'$foo' now treats string as single quoted
- * patch10: certain pattern optimizations were botched
- *
- * Revision 4.0.1.2 91/06/07 12:05:56 lwall
- * patch4: new copyright notice
- * patch4: debugger lost track of lines in eval
- * patch4: //o and s///o now optimize themselves fully at runtime
- * patch4: added global modifier for pattern matches
- *
- * Revision 4.0.1.1 91/04/12 09:18:18 lwall
- * patch1: perl -de "print" wouldn't stop at the first statement
- *
- * Revision 4.0 91/03/20 01:42:14 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "perly.h"
-
-static void set_csh();
-
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
-
-#ifdef f_next
-#undef f_next
-#endif
-
-/* which backslash sequences to keep in m// or s// */
-
-static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}";
-
-char *reparse; /* if non-null, scanident found ${foo[$bar]} */
-
-void checkcomma();
-
-#ifdef CLINE
-#undef CLINE
-#endif
-#define CLINE (cmdline = (curcmd->c_line < cmdline ? curcmd->c_line : cmdline))
-
-#ifdef atarist
-#define PERL_META(c) ((c) | 128)
-#else
-#define META(c) ((c) | 128)
-#endif
-
-#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 FUN2x(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2x)
-#define FUN3(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC3)
-#define FUN4(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC4)
-#define FUN5(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC5)
-#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 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)
-
-static char *last_uni;
-
-/* 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, \
- last_uni = oldbufptr, \
- (*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.
- */
-#ifdef atarist
-#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \
- (*s = (char) PERL_META('('), bufptr = oldbufptr, '(') : \
- (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
-#else
-#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \
- (*s = (char) META('('), bufptr = oldbufptr, '(') : \
- (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
-#endif
-/* 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 && isSPACE(*s))
- s++;
- return s;
-}
-
-void
-check_uni() {
- char *s;
- char ch;
-
- if (oldoldbufptr != last_uni)
- return;
- while (isSPACE(*last_uni))
- last_uni++;
- for (s = last_uni; isALNUM(*s); s++) ;
- ch = *s;
- *s = '\0';
- warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
- *s = ch;
-}
-
-#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;
- last_uni = oldbufptr;
- if (*s == '(')
- return FUNC1;
- s = skipspace(s);
- if (*s == '(')
- return FUNC1;
- else
- return UNIOP;
-}
-
-int
-lop(f,s)
-int f;
-char *s;
-{
- CLINE;
- if (*s != '(')
- s = skipspace(s);
- if (*s == '(') {
-#ifdef atarist
- *s = PERL_META('(');
-#else
- *s = META('(');
-#endif
- bufptr = oldbufptr;
- return '(';
- }
- else {
- yylval.ival=f;
- expectterm = TRUE;
- bufptr = s;
- return LISTOP;
- }
-}
-
-#endif /* CRIPPLED_CC */
-
-int
-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
-#ifdef BADSWITCH
- if (*s & 128) {
- if ((*s & 127) == '(') {
- *s++ = '(';
- oldbufptr = s;
- }
- else if ((*s & 127) == '}') {
- *s++ = '}';
- RETURN('}');
- }
- else
- warn("Unrecognized character \\%03o ignored", *s++ & 255);
- goto retry;
- }
-#endif
- switch (*s) {
- default:
- if ((*s & 127) == '(') {
- *s++ = '(';
- oldbufptr = s;
- }
- else if ((*s & 127) == '}') {
- *s++ = '}';
- RETURN('}');
- }
- else
- warn("Unrecognized character \\%03o ignored", *s++ & 255);
- goto retry;
- case 4:
- case 26:
- goto fake_eof; /* emulate EOF on ^D or ^Z */
- case 0:
- if (!rsfp)
- RETURN(0);
- if (s++ < bufend)
- goto retry; /* ignore stray nulls */
- last_uni = 0;
- if (firstline) {
- firstline = FALSE;
- if (minus_n || minus_p || perldb) {
- str_set(linestr,"");
- if (perldb) {
- char *getenv();
- char *pdb = getenv("PERLDB");
-
- str_cat(linestr, pdb ? pdb : "require 'perldb.pl'");
- str_cat(linestr, ";");
- }
- if (minus_n || minus_p) {
- str_cat(linestr,"line: while (<>) {");
- if (minus_l)
- str_cat(linestr,"chop;");
- 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) {
- bufptr = bufend;
- yylval.formval = load_format();
- in_format = FALSE;
- oldoldbufptr = oldbufptr = s = str_get(linestr) + 1;
- bufend = linestr->str_ptr + linestr->str_cur;
- OPERATOR(FORMLIST);
- }
- curcmd->c_line++;
-#ifdef CRYPTSCRIPT
- cryptswitch();
-#endif /* CRYPTSCRIPT */
- do {
- if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
- fake_eof:
- if (rsfp) {
- if (preprocess)
- (void)mypclose(rsfp);
- else if ((FILE*)rsfp == stdin)
- clearerr(stdin);
- else
- (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(';'); /* not infinite loop because rsfp is NULL now */
- }
- if (doextract && *linestr->str_ptr == '#')
- doextract = FALSE;
- } while (doextract);
- oldoldbufptr = oldbufptr = bufptr = s;
- if (perldb) {
- STR *str = Str_new(85,0);
-
- str_sset(str,linestr);
- astore(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str);
- }
-#ifdef DEBUG
- if (firstline) {
- char *showinput();
- s = showinput();
- }
-#endif
- bufend = linestr->str_ptr + linestr->str_cur;
- if (curcmd->c_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': case '\r': case 013:
- s++;
- goto retry;
- case '#':
- if (preprocess && s == str_get(linestr) &&
- s[1] == ' ' && (isDIGIT(s[2]) || strnEQ(s+2,"line ",5)) ) {
- while (*s && !isDIGIT(*s))
- s++;
- curcmd->c_line = atoi(s)-1;
- while (isDIGIT(*s))
- s++;
- d = bufend;
- while (s < d && isSPACE(*s)) s++;
- s[strlen(s)-1] = '\0'; /* wipe out newline */
- if (*s == '"') {
- s++;
- s[strlen(s)-1] = '\0'; /* wipe out trailing quote */
- }
- if (*s)
- curcmd->c_filestab = fstab(s);
- else
- curcmd->c_filestab = fstab(origfilename);
- oldoldbufptr = oldbufptr = s = str_get(linestr);
- }
- /* FALL THROUGH */
- case '\n':
- if (in_eval && !rsfp) {
- d = bufend;
- while (s < d && *s != '\n')
- s++;
- if (s < d)
- s++;
- if (in_format) {
- bufptr = s;
- yylval.formval = load_format();
- in_format = FALSE;
- oldoldbufptr = oldbufptr = s = bufptr + 1;
- TERM(FORMLIST);
- }
- curcmd->c_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);
- case 'M': stabent("\024",TRUE); FTST(O_FTMTIME);
- case 'A': stabent("\024",TRUE); FTST(O_FTATIME);
- case 'C': stabent("\024",TRUE); FTST(O_FTCTIME);
- default:
- s -= 2;
- break;
- }
- }
- tmp = *s++;
- if (*s == tmp) {
- s++;
- RETURN(DEC);
- }
- if (expectterm) {
- if (isSPACE(*s) || !isSPACE(*bufptr))
- check_uni();
- OPERATOR('-');
- }
- else
- AOP(O_SUBTRACT);
- case '+':
- tmp = *s++;
- if (*s == tmp) {
- s++;
- RETURN(INC);
- }
- if (expectterm) {
- if (isSPACE(*s) || !isSPACE(*bufptr))
- check_uni();
- OPERATOR('+');
- }
- else
- AOP(O_ADD);
-
- case '*':
- if (expectterm) {
- check_uni();
- s = scanident(s,bufend,tokenbuf);
- yylval.stabval = stabent(tokenbuf,TRUE);
- TERM(STAR);
- }
- tmp = *s++;
- if (*s == tmp) {
- s++;
- OPERATOR(POW);
- }
- MOP(O_MULTIPLY);
- case '%':
- if (expectterm) {
- if (!isALPHA(s[1]))
- check_uni();
- s = scanident(s,bufend,tokenbuf);
- yylval.stabval = hadd(stabent(tokenbuf,TRUE));
- TERM(HSH);
- }
- s++;
- MOP(O_MODULO);
-
- case '^':
- case '~':
- case '(':
- case ',':
- case ':':
- case '[':
- tmp = *s++;
- OPERATOR(tmp);
- case '{':
- tmp = *s++;
- yylval.ival = curcmd->c_line;
- if (isSPACE(*s) || *s == '#')
- cmdline = NOLINE; /* invalidate current command line number */
- expectterm = 2;
- RETURN(tmp);
- case ';':
- if (curcmd->c_line < cmdline)
- cmdline = curcmd->c_line;
- tmp = *s++;
- OPERATOR(tmp);
- case ')':
- case ']':
- tmp = *s++;
- TERM(tmp);
- case '}':
- *s |= 128;
- RETURN(';');
- 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 */
- else
- check_uni();
- 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) {
- if (s[1] != '<' && !index(s,'>'))
- check_uni();
- s = scanstr(s, SCAN_DEF);
- TERM(RSTRING);
- }
- s++;
- tmp = *s++;
- if (tmp == '<')
- OPERATOR(LS);
- if (tmp == '=') {
- tmp = *s++;
- if (tmp == '>')
- EOP(O_NCMP);
- s--;
- 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 (isALNUM(*s) || *s == '\'') \
- *d++ = *s++; \
- while (d[-1] == '\'') \
- d--,s--; \
- *d = '\0'; \
- d = tokenbuf;
-
- case '$':
- if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_')) {
- s++;
- s = scanident(s,bufend,tokenbuf);
- yylval.stabval = aadd(stabent(tokenbuf,TRUE));
- TERM(ARYLEN);
- }
- d = s;
- s = scanident(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);
- expectterm = FALSE;
- if (isSPACE(*s) && oldoldbufptr && oldoldbufptr < bufptr) {
- s++;
- while (isSPACE(*oldoldbufptr))
- oldoldbufptr++;
- if (*oldoldbufptr == 'p' && strnEQ(oldoldbufptr,"print",5)) {
- if (index("&*<%", *s) && isALPHA(s[1]))
- expectterm = TRUE; /* e.g. print $fh &sub */
- else if (*s == '.' && isDIGIT(s[1]))
- expectterm = TRUE; /* e.g. print $fh .3 */
- else if (index("/?-+", *s) && !isSPACE(s[1]))
- expectterm = TRUE; /* e.g. print $fh -1 */
- }
- }
- RETURN(REG);
-
- case '@':
- d = s;
- s = scanident(s,bufend,tokenbuf);
- if (reparse)
- goto do_reparse;
- yylval.stabval = aadd(stabent(tokenbuf,TRUE));
- TERM(ARY);
-
- case '/': /* may either be division or pattern */
- case '?': /* may either be conditional or pattern */
- if (expectterm) {
- check_uni();
- 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++;
- if (*s == tmp) {
- s++;
- yylval.ival = 0;
- }
- else
- yylval.ival = AF_COMMON;
- OPERATOR(DOTDOT);
- }
- if (expectterm)
- check_uni();
- 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, SCAN_DEF);
- TERM(RSTRING);
-
- case '\\': /* some magic to force next word to be a WORD */
- s++; /* used by do and sub to force a separate namespace */
- if (!isALPHA(*s) && *s != '_' && *s != '\'') {
- warn("Spurious backslash ignored");
- goto retry;
- }
- /* FALL THROUGH */
- case '_':
- SNARFWORD;
- if (d[1] == '_') {
- if (strEQ(d,"__LINE__") || strEQ(d,"__FILE__")) {
- ARG *arg = op_new(1);
-
- yylval.arg = arg;
- arg->arg_type = O_ITEM;
- if (d[2] == 'L')
- (void)sprintf(tokenbuf,"%ld",(long)curcmd->c_line);
- else
- strcpy(tokenbuf, stab_val(curcmd->c_filestab)->str_ptr);
- arg[1].arg_type = A_SINGLE;
- arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
- TERM(RSTRING);
- }
- else if (strEQ(d,"__END__")) {
- STAB *stab;
- int fd;
-
- /*SUPPRESS 560*/
- if (!in_eval && (stab = stabent("DATA",FALSE))) {
- stab->str_pok |= SP_MULTI;
- if (!stab_io(stab))
- stab_io(stab) = stio_new();
- stab_io(stab)->ifp = rsfp;
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- fd = fileno(rsfp);
- fcntl(fd,F_SETFD,fd >= 3);
-#endif
- if (preprocess)
- stab_io(stab)->type = '|';
- else if ((FILE*)rsfp == stdin)
- stab_io(stab)->type = '-';
- else
- stab_io(stab)->type = '<';
- rsfp = Nullfp;
- }
- goto fake_eof;
- }
- }
- break;
- case 'a': case 'A':
- SNARFWORD;
- if (strEQ(d,"alarm"))
- UNI(O_ALARM);
- 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);
- if (strEQ(d,"binmode"))
- FOP(O_BINMODE);
- 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,"cmp"))
- EOP(O_SCMP);
- if (strEQ(d,"caller"))
- UNI(O_CALLER);
- if (strEQ(d,"crypt")) {
-#ifdef FCRYPT
- static int cryptseen = 0;
-
- if (!cryptseen++)
- 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 = curcmd->c_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_OP);
- }
- 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 = curcmd->c_line;
- while (s < bufend && isSPACE(*s))
- s++;
- if (isALPHA(*s))
- fatal("Missing $ on loop variable");
- 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 = curcmd->c_line;
- OPERATOR(IF);
- }
- if (strEQ(d,"index"))
- FUN2x(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 */
- }
- switch (d[1]) {
- case 'k':
- if (strEQ(d,"mkdir"))
- FUN2(O_MKDIR);
- break;
- case 's':
- if (strEQ(d,"msgctl"))
- FUN3(O_MSGCTL);
- if (strEQ(d,"msgget"))
- FUN2(O_MSGGET);
- if (strEQ(d,"msgrcv"))
- FUN5(O_MSGRCV);
- if (strEQ(d,"msgsnd"))
- FUN3(O_MSGSND);
- break;
- }
- 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_OPEN_DIR);
- break;
- case 'p': case 'P':
- SNARFWORD;
- if (strEQ(d,"print")) {
- checkcomma(s,d,"filehandle");
- LOP(O_PRINT);
- }
- if (strEQ(d,"printf")) {
- checkcomma(s,d,"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_OP);
- break;
- case 'q': case 'Q':
- SNARFWORD;
- if (strEQ(d,"q")) {
- s = scanstr(s-1, SCAN_DEF);
- TERM(RSTRING);
- }
- if (strEQ(d,"qq")) {
- s = scanstr(s-2, SCAN_DEF);
- TERM(RSTRING);
- }
- if (strEQ(d,"qx")) {
- s = scanstr(s-2, SCAN_DEF);
- TERM(RSTRING);
- }
- break;
- case 'r': case 'R':
- SNARFWORD;
- if (strEQ(d,"return"))
- OLDLOP(O_RETURN);
- if (strEQ(d,"require")) {
- allstabs = TRUE; /* must initialize everything since */
- UNI(O_REQUIRE); /* we don't know what will be used */
- }
- 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"))
- FUN2x(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':
- break;
- case 'c':
- if (strEQ(d,"scalar"))
- UNI(O_SCALAR);
- break;
- case 'd':
- break;
- case 'e':
- if (strEQ(d,"select"))
- OPERATOR(SSELECT);
- if (strEQ(d,"seek"))
- FOP3(O_SEEK);
- if (strEQ(d,"semctl"))
- FUN4(O_SEMCTL);
- if (strEQ(d,"semget"))
- FUN3(O_SEMGET);
- if (strEQ(d,"semop"))
- FUN2(O_SEMOP);
- 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,"shmctl"))
- FUN3(O_SHMCTL);
- if (strEQ(d,"shmget"))
- FUN3(O_SHMGET);
- if (strEQ(d,"shmread"))
- FUN4(O_SHMREAD);
- if (strEQ(d,"shmwrite"))
- FUN4(O_SHMWRITE);
- 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_SOCKPAIR);
- if (strEQ(d,"sort")) {
- checkcomma(s,d,"subroutine name");
- d = bufend;
- while (s < d && isSPACE(*s)) s++;
- if (*s == ';' || *s == ')') /* probably a close */
- fatal("sort is now a reserved word");
- if (isALPHA(*s) || *s == '_') {
- /*SUPPRESS 530*/
- for (d = s; isALNUM(*d); d++) ;
- strncpy(tokenbuf,s,d-s);
- tokenbuf[d-s] = '\0';
- if (strNE(tokenbuf,"keys") &&
- strNE(tokenbuf,"values") &&
- strNE(tokenbuf,"split") &&
- strNE(tokenbuf,"grep") &&
- strNE(tokenbuf,"readdir") &&
- strNE(tokenbuf,"unpack") &&
- strNE(tokenbuf,"do") &&
- strNE(tokenbuf,"eval") &&
- (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);
- if (strEQ(d,"splice")) {
- yylval.ival = O_SPLICE;
- OPERATOR(PUSH);
- }
- 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"))
- FUN2x(O_SUBSTR);
- if (strEQ(d,"sub")) {
- yylval.ival = savestack->ary_fill; /* restore stuff on reduce */
- savelong(&subline);
- saveitem(subname);
-
- subline = curcmd->c_line;
- d = bufend;
- while (s < d && isSPACE(*s))
- s++;
- if (isALPHA(*s) || *s == '_' || *s == '\'') {
- str_sset(subname,curstname);
- str_ncat(subname,"'",1);
- for (d = s+1; isALNUM(*d) || *d == '\''; d++)
- /*SUPPRESS 530*/
- ;
- if (d[-1] == '\'')
- d--;
- str_ncat(subname,s,d-s);
- *(--s) = '\\'; /* force next ident to WORD */
- }
- else
- 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);
- if (strEQ(d,"sysread"))
- FOP3(O_SYSREAD);
- if (strEQ(d,"syswrite"))
- FOP3(O_SYSWRITE);
- 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);
- if (strEQ(d,"truncate"))
- FOP2(O_TRUNCATE);
- break;
- case 'u': case 'U':
- SNARFWORD;
- if (strEQ(d,"using"))
- OPERATOR(USING);
- if (strEQ(d,"until")) {
- yylval.ival = curcmd->c_line;
- OPERATOR(UNTIL);
- }
- if (strEQ(d,"unless")) {
- yylval.ival = curcmd->c_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 = curcmd->c_line;
- OPERATOR(WHILE);
- }
- if (strEQ(d,"warn"))
- LOP(O_WARN);
- if (strEQ(d,"wait"))
- FUN0(O_WAIT);
- if (strEQ(d,"waitpid"))
- FUN2(O_WAITPID);
- 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':
- if (*s == 'x' && isDIGIT(s[1]) && !expectterm) {
- s++;
- MOP(O_REPEAT);
- }
- SNARFWORD;
- if (strEQ(d,"x")) {
- if (!expectterm)
- MOP(O_REPEAT);
- check_uni();
- }
- 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);
- if (expectterm == 2) { /* special case: start of statement */
- while (isSPACE(*s)) s++;
- if (*s == ':') {
- s++;
- CLINE;
- OPERATOR(LABEL);
- }
- TERM(WORD);
- }
- 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);
-}
-
-void
-checkcomma(s,name,what)
-register char *s;
-char *name;
-char *what;
-{
- char *w;
-
- if (dowarn && *s == ' ' && s[1] == '(') {
- w = index(s,')');
- if (w)
- for (w++; *w && isSPACE(*w); w++) ;
- if (!w || !*w || !index(";|}", *w)) /* an advisory hack only... */
- warn("%s (...) interpreted as function",name);
- }
- while (s < bufend && isSPACE(*s))
- s++;
- if (*s == '(')
- s++;
- while (s < bufend && isSPACE(*s))
- s++;
- if (isALPHA(*s) || *s == '_') {
- w = s++;
- while (isALNUM(*s))
- s++;
- while (s < bufend && isSPACE(*s))
- s++;
- if (*s == ',') {
- *s = '\0';
- w = instr(
- "tell eof times getlogin wait length shift umask getppid \
- cos exp int log rand sin sqrt ord wantarray",
- w);
- *s = ',';
- if (w)
- return;
- fatal("No comma allowed after %s", what);
- }
- }
-}
-
-char *
-scanident(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 (isALNUM(*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 && isALNUM(*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 == '^' && (isUPPER(*s) || index("[\\]^_?", *s))) {
-#ifdef DEBUGGING
- if (*s == 'D')
- debug |= 32768;
-#endif
- *d = *s++ ^ 64;
- }
- return s;
-}
-
-void
-scanconst(spat,string,len)
-SPAT *spat;
-char *string;
-int len;
-{
- register STR *tmpstr;
- register char *t;
- register char *d;
- register char *e;
- char *origstring = string;
- static char *vert = "|";
-
- if (ninstr(string, string+len, vert, vert+1))
- return;
- if (*string == '^')
- string++, len--;
- tmpstr = Str_new(86,len);
- str_nset(tmpstr,string,len);
- t = str_get(tmpstr);
- e = t + len;
- tmpstr->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 '+':
- case '^':
- e = d;
- break;
- case '\\':
- if (d[1] && index("wWbB0123456789sSdDlLuUExc",d[1])) {
- e = d;
- break;
- }
- Move(d+1,d,e-d,char);
- e--;
- switch(*d) {
- case 'n':
- *d = '\n';
- break;
- case 't':
- *d = '\t';
- break;
- case 'f':
- *d = '\f';
- break;
- case 'r':
- *d = '\r';
- break;
- case 'e':
- *d = '\033';
- break;
- case 'a':
- *d = '\007';
- break;
- }
- /* FALL THROUGH */
- default:
- defchar:
- if (d[1] == '*' || (d[1] == '{' && d[2] == '0') || d[1] == '?') {
- e = d;
- break;
- }
- d++;
- }
- }
- if (d == t) {
- str_free(tmpstr);
- return;
- }
- *d = '\0';
- tmpstr->str_cur = d - t;
- if (d == t+len)
- spat->spat_flags |= SPAT_ALL;
- if (*origstring != '^')
- spat->spat_flags |= SPAT_SCANFIRST;
- spat->spat_short = tmpstr;
- spat->spat_slen = d - t;
-}
-
-char *
-scanpat(s)
-register char *s;
-{
- register SPAT *spat;
- register char *d;
- register char *e;
- int len;
- SPAT savespat;
- STR *str = Str_new(93,0);
- char delim;
-
- 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 = str_append_till(str,s,bufend,s[-1],patleave);
- if (s >= bufend) {
- str_free(str);
- yyerror("Search pattern not terminated");
- yylval.arg = Nullarg;
- return s;
- }
- delim = *s++;
- while (*s == 'i' || *s == 'o' || *s == 'g') {
- if (*s == 'i') {
- s++;
- sawi = TRUE;
- spat->spat_flags |= SPAT_FOLD;
- }
- if (*s == 'o') {
- s++;
- spat->spat_flags |= SPAT_KEEP;
- }
- if (*s == 'g') {
- s++;
- spat->spat_flags |= SPAT_GLOBAL;
- }
- }
- len = str->str_cur;
- e = str->str_ptr + len;
- if (delim == '\'')
- d = e;
- else
- d = str->str_ptr;
- for (; d < e; d++) {
- if (*d == '\\')
- d++;
- else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') ||
- (*d == '@')) {
- 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_smake(str);
- d = scanident(d,bufend,buf);
- (void)stabent(buf,TRUE); /* make sure it's created */
- for (; d < e; d++) {
- if (*d == '\\')
- d++;
- else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') {
- d = scanident(d,bufend,buf);
- (void)stabent(buf,TRUE);
- }
- else if (*d == '@') {
- d = scanident(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)
- StructCopy(spat, &savespat, SPAT);
- scanconst(spat,str->str_ptr,len);
- if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) {
- fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
- spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
- spat->spat_flags & SPAT_FOLD);
- /* 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)
- StructCopy(&savespat, spat, SPAT);
- if (spat->spat_short)
- fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
- spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
- spat->spat_flags & SPAT_FOLD);
- hoistmust(spat);
- }
- got_pat:
- str_free(str);
- yylval.arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
- return s;
-}
-
-char *
-scansubst(start)
-char *start;
-{
- register char *s = start;
- register SPAT *spat;
- register char *d;
- register char *e;
- int len;
- STR *str = Str_new(93,0);
- char term = *s;
-
- if (term && (d = index("([{< )]}> )]}>",term)))
- term = d[5];
-
- Newz(802,spat,1,SPAT);
- spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
- curstash->tbl_spatroot = spat;
-
- s = str_append_till(str,s+1,bufend,term,patleave);
- if (s >= bufend) {
- str_free(str);
- yyerror("Substitution pattern not terminated");
- yylval.arg = Nullarg;
- return s;
- }
- len = str->str_cur;
- e = str->str_ptr + len;
- for (d = str->str_ptr; d < e; d++) {
- if (*d == '\\')
- d++;
- else if ((*d == '$' && d[1] && d[1] != '|' && /*(*/ d[1] != ')') ||
- *d == '@' ) {
- 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_smake(str);
- d = scanident(d,e,buf);
- (void)stabent(buf,TRUE); /* make sure it's created */
- for (; *d; d++) {
- if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
- d = scanident(d,e,buf);
- (void)stabent(buf,TRUE);
- }
- else if (*d == '@' && d[-1] != '\\') {
- d = scanident(d,e,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 */
- }
- }
- scanconst(spat,str->str_ptr,len);
-get_repl:
- if (term != *start)
- s++;
- s = scanstr(s, SCAN_REPL);
- if (s >= bufend) {
- str_free(str);
- yyerror("Substitution replacement not terminated");
- yylval.arg = Nullarg;
- return s;
- }
- spat->spat_repl = yylval.arg;
- 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') {
- int es = 0;
-
- if (*s == 'e') {
- s++;
- es++;
- if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE)
- spat->spat_repl[1].arg_type = A_SINGLE;
- spat->spat_repl = make_op(
- (!es && spat->spat_repl[1].arg_type == A_SINGLE
- ? O_EVALONCE
- : O_EVAL),
- 2,
- spat->spat_repl,
- Nullarg,
- Nullarg);
- spat->spat_flags &= ~SPAT_CONST;
- }
- if (*s == 'g') {
- s++;
- spat->spat_flags |= SPAT_GLOBAL;
- }
- 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(str->str_ptr,str->str_ptr+len,
- spat->spat_flags & SPAT_FOLD);
- hoistmust(spat);
- }
- yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat);
- str_free(str);
- return s;
-}
-
-void
-hoistmust(spat)
-register SPAT *spat;
-{
- if (!spat->spat_short && spat->spat_regexp->regstart &&
- (!spat->spat_regexp->regmust || spat->spat_regexp->reganch & ROPT_ANCH)
- ) {
- if (!(spat->spat_regexp->reganch & ROPT_ANCH))
- spat->spat_flags |= SPAT_SCANFIRST;
- else if (spat->spat_flags & SPAT_FOLD)
- return;
- spat->spat_short = str_smake(spat->spat_regexp->regstart);
- }
- else 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 *
-scantrans(start)
-char *start;
-{
- register char *s = start;
- ARG *arg =
- l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg));
- STR *tstr;
- STR *rstr;
- register char *t;
- register char *r;
- register short *tbl;
- register int i;
- register int j;
- int tlen, rlen;
- int squash;
- int delete;
- int complement;
-
- New(803,tbl,256,short);
- arg[2].arg_type = A_NULL;
- arg[2].arg_ptr.arg_cval = (char*) tbl;
-
- s = scanstr(s, SCAN_TR);
- if (s >= bufend) {
- yyerror("Translation pattern not terminated");
- yylval.arg = Nullarg;
- return s;
- }
- tstr = yylval.arg[1].arg_ptr.arg_str;
- yylval.arg[1].arg_ptr.arg_str = Nullstr;
- arg_free(yylval.arg);
- t = tstr->str_ptr;
- tlen = tstr->str_cur;
-
- if (s[-1] == *start)
- s--;
-
- s = scanstr(s, SCAN_TR|SCAN_REPL);
- if (s >= bufend) {
- yyerror("Translation replacement not terminated");
- yylval.arg = Nullarg;
- return s;
- }
- rstr = yylval.arg[1].arg_ptr.arg_str;
- yylval.arg[1].arg_ptr.arg_str = Nullstr;
- arg_free(yylval.arg);
- r = rstr->str_ptr;
- rlen = rstr->str_cur;
-
- complement = delete = squash = 0;
- while (*s == 'c' || *s == 'd' || *s == 's') {
- if (*s == 'c')
- complement = 1;
- else if (*s == 'd')
- delete = 2;
- else
- squash = 1;
- s++;
- }
- arg[2].arg_len = delete|squash;
- yylval.arg = arg;
- if (complement) {
- Zero(tbl, 256, short);
- for (i = 0; i < tlen; i++)
- tbl[t[i] & 0377] = -1;
- for (i = 0, j = 0; i < 256; i++) {
- if (!tbl[i]) {
- if (j >= rlen) {
- if (delete)
- tbl[i] = -2;
- else if (rlen)
- tbl[i] = r[j-1] & 0377;
- else
- tbl[i] = i;
- }
- else
- tbl[i] = r[j++] & 0377;
- }
- }
- }
- else {
- if (!rlen && !delete) {
- r = t; rlen = tlen;
- }
- for (i = 0; i < 256; i++)
- tbl[i] = -1;
- for (i = 0, j = 0; i < tlen; i++,j++) {
- if (j >= rlen) {
- if (delete) {
- if (tbl[t[i] & 0377] == -1)
- tbl[t[i] & 0377] = -2;
- continue;
- }
- --j;
- }
- if (tbl[t[i] & 0377] == -1)
- tbl[t[i] & 0377] = r[j] & 0377;
- }
- }
- str_free(tstr);
- str_free(rstr);
- return s;
-}
-
-char *
-scanstr(start, in_what)
-char *start;
-int in_what;
-{
- register char *s = start;
- 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;
- STR *str;
- /* which backslash sequences to keep */
- char *leave = (in_what & SCAN_TR)
- ? "\\$@nrtfbeacx0123456789-"
- : "\\$@nrtfbeacx0123456789[{]}lLuUE";
- 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':
- {
- unsigned 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 '_':
- s++;
- break;
- 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:
- str = Str_new(92,0);
- str_numset(str,(double)i);
- if (str->str_ptr) {
- Safefree(str->str_ptr);
- str->str_ptr = Nullch;
- str->str_len = str->str_cur = 0;
- }
- arg[1].arg_ptr.arg_str = str;
- }
- 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] != '.') {
- *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';
- str = Str_new(92,0);
- str_numset(str,atof(tokenbuf));
- if (str->str_ptr) {
- Safefree(str->str_ptr);
- str->str_ptr = Nullch;
- str->str_len = str->str_cur = 0;
- }
- arg[1].arg_ptr.arg_str = str;
- break;
- case '<':
- if (in_what & (SCAN_REPL|SCAN_TR))
- goto do_double;
- 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 (isALNUM(*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++;
- else
- fatal("Unterminated <> operator");
-
- if (*d == '$') d++;
- while (*d && (isALNUM(*d) || *d == '\''))
- d++;
- if (d - tokenbuf != len) {
- s = start;
- term = *s;
- arg[1].arg_type = A_GLOB;
- set_csh();
- alwaysdollar = TRUE; /* treat $) and $| as variables */
- goto snarf_it;
- }
- 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;
- 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;
- }
- if (*s == 'x') {
- s++;
- goto do_back;
- }
- /* 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;
- STR *tmpstr2 = Nullstr;
- char *tmps;
- bool dorange = FALSE;
-
- CLINE;
- multi_start = curcmd->c_line;
- if (hereis)
- multi_open = multi_close = '<';
- else {
- multi_open = term;
- if (term && (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')
- curcmd->c_line++;
- }
- if (s >= bufend) {
- curcmd->c_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
- str_nset(tmpstr,"",0); /* avoid "uninitialized" warning */
- }
- 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))) {
- curcmd->c_line = multi_start;
- fatal("EOF in string");
- }
- curcmd->c_line++;
- if (perldb) {
- STR *str = Str_new(88,0);
-
- str_sset(str,linestr);
- astore(stab_xarray(curcmd->c_filestab),
- (int)curcmd->c_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 = curcmd->c_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_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[1] != '0')
- *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) {
- if (index("lLuUE",s[1]))
- makesingle = FALSE;
- s++;
- }
- s++;
- }
- s = d = tmpstr->str_ptr; /* assuming shrinkage only */
- while (s < send || dorange) {
- if (in_what & SCAN_TR) {
- if (dorange) {
- int i;
- int max;
- if (!tmpstr2) { /* oops, have to grow */
- tmpstr2 = str_smake(tmpstr);
- s = tmpstr2->str_ptr + (s - tmpstr->str_ptr);
- send = tmpstr2->str_ptr + (send - tmpstr->str_ptr);
- }
- i = d - tmpstr->str_ptr;
- STR_GROW(tmpstr, tmpstr->str_len + 256);
- d = tmpstr->str_ptr + i;
- d -= 2;
- max = d[1] & 0377;
- for (i = (*d & 0377); i <= max; i++)
- *d++ = i;
- dorange = FALSE;
- continue;
- }
- else if (*s == '-' && s+1 < send && d != tmpstr->str_ptr) {
- dorange = TRUE;
- s++;
- }
- }
- else {
- if ((*s == '$' && s+1 < send &&
- (alwaysdollar || /*(*/(s[1] != ')' && s[1] != '|')) ) ||
- (*s == '@' && s+1 < send) ) {
- if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_'))
- *d++ = *s++;
- len = scanident(s,send,tokenbuf) - s;
- if (*s == '$' || strEQ(tokenbuf,"ARGV")
- || strEQ(tokenbuf,"ENV")
- || strEQ(tokenbuf,"SIG")
- || strEQ(tokenbuf,"INC") )
- (void)stabent(tokenbuf,TRUE); /* add symbol */
- while (len--)
- *d++ = *s++;
- continue;
- }
- }
- if (*s == '\\' && s+1 < send) {
- s++;
- switch (*s) {
- case '-':
- if (in_what & SCAN_TR) {
- *d++ = *s++;
- continue;
- }
- /* FALL THROUGH */
- 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++ = scanoct(s, 3, &len);
- s += len;
- continue;
- case 'x':
- *d++ = scanhex(++s, 2, &len);
- s += len;
- continue;
- case 'c':
- s++;
- *d = *s++;
- if (isLOWER(*d))
- *d = toupper(*d);
- *d++ ^= 64;
- 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;
- case 'e':
- *d++ = '\033';
- break;
- case 'a':
- *d++ = '\007';
- break;
- }
- s++;
- continue;
- }
- *d++ = *s++;
- }
- *d = '\0';
-
- if (arg[1].arg_type == A_DOUBLE && makesingle)
- arg[1].arg_type = A_SINGLE; /* now we can optimize on it */
-
- tmpstr->str_cur = d - tmpstr->str_ptr;
- if (arg[1].arg_type == A_GLOB) {
- arg[1].arg_ptr.arg_stab = stab = genstab();
- stab_io(stab) = stio_new();
- str_sset(stab_val(stab), tmpstr);
- }
- else
- arg[1].arg_ptr.arg_str = tmpstr;
- s = tmps;
- if (tmpstr2)
- str_free(tmpstr2);
- break;
- }
- }
- if (hereis)
- str_free(herewas);
- return s;
-}
-
-FCMD *
-load_format()
-{
- FCMD froot;
- FCMD *flinebeg;
- char *eol;
- register FCMD *fprev = &froot;
- register FCMD *fcmd;
- register char *s;
- register char *t;
- register STR *str;
- bool noblank;
- bool repeater;
-
- Zero(&froot, 1, FCMD);
- s = bufptr;
- while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) {
- curcmd->c_line++;
- if (in_eval && !rsfp) {
- eol = index(s,'\n');
- if (!eol++)
- eol = bufend;
- }
- else
- eol = bufend = linestr->str_ptr + linestr->str_cur;
- if (perldb) {
- STR *tmpstr = Str_new(89,0);
-
- str_nset(tmpstr, s, eol-s);
- astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr);
- }
- if (*s == '.') {
- /*SUPPRESS 530*/
- for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
- if (*t == '\n') {
- bufptr = s;
- return froot.f_next;
- }
- }
- if (*s == '#') {
- s = eol;
- continue;
- }
- flinebeg = Nullfcmd;
- noblank = FALSE;
- repeater = FALSE;
- while (s < eol) {
- Newz(804,fcmd,1,FCMD);
- fprev->f_next = fcmd;
- fprev = fcmd;
- for (t=s; t < eol && *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 >= eol) {
- 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;
- case '#':
- case '.':
- /* Catch the special case @... and handle it as a string
- field. */
- if (*s == '.' && s[1] == '.') {
- goto default_format;
- }
- fcmd->f_type = F_DECIMAL;
- {
- char *p;
-
- /* Read a format in the form @####.####, where either group
- of ### may be empty, or the final .### may be missing. */
- while (*s == '#')
- s++;
- if (*s == '.') {
- s++;
- p = s;
- while (*s == '#')
- s++;
- fcmd->f_decimals = s-p;
- fcmd->f_flags |= FC_DP;
- } else {
- fcmd->f_decimals = 0;
- }
- }
- break;
- default:
- default_format:
- 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 >= bufend &&
- (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) )
- goto badform;
- curcmd->c_line++;
- if (in_eval && !rsfp) {
- eol = index(s,'\n');
- if (!eol++)
- eol = bufend;
- }
- else
- eol = bufend = linestr->str_ptr + linestr->str_cur;
- if (perldb) {
- STR *tmpstr = Str_new(90,0);
-
- str_nset(tmpstr, s, eol-s);
- astore(stab_xarray(curcmd->c_filestab),
- (int)curcmd->c_line,tmpstr);
- }
- if (strnEQ(s,".\n",2)) {
- bufptr = s;
- yyerror("Missing values line");
- return froot.f_next;
- }
- if (*s == '#') {
- s = eol;
- goto again;
- }
- str = flinebeg->f_unparsed = Str_new(91,eol - s);
- str->str_u.str_hash = curstash;
- str_nset(str,"(",1);
- flinebeg->f_line = curcmd->c_line;
- eol[-1] = '\0';
- if (!flinebeg->f_next->f_type || index(s, ',')) {
- eol[-1] = '\n';
- str_ncat(str, s, eol - s - 1);
- str_ncat(str,",$$);",5);
- s = eol;
- }
- else {
- eol[-1] = '\n';
- while (s < eol && isSPACE(*s))
- s++;
- t = s;
- while (s < eol) {
- switch (*s) {
- case ' ': case '\t': case '\n': case ';':
- str_ncat(str, t, s - t);
- str_ncat(str, "," ,1);
- while (s < eol && (isSPACE(*s) || *s == ';'))
- s++;
- t = s;
- break;
- case '$':
- str_ncat(str, t, s - t);
- t = s;
- s = scanident(s,eol,tokenbuf);
- str_ncat(str, t, s - t);
- t = s;
- if (s < eol && *s && index("$'\"",*s))
- str_ncat(str, ",", 1);
- break;
- case '"': case '\'':
- str_ncat(str, t, s - t);
- t = s;
- s++;
- while (s < eol && (*s != *t || s[-1] == '\\'))
- s++;
- if (s < eol)
- s++;
- str_ncat(str, t, s - t);
- t = s;
- if (s < eol && *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;
-}
-
-static void
-set_csh()
-{
-#ifdef CSH
- if (!cshlen)
- cshlen = strlen(cshname);
-#endif
-}
+++ /dev/null
-***************
-*** 1,4 ****
-! /* $RCSfile: toke.c,v $$Revision: 4.0.1.8 $$Date: 1992/06/23 12:33:45 $
- *
- * Copyright (c) 1991, Larry Wall
- *
---- 1,4 ----
-! /* $RCSfile: toke.c,v $$Revision: 4.0.1.9 $$Date: 1993/02/05 19:48:43 $
- *
- * Copyright (c) 1991, Larry Wall
- *
-***************
-*** 6,14 ****
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: toke.c,v $
-! * Revision 4.0.1.8 1992/06/23 12:33:45 lwall
-! * patch35: bad interaction between backslash and hyphen in tr///
- *
- * Revision 4.0.1.7 92/06/11 21:16:30 lwall
- * patch34: expectterm incorrectly set to indicate start of program or block
- *
---- 6,18 ----
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: toke.c,v $
-! * Revision 4.0.1.9 1993/02/05 19:48:43 lwall
-! * patch36: now detects ambiguous use of filetest operators as well as unary
-! * patch36: fixed ambiguity on - within tr///
- *
-+ * Revision 4.0.1.8 92/06/23 12:33:45 lwall
-+ * patch35: bad interaction between backslash and hyphen in tr///
-+ *
- * Revision 4.0.1.7 92/06/11 21:16:30 lwall
- * patch34: expectterm incorrectly set to indicate start of program or block
- *
--- /dev/null
+ if (complement) {
+ Zero(tbl, 256, short);
+ for (i = 0; i < tlen; i++)
+ tbl[t[i] & 0377] = -1;
+ for (i = 0, j = 0; i < 256; i++) {
+ if (!tbl[i]) {
+ if (j >= rlen) {
+ if (delete)
+ tbl[i] = -2;
+ else if (rlen)
+ tbl[i] = r[j-1] & 0377;
+ else
+ tbl[i] = i;
+ }
+ else
+ tbl[i] = r[j++] & 0377;
+ }
+ }
+ }
+ else {
+ if (!rlen && !delete) {
+ r = t; rlen = tlen;
+ }
+ for (i = 0; i < 256; i++)
+ tbl[i] = -1;
+ for (i = 0, j = 0; i < tlen; i++,j++) {
+ if (j >= rlen) {
+ if (delete) {
+ if (tbl[t[i] & 0377] == -1)
+ tbl[t[i] & 0377] = -2;
+ continue;
+ }
+ --j;
+ }
+ if (tbl[t[i] & 0377] == -1)
+ tbl[t[i] & 0377] = r[j] & 0377;
+ }
+ }
+ sv_free(tstr);
+ sv_free(rstr);
--- /dev/null
+#!./perl -Dxstp
+
+# 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/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`);
+}
+
+open(CONFIG,"../foo.sh");
+while (<CONFIG>) {
+ if (/sharpbang='(.*)'/) {
+ $sharpbang = ($1 eq '#!');
+ last;
+ }
+}
+$bad = 0;
+while ($test = shift) {
+ if ($test =~ /^$/) {
+ next;
+ }
+ $te = $test;
+ chop($te);
+ print "$te" . '.' x (15 - length($te));
+ if ($sharpbang) {
+ open(results,"./$test|") || (print "can't run.\n");
+ } else {
+ open(script,"$test") || die "Can't run $test.\n";
+ $_ = <script>;
+ close(script);
+ if (/#!..perl(.*)/) {
+ $switch = $1;
+ } else {
+ $switch = '';
+ }
+ open(results,"./perl$switch $test|") || (print "can't run.\n");
+ }
+ $ok = 0;
+ $next = 0;
+ while (<results>) {
+ if ($verbose) {
+ print $_;
+ }
+ unless (/^#/) {
+ if (/^1\.\.([0-9]+)/) {
+ $max = $1;
+ $totmax += $max;
+ $files += 1;
+ $next = 1;
+ $ok = 1;
+ } else {
+ $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
+ if (/^ok (.*)/ && $1 == $next) {
+ $next = $next + 1;
+ } else {
+ $ok = 0;
+ }
+ }
+ }
+ }
+ $next = $next - 1;
+ if ($ok && $next == $max) {
+ print "ok\n";
+ } else {
+ $next += 1;
+ print "FAILED on test $next\n";
+ $bad = $bad + 1;
+ $_ = $test;
+ if (/^base/) {
+ die "Failed a basic test--cannot continue.\n";
+ }
+ }
+}
+
+if ($bad == 0) {
+ if ($ok) {
+ print "All tests successful.\n";
+ } else {
+ die "FAILED--no tests were run for some reason.\n";
+ }
+} else {
+ if ($bad == 1) {
+ die "Failed 1 test.\n";
+ } else {
+ die "Failed $bad tests.\n";
+ }
+}
+($user,$sys,$cuser,$csys) = times;
+print sprintf("u=%g s=%g cu=%g cs=%g files=%d tests=%d\n",
+ $user,$sys,$cuser,$csys,$files,$totmax);
--- /dev/null
+#!/usr/bin/perl -00
+
+$* = 1;
+while (<>) {
+ if (/^do_(\w+)/) {
+ open(OUT, ">>do/$1");
+ }
+ print OUT;
+ chop;
+ chop;
+ close OUT if chop eq '}' && chop eq "\n";
+}
--- /dev/null
+
+/*
+ * The following symbols are defined if your operating system supports
+ * functions by that name. All Unixes I know of support them, thus they
+ * are not checked by the configuration script, but are directly defined
+ * here.
+ */
+#define HAS_ALARM
+#define HAS_CHOWN
+#define HAS_CHROOT
+#define HAS_FORK
+#define HAS_GETLOGIN
+#define HAS_GETPPID
+#define HAS_KILL
+#define HAS_LINK
+#define HAS_PIPE
+#define HAS_WAIT
+#define HAS_UMASK
+#define HAS_PAUSE
+/*
+ * The following symbols are defined if your operating system supports
+ * password and group functions in general. All Unix systems do.
+ */
+#ifdef I_GRP
+#define HAS_GROUP
+#endif
+#ifdef I_PWD
+#define HAS_PASSWD
+#endif
+
+#ifndef SIGABRT
+# define SIGABRT SIGILL
+#endif
+#ifndef SIGILL
+# define SIGILL 6 /* blech */
+#endif
+#define ABORT() kill(getpid(),SIGABRT);
+
-/* $RCSfile: usersub.c,v $$Revision: 4.0.1.2 $$Date: 92/06/08 16:04:24 $
+/* $RCSfile: usersub.c,v $$Revision: 4.1 $$Date: 92/08/07 18:28:45 $
*
* This file contains stubs for routines that the user may define to
* set up glue routines for C libraries or to decrypt encrypted scripts
* for execution.
*
* $Log: usersub.c,v $
+ * Revision 4.1 92/08/07 18:28:45 lwall
+ *
* Revision 4.0.1.2 92/06/08 16:04:24 lwall
* patch20: removed implicit int declarations on functions
*
#endif
FILE *
-mypfiopen(fil,func) /* open a pipe to function call for input */
+my_pfiopen(fil,func) /* open a pipe to function call for input */
FILE *fil;
VOID (*func)();
{
int p[2];
- STR *str;
+ SV *sv;
if (pipe(p) < 0) {
fclose( fil );
close(p[1]);
close(fileno(fil));
fclose(fil);
- str = afetch(fdpid,p[0],TRUE);
- str->str_u.str_useful = pipepid;
+ sv = *av_fetch(fdpid,p[0],TRUE);
+ sv->sv_u.sv_useful = pipepid;
return fdopen(p[0], "r");
}
if (ch == CRYPT_MAGIC_1) {
if (getc(rsfp) == CRYPT_MAGIC_2) {
if( perldb ) fatal("can't debug an encrypted script");
- rsfp = mypfiopen( rsfp, cryptfilter );
+ rsfp = my_pfiopen( rsfp, cryptfilter );
preprocess = 1; /* force call to pclose when done */
}
else
- fatal( "bad encryption format" );
+ fatal( "bad encryption run_format" );
}
else
ungetc(ch,rsfp);
-/* $RCSfile: bsdcurses.mus,v $$Revision: 4.0.1.2 $$Date: 92/06/08 16:05:28 $
+/* $RCSfile: bsdcurses.mus,v $$Revision: 4.1 $$Date: 92/08/07 18:28:50 $
*
* $Log: bsdcurses.mus,v $
+ * Revision 4.1 92/08/07 18:28:50 lwall
+ *
* Revision 4.0.1.2 92/06/08 16:05:28 lwall
* patch20: &getcap eventually dumped core in bsdcurses
*
int retval;
STR* str = str_new(0);
- do_sprintf(str, items - 1, st + 1);
+ do_sprintf(str, items, st + 1);
retval = addstr(str->str_ptr);
str_numset(st[0], (double) retval);
str_free(str);
-/* $RCSfile: curses.mus,v $$Revision: 4.0.1.2 $$Date: 92/06/08 16:06:12 $
+/* $RCSfile: curses.mus,v $$Revision: 4.1 $$Date: 92/08/07 18:28:53 $
*
* $Log: curses.mus,v $
+ * Revision 4.1 92/08/07 18:28:53 lwall
+ *
* Revision 4.0.1.2 92/06/08 16:06:12 lwall
* patch20: function key support added to curses.mus
*
int retval;
STR* str = str_new(0);
- do_sprintf(str, items - 1, st + 1);
+ do_sprintf(str, items, st + 1);
retval = addstr(str->str_ptr);
str_numset(st[0], (double) retval);
str_free(str);
-/* $RCSfile: usersub.c,v $$Revision: 4.0.1.1 $$Date: 91/11/05 19:07:24 $
+/* $RCSfile: usersub.c,v $$Revision: 4.1 $$Date: 92/08/07 18:28:59 $
*
* $Log: usersub.c,v $
+ * Revision 4.1 92/08/07 18:28:59 lwall
+ *
* Revision 4.0.1.1 91/11/05 19:07:24 lwall
* patch11: there are now subroutines for calling back from C into Perl
*
-/* $RCSfile: util.c,v $$Revision: 4.0.1.6 $$Date: 92/06/11 21:18:47 $
+/* $RCSfile: util.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:00 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: util.c,v $
+ * Revision 4.1 92/08/07 18:29:00 lwall
+ *
* Revision 4.0.1.6 92/06/11 21:18:47 lwall
* patch34: boneheaded typo in my_bcopy()
*
#ifndef safemalloc
-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.
#ifdef MSDOS
if (size > 0xffff) {
fprintf(stderr, "Allocation too large: %lx\n", size) FLUSH;
- exit(1);
+ my_exit(1);
}
#endif /* MSDOS */
#ifdef DEBUGGING
fatal("panic: malloc");
#endif
ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
-#ifdef DEBUGGING
-# if !(defined(I286) || defined(atarist))
- if (debug & 128)
- fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size);
-# else
- if (debug & 128)
- fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size);
-# endif
+#if !(defined(I286) || defined(atarist))
+ DEBUG_m(fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
+#else
+ DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
#endif
if (ptr != Nullch)
return ptr;
else if (nomemok)
return Nullch;
else {
- fputs(nomem,stderr) FLUSH;
- exit(1);
+ fputs(no_mem,stderr) FLUSH;
+ my_exit(1);
}
/*NOTREACHED*/
-#ifdef lint
- return ptr;
-#endif
}
/* paranoid version of realloc */
#ifdef MSDOS
if (size > 0xffff) {
fprintf(stderr, "Reallocation too large: %lx\n", size) FLUSH;
- exit(1);
+ my_exit(1);
}
#endif /* MSDOS */
if (!where)
fatal("panic: realloc");
#endif
ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
-#ifdef DEBUGGING
-# if !(defined(I286) || defined(atarist))
- if (debug & 128) {
+
+#if !(defined(I286) || defined(atarist))
+ DEBUG_m( {
fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
- }
-# else
- if (debug & 128) {
+ } )
+#else
+ DEBUG_m( {
fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++);
fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
- }
-# endif
+ } )
#endif
+
if (ptr != Nullch)
return ptr;
else if (nomemok)
return Nullch;
else {
- fputs(nomem,stderr) FLUSH;
- exit(1);
+ fputs(no_mem,stderr) FLUSH;
+ my_exit(1);
}
/*NOTREACHED*/
-#ifdef lint
- return ptr;
-#endif
}
/* safe version of free */
safefree(where)
char *where;
{
-#ifdef DEBUGGING
-# if !(defined(I286) || defined(atarist))
- 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
+#if !(defined(I286) || defined(atarist))
+ DEBUG_m( fprintf(stderr,"0x%x: (%05d) free\n",where,an++));
+#else
+ DEBUG_m( fprintf(stderr,"0x%lx: (%05d) free\n",where,an++));
#endif
if (where) {
/*SUPPRESS 701*/
char *
safexmalloc(x,size)
-int x;
+I32 x;
MEM_SIZE size;
{
register char *where;
safexfree(where)
char *where;
{
- int x;
+ I32 x;
if (!where)
return;
static void
xstat()
{
- register int i;
+ register I32 i;
for (i = 0; i < MAXXCOUNT; i++) {
if (xcount[i] > lastxcount[i]) {
register char *to;
register char *from;
register char *fromend;
-register int delim;
-int *retlen;
+register I32 delim;
+I32 *retlen;
{
char *origto = to;
register char *little;
{
register char *s, *x;
- register int first;
+ register I32 first;
if (!little)
return big;
char *lend;
{
register char *s, *x;
- register int first = *little;
+ register I32 first = *little;
register char *littleend = lend;
if (!first && little > littleend)
{
register char *bigbeg;
register char *s, *x;
- register int first = *little;
+ register I32 first = *little;
register char *littleend = lend;
if (!first && little > littleend)
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;
+fbm_compile(sv, iflag)
+SV *sv;
+I32 iflag;
{
register unsigned char *s;
register unsigned char *table;
- register unsigned int i;
- register unsigned int len = str->str_cur;
- int rarest = 0;
- unsigned int frequency = 256;
-
- Str_Grow(str,len+258);
-#ifndef lint
- table = (unsigned char*)(str->str_ptr + len + 1);
-#else
- table = Null(unsigned char*);
-#endif
+ register U32 i;
+ register U32 len = SvCUR(sv);
+ I32 rarest = 0;
+ U32 frequency = 256;
+
+ Sv_Grow(sv,len+258);
+ table = (unsigned char*)(SvPV(sv) + len + 1);
s = table - 2;
for (i = 0; i < 256; i++) {
table[i] = len;
}
i = 0;
-#ifndef lint
- while (s >= (unsigned char*)(str->str_ptr))
-#endif
+ while (s >= (unsigned char*)(SvPV(sv)))
{
if (table[*s] == len) {
#ifndef pdp11
table[*s] = table[fold[*s]] = i;
#else
if (iflag) {
- int j;
+ I32 j;
j = fold[*s];
table[j] = i;
table[*s] = i;
}
s--,i++;
}
- str->str_pok |= SP_FBM; /* deep magic */
+ sv_upgrade(sv, SVt_PVBM);
+ sv_magic(sv, 0, 'B', 0, 0); /* deep magic */
+ SvVALID_on(sv);
-#ifndef lint
- s = (unsigned char*)(str->str_ptr); /* deeper magic */
-#else
- s = Null(unsigned char*);
-#endif
+ s = (unsigned char*)(SvPV(sv)); /* deeper magic */
if (iflag) {
- register unsigned int tmp, foldtmp;
- str->str_pok |= SP_CASEFOLD;
+ register U32 tmp, foldtmp;
+ SvCASEFOLD_on(sv);
for (i = 0; i < len; i++) {
tmp=freq[s[i]];
foldtmp=freq[fold[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
+ BmRARE(sv) = s[rarest];
+ BmPREVIOUS(sv) = rarest;
+ DEBUG_r(fprintf(stderr,"rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
}
char *
-fbminstr(big, bigend, littlestr)
+fbm_instr(big, bigend, littlestr)
unsigned char *big;
register unsigned char *bigend;
-STR *littlestr;
+SV *littlestr;
{
register unsigned char *s;
- register int tmp;
- register int littlelen;
+ register I32 tmp;
+ register I32 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)) {
- if (!littlestr->str_ptr)
+ if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
+ if (!SvPOK(littlestr) || !SvPV(littlestr))
return (char*)big;
return ninstr((char*)big,(char*)bigend,
- littlestr->str_ptr, littlestr->str_ptr + littlestr->str_cur);
+ SvPV(littlestr), SvPV(littlestr) + SvCUR(littlestr));
}
-#endif
- littlelen = littlestr->str_cur;
-#ifndef lint
- if (littlestr->str_pok & SP_TAIL && !multiline) { /* tail anchored? */
+ littlelen = SvCUR(littlestr);
+ if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
if (littlelen > bigend - big)
return Nullch;
- little = (unsigned char*)littlestr->str_ptr;
- if (littlestr->str_pok & SP_CASEFOLD) { /* oops, fake it */
+ little = (unsigned char*)SvPV(littlestr);
+ if (SvCASEFOLD(littlestr)) { /* oops, fake it */
big = bigend - littlelen; /* just start near end */
if (bigend[-1] == '\n' && little[littlelen-1] != '\n')
big--;
return Nullch;
}
}
- table = (unsigned char*)(littlestr->str_ptr + littlelen + 1);
-#else
- table = Null(unsigned char*);
-#endif
+ table = (unsigned char*)(SvPV(littlestr) + littlelen + 1);
if (--littlelen >= bigend - big)
return Nullch;
s = big + littlelen;
oldlittle = little = table - 2;
- if (littlestr->str_pok & SP_CASEFOLD) { /* case insensitive? */
+ if (SvCASEFOLD(littlestr)) { /* case insensitive? */
if (s < bigend) {
top1:
/*SUPPRESS 560*/
goto top1;
return Nullch;
}
-#ifndef lint
return (char *)s;
-#endif
}
}
}
goto top2;
return Nullch;
}
-#ifndef lint
return (char *)s;
-#endif
}
}
}
char *
screaminstr(bigstr, littlestr)
-STR *bigstr;
-STR *littlestr;
+SV *bigstr;
+SV *littlestr;
{
register unsigned char *s, *x;
register unsigned char *big;
- register int pos;
- register int previous;
- register int first;
+ register I32 pos;
+ register I32 previous;
+ register I32 first;
register unsigned char *little;
register unsigned char *bigend;
register unsigned char *littleend;
- if ((pos = screamfirst[littlestr->str_rare]) < 0)
+ if ((pos = screamfirst[BmRARE(littlestr)]) < 0)
return Nullch;
-#ifndef lint
- little = (unsigned char *)(littlestr->str_ptr);
-#else
- little = Null(unsigned char *);
-#endif
- littleend = little + littlestr->str_cur;
+ little = (unsigned char *)(SvPV(littlestr));
+ littleend = little + SvCUR(littlestr);
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;
+ previous = BmPREVIOUS(littlestr);
+ big = (unsigned char *)(SvPV(bigstr));
+ bigend = big + SvCUR(bigstr);
while (pos < previous) {
-#ifndef lint
if (!(pos += screamnext[pos]))
-#endif
return Nullch;
}
#ifdef POINTERRIGOR
- if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */
+ if (SvCASEFOLD(littlestr)) { /* case insignificant? */
do {
if (big[pos-previous] != first && big[pos-previous] != fold[first])
continue;
}
}
if (s == littleend)
-#ifndef lint
return (char *)(big+pos-previous);
-#else
- return Nullch;
-#endif
} while (
-#ifndef lint
pos += screamnext[pos] /* does this goof up anywhere? */
-#else
- pos += screamnext[0]
-#endif
);
}
else {
}
}
if (s == littleend)
-#ifndef lint
return (char *)(big+pos-previous);
-#else
- return Nullch;
-#endif
- } while (
-#ifndef lint
- pos += screamnext[pos]
-#else
- pos += screamnext[0]
-#endif
- );
+ } while ( pos += screamnext[pos] );
}
#else /* !POINTERRIGOR */
big -= previous;
- if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */
+ if (SvCASEFOLD(littlestr)) { /* case insignificant? */
do {
if (big[pos] != first && big[pos] != fold[first])
continue;
}
}
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 {
}
}
if (s == littleend)
-#ifndef lint
return (char *)(big+pos);
-#else
- return Nullch;
-#endif
} while (
-#ifndef lint
pos += screamnext[pos]
-#else
- pos += screamnext[0]
-#endif
);
}
#endif /* POINTERRIGOR */
return Nullch;
}
+I32
+ibcmp(a,b,len)
+register char *a;
+register char *b;
+register I32 len;
+{
+ while (len--) {
+ if (*a == *b) {
+ a++,b++;
+ continue;
+ }
+ if (fold[*a++] == *b++)
+ continue;
+ return 1;
+ }
+ return 0;
+}
+
/* copy a string to a safe spot */
char *
-savestr(str)
-char *str;
+savestr(sv)
+char *sv;
{
register char *newaddr;
- New(902,newaddr,strlen(str)+1,char);
- (void)strcpy(newaddr,str);
+ New(902,newaddr,strlen(sv)+1,char);
+ (void)strcpy(newaddr,sv);
return newaddr;
}
/* same thing but with a known length */
char *
-nsavestr(str, len)
-char *str;
-register int len;
+nsavestr(sv, len)
+char *sv;
+register I32 len;
{
register char *newaddr;
New(903,newaddr,len+1,char);
- Copy(str,newaddr,len,char); /* might not be null terminated */
+ Copy(sv,newaddr,len,char); /* 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)
+pv_grow(strptr,curlen,newlen)
char **strptr;
-int *curlen;
-int newlen;
+I32 *curlen;
+I32 newlen;
{
if (newlen > *curlen) { /* need more room? */
if (*curlen)
long a1, a2, a3, a4;
{
char *s;
- int usermess = strEQ(pat,"%s");
- STR *tmpstr;
+ I32 usermess = strEQ(pat,"%s");
+ SV *tmpstr;
s = buf;
if (usermess) {
- tmpstr = str_mortal(&str_undef);
- str_set(tmpstr, (char*)a1);
- *s++ = tmpstr->str_ptr[tmpstr->str_cur-1];
+ tmpstr = sv_mortalcopy(&sv_undef);
+ sv_setpv(tmpstr, (char*)a1);
+ *s++ = SvPV(tmpstr)[SvCUR(tmpstr)-1];
}
else {
(void)sprintf(s,pat,a1,a2,a3,a4);
}
if (s[-1] != '\n') {
- if (curcmd->c_line) {
+ if (curcop->cop_line) {
(void)sprintf(s," at %s line %ld",
- stab_val(curcmd->c_filestab)->str_ptr, (long)curcmd->c_line);
+ SvPV(GvSV(curcop->cop_filegv)), (long)curcop->cop_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_ename(last_in_stab),
- (long)stab_io(last_in_stab)->lines);
+ if (last_in_gv &&
+ GvIO(last_in_gv) &&
+ GvIO(last_in_gv)->lines ) {
+ (void)sprintf(s,", <%s> %s %ld",
+ last_in_gv == argvgv ? "" : GvENAME(last_in_gv),
+ strEQ(rs,"\n") ? "line" : "chunk",
+ (long)GvIO(last_in_gv)->lines);
s += strlen(s);
}
(void)strcpy(s,".\n");
if (usermess)
- str_cat(tmpstr,buf+1);
+ sv_catpv(tmpstr,buf+1);
}
if (usermess)
- return tmpstr->str_ptr;
+ return SvPV(tmpstr);
else
return buf;
}
char *pat;
long a1, a2, a3, a4;
{
- extern FILE *e_fp;
- extern char *e_tmpname;
char *tmps;
char *message;
message = mess(pat,a1,a2,a3,a4);
- if (in_eval) {
- str_set(stab_val(stabent("@",TRUE)),message);
- 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);
- }
+ XXX
fputs(message,stderr);
(void)fflush(stderr);
if (e_fp)
(void)UNLINK(e_tmpname);
statusvalue >>= 8;
- exit((int)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+ my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
}
/*VARARGS1*/
message = mess(pat,a1,a2,a3,a4);
fputs(message,stderr);
#ifdef LEAKTEST
-#ifdef DEBUGGING
- if (debug & 4096)
- xstat();
-#endif
+ DEBUG_L(xstat());
#endif
(void)fflush(stderr);
}
{
char *pat;
char *s;
- STR *tmpstr;
- int usermess;
+ SV *tmpstr;
+ I32 usermess;
#ifndef HAS_VPRINTF
#ifdef CHARVSPRINTF
char *vsprintf();
#else
- int vsprintf();
+ I32 vsprintf();
#endif
#endif
-#ifdef lint
- pat = Nullch;
-#else
pat = va_arg(args, char *);
-#endif
s = buf;
usermess = strEQ(pat, "%s");
if (usermess) {
- tmpstr = str_mortal(&str_undef);
- str_set(tmpstr, va_arg(args, char *));
- *s++ = tmpstr->str_ptr[tmpstr->str_cur-1];
+ tmpstr = sv_mortalcopy(&sv_undef);
+ sv_setpv(tmpstr, va_arg(args, char *));
+ *s++ = SvPV(tmpstr)[SvCUR(tmpstr)-1];
}
else {
(void) vsprintf(s,pat,args);
}
if (s[-1] != '\n') {
- if (curcmd->c_line) {
+ if (curcop->cop_line) {
(void)sprintf(s," at %s line %ld",
- stab_val(curcmd->c_filestab)->str_ptr, (long)curcmd->c_line);
+ SvPV(GvSV(curcop->cop_filegv)), (long)curcop->cop_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);
+ if (last_in_gv &&
+ GvIO(last_in_gv) &&
+ GvIO(last_in_gv)->lines ) {
+ (void)sprintf(s,", <%s> %s %ld",
+ last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
+ strEQ(rs,"\n") ? "line" : "chunk",
+ (long)GvIO(last_in_gv)->lines);
s += strlen(s);
}
(void)strcpy(s,".\n");
if (usermess)
- str_cat(tmpstr,buf+1);
+ sv_catpv(tmpstr,buf+1);
}
if (usermess)
- return tmpstr->str_ptr;
+ return SvPV(tmpstr);
else
return buf;
}
/*VARARGS0*/
-void fatal(va_alist)
+void
+fatal(va_alist)
va_dcl
{
va_list args;
- extern FILE *e_fp;
- extern char *e_tmpname;
char *tmps;
char *message;
-#ifndef lint
va_start(args);
-#else
- args = 0;
-#endif
message = mess(args);
va_end(args);
- if (in_eval) {
- str_set(stab_val(stabent("@",TRUE)),message);
- 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);
- }
+ if (restartop = die_where(message))
+ longjmp(top_env, 3);
fputs(message,stderr);
(void)fflush(stderr);
if (e_fp)
(void)UNLINK(e_tmpname);
statusvalue >>= 8;
- exit((int)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+ my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
}
/*VARARGS0*/
va_list args;
char *message;
-#ifndef lint
va_start(args);
-#else
- args = 0;
-#endif
message = mess(args);
va_end(args);
fputs(message,stderr);
#ifdef LEAKTEST
-#ifdef DEBUGGING
- if (debug & 4096)
- xstat();
-#endif
+ DEBUG_L(xstat());
#endif
(void)fflush(stderr);
}
my_setenv(nam,val)
char *nam, *val;
{
- register int i=envix(nam); /* where does it go? */
+ register I32 i=setenv_getix(nam); /* where does it go? */
if (environ == origenviron) { /* need we copy environment? */
- int j;
- int max;
+ I32 j;
+ I32 max;
char **tmpenv;
/*SUPPRESS 530*/
#endif /* MSDOS */
}
-int
-envix(nam)
+I32
+setenv_getix(nam)
char *nam;
{
- register int i, len = strlen(nam);
+ register I32 i, len = strlen(nam);
for (i = 0; environ[i]; i++) {
if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
}
#ifdef EUNICE
-int
+I32
unlnk(f) /* unlink all versions of a file */
char *f;
{
- int i;
+ I32 i;
for (i = 0; unlink(f) >= 0; i++) ;
return i ? 0 : -1;
my_bcopy(from,to,len)
register char *from;
register char *to;
-register int len;
+register I32 len;
{
char *retval = to;
char *
my_bzero(loc,len)
register char *loc;
-register int len;
+register I32 len;
{
char *retval = loc;
#endif
#ifndef HAS_MEMCMP
-int
+I32
my_memcmp(s1,s2,len)
register unsigned char *s1;
register unsigned char *s2;
-register int len;
+register I32 len;
{
- register int tmp;
+ register I32 tmp;
while (len--) {
if (tmp = *s1++ - *s2++)
#endif
}
-#ifdef DEBUGGING
int
vfprintf(fd, pat, args)
FILE *fd;
_doprnt(pat, args, fd);
return 0; /* wrong, but perl doesn't use the return value */
}
-#endif
#endif /* HAS_VPRINTF */
#endif /* I_VARARGS */
#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
fatal("Unknown BYTEORDER\n");
#else
- register int o;
- register int s;
+ register I32 o;
+ register I32 s;
for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
u.c[o & 0xf] = (l >> s) & 255;
#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
fatal("Unknown BYTEORDER\n");
#else
- register int o;
- register int s;
+ register I32 o;
+ register I32 s;
u.l = l;
l = 0;
type value; \
char c[sizeof(type)]; \
} u; \
- register int i; \
- register int s; \
+ register I32 i; \
+ register I32 s; \
for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
u.c[i] = (n >> s) & 0xFF; \
} \
type value; \
char c[sizeof(type)]; \
} u; \
- register int i; \
- register int s; \
+ register I32 i; \
+ register I32 s; \
u.value = n; \
n = 0; \
for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
#ifndef DOSISH
FILE *
-mypopen(cmd,mode)
+my_popen(cmd,mode)
char *cmd;
char *mode;
{
int p[2];
- register int this, that;
- register int pid;
- STR *str;
- int doexec = strNE(cmd,"-");
+ register I32 this, that;
+ register I32 pid;
+ SV *sv;
+ I32 doexec = strNE(cmd,"-");
if (pipe(p) < 0)
return Nullfp;
that = !this;
#ifdef TAINT
if (doexec) {
- taintenv();
- taintproper("Insecure dependency in exec");
+ taint_env();
+ TAINT_PROPER("exec");
}
#endif
while ((pid = (doexec?vfork():fork())) < 0) {
sleep(5);
}
if (pid == 0) {
+ GV* tmpgv;
+
#define THIS that
#define THAT this
close(p[THAT]);
close(p[THIS]);
}
if (doexec) {
-#if !defined(HAS_FCNTL) || !defined(F_SETFD)
+#if !defined(HAS_FCNTL) || !defined(FFt_SETFD)
int fd;
#ifndef NOFILE
_exit(1);
}
/*SUPPRESS 560*/
- if (tmpstab = stabent("$",allstabs))
- str_numset(STAB_STR(tmpstab),(double)getpid());
+ if (tmpgv = gv_fetchpv("$",allgvs))
+ sv_setiv(GvSV(tmpgv),(I32)getpid());
forkprocess = 0;
- hclear(pidstatus, FALSE); /* we have no children */
+ hv_clear(pidstatus, FALSE); /* we have no children */
return Nullfp;
#undef THIS
#undef THAT
close(p[this]);
p[this] = p[that];
}
- str = afetch(fdpid,p[this],TRUE);
- str->str_u.str_useful = pid;
+ sv = *av_fetch(fdpid,p[this],TRUE);
+ SvUPGRADE(sv,SVt_IV);
+ SvIV(sv) = pid;
forkprocess = pid;
return fdopen(p[this], mode);
}
#ifdef atarist
FILE *popen();
FILE *
-mypopen(cmd,mode)
+my_popen(cmd,mode)
char *cmd;
char *mode;
{
#endif /* !DOSISH */
#ifdef NOTDEF
-dumpfds(s)
+dump_fds(s)
char *s;
{
int fd;
int oldfd;
int newfd;
{
-#if defined(HAS_FCNTL) && defined(F_DUPFD)
+#if defined(HAS_FCNTL) && defined(FFt_DUPFD)
close(newfd);
- fcntl(oldfd, F_DUPFD, newfd);
+ fcntl(oldfd, FFt_DUPFD, newfd);
#else
int fdtmp[256];
- int fdx = 0;
+ I32 fdx = 0;
int fd;
if (oldfd == newfd)
#endif
#ifndef DOSISH
-int
-mypclose(ptr)
+I32
+my_pclose(ptr)
FILE *ptr;
{
#ifdef VOIDSIG
int (*hstat)(), (*istat)(), (*qstat)();
#endif
int status;
- STR *str;
+ SV *sv;
int pid;
- str = afetch(fdpid,fileno(ptr),TRUE);
- pid = (int)str->str_u.str_useful;
- astore(fdpid,fileno(ptr),Nullstr);
+ sv = *av_fetch(fdpid,fileno(ptr),TRUE);
+ pid = SvIV(sv);
+ av_store(fdpid,fileno(ptr),Nullsv);
fclose(ptr);
#ifdef UTS
if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
return(pid < 0 ? pid : status);
}
-int
+I32
wait4pid(pid,statusp,flags)
int pid;
int *statusp;
int flags;
{
-#if !defined(HAS_WAIT4) && !defined(HAS_WAITPID)
- int result;
- STR *str;
+ I32 result;
+ SV *sv;
+ SV** svp;
char spid[16];
-#endif
if (!pid)
return -1;
-#ifdef HAS_WAIT4
- return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
-#else
-#ifdef HAS_WAITPID
- return waitpid(pid,statusp,flags);
-#else
if (pid > 0) {
sprintf(spid, "%d", pid);
- str = hfetch(pidstatus,spid,strlen(spid),FALSE);
- if (str != &str_undef) {
- *statusp = (int)str->str_u.str_useful;
- hdelete(pidstatus,spid,strlen(spid));
+ svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
+ if (svp && *svp != &sv_undef) {
+ *statusp = SvIV(*svp);
+ hv_delete(pidstatus,spid,strlen(spid));
return pid;
}
}
else {
- HENT *entry;
+ HE *entry;
- hiterinit(pidstatus);
- if (entry = hiternext(pidstatus)) {
- pid = atoi(hiterkey(entry,statusp));
- str = hiterval(pidstatus,entry);
- *statusp = (int)str->str_u.str_useful;
+ hv_iterinit(pidstatus);
+ if (entry = hv_iternext(pidstatus)) {
+ pid = atoi(hv_iterkey(entry,statusp));
+ sv = hv_iterval(pidstatus,entry);
+ *statusp = SvIV(sv);
sprintf(spid, "%d", pid);
- hdelete(pidstatus,spid,strlen(spid));
+ hv_delete(pidstatus,spid,strlen(spid));
return pid;
}
}
+#ifdef HAS_WAIT4
+ return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
+#else
+#ifdef HAS_WAITPID
+ return waitpid(pid,statusp,flags);
+#else
if (flags)
fatal("Can't do waitpid with flags");
else {
int pid;
int status;
{
-#if defined(HAS_WAIT4) || defined(HAS_WAITPID)
-#else
- register STR *str;
+ register SV *sv;
char spid[16];
sprintf(spid, "%d", pid);
- str = hfetch(pidstatus,spid,strlen(spid),TRUE);
- str->str_u.str_useful = status;
-#endif
+ sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
+ SvUPGRADE(sv,SVt_IV);
+ SvIV(sv) = status;
return;
}
#ifdef atarist
int pclose();
-int
-mypclose(ptr)
+I32
+my_pclose(ptr)
FILE *ptr;
{
return pclose(ptr);
repeatcpy(to,from,len,count)
register char *to;
register char *from;
-int len;
-register int count;
+I32 len;
+register I32 count;
{
- register int todo;
+ register I32 todo;
register char *frombase = from;
if (len == 1) {
#ifndef CASTNEGFLOAT
unsigned long
-castulong(f)
+cast_ulong(f)
double f;
{
long along;
#endif
#ifndef HAS_RENAME
-int
+I32
same_dirent(a,b)
char *a;
char *b;
#endif /* !HAS_RENAME */
unsigned long
-scanoct(start, len, retlen)
+scan_oct(start, len, retlen)
char *start;
-int len;
-int *retlen;
+I32 len;
+I32 *retlen;
{
register char *s = start;
register unsigned long retval = 0;
}
unsigned long
-scanhex(start, len, retlen)
+scan_hex(start, len, retlen)
char *start;
-int len;
-int *retlen;
+I32 len;
+I32 *retlen;
{
register char *s = start;
register unsigned long retval = 0;
-/* $RCSfile: util.h,v $$Revision: 4.0.1.4 $$Date: 92/06/11 21:19:36 $
+/* $RCSfile: util.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:03 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: util.h,v $
+ * Revision 4.1 92/08/07 18:29:03 lwall
+ *
* Revision 4.0.1.4 92/06/11 21:19:36 lwall
* patch34: pidgone() wasn't declared right
*
* 4.0 baseline.
*
*/
-
-EXT int *screamfirst INIT(Null(int*));
-EXT int *screamnext INIT(Null(int*));
-
-#ifndef safemalloc
-char *safemalloc();
-char *saferealloc();
-#endif
-char *cpytill();
-char *instr();
-char *fbminstr();
-char *screaminstr();
-void fbmcompile();
-char *savestr();
-void my_setenv();
-int envix();
-void growstr();
-char *ninstr();
-char *rninstr();
-char *nsavestr();
-FILE *mypopen();
-int mypclose();
-#if !defined(HAS_BCOPY) || !defined(SAFE_BCOPY)
-char *my_bcopy();
-#endif
-#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
-char *my_bzero();
-#endif
-#ifndef HAS_MEMCMP
-int my_memcmp();
-#endif
-unsigned long scanoct();
-unsigned long scanhex();
-void pidgone();
-/* $RCSfile: EXTERN.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:11:15 $
+/* $RCSfile: EXTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:05 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: EXTERN.h,v $
+ * Revision 4.1 92/08/07 18:29:05 lwall
+ *
* Revision 4.0.1.1 91/06/07 12:11:15 lwall
* patch4: new copyright notice
*
-/* $RCSfile: INTERN.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:11:20 $
+/* $RCSfile: INTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:06 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: INTERN.h,v $
+ * Revision 4.1 92/08/07 18:29:06 lwall
+ *
* Revision 4.0.1.1 91/06/07 12:11:20 lwall
* patch4: new copyright notice
*
--- /dev/null
+# : Makefile.SH,v 15738Revision: 4.1 15738Date: 92/08/07 18:29:07 $
+#
+# $Log: Makefile.SH,v $
+# Revision 4.1 92/08/07 18:29:07 lwall
+#
+# Revision 4.0.1.3 92/06/08 16:11:32 lwall
+# patch20: SH files didn't work well with symbolic links
+# patch20: cray didn't give enough memory to /bin/sh
+# patch20: makefiles now display new shift/reduce expectations
+#
+# Revision 4.0.1.2 91/11/05 19:19:04 lwall
+# patch11: random cleanup
+#
+# Revision 4.0.1.1 91/06/07 12:12:14 lwall
+# patch4: cflags now emits entire cc command except for the filename
+#
+# Revision 4.0 91/03/20 01:57:03 lwall
+# 4.0 baseline.
+#
+#
+
+CC = cc
+YACC = /bin/yacc
+bin = /usr/local/bin
+lib =
+mansrc = /usr/man/manl
+manext = l
+LDFLAGS =
+SMALL =
+LARGE =
+mallocsrc = malloc.c
+mallocobj = malloc.o
+shellflags =
+
+libs = -ldbm -lm -lposix
+
+CCCMD = `sh $(shellflags) cflags $@`
+
+public = a2p s2p find2perl
+
+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:
+ $(CCCMD) $*.c
+
+all: $(public) $(private) $(util)
+ touch all
+
+a2p: $(obj) a2p.o
+ $(CC) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p
+
+a2p.c: a2p.y
+ @ echo Expect 231 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 str.h hash.h
+ $(CCCMD) $(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
+ - if test `pwd` != $(mansrc); then \
+for page in $(manpages); do \
+cp $$page $(mansrc)/`basename $$page .man`.$(manext); \
+done; \
+fi
+
+clean:
+ rm -f a2p *.o a2p.c
+
+realclean: clean
+ rm -f *.orig */*.orig core $(addedbyconf) a2p.c s2p find2perl all cflags
+
+# 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: $(mallocsrc) ../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 .
+
+malloc.c: ../malloc.c
+ sed <../malloc.c >malloc.c \
+ -e 's/"perl.h"/"..\/perl.h"/' \
+ -e 's/my_exit/exit/'
+
+# 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 $(shellflags) makedepend.SH
echo "Extracting x2p/Makefile (with variable substitutions)"
rm -f Makefile
cat >Makefile <<!GROK!THIS!
-# $RCSfile: Makefile.SH,v $$Revision: 4.0.1.3 $$Date: 92/06/08 16:11:32 $
+# $RCSfile: Makefile.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:07 $
#
# $Log: Makefile.SH,v $
+# Revision 4.1 92/08/07 18:29:07 lwall
+#
# Revision 4.0.1.3 92/06/08 16:11:32 lwall
# patch20: SH files didn't work well with symbolic links
# patch20: cray didn't give enough memory to /bin/sh
ln ../config.sh .
malloc.c: ../malloc.c
- sed 's/"perl.h"/"..\/perl.h"/' ../malloc.c >malloc.c
+ sed <../malloc.c >malloc.c \
+ -e 's/"perl.h"/"..\/perl.h"/' \
+ -e 's/my_exit/exit/'
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
$(obj):
--- /dev/null
+extern char *malloc(), *realloc();
+
+# line 2 "a2p.y"
+/* $RCSfile: a2p.y,v $$Revision: 4.0.1.2 $$Date: 92/06/08 16:13:03 $
+ *
+ * Copyright (c) 1991, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: a2p.y,v $
+ * Revision 4.0.1.2 92/06/08 16:13:03 lwall
+ * patch20: in a2p, getline should allow variable to be array element
+ *
+ * Revision 4.0.1.1 91/06/07 12:12:41 lwall
+ * patch4: new copyright notice
+ *
+ * Revision 4.0 91/03/20 01:57:21 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "INTERN.h"
+#include "a2p.h"
+
+int root;
+int begins = Nullop;
+int ends = Nullop;
+
+# define BEGIN 257
+# define END 258
+# define REGEX 259
+# define SEMINEW 260
+# define NEWLINE 261
+# define COMMENT 262
+# define FUN1 263
+# define FUNN 264
+# define GRGR 265
+# define PRINT 266
+# define PRINTF 267
+# define SPRINTF 268
+# define SPLIT 269
+# define IF 270
+# define ELSE 271
+# define WHILE 272
+# define FOR 273
+# define IN 274
+# define EXIT 275
+# define NEXT 276
+# define BREAK 277
+# define CONTINUE 278
+# define RET 279
+# define GETLINE 280
+# define DO 281
+# define SUB 282
+# define GSUB 283
+# define MATCH 284
+# define FUNCTION 285
+# define USERFUN 286
+# define DELETE 287
+# define ASGNOP 288
+# define OROR 289
+# define ANDAND 290
+# define NUMBER 291
+# define VAR 292
+# define SUBSTR 293
+# define INDEX 294
+# define MATCHOP 295
+# define RELOP 296
+# define OR 297
+# define STRING 298
+# define UMINUS 299
+# define NOT 300
+# define INCR 301
+# define DECR 302
+# define FIELD 303
+# define VFIELD 304
+#define yyclearin yychar = -1
+#define yyerrok yyerrflag = 0
+extern int yychar;
+extern int yyerrflag;
+#ifndef YYMAXDEPTH
+#define YYMAXDEPTH 150
+#endif
+#ifndef YYSTYPE
+#define YYSTYPE int
+#endif
+YYSTYPE yylval, yyval;
+# define YYERRCODE 256
+
+# line 402 "a2p.y"
+
+#include "a2py.c"
+int yyexca[] ={
+-1, 1,
+ 0, -1,
+ -2, 0,
+ };
+# define YYNPROD 137
+# define YYLAST 3142
+int yyact[]={
+
+ 63, 44, 156, 32, 50, 31, 222, 73, 74, 75,
+ 210, 53, 45, 46, 124, 49, 86, 307, 104, 158,
+ 74, 75, 52, 54, 53, 302, 126, 271, 306, 265,
+ 106, 107, 270, 245, 51, 157, 269, 21, 56, 92,
+ 2, 131, 55, 20, 48, 72, 19, 90, 69, 132,
+ 47, 196, 241, 102, 100, 272, 195, 193, 109, 110,
+ 111, 112, 253, 76, 79, 252, 72, 139, 15, 77,
+ 237, 68, 78, 311, 236, 160, 66, 64, 309, 65,
+ 293, 67, 187, 174, 255, 139, 198, 184, 183, 130,
+ 68, 80, 179, 129, 5, 66, 64, 71, 65, 128,
+ 67, 68, 286, 214, 199, 212, 66, 211, 105, 103,
+ 99, 67, 98, 97, 96, 95, 71, 108, 94, 89,
+ 88, 152, 87, 4, 153, 10, 9, 200, 69, 14,
+ 177, 178, 239, 140, 13, 3, 136, 137, 127, 1,
+ 0, 0, 0, 185, 186, 0, 72, 69, 151, 0,
+ 0, 154, 0, 0, 0, 0, 0, 0, 69, 0,
+ 0, 0, 0, 204, 205, 72, 0, 106, 107, 0,
+ 0, 0, 0, 0, 175, 176, 72, 213, 0, 215,
+ 76, 0, 140, 0, 0, 0, 77, 0, 0, 78,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 230, 231, 232, 233, 234, 235, 0,
+ 206, 207, 0, 0, 0, 0, 244, 0, 0, 0,
+ 159, 106, 107, 34, 35, 0, 162, 163, 37, 39,
+ 170, 0, 171, 173, 248, 166, 165, 164, 167, 168,
+ 33, 172, 42, 43, 41, 161, 36, 169, 44, 18,
+ 247, 27, 44, 38, 40, 54, 53, 249, 28, 45,
+ 46, 29, 30, 45, 46, 54, 53, 54, 53, 0,
+ 282, 18, 18, 238, 284, 285, 242, 243, 289, 290,
+ 54, 53, 240, 91, 54, 53, 0, 299, 300, 54,
+ 53, 0, 304, 0, 0, 6, 7, 8, 18, 0,
+ 0, 298, 0, 113, 114, 115, 116, 63, 70, 18,
+ 32, 310, 31, 313, 312, 315, 314, 316, 0, 18,
+ 0, 0, 303, 0, 247, 0, 158, 70, 201, 202,
+ 203, 0, 133, 135, 91, 91, 308, 287, 247, 141,
+ 143, 144, 145, 146, 147, 149, 91, 0, 0, 91,
+ 0, 301, 0, 0, 0, 18, 18, 0, 0, 0,
+ 63, 0, 0, 32, 0, 31, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 181, 158,
+ 0, 0, 0, 0, 0, 0, 0, 0, 141, 0,
+ 174, 0, 305, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 91, 91,
+ 63, 0, 208, 32, 209, 31, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 158,
+ 0, 219, 220, 0, 221, 0, 223, 225, 226, 227,
+ 228, 229, 0, 174, 0, 274, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 18, 18, 0,
+ 246, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 63, 0, 0, 32, 0, 31, 0, 0,
+ 0, 0, 266, 0, 0, 0, 267, 268, 0, 0,
+ 0, 158, 0, 174, 0, 217, 275, 0, 276, 0,
+ 0, 0, 0, 0, 278, 0, 279, 0, 280, 0,
+ 281, 0, 0, 0, 0, 0, 0, 0, 18, 0,
+ 0, 0, 0, 0, 0, 0, 0, 159, 0, 0,
+ 34, 35, 18, 162, 163, 37, 39, 170, 0, 171,
+ 173, 0, 166, 165, 164, 167, 168, 33, 172, 42,
+ 43, 41, 0, 36, 169, 174, 0, 216, 27, 44,
+ 38, 40, 0, 0, 0, 28, 0, 0, 29, 30,
+ 45, 46, 63, 0, 0, 32, 0, 31, 0, 0,
+ 159, 0, 0, 34, 35, 0, 162, 163, 37, 39,
+ 170, 0, 171, 173, 0, 166, 165, 164, 167, 168,
+ 33, 172, 42, 43, 41, 0, 36, 169, 0, 0,
+ 0, 27, 44, 38, 40, 0, 0, 0, 28, 0,
+ 0, 29, 30, 45, 46, 0, 25, 0, 0, 32,
+ 159, 31, 0, 34, 35, 0, 162, 163, 37, 39,
+ 170, 0, 171, 173, 0, 166, 165, 164, 167, 168,
+ 33, 172, 42, 43, 41, 0, 36, 169, 0, 0,
+ 0, 27, 44, 38, 40, 0, 0, 0, 28, 0,
+ 0, 29, 30, 45, 46, 63, 0, 0, 32, 0,
+ 31, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 159, 0, 158, 34, 35, 0, 162, 163,
+ 37, 39, 170, 0, 171, 173, 0, 166, 165, 164,
+ 167, 168, 33, 172, 42, 43, 41, 0, 36, 169,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 0, 29, 30, 45, 46, 63, 0, 0,
+ 32, 0, 31, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 158, 0, 174, 0,
+ 197, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 63, 0, 0, 32, 138, 31, 0, 0,
+ 0, 0, 0, 0, 0, 34, 35, 0, 162, 163,
+ 37, 39, 59, 0, 58, 0, 0, 166, 165, 164,
+ 167, 168, 33, 0, 42, 43, 41, 0, 36, 169,
+ 174, 0, 155, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 0, 29, 30, 45, 46, 0, 0, 0,
+ 0, 0, 0, 0, 0, 24, 0, 106, 107, 34,
+ 35, 0, 0, 0, 37, 39, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 33, 0, 42, 43,
+ 41, 0, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 0, 26, 29, 30, 45,
+ 46, 0, 0, 0, 0, 159, 0, 0, 34, 35,
+ 0, 162, 163, 37, 39, 170, 0, 171, 173, 0,
+ 166, 165, 164, 167, 168, 33, 172, 42, 43, 41,
+ 63, 36, 169, 32, 0, 31, 27, 44, 38, 40,
+ 0, 0, 0, 28, 0, 0, 29, 30, 45, 46,
+ 59, 0, 58, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 159, 0, 0,
+ 34, 35, 0, 162, 163, 37, 39, 170, 0, 171,
+ 173, 0, 166, 165, 164, 167, 168, 33, 172, 42,
+ 43, 41, 0, 36, 169, 23, 0, 0, 27, 44,
+ 38, 40, 0, 0, 0, 28, 0, 0, 29, 30,
+ 45, 46, 0, 0, 62, 34, 35, 0, 0, 0,
+ 37, 39, 0, 0, 0, 81, 82, 62, 62, 85,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 62, 27, 44, 38, 40, 60, 57, 0,
+ 28, 0, 0, 29, 30, 45, 46, 0, 0, 0,
+ 62, 62, 62, 62, 62, 62, 25, 62, 0, 32,
+ 0, 31, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 62, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 62,
+ 62, 62, 62, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 180, 0, 0, 0, 0, 0, 0, 62,
+ 63, 62, 0, 32, 0, 31, 0, 62, 0, 62,
+ 62, 62, 62, 62, 0, 62, 0, 0, 0, 12,
+ 0, 0, 0, 34, 35, 0, 0, 62, 37, 39,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 33, 0, 42, 43, 41, 62, 36, 62, 0, 0,
+ 0, 27, 44, 38, 40, 60, 57, 0, 28, 0,
+ 0, 29, 30, 45, 46, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 62, 62, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 62, 62, 62, 0, 62,
+ 0, 62, 62, 62, 62, 62, 0, 0, 0, 0,
+ 0, 0, 0, 22, 0, 0, 0, 0, 0, 0,
+ 0, 0, 62, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 61, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 62, 62, 62, 83, 84, 0, 0, 0,
+ 0, 62, 62, 0, 62, 62, 62, 62, 0, 0,
+ 101, 0, 0, 16, 17, 24, 0, 0, 0, 34,
+ 35, 0, 0, 0, 37, 39, 0, 0, 118, 119,
+ 120, 121, 122, 123, 0, 125, 33, 0, 42, 43,
+ 41, 11, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 61, 26, 29, 30, 45,
+ 46, 0, 25, 0, 0, 32, 0, 31, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 61, 61, 61,
+ 61, 288, 0, 34, 35, 0, 0, 0, 37, 39,
+ 0, 0, 0, 0, 0, 0, 0, 61, 0, 61,
+ 33, 0, 42, 43, 41, 61, 36, 61, 61, 61,
+ 61, 61, 25, 61, 0, 32, 0, 31, 28, 0,
+ 0, 29, 30, 45, 46, 61, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 218, 0, 61, 0, 0, 0, 0,
+ 0, 0, 0, 0, 63, 263, 0, 32, 264, 31,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 61, 61, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 61, 61, 61, 0, 61, 0, 61,
+ 61, 61, 61, 61, 0, 0, 63, 261, 0, 32,
+ 262, 31, 0, 0, 0, 0, 0, 0, 0, 0,
+ 61, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 61, 61, 61, 0, 0, 0, 0, 0, 0, 61,
+ 61, 0, 61, 61, 61, 61, 63, 259, 0, 32,
+ 260, 31, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 24, 0, 0, 0, 34, 35, 0, 0, 0,
+ 37, 39, 63, 257, 0, 32, 258, 31, 0, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 26, 29, 30, 45, 46, 0, 0, 0,
+ 0, 24, 0, 0, 0, 34, 35, 0, 0, 0,
+ 37, 39, 63, 251, 0, 32, 250, 31, 0, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 26, 29, 30, 45, 46, 34, 35, 0,
+ 0, 0, 37, 39, 0, 0, 63, 0, 0, 32,
+ 0, 31, 0, 0, 33, 0, 42, 43, 41, 0,
+ 36, 0, 0, 0, 0, 27, 44, 38, 40, 0,
+ 0, 0, 28, 0, 0, 29, 30, 45, 46, 34,
+ 35, 0, 0, 0, 37, 39, 0, 0, 0, 0,
+ 0, 0, 142, 0, 0, 32, 33, 31, 42, 43,
+ 41, 0, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 0, 0, 29, 30, 45,
+ 46, 0, 0, 0, 0, 0, 0, 0, 0, 34,
+ 35, 0, 0, 0, 37, 39, 63, 297, 0, 32,
+ 0, 31, 0, 0, 0, 0, 33, 0, 42, 43,
+ 41, 0, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 0, 0, 29, 30, 45,
+ 46, 0, 0, 0, 0, 34, 35, 0, 0, 0,
+ 37, 39, 63, 296, 0, 32, 0, 31, 0, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 0, 29, 30, 45, 46, 0, 0, 0,
+ 0, 0, 0, 0, 0, 34, 35, 0, 0, 0,
+ 37, 39, 63, 295, 0, 32, 0, 31, 0, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 0, 29, 30, 45, 46, 106, 107, 34,
+ 35, 0, 0, 0, 37, 39, 63, 294, 0, 32,
+ 0, 31, 0, 0, 0, 0, 33, 0, 42, 43,
+ 41, 0, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 0, 0, 29, 30, 45,
+ 46, 24, 0, 0, 0, 34, 35, 0, 0, 0,
+ 37, 39, 63, 292, 0, 32, 0, 31, 0, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 26, 29, 30, 45, 46, 0, 0, 34,
+ 35, 0, 0, 0, 37, 39, 63, 291, 0, 32,
+ 0, 31, 0, 0, 0, 0, 33, 0, 42, 43,
+ 41, 0, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 0, 0, 29, 30, 45,
+ 46, 0, 0, 0, 0, 34, 35, 0, 0, 63,
+ 37, 39, 32, 0, 31, 0, 0, 0, 0, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 0, 29, 30, 45, 46, 0, 0, 0,
+ 0, 0, 0, 0, 0, 34, 35, 0, 0, 0,
+ 37, 39, 283, 63, 0, 0, 32, 0, 31, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 0, 29, 30, 45, 46, 0, 0, 34,
+ 35, 0, 0, 0, 37, 39, 63, 273, 0, 32,
+ 0, 31, 0, 0, 0, 0, 33, 0, 42, 43,
+ 41, 0, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 0, 0, 29, 30, 45,
+ 46, 0, 0, 0, 0, 34, 35, 0, 0, 0,
+ 37, 39, 63, 256, 0, 32, 0, 31, 0, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 0, 29, 30, 45, 46, 0, 0, 34,
+ 35, 0, 0, 0, 37, 39, 63, 254, 0, 32,
+ 0, 31, 0, 0, 0, 0, 33, 0, 42, 43,
+ 41, 0, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 0, 0, 29, 30, 45,
+ 46, 0, 34, 35, 0, 0, 0, 37, 39, 0,
+ 0, 0, 63, 0, 0, 32, 0, 31, 0, 33,
+ 0, 42, 43, 41, 0, 36, 0, 0, 0, 0,
+ 27, 44, 38, 40, 0, 0, 0, 28, 0, 0,
+ 29, 30, 45, 46, 0, 0, 0, 0, 0, 0,
+ 0, 0, 277, 0, 0, 63, 34, 35, 32, 194,
+ 31, 37, 39, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 33, 0, 42, 43, 41, 0, 36,
+ 0, 0, 0, 0, 27, 44, 38, 40, 0, 0,
+ 0, 28, 0, 0, 29, 30, 45, 46, 63, 34,
+ 35, 32, 192, 31, 37, 39, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 33, 0, 42, 43,
+ 41, 0, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 0, 0, 29, 30, 45,
+ 46, 0, 0, 0, 63, 34, 35, 32, 191, 31,
+ 37, 39, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 0, 29, 30, 45, 46, 0, 63, 34,
+ 35, 32, 190, 31, 37, 39, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 33, 0, 42, 43,
+ 41, 0, 36, 0, 0, 0, 0, 27, 44, 38,
+ 40, 0, 0, 0, 28, 0, 0, 29, 30, 45,
+ 46, 224, 0, 0, 63, 34, 35, 32, 189, 31,
+ 37, 39, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 33, 0, 42, 43, 41, 0, 36, 0,
+ 0, 0, 0, 27, 44, 38, 40, 0, 0, 0,
+ 28, 0, 0, 29, 30, 45, 46, 63, 34, 35,
+ 32, 188, 31, 37, 39, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 33, 0, 42, 43, 41,
+ 0, 36, 0, 0, 0, 0, 27, 44, 38, 40,
+ 0, 0, 0, 28, 0, 0, 29, 30, 45, 46,
+ 0, 34, 35, 0, 0, 0, 37, 39, 63, 182,
+ 0, 32, 0, 31, 0, 0, 0, 0, 33, 0,
+ 42, 43, 41, 0, 36, 0, 0, 0, 0, 27,
+ 44, 38, 40, 0, 0, 0, 28, 0, 0, 29,
+ 30, 45, 46, 0, 0, 0, 0, 34, 35, 0,
+ 0, 0, 37, 39, 63, 0, 0, 32, 0, 31,
+ 0, 0, 0, 0, 33, 0, 42, 43, 41, 0,
+ 36, 0, 0, 0, 0, 27, 44, 38, 40, 0,
+ 0, 0, 28, 0, 0, 29, 30, 45, 46, 0,
+ 0, 34, 35, 0, 0, 0, 37, 39, 0, 0,
+ 63, 0, 0, 32, 0, 31, 0, 0, 33, 0,
+ 42, 43, 41, 0, 36, 0, 0, 0, 0, 27,
+ 44, 38, 40, 0, 0, 0, 28, 0, 0, 29,
+ 30, 45, 46, 0, 0, 0, 0, 34, 35, 0,
+ 0, 0, 37, 39, 63, 0, 0, 32, 138, 31,
+ 0, 0, 0, 0, 33, 0, 42, 43, 41, 0,
+ 36, 0, 0, 0, 0, 27, 44, 38, 40, 0,
+ 0, 0, 28, 0, 0, 29, 30, 45, 46, 0,
+ 34, 35, 0, 0, 0, 37, 39, 63, 134, 0,
+ 32, 0, 31, 0, 0, 0, 0, 33, 0, 42,
+ 43, 41, 0, 36, 0, 0, 0, 0, 27, 44,
+ 38, 40, 0, 0, 0, 28, 0, 0, 29, 30,
+ 45, 46, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 34, 35, 0, 0, 63, 37, 39, 32, 0,
+ 31, 0, 0, 0, 0, 0, 0, 0, 33, 0,
+ 42, 43, 41, 0, 36, 0, 0, 0, 0, 27,
+ 44, 38, 40, 0, 0, 0, 28, 0, 0, 29,
+ 30, 45, 46, 150, 0, 0, 0, 34, 35, 0,
+ 0, 63, 37, 39, 32, 0, 31, 0, 0, 0,
+ 0, 0, 0, 0, 33, 0, 42, 43, 41, 0,
+ 36, 0, 0, 0, 0, 27, 44, 38, 40, 0,
+ 0, 0, 28, 0, 0, 29, 30, 45, 46, 148,
+ 0, 0, 0, 34, 35, 0, 0, 93, 37, 39,
+ 32, 0, 31, 0, 0, 0, 0, 0, 0, 0,
+ 33, 0, 42, 43, 41, 0, 36, 0, 0, 0,
+ 0, 27, 44, 38, 40, 0, 0, 0, 28, 0,
+ 0, 29, 30, 45, 46, 0, 0, 34, 35, 0,
+ 0, 0, 37, 39, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 33, 0, 42, 43, 41, 0,
+ 36, 0, 0, 0, 0, 27, 44, 38, 40, 0,
+ 0, 0, 28, 0, 0, 29, 30, 45, 46, 0,
+ 34, 35, 0, 0, 0, 37, 39, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 33, 0, 42,
+ 43, 41, 0, 36, 0, 0, 0, 0, 27, 44,
+ 38, 40, 0, 0, 0, 28, 0, 0, 29, 30,
+ 45, 46, 0, 0, 117, 0, 0, 0, 34, 35,
+ 0, 0, 0, 37, 39, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 33, 0, 42, 43, 41,
+ 0, 36, 0, 0, 0, 0, 27, 44, 38, 40,
+ 0, 0, 0, 28, 0, 0, 29, 30, 45, 46,
+ 0, 0, 0, 0, 34, 35, 0, 0, 0, 37,
+ 39, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 33, 0, 42, 43, 41, 0, 36, 0, 0,
+ 0, 0, 27, 44, 38, 40, 0, 0, 0, 28,
+ 0, 0, 29, 30, 45, 46, 0, 0, 0, 0,
+ 34, 35, 0, 0, 0, 37, 39, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 33, 0, 42,
+ 43, 41, 0, 36, 0, 0, 0, 0, 27, 44,
+ 38, 40, 0, 0, 0, 28, 0, 0, 29, 30,
+ 45, 46 };
+int yypact[]={
+
+ -1000, -1000, 35, 1016, -1000, -1000, -1000, -1000, -1000, -1000,
+ -79, -271, -1000, -1000, -227, -22, -81, -85, 880, -1000,
+ -1000, -1000, 53, -281, -1000, 1332, 1332, -1000, -1000, -291,
+ -291, 2791, 2791, -44, 82, 80, 79, 2837, 78, 75,
+ 74, 73, 72, 70, -37, -1000, 2791, 35, -1000, 69,
+ -231, -1000, 1332, -1000, -1000, -1000, -1000, 2791, 2791, 2791,
+ 2745, 53, -293, 1332, 2791, 2791, 2791, 2791, 2791, 2791,
+ -278, 2791, -254, 1332, -1000, -1000, 58, 52, 48, 0,
+ -1000, -1000, -1000, -46, -46, -11, 2791, 2697, 2837, 2837,
+ -1000, 2654, 23, 1652, 2791, 2791, 2791, 2791, 2610, 2564,
+ 2837, -67, -231, 2837, 697, -1000, -1000, -1000, -266, 586,
+ 586, -231, -231, 1080, 1080, 1080, 1080, -1000, 64, 64,
+ -46, -46, -46, -46, -1000, 34, -291, -266, -1000, -1000,
+ -1000, -1000, 2791, 1080, -1000, 2518, 47, 46, -1000, -1000,
+ 41, 742, 1652, 2467, 2424, 2378, 2334, 2288, 13, 2245,
+ 12, -42, 635, 45, -1000, -1000, -1000, 68, -1000, -1000,
+ -1000, 2791, 2837, 2837, -1000, -1000, 2791, -1000, 2791, -282,
+ 67, 65, -1000, 63, -1000, -1000, -279, 432, 370, 2791,
+ -1000, 1080, -1000, -1000, -1000, 1606, 1606, -1000, 2791, -286,
+ 2791, 2202, 2791, 2791, 2791, 2791, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -1000, -231, -231, 8, 8, 2791, 2791,
+ -39, 1332, 1332, -40, 532, -231, -1000, -1000, 53, 2791,
+ 2791, 1562, 21, 2156, 43, 2112, 1512, 1466, 1416, 1374,
+ -94, -231, -231, -231, -231, -231, 2791, -1000, -1000, -1000,
+ 2791, 2791, -5, -9, -245, -4, 2066, -1000, 320, 35,
+ 2791, -1000, 2023, -1000, -1000, -1000, -1000, -1000, 2791, -1000,
+ 2791, -1000, 2791, -1000, 2791, -1000, 2791, 2791, 1969, -1000,
+ -1000, 62, 1282, -1000, -1000, 1926, 1882, 39, 1836, 1792,
+ 1742, 1696, -231, -1000, -40, -40, 1332, -34, 532, -40,
+ -231, -1000, -1000, -1000, -1000, -1000, -1000, -1000, 267, -243,
+ -1000, -24, 532, 37, -1000, -1000, -1000, -1000, 32, -1000,
+ -40, -1000, -40, -1000, -40, -1000, -1000 };
+int yypgo[]={
+
+ 0, 139, 40, 135, 134, 4, 18, 129, 126, 125,
+ 124, 47, 64, 245, 46, 43, 37, 1223, 985, 39,
+ 123, 108, 104, 2, 35, 75, 33, 74 };
+int yyr1[]={
+
+ 0, 1, 4, 7, 7, 3, 3, 8, 8, 8,
+ 8, 8, 8, 10, 9, 9, 12, 12, 12, 12,
+ 16, 16, 16, 16, 15, 15, 15, 15, 14, 14,
+ 14, 14, 13, 13, 13, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 18, 18, 18, 18, 11, 11, 11, 19, 19,
+ 19, 2, 2, 20, 20, 20, 20, 5, 5, 21,
+ 21, 22, 22, 22, 22, 6, 6, 23, 23, 23,
+ 23, 26, 26, 24, 24, 24, 24, 24, 24, 24,
+ 24, 24, 24, 24, 24, 24, 27, 27, 27, 25,
+ 25, 25, 25, 25, 25, 25, 25 };
+int yyr2[]={
+
+ 0, 5, 13, 11, 5, 7, 1, 3, 11, 21,
+ 9, 2, 2, 3, 3, 7, 2, 2, 2, 2,
+ 7, 9, 9, 5, 7, 7, 7, 7, 7, 7,
+ 3, 7, 3, 5, 7, 3, 3, 3, 7, 7,
+ 7, 7, 7, 7, 7, 11, 5, 5, 5, 5,
+ 5, 5, 7, 3, 5, 7, 9, 7, 9, 3,
+ 7, 9, 9, 9, 5, 17, 13, 17, 17, 13,
+ 13, 13, 13, 13, 13, 13, 13, 17, 17, 17,
+ 17, 3, 9, 3, 5, 2, 2, 1, 9, 9,
+ 7, 5, 1, 3, 3, 3, 3, 5, 1, 3,
+ 3, 5, 5, 5, 5, 5, 1, 7, 5, 5,
+ 2, 2, 1, 2, 9, 5, 9, 5, 3, 3,
+ 3, 5, 3, 3, 5, 11, 3, 3, 3, 13,
+ 19, 13, 15, 21, 19, 13, 11 };
+int yychk[]={
+
+ -1000, -1, -2, -3, -20, 59, 260, 261, 262, -8,
+ -9, 285, 123, -4, -7, -12, 257, 258, -13, -14,
+ -15, -16, -17, -18, 259, 40, 300, 291, 298, 301,
+ 302, 45, 43, 280, 263, 264, 286, 268, 293, 269,
+ 294, 284, 282, 283, 292, 303, 304, -2, 123, 286,
+ -5, 261, 44, 290, 289, 123, 123, 296, 62, 60,
+ 295, -17, -18, 40, 43, 45, 42, 47, 37, 94,
+ 274, 63, 112, 288, 301, 302, -16, -15, -14, -12,
+ -12, -18, -18, -17, -17, -18, 60, 40, 40, 40,
+ -11, -13, -19, 40, 40, 40, 40, 40, 40, 40,
+ 91, -17, -5, 40, -6, -21, 261, 262, -12, -5,
+ -5, -5, -5, -13, -13, -13, -13, 259, -17, -17,
+ -17, -17, -17, -17, 292, -17, 280, -12, 41, 41,
+ 41, 41, 60, -13, 41, -13, -11, -11, 44, 44,
+ -19, -13, 40, -13, -13, -13, -13, -13, 259, -13,
+ 259, -11, -6, -10, -11, 125, -23, -24, 59, 260,
+ -25, -13, 266, 267, 277, 276, 275, 278, 279, 287,
+ 270, 272, 281, 273, 123, -12, -12, -6, -6, 58,
+ -18, -13, 41, 41, 41, -5, -5, 41, 44, 44,
+ 44, 44, 44, 44, 44, 44, 93, 125, 41, -22,
+ 59, 260, 261, 262, -5, -5, -11, -11, -13, -13,
+ 292, 40, 40, -5, 40, -5, 125, 125, -17, -13,
+ -13, -13, 292, -13, 259, -13, -13, -13, -13, -13,
+ -5, -5, -5, -5, -5, -5, -27, 62, 265, 124,
+ -27, 91, -12, -12, -23, -26, -13, -24, -6, -2,
+ 44, 41, 44, 41, 41, 41, 41, 41, 44, 41,
+ 44, 41, 44, 41, 44, 123, -13, -13, -13, 41,
+ 41, 272, 59, 41, 125, -13, -13, 259, -13, -13,
+ -13, -13, -5, 93, -5, -5, 40, -12, 59, -5,
+ -5, 41, 41, 41, 41, 41, 41, 41, -6, -23,
+ -23, -12, 59, -26, -23, 125, 271, 41, -26, 41,
+ -5, 41, -5, -23, -5, -23, -23 };
+int yydef[]={
+
+ 92, -2, 6, 1, 91, 93, 94, 95, 96, 92,
+ 7, 0, 98, 11, 12, 14, 0, 0, 16, 17,
+ 18, 19, 32, 35, 30, 0, 0, 36, 37, 0,
+ 0, 0, 0, 53, 59, 0, 0, 87, 0, 0,
+ 0, 0, 0, 0, 81, 83, 0, 5, 98, 0,
+ 106, 4, 0, 98, 98, 98, 98, 0, 0, 0,
+ 0, 33, 35, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 46, 47, 19, 18, 17, 0,
+ 23, 48, 49, 50, 51, 54, 0, 0, 87, 87,
+ 64, 85, 86, 0, 0, 0, 0, 0, 0, 0,
+ 87, 84, 106, 87, 0, 97, 99, 100, 15, 0,
+ 0, 106, 106, 24, 25, 26, 28, 29, 38, 39,
+ 40, 41, 42, 43, 44, 0, 57, 34, 20, 27,
+ 31, 52, 0, 55, 60, 0, 0, 0, 98, 98,
+ 0, 16, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 13, 10, 105, 0, 98, 98,
+ 110, 113, 87, 87, 118, 119, 120, 122, 123, 0,
+ 0, 0, 98, 0, 98, 21, 22, 0, 0, 0,
+ 58, 56, 61, 62, 63, 0, 0, 90, 0, 0,
+ 0, 0, 0, 0, 0, 0, 82, 8, 98, 98,
+ 98, 98, 98, 98, 108, 109, 115, 117, 121, 124,
+ 0, 0, 0, 0, 112, 106, 92, 3, 45, 88,
+ 89, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 107, 101, 102, 103, 104, 0, 126, 127, 128,
+ 0, 0, 0, 0, 0, 0, 113, 111, 0, 2,
+ 0, 66, 0, 69, 70, 71, 72, 73, 0, 74,
+ 0, 75, 0, 76, 0, 98, 114, 116, 0, 98,
+ 98, 0, 0, 98, 98, 0, 0, 0, 0, 0,
+ 0, 0, 106, 125, 0, 0, 0, 0, 112, 0,
+ 136, 65, 67, 68, 77, 78, 79, 80, 0, 129,
+ 131, 0, 112, 0, 135, 9, 98, 132, 0, 98,
+ 0, 98, 0, 130, 0, 134, 133 };
+typedef struct { char *t_name; int t_val; } yytoktype;
+#ifndef YYDEBUG
+# define YYDEBUG 0 /* don't allow debugging */
+#endif
+
+#if YYDEBUG
+
+yytoktype yytoks[] =
+{
+ "BEGIN", 257,
+ "END", 258,
+ "REGEX", 259,
+ "SEMINEW", 260,
+ "NEWLINE", 261,
+ "COMMENT", 262,
+ "FUN1", 263,
+ "FUNN", 264,
+ "GRGR", 265,
+ "PRINT", 266,
+ "PRINTF", 267,
+ "SPRINTF", 268,
+ "SPLIT", 269,
+ "IF", 270,
+ "ELSE", 271,
+ "WHILE", 272,
+ "FOR", 273,
+ "IN", 274,
+ "EXIT", 275,
+ "NEXT", 276,
+ "BREAK", 277,
+ "CONTINUE", 278,
+ "RET", 279,
+ "GETLINE", 280,
+ "DO", 281,
+ "SUB", 282,
+ "GSUB", 283,
+ "MATCH", 284,
+ "FUNCTION", 285,
+ "USERFUN", 286,
+ "DELETE", 287,
+ "ASGNOP", 288,
+ "?", 63,
+ ":", 58,
+ "OROR", 289,
+ "ANDAND", 290,
+ "NUMBER", 291,
+ "VAR", 292,
+ "SUBSTR", 293,
+ "INDEX", 294,
+ "MATCHOP", 295,
+ "RELOP", 296,
+ "<", 60,
+ ">", 62,
+ "OR", 297,
+ "STRING", 298,
+ "+", 43,
+ "-", 45,
+ "*", 42,
+ "/", 47,
+ "%", 37,
+ "UMINUS", 299,
+ "NOT", 300,
+ "^", 94,
+ "INCR", 301,
+ "DECR", 302,
+ "FIELD", 303,
+ "VFIELD", 304,
+ "-unknown-", -1 /* ends search */
+};
+
+char * yyreds[] =
+{
+ "-no such reduction-",
+ "program : junk hunks",
+ "begin : BEGIN '{' maybe states '}' junk",
+ "end : END '{' maybe states '}'",
+ "end : end NEWLINE",
+ "hunks : hunks hunk junk",
+ "hunks : /* empty */",
+ "hunk : patpat",
+ "hunk : patpat '{' maybe states '}'",
+ "hunk : FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}'",
+ "hunk : '{' maybe states '}'",
+ "hunk : begin",
+ "hunk : end",
+ "arg_list : expr_list",
+ "patpat : cond",
+ "patpat : cond ',' cond",
+ "cond : expr",
+ "cond : match",
+ "cond : rel",
+ "cond : compound_cond",
+ "compound_cond : '(' compound_cond ')'",
+ "compound_cond : cond ANDAND maybe cond",
+ "compound_cond : cond OROR maybe cond",
+ "compound_cond : NOT cond",
+ "rel : expr RELOP expr",
+ "rel : expr '>' expr",
+ "rel : expr '<' expr",
+ "rel : '(' rel ')'",
+ "match : expr MATCHOP expr",
+ "match : expr MATCHOP REGEX",
+ "match : REGEX",
+ "match : '(' match ')'",
+ "expr : term",
+ "expr : expr term",
+ "expr : variable ASGNOP cond",
+ "term : variable",
+ "term : NUMBER",
+ "term : STRING",
+ "term : term '+' term",
+ "term : term '-' term",
+ "term : term '*' term",
+ "term : term '/' term",
+ "term : term '%' term",
+ "term : term '^' term",
+ "term : term IN VAR",
+ "term : term '?' term ':' term",
+ "term : variable INCR",
+ "term : variable DECR",
+ "term : INCR variable",
+ "term : DECR variable",
+ "term : '-' term",
+ "term : '+' term",
+ "term : '(' cond ')'",
+ "term : GETLINE",
+ "term : GETLINE variable",
+ "term : GETLINE '<' expr",
+ "term : GETLINE variable '<' expr",
+ "term : term 'p' GETLINE",
+ "term : term 'p' GETLINE variable",
+ "term : FUN1",
+ "term : FUN1 '(' ')'",
+ "term : FUN1 '(' expr ')'",
+ "term : FUNN '(' expr_list ')'",
+ "term : USERFUN '(' expr_list ')'",
+ "term : SPRINTF expr_list",
+ "term : SUBSTR '(' expr ',' expr ',' expr ')'",
+ "term : SUBSTR '(' expr ',' expr ')'",
+ "term : SPLIT '(' expr ',' VAR ',' expr ')'",
+ "term : SPLIT '(' expr ',' VAR ',' REGEX ')'",
+ "term : SPLIT '(' expr ',' VAR ')'",
+ "term : INDEX '(' expr ',' expr ')'",
+ "term : MATCH '(' expr ',' REGEX ')'",
+ "term : MATCH '(' expr ',' expr ')'",
+ "term : SUB '(' expr ',' expr ')'",
+ "term : SUB '(' REGEX ',' expr ')'",
+ "term : GSUB '(' expr ',' expr ')'",
+ "term : GSUB '(' REGEX ',' expr ')'",
+ "term : SUB '(' expr ',' expr ',' expr ')'",
+ "term : SUB '(' REGEX ',' expr ',' expr ')'",
+ "term : GSUB '(' expr ',' expr ',' expr ')'",
+ "term : GSUB '(' REGEX ',' expr ',' expr ')'",
+ "variable : VAR",
+ "variable : VAR '[' expr_list ']'",
+ "variable : FIELD",
+ "variable : VFIELD term",
+ "expr_list : expr",
+ "expr_list : clist",
+ "expr_list : /* empty */",
+ "clist : expr ',' maybe expr",
+ "clist : clist ',' maybe expr",
+ "clist : '(' clist ')'",
+ "junk : junk hunksep",
+ "junk : /* empty */",
+ "hunksep : ';'",
+ "hunksep : SEMINEW",
+ "hunksep : NEWLINE",
+ "hunksep : COMMENT",
+ "maybe : maybe nlstuff",
+ "maybe : /* empty */",
+ "nlstuff : NEWLINE",
+ "nlstuff : COMMENT",
+ "separator : ';' maybe",
+ "separator : SEMINEW maybe",
+ "separator : NEWLINE maybe",
+ "separator : COMMENT maybe",
+ "states : states statement",
+ "states : /* empty */",
+ "statement : simple separator maybe",
+ "statement : ';' maybe",
+ "statement : SEMINEW maybe",
+ "statement : compound",
+ "simpnull : simple",
+ "simpnull : /* empty */",
+ "simple : expr",
+ "simple : PRINT expr_list redir expr",
+ "simple : PRINT expr_list",
+ "simple : PRINTF expr_list redir expr",
+ "simple : PRINTF expr_list",
+ "simple : BREAK",
+ "simple : NEXT",
+ "simple : EXIT",
+ "simple : EXIT expr",
+ "simple : CONTINUE",
+ "simple : RET",
+ "simple : RET expr",
+ "simple : DELETE VAR '[' expr ']'",
+ "redir : '>'",
+ "redir : GRGR",
+ "redir : '|'",
+ "compound : IF '(' cond ')' maybe statement",
+ "compound : IF '(' cond ')' maybe statement ELSE maybe statement",
+ "compound : WHILE '(' cond ')' maybe statement",
+ "compound : DO maybe statement WHILE '(' cond ')'",
+ "compound : FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement",
+ "compound : FOR '(' simpnull ';' ';' simpnull ')' maybe statement",
+ "compound : FOR '(' expr ')' maybe statement",
+ "compound : '{' maybe states '}' maybe",
+};
+#endif /* YYDEBUG */
+#line 1 "/usr/lib/yaccpar"
+/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */
+
+/*
+** Skeleton parser driver for yacc output
+*/
+
+/*
+** yacc user known macros and defines
+*/
+#define YYERROR goto yyerrlab
+#define YYACCEPT { free(yys); free(yyv); return(0); }
+#define YYABORT { free(yys); free(yyv); return(1); }
+#define YYBACKUP( newtoken, newvalue )\
+{\
+ if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\
+ {\
+ yyerror( "syntax error - cannot backup" );\
+ goto yyerrlab;\
+ }\
+ yychar = newtoken;\
+ yystate = *yyps;\
+ yylval = newvalue;\
+ goto yynewstate;\
+}
+#define YYRECOVERING() (!!yyerrflag)
+#ifndef YYDEBUG
+# define YYDEBUG 1 /* make debugging available */
+#endif
+
+/*
+** user known globals
+*/
+int yydebug; /* set to 1 to get debugging */
+
+/*
+** driver internal defines
+*/
+#define YYFLAG (-1000)
+
+/*
+** static variables used by the parser
+*/
+static YYSTYPE *yyv; /* value stack */
+static int *yys; /* state stack */
+
+static YYSTYPE *yypv; /* top of value stack */
+static int *yyps; /* top of state stack */
+
+static int yystate; /* current state */
+static int yytmp; /* extra var (lasts between blocks) */
+
+int yynerrs; /* number of errors */
+
+int yyerrflag; /* error recovery flag */
+int yychar; /* current input token number */
+
+
+/*
+** yyparse - return 0 if worked, 1 if syntax error not recovered from
+*/
+int
+yyparse()
+{
+ register YYSTYPE *yypvt; /* top of value stack for $vars */
+ unsigned yymaxdepth = YYMAXDEPTH;
+
+ /*
+ ** Initialize externals - yyparse may be called more than once
+ */
+ yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE));
+ yys = (int*)malloc(yymaxdepth*sizeof(int));
+ if (!yyv || !yys)
+ {
+ yyerror( "out of memory" );
+ return(1);
+ }
+ yypv = &yyv[-1];
+ yyps = &yys[-1];
+ yystate = 0;
+ yytmp = 0;
+ yynerrs = 0;
+ yyerrflag = 0;
+ yychar = -1;
+
+ goto yystack;
+ {
+ register YYSTYPE *yy_pv; /* top of value stack */
+ register int *yy_ps; /* top of state stack */
+ register int yy_state; /* current state */
+ register int yy_n; /* internal state number info */
+
+ /*
+ ** get globals into registers.
+ ** branch to here only if YYBACKUP was called.
+ */
+ yynewstate:
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+ goto yy_newstate;
+
+ /*
+ ** get globals into registers.
+ ** either we just started, or we just finished a reduction
+ */
+ yystack:
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+
+ /*
+ ** top of for (;;) loop while no reductions done
+ */
+ yy_stack:
+ /*
+ ** put a state and value onto the stacks
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token value in list of value vs.
+ ** name pairs. 0 and negative (-1) are special values.
+ ** Note: linear search is used since time is not a real
+ ** consideration while debugging.
+ */
+ if ( yydebug )
+ {
+ register int yy_i;
+
+ (void)printf( "State %d, token ", yy_state );
+ if ( yychar == 0 )
+ (void)printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0; yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val == yychar )
+ break;
+ }
+ (void)printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */
+ {
+ /*
+ ** reallocate and recover. Note that pointers
+ ** have to be reset, or bad things will happen
+ */
+ int yyps_index = (yy_ps - yys);
+ int yypv_index = (yy_pv - yyv);
+ int yypvt_index = (yypvt - yyv);
+ yymaxdepth += YYMAXDEPTH;
+ yyv = (YYSTYPE*)realloc((char*)yyv,
+ yymaxdepth * sizeof(YYSTYPE));
+ yys = (int*)realloc((char*)yys,
+ yymaxdepth * sizeof(int));
+ if (!yyv || !yys)
+ {
+ yyerror( "yacc stack overflow" );
+ return(1);
+ }
+ yy_ps = yys + yyps_index;
+ yy_pv = yyv + yypv_index;
+ yypvt = yyv + yypvt_index;
+ }
+ *yy_ps = yy_state;
+ *++yy_pv = yyval;
+
+ /*
+ ** we have a new state - find out what to do
+ */
+ yy_newstate:
+ if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG )
+ goto yydefault; /* simple state */
+#if YYDEBUG
+ /*
+ ** if debugging, need to mark whether new token grabbed
+ */
+ yytmp = yychar < 0;
+#endif
+ if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) )
+ yychar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( yydebug && yytmp )
+ {
+ register int yy_i;
+
+ (void)printf( "Received token " );
+ if ( yychar == 0 )
+ (void)printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0; yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val == yychar )
+ break;
+ }
+ (void)printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) )
+ goto yydefault;
+ if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/
+ {
+ yychar = -1;
+ yyval = yylval;
+ yy_state = yy_n;
+ if ( yyerrflag > 0 )
+ yyerrflag--;
+ goto yy_stack;
+ }
+
+ yydefault:
+ if ( ( yy_n = yydef[ yy_state ] ) == -2 )
+ {
+#if YYDEBUG
+ yytmp = yychar < 0;
+#endif
+ if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) )
+ yychar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( yydebug && yytmp )
+ {
+ register int yy_i;
+
+ (void)printf( "Received token " );
+ if ( yychar == 0 )
+ (void)printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0;
+ yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val
+ == yychar )
+ {
+ break;
+ }
+ }
+ (void)printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ /*
+ ** look through exception table
+ */
+ {
+ register int *yyxi = yyexca;
+
+ while ( ( *yyxi != -1 ) ||
+ ( yyxi[1] != yy_state ) )
+ {
+ yyxi += 2;
+ }
+ while ( ( *(yyxi += 2) >= 0 ) &&
+ ( *yyxi != yychar ) )
+ ;
+ if ( ( yy_n = yyxi[1] ) < 0 )
+ YYACCEPT;
+ }
+ }
+
+ /*
+ ** check for syntax error
+ */
+ if ( yy_n == 0 ) /* have an error */
+ {
+ /* no worry about speed here! */
+ switch ( yyerrflag )
+ {
+ case 0: /* new error */
+ yyerror( "syntax error" );
+ goto skip_init;
+ yyerrlab:
+ /*
+ ** get globals into registers.
+ ** we have a user generated syntax type error
+ */
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+ yynerrs++;
+ skip_init:
+ case 1:
+ case 2: /* incompletely recovered error */
+ /* try again... */
+ yyerrflag = 3;
+ /*
+ ** find state where "error" is a legal
+ ** shift action
+ */
+ while ( yy_ps >= yys )
+ {
+ yy_n = yypact[ *yy_ps ] + YYERRCODE;
+ if ( yy_n >= 0 && yy_n < YYLAST &&
+ yychk[yyact[yy_n]] == YYERRCODE) {
+ /*
+ ** simulate shift of "error"
+ */
+ yy_state = yyact[ yy_n ];
+ goto yy_stack;
+ }
+ /*
+ ** current state has no shift on
+ ** "error", pop stack
+ */
+#if YYDEBUG
+# define _POP_ "Error recovery pops state %d, uncovers state %d\n"
+ if ( yydebug )
+ (void)printf( _POP_, *yy_ps,
+ yy_ps[-1] );
+# undef _POP_
+#endif
+ yy_ps--;
+ yy_pv--;
+ }
+ /*
+ ** there is no state on stack with "error" as
+ ** a valid shift. give up.
+ */
+ YYABORT;
+ case 3: /* no shift yet; eat a token */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token in list of
+ ** pairs. 0 and negative shouldn't occur,
+ ** but since timing doesn't matter when
+ ** debugging, it doesn't hurt to leave the
+ ** tests here.
+ */
+ if ( yydebug )
+ {
+ register int yy_i;
+
+ (void)printf( "Error recovery discards " );
+ if ( yychar == 0 )
+ (void)printf( "token end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "token -none-\n" );
+ else
+ {
+ for ( yy_i = 0;
+ yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val
+ == yychar )
+ {
+ break;
+ }
+ }
+ (void)printf( "token %s\n",
+ yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( yychar == 0 ) /* reached EOF. quit */
+ YYABORT;
+ yychar = -1;
+ goto yy_newstate;
+ }
+ }/* end if ( yy_n == 0 ) */
+ /*
+ ** reduction by production yy_n
+ ** put stack tops, etc. so things right after switch
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, print the string that is the user's
+ ** specification of the reduction which is just about
+ ** to be done.
+ */
+ if ( yydebug )
+ (void)printf( "Reduce by (%d) \"%s\"\n",
+ yy_n, yyreds[ yy_n ] );
+#endif
+ yytmp = yy_n; /* value to switch over */
+ yypvt = yy_pv; /* $vars top of value stack */
+ /*
+ ** Look in goto table for next state
+ ** Sorry about using yy_state here as temporary
+ ** register variable, but why not, if it works...
+ ** If yyr2[ yy_n ] doesn't have the low order bit
+ ** set, then there is no action to be done for
+ ** this reduction. So, no saving & unsaving of
+ ** registers done. The only difference between the
+ ** code just after the if and the body of the if is
+ ** the goto yy_stack in the body. This way the test
+ ** can be made before the choice of what to do is needed.
+ */
+ {
+ /* length of production doubled with extra bit */
+ register int yy_len = yyr2[ yy_n ];
+
+ if ( !( yy_len & 01 ) )
+ {
+ yy_len >>= 1;
+ yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */
+ yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] +
+ *( yy_ps -= yy_len ) + 1;
+ if ( yy_state >= YYLAST ||
+ yychk[ yy_state =
+ yyact[ yy_state ] ] != -yy_n )
+ {
+ yy_state = yyact[ yypgo[ yy_n ] ];
+ }
+ goto yy_stack;
+ }
+ yy_len >>= 1;
+ yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */
+ yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] +
+ *( yy_ps -= yy_len ) + 1;
+ if ( yy_state >= YYLAST ||
+ yychk[ yy_state = yyact[ yy_state ] ] != -yy_n )
+ {
+ yy_state = yyact[ yypgo[ yy_n ] ];
+ }
+ }
+ /* save until reenter driver code */
+ yystate = yy_state;
+ yyps = yy_ps;
+ yypv = yy_pv;
+ }
+ /*
+ ** code supplied by user is placed in this switch
+ */
+ switch( yytmp )
+ {
+
+case 1:
+# line 60 "a2p.y"
+{ root = oper4(OPROG,yypvt[-1],begins,yypvt[-0],ends); } break;
+case 2:
+# line 64 "a2p.y"
+{ begins = oper4(OJUNK,begins,yypvt[-3],yypvt[-2],yypvt[-0]); in_begin = FALSE;
+ yyval = Nullop; } break;
+case 3:
+# line 69 "a2p.y"
+{ ends = oper3(OJUNK,ends,yypvt[-2],yypvt[-1]); yyval = Nullop; } break;
+case 4:
+# line 71 "a2p.y"
+{ yyval = yypvt[-1]; } break;
+case 5:
+# line 75 "a2p.y"
+{ yyval = oper3(OHUNKS,yypvt[-2],yypvt[-1],yypvt[-0]); } break;
+case 6:
+# line 77 "a2p.y"
+{ yyval = Nullop; } break;
+case 7:
+# line 81 "a2p.y"
+{ yyval = oper1(OHUNK,yypvt[-0]); need_entire = TRUE; } break;
+case 8:
+# line 83 "a2p.y"
+{ yyval = oper2(OHUNK,yypvt[-4],oper2(OJUNK,yypvt[-2],yypvt[-1])); } break;
+case 9:
+# line 85 "a2p.y"
+{ fixfargs(yypvt[-8],yypvt[-6],0); yyval = oper5(OUSERDEF,yypvt[-8],yypvt[-6],yypvt[-4],yypvt[-2],yypvt[-1]); } break;
+case 10:
+# line 87 "a2p.y"
+{ yyval = oper2(OHUNK,Nullop,oper2(OJUNK,yypvt[-2],yypvt[-1])); } break;
+case 13:
+# line 93 "a2p.y"
+{ yyval = rememberargs(yyval); } break;
+case 14:
+# line 97 "a2p.y"
+{ yyval = oper1(OPAT,yypvt[-0]); } break;
+case 15:
+# line 99 "a2p.y"
+{ yyval = oper2(ORANGE,yypvt[-2],yypvt[-0]); } break;
+case 20:
+# line 110 "a2p.y"
+{ yyval = oper1(OCPAREN,yypvt[-1]); } break;
+case 21:
+# line 112 "a2p.y"
+{ yyval = oper3(OCANDAND,yypvt[-3],yypvt[-1],yypvt[-0]); } break;
+case 22:
+# line 114 "a2p.y"
+{ yyval = oper3(OCOROR,yypvt[-3],yypvt[-1],yypvt[-0]); } break;
+case 23:
+# line 116 "a2p.y"
+{ yyval = oper1(OCNOT,yypvt[-0]); } break;
+case 24:
+# line 120 "a2p.y"
+{ yyval = oper3(ORELOP,yypvt[-1],yypvt[-2],yypvt[-0]); } break;
+case 25:
+# line 122 "a2p.y"
+{ yyval = oper3(ORELOP,string(">",1),yypvt[-2],yypvt[-0]); } break;
+case 26:
+# line 124 "a2p.y"
+{ yyval = oper3(ORELOP,string("<",1),yypvt[-2],yypvt[-0]); } break;
+case 27:
+# line 126 "a2p.y"
+{ yyval = oper1(ORPAREN,yypvt[-1]); } break;
+case 28:
+# line 130 "a2p.y"
+{ yyval = oper3(OMATCHOP,yypvt[-1],yypvt[-2],yypvt[-0]); } break;
+case 29:
+# line 132 "a2p.y"
+{ yyval = oper3(OMATCHOP,yypvt[-1],yypvt[-2],oper1(OREGEX,yypvt[-0])); } break;
+case 30:
+# line 134 "a2p.y"
+{ yyval = oper1(OREGEX,yypvt[-0]); } break;
+case 31:
+# line 136 "a2p.y"
+{ yyval = oper1(OMPAREN,yypvt[-1]); } break;
+case 32:
+# line 140 "a2p.y"
+{ yyval = yypvt[-0]; } break;
+case 33:
+# line 142 "a2p.y"
+{ yyval = oper2(OCONCAT,yypvt[-1],yypvt[-0]); } break;
+case 34:
+# line 144 "a2p.y"
+{ yyval = oper3(OASSIGN,yypvt[-1],yypvt[-2],yypvt[-0]);
+ if ((ops[yypvt[-2]].ival & 255) == OFLD)
+ lval_field = TRUE;
+ if ((ops[yypvt[-2]].ival & 255) == OVFLD)
+ lval_field = TRUE;
+ } break;
+case 35:
+# line 153 "a2p.y"
+{ yyval = yypvt[-0]; } break;
+case 36:
+# line 155 "a2p.y"
+{ yyval = oper1(ONUM,yypvt[-0]); } break;
+case 37:
+# line 157 "a2p.y"
+{ yyval = oper1(OSTR,yypvt[-0]); } break;
+case 38:
+# line 159 "a2p.y"
+{ yyval = oper2(OADD,yypvt[-2],yypvt[-0]); } break;
+case 39:
+# line 161 "a2p.y"
+{ yyval = oper2(OSUBTRACT,yypvt[-2],yypvt[-0]); } break;
+case 40:
+# line 163 "a2p.y"
+{ yyval = oper2(OMULT,yypvt[-2],yypvt[-0]); } break;
+case 41:
+# line 165 "a2p.y"
+{ yyval = oper2(ODIV,yypvt[-2],yypvt[-0]); } break;
+case 42:
+# line 167 "a2p.y"
+{ yyval = oper2(OMOD,yypvt[-2],yypvt[-0]); } break;
+case 43:
+# line 169 "a2p.y"
+{ yyval = oper2(OPOW,yypvt[-2],yypvt[-0]); } break;
+case 44:
+# line 171 "a2p.y"
+{ yyval = oper2(ODEFINED,aryrefarg(yypvt[-0]),yypvt[-2]); } break;
+case 45:
+# line 173 "a2p.y"
+{ yyval = oper3(OCOND,yypvt[-4],yypvt[-2],yypvt[-0]); } break;
+case 46:
+# line 175 "a2p.y"
+{ yyval = oper1(OPOSTINCR,yypvt[-1]); } break;
+case 47:
+# line 177 "a2p.y"
+{ yyval = oper1(OPOSTDECR,yypvt[-1]); } break;
+case 48:
+# line 179 "a2p.y"
+{ yyval = oper1(OPREINCR,yypvt[-0]); } break;
+case 49:
+# line 181 "a2p.y"
+{ yyval = oper1(OPREDECR,yypvt[-0]); } break;
+case 50:
+# line 183 "a2p.y"
+{ yyval = oper1(OUMINUS,yypvt[-0]); } break;
+case 51:
+# line 185 "a2p.y"
+{ yyval = oper1(OUPLUS,yypvt[-0]); } break;
+case 52:
+# line 187 "a2p.y"
+{ yyval = oper1(OPAREN,yypvt[-1]); } break;
+case 53:
+# line 189 "a2p.y"
+{ yyval = oper0(OGETLINE); } break;
+case 54:
+# line 191 "a2p.y"
+{ yyval = oper1(OGETLINE,yypvt[-0]); } break;
+case 55:
+# line 193 "a2p.y"
+{ yyval = oper3(OGETLINE,Nullop,string("<",1),yypvt[-0]);
+ if (ops[yypvt[-0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break;
+case 56:
+# line 196 "a2p.y"
+{ yyval = oper3(OGETLINE,yypvt[-2],string("<",1),yypvt[-0]);
+ if (ops[yypvt[-0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break;
+case 57:
+# line 199 "a2p.y"
+{ yyval = oper3(OGETLINE,Nullop,string("|",1),yypvt[-2]);
+ if (ops[yypvt[-2]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break;
+case 58:
+# line 202 "a2p.y"
+{ yyval = oper3(OGETLINE,yypvt[-0],string("|",1),yypvt[-3]);
+ if (ops[yypvt[-3]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break;
+case 59:
+# line 205 "a2p.y"
+{ yyval = oper0(yypvt[-0]); need_entire = do_chop = TRUE; } break;
+case 60:
+# line 207 "a2p.y"
+{ yyval = oper1(yypvt[-2],Nullop); need_entire = do_chop = TRUE; } break;
+case 61:
+# line 209 "a2p.y"
+{ yyval = oper1(yypvt[-3],yypvt[-1]); } break;
+case 62:
+# line 211 "a2p.y"
+{ yyval = oper1(yypvt[-3],yypvt[-1]); } break;
+case 63:
+# line 213 "a2p.y"
+{ yyval = oper2(OUSERFUN,yypvt[-3],yypvt[-1]); } break;
+case 64:
+# line 215 "a2p.y"
+{ yyval = oper1(OSPRINTF,yypvt[-0]); } break;
+case 65:
+# line 217 "a2p.y"
+{ yyval = oper3(OSUBSTR,yypvt[-5],yypvt[-3],yypvt[-1]); } break;
+case 66:
+# line 219 "a2p.y"
+{ yyval = oper2(OSUBSTR,yypvt[-3],yypvt[-1]); } break;
+case 67:
+# line 221 "a2p.y"
+{ yyval = oper3(OSPLIT,yypvt[-5],aryrefarg(numary(yypvt[-3])),yypvt[-1]); } break;
+case 68:
+# line 223 "a2p.y"
+{ yyval = oper3(OSPLIT,yypvt[-5],aryrefarg(numary(yypvt[-3])),oper1(OREGEX,yypvt[-1]));} break;
+case 69:
+# line 225 "a2p.y"
+{ yyval = oper2(OSPLIT,yypvt[-3],aryrefarg(numary(yypvt[-1]))); } break;
+case 70:
+# line 227 "a2p.y"
+{ yyval = oper2(OINDEX,yypvt[-3],yypvt[-1]); } break;
+case 71:
+# line 229 "a2p.y"
+{ yyval = oper2(OMATCH,yypvt[-3],oper1(OREGEX,yypvt[-1])); } break;
+case 72:
+# line 231 "a2p.y"
+{ yyval = oper2(OMATCH,yypvt[-3],yypvt[-1]); } break;
+case 73:
+# line 233 "a2p.y"
+{ yyval = oper2(OSUB,yypvt[-3],yypvt[-1]); } break;
+case 74:
+# line 235 "a2p.y"
+{ yyval = oper2(OSUB,oper1(OREGEX,yypvt[-3]),yypvt[-1]); } break;
+case 75:
+# line 237 "a2p.y"
+{ yyval = oper2(OGSUB,yypvt[-3],yypvt[-1]); } break;
+case 76:
+# line 239 "a2p.y"
+{ yyval = oper2(OGSUB,oper1(OREGEX,yypvt[-3]),yypvt[-1]); } break;
+case 77:
+# line 241 "a2p.y"
+{ yyval = oper3(OSUB,yypvt[-5],yypvt[-3],yypvt[-1]); } break;
+case 78:
+# line 243 "a2p.y"
+{ yyval = oper3(OSUB,oper1(OREGEX,yypvt[-5]),yypvt[-3],yypvt[-1]); } break;
+case 79:
+# line 245 "a2p.y"
+{ yyval = oper3(OGSUB,yypvt[-5],yypvt[-3],yypvt[-1]); } break;
+case 80:
+# line 247 "a2p.y"
+{ yyval = oper3(OGSUB,oper1(OREGEX,yypvt[-5]),yypvt[-3],yypvt[-1]); } break;
+case 81:
+# line 251 "a2p.y"
+{ yyval = oper1(OVAR,yypvt[-0]); } break;
+case 82:
+# line 253 "a2p.y"
+{ yyval = oper2(OVAR,aryrefarg(yypvt[-3]),yypvt[-1]); } break;
+case 83:
+# line 255 "a2p.y"
+{ yyval = oper1(OFLD,yypvt[-0]); } break;
+case 84:
+# line 257 "a2p.y"
+{ yyval = oper1(OVFLD,yypvt[-0]); } break;
+case 87:
+# line 264 "a2p.y"
+{ yyval = Nullop; } break;
+case 88:
+# line 268 "a2p.y"
+{ yyval = oper3(OCOMMA,yypvt[-3],yypvt[-1],yypvt[-0]); } break;
+case 89:
+# line 270 "a2p.y"
+{ yyval = oper3(OCOMMA,yypvt[-3],yypvt[-1],yypvt[-0]); } break;
+case 90:
+# line 272 "a2p.y"
+{ yyval = yypvt[-1]; } break;
+case 91:
+# line 276 "a2p.y"
+{ yyval = oper2(OJUNK,yypvt[-1],yypvt[-0]); } break;
+case 92:
+# line 278 "a2p.y"
+{ yyval = Nullop; } break;
+case 93:
+# line 282 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } break;
+case 94:
+# line 284 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } break;
+case 95:
+# line 286 "a2p.y"
+{ yyval = oper0(ONEWLINE); } break;
+case 96:
+# line 288 "a2p.y"
+{ yyval = oper1(OCOMMENT,yypvt[-0]); } break;
+case 97:
+# line 292 "a2p.y"
+{ yyval = oper2(OJUNK,yypvt[-1],yypvt[-0]); } break;
+case 98:
+# line 294 "a2p.y"
+{ yyval = Nullop; } break;
+case 99:
+# line 298 "a2p.y"
+{ yyval = oper0(ONEWLINE); } break;
+case 100:
+# line 300 "a2p.y"
+{ yyval = oper1(OCOMMENT,yypvt[-0]); } break;
+case 101:
+# line 305 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSEMICOLON),yypvt[-0]); } break;
+case 102:
+# line 307 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSNEWLINE),yypvt[-0]); } break;
+case 103:
+# line 309 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSNEWLINE),yypvt[-0]); } break;
+case 104:
+# line 311 "a2p.y"
+{ yyval = oper2(OJUNK,oper1(OSCOMMENT,yypvt[-1]),yypvt[-0]); } break;
+case 105:
+# line 315 "a2p.y"
+{ yyval = oper2(OSTATES,yypvt[-1],yypvt[-0]); } break;
+case 106:
+# line 317 "a2p.y"
+{ yyval = Nullop; } break;
+case 107:
+# line 322 "a2p.y"
+{ yyval = oper2(OJUNK,oper2(OSTATE,yypvt[-2],yypvt[-1]),yypvt[-0]); } break;
+case 108:
+# line 324 "a2p.y"
+{ yyval = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),yypvt[-0])); } break;
+case 109:
+# line 326 "a2p.y"
+{ yyval = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),yypvt[-0])); } break;
+case 112:
+# line 332 "a2p.y"
+{ yyval = Nullop; } break;
+case 114:
+# line 338 "a2p.y"
+{ yyval = oper3(OPRINT,yypvt[-2],yypvt[-1],yypvt[-0]);
+ do_opens = TRUE;
+ saw_ORS = saw_OFS = TRUE;
+ if (!yypvt[-2]) need_entire = TRUE;
+ if (ops[yypvt[-0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break;
+case 115:
+# line 344 "a2p.y"
+{ yyval = oper1(OPRINT,yypvt[-0]);
+ if (!yypvt[-0]) need_entire = TRUE;
+ saw_ORS = saw_OFS = TRUE;
+ } break;
+case 116:
+# line 349 "a2p.y"
+{ yyval = oper3(OPRINTF,yypvt[-2],yypvt[-1],yypvt[-0]);
+ do_opens = TRUE;
+ if (!yypvt[-2]) need_entire = TRUE;
+ if (ops[yypvt[-0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break;
+case 117:
+# line 354 "a2p.y"
+{ yyval = oper1(OPRINTF,yypvt[-0]);
+ if (!yypvt[-0]) need_entire = TRUE;
+ } break;
+case 118:
+# line 358 "a2p.y"
+{ yyval = oper0(OBREAK); } break;
+case 119:
+# line 360 "a2p.y"
+{ yyval = oper0(ONEXT); } break;
+case 120:
+# line 362 "a2p.y"
+{ yyval = oper0(OEXIT); } break;
+case 121:
+# line 364 "a2p.y"
+{ yyval = oper1(OEXIT,yypvt[-0]); } break;
+case 122:
+# line 366 "a2p.y"
+{ yyval = oper0(OCONTINUE); } break;
+case 123:
+# line 368 "a2p.y"
+{ yyval = oper0(ORETURN); } break;
+case 124:
+# line 370 "a2p.y"
+{ yyval = oper1(ORETURN,yypvt[-0]); } break;
+case 125:
+# line 372 "a2p.y"
+{ yyval = oper2(ODELETE,aryrefarg(yypvt[-3]),yypvt[-1]); } break;
+case 126:
+# line 376 "a2p.y"
+{ yyval = oper1(OREDIR,string(">",1)); } break;
+case 127:
+# line 378 "a2p.y"
+{ yyval = oper1(OREDIR,string(">>",2)); } break;
+case 128:
+# line 380 "a2p.y"
+{ yyval = oper1(OREDIR,string("|",1)); } break;
+case 129:
+# line 385 "a2p.y"
+{ yyval = oper2(OIF,yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break;
+case 130:
+# line 387 "a2p.y"
+{ yyval = oper3(OIF,yypvt[-6],bl(yypvt[-3],yypvt[-4]),bl(yypvt[-0],yypvt[-1])); } break;
+case 131:
+# line 389 "a2p.y"
+{ yyval = oper2(OWHILE,yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break;
+case 132:
+# line 391 "a2p.y"
+{ yyval = oper2(ODO,bl(yypvt[-4],yypvt[-5]),yypvt[-1]); } break;
+case 133:
+# line 393 "a2p.y"
+{ yyval = oper4(OFOR,yypvt[-7],yypvt[-5],yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break;
+case 134:
+# line 395 "a2p.y"
+{ yyval = oper4(OFOR,yypvt[-6],string("",0),yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break;
+case 135:
+# line 397 "a2p.y"
+{ yyval = oper2(OFORIN,yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break;
+case 136:
+# line 399 "a2p.y"
+{ yyval = oper3(OBLOCK,oper2(OJUNK,yypvt[-3],yypvt[-2]),Nullop,yypvt[-0]); } break;
+ }
+ goto yystack; /* reset registers in driver code */
+}
-/* $RCSfile: a2p.h,v $$Revision: 4.0.1.2 $$Date: 92/06/08 16:12:23 $
+/* $RCSfile: a2p.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:09 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: a2p.h,v $
+ * Revision 4.1 92/08/07 18:29:09 lwall
+ *
* Revision 4.0.1.2 92/06/08 16:12:23 lwall
* patch20: hash tables now split only if the memory is available to do so
*
#define P_POW 95
#define P_AUTO 100
#define P_MAX 999
+
+EXT int an;
.rn '' }`
-''' $Header: a2p.man,v 4.0 91/03/20 01:57:11 lwall Locked $
+''' $RCSfile: a2p.man,v $$Revision: 4.1 $$Date: 92/08/07 18:29:10 $
'''
''' $Log: a2p.man,v $
+''' Revision 4.1 92/08/07 18:29:10 lwall
+'''
''' Revision 4.0 91/03/20 01:57:11 lwall
''' 4.0 baseline.
'''
%{
-/* $RCSfile: a2p.y,v $$Revision: 4.0.1.2 $$Date: 92/06/08 16:13:03 $
+/* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: a2p.y,v $
+ * Revision 4.1 92/08/07 18:29:12 lwall
+ *
* Revision 4.0.1.2 92/06/08 16:13:03 lwall
* patch20: in a2p, getline should allow variable to be array element
*
-/* $RCSfile: a2py.c,v $$Revision: 4.0.1.2 $$Date: 92/06/08 16:15:16 $
+/* $RCSfile: a2py.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:14 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: a2py.c,v $
+ * Revision 4.1 92/08/07 18:29:14 lwall
+ *
* Revision 4.0.1.2 92/06/08 16:15:16 lwall
* patch20: in a2p, now warns about spurious backslashes
* patch20: in a2p, now allows [ to be backslashed in pattern
}
return numargs;
}
-
--- /dev/null
+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 2>/dev/null
+ . ./config.sh
+ ;;
+esac
+
+also=': '
+case $# in
+1) also='echo 1>&2 " CCCMD = "'
+esac
+
+case $# in
+0) set *.c; echo "The current C flags are:" ;;
+esac
+
+set `echo "$* " | sed 's/\.[oc] / /g'`
+
+for file do
+
+ case "$#" in
+ 1) ;;
+ *) echo $n " $file.c $c" ;;
+ esac
+
+ : allow variables like str_cflags to be evaluated
+
+ eval 'eval ${'"${file}_cflags"'-""}'
+
+ : or customize here
+
+ case "$file" in
+ a2p) ;;
+ a2py) ;;
+ hash) ;;
+ str) ;;
+ util) ;;
+ walk) ;;
+ *) ;;
+ esac
+
+ echo "$cc -c $ccflags $optimize $large $split"
+ eval "$also "'"$cc -c $ccflags $optimize $large $split"'
+
+ . ./config.sh
+
+done
--- /dev/null
+../config.sh
\ No newline at end of file
--- /dev/null
+#!/usr/local/bin/perl
+
+eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+$bin = "/usr/local/bin";
+
+
+while ($ARGV[0] =~ /^[^-!(]/) {
+ push(@roots, shift);
+}
+@roots = ('.') unless @roots;
+for (@roots) { $_ = "e($_); }
+$roots = join(',', @roots);
+
+$indent = 1;
+
+while (@ARGV) {
+ $_ = shift;
+ s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
+ if ($_ eq '(') {
+ $out .= &tab . "(\n";
+ $indent++;
+ next;
+ }
+ elsif ($_ eq ')') {
+ $indent--;
+ $out .= &tab . ")";
+ }
+ elsif ($_ eq '!') {
+ $out .= &tab . "!";
+ next;
+ }
+ elsif ($_ eq 'name') {
+ $out .= &tab;
+ $pat = &fileglob_to_re(shift);
+ $out .= '/' . $pat . "/";
+ }
+ elsif ($_ eq 'perm') {
+ $onum = shift;
+ die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
+ if ($onum =~ s/^-//) {
+ $onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ?
+ $out .= &tab . "((\$mode & $onum) == $onum)";
+ }
+ else {
+ $onum = '0' . $onum unless $onum =~ /^0/;
+ $out .= &tab . "((\$mode & 0777) == $onum)";
+ }
+ }
+ elsif ($_ eq 'type') {
+ ($filetest = shift) =~ tr/s/S/;
+ $out .= &tab . "-$filetest _";
+ }
+ elsif ($_ eq 'print') {
+ $out .= &tab . 'print("$name\n")';
+ }
+ elsif ($_ eq 'print0') {
+ $out .= &tab . 'print("$name\0")';
+ }
+ elsif ($_ eq 'fstype') {
+ $out .= &tab;
+ $type = shift;
+ if ($type eq 'nfs')
+ { $out .= '$dev < 0'; }
+ else
+ { $out .= '$dev >= 0'; }
+ }
+ elsif ($_ eq 'user') {
+ $uname = shift;
+ $out .= &tab . "\$uid == \$uid{'$uname'}";
+ $inituser++;
+ }
+ elsif ($_ eq 'group') {
+ $gname = shift;
+ $out .= &tab . "\$gid == \$gid{'$gname'}";
+ $initgroup++;
+ }
+ elsif ($_ eq 'nouser') {
+ $out .= &tab . '!defined $uid{$uid}';
+ $inituser++;
+ }
+ elsif ($_ eq 'nogroup') {
+ $out .= &tab . '!defined $gid{$gid}';
+ $initgroup++;
+ }
+ elsif ($_ eq 'links') {
+ $out .= &tab . '$nlink ' . &n(shift);
+ }
+ elsif ($_ eq 'inum') {
+ $out .= &tab . '$ino ' . &n(shift);
+ }
+ elsif ($_ eq 'size') {
+ $out .= &tab . 'int((-s _ + 511) / 512) ' . &n(shift);
+ }
+ elsif ($_ eq 'atime') {
+ $out .= &tab . 'int(-A _) ' . &n(shift);
+ }
+ elsif ($_ eq 'mtime') {
+ $out .= &tab . 'int(-M _) ' . &n(shift);
+ }
+ elsif ($_ eq 'ctime') {
+ $out .= &tab . 'int(-C _) ' . &n(shift);
+ }
+ elsif ($_ eq 'exec') {
+ for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
+ shift;
+ $_ = "@cmd";
+ if (m#^(/bin/)?rm -f {}$#) {
+ if (!@ARGV) {
+ $out .= &tab . 'unlink($_)';
+ }
+ else {
+ $out .= &tab . '(unlink($_) || 1)';
+ }
+ }
+ elsif (m#^(/bin/)?rm {}$#) {
+ $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
+ }
+ else {
+ for (@cmd) { s/'/\\'/g; }
+ $" = "','";
+ $out .= &tab . "&exec(0, '@cmd')";
+ $" = ' ';
+ $initexec++;
+ }
+ }
+ elsif ($_ eq 'ok') {
+ for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
+ shift;
+ for (@cmd) { s/'/\\'/g; }
+ $" = "','";
+ $out .= &tab . "&exec(1, '@cmd')";
+ $" = ' ';
+ $initexec++;
+ }
+ elsif ($_ eq 'prune') {
+ $out .= &tab . '($prune = 1)';
+ }
+ elsif ($_ eq 'xdev') {
+ $out .= &tab . '(($prune |= ($dev != $topdev)),1)';
+ }
+ elsif ($_ eq 'newer') {
+ $out .= &tab;
+ $file = shift;
+ $newername = 'AGE_OF' . $file;
+ $newername =~ s/[^\w]/_/g;
+ $newername = '$' . $newername;
+ $out .= "-M _ < $newername";
+ $initnewer .= "$newername = -M " . "e($file) . ";\n";
+ }
+ elsif ($_ eq 'eval') {
+ $prog = "e(shift);
+ $out .= &tab . "eval $prog";
+ }
+ elsif ($_ eq 'depth') {
+ $depth++;
+ next;
+ }
+ elsif ($_ eq 'ls') {
+ $out .= &tab . "&ls";
+ $initls++;
+ }
+ elsif ($_ eq 'tar') {
+ $out .= &tab;
+ die "-tar must have a filename argument\n" unless @ARGV;
+ $file = shift;
+ $fh = 'FH' . $file;
+ $fh =~ s/[^\w]/_/g;
+ $out .= "&tar($fh)";
+ $file = '>' . $file;
+ $initfile .= "open($fh, " . "e($file) .
+ qq{) || die "Can't open $fh: \$!\\n";\n};
+ $inittar++;
+ $flushall = "\n&tflushall;\n";
+ }
+ elsif (/^n?cpio$/) {
+ $depth++;
+ $out .= &tab;
+ die "-$_ must have a filename argument\n" unless @ARGV;
+ $file = shift;
+ $fh = 'FH' . $file;
+ $fh =~ s/[^\w]/_/g;
+ $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
+ $file = '>' . $file;
+ $initfile .= "open($fh, " . "e($file) .
+ qq{) || die "Can't open $fh: \$!\\n";\n};
+ $initcpio++;
+ $flushall = "\n&flushall;\n";
+ }
+ else {
+ die "Unrecognized switch: -$_\n";
+ }
+ if (@ARGV) {
+ if ($ARGV[0] eq '-o') {
+ { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
+ $statdone = 0 if $indent == 1 && $delayedstat;
+ $saw_or++;
+ shift;
+ }
+ else {
+ $out .= " &&" unless $ARGV[0] eq ')';
+ $out .= "\n";
+ shift if $ARGV[0] eq '-a';
+ }
+ }
+}
+
+print <<"END";
+#!$bin/perl
+
+eval 'exec $bin/perl -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+
+END
+
+if ($initls) {
+ print <<'END';
+@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
+@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
+
+END
+}
+
+if ($inituser || $initls) {
+ print 'while (($name, $pw, $uid) = getpwent) {', "\n";
+ print ' $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
+ print ' $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
+ print "}\n\n";
+}
+
+if ($initgroup || $initls) {
+ print 'while (($name, $pw, $gid) = getgrent) {', "\n";
+ print ' $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
+ print ' $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
+ print "}\n\n";
+}
+
+print $initnewer, "\n" if $initnewer;
+
+print $initfile, "\n" if $initfile;
+
+$find = $depth ? "finddepth" : "find";
+print <<"END";
+require "$find.pl";
+
+# Traverse desired filesystems
+
+&$find($roots);
+$flushall
+exit;
+
+sub wanted {
+$out;
+}
+
+END
+
+if ($initexec) {
+ print <<'END';
+sub exec {
+ local($ok, @cmd) = @_;
+ foreach $word (@cmd) {
+ $word =~ s#{}#$name#g;
+ }
+ if ($ok) {
+ local($old) = select(STDOUT);
+ $| = 1;
+ print "@cmd";
+ select($old);
+ return 0 unless <STDIN> =~ /^y/;
+ }
+ chdir $cwd; # sigh
+ system @cmd;
+ chdir $dir;
+ return !$?;
+}
+
+END
+}
+
+if ($initls) {
+ print <<'END';
+sub ls {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
+ $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
+
+ $pname = $name;
+
+ if (defined $blocks) {
+ $blocks = int(($blocks + 1) / 2);
+ }
+ else {
+ $blocks = int(($size + 1023) / 1024);
+ }
+
+ if (-f _) { $perms = '-'; }
+ elsif (-d _) { $perms = 'd'; }
+ elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
+ elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
+ elsif (-p _) { $perms = 'p'; }
+ elsif (-S _) { $perms = 's'; }
+ else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
+
+ $tmpmode = $mode;
+ $tmp = $rwx[$tmpmode & 7];
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
+ substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
+ substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
+ $perms .= $tmp;
+
+ $user = $user{$uid} || $uid;
+ $group = $group{$gid} || $gid;
+
+ ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
+ $moname = $moname[$mon];
+ if (-M _ > 365.25 / 2) {
+ $timeyear = '19' . $year;
+ }
+ else {
+ $timeyear = sprintf("%02d:%02d", $hour, $min);
+ }
+
+ printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
+ $ino,
+ $blocks,
+ $perms,
+ $nlink,
+ $user,
+ $group,
+ $sizemm,
+ $moname,
+ $mday,
+ $timeyear,
+ $pname;
+ 1;
+}
+
+sub sizemm {
+ sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
+}
+
+END
+}
+
+if ($initcpio) {
+print <<'END';
+sub cpio {
+ local($nc,$fh) = @_;
+ local($text);
+
+ if ($name eq 'TRAILER!!!') {
+ $text = '';
+ $size = 0;
+ }
+ else {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
+ if (-f _) {
+ open(IN, "./$_\0") || do {
+ warn "Couldn't open $name: $!\n";
+ return;
+ };
+ }
+ else {
+ $text = readlink($_);
+ $size = 0 unless defined $text;
+ }
+ }
+
+ ($nm = $name) =~ s#^\./##;
+ $nc{$fh} = $nc;
+ if ($nc eq 'n') {
+ $cpout{$fh} .=
+ sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
+ 070707,
+ $dev & 0777777,
+ $ino & 0777777,
+ $mode & 0777777,
+ $uid & 0777777,
+ $gid & 0777777,
+ $nlink & 0777777,
+ $rdev & 0177777,
+ $mtime,
+ length($nm)+1,
+ $size,
+ $nm);
+ }
+ else {
+ $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
+ $cpout{$fh} .= pack("SSSSSSSSLSLa*",
+ 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
+ length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
+ }
+ if ($text ne '') {
+ $cpout{$fh} .= $text;
+ }
+ elsif ($size) {
+ &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
+ while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
+ &flush($fh);
+ $l = length($cpout{$fh});
+ }
+ }
+ close IN;
+}
+
+sub flush {
+ local($fh) = @_;
+
+ while (length($cpout{$fh}) >= 5120) {
+ syswrite($fh,$cpout{$fh},5120);
+ ++$blocks{$fh};
+ substr($cpout{$fh}, 0, 5120) = '';
+ }
+}
+
+sub flushall {
+ $name = 'TRAILER!!!';
+ foreach $fh (keys %cpout) {
+ &cpio($nc{$fh},$fh);
+ $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
+ &flush($fh);
+ print $blocks{$fh} * 10, " blocks\n";
+ }
+}
+
+END
+}
+
+if ($inittar) {
+print <<'END';
+sub tar {
+ local($fh) = @_;
+ local($linkname,$header,$l,$slop);
+ local($linkflag) = "\0";
+
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
+ $nm = $name;
+ if ($nlink > 1) {
+ if ($linkname = $linkseen{$fh,$dev,$ino}) {
+ $linkflag = 1;
+ }
+ else {
+ $linkseen{$fh,$dev,$ino} = $nm;
+ }
+ }
+ if (-f _) {
+ open(IN, "./$_\0") || do {
+ warn "Couldn't open $name: $!\n";
+ return;
+ };
+ $size = 0 if $linkflag ne "\0";
+ }
+ else {
+ $linkname = readlink($_);
+ $linkflag = 2 if defined $linkname;
+ $nm .= '/' if -d _;
+ $size = 0;
+ }
+
+ $header = pack("a100a8a8a8a12a12a8a1a100",
+ $nm,
+ sprintf("%6o ", $mode & 0777),
+ sprintf("%6o ", $uid & 0777777),
+ sprintf("%6o ", $gid & 0777777),
+ sprintf("%11o ", $size),
+ sprintf("%11o ", $mtime),
+ " ",
+ $linkflag,
+ $linkname);
+ $l = length($header) % 512;
+ substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
+ substr($header, 154, 1) = "\0"; # blech
+ $tarout{$fh} .= $header;
+ $tarout{$fh} .= "\0" x (512 - $l) if $l;
+ if ($size) {
+ &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
+ while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
+ $slop = length($tarout{$fh}) % 512;
+ $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
+ &tflush($fh);
+ $l = length($tarout{$fh});
+ }
+ }
+ close IN;
+}
+
+sub tflush {
+ local($fh) = @_;
+
+ while (length($tarout{$fh}) >= 10240) {
+ syswrite($fh,$tarout{$fh},10240);
+ ++$blocks{$fh};
+ substr($tarout{$fh}, 0, 10240) = '';
+ }
+}
+
+sub tflushall {
+ local($len);
+
+ foreach $fh (keys %tarout) {
+ $len = 10240 - length($tarout{$fh});
+ $len += 10240 if $len < 1024;
+ $tarout{$fh} .= "\0" x $len;
+ &tflush($fh);
+ }
+}
+
+END
+}
+
+exit;
+
+############################################################################
+
+sub tab {
+ local($tabstring);
+
+ $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
+ if (!$statdone) {
+ if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) {
+ $delayedstat++;
+ }
+ else {
+ if ($saw_or) {
+ $tabstring .= <<'ENDOFSTAT' . $tabstring;
+($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+ENDOFSTAT
+ }
+ else {
+ $tabstring .= <<'ENDOFSTAT' . $tabstring;
+(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+ENDOFSTAT
+ }
+ $statdone = 1;
+ }
+ }
+ $tabstring =~ s/^\s+/ / if $out =~ /!$/;
+ $tabstring;
+}
+
+sub fileglob_to_re {
+ local($tmp) = @_;
+
+ $tmp =~ s/([.^\$()])/\\$1/g;
+ $tmp =~ s/([?*])/.$1/g;
+ "^$tmp$";
+}
+
+sub n {
+ local($n) = @_;
+
+ $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
+ $n =~ s/ 0*(\d)/ $1/;
+ $n;
+}
+
+sub quote {
+ local($string) = @_;
+ $string =~ s/'/\\'/;
+ "'$string'";
+}
$out .= &tab;
$type = shift;
if ($type eq 'nfs')
- { $out .= '$dev < 0'; }
+ { $out .= '($dev < 0)'; }
else
- { $out .= '$dev >= 0'; }
+ { $out .= '($dev >= 0)'; }
}
elsif ($_ eq 'user') {
$uname = shift;
- $out .= &tab . "\$uid == \$uid{'$uname'}";
+ $out .= &tab . "(\$uid == \$uid{'$uname'})";
$inituser++;
}
elsif ($_ eq 'group') {
$gname = shift;
- $out .= &tab . "\$gid == \$gid{'$gname'}";
+ $out .= &tab . "(\$gid == \$gid{'$gname'})";
$initgroup++;
}
elsif ($_ eq 'nouser') {
$initgroup++;
}
elsif ($_ eq 'links') {
- $out .= &tab . '$nlink ' . &n(shift);
+ $out .= &tab . '($nlink ' . &n(shift);
}
elsif ($_ eq 'inum') {
- $out .= &tab . '$ino ' . &n(shift);
+ $out .= &tab . '($ino ' . &n(shift);
}
elsif ($_ eq 'size') {
- $out .= &tab . 'int((-s _ + 511) / 512) ' . &n(shift);
+ $out .= &tab . '(int((-s _ + 511) / 512) ' . &n(shift);
}
elsif ($_ eq 'atime') {
- $out .= &tab . 'int(-A _) ' . &n(shift);
+ $out .= &tab . '(int(-A _) ' . &n(shift);
}
elsif ($_ eq 'mtime') {
- $out .= &tab . 'int(-M _) ' . &n(shift);
+ $out .= &tab . '(int(-M _) ' . &n(shift);
}
elsif ($_ eq 'ctime') {
- $out .= &tab . 'int(-C _) ' . &n(shift);
+ $out .= &tab . '(int(-C _) ' . &n(shift);
}
elsif ($_ eq 'exec') {
for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
$newername = 'AGE_OF' . $file;
$newername =~ s/[^\w]/_/g;
$newername = '$' . $newername;
- $out .= "-M _ < $newername";
+ $out .= "(-M _ < $newername)";
$initnewer .= "$newername = -M " . "e($file) . ";\n";
}
elsif ($_ eq 'eval') {
sub fileglob_to_re {
local($tmp) = @_;
- $tmp =~ s/([.^\$()])/\\$1/g;
+ $tmp =~ s#([./^\$()])#\\$1#g;
$tmp =~ s/([?*])/.$1/g;
"^$tmp$";
}
$n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
$n =~ s/ 0*(\d)/ $1/;
- $n;
+ $n . ')';
}
sub quote {
-/* $RCSfile: handy.h,v $$Revision: 4.0.1.2 $$Date: 91/06/07 12:15:43 $
+/* $RCSfile: handy.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:19 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: handy.h,v $
+ * Revision 4.1 92/08/07 18:29:19 lwall
+ *
* Revision 4.0.1.2 91/06/07 12:15:43 lwall
* patch4: new copyright notice
*
-/* $RCSfile: hash.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:15:55 $
+/* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:20 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: hash.c,v $
+ * Revision 4.1 92/08/07 18:29:20 lwall
+ *
* Revision 4.0.1.1 91/06/07 12:15:55 lwall
* patch4: new copyright notice
*
-/* $RCSfile: hash.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:16:04 $
+/* $RCSfile: hash.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:21 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: hash.h,v $
+ * Revision 4.1 92/08/07 18:29:21 lwall
+ *
* Revision 4.0.1.1 91/06/07 12:16:04 lwall
* patch4: new copyright notice
*
--- /dev/null
+../makedepend
+make: Warning: Both `makefile' and `Makefile' exists
+Current working directory /usr/src/local/lwall/perl5/x2p
+echo hash.c malloc.c str.c util.c walk.c | tr ' ' '\012' >.clist
+Finding dependencies for hash.o.
+Finding dependencies for malloc.o.
+Finding dependencies for str.o.
+Finding dependencies for util.o.
+Finding dependencies for walk.o.
+make: Warning: Both `makefile' and `Makefile' exists
+Current working directory /usr/src/local/lwall/perl5/x2p
+echo Makefile.SH makedepend.SH | tr ' ' '\012' >.shlist
+Updating makefile...
--- /dev/null
+# : Makefile.SH,v 15738Revision: 4.1 15738Date: 92/08/07 18:29:07 $
+#
+# $Log: Makefile.SH,v $
+# Revision 4.1 92/08/07 18:29:07 lwall
+#
+# Revision 4.0.1.3 92/06/08 16:11:32 lwall
+# patch20: SH files didn't work well with symbolic links
+# patch20: cray didn't give enough memory to /bin/sh
+# patch20: makefiles now display new shift/reduce expectations
+#
+# Revision 4.0.1.2 91/11/05 19:19:04 lwall
+# patch11: random cleanup
+#
+# Revision 4.0.1.1 91/06/07 12:12:14 lwall
+# patch4: cflags now emits entire cc command except for the filename
+#
+# Revision 4.0 91/03/20 01:57:03 lwall
+# 4.0 baseline.
+#
+#
+
+CC = cc
+YACC = /bin/yacc
+bin = /usr/local/bin
+lib =
+mansrc = /usr/man/manl
+manext = l
+LDFLAGS =
+SMALL =
+LARGE =
+mallocsrc = malloc.c
+mallocobj = malloc.o
+shellflags =
+
+libs = -ldbm -lm -lposix
+
+CCCMD = `sh $(shellflags) cflags $@`
+
+public = a2p s2p find2perl
+
+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:
+ $(CCCMD) $*.c
+
+all: $(public) $(private) $(util)
+ touch all
+
+a2p: $(obj) a2p.o
+ $(CC) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p
+
+a2p.c: a2p.y
+ @ echo Expect 231 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 str.h hash.h
+ $(CCCMD) $(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
+ - if test `pwd` != $(mansrc); then \
+for page in $(manpages); do \
+cp $$page $(mansrc)/`basename $$page .man`.$(manext); \
+done; \
+fi
+
+clean:
+ rm -f a2p *.o a2p.c
+
+realclean: clean
+ rm -f *.orig */*.orig core $(addedbyconf) a2p.c s2p find2perl all cflags
+
+# 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: $(mallocsrc) ../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 .
+
+malloc.c: ../malloc.c
+ sed <../malloc.c >malloc.c \
+ -e 's/"perl.h"/"..\/perl.h"/' \
+ -e 's/my_exit/exit/'
+
+# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
+# If this runs make out of memory, delete /usr/include lines.
+hash.o:
+hash.o: ../config.h
+hash.o: /usr/ucbinclude/ctype.h
+hash.o: /usr/ucbinclude/stdio.h
+hash.o: EXTERN.h
+hash.o: a2p.h
+hash.o: handy.h
+hash.o: hash.c
+hash.o: hash.h
+hash.o: str.h
+hash.o: util.h
+malloc.o:
+malloc.o: ../av.h
+malloc.o: ../config.h
+malloc.o: ../cop.h
+malloc.o: ../embed.h
+malloc.o: ../form.h
+malloc.o: ../gv.h
+malloc.o: ../handy.h
+malloc.o: ../hv.h
+malloc.o: ../op.h
+malloc.o: ../opcode.h
+malloc.o: ../perl.h
+malloc.o: ../pm.h
+malloc.o: ../pp.h
+malloc.o: ../proto.h
+malloc.o: ../regexp.h
+malloc.o: ../sv.h
+malloc.o: ../unixish.h
+malloc.o: ../util.h
+malloc.o: /usr/ucbinclude/ctype.h
+malloc.o: /usr/ucbinclude/dirent.h
+malloc.o: /usr/ucbinclude/errno.h
+malloc.o: /usr/ucbinclude/machine/param.h
+malloc.o: /usr/ucbinclude/machine/setjmp.h
+malloc.o: /usr/ucbinclude/ndbm.h
+malloc.o: /usr/ucbinclude/netinet/in.h
+malloc.o: /usr/ucbinclude/setjmp.h
+malloc.o: /usr/ucbinclude/stdio.h
+malloc.o: /usr/ucbinclude/sys/dirent.h
+malloc.o: /usr/ucbinclude/sys/errno.h
+malloc.o: /usr/ucbinclude/sys/filio.h
+malloc.o: /usr/ucbinclude/sys/ioccom.h
+malloc.o: /usr/ucbinclude/sys/ioctl.h
+malloc.o: /usr/ucbinclude/sys/param.h
+malloc.o: /usr/ucbinclude/sys/signal.h
+malloc.o: /usr/ucbinclude/sys/sockio.h
+malloc.o: /usr/ucbinclude/sys/stat.h
+malloc.o: /usr/ucbinclude/sys/stdtypes.h
+malloc.o: /usr/ucbinclude/sys/sysmacros.h
+malloc.o: /usr/ucbinclude/sys/time.h
+malloc.o: /usr/ucbinclude/sys/times.h
+malloc.o: /usr/ucbinclude/sys/ttold.h
+malloc.o: /usr/ucbinclude/sys/ttychars.h
+malloc.o: /usr/ucbinclude/sys/ttycom.h
+malloc.o: /usr/ucbinclude/sys/ttydev.h
+malloc.o: /usr/ucbinclude/sys/types.h
+malloc.o: /usr/ucbinclude/time.h
+malloc.o: /usr/ucbinclude/vm/faultcode.h
+malloc.o: EXTERN.h
+malloc.o: malloc.c
+str.o:
+str.o: ../config.h
+str.o: /usr/ucbinclude/ctype.h
+str.o: /usr/ucbinclude/stdio.h
+str.o: EXTERN.h
+str.o: a2p.h
+str.o: handy.h
+str.o: hash.h
+str.o: str.c
+str.o: str.h
+str.o: util.h
+util.o:
+util.o: ../config.h
+util.o: /usr/ucbinclude/ctype.h
+util.o: /usr/ucbinclude/stdio.h
+util.o: EXTERN.h
+util.o: INTERN.h
+util.o: a2p.h
+util.o: handy.h
+util.o: hash.h
+util.o: str.h
+util.o: util.c
+util.o: util.h
+walk.o:
+walk.o: ../config.h
+walk.o: /usr/ucbinclude/ctype.h
+walk.o: /usr/ucbinclude/stdio.h
+walk.o: EXTERN.h
+walk.o: a2p.h
+walk.o: handy.h
+walk.o: hash.h
+walk.o: str.h
+walk.o: util.h
+walk.o: walk.c
+Makefile: Makefile.SH config.sh ; /bin/sh Makefile.SH
+makedepend: makedepend.SH config.sh ; /bin/sh makedepend.SH
+# WARNING: Put nothing here or make depend will gobble it up!
--- /dev/null
+/* $RCSfile: malloc.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:25 $
+ *
+ * $Log: malloc.c,v $
+ * Revision 4.1 92/08/07 18:24:25 lwall
+ *
+ * Revision 4.0.1.4 92/06/08 14:28:38 lwall
+ * patch20: removed implicit int declarations on functions
+ * patch20: hash tables now split only if the memory is available to do so
+ * patch20: realloc(0, size) now does malloc in case library routines call it
+ *
+ * Revision 4.0.1.3 91/11/05 17:57:40 lwall
+ * patch11: safe malloc code now integrated into Perl's malloc when possible
+ *
+ * Revision 4.0.1.2 91/06/07 11:20:45 lwall
+ * patch4: many, many itty-bitty portability fixes
+ *
+ * Revision 4.0.1.1 91/04/11 17:48:31 lwall
+ * patch1: Configure now figures out malloc ptr type
+ *
+ * Revision 4.0 91/03/20 01:28:52 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#ifndef lint
+/*SUPPRESS 592*/
+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 int findbucket();
+static int 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 ALIGNBYTES > 4
+ 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 <stdio.h>
+#endif
+
+#ifdef debug
+#define ASSERT(p) if (!(p)) botch("p"); else
+static void
+botch(s)
+ char *s;
+{
+
+ printf("assertion botched: %s\n", s);
+ abort();
+}
+#else
+#define ASSERT(p)
+#endif
+
+MALLOCPTRTYPE *
+malloc(nbytes)
+ register MEM_SIZE nbytes;
+{
+ register union overhead *p;
+ register int bucket = 0;
+ register MEM_SIZE shiftr;
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+ MEM_SIZE size = nbytes;
+#endif
+
+#ifdef MSDOS
+ if (nbytes > 0xffff) {
+ fprintf(stderr, "Allocation too large: %lx\n", (long)nbytes);
+ exit(1);
+ }
+#endif /* MSDOS */
+#ifdef DEBUGGING
+ if ((long)nbytes < 0)
+ fatal("panic: malloc");
+#endif
+#endif /* safemalloc */
+
+ /*
+ * 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) {
+#ifdef safemalloc
+ if (!nomemok) {
+ fputs("Out of memory!\n", stderr);
+ exit(1);
+ }
+#else
+ return (NULL);
+#endif
+ }
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+# if !(defined(I286) || defined(atarist))
+ if (debug & 128)
+ fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",p+1,an++,(long)size);
+# else
+ if (debug & 128)
+ fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",p+1,an++,(long)size);
+# endif
+#endif
+#endif /* safemalloc */
+
+ /* remove from linked list */
+#ifdef RCHECK
+ if (*((int*)p) & (sizeof(union overhead) - 1))
+#if !(defined(I286) || defined(atarist))
+ 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 ((MALLOCPTRTYPE *)(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 MEM_SIZE siz;
+
+ if (nextf[bucket])
+ return;
+ /*
+ * Insure memory is allocated
+ * on a page boundary. Should
+ * make getpageize call?
+ */
+#ifndef atarist /* on the atari we dont have to worry about this */
+ 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
+#endif /* atarist */
+
+#if !(defined(I286) || defined(atarist))
+ /* 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!), probably good on the atari too */
+ 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(1L << 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 *)(((MEM_SIZE)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);
+ }
+}
+
+void
+free(mp)
+ MALLOCPTRTYPE *mp;
+{
+ register MEM_SIZE size;
+ register union overhead *op;
+ char *cp = (char*)mp;
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+# if !(defined(I286) || defined(atarist))
+ if (debug & 128)
+ fprintf(stderr,"0x%x: (%05d) free\n",cp,an++);
+# else
+ if (debug & 128)
+ fprintf(stderr,"0x%lx: (%05d) free\n",cp,an++);
+# endif
+#endif
+#endif /* safemalloc */
+
+ 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 */
+
+MALLOCPTRTYPE *
+realloc(mp, nbytes)
+ MALLOCPTRTYPE *mp;
+ MEM_SIZE nbytes;
+{
+ register MEM_SIZE onb;
+ union overhead *op;
+ char *res;
+ register int i;
+ int was_alloced = 0;
+ char *cp = (char*)mp;
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+ MEM_SIZE size = nbytes;
+#endif
+
+#ifdef MSDOS
+ if (nbytes > 0xffff) {
+ fprintf(stderr, "Reallocation too large: %lx\n", size);
+ exit(1);
+ }
+#endif /* MSDOS */
+ if (!cp)
+ return malloc(nbytes);
+#ifdef DEBUGGING
+ if ((long)nbytes < 0)
+ fatal("panic: realloc");
+#endif
+#endif /* safemalloc */
+
+ 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 = (1L << (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
+ res = cp;
+ }
+ else {
+ if ((res = (char*)malloc(nbytes)) == NULL)
+ return (NULL);
+ if (cp != res) /* common optimization */
+ Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
+ if (was_alloced)
+ free(cp);
+ }
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+# if !(defined(I286) || defined(atarist))
+ if (debug & 128) {
+ fprintf(stderr,"0x%x: (%05d) rfree\n",res,an++);
+ fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",res,an++,(long)size);
+ }
+# else
+ if (debug & 128) {
+ fprintf(stderr,"0x%lx: (%05d) rfree\n",res,an++);
+ fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",res,an++,(long)size);
+ }
+# endif
+#endif
+#endif /* safemalloc */
+ return ((MALLOCPTRTYPE*)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 int
+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.
+ */
+void
+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 */
--- /dev/null
+#!/usr/local/bin/perl
+
+eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+$bin = '/usr/local/bin';
+
+# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
+#
+# $Log: s2p.SH,v $
+# Revision 4.1 92/08/07 18:29:23 lwall
+#
+# Revision 4.0.1.2 92/06/08 17:26:31 lwall
+# patch20: s2p didn't output portable startup code
+# patch20: added ... as variant on ..
+# patch20: s2p didn't translate s/pat/\&/ or s/pat/\$/ or s/pat/\\1/ right
+#
+# Revision 4.0.1.1 91/06/07 12:19:18 lwall
+# patch4: s2p now handles embedded newlines better and optimizes common idioms
+#
+# Revision 4.0 91/03/20 01:57:59 lwall
+# 4.0 baseline.
+#
+#
+
+$indent = 4;
+$shiftwidth = 4;
+$l = '{'; $r = '}';
+
+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$$") ||
+ &Die("Can't open temp file: $!\n");
+}
+
+if (!$assumen && !$assumep) {
+ print BODY &q(<<'EOT');
+: while ($ARGV[0] =~ /^-/) {
+: $_ = shift;
+: last if /^--/;
+: if (/^-n/) {
+: $nflag++;
+: next;
+: }
+: die "I don't recognize this switch: $_\\n";
+: }
+:
+EOT
+}
+
+print BODY &q(<<'EOT');
+: #ifdef PRINTIT
+: #ifdef ASSUMEP
+: $printit++;
+: #else
+: $printit++ unless $nflag;
+: #endif
+: #endif
+: <><>
+: $\ = "\n"; # automatically add newline on print
+: <><>
+: #ifdef TOPLABEL
+: LINE:
+: while (chop($_ = <>)) {
+: #else
+: LINE:
+: while (<>) {
+: chop;
+: #endif
+EOT
+
+LINE:
+while (<>) {
+
+ # Wipe out surrounding whitespace.
+
+ s/[ \t]*(.*)\n$/$1/;
+
+ # Perhaps it's a label/comment.
+
+ if (/^:/) {
+ s/^:[ \t]*//;
+ $label = &make_label($_);
+ if ($. == 1) {
+ $toplabel = $label;
+ if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
+ $_ = <>;
+ redo LINE; # Never referenced, so delete it if not a comment.
+ }
+ }
+ $_ = "$label:";
+ if ($lastlinewaslabel++) {
+ $indent += 4;
+ print BODY &tab, ";\n";
+ $indent -= 4;
+ }
+ if ($indent >= 2) {
+ $indent -= 2;
+ $indmod = 2;
+ }
+ next;
+ } else {
+ $lastlinewaslabel = '';
+ }
+
+ # Look for one or two address clauses
+
+ $addr1 = '';
+ $addr2 = '';
+ if (s/^([0-9]+)//) {
+ $addr1 = "$1";
+ $addr1 = "\$. == $addr1" unless /^,/;
+ }
+ elsif (s/^\$//) {
+ $addr1 = 'eof()';
+ }
+ elsif (s|^/||) {
+ $addr1 = &fetchpat('/');
+ }
+ if (s/^,//) {
+ if (s/^([0-9]+)//) {
+ $addr2 = "$1";
+ } elsif (s/^\$//) {
+ $addr2 = "eof()";
+ } elsif (s|^/||) {
+ $addr2 = &fetchpat('/');
+ } else {
+ &Die("Invalid second address at line $.\n");
+ }
+ if ($addr2 =~ /^\d+$/) {
+ $addr1 .= "..$addr2";
+ }
+ else {
+ $addr1 .= "...$addr2";
+ }
+ }
+
+ # Now we check for metacommands {, }, and ! and worry
+ # about indentation.
+
+ s/^[ \t]+//;
+ # a { to keep vi happy
+ 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 = '';
+ }
+ $_ = &transmogrify();
+ }
+
+ # See if we can optimize to modifier form.
+
+ if ($addr1) {
+ if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
+ $_ !~ / if / && $_ !~ / unless /) {
+ s/;$/ $if $addr1;/;
+ $_ = substr($_,$shiftwidth,1000);
+ } else {
+ $_ = "$if ($addr1) $l\n$change$_$rmaybe";
+ }
+ $change = '';
+ next LINE;
+ }
+} continue {
+ @lines = split(/\n/,$_);
+ for (@lines) {
+ unless (s/^ *<<--//) {
+ print BODY &tab;
+ }
+ print BODY $_, "\n";
+ }
+ $indent += $indmod;
+ $indmod = 0;
+ if ($redo) {
+ $_ = $redo;
+ $redo = '';
+ redo LINE;
+ }
+}
+if ($lastlinewaslabel++) {
+ $indent += 4;
+ print BODY &tab, ";\n";
+ $indent -= 4;
+}
+
+if ($appendseen || $tseen || !$assumen) {
+ $printit++ if $dseen || (!$assumen && !$assumep);
+ print BODY &q(<<'EOT');
+: #ifdef SAWNEXT
+: }
+: continue {
+: #endif
+: #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 = 0;
+: #endif
+: #ifdef APPENDSEEN
+: if ($atext) { chop $atext; print $atext; $atext = ''; }
+: #endif
+EOT
+
+print BODY &q(<<'EOT');
+: }
+EOT
+}
+
+close BODY;
+
+unless ($debug) {
+ open(HEAD,">/tmp/sperl2$$.c")
+ || &Die("Can't open temp file 2: $!\n");
+ 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;
+ print HEAD "#define TOPLABEL\n" if $toplabel;
+ print HEAD "#define SAWNEXT\n" if $sawnext;
+ if ($opens) {print HEAD "$opens\n";}
+ open(BODY,"/tmp/sperl$$")
+ || &Die("Can't reopen temp file: $!\n");
+ while (<BODY>) {
+ print HEAD $_;
+ }
+ close HEAD;
+
+ print &q(<<"EOT");
+: #!$bin/perl
+: eval 'exec $bin/perl -S \$0 \${1+"\$@"}'
+: if \$running_under_some_shell;
+:
+EOT
+ open(BODY,"cc -E /tmp/sperl2$$.c |") ||
+ &Die("Can't reopen temp file: $!\n");
+ while (<BODY>) {
+ /^# [0-9]/ && next;
+ /^[ \t]*$/ && next;
+ s/^<><>//;
+ print;
+ }
+}
+
+&Cleanup;
+exit;
+
+sub Cleanup {
+ chdir "/tmp";
+ unlink "sperl$$", "sperl2$$", "sperl2$$.c";
+}
+sub Die {
+ &Cleanup;
+ die $_[0];
+}
+sub tab {
+ "\t" x ($indent / 8) . ' ' x ($indent % 8);
+}
+sub make_filehandle {
+ local($_) = $_[0];
+ local($fname) = $_;
+ if (!$seen{$fname}) {
+ $_ = "FH_" . $_ if /^\d/;
+ s/[^a-zA-Z0-9]/_/g;
+ s/^_*//;
+ $_ = "\U$_";
+ if ($fhseen{$_}) {
+ for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
+ $_ .= $tmp;
+ }
+ $fhseen{$_} = 1;
+ $opens .= &q(<<"EOT");
+: open($_, '>$fname') || die "Can't create $fname: \$!";
+EOT
+ $seen{$fname} = $_;
+ }
+ $seen{$fname};
+}
+
+sub make_label {
+ local($label) = @_;
+ $label =~ s/[^a-zA-Z0-9]/_/g;
+ if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
+ $label = substr($label,0,8);
+
+ # Could be a reserved word, so capitalize it.
+ substr($label,0,1) =~ y/a-z/A-Z/
+ if $label =~ /^[a-z]/;
+
+ $label;
+}
+
+sub transmogrify {
+ { # case
+ if (/^d/) {
+ $dseen++;
+ chop($_ = &q(<<'EOT'));
+: <<--#ifdef PRINTIT
+: $printit = 0;
+: <<--#endif
+: next LINE;
+EOT
+ $sawnext++;
+ next;
+ }
+
+ if (/^n/) {
+ chop($_ = &q(<<'EOT'));
+: <<--#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) {chop $atext; print $atext; $atext = '';}
+: <<--#endif
+: $_ = <>;
+: chop;
+: <<--#ifdef TSEEN
+: $tflag = 0;
+: <<--#endif
+EOT
+ next;
+ }
+
+ if (/^a/) {
+ $appendseen++;
+ $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
+ $lastline = 0;
+ while (<>) {
+ s/^[ \t]*//;
+ s/^[\\]//;
+ unless (s|\\$||) { $lastline = 1;}
+ s/^([ \t]*\n)/<><>$1/;
+ $command .= $_;
+ $command .= '<<--';
+ last if $lastline;
+ }
+ $_ = $command . "End_Of_Text";
+ last;
+ }
+
+ if (/^[ic]/) {
+ if (/^c/) { $change = 1; }
+ $addr1 = 1 if $addr1 eq '';
+ $addr1 = '$iter = (' . $addr1 . ')';
+ $command = $space .
+ " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
+ $lastline = 0;
+ while (<>) {
+ s/^[ \t]*//;
+ s/^[\\]//;
+ unless (s/\\$//) { $lastline = 1;}
+ s/'/\\'/g;
+ s/^([ \t]*\n)/<><>$1/;
+ $command .= $_;
+ $command .= '<<--';
+ last if $lastline;
+ }
+ $_ = $command . "End_Of_Text";
+ if ($change) {
+ $dseen++;
+ $change = "$_\n";
+ chop($_ = &q(<<"EOT"));
+: <<--#ifdef PRINTIT
+: $space\$printit = 0;
+: <<--#endif
+: ${space}next LINE;
+EOT
+ $sawnext++;
+ }
+ 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($_, $i, 0) = '\\';
+ $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 (substr($_,$i,1) =~ /^[n]$/) {
+ ;
+ }
+ elsif (!$repl &&
+ substr($_,$i,1) =~ /^[(){}\w]$/) {
+ $i--;
+ $len--;
+ substr($_, $i, 1) = '';
+ }
+ elsif (!$repl &&
+ substr($_,$i,1) =~ /^[<>]$/) {
+ substr($_,$i,1) = 'b';
+ }
+ elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
+ substr($_,$i-1,1) = '$';
+ }
+ }
+ elsif ($c eq '&' && $repl) {
+ substr($_, $i, 0) = '$';
+ $i++;
+ $len++;
+ }
+ elsif ($c eq '$' && $repl) {
+ substr($_, $i, 0) = '\\';
+ $i++;
+ $len++;
+ }
+ elsif ($c eq '[' && !$repl) {
+ $i++ if substr($_,$i,1) eq '^';
+ $i++ if substr($_,$i,1) eq ']';
+ $inbracket = 1;
+ }
+ elsif ($c eq ']') {
+ $inbracket = 0;
+ }
+ elsif ($c eq "\t") {
+ substr($_, $i, 1) = '\\t';
+ $i++;
+ $len++;
+ }
+ elsif (!$repl && index("()+",$c) >= 0) {
+ substr($_, $i, 0) = '\\';
+ $i++;
+ $len++;
+ }
+ }
+ &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);
+ &simplify($pat);
+ $dol = '$';
+ $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 = &make_filehandle($end);
+ $cmd .= " && (print $fh \$_)";
+ $end = '';
+ next;
+ }
+ &Die("Unrecognized substitution command".
+ "($end) at line $.\n");
+ }
+ chop ($_ = &q(<<"EOT"));
+: <<--#ifdef TSEEN
+: $subst && \$tflag++$cmd;
+: <<--#else
+: $subst$cmd;
+: <<--#endif
+EOT
+ next;
+ }
+
+ if (/^p/) {
+ $_ = 'print;';
+ next;
+ }
+
+ if (/^w/) {
+ s/^w[ \t]*//;
+ $fh = &make_filehandle($_);
+ $_ = "print $fh \$_;";
+ next;
+ }
+
+ if (/^r/) {
+ $appendseen++;
+ s/^r[ \t]*//;
+ $file = $_;
+ $_ = "\$atext .= `cat $file 2>/dev/null`;";
+ next;
+ }
+
+ if (/^P/) {
+ $_ = 'print $1 if /^(.*)/;';
+ next;
+ }
+
+ if (/^D/) {
+ chop($_ = &q(<<'EOT'));
+: s/^.*\n?//;
+: redo LINE if $_;
+: next LINE;
+EOT
+ $sawnext++;
+ next;
+ }
+
+ if (/^N/) {
+ chop($_ = &q(<<'EOT'));
+: $_ .= "\n";
+: $len1 = length;
+: $_ .= <>;
+: chop if $len1 < length;
+: <<--#ifdef TSEEN
+: $tflag = 0;
+: <<--#endif
+EOT
+ next;
+ }
+
+ if (/^h/) {
+ $_ = '$hold = $_;';
+ next;
+ }
+
+ if (/^H/) {
+ $_ = '$hold .= "\n"; $hold .= $_;';
+ next;
+ }
+
+ if (/^g/) {
+ $_ = '$_ = $hold;';
+ next;
+ }
+
+ if (/^G/) {
+ $_ = '$_ .= "\n"; $_ .= $hold;';
+ next;
+ }
+
+ if (/^x/) {
+ $_ = '($_, $hold) = ($hold, $_);';
+ next;
+ }
+
+ if (/^b$/) {
+ $_ = 'next LINE;';
+ $sawnext++;
+ next;
+ }
+
+ if (/^b/) {
+ s/^b[ \t]*//;
+ $lab = &make_label($_);
+ if ($lab eq $toplabel) {
+ $_ = 'redo LINE;';
+ } else {
+ $_ = "goto $lab;";
+ }
+ next;
+ }
+
+ if (/^t$/) {
+ $_ = 'next LINE if $tflag;';
+ $sawnext++;
+ $tseen++;
+ next;
+ }
+
+ if (/^t/) {
+ s/^t[ \t]*//;
+ $lab = &make_label($_);
+ $_ = q/if ($tflag) {$tflag = 0; /;
+ if ($lab eq $toplabel) {
+ $_ .= 'redo LINE;}';
+ } else {
+ $_ .= "goto $lab;}";
+ }
+ $tseen++;
+ next;
+ }
+
+ if (/^y/) {
+ s/abcdefghijklmnopqrstuvwxyz/a-z/g;
+ s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
+ s/abcdef/a-f/g;
+ s/ABCDEF/A-F/g;
+ s/0123456789/0-9/g;
+ s/01234567/0-7/g;
+ $_ .= ';';
+ }
+
+ if (/^=/) {
+ $_ = 'print $.;';
+ next;
+ }
+
+ if (/^q/) {
+ chop($_ = &q(<<'EOT'));
+: close(ARGV);
+: @ARGV = ();
+: next LINE;
+EOT
+ $sawnext++;
+ 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);
+
+ # Process pattern one potential delimiter at a time.
+
+ DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
+ $prefix = $1;
+ $delim = $2;
+ if ($delim eq '\\') {
+ s/(.)//;
+ $ch = $1;
+ $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
+ $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 =~ s/\t/\\t/g;
+ &simplify($addr);
+ $addr;
+}
+
+sub q {
+ local($string) = @_;
+ local($*) = 1;
+ $string =~ s/^:\t?//g;
+ $string;
+}
+
+sub simplify {
+ $_[0] =~ s/_a-za-z0-9/\\w/ig;
+ $_[0] =~ s/a-z_a-z0-9/\\w/ig;
+ $_[0] =~ s/a-za-z_0-9/\\w/ig;
+ $_[0] =~ s/a-za-z0-9_/\\w/ig;
+ $_[0] =~ s/_0-9a-za-z/\\w/ig;
+ $_[0] =~ s/0-9_a-za-z/\\w/ig;
+ $_[0] =~ s/0-9a-z_a-z/\\w/ig;
+ $_[0] =~ s/0-9a-za-z_/\\w/ig;
+ $_[0] =~ s/\[\\w\]/\\w/g;
+ $_[0] =~ s/\[^\\w\]/\\W/g;
+ $_[0] =~ s/\[0-9\]/\\d/g;
+ $_[0] =~ s/\[^0-9\]/\\D/g;
+ $_[0] =~ s/\\d\\d\*/\\d+/g;
+ $_[0] =~ s/\\D\\D\*/\\D+/g;
+ $_[0] =~ s/\\w\\w\*/\\w+/g;
+ $_[0] =~ s/\\t\\t\*/\\t+/g;
+ $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
+ $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
+}
+
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>s2p <<'!NO!SUBS!'
-# $RCSfile: s2p.SH,v $$Revision: 4.0.1.2 $$Date: 92/06/08 17:26:31 $
+# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
#
# $Log: s2p.SH,v $
+# Revision 4.1 92/08/07 18:29:23 lwall
+#
# Revision 4.0.1.2 92/06/08 17:26:31 lwall
# patch20: s2p didn't output portable startup code
# patch20: added ... as variant on ..
.rn '' }`
-''' $RCSfile: s2p.man,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:57 $
+''' $RCSfile: s2p.man,v $$Revision: 4.1 $$Date: 92/08/07 18:29:24 $
'''
''' $Log: s2p.man,v $
+''' Revision 4.1 92/08/07 18:29:24 lwall
+'''
''' Revision 4.0.1.1 91/06/07 12:19:57 lwall
''' patch4: s2p now handles embedded newlines better and optimizes common idioms
'''
-/* $RCSfile: str.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20:08 $
+/* $RCSfile: str.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:26 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: str.c,v $
+ * Revision 4.1 92/08/07 18:29:26 lwall
+ *
* Revision 4.0.1.1 91/06/07 12:20:08 lwall
* patch4: new copyright notice
*
-/* $RCSfile: str.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20:22 $
+/* $RCSfile: str.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:27 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: str.h,v $
+ * Revision 4.1 92/08/07 18:29:27 lwall
+ *
* Revision 4.0.1.1 91/06/07 12:20:22 lwall
* patch4: new copyright notice
*
-/* $RCSfile: util.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20:35 $
+/* $RCSfile: util.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:29 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: util.c,v $
+ * Revision 4.1 92/08/07 18:29:29 lwall
+ *
* Revision 4.0.1.1 91/06/07 12:20:35 lwall
* patch4: new copyright notice
*
-/* $RCSfile: util.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 19:21:20 $
+/* $RCSfile: util.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:30 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: util.h,v $
+ * Revision 4.1 92/08/07 18:29:30 lwall
+ *
* Revision 4.0.1.2 91/11/05 19:21:20 lwall
* patch11: various portability fixes
*
-/* $RCSfile: walk.c,v $$Revision: 4.0.1.3 $$Date: 92/06/08 17:33:46 $
+/* $RCSfile: walk.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:31 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: walk.c,v $
+ * Revision 4.1 92/08/07 18:29:31 lwall
+ *
* Revision 4.0.1.3 92/06/08 17:33:46 lwall
* patch20: in a2p, simplified the filehandle model
* patch20: in a2p, made RS="" translate to $/ = "\n\n"
--- /dev/null
+#!/usr/bin/perl -i.bak
+
+while (<>) {
+ study;
+ s/\bFCMD\b/FF/g && study;
+ s/\bSTR\b/SV/g && study;
+ s/\bARRAY\b/AV/g && study;
+ s/\bARG\b/OP/g && study;
+ s/\bHASH\b/HV/g && study;
+ s/\bHENT\b/HE/g && study;
+ s/\bCMD\b/COP/g && study;
+ s/\bSPAT\b/PM/g && study;
+ s/\bSTIO\b/IO/g && study;
+ s/\bSTAB\b/GV/g && study;
+ s/\bSTBP\b/GP/g && study;
+ s/\bSUBR\b/SUB/g && study;
+
+ s/\bNullfcmd\b/Nullfield/g && study;
+ s/\bNullstr\b/Nullsv/g && study;
+ s/\bNullarg\b/Nullop/g && study;
+ s/\bNullcmd\b/Nullcop/g && study;
+ s/\bNullstab\b/Nullgv/g && study;
+
+ s/\bstruct stab\b/struct gv/g && study;
+ s/\bstruct stabptrs\b/struct gp/g && study;
+ s/\bstruct stio\b/struct io/g && study;
+ s/\bstruct string\b/struct sv/g && study;
+ s/\bstruct scanpat\b/struct pm/g && study;
+ s/\bstruct formcmd\b/struct ff/g && study;
+ s/\bstruct hentry\b/struct he/g && study;
+ s/\bstruct atbl\b/struct av/g && study;
+ s/\bstruct htbl\b/struct hv/g && study;
+ s/\bstruct cmd\b/struct cop/g && study;
+
+ s/\bcmdname\b/cop_name/g && study;
+ s/\bopname\b/op_name/g && study;
+
+ s/\bstab_stab\b/GvGV/g && study;
+ s/\bstab_estab\b/GvEGV/g && study;
+ s/\bstab_stash\b/GvSTASH/g && study;
+ s/\bstab_estash\b/GvESTASH/g && study;
+ s/\bstab_name\b/GvNAME/g && study;
+ s/\bstab_ename\b/GvENAME/g && study;
+ s/\bstab_hash\b/GvHVn/g && study;
+ s/\bstab_xhash\b/GvHV/g && study;
+ s/\bstab_array\b/GvAVn/g && study;
+ s/\bstab_xarray\b/GvAV/g && study;
+ s/\bstab_sub\b/GvSUB/g && study;
+ s/\bstab_form\b/GvFORM/g && study;
+ s/\bstab_magic\b/GvMAGIC/g && study;
+ s/\bstab_val\b/GvSV/g && study;
+ s/\bstab_xio\b/GvIO/g && study;
+ s/\bstab_io\b/GvIOn/g && study;
+ s/\bstab_lastexpr\b/GvLASTEXPR/g && study;
+ s/\bstab_line\b/GvLINE/g && study;
+ s/\bstab_flags\b/GvFLAGS/g && study;
+
+ s/\bstbp_val\b/gp_sv/g && study;
+ s/\bstbp_array\b/gp_av/g && study;
+ s/\bstbp_hash\b/gp_hv/g && study;
+ s/\bstbp_stab\b/gp_egv/g && study;
+
+ s/\bstr_array\b/sv_av/g && study;
+ s/\bstr_hash\b/sv_hv/g && study;
+ s/\bstr_cmd\b/sv_cop/g && study;
+ s/\bstr_args\b/sv_op/g && study;
+ s/\bstr_nval\b/sv_nv/g && study;
+ s/\bstr_pval\b/sv_pv/g && study;
+
+ s/\bSTABSET\b/SvSETMAGIC/g && study;
+ s/\bstabset\b/sv_setmagic/g && study;
+ s/\bSTR_SSET\b/SvSetSV/g && study;
+ s/\bSTR_SSET\b/SvSetPV/g && study;
+ s/\bSTR_SSET\b/SvSetNV/g && study;
+ s/\bSTR_GROW\b/SvGROW/g && study;
+ s/SINGLE\b/CONST/g && study;
+ s/DOUBLE\b/INTERP/g && study;
+
+ s/\bstr_true\b/SvTRUE/g && study;
+ s/\bstr_peek\b/SvPEEK/g && study;
+ s/\bstr_get\b/SvPV/g && study;
+ s/\bstr_gnum\b/SvNV/g && study;
+
+ s/\bstab\b/gv/g && study;
+ s/\bstr\b/sv/g && study;
+ s/\bStr\b/Sv/g && study;
+
+ s/\baadd\b/gv_AVn/g && study;
+
+ s/\baclear\b/av_clear/g && study;
+ s/\bafake\b/av_fake/g && study;
+ s/\bafetch\b/av_fetch/g && study;
+ s/\bafill\b/av_fill/g && study;
+ s/\bafree\b/av_free/g && study;
+ s/\balen\b/av_len/g && study;
+ s/\banew\b/newAV/g && study;
+ s/\bapop\b/av_pop/g && study;
+ s/\bapush\b/av_push/g && study;
+ s/\barg_free\b/op_free/g && study;
+ s/\bashift\b/av_shift/g && study;
+ s/\bastore\b/av_store/g && study;
+ s/\baunshift\b/av_unshift/g && study;
+ s/\bcastulong\b/cast_ulong/g && study;
+ s/\bcmd_exec\b/cop_exec/g && study;
+ s/\bcmd_free\b/cop_free/g && study;
+ s/\bcmd_to_arg\b/cop_to_arg/g && study;
+ s/\bcurcmd\b/curcop/g && study;
+ s/\bcval_to_arg\b/pv_to_op/g && study;
+ s/\bdehoist\b/dehoistXXX/g && study;
+ s/\bldehoist\b/ldehoistXXX/g && study;
+ s/\bdodb\b/CopDBadd/g && study;
+ s/\bdump_arg\b/dump_op/g && study;
+ s/\bdump_cmd\b/dump_cop/g && study;
+ s/\bdump_spat\b/dump_pm/g && study;
+ s/\bdump_stab\b/dump_gv/g && study;
+ s/\bdumpfds\b/dump_fds/g && study;
+ s/\benvix\b/setenv_getix/g && study;
+ s/\beval\b/oldeval/g && study;
+ s/\bevalstatic\b/op_fold_const/g && study;
+ s/\bfbmcompile\b/fbm_compile/g && study;
+ s/\bfbminstr\b/fbm_instr/g && study;
+ s/\bfixl\b/fixlXXX/g && study;
+ s/\bform_parseargs\b/XXX/g && study;
+ s/\bformat\b/run_format/g && study;
+ s/\bfree_arg\b/op_behead/g && study;
+ s/\bfstab\b/newGVfile/g && study;
+ s/\bgenstab\b/newGVgen/g && study;
+ s/\bgrow_dlevel\b/deb_growlevel/g && study;
+ s/\bgrowstr\b/cv_grow/g && study;
+ s/\bhadd\b/gv_HVn/g && study;
+ s/\bhclear\b/hv_clear/g && study;
+ s/\bhdbmclose\b/hv_dbmclose/g && study;
+ s/\bhdbmopen\b/hv_dbmopen/g && study;
+ s/\bhdbmstore\b/hv_dbmstore/g && study;
+ s/\bhdelete\b/hv_delete/g && study;
+ s/\bhentdelayfree\b/he_delayfree/g && study;
+ s/\bhentfree\b/he_free/g && study;
+ s/\bhfetch\b/hv_fetch/g && study;
+ s/\bhfree\b/hv_free/g && study;
+ s/\bhide_ary\b/hide_aryXXX/g && study;
+ s/\bhiterinit\b/hv_iterinit/g && study;
+ s/\bhiterkey\b/hv_iterkey/g && study;
+ s/\bhiternext\b/hv_iternext/g && study;
+ s/\bhiterval\b/hv_iterval/g && study;
+ s/\bhnew\b/newHV/g && study;
+ s/\bhstore\b/hv_store/g && study;
+ s/\binterp\b/sv_interp/g && study;
+ s/\bintrpcompile\b/sv_intrpcompile/g && study;
+ s/\blistish\b/forcelist/g && study;
+ s/\bload_format\b/parse_format/g && study;
+ s/\bmake_acmd\b/newACOP/g && study;
+ s/\bmake_ccmd\b/newCCOP/g && study;
+ s/\bmake_form\b/newFORM/g && study;
+ s/\bmake_icmd\b/newICOP/g && study;
+ s/\bmake_list\b/flatten/g && study;
+ s/\bmake_match\b/newPM/g && study;
+ s/\bmake_op\b/newOP/g && study;
+ s/\bmake_split\b/newSPLIT/g && study;
+ s/\bmake_sub\b/newSUB/g && study;
+ s/\bmake_usub\b/newUSUB/g && study;
+ s/\bmaybelistish\b/maybeforcelist/g && study;
+ s/\bmod_match\b/bind_match/g && study;
+ s/\bmylstat\b/my_lstat/g && study;
+ s/\bmypclose\b/my_pclose/g && study;
+ s/\bmypfiopen\b/my_pfiopen/g && study;
+ s/\bmypopen\b/my_popen/g && study;
+ s/\bmystat\b/my_stat/g && study;
+ s/\bop_new\b/newOP/g && study;
+ s/\bopt_arg\b/op_optimize/g && study;
+ s/\bparselist\b/parse_list/g && study;
+ s/\bperl_alloc\b/perl_alloc/g && study;
+ s/\bperl_callback\b/perl_callback/g && study;
+ s/\bperl_callv\b/perl_callv/g && study;
+ s/\bperl_construct\b/perl_construct/g && study;
+ s/\bperl_destruct\b/perl_destruct/g && study;
+ s/\bperl_free\b/perl_free/g && study;
+ s/\bperl_parse\b/perl_parse/g && study;
+ s/\bperl_run\b/perl_run/g && study;
+ s/\bregcomp\b/regcomp/g && study;
+ s/\bregdump\b/regdump/g && study;
+ s/\bregexec\b/regexec/g && study;
+ s/\bregfree\b/regfree/g && study;
+ s/\bregnext\b/regnext/g && study;
+ s/\bregprop\b/regprop/g && study;
+ s/\brepeatcpy\b/repeatcpy/g && study;
+ s/\brestorelist\b/leave_scope/g && study;
+ s/\bsaveaptr\b/save_aptr/g && study;
+ s/\bsaveary\b/save_ary/g && study;
+ s/\bsavehash\b/save_hash/g && study;
+ s/\bsavehptr\b/save_hptr/g && study;
+ s/\bsaveint\b/save_int/g && study;
+ s/\bsaveitem\b/save_item/g && study;
+ s/\bsavelines\b/save_lines/g && study;
+ s/\bsavelist\b/save_list/g && study;
+ s/\bsavelong\b/save_long/g && study;
+ s/\bsavenostab\b/save_nostab/g && study;
+ s/\bsavesptr\b/save_sptr/g && study;
+ s/\bscanconst\b/scan_const/g && study;
+ s/\bscanhex\b/scan_hex/g && study;
+ s/\bscanident\b/scan_ident/g && study;
+ s/\bscanoct\b/scan_oct/g && study;
+ s/\bscanpat\b/scan_pat/g && study;
+ s/\bscanstr\b/scan_str/g && study;
+ s/\bscansubst\b/scan_subst/g && study;
+ s/\bscantrans\b/scan_trans/g && study;
+ s/\bspat_free\b/pm_free/g && study;
+ s/\bstab2arg\b/gv_to_op/g && study;
+ s/\bstab_check\b/gv_check/g && study;
+ s/\bstab_clear\b/gv_clear/g && study;
+ s/\bstab_efullname\b/gv_efullname/g && study;
+ s/\bstab_fullname\b/gv_fullname/g && study;
+ s/\bstab_len\b/gv_len/g && study;
+ s/\bstab_str\b/gv_str/g && study;
+ s/\bstabent\b/gv_fetchpv/g && study;
+ s/\bstio_new\b/newIO/g && study;
+ s/\bstr_2mortal\b/sv_2mortal/g && study;
+ s/\bstr_2num\b/sv_2num/g && study;
+ s/\bstr_2ptr\b/sv_2ptr/g && study;
+ s/\bstr_append_till\b/sv_append_till/g && study;
+ s/\bstr_cat\b/sv_catpv/g && study;
+ s/\bstr_chop\b/sv_chop/g && study;
+ s/\bstr_cmp\b/sv_cmp/g && study;
+ s/\bstr_dec\b/sv_dec/g && study;
+ s/\bstr_eq\b/sv_eq/g && study;
+ s/\bstr_free\b/sv_free/g && study;
+ s/\bstr_gets\b/sv_gets/g && study;
+ s/\bstr_grow\b/sv_grow/g && study;
+ s/\bstr_inc\b/sv_inc/g && study;
+ s/\bstr_insert\b/sv_insert/g && study;
+ s/\bstr_len\b/sv_len/g && study;
+ s/\bstr_magic\b/sv_magic/g && study;
+ s/\bstr_make\b/newSVpv/g && study;
+ s/\bstr_mortal\b/sv_mortalcopy/g && study;
+ s/\bstr_ncat\b/sv_catpvn/g && study;
+ s/\bstr_new\b/newSV/g && study;
+ s/\bstr_nmake\b/newSVnv/g && study;
+ s/\bstr_nset\b/sv_setpvn/g && study;
+ s/\bstr_numset\b/sv_setnv/g && study;
+ s/\bstr_replace\b/sv_replace/g && study;
+ s/\bstr_reset\b/sv_reset/g && study;
+ s/\bstr_scat\b/sv_catsv/g && study;
+ s/\bstr_set\b/sv_setpv/g && study;
+ s/\bstr_smake\b/newSVsv/g && study;
+ s/\bstr_sset\b/sv_setsv/g && study;
+ s/\btaintenv\b/taint_env/g && study;
+ s/\btaintproper\b/taint_proper/g && study;
+ s/\barg\b/op/g && study;
+ s/\barg_ptr\.//g && study;
+ s/\barg_/op_/g && study;
+
+ s/\bSTR_/SV_/g && study;
+ s/\bSP_/SVp_/g && study;
+ s/\bSS_/SVs_/g && study;
+ s/\bSTAB_/GV_/g && study;
+ s/\bSF_/GVf_/g && study;
+ s/\bSPAT_/PMf_/g && study;
+ s/\bF_/FFt_/g && study;
+ s/\bFC_/FFf_/g && study;
+ s/\bO_/OP_/g && study;
+ s/\bC_/COP_/g && study;
+ s/\bCF_/COPf_/g && study;
+ s/\bCFT_/COPo_/g && study;
+ s/\bARF_/AVf_/g && study;
+ s/\bIOF_/IOf_/g && study;
+ s/\bStr_new\b/NEWSV/g && study;
+
+ s/\bstbp_/gp_/g && study;
+ s/\bstab_/gv_/g && study;
+ s/\bspat_/pm_/g && study;
+ s/\bstio/io/g && study;
+ s/\bf_/ff_/g && study;
+ s/\bStr_/Sv_/g && study;
+ s/\bstr_/sv_/g && study;
+ s/\btbl_/hv_/g && study;
+ s/\bary_/av_/g && study;
+ s/acmd\.ac_/acop_/g && study;
+ s/ccmd\.cc_/ccop_/g && study;
+ s/scmd\.sc_/scop_/g && study;
+ s/\bac_/acop_/g;
+ s/\bcc_/ccop_/g;
+ s/\bsc_/scop_/g;
+ s/\bc_/cop_/g;
+ s/spat/pm/g;
+ s/stab/gv/g;
+
+ print;
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff