+++ /dev/null
-Changes to perl
----------------
-
-Apart from little bug fixes, here are the new features:
-
-Perl can now handle binary data correctly and has functions to pack and
-unpack binary structures into arrays or lists. You can now do arbitrary
-ioctl functions.
-
-You can do i/o with sockets and select.
-
-You can now write packages with their own namespace.
-
-You can now pass things to subroutines by reference.
-
-The debugger now has hooks in the perl parser so it doesn't get confused.
-The debugger won't interfere with stdin and stdout. New debugger commands:
- n Single step around subroutine call.
- l min+incr List incr+1 lines starting at min.
- l List incr+1 more lines.
- l subname List subroutine.
- b subname Set breakpoint at first line of subroutine.
- S List subroutine names.
- D Delete all breakpoints.
- A List line actions.
- < command Define command before prompt.
- > command Define command after prompt.
- ! number Redo command (default previous command).
- ! -number Redo numberth to last command.
- h -number Display last number commands (default all).
- p expr Same as \"print DBout expr\".
-
-The rules are more consistent about where parens are needed and
-where they are not. In particular, unary operators and list operators now
-behave like functions if they're called like functions.
-
-There are some new quoting mechanisms:
- $foo = q/"'"'"'"'"'"'"/;
- $foo = qq/"'"''$bar"''/;
- $foo = q(hi there);
- $foo = <<'EOF' x 10;
- Why, it's the old here-is mechanism!
- EOF
-
-You can now work with array slices (note the initial @):
- @foo[1,2,3];
- @foo{'Sun','Mon','Tue','Wed','Thu','Fri','Sat'} = (1,2,3,4,5,6,7);
- @foo{split} = (1,1,1,1,1,1,1);
-
-There's now a range operator that works in array contexts:
- for (1..15) { ...
- @foo[3..5] = ('time','for','all');
- @foo{'Sun','Mon','Tue','Wed','Thu','Fri','Sat'} = 1..7;
-
-You can now reference associative arrays as a whole:
- %abc = %def;
- %foo = ('Sun',1,'Mon',2,'Tue',3,'Wed',4,'Thu',5,'Fri',6,'Sat',7);
-
-Associative arrays can now be bound to a dbm or ndbm file. Perl automatically
-caches references to the dbm file for you.
-
-An array or associative array can now be assigned to as part of a list, if
-it's the last thing in the list:
- ($a,$b,@rest) = split;
-
-An array or associative array may now appear in a local() list.
- local(%assoc);
- local(@foo) = @_;
-
-Array values may now be interpolated into strings:
- `echo @ARGV`;
- print "first three = @list[0..2]\n";
- print "@ENV{keys(ENV)}";
- ($" is used as the delimiter between array elements)
-
-Array sizes may be interpolated into strings:
- print "The last element is $#foo.\n";
-
-Array values may now be returned from subroutines, evals, and do blocks.
-
-Lists of values in formats may now be arbitrary expressions, separated
-by commas.
-
-Subroutine names are now distinguished by prefixing with &. You can call
-subroutines without using do, and without passing any argument list at all:
- $foo = &min($a,$b,$c);
- $num = &myrand;
-
-You can use the new -u switch to cause perl to dump core so that you can
-run undump and produce a binary executable image. Alternately you can
-use the "dump" operator after initializing any variables and such.
-
-Perl now optimizes splits that are assigned directly to an array, or
-to a list with fewer elements than the split would produce, or that
-split on a constant string.
-
-Perl now optimizes on end matches such as /foo$/;
-
-Perl now recognizes {n,m} in patterns to match preceding item at least n times
-and no more than m times. Also recognizes {n,} and {n} to match n or more
-times, or exactly n times. If { occurs in other than this context it is
-still treated as a normal character.
-
-Perl now optimizes "next" to avoid unnecessary longjmps and subroutine calls.
-
-Perl now optimizes appended input: $_ .= <>;
-
-Substitutions are faster if the substituted text is constant, especially
-when substituting at the beginning of a string. This plus the previous
-optimization let you run down a file comparing multiple lines more
-efficiently. (Basically the equivalents of sed's N and D are faster.)
-
-Similarly, combinations of shifts and pushes on the same array are much
-faster now--it doesn't copy all the pointers every time you shift (just
-every n times, where n is approximately the length of the array plus 10,
-more if you pre-extend the array), so you can use an array as a shift
-register much more efficiently:
- push(@ary,shift(@ary));
-or
- shift(@ary); push(@ary,<>);
-
-The shift operator used inside subroutines now defaults to shifting
-the @_ array. You can still shift ARGV explicitly, of course.
-
-The @_ array which is passed to subroutines is a local array, but the
-elements of it are passed by reference now. This means that if you
-explicitly modify $_[0], you are actually modifying the first argument
-to the routine. Assignment to another location (such as the usual
-local($foo) = @_ trick) causes a copy of the value, so this will not
-affect most scripts. However, if you've modified @_ values in the
-subroutine you could be in for a surprise. I don't believe most people
-will find this a problem, and the long term efficiency gain is worth
-a little confusion.
-
-Perl now detects sequences of references to the same variable and builds
-switch statements internally wherever reasonable.
-
-The substr function can take offsets from the end of the string.
-
-The substr function can be assigned to in order to change the interior of a
-string in place.
-
-The split function can return as part of the returned array any substrings
-matched as part of the delimiter:
- split(/([-,])/, '1-10,20')
-returns
- (1,'-',10,',',20)
-
-If you specify a maximum number of fields to split, the truncation of
-trailing null fields is disabled.
-
-You can now chop lists.
-
-Perl now uses /bin/csh to do filename globbing, if available. This means
-that filenames with spaces or other strangenesses work right.
-
-Perl can now report multiple syntax errors with a single invocation.
-
-Perl syntax errors now give two tokens of context where reasonable.
-
-Perl will now report the possibility of a runaway multi-line string if
-such a string ends on a line with a syntax error.
-
-The assumed assignment in a while now works in the while modifier as
-well as the while statement.
-
-Perl can now warn you if you use numeric == on non-numeric string values.
-
-New functions:
- mkdir and rmdir
- getppid
- getpgrp and setpgrp
- getpriority and setpriority
- chroot
- ioctl and fcntl
- flock
- readlink
- lstat
- rindex - find last occurrence of substring
- pack and unpack - turn structures into arrays and vice versa
- read - just what you think
- warn - like die, only not fatal
- dbmopen and dbmclose - bind a dbm file to an associative array
- dump - do core dump so you can undump
- reverse - turns an array value end for end
- defined - does an object exist?
- undef - make an object not exist
- vec - treat string as a vector of small integers
- fileno - return the file descriptor for a handle
- wantarray - was subroutine called in array context?
- opendir
- readdir
- telldir
- seekdir
- rewinddir
- closedir
- syscall
- socket
- bind
- connect
- listen
- accept
- shutdown
- socketpair
- getsockname
- getpeername
- getsockopt
- setsockopt
- getpwnam
- getpwuid
- getpwent
- setpwent
- endpwent
- getgrnam
- getgrgid
- getgrent
- setgrent
- endgrent
- gethostbyname
- gethostbyaddr
- gethostent
- sethostent
- endhostent
- getnetbyname
- getnetbyaddr
- getnetent
- setnetent
- endnetent
- getprotobyname
- getprotobynumber
- getprotoent
- setprotoent
- endprotoent
- getservbyname
- getservbyport
- getservent
- setservent
- endservent
-
-Changes to s2p
---------------
-
-In patterns, s2p now translates \{n,m\} correctly to {n,m}.
-
-In patterns, s2p no longer removes backslashes in front of |.
-
-In patterns, s2p now removes backslashes in front of [a-zA-Z0-9].
-
-S2p now makes use of the location of perl as determined by Configure.
-
-
-Changes to a2p
---------------
-
-A2p can now accurately translate the "in" operator by using perl's new
-"defined" operator.
-
-A2p can now accurately translate the passing of arrays by reference.
-
# and edit it to reflect your system. Some packages may include samples
# of config.h for certain machines, so you might look for one of those.)
#
-# $Header: Configure,v 3.0.1.14 91/01/11 21:56:38 lwall Locked $
+# $Id: Head.U,v 2.11 90/09/17 17:04:47 hokey Exp Locker: hokey $
#
# Yes, you may rip this off to use in other distribution packages.
# (Note: this Configure script was generated automatically. Rather than
# working with this copy of Configure, you may wish to get metaconfig.)
: sanity checks
-PATH="$PATH:.:/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/local:/usr/lbin:/etc:/usr/new:/usr/new/bin:/usr/nbin"
+PATH=".:$PATH:/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/local:/usr/lbin:/etc:/usr/new:/usr/new/bin:/usr/nbin"
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0; kill $$)
if test ! -t 0; then
-d) shift; fastread='yes';;
esac
+kit_has_binaries=''
d_eunice=''
define=''
eunicefix=''
make=''
date=''
csh=''
+bash=''
+ksh=''
+lex=''
+flex=''
+bison=''
Log=''
Header=''
+Id=''
alignbytes=''
bin=''
+installbin=''
byteorder=''
contains=''
cppstdin=''
d_getprior=''
d_htonl=''
d_index=''
-d_ioctl=''
d_killpg=''
d_lstat=''
d_memcmp=''
d_memcpy=''
d_mkdir=''
+d_msg=''
+d_msgctl=''
+d_msgget=''
+d_msgrcv=''
+d_msgsnd=''
d_ndbm=''
d_odbm=''
+d_open3=''
d_readdir=''
d_rename=''
d_rmdir=''
d_select=''
+d_sem=''
+d_semctl=''
+d_semget=''
+d_semop=''
d_setegid=''
d_seteuid=''
d_setpgrp=''
d_setresuid=''
d_setrgid=''
d_setruid=''
+d_shm=''
+d_shmat=''
+d_shmctl=''
+d_shmdt=''
+d_shmget=''
d_socket=''
d_sockpair=''
d_oldsock=''
d_strerror=''
d_symlink=''
d_syscall=''
-d_sysvipc=''
-d_ipcmsg=''
-d_ipcsem=''
-d_ipcshm=''
d_truncate=''
-d_varargs=''
d_vfork=''
d_voidsig=''
+d_tosignal=''
d_volatile=''
d_vprintf=''
d_charvspr=''
d_wait4=''
d_waitpid=''
gidtype=''
-i_dirent=''
-d_dirnamlen=''
i_fcntl=''
+i_gdbm=''
i_grp=''
i_niin=''
+i_sysin=''
i_pwd=''
-d_pwcomment=''
d_pwquota=''
d_pwage=''
d_pwchange=''
d_pwclass=''
d_pwexpire=''
-i_sysdir=''
+d_pwcomment=''
+i_sys_file=''
i_sysioctl=''
-i_sysndir=''
i_time=''
-i_systime=''
+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=''
usemymalloc=''
startsh=''
stdchar=''
uidtype=''
-voidflags=''
-defvoidused=''
+usrinclude=''
+inclPath=''
+void=''
+voidhave=''
+voidwant=''
+w_localtim=''
+w_s_timevl=''
+w_s_tm=''
yacc=''
-privlib=''
lib=''
+privlib=''
+installprivlib=''
CONFIG=''
-: set package name
+: 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
undef='undef'
: change the next line if compiling for Xenix/286 on Xenix/386
xlibpth='/usr/lib/386 /lib/386'
-libpth='/usr/ccs/lib /usr/lib /usr/local/lib /usr/lib/large /lib '$xlibpth' /lib/large /usr/lib/small /lib/small'
+libpth='/usr/ccs/lib /usr/lib /usr/ucblib /usr/local/lib /usr/lib/large /lib '$xlibpth' /lib/large /usr/lib/small /lib/small'
smallmach='pdp11 i8086 z8000 i80286 iAPX286'
-rmlist='kit[1-9]isdone kit[1-9][0-9]isdone'
-trap 'echo " "; rm -f $rmlist; exit 1' 1 2 3
+trap 'echo " "; exit 1' 1 2 3
: We must find out about Eunice early
eunicefix=':'
eunicefix=/etc/unixtovms.exe
fi
+kit_has_binaries=false
+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"
+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
+libswanted="net_s net nsl_s nsl socket nm ndir ndbm dbm sun m bsd BSD x c_s"
+inclwanted='/usr/include /usr/netinclude /usr/include/sun /usr/include/bsd /usr/include/lan'
+
: Now test for existence of everything in MANIFEST
echo "First let's make sure your kit is complete. Checking..."
-(cd ..; awk '' `awk '$1 !~ /PACKINGLIST/ {print $1}' MANIFEST` >/dev/null || kill $$)
+if $kit_has_binaries; then
+( cd ..
+ bad=false
+ for i in `awk '$1 !~ /PACKINGLIST/ {print $1}' MANIFEST`
+ do
+ if test ! -f $i ; then
+ echo Missing $i
+ bad=true
+ fi
+ done
+ if $bad; then
+ kill $$
+ fi
+)
+else
+ (cd ..; awk '{}' `awk '$1 !~ /PACKINGLIST/ {print $1}' MANIFEST` >/dev/null || kill $$)
+fi
echo "Looks good..."
-attrlist="mc68000 sun gcos unix ibm gimpel interdata tss os mert pyr"
-attrlist="$attrlist vax pdp11 i8086 z8000 u3b2 u3b5 u3b20 u3b200"
-attrlist="$attrlist hpux hp9000s300 hp9000s500 hp9000s800"
-attrlist="$attrlist ns32000 ns16000 iAPX286 mc300 mc500 mc700 sparc"
-attrlist="$attrlist nsc32000 sinix xenix venix posix ansi M_XENIX"
-attrlist="$attrlist $mc68k __STDC__ UTS M_I8086 M_I186 M_I286 M_I386"
-attrlist="$attrlist i186 __m88k__ m88k DGUX __DGUX__"
-pth="/usr/ccs/bin /bin /usr/bin /usr/ucb /usr/local /usr/local/bin /usr/lbin /usr/plx /usr/5bin /vol/local/bin /etc /usr/lib /lib /usr/local/lib /sys5.3/bin /sys5.3/usr/bin /bsd4.3/bin /bsd4.3/usr/bin /bsd4.3/usr/ucb"
-d_newshome="/usr/NeWS"
-defvoidused=7
-libswanted="net_s net nsl_s nsl socket nm ndir ndbm dbm sun m bsd BSD x c_s"
-inclwanted='/usr/netinclude /usr/include/sun /usr/include/bsd /usr/include/lan'
-
: some greps do not return status, grrr.
-echo "grimblepritz" >grimble
-if grep blurfldyick grimble >/dev/null 2>&1 ; then
+echo "grimblepritz" >contains.txt
+if grep blurfldyick contains.txt >/dev/null 2>&1 ; then
contains=contains
-elif grep grimblepritz grimble >/dev/null 2>&1 ; then
+elif grep grimblepritz contains.txt >/dev/null 2>&1 ; then
contains=grep
else
contains=contains
fi
-rm -f grimble
: the following should work in any shell
case "$contains" in
contains*)
spitshell=cat
echo " "
echo "Okay, let's see if #! works on this system..."
- echo "#!/bin/echo hi" > try
- $eunicefix try
- chmod +x try
- ./try > today
+ if 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" > try
- $eunicefix try
- chmod +x try
- ./try > today
+ 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='#! '
echo "Checking out how to guarantee sh startup..."
startsh=$sharpbang'/bin/sh'
echo "Let's see if '$startsh' works..."
-cat >try <<EOSS
+cat >start.sh <<EOSS
$startsh
set abc
test "$?abc" != 1
EOSS
-chmod +x try
-$eunicefix try
-if ./try; then
+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
-rm -f try today
: 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 "hi there\c" ; echo " ") >echotmp
+if $contains c echotmp >/dev/null 2>&1 ; then
echo "...using -n."
n='-n'
c=''
fi
echo $n "Type carriage return to continue. Your cursor should be here-->$c"
read ans
-rm -f .echotmp
: now set up to do reads with possible shell escape and default assignment
cat <<EOSC >myread
. 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@jpl-devvax.jpl.nasa.gov)
+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@jpl-devvax.jpl.nasa.gov)
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.
"
trylist="
Mcc
+bison
cpp
csh
egrep
+nroff
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
/bin/echo)
echo " "
echo "Checking compatibility between /bin/echo and builtin echo (if any)..."
- $echo $n "hi there$c" >foo1
- echo $n "hi there$c" >foo2
- if cmp foo1 foo2 >/dev/null 2>&1; then
+ $echo $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
$echo $n "$rp$c"
. myread
fi
- $rm -f foo1 foo2
;;
*)
: cross your fingers
echo=echo
;;
esac
-rmlist="$rmlist loc"
: set up shell script to do ~ expansion
cat >filexp <<EOSS
: determine where manual pages go
$cat <<EOM
-$package has manual pages that need to be installed in source form.
+$package has manual pages available in source form.
EOM
+case "$nroff" in
+'')
+ 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 . /usr/man/man1 /usr/man/mann /usr/man/manl /usr/man/local/man1 /usr/man/u_man/man1 /usr/man/man1 /usr/man/man.L`
+ dflt=`./loc . none /usr/man/local/man1 /usr/man/man.L /usr/man/manl /usr/man/mann /usr/man/u_man/man1 /usr/man/man1`
;;
*) dflt="$mansrc"
;;
cont=true
while $test "$cont" ; do
echo " "
- rp="Where do the manual pages (source) go? (~name ok) [$dflt]"
+ rp="Where do the manual pages (source) go (~name ok)? [$dflt]"
$echo $n "$rp $c"
. myread
- mansrc=`./filexp "$ans"`
- if $test -d "$mansrc"; then
+ case "$ans" in
+ 'none')
+ mansrc=''
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
+ ;;
+ *)
+ 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
;;
manext=l
;;
*p)
- manext=p
+ manext=n
;;
*C)
manext=C
;;
esac
-: make some quick guesses about what we are up against
+: Sigh. Well, at least the box is fast...
echo " "
$echo $n "Hmm... $c"
-cat /usr/include/signal.h /usr/include/sys/signal.h >foo
-if test `echo abc | tr a-z A-Z` = Abc ; then
+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 " "
+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
+ echo exit 1 >usg
+ echo exit 1 >v7
+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 1 >bsd
echo exit 0 >usg
echo exit 1 >v7
-elif $contains SIGTSTP foo >/dev/null 2>&1 ; then
+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
echo exit 1 >usg
fi
chmod +x bsd usg v7 eunice venix
$eunicefix bsd usg v7 eunice venix
-rm -rf foo
-rmlist="$rmlist bsd usg v7 eunice venix xenix"
: see what memory models we can support
case "$models" in
esac
for thisincl in $inclwanted; do
if test -d $thisincl; then
- case "$dflt" in
- *$thisincl*);;
- *) dflt="$dflt -I$thisincl";;
- esac
+ if test "x$thisincl" != "x$usrinclude"; then
+ case "$dflt" in
+ *$thisincl*);;
+ *) dflt="$dflt -I$thisincl";;
+ esac
+ fi
fi
done
case "$optimize" in
esac
;;
esac
-if $contains 'LANGUAGE_C' /usr/include/signal.h >/dev/null 2>&1; then
+if $contains 'LANGUAGE_C' $usrinclude/signal.h >/dev/null 2>&1; then
case "$dflt" in
*LANGUAGE_C*);;
*) dflt="$dflt -DLANGUAGE_C";;
cppflags=''
for flag do
case $flag in
- -D*|-I*) cppflags="$cppflags $flag";;
+ -D*|-I*|-traditional|-ansi|-nostdinc) cppflags="$cppflags $flag";;
esac
done
case "$cppflags" in
none) ans='';
esac
ldflags="$ans"
-rmlist="$rmlist pdp11"
echo " "
echo "Checking for optional libraries..."
-dflt=''
+case "$libs" in
+'') dflt='';;
+*) dflt="$libs";;
+esac
case "$libswanted" in
'') libswanted='c_s';;
esac
*) thatlib="${thislib}_s";;
*) thatlib=NONE;;
esac
- xxx=`./loc lib$thislib.a X /usr/ccs/lib /usr/lib /usr/local/lib /lib`
+ 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
set X $dflt
shift
dflt="$*"
-case "$libs" in
-'') dflt="$dflt";;
-*) dflt="$libs";;
-esac
case "$dflt" in
'') dflt='none';;
esac
$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 . /bin /usr/local/bin /usr/lbin /usr/local /usr/bin`
+ dflt=`./loc . /usr/local/bin /usr/local/bin /usr/lbin /usr/local /usr/bin /bin`
;;
*) dflt="$bin"
;;
esac
cont=true
while $test "$cont" ; do
- echo " "
- rp="Where do you want to put the public executables? (~name ok) [$dflt]"
+ rp="In which directory will public executables reside (~name ok)? [$dflt]"
$echo $n "$rp $c"
. myread
bin="$ans"
- bin=`./filexp "$bin"`
+ bin=`./filexp $bin`
if test -d $bin; then
cont=''
else
fi
done
+case "$installbin" in
+'')
+ dflt=`echo $bin | sed 's#^/afs/#/afs/.#'`
+ ;;
+*) dflt="$installbin"
+ ;;
+esac
+cont=true
+while $test "$cont" ; do
+ rp="In which directory will public executables be installed (~name ok)? [$dflt]"
+ $echo $n "$rp $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
'')
the test program works the default is probably right.
I'm now running the test program...
EOM
- $cat >try.c <<'EOCP'
+ $cat >byteorder.c <<'EOCP'
#include <stdio.h>
main()
{
} u;
if (sizeof(long) > 4)
- u.l = (0x08070605<<32) | 0x04030201;
+ u.l = (0x08070605 << 32) | 0x04030201;
else
u.l = 0x04030201;
for (i=0; i < sizeof(long); i++)
printf("\n");
}
EOCP
- if $cc $ccflags try.c -o try >/dev/null 2>&1 ; then
- dflt=`./try`
+ 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.)";;
$echo $n "$rp $c"
. myread
byteorder="$ans"
-$rm -f try.c try
: 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>
+
main()
{
double f = -123;
unsigned short ashort;
int result = 0;
+ signal(SIGFPE, SIG_IGN);
along = (unsigned long)f;
aint = (unsigned int)f;
ashort = (unsigned short)f;
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
-$cc -o try $ccflags try.c >/dev/null 2>&1 && ./try
-castflags=$?
+if $cc -o try $ccflags try.c >/dev/null 2>&1; then
+ ./try
+ castflags=$?
+else
+ castflags=3
+fi
case "$castflags" in
0) d_castneg="$define"
echo "Yup, it does."
fi
fi
fi
-rm -f testcpp.c testcpp.out
: get list of predefined functions in a handy place
echo " "
case "$libc" in
'') libc=unknown;;
esac
+case "$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
-'') libpth='/usr/ccs/lib /lib /usr/lib /usr/local/lib';;
+'') 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`
set /usr/ccs/lib/libc.so
test -f $1 || set /usr/lib/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 is in $1."
libc="$1"
elif test -f $libc; then
echo "Your C library is in $libc, like you said before."
- if test $libc = "/lib/libc"; then
- libc="$libc /lib/clib"
- fi
elif test -f /lib/libc.a; then
echo "Your C library is in /lib/libc.a. You're normal."
libc=/lib/libc.a
else
- ans=`./loc libc.a blurfl/dyick $libpth`
- if test ! -f "$ans"; then
- ans=`./loc Slibc.a blurfl/dyick $xlibpth`
- fi
- if test ! -f "$ans"; then
- ans=`./loc Mlibc.a blurfl/dyick $xlibpth`
- fi
- if test ! -f "$ans"; then
- ans=`./loc Llibc.a blurfl/dyick $xlibpth`
- fi
- if test ! -f "$ans"; then
- ans=`./loc libc blurfl/dyick $libpth`
- fi
- if test ! -f "$ans"; then
- ans=`./loc clib blurfl/dyick $libpth`
- else
- libnames="$libnames "`./loc clib blurfl/dyick $libpth`
+ 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 is in $ans, of all places."
fi
fi
echo " "
+if test $libc = "/lib/libc"; then
+ libc="$libc /lib/clib"
+fi
set `echo $libc $libnames | tr ' ' '\012' | sort | uniq`
$echo $n "Extracting names from $* for later perusal...$c"
-nm $* 2>/dev/null >libc.tmp
-$sed -n -e 's/^.* [ATDS] *_[_.]*//p' -e 's/^.* [ATDS] //p' <libc.tmp >libc.list
+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"
+ 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 '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
else
- $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 || \
- $sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p' <libc.tmp >libc.list
- $contains '^printf$' libc.list >/dev/null 2>&1 || \
- $sed -n -e 's/^.* D __*//p' -e 's/^.* D //p' <libc.tmp >libc.list
- $contains '^printf$' libc.list >/dev/null 2>&1 || \
- $sed -n -e 's/^_//' \
- -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p' <libc.tmp >libc.list
- $contains '^printf$' libc.list >/dev/null 2>&1 || \
- $sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p' \
- <libc.tmp >libc.list
+ 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 " "
done
echo "Ok."
else
- echo "That didn't work either. Giving up."
- exit 1
+ echo "That didn't work either. Giving up."
+ exit 1
fi
fi
fi
then echo "$1() found"; eval "$2=$define";
else echo "$1() not found"; eval "$2=$undef"; fi'
-rmlist="$rmlist libc.tmp libc.list"
-
: see if bcmp exists
set bcmp d_bcmp
eval $inlibc
: see if sprintf is declared as int or pointer to char
echo " "
-cat >.ucbsprf.c <<'EOF'
+cat >ucbsprf.c <<'EOF'
main() { char buf[10]; exit((unsigned long)sprintf(buf,"%s","foo") > 10L); }
EOF
-if $cc $ccflags .ucbsprf.c -o .ucbsprf >/dev/null 2>&1 && .ucbsprf; then
+if $cc $ccflags ucbsprf.c -o ucbsprf >/dev/null 2>&1 && ./ucbsprf; then
echo "Your sprintf() returns (int)."
d_charsprf="$undef"
else
echo "Your sprintf() returns (char*)."
d_charsprf="$define"
fi
-/bin/rm -f .ucbsprf.c .ucbsprf
: see if vprintf exists
echo " "
if $contains '^vprintf$' libc.list >/dev/null 2>&1; then
echo 'vprintf() found.'
d_vprintf="$define"
- cat >.ucbsprf.c <<'EOF'
-#include <stdio.h>
+ cat >vprintf.c <<'EOF'
#include <varargs.h>
main() { xxx("foo"); }
exit((unsigned long)vsprintf(buf,"%s",args) > 10L);
}
EOF
- if $cc $ccflags .ucbsprf.c -o .ucbsprf >/dev/null 2>&1 && .ucbsprf; then
+ if $cc $ccflags vprintf.c -o vprintf >/dev/null 2>&1 && ./vprintf; then
echo "Your vsprintf() returns (int)."
d_charvspr="$undef"
else
echo "Your vsprintf() returns (char*)."
d_charvspr="$define"
fi
- /bin/rm -f .ucbsprf.c .ucbsprf
else
echo 'vprintf() not found.'
d_vprintf="$undef"
*) d_csh="$define" ;;
esac
-: see if this is a dirent system
+: see if readdir exists
+set readdir d_readdir
+eval $inlibc
+
+: see if there are directory access routines out there
echo " "
-if $test -r /usr/include/dirent.h ; then
- i_dirent="$define"
+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' /usr/include/sys/dirent.h >/dev/null 2>&1; then
+ 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
- d_dirnamlen="$undef"
+ 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
-else
- i_dirent="$undef"
- if $contains 'd_namlen' /usr/include/sys/dir.h >/dev/null 2>&1; then
+ 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
- d_dirnamlen="$undef"
+ 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
- echo "No dirent.h found."
fi
: now see if they want to do setuid emulation
eval $inlibc
: see if this is an fcntl system
-echo " "
-if $test -r /usr/include/fcntl.h ; then
- d_fcntl="$define"
- echo "fcntl.h found."
-else
- d_fcntl="$undef"
- echo "No fcntl.h found, but that's ok."
-fi
+set fcntl d_fcntl
+eval $inlibc
: see if we can have long filenames
echo " "
fi
fi
-: see if ioctl defs are in sgtty/termio or sys/ioctl
-echo " "
-if $test -r /usr/include/sys/ioctl.h ; then
- d_ioctl="$define"
- echo "sys/ioctl.h found."
-else
- d_ioctl="$undef"
- echo "sys/ioctl.h not found, assuming ioctl args are defined in sgtty.h."
-fi
-
-: see if there is System V IPC
-set msgget d_ipcmsg
-eval $inlibc
-
-set semget d_ipcsem
-eval $inlibc
-
-set shmget d_ipcshm
-eval $inlibc
-
-case "$d_ipcmsg$d_ipcsem$d_ipcshm" in
-*define*) d_sysvipc="$define";;
-*) d_sysvipc="$undef";;
-esac
-
: see if killpg exists
set killpg d_killpg
eval $inlibc
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."
+ d_msg="$define"
+else
+ echo "You don't have the full msg*(2) library."
+ d_msg="$undef"
+fi
+
: see if ndbm is available
echo " "
-xxx=`./loc ndbm.h x /usr/include /usr/local/include $inclwanted`
+xxx=`./loc ndbm.h x $usrinclude /usr/local/include $inclwanted`
if test -f $xxx; then
d_ndbm="$define"
echo "ndbm.h found."
: see if we have the old dbm
echo " "
-xxx=`./loc dbm.h x /usr/include /usr/local/include $inclwanted`
+xxx=`./loc dbm.h x $usrinclude /usr/local/include $inclwanted`
if test -f $xxx; then
d_odbm="$define"
echo "dbm.h found."
echo "dbm.h not found."
fi
-socketlib=''
: see whether socket exists
echo " "
+socketlib=''
if $contains socket libc.list >/dev/null 2>&1; then
echo "Looks like you have Berkeley networking support."
d_socket="$define"
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"
+ socketlib="-lnet -lnsl_s"
d_socket="$define"
: now check for advanced features
if $contains setsockopt libc.list >/dev/null 2>&1; then
d_sockpair="$undef"
fi
-: see if this is a pwd system
+: Locate the flags for 'open()'
echo " "
-if $test -r /usr/include/pwd.h ; then
- i_pwd="$define"
- echo "pwd.h found."
- $cppstdin $cppflags $cppminus </usr/include/pwd.h >$$.h
- if $contains 'pw_comment' $$.h >/dev/null 2>&1; then
- d_pwcomment="$define"
+$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()."
+ d_open3="$define"
else
- d_pwcomment="$undef"
+ echo "but not the 3 argument form of open(). Oh, well."
+ d_open3="$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()."
+ d_open3="$define"
+ else
+ echo "but not the 3 argument form of open(). Oh, well."
+ d_open3="$undef"
fi
- if $contains 'pw_quota' $$.h >/dev/null 2>&1; then
+else
+ d_open3="$undef"
+ echo "I can't find the O_* constant definitions! You got problems."
+fi
+
+: see if how pwd stuff is defined
+echo " "
+if $test -r $usrinclude/pwd.h ; then
+ i_pwd="$define"
+ echo "pwd.h found."
+ $cppstdin $cppflags <$usrinclude/pwd.h >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' $$.h >/dev/null 2>&1; then
+ if $contains 'pw_age' pwd.txt >/dev/null 2>&1; then
d_pwage="$define"
else
d_pwage="$undef"
fi
- if $contains 'pw_change' $$.h >/dev/null 2>&1; then
+ if $contains 'pw_change' pwd.txt >/dev/null 2>&1; then
d_pwchange="$define"
else
d_pwchange="$undef"
fi
- if $contains 'pw_class' $$.h >/dev/null 2>&1; then
+ if $contains 'pw_class' pwd.txt >/dev/null 2>&1; then
d_pwclass="$define"
else
d_pwclass="$undef"
fi
- if $contains 'pw_expire' $$.h >/dev/null 2>&1; then
+ if $contains 'pw_expire' pwd.txt >/dev/null 2>&1; then
d_pwexpire="$define"
else
d_pwexpire="$undef"
fi
- rm -f $$.h
+ if $contains 'pw_comment' pwd.txt >/dev/null 2>&1; then
+ d_pwcomment="$define"
+ else
+ d_pwcomment="$undef"
+ fi
else
i_pwd="$undef"
- d_pwcomment="$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 readdir exists
-set readdir d_readdir
-eval $inlibc
-
: see if rename exists
set rename d_rename
eval $inlibc
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."
+ d_sem="$define"
+else
+ echo "You don't have the full sem*(2) library."
+ d_sem="$undef"
+fi
+
: see if setegid exists
set setegid d_setegid
eval $inlibc
set setruid d_setruid
eval $inlibc
-: see if stat knows about block sizes
+: 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
+
+: see if shmdt exists
+set shmdt d_shmdt
+eval $inlibc
+
+: see how much of the 'shm*(2)' library is present.
+h_shm=true
echo " "
-if $contains 'st_blocks;' /usr/include/sys/stat.h >/dev/null 2>&1 ; then
- if $contains 'st_blksize;' /usr/include/sys/stat.h >/dev/null 2>&1 ; then
+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."
+ d_shm="$define"
+else
+ echo "You don't have the full shm*(2) library."
+ d_shm="$undef"
+fi
+
+: 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."
d_statblks="$define"
else
: see if stdio is really std
echo " "
-if $contains 'char.*_ptr.*;' /usr/include/stdio.h >/dev/null 2>&1 ; then
- if $contains '_cnt;' /usr/include/stdio.h >/dev/null 2>&1 ; then
+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."
d_stdstdio="$define"
else
: check for structure copying
echo " "
echo "Checking to see if your C compiler can copy structs..."
-$cat >try.c <<'EOCP'
+$cat >strctcpy.c <<'EOCP'
main()
{
struct blurfl {
foo = bar;
}
EOCP
-if $cc -c $ccflags try.c >/dev/null 2>&1 ; then
+if $cc -c strctcpy.c >/dev/null 2>&1 ; then
d_strctcpy="$define"
echo "Yup, it can."
else
d_strctcpy="$undef"
echo "Nope, it can't."
fi
-$rm -f try.*
: see if strerror exists
set strerror d_strerror
set syscall d_syscall
eval $inlibc
-: see if we should include time.h, sys/time.h, or both
+: set if package uses struct tm
+w_s_tm=1
+
+: set if package uses struct timeval
+w_s_timevl=1
+
+: 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 if we should include <time.h>, <sys/time.h> or both.
-I'm now running the test program...
+Testing to see which of <time.h>, <sys/time.h>, and <sys/select.h>
+should be included, because this application wants:
+
EOM
-$cat >try.c <<'EOCP'
+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_SYSTIME
+#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 s_timeval in '-DS_TIMEVAL' ''; do
+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_SYSTIME' ''; do
+ for i_systime in '-DI_SYS_TIME' ''; do
case "$flags" in
- '') echo Trying $i_time $i_systime $d_systimekernel $s_timeval
- if $cc $ccflags \
- $i_time $i_systime $d_systimekernel $s_timeval \
- try.c -o try >/dev/null 2>&1 ; then
- set X $i_time $i_systime $d_systimekernel $s_timeval
+ '') echo Trying $i_time $i_systime $d_systimekernel $i_sys_select
+ if $cc $ccflags i_time.c $idefs \
+ $i_time $i_systime $d_systimekernel $i_sys_select \
+ -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
*) i_time="$undef";;
esac
case "$flags" in
-*I_SYSTIME*) i_systime="$define";;
-*) i_systime="$undef";;
+*I_SYS_SELECT*) i_sys_select="$define";;
+*) i_sys_select="$undef";;
+esac
+case "$flags" in
+*I_SYS_TIME*) i_sys_time="$define";;
+*) i_sys_time="$undef";;
esac
-$rm -f try.c try
-
-: see if truncate exists
-set truncate d_truncate
-eval $inlibc
-
-: see if this is a varargs system
-echo " "
-if $test -r /usr/include/varargs.h ; then
- d_varargs="$define"
- echo "varargs.h found."
-else
- d_varargs="$undef"
- echo "No varargs.h found, but that's ok (I hope)."
-fi
-
-: see if there is a vfork
-set vfork d_vfork
-eval $inlibc
: see if signal is declared as pointer to function returning int or void
echo " "
-$cppstdin $cppflags $cppminus < /usr/include/signal.h >$$.tmp
-if $contains 'void.*signal' $$.tmp >/dev/null 2>&1 ; then
+$cppstdin $cppflags $cppminus < $usrinclude/signal.h >d_voidsig.txt
+if $contains 'void.*signal' d_voidsig.txt >/dev/null 2>&1 ; then
echo "You have void (*signal())() instead of int."
d_voidsig="$define"
else
echo "You have int (*signal())() instead of void."
d_voidsig="$undef"
fi
-rm -f $$.tmp
+
+: 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 " "
set waitpid d_waitpid
eval $inlibc
-: 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 "$voidflags" in
-'')
- $cat >try.c <<'EOCP'
-#if TRY & 1
-void main() {
-#else
-main() {
-#endif
- extern void moo(); /* function returning void */
- void (*goo)(); /* ptr to func returning void */
-#if TRY & 2
- void (*foo[10])();
-#endif
-
-#if TRY & 4
- if(goo == moo) {
- exit(0);
- }
-#endif
- exit(0);
-}
-EOCP
- if $cc $ccflags -c -DTRY=$defvoidused try.c >.out 2>&1 ; then
- voidflags=$defvoidused
- echo "It appears to support void."
- if $contains warning .out >/dev/null 2>&1; then
- echo "However, you might get some warnings that look like this:"
- $cat .out
- fi
- else
- echo "Hmm, your compiler has some difficulty with void. Checking further..."
- if $cc $ccflags -c -DTRY=1 try.c >/dev/null 2>&1 ; then
- echo "It supports 1..."
- if $cc $ccflags -c -DTRY=3 try.c >/dev/null 2>&1 ; then
- voidflags=3
- echo "And it supports 2 but not 4."
- else
- echo "It doesn't support 2..."
- if $cc $ccflags -c -DTRY=5 try.c >/dev/null 2>&1 ; then
- voidflags=5
- echo "But it supports 4."
- else
- voidflags=1
- echo "And it doesn't support 4."
- fi
- fi
- else
- echo "There is no support at all for void."
- voidflags=0
- fi
- fi
-esac
-dflt="$voidflags";
-rp="Your void support flags add up to what? [$dflt]"
-$echo $n "$rp $c"
-. myread
-voidflags="$ans"
-$rm -f try.* .out
-
: see what type gids are declared as in the kernel
echo " "
case "$gidtype" in
dflt='short'
elif $contains 'getgroups.*int' /usr/lib/lint/llib-lc >/dev/null 2>&1; then
dflt='int'
- elif $contains 'gid_t;' /usr/include/sys/types.h >/dev/null 2>&1 ; then
+ elif $contains 'gid_t;' $usrinclude/sys/types.h >/dev/null 2>&1 ; then
dflt='gid_t'
else
- set `grep 'groups\[NGROUPS\];' /usr/include/sys/user.h 2>/dev/null` unsigned short
+ set `grep 'groups\[NGROUPS\];' $usrinclude/sys/user.h 2>/dev/null` unsigned short
case $1 in
unsigned) dflt="$1 $2" ;;
*) dflt="$1" ;;
. myread
gidtype="$ans"
-: see if this is an fcntl system
-echo " "
-if $test -r /usr/include/fcntl.h ; then
- i_fcntl="$define"
- echo "fcntl.h found."
-else
- i_fcntl="$undef"
- echo "No fcntl.h found, but that's ok."
-fi
-
-: see if this is an grp system
-echo " "
-if $test -r /usr/include/grp.h ; then
- i_grp="$define"
- echo "grp.h found."
-else
- i_grp="$undef"
- echo "No grp.h found."
-fi
-
-: see if this is a netinet/in.h system
-echo " "
-xxx=`./loc netinet/in.h x /usr/include /usr/local/include $inclwanted`
-if test -f $xxx; then
- i_niin="$define"
- echo "netinet/in.h found."
-else
- i_niin="$undef"
- echo "No netinet/in.h found."
-fi
-
-: see if this is a sys/dir.h system
-echo " "
-if $test -r /usr/include/sys/dir.h ; then
- i_sysdir="$define"
- echo "sys/dir.h found."
-else
- i_sysdir="$undef"
- echo "No sys/dir.h found."
-fi
-
-: see if ioctl defs are in sgtty/termio or sys/ioctl
-echo " "
-if $test -r /usr/include/sys/ioctl.h ; then
- i_sysioctl="$define"
- echo "sys/ioctl.h found."
-else
- i_sysioctl="$undef"
- echo "sys/ioctl.h not found, assuming ioctl args are defined in sgtty.h."
-fi
-
-: see if this is a sys/ndir.h system
-echo " "
-xxx=`./loc sys/ndir.h x /usr/include /usr/local/include $inclwanted`
-if test -f $xxx; then
- i_sysndir="$define"
- echo "sys/ndir.h found."
-else
- i_sysndir="$undef"
- echo "No sys/ndir.h found."
-fi
-
-: see if we should include utime.h
-echo " "
-if $test -r /usr/include/utime.h ; then
- i_utime="$define"
- echo "utime.h found."
-else
- i_utime="$undef"
- echo "No utime.h found, but that's ok."
-fi
-
-: see if this is a varargs system
-echo " "
-if $test -r /usr/include/varargs.h ; then
- i_varargs="$define"
- echo "varargs.h found."
-else
- i_varargs="$undef"
- echo "No varargs.h found, but that's ok (I hope)."
-fi
-
-: see if this is a vfork system
-echo " "
-if $test -r /usr/include/vfork.h ; then
- i_vfork="$define"
- echo "vfork.h found."
-else
- i_vfork="$undef"
- echo "No vfork.h found."
-fi
-
: check for length of integer
echo " "
case "$intsize" in
'')
echo "Checking to see how big your integers are..."
- $cat >try.c <<'EOCP'
+ $cat >intsize.c <<'EOCP'
#include <stdio.h>
main()
{
printf("%d\n", sizeof(int));
}
EOCP
- if $cc $ccflags try.c -o try >/dev/null 2>&1 ; then
- dflt=`./try`
+ 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...)"
$echo $n "$rp $c"
. myread
intsize="$ans"
-$rm -f try.c try
: determine where private executables go
case "$privlib" in
esac
$cat <<EOM
-The $package package has some auxiliary files that should be put in a library
-that is accessible by everyone. Where do you want to put these "private"
+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 "but accessible files? (~name ok) [$dflt] $c"
-rp="Put private files where? [$dflt]"
+$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/.#'`
+ ;;
+*) 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 >try.c <<'EOCP'
+ $cat >randbits.c <<'EOCP'
#include <stdio.h>
main()
{
printf("%d\n",i);
}
EOCP
- if $cc $ccflags try.c -o try >/dev/null 2>&1 ; then
- dflt=`./try`
+ 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...)"
$echo $n "$rp $c"
. myread
randbits="$ans"
-$rm -f try.c try
+
+: determine where public executables 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 do you keep publicly executable scripts (~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
: generate list of signal names
echo " "
case "$sig_name" in
'')
echo "Generating a list of signal names..."
- set X `cat /usr/include/signal.h /usr/include/sys/signal.h 2>&1 | awk '
+ 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) {
: see what type of char stdio uses.
echo " "
-if $contains 'unsigned.*char.*_ptr.*;' /usr/include/stdio.h >/dev/null 2>&1 ; then
+if $contains 'unsigned.*char.*_ptr;' $usrinclude/stdio.h >/dev/null 2>&1 ; then
echo "Your stdio uses unsigned chars."
stdchar="unsigned char"
else
: see what type uids are declared as in the kernel
case "$uidtype" in
'')
- if $contains 'uid_t;' /usr/include/sys/types.h >/dev/null 2>&1 ; then
+ if $contains 'uid_t;' $usrinclude/sys/types.h >/dev/null 2>&1 ; then
dflt='uid_t';
else
- set `grep '_ruid;' /usr/include/sys/user.h 2>/dev/null` unsigned short
+ set `grep '_ruid;' $usrinclude/sys/user.h 2>/dev/null` unsigned short
case $1 in
unsigned) dflt="$1 $2" ;;
*) dflt="$1" ;;
. 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 -S -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 -S -DTRY=1 void.c >/dev/null 2>&1 ; then
+ echo "It supports 1..."
+ if $cc -S -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 -S -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'
: determine which malloc to compile in
*) mallocsrc=''; mallocobj='';;
esac
-: determine where public executables 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 do you keep publicly executable scripts? (~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
-
: determine compiler compiler
case "$yacc" in
-'') dflt=yacc;;
+'') if xenix; then
+ dflt=yacc
+ else
+ dflt='yacc -Sm25000'
+ fi
+ ;;
*) dflt="$yacc";;
esac
cont=true
esac
yacc="$ans"
+: see if we can include fcntl.h
+echo " "
+if $h_fcntl; then
+ i_fcntl="$define"
+ echo "We'll be including <fcntl.h>."
+else
+ i_fcntl="$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
+
+: see if gdbm is available
+echo " "
+xxx=`./loc gdbm.h x $usrinclude /usr/local/include $inclwanted`
+if test -f $xxx; then
+ i_gdbm="$define"
+ echo "gdbm.h found."
+else
+ i_gdbm="$undef"
+ echo "gdbm.h not found."
+fi
+
+: see if this is an grp system
+echo " "
+if $test -r $usrinclude/grp.h ; then
+ i_grp="$define"
+ echo "grp.h found."
+else
+ i_grp="$undef"
+ echo "No grp.h found."
+fi
+
+: see if this is a netinet/in.h or sys/in.h system
+echo " "
+xxx=`./loc netinet/in.h x $usrinclude /usr/local/include $inclwanted`
+if test -f $xxx; then
+ i_niin="$define"
+ i_sysin="$undef"
+ echo "netinet/in.h found."
+else
+ i_niin="$undef"
+ echo "No netinet/in.h found, ..."
+ xxx=`./loc sys/in.h x $usrinclude /usr/local/include $inclwanted`
+ if test -f $xxx; then
+ i_sysin="$define"
+ echo "but I found sys/in.h instead."
+ else
+ i_sysin="$undef"
+ echo "and I didn't find sys/in.h either."
+ fi
+fi
+
+: Do we need to #include <sys/file.h> ?
+echo " "
+if $h_sys_file; then
+ i_sys_file="$define"
+ echo "We'll be including <sys/file.h>."
+else
+ i_sys_file="$undef"
+ echo "We won't be including <sys/file.h>."
+fi
+
+: see if ioctl defs are in sgtty/termio or sys/ioctl
+echo " "
+if $test -r $usrinclude/sys/ioctl.h ; then
+ i_sysioctl="$define"
+ echo "sys/ioctl.h found."
+else
+ i_sysioctl="$undef"
+ echo "sys/ioctl.h not found, assuming ioctl args are defined in sgtty.h."
+fi
+
+: see if we should include utime.h
+echo " "
+if $test -r $usrinclude/utime.h ; then
+ i_utime="$define"
+ echo "utime.h found."
+else
+ i_utime="$undef"
+ echo "No utime.h found, but that's ok."
+fi
+
+: see if this is a varargs system
+echo " "
+if $test -r $usrinclude/varargs.h ; then
+ i_varargs="$define"
+ echo "varargs.h found."
+else
+ i_varargs="$undef"
+ echo "No varargs.h found, but that's ok (I hope)."
+fi
+
+: see if this is a vfork system
+echo " "
+if $test -r $usrinclude/vfork.h ; then
+ i_vfork="$define"
+ echo "vfork.h found."
+else
+ i_vfork="$undef"
+ echo "No vfork.h found."
+fi
+
+: end of configuration questions
echo " "
echo "End of configuration questions."
echo " "
# config.sh
# This file was produced by running the Configure script.
+kit_has_binaries='$kit_has_binaries'
d_eunice='$d_eunice'
define='$define'
eunicefix='$eunicefix'
make='$make'
date='$date'
csh='$csh'
+bash='$bash'
+ksh='$ksh'
+lex='$lex'
+flex='$flex'
+bison='$bison'
Log='$Log'
Header='$Header'
+Id='$Id'
alignbytes='$alignbytes'
bin='$bin'
+installbin='$installbin'
byteorder='$byteorder'
contains='$contains'
cppstdin='$cppstdin'
d_getprior='$d_getprior'
d_htonl='$d_htonl'
d_index='$d_index'
-d_ioctl='$d_ioctl'
d_killpg='$d_killpg'
d_lstat='$d_lstat'
d_memcmp='$d_memcmp'
d_memcpy='$d_memcpy'
d_mkdir='$d_mkdir'
+d_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_rmdir='$d_rmdir'
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_setresuid='$d_setresuid'
d_setrgid='$d_setrgid'
d_setruid='$d_setruid'
+d_shm='$d_shm'
+d_shmat='$d_shmat'
+d_shmctl='$d_shmctl'
+d_shmdt='$d_shmdt'
+d_shmget='$d_shmget'
d_socket='$d_socket'
d_sockpair='$d_sockpair'
d_oldsock='$d_oldsock'
d_strerror='$d_strerror'
d_symlink='$d_symlink'
d_syscall='$d_syscall'
-d_sysvipc='$d_sysvipc'
-d_ipcmsg='$d_ipcmsg'
-d_ipcsem='$d_ipcsem'
-d_ipcshm='$d_ipcshm'
d_truncate='$d_truncate'
-d_varargs='$d_varargs'
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'
-i_dirent='$i_dirent'
-d_dirnamlen='$d_dirnamlen'
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_pwcomment='$d_pwcomment'
d_pwquota='$d_pwquota'
d_pwage='$d_pwage'
d_pwchange='$d_pwchange'
d_pwclass='$d_pwclass'
d_pwexpire='$d_pwexpire'
-i_sysdir='$i_sysdir'
+d_pwcomment='$d_pwcomment'
+i_sys_file='$i_sys_file'
i_sysioctl='$i_sysioctl'
-i_sysndir='$i_sysndir'
i_time='$i_time'
-i_systime='$i_systime'
+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'
usemymalloc='$usemymalloc'
startsh='$startsh'
stdchar='$stdchar'
uidtype='$uidtype'
-voidflags='$voidflags'
-defvoidused='$defvoidused'
+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'
-privlib='$privlib'
lib='$lib'
+privlib='$privlib'
+installprivlib='$installprivlib'
CONFIG=true
EOT
+: Finish up
CONFIG=true
echo " "
+test -f patchlevel.h && awk '{printf "%s=%s\n",$2,$3}' patchlevel.h >>config.sh
dflt=''
fastread=''
echo "If you didn't make any mistakes, then just type a carriage return here."
fi
fi
-if $contains '^depend:' Makefile >/dev/null 2>&1; then
+if $contains '^depend:' [Mm]akefile >/dev/null 2>&1; then
dflt=n
$cat <<EOM
*) echo "You must run 'make depend' then 'make'."
;;
esac
-elif test -f Makefile; then
+elif test -f [Mm]akefile; then
echo " "
echo "Now you must run a make."
else
fi
$rm -f kit*isdone
-: the following is currently useless
-cd UU && $rm -f $rmlist
-: since this removes it all anyway
cd .. && $rm -rf UU
: end of Configure
-/* $Header: EXTERN.h,v 3.0 89/10/18 15:06:03 lwall Locked $
+/* $Header: EXTERN.h,v 4.0 91/03/20 00:58:26 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: EXTERN.h,v $
- * Revision 3.0 89/10/18 15:06:03 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 00:58:26 lwall
+ * 4.0 baseline.
*
*/
-/* $Header: INTERN.h,v 3.0 89/10/18 15:06:25 lwall Locked $
+/* $Header: INTERN.h,v 4.0 91/03/20 00:58:35 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: INTERN.h,v $
- * Revision 3.0 89/10/18 15:06:25 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 00:58:35 lwall
+ * 4.0 baseline.
*
*/
-Changes Differences between 2.0 level 18 and 3.0 level 0
Configure Run this first
Copying The GNU General Public License
EXTERN.h Included before foreign .h files
PACKINGLIST Which files came from which kits
README The Instructions
README.uport Special instructions for Microports
+README.xenix Special instructions for Xenix
Wishlist Some things that may or may not happen
arg.h Public declarations for the above
array.c Numerically subscripted arrays
eg/van/vanexp A program to expire vanished files
eg/van/vanish A program to put files in a trashcan
eg/who A sample who program
+emacs/perldb.pl Emacs debugging
+emacs/perldb.el Emacs debugging
+emacs/perl-mode.el Emacs major mode for perl
+emacs/tedstuff Some optional patches
eval.c The expression evaluator
-evalargs.xc The arg evaluator of eval.c
form.c Format processing
form.h Public declarations for the above
gettest A little script to test the get* routines
lib/stat.pl Perl library supporting stat function
lib/syslog.pl Perl library supporting syslogging
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
makedepend.SH Precursor to makedepend
makedir.SH Precursor to makedir
-makelib.SH Deprecated (renamed to h2ph)
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
msdos/README.msdos Compiling and usage information
msdos/Wishlist.dds My wishlist
msdos/config.h Definitions for msdos
+msdos/chdir.c A chdir that can change drives
msdos/dir.h MS-DOS header for directory access functions
msdos/directory.c MS-DOS directory access functions.
msdos/eg/crlf.bat Convert files from unix to MS-DOS line termination
msdos/glob.c A command equivalent to csh glob
msdos/msdos.c MS-DOS ioctl, sleep, gete?[gu]if, spawn, aspawn
msdos/popen.c My_popen and my_pclose for MS-DOS
+msdos/usage.c How to invoke perl under MS-DOS
os2/Makefile Makefile for OS/2
os2/README.OS2 Notes for OS/2
os2/a2p.cs Compiler script for a2p
os2/a2p.def Linker defs for a2p
+os2/alarm.c An implementation of alarm()
+os2/alarm.h Header file for same
os2/config.h Configuration file for OS/2
os2/dir.h Directory header
os2/director.c Directory routines
+os2/eg/alarm.pl Example of alarm code
os2/eg/os2.pl Sample script for OS/2
os2/eg/syscalls.pl Example of syscall on OS/2
+os2/glob.c Globbing routines
os2/makefile Make file
os2/mktemp.c Mktemp() using TMP
os2/os2.c Unix compatibility functions
os2/perl.cs Compiler script for perl
os2/perl.def Linker defs for perl
os2/perldb.dif Changes to make the debugger work
+os2/perlglob.bad names of protect-only API calls for BIND
os2/perlglob.cs Compiler script for perlglob
os2/perlglob.def Linker defs for perlglob
os2/perlsh.cmd Poor man's shell for os2
os2/popen.c Code for opening pipes
+os2/s2p.cmd s2p as command file
+os2/selfrun.bat A self running perl script for DOS
os2/selfrun.cmd Example of extproc feature
os2/suffix.c Code for creating backup filenames
patchlevel.h The current patch level of perl
+perl.c main()
perl.h Global declarations
-perl.y Yacc grammar for perl
-perl_man.1 The manual page(s), first fourth
-perl_man.2 The manual page(s), second fourth
-perl_man.3 The manual page(s), third fourth
-perl_man.4 The manual page(s), fourth fourth
+perl.man The manual page(s)
perlsh A poor man's perl shell
-perly.c main()
+perly.y Yacc grammar for perl
+perly.fixer A program to remove yacc stack limitations
regcomp.c Regular expression compiler
regcomp.h Private declarations for above
regexec.c Regular expression evaluator
str.h Public declarations for the above
t/README Instructions for regression tests
t/TEST The regression tester
-t/base.cond See if conditionals work
-t/base.if See if if works
-t/base.lex See if lexical items work
-t/base.pat See if pattern matching works
-t/base.term See if various terms work
-t/cmd.elsif See if else-if works
-t/cmd.for See if for loops work
-t/cmd.mod See if statement modifiers work
-t/cmd.subval See if subroutine values work
-t/cmd.switch See if switch optimizations work
-t/cmd.while See if while loops work
-t/comp.cmdopt See if command optimization works
-t/comp.cpp See if C preprocessor works
-t/comp.decl See if declarations work
-t/comp.multiline See if multiline strings work
-t/comp.package See if packages work
-t/comp.script See if script invokation works
-t/comp.term See if more terms work
-t/io.argv See if ARGV stuff works
-t/io.dup See if >& works right
-t/io.fs See if directory manipulations work
-t/io.inplace See if inplace editing works
-t/io.pipe See if secure pipes work
-t/io.print See if print commands work
-t/io.tell See if file seeking works
-t/lib.big See if lib/bigint.pl works
-t/op.append See if . works
-t/op.array See if array operations work
-t/op.auto See if autoincrement et all work
-t/op.chop See if chop works
-t/op.cond See if conditional expressions work
-t/op.dbm See if dbm binding works
-t/op.delete See if delete works
-t/op.do See if subroutines work
-t/op.each See if associative iterators work
-t/op.eval See if eval operator works
-t/op.exec See if exec and system work
-t/op.exp See if math functions work
-t/op.flip See if range operator works
-t/op.fork See if fork works
-t/op.glob See if <*> works
-t/op.goto See if goto works
-t/op.index See if index works
-t/op.int See if int works
-t/op.join See if join works
-t/op.list See if array lists work
-t/op.local See if local works
-t/op.magic See if magic variables work
-t/op.mkdir See if mkdir works
-t/op.oct See if oct and hex work
-t/op.ord See if ord works
-t/op.pack See if pack and unpack work
-t/op.pat See if esoteric patterns work
-t/op.push See if push and pop work
-t/op.range See if .. works
-t/op.read See if read() works
-t/op.regexp See if regular expressions work
-t/op.repeat See if x operator works
-t/op.s See if substitutions work
-t/op.sleep See if sleep works
-t/op.sort See if sort works
-t/op.split See if split works
-t/op.sprintf See if sprintf works
-t/op.stat See if stat works
-t/op.study See if study works
-t/op.substr See if substr works
-t/op.time See if time functions work
-t/op.undef See if undef works
-t/op.unshift See if unshift works
-t/op.vec See if vectors work
-t/op.write See if write works
-t/re_tests Input file for op.regexp
+t/base/cond.t See if conditionals work
+t/base/if.t See if if works
+t/base/lex.t See if lexical items work
+t/base/pat.t See if pattern matching works
+t/base/term.t See if various terms work
+t/cmd/elsif.t See if else-if works
+t/cmd/for.t See if for loops work
+t/cmd/mod.t See if statement modifiers work
+t/cmd/subval.t See if subroutine values work
+t/cmd/switch.t See if switch optimizations work
+t/cmd/while.t See if while loops work
+t/comp/cmdopt.t See if command optimization works
+t/comp/cpp.t See if C preprocessor works
+t/comp/decl.t See if declarations work
+t/comp/multiline.t See if multiline strings work
+t/comp/package.t See if packages work
+t/comp/script.t See if script invokation works
+t/comp/term.t See if more terms work
+t/io/argv.t See if ARGV stuff works
+t/io/dup.t See if >& works right
+t/io/fs.t See if directory manipulations work
+t/io/inplace.t See if inplace editing works
+t/io/pipe.t See if secure pipes work
+t/io/print.t See if print commands work
+t/io/tell.t See if file seeking works
+t/lib/big.t See if lib/bigint.pl works
+t/op/append.t See if . works
+t/op/array.t See if array operations work
+t/op/auto.t See if autoincrement et all work
+t/op/chop.t See if chop works
+t/op/cond.t See if conditional expressions work
+t/op/dbm.t See if dbm binding works
+t/op/delete.t See if delete works
+t/op/do.t See if subroutines work
+t/op/each.t See if associative iterators work
+t/op/eval.t See if eval operator works
+t/op/exec.t See if exec and system work
+t/op/exp.t See if math functions work
+t/op/flip.t See if range operator works
+t/op/fork.t See if fork works
+t/op/glob.t See if <*> works
+t/op/goto.t See if goto works
+t/op/groups.t See if $( works
+t/op/index.t See if index works
+t/op/int.t See if int works
+t/op/join.t See if join works
+t/op/list.t See if array lists work
+t/op/local.t See if local works
+t/op/magic.t See if magic variables work
+t/op/mkdir.t See if mkdir works
+t/op/oct.t See if oct and hex work
+t/op/ord.t See if ord works
+t/op/pack.t See if pack and unpack work
+t/op/pat.t See if esoteric patterns work
+t/op/push.t See if push and pop work
+t/op/range.t See if .. works
+t/op/read.t See if read() works
+t/op/regexp.t See if regular expressions work
+t/op/repeat.t See if x operator works
+t/op/s.t See if substitutions work
+t/op/sleep.t See if sleep works
+t/op/sort.t See if sort works
+t/op/split.t See if split works
+t/op/sprintf.t See if sprintf works
+t/op/stat.t See if stat works
+t/op/study.t See if study works
+t/op/substr.t See if substr works
+t/op/time.t See if time functions work
+t/op/undef.t See if undef works
+t/op/unshift.t See if unshift works
+t/op/vec.t See if vectors work
+t/op/write.t See if write works
+t/op/re_tests Input file for op.regexp
toke.c The tokener
usersub.c User supplied (possibly proprietary) subroutines
+usub/README Instructions for user supplied subroutines
usub/Makefile Makefile for curseperl
usub/curses.mus Glue routines for BSD curses
usub/man2mus A manual page to .mus translator
x2p/a2p.man Manual page for awk to perl translator
x2p/a2p.y A yacc grammer for awk
x2p/a2py.c Awk compiler, sort of
+x2p/find2perl.SH A find to perl translator
x2p/handy.h Handy definitions
x2p/hash.c Associative arrays again
x2p/hash.h Public declarations for the above
ln ../../config.sh . || \
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
- fi
+ fi 2>/dev/null
. ./config.sh
;;
esac
echo "Extracting Makefile (with variable substitutions)"
cat >Makefile <<!GROK!THIS!
-# $Header: Makefile.SH,v 3.0.1.12 91/01/11 17:05:17 lwall Locked $
+# $Header: Makefile.SH,v 4.0 91/03/20 00:58:54 lwall Locked $
#
# $Log: Makefile.SH,v $
-# Revision 3.0.1.12 91/01/11 17:05:17 lwall
-# patch42: added installperl script
+# Revision 4.0 91/03/20 00:58:54 lwall
+# 4.0 baseline.
#
-# Revision 3.0.1.11 90/11/10 01:25:51 lwall
-# patch38: new arbitrary precision libraries from Mark Biggar
-#
-# Revision 3.0.1.10 90/10/20 01:59:21 lwall
-# patch37: added cryptlib support to Makefile
-#
-# Revision 3.0.1.9 90/10/15 14:41:34 lwall
-# patch29: various portability fixes
-#
-# Revision 3.0.1.8 90/08/13 21:50:49 lwall
-# patch28: not all yaccs are the same
-#
-# Revision 3.0.1.7 90/08/09 02:19:56 lwall
-# patch19: Configure now asks where you want to put scripts
-# patch19: Added support for linked-in C subroutines
-#
-# Revision 3.0.1.6 90/03/27 15:27:15 lwall
-# patch16: MSDOS support
-#
-# Revision 3.0.1.5 90/03/12 16:15:17 lwall
-# patch13: some dependencies missing on perly.h
-# patch13: some relief for buggy parallel makes
-# patch13: bison doesn't declare extern YYSTYPE yylval;
-#
-# Revision 3.0.1.4 90/02/28 16:19:43 lwall
-# patch9: extraneous $ on suidperl in Makefile
-#
-# Revision 3.0.1.3 89/12/21 19:09:26 lwall
-# patch7: Configure now lets you pick between yacc or bison
-#
-# Revision 3.0.1.2 89/11/11 04:07:30 lwall
-# patch2: $sockethdr incorporated into $ccflags
-# patch2: $libs now has most of the -l libraries
-#
-# Revision 3.0.1.1 89/10/26 23:00:38 lwall
-# patch1: Makefile.SH needed some more .h dependecies
-#
-# Revision 3.0 89/10/18 15:06:43 lwall
-# 3.0 baseline
#
CC = $cc
YACC = $yacc
-bin = $bin
+bin = $installbin
scriptdir = $scriptdir
-privlib = $privlib
+privlib = $installprivlib
mansrc = $mansrc
manext = $manext
CFLAGS = $ccflags $optimize
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) perly.c regcomp.c regexec.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
c = $(c1) $(c2) $(c3)
obj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o
-obj2 = eval.o form.o hash.o $(mallocobj) perly.o regcomp.o regexec.o
+obj2 = eval.o form.o hash.o $(mallocobj) perl.o regcomp.o regexec.o
obj3 = stab.o str.o toke.o util.o
obj = $(obj1) $(obj2) $(obj3)
.c.o:
$(CC) -c $(CFLAGS) $(LARGE) $*.c
-all: $(public) $(private) $(util) perl.man uperl.o $(scripts)
+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.
-perl: perl.o $(obj) usersub.o
- $(CC) $(LARGE) $(CLDFLAGS) $(obj) perl.o usersub.o $(libs) -o perl
+perl: $& perly.o $(obj) usersub.o
+ $(CC) $(LARGE) $(CLDFLAGS) $(obj) perly.o usersub.o $(libs) -o perl
-uperl.o: perl.o $(obj)
- -ld $(LARGE) $(LDFLAGS) -r $(obj) perl.o $(libs) -o uperl.o
+uperl.o: $& perly.o $(obj)
+ -ld $(LARGE) $(LDFLAGS) -r $(obj) perly.o $(libs) -o uperl.o
-saber: perl.c
- # load $(c) perl.c
+saber: perly.c
+ # load $(c) perly.c
# 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: tperl.o sperly.o $(tobj) usersub.o
- $(CC) $(LARGE) $(CLDFLAGS) sperly.o $(tobj) tperl.o usersub.o $(libs) \
+suidperl: $& tperly.o sperl.o $(tobj) usersub.o
+ $(CC) $(LARGE) $(CLDFLAGS) sperl.o $(tobj) tperly.o usersub.o $(libs) \
-o suidperl
# This version interprets scripts that are already set-id either via a wrapper
# NOT be setuid to root or anything else. The only difference between it
# and normal perl is the presence of the "taint" checks.
-taintperl: tperl.o tperly.o $(tobj) usersub.o
- $(CC) $(LARGE) $(CLDFLAGS) tperly.o $(tobj) tperl.o usersub.o $(libs) \
+taintperl: $& tperly.o tperl.o $(tobj) usersub.o
+ $(CC) $(LARGE) $(CLDFLAGS) tperl.o $(tobj) tperly.o usersub.o $(libs) \
-o taintperl
# Replicating all this junk is yucky, but I don't see a portable way to fix it.
-tperl.o: perl.c perly.h $(h)
- /bin/rm -f tperl.c
- $(SLN) perl.c tperl.c
- $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tperl.c
- /bin/rm -f tperl.c
-
tperly.o: perly.c perly.h $(h)
/bin/rm -f tperly.c
$(SLN) perly.c tperly.c
$(CC) -c -DTAINT $(CFLAGS) $(LARGE) tperly.c
/bin/rm -f tperly.c
-sperly.o: perly.c perly.h patchlevel.h $(h)
- /bin/rm -f sperly.c
- $(SLN) perly.c sperly.c
- $(CC) -c -DTAINT -DIAMSUID $(CFLAGS) $(LARGE) sperly.c
- /bin/rm -f sperly.c
+tperl.o: perl.c perly.h patchlevel.h perl.h $(h)
+ /bin/rm -f tperl.c
+ $(SLN) perl.c tperl.c
+ $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tperl.c
+ /bin/rm -f tperl.c
+
+sperl.o: perl.c perly.h patchlevel.h $(h)
+ /bin/rm -f sperl.c
+ $(SLN) perl.c sperl.c
+ $(CC) -c -DTAINT -DIAMSUID $(CFLAGS) $(LARGE) sperl.c
+ /bin/rm -f sperl.c
tarray.o: array.c $(h)
/bin/rm -f tarray.c
$(CC) -c -DTAINT $(CFLAGS) $(LARGE) tutil.c
/bin/rm -f tutil.c
-perly.h: perl.c
+perly.h: perly.c
@ echo Dummy dependency for dumb parallel make
touch perly.h
-perl.c: perl.y
+perly.c: perly.y
@ echo 'Expect either' 29 shift/reduce and 59 reduce/reduce conflicts...
@ echo ' or' 27 shift/reduce and 61 reduce/reduce conflicts...
- $(YACC) -d perl.y
- mv y.tab.c perl.c
+ $(YACC) -d perly.y
+ sh perly.fixer y.tab.c perly.c
mv y.tab.h perly.h
echo 'extern YYSTYPE yylval;' >>perly.h
-perl.o: perl.c perly.h $(h)
- $(CC) -c $(CFLAGS) $(LARGE) perl.c
-
-perl.man: perl_man.1 perl_man.2 perl_man.3 perl_man.4 patchlevel.h perl
- ./perl -e '($$r,$$p)=$$]=~/(\d+\.\d+).*\n\D*(\d+)/;' \
- -e 'print ".ds RP Release $$r Patchlevel $$p\n";' >perl.man
- cat perl_man.[1-4] >>perl.man
+perly.o: perly.c perly.h $(h)
+ $(CC) -c $(CFLAGS) $(LARGE) perly.c
install: all
./perl installperl
cd x2p; $(MAKE) install
clean:
- rm -f *.o all perl taintperl suidperl perl.man
+ rm -f *.o all perl taintperl suidperl
cd x2p; $(MAKE) clean
realclean: clean
cd x2p; $(MAKE) realclean
rm -f *.orig */*.orig *~ */*~ core $(addedbyconf) h2ph h2ph.man
- rm -f perl.c perly.h t/perl Makefile config.h makedepend makedir
+ rm -f perly.c perly.h t/perl Makefile config.h makedepend makedir
rm -f x2p/Makefile
# The following lint has practically everything turned on. Unfortunately,
# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
# for that spot.
-lint: perl.c $(c)
- lint $(lintflags) $(defs) perl.c $(c) > perl.fuzz
+lint: perly.c $(c)
+ lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz
depend: makedepend
- test -f perly.h || cp /dev/null perly.h
cd x2p; $(MAKE) depend
test: perl
- - chmod +x t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.* t/lib.*; \
- cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST
+ - cd t && chmod +x TEST */*.t
+ - cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST </dev/tty
clist:
echo $(c) | tr ' ' '\012' >.clist
Filename Kit Description
-------- --- -----------
-Changes 20 Differences between 2.0 level 18 and 3.0 level 0
-Configure 2 Run this first
-Copying 10 The GNU General Public License
-EXTERN.h 24 Included before foreign .h files
-INTERN.h 24 Included before domestic .h files
-MANIFEST 20 This list of files
-Makefile.SH 19 Precursor to Makefile
-PACKINGLIST 18 Which files came from which kits
+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
-Wishlist 24 Some things that may or may not happen
-arg.h 11 Public declarations for the above
-array.c 21 Numerically subscripted arrays
-array.h 24 Public declarations for the above
-client 24 A client to test sockets
-cmd.c 15 Command interpreter
-cmd.h 21 Public declarations for the above
-config.H 15 Sample config.h
-config.h.SH 14 Produces config.h
-cons.c 10 Routines to construct cmd nodes of a parse tree
-consarg.c 14 Routines to construct arg nodes of a parse tree
-doarg.c 11 Scalar expression evaluation
-doio.c 7 I/O operations
-dolist.c 16 Array expression evaluation
-dump.c 20 Debugging output
-eg/ADB 24 An adb wrapper to put in your crash dir
+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 23 A program to list recently changed files
-eg/down 24 A program to do things to subdirectories
-eg/dus 24 A program to do du -s on non-mounted dirs
-eg/findcp 17 A find wrapper that implements a -cp switch
-eg/findtar 24 A find wrapper that pumps out a tar file
-eg/g/gcp 22 A program to do a global rcp
-eg/g/gcp.man 23 Manual page for gcp
-eg/g/ged 24 A program to do a global edit
-eg/g/ghosts 22 A sample /etc/ghosts file
-eg/g/gsh 22 A program to do a global rsh
-eg/g/gsh.man 21 Manual page for gsh
-eg/muck 22 A program to find missing make dependencies
-eg/muck.man 24 Manual page for muck
-eg/myrup 23 A program to find lightly loaded machines
-eg/nih 24 Script to insert #! workaround
-eg/rename 24 A program to rename files
-eg/rmfrom 24 A program to feed doomed filenames to
-eg/scan/scan_df 23 Scan for filesystem anomalies
-eg/scan/scan_last 23 Scan for login anomalies
-eg/scan/scan_messages 21 Scan for console message anomalies
-eg/scan/scan_passwd 6 Scan for passwd file anomalies
-eg/scan/scan_ps 24 Scan for process anomalies
-eg/scan/scan_sudo 23 Scan for sudo anomalies
-eg/scan/scan_suid 22 Scan for setuid anomalies
-eg/scan/scanner 23 An anomaly reporter
-eg/shmkill 23 A program to remove unused shared memory
-eg/van/empty 24 A program to empty the trashcan
-eg/van/unvanish 23 A program to undo what vanish does
-eg/van/vanexp 24 A program to expire vanished files
-eg/van/vanish 23 A program to put files in a trashcan
-eg/who 24 A sample who program
-eval.c 3 The expression evaluator
-evalargs.xc 19 The arg evaluator of eval.c
-form.c 20 Format processing
-form.h 24 Public declarations for the above
-gettest 24 A little script to test the get* routines
-handy.h 22 Handy definitions
-hash.c 18 Associative arrays
-hash.h 23 Public declarations for the above
-ioctl.pl 21 Sample ioctl.pl
-lib/abbrev.pl 24 An abbreviation table builder
-lib/complete.pl 23 A command completion subroutine
-lib/dumpvar.pl 24 A variable dumper
-lib/getopt.pl 23 Perl library supporting option parsing
-lib/getopts.pl 24 Perl library supporting option parsing
-lib/importenv.pl 24 Perl routine to get environment into variables
-lib/look.pl 23 A "look" equivalent
-lib/perldb.pl 18 Perl debugging routines
-lib/stat.pl 24 Perl library supporting stat function
-lib/termcap.pl 22 Perl library supporting termcap usage
-lib/validate.pl 21 Perl library supporting wholesale file mode validation
-makedepend.SH 21 Precursor to makedepend
-makedir.SH 23 Precursor to makedir
-makelib.SH 21 A thing to turn C .h file into perl .h files
-malloc.c 19 A version of malloc you might not want
-patchlevel.h 10 The current patch level of perl
-perl.h 8 Global declarations
-perl.man.1 1 The manual page(s), first fourth
-perl.man.2 9 The manual page(s), second fourth
-perl.man.3 8 The manual page(s), third fourth
-perl.man.4 6 The manual page(s), fourth fourth
-perl.y 12 Yacc grammar for perl
-perlsh 24 A poor man's perl shell
-perly.c 17 main()
-regcomp.c 12 Regular expression compiler
-regcomp.h 7 Private declarations for above
-regexec.c 13 Regular expression evaluator
-regexp.h 23 Public declarations for the above
-server 24 A server to test sockets
-spat.h 23 Search pattern declarations
-stab.c 9 Symbol table stuff
-stab.h 20 Public declarations for the above
-str.c 13 String handling package
-str.h 14 Public declarations for the above
+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 23 The regression tester
-t/base.cond 24 See if conditionals work
-t/base.if 24 See if if works
-t/base.lex 23 See if lexical items work
-t/base.pat 24 See if pattern matching works
-t/base.term 24 See if various terms work
-t/cmd.elsif 24 See if else-if works
-t/cmd.for 23 See if for loops work
-t/cmd.mod 24 See if statement modifiers work
-t/cmd.subval 22 See if subroutine values work
-t/cmd.switch 12 See if switch optimizations work
-t/cmd.while 22 See if while loops work
-t/comp.cmdopt 22 See if command optimization works
-t/comp.cpp 24 See if C preprocessor works
-t/comp.decl 24 See if declarations work
-t/comp.multiline 24 See if multiline strings work
-t/comp.package 24 See if packages work
-t/comp.script 24 See if script invokation works
-t/comp.term 23 See if more terms work
-t/io.argv 23 See if ARGV stuff works
-t/io.dup 24 See if >& works right
-t/io.fs 22 See if directory manipulations work
-t/io.inplace 24 See if inplace editing works
-t/io.pipe 24 See if secure pipes work
-t/io.print 24 See if print commands work
-t/io.tell 23 See if file seeking works
-t/op.append 24 See if . works
-t/op.array 22 See if array operations work
-t/op.auto 18 See if autoincrement et all work
-t/op.chop 24 See if chop works
-t/op.cond 24 See if conditional expressions work
-t/op.dbm 22 See if dbm binding works
-t/op.delete 24 See if delete works
-t/op.do 23 See if subroutines work
-t/op.each 23 See if associative iterators work
-t/op.eval 23 See if eval operator works
-t/op.exec 24 See if exec and system work
-t/op.exp 1 See if math functions work
-t/op.flip 24 See if range operator works
-t/op.fork 24 See if fork works
-t/op.glob 24 See if <*> works
-t/op.goto 24 See if goto works
-t/op.index 24 See if index works
-t/op.int 24 See if int works
-t/op.join 24 See if join works
-t/op.list 10 See if array lists work
-t/op.local 24 See if local works
-t/op.magic 23 See if magic variables work
-t/op.mkdir 24 See if mkdir works
-t/op.oct 24 See if oct and hex work
-t/op.ord 24 See if ord works
-t/op.pack 24 See if pack and unpack work
-t/op.pat 22 See if esoteric patterns work
-t/op.push 15 See if push and pop work
-t/op.range 24 See if .. works
-t/op.read 24 See if read() works
-t/op.regexp 24 See if regular expressions work
-t/op.repeat 23 See if x operator works
-t/op.sleep 8 See if sleep works
-t/op.sort 24 See if sort works
-t/op.split 13 See if split works
-t/op.sprintf 24 See if sprintf works
-t/op.stat 21 See if stat works
-t/op.study 23 See if study works
-t/op.subst 21 See if substitutions work
-t/op.substr 23 See if substr works
-t/op.time 23 See if time functions work
-t/op.undef 23 See if undef works
-t/op.unshift 24 See if unshift works
-t/op.vec 24 See if vectors work
-t/op.write 23 See if write works
-t/re_tests 22 Input file for op.regexp
-toke.c 5 The tokener
-util.c 17 Utility routines
-util.h 24 Public declarations for the above
-x2p/EXTERN.h 24 Same as above
-x2p/INTERN.h 24 Same as above
-x2p/Makefile.SH 22 Precursor to Makefile
-x2p/a2p.h 20 Global declarations
-x2p/a2p.man 20 Manual page for awk to perl translator
-x2p/a2p.y 19 A yacc grammer for awk
-x2p/a2py.c 16 Awk compiler, sort of
-x2p/handy.h 24 Handy definitions
-x2p/hash.c 21 Associative arrays again
-x2p/hash.h 23 Public declarations for the above
-x2p/s2p.SH 18 Sed to perl translator
-x2p/s2p.man 22 Manual page for sed to perl translator
-x2p/str.c 19 String handling package
-x2p/str.h 23 Public declarations for the above
-x2p/util.c 15 Utility routines
-x2p/util.h 24 Public declarations for the above
-x2p/walk.c 4 Parse tree walker
+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
- Perl Kit, Version 3.0
+ Perl Kit, Version 4.0
- Copyright (c) 1989,1990, Larry Wall
+ Copyright (c) 1989,1990,1991, Larry Wall
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
1) Run Configure. This will figure out various things about your system.
Some things Configure will figure out for itself, other things it will
ask you about. It will then proceed to make config.h, config.sh, and
- Makefile.
+ Makefile. If you're a hotshot, run Configure -d to take all the
+ defaults and then edit config.sh to patch up any flaws.
You might possibly have to trim # comments from the front of Configure
if your sh doesn't handle them, but all other # comments will be taken
absence of a specific rule.
The 3b2 needs to turn off -O.
+ Compilers with limited switch tables may have to define -DSMALLSWITCHES
Domain/OS 10.3 (at least) native C 6.7 may need -opt 2 for eval.c
AIX/RT may need a -a switch and -DCRIPPLED_CC.
+ AIX RS/6000 needs to use system malloc and avoid -O on eval.c and toke.c.
+ AIX RS/6000 needs -D_NO_PROTO.
SUNOS 4.0.[12] needs #define fputs(str,fp) fprintf(fp,"%s",str) in perl.h
SUNOS 3.[45] should use the system malloc.
- SGI machines may need -Ddouble="long float".
- Ultrix (2.3) may need to hand assemble teval.s with a -J switch.
+ SGI machines may need -Ddouble="long float" and -O1.
+ Vax-based systems may need to hand assemble teval.s with a -J switch.
Ultrix on MIPS machines may need -DLANGUAGE_C.
Ultrix 4.0 on MIPS machines may need -Olimit 2820 or so.
Ultrix 3.[01] on MIPS needs to undefine WAITPID--the system call is busted.
MIPS machines may need to undef d_volatile.
- MIPS machines may need to turn off -O on perly.c and tperly.c.
+ MIPS machines may need to turn off -O on cmd.c, perl.c and tperl.c.
Some MIPS machines may need to undefine CASTNEGFLOAT.
- SCO Xenix may need -m25000 for yacc.
Xenix 386 needs -Sm11000 for yacc, and may need -UM_I86.
+ SCO Xenix may need -m25000 for yacc. See also README.xenix.
Genix needs to use libc rather than libc_s, or #undef VARARGS.
NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR.
A/UX may appears to work with -O -B/usr/lib/big/ optimizer flags.
A/UX may need -ZP -DPOSIX, and -g if big cc is used.
FPS machines may need -J and -DBADSWITCH.
UTS may need one or more of -DCRIPPLED_CC, -K or -g, and undef LSTAT.
+ dynix may need to undefine CASTNEGFLOAT (d_castneg='undef' in config.sh).
Dnix (not dynix) may need to remove -O.
IRIX 3.3 may need to undefine VFORK.
+ HP/UX may need to pull cerror.o and syscall.o out of libc.a and link
+ them in explicitly.
If you get syntax errors on '(', try -DCRIPPLED_CC or -DBADSWITCH or both.
Machines with half-implemented dbm routines will need to #undef ODBM & NDBM.
+ If you have GDBM available and want it instead of NDBM, say -DHAS_GDBM.
C's that don't try to restore registers on longjmp() may need -DJMPCLOBBER.
(Try this if you get random glitches.)
7) Read the manual entry before running perl.
8) IMPORTANT! Help save the world! Communicate any problems and suggested
- patches to me, lwall@jpl-devvax.jpl.nasa.gov (Larry Wall), so we can
+ patches to me, lwall@netlabs.com (Larry Wall), so we can
keep the world in sync. If you have a problem, there's someone else
out there who either has had or will have the same problem.
--- /dev/null
+From jpl-devvax!elroy.jpl.nasa.gov!sdd.hp.com!spool.mu.edu!uunet!mcsun!ukc!stl!robobar!ronald Thu Mar 7 09:51:06 PST 1991
+Article 4564 of comp.lang.perl:
+Path: jpl-devvax!elroy.jpl.nasa.gov!sdd.hp.com!spool.mu.edu!uunet!mcsun!ukc!stl!robobar!ronald
+>From: ronald@robobar.co.uk (Ronald S H Khoo)
+Newsgroups: comp.lang.perl
+Subject: Re: directory entries chopped on SCO Unix
+Message-ID: <1991Mar7.083046.14410@robobar.co.uk>
+Date: 7 Mar 91 08:30:46 GMT
+References: <18097@ogicse.ogi.edu> <DJM.91Mar5054514@egypt.eng.umd.edu> <498@stephsf.stephsf.com>
+Organization: Robobar Ltd., Perivale, Middx., ENGLAND.
+Lines: 38
+Status: OR
+
+wengland@stephsf.stephsf.com (Bill England) writes:
+
+> Would modification of the config to
+> drop the Xenix specific test and also dropping the -lx library
+> work better on Xenix boxes ? Sorry I can't test Xenix here.
+
+This is a difficult question to answer, mostly because it's hard to
+tell exactly what kind of Xenix you have.
+
+ Early releases didn't have any kind of ndir -- no problem
+
+ Many releases have only sys/ndir + -lx -- no problem
+
+ SCO Xenix 2.3.[012] have ndir + dirent, but dirent is reputedly
+ broken on .0 and .1, hence the hack to undef it.
+
+ *However*, the kernel upgrade to 2.3.3 (where dirent apparently works)
+ from any lower 2.3.? is a free upgrade, which you can anon FTP or UUCP.
+
+I use dirent -- I had to make a decision which set of directory routines
+to throw out (so that there would be no confusion), so I threw out the
+old ones. This means I have to manually remove the ! defined(M_XENIX)
+hacks from the source which is very ugh.
+
+My opinion is that the hacks should be removed seeing as they only apply
+to a small number of operating system versions which you upgrade for
+free anyway. Chip may disagree with me. It all rather depends on your
+particular point of view.
+
+You could hack Configure to do case "`uname -r`" in 2.3.[01])
+I guess. It's a lot of code to handle just one specific case,
+since you have to determine whether to do it or not as well.
+
+In short, I Really Don't Know But It's All Very Annoying.
+
+Just another Xenix user,
+--
+Ronald Khoo <ronald@robobar.co.uk> +44 81 991 1142 (O) +44 71 229 7741 (H)
+
+
-ctime to time support
-better format pictures
-pager?
built-in cpp
perl to C translator
multi-threading
-/* $Header: arg.h,v 3.0.1.8 90/11/10 01:04:36 lwall Locked $
+/* $Header: arg.h,v 4.0 91/03/20 01:03:09 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: arg.h,v $
- * Revision 3.0.1.8 90/11/10 01:04:36 lwall
- * patch38: added alarm function
- * patch38: socket, recv, select, socketpair, setsockopt didn't eval all args
- *
- * Revision 3.0.1.7 90/10/15 14:53:59 lwall
- * patch29: added SysV IPC
- * patch29: added waitpid
- * patch29: added cmp and <=>
- * patch29: added caller
- * patch29: added scalar
- * patch29: added sysread and syswrite
- * patch29: added -M, -A and -C
- * patch29: index and substr now have optional 3rd args
- * patch29: you can now read into the middle string
- * patch29: various portability fixes
- *
- * Revision 3.0.1.6 90/08/09 02:25:14 lwall
- * patch19: added require operator
- * patch19: added truncate operator
- *
- * Revision 3.0.1.5 90/03/27 15:29:41 lwall
- * patch16: MSDOS support
- *
- * Revision 3.0.1.4 90/03/12 16:18:21 lwall
- * patch13: added list slice operator (LIST)[LIST]
- * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST)
- *
- * Revision 3.0.1.3 90/02/28 16:21:55 lwall
- * patch9: added pipe function
- *
- * Revision 3.0.1.2 89/12/21 19:13:14 lwall
- * patch7: send() didn't allow a TO argument
- *
- * Revision 3.0.1.1 89/10/26 23:02:35 lwall
- * patch1: reverse didn't work
- *
- * Revision 3.0 89/10/18 15:08:27 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:03:09 lwall
+ * 4.0 baseline.
*
*/
#define O_NULL 0
-#define O_ITEM 1
-#define O_ITEM2 2
-#define O_ITEM3 3
-#define O_CONCAT 4
-#define O_MATCH 5
-#define O_NMATCH 6
-#define O_SUBST 7
-#define O_NSUBST 8
-#define O_ASSIGN 9
-#define O_MULTIPLY 10
-#define O_DIVIDE 11
-#define O_MODULO 12
-#define O_ADD 13
-#define O_SUBTRACT 14
-#define O_LEFT_SHIFT 15
-#define O_RIGHT_SHIFT 16
-#define O_LT 17
-#define O_GT 18
-#define O_LE 19
-#define O_GE 20
-#define O_EQ 21
-#define O_NE 22
-#define O_BIT_AND 23
-#define O_XOR 24
-#define O_BIT_OR 25
-#define O_AND 26
-#define O_OR 27
-#define O_COND_EXPR 28
-#define O_COMMA 29
-#define O_NEGATE 30
-#define O_NOT 31
-#define O_COMPLEMENT 32
-#define O_WRITE 33
-#define O_OPEN 34
-#define O_TRANS 35
-#define O_NTRANS 36
-#define O_CLOSE 37
-#define O_ARRAY 38
-#define O_HASH 39
-#define O_LARRAY 40
-#define O_LHASH 41
-#define O_PUSH 42
-#define O_POP 43
-#define O_SHIFT 44
-#define O_SPLIT 45
-#define O_LENGTH 46
-#define O_SPRINTF 47
-#define O_SUBSTR 48
-#define O_JOIN 49
-#define O_SLT 50
-#define O_SGT 51
-#define O_SLE 52
-#define O_SGE 53
-#define O_SEQ 54
-#define O_SNE 55
-#define O_SUBR 56
-#define O_PRINT 57
-#define O_CHDIR 58
-#define O_DIE 59
-#define O_EXIT 60
-#define O_RESET 61
-#define O_LIST 62
-#define O_SELECT 63
-#define O_EOF 64
-#define O_TELL 65
-#define O_SEEK 66
-#define O_LAST 67
-#define O_NEXT 68
-#define O_REDO 69
-#define O_GOTO 70
-#define O_INDEX 71
-#define O_TIME 72
-#define O_TMS 73
-#define O_LOCALTIME 74
-#define O_GMTIME 75
-#define O_STAT 76
-#define O_CRYPT 77
-#define O_EXP 78
-#define O_LOG 79
-#define O_SQRT 80
-#define O_INT 81
-#define O_PRTF 82
-#define O_ORD 83
-#define O_SLEEP 84
-#define O_FLIP 85
-#define O_FLOP 86
-#define O_KEYS 87
-#define O_VALUES 88
-#define O_EACH 89
-#define O_CHOP 90
-#define O_FORK 91
-#define O_EXEC_OP 92
-#define O_SYSTEM 93
-#define O_OCT 94
-#define O_HEX 95
-#define O_CHMOD 96
-#define O_CHOWN 97
-#define O_KILL 98
-#define O_RENAME 99
-#define O_UNLINK 100
-#define O_UMASK 101
-#define O_UNSHIFT 102
-#define O_LINK 103
-#define O_REPEAT 104
-#define O_EVAL 105
-#define O_FTEREAD 106
-#define O_FTEWRITE 107
-#define O_FTEEXEC 108
-#define O_FTEOWNED 109
-#define O_FTRREAD 110
-#define O_FTRWRITE 111
-#define O_FTREXEC 112
-#define O_FTROWNED 113
-#define O_FTIS 114
-#define O_FTZERO 115
-#define O_FTSIZE 116
-#define O_FTFILE 117
-#define O_FTDIR 118
-#define O_FTLINK 119
-#define O_SYMLINK 120
-#define O_FTPIPE 121
-#define O_FTSOCK 122
-#define O_FTBLK 123
-#define O_FTCHR 124
-#define O_FTSUID 125
-#define O_FTSGID 126
-#define O_FTSVTX 127
-#define O_FTTTY 128
-#define O_DOFILE 129
-#define O_FTTEXT 130
-#define O_FTBINARY 131
-#define O_UTIME 132
-#define O_WAIT 133
-#define O_SORT 134
-#define O_DELETE 135
-#define O_STUDY 136
-#define O_ATAN2 137
-#define O_SIN 138
-#define O_COS 139
-#define O_RAND 140
-#define O_SRAND 141
-#define O_POW 142
-#define O_RETURN 143
-#define O_GETC 144
-#define O_MKDIR 145
-#define O_RMDIR 146
-#define O_GETPPID 147
-#define O_GETPGRP 148
-#define O_SETPGRP 149
-#define O_GETPRIORITY 150
-#define O_SETPRIORITY 151
-#define O_CHROOT 152
-#define O_IOCTL 153
-#define O_FCNTL 154
-#define O_FLOCK 155
-#define O_RINDEX 156
-#define O_PACK 157
-#define O_UNPACK 158
-#define O_READ 159
-#define O_WARN 160
-#define O_DBMOPEN 161
-#define O_DBMCLOSE 162
-#define O_ASLICE 163
-#define O_HSLICE 164
-#define O_LASLICE 165
-#define O_LHSLICE 166
-#define O_F_OR_R 167
-#define O_RANGE 168
-#define O_RCAT 169
-#define O_AASSIGN 170
-#define O_SASSIGN 171
-#define O_DUMP 172
-#define O_REVERSE 173
-#define O_ADDROF 174
-#define O_SOCKET 175
-#define O_BIND 176
-#define O_CONNECT 177
-#define O_LISTEN 178
-#define O_ACCEPT 179
-#define O_SEND 180
-#define O_RECV 181
-#define O_SSELECT 182
-#define O_SOCKPAIR 183
-#define O_DBSUBR 184
-#define O_DEFINED 185
-#define O_UNDEF 186
-#define O_READLINK 187
-#define O_LSTAT 188
-#define O_AELEM 189
-#define O_HELEM 190
-#define O_LAELEM 191
-#define O_LHELEM 192
-#define O_LOCAL 193
-#define O_PIPE 194
-#define O_FILENO 195
-#define O_GHBYNAME 196
-#define O_GHBYADDR 197
-#define O_GHOSTENT 198
-#define O_SHOSTENT 199
-#define O_EHOSTENT 200
-#define O_GSBYNAME 201
-#define O_GSBYPORT 202
-#define O_GSERVENT 203
-#define O_SSERVENT 204
-#define O_ESERVENT 205
-#define O_GPBYNAME 206
-#define O_GPBYNUMBER 207
-#define O_GPROTOENT 208
-#define O_SPROTOENT 209
-#define O_EPROTOENT 210
-#define O_GNBYNAME 211
-#define O_GNBYADDR 212
-#define O_GNETENT 213
-#define O_SNETENT 214
-#define O_ENETENT 215
-#define O_VEC 216
-#define O_GREP 217
-#define O_GPWNAM 218
-#define O_GPWUID 219
-#define O_GPWENT 220
-#define O_SPWENT 221
-#define O_EPWENT 222
-#define O_GGRNAM 223
-#define O_GGRGID 224
-#define O_GGRENT 225
-#define O_SGRENT 226
-#define O_EGRENT 227
-#define O_SHUTDOWN 228
-#define O_OPENDIR 229
-#define O_READDIR 230
-#define O_TELLDIR 231
-#define O_SEEKDIR 232
-#define O_REWINDDIR 233
-#define O_CLOSEDIR 234
-#define O_GETLOGIN 235
-#define O_SYSCALL 236
-#define O_GSOCKOPT 237
-#define O_SSOCKOPT 238
-#define O_GETSOCKNAME 239
-#define O_GETPEERNAME 240
-#define O_LSLICE 241
-#define O_SPLICE 242
-#define O_BINMODE 243
-#define O_REQUIRE 244
-#define O_TRUNCATE 245
-#define O_MSGGET 246
-#define O_MSGCTL 247
-#define O_MSGSND 248
-#define O_MSGRCV 249
-#define O_SEMGET 250
-#define O_SEMCTL 251
-#define O_SEMOP 252
-#define O_SHMGET 253
-#define O_SHMCTL 254
-#define O_SHMREAD 255
-#define O_SHMWRITE 256
-#define O_NCMP 257
-#define O_SCMP 258
-#define O_CALLER 259
-#define O_SCALAR 260
-#define O_SYSREAD 261
-#define O_SYSWRITE 262
-#define O_FTMTIME 263
-#define O_FTATIME 264
-#define O_FTCTIME 265
-#define O_WAITPID 266
-#define O_ALARM 267
-#define MAXO 268
+#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_OPENDIR 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 266
+#define MAXO 267
#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",
"GE",
"EQ",
"NE",
+ "NCMP",
"BIT_AND",
"XOR",
"BIT_OR",
"NEGATE",
"NOT",
"COMPLEMENT",
+ "SELECT",
"WRITE",
+ "DBMOPEN",
+ "DBMCLOSE",
"OPEN",
"TRANS",
"NTRANS",
"CLOSE",
- "ARRAY",
- "HASH",
+ "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",
"SGE",
"SEQ",
"SNE",
+ "SCMP",
"SUBR",
+ "DBSUBR",
+ "CALLER",
+ "SORT",
+ "REVERSE",
+ "WARN",
+ "DIE",
+ "PRINTF",
"PRINT",
"CHDIR",
- "DIE",
"EXIT",
"RESET",
"LIST",
- "SELECT",
"EOF",
+ "GETC",
"TELL",
+ "RECV",
+ "READ",
+ "SYSREAD",
+ "SYSWRITE",
+ "SEND",
"SEEK",
- "LAST",
- "NEXT",
+ "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",
- "PRINTF",
"ORD",
+ "ALARM",
"SLEEP",
+ "RANGE",
+ "FLIP_OR_RANGE",
"FLIP",
"FLOP",
- "KEYS",
- "VALUES",
- "EACH",
- "CHOP",
"FORK",
- "EXEC",
+ "WAIT",
+ "WAITPID",
"SYSTEM",
- "OCT",
+ "EXEC",
"HEX",
- "CHMOD",
+ "OCT",
"CHOWN",
"KILL",
- "RENAME",
"UNLINK",
+ "CHMOD",
+ "UTIME",
"UMASK",
- "UNSHIFT",
+ "MSGGET",
+ "SHMGET",
+ "SEMGET",
+ "MSGCTL",
+ "SHMCTL",
+ "SEMCTL",
+ "MSGSND",
+ "MSGRCV",
+ "SEMOP",
+ "SHMREAD",
+ "SHMWRITE",
+ "RENAME",
"LINK",
- "REPEAT",
+ "MKDIR",
+ "RMDIR",
+ "GETPPID",
+ "GETPGRP",
+ "SETPGRP",
+ "GETPRIORITY",
+ "SETPRIORITY",
+ "CHROOT",
+ "FCNTL",
+ "SYSIOCTL",
+ "FLOCK",
+ "UNSHIFT",
+ "REQUIRE",
+ "DOFILE",
"EVAL",
+ "FTRREAD",
+ "FTRWRITE",
+ "FTREXEC",
"FTEREAD",
"FTEWRITE",
"FTEEXEC",
+ "FTIS",
"FTEOWNED",
- "FTRREAD",
- "FTRWRITE",
- "FTREXEC",
"FTROWNED",
- "FTIS",
"FTZERO",
"FTSIZE",
+ "FTMTIME",
+ "FTATIME",
+ "FTCTIME",
+ "FTSOCK",
+ "FTCHR",
+ "FTBLK",
"FTFILE",
"FTDIR",
+ "FTPIPE",
"FTLINK",
"SYMLINK",
- "FTPIPE",
- "FTSOCK",
- "FTBLK",
- "FTCHR",
+ "READLINK",
"FTSUID",
"FTSGID",
"FTSVTX",
"FTTTY",
- "DOFILE",
"FTTEXT",
"FTBINARY",
- "UTIME",
- "WAIT",
- "SORT",
- "DELETE",
- "STUDY",
- "ATAN2",
- "SIN",
- "COS",
- "RAND",
- "SRAND",
- "POW",
- "RETURN",
- "GETC",
- "MKDIR",
- "RMDIR",
- "GETPPID",
- "GETPGRP",
- "SETPGRP",
- "GETPRIORITY",
- "SETPRIORITY",
- "CHROOT",
- "IOCTL",
- "FCNTL",
- "FLOCK",
- "RINDEX",
- "PACK",
- "UNPACK",
- "READ",
- "WARN",
- "DBMOPEN",
- "DBMCLOSE",
- "ASLICE",
- "HSLICE",
- "LASLICE",
- "LHSLICE",
- "FLIP_OR_RANGE",
- "RANGE",
- "RCAT",
- "AASSIGN",
- "SASSIGN",
- "DUMP",
- "REVERSE",
- "ADDRESS_OF",
"SOCKET",
"BIND",
"CONNECT",
"LISTEN",
"ACCEPT",
- "SEND",
- "RECV",
- "SSELECT",
- "SOCKPAIR",
- "DBSUBR",
- "DEFINED",
- "UNDEF",
- "READLINK",
- "LSTAT",
- "AELEM",
- "HELEM",
- "LAELEM",
- "LHELEM",
- "LOCAL",
- "PIPE",
- "FILENO",
"GHBYNAME",
"GHBYADDR",
"GHOSTENT",
- "SHOSTENT",
- "EHOSTENT",
- "GSBYNAME",
- "GSBYPORT",
- "GSERVENT",
- "SSERVENT",
- "ESERVENT",
- "GPBYNAME",
- "GPBYNUMBER",
- "GPROTOENT",
- "SPROTOENT",
- "EPROTOENT",
"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",
- "GREP",
"GPWNAM",
"GPWUID",
"GPWENT",
"GGRENT",
"SGRENT",
"EGRENT",
- "SHUTDOWN",
+ "GETLOGIN",
"OPENDIR",
"READDIR",
"TELLDIR",
"SEEKDIR",
"REWINDDIR",
"CLOSEDIR",
- "GETLOGIN",
"SYSCALL",
- "GSOCKOPT",
- "SSOCKOPT",
- "GETSOCKNAME",
- "GETPEERNAME",
- "LSLICE",
- "SPLICE",
- "BINMODE",
- "REQUIRE",
- "TRUNCATE",
- "MSGGET",
- "MSGCTL",
- "MSGSND",
- "MSGRCV",
- "SEMGET",
- "SEMCTL",
- "SEMOP",
- "SHMGET",
- "SHMCTL",
- "SHMREAD",
- "SHMWRITE",
- "NCMP",
- "SCMP",
- "CALLER",
- "SCALAR",
- "SYSREAD",
- "SYSWRITE",
- "FTMTIME",
- "FTATIME",
- "FTCTIME",
- "WAITPID",
- "ALARM",
- "268"
+ "PIPE",
+ "267"
};
#endif
#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_UNUSED 32 /* */
+#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 */
#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), /* 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), /* 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), /* ARRAY */
- A(0,0,0), /* HASH */
+ 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), /* 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(0,3,0), /* DIE */
A(1,0,0), /* EXIT */
A(1,0,0), /* RESET */
A(3,0,0), /* LIST */
- A(1,0,0), /* SELECT */
A(1,0,0), /* EOF */
+ A(1,0,0), /* 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,0,0), /* LAST */
- A(0,0,0), /* NEXT */
+ 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,3,0), /* PRINTF */
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), /* KEYS */
- A(0,0,0), /* VALUES */
- A(0,0,0), /* EACH */
- A(3,0,0), /* CHOP */
A(0,0,0), /* FORK */
- A(1,3,0), /* EXEC */
+ A(0,0,0), /* WAIT */
+ A(1,1,0), /* WAITPID */
A(1,3,0), /* SYSTEM */
- A(1,0,0), /* OCT */
+ A(1,3,0), /* EXEC */
A(1,0,0), /* HEX */
- A(0,3,0), /* CHMOD */
+ A(1,0,0), /* OCT */
A(0,3,0), /* CHOWN */
A(0,3,0), /* KILL */
- A(1,1,0), /* RENAME */
A(0,3,0), /* UNLINK */
+ A(0,3,0), /* CHMOD */
+ A(0,3,0), /* UTIME */
A(1,0,0), /* UMASK */
- A(0,3,0), /* UNSHIFT */
+ 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), /* REPEAT */
+ 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), /* FTRREAD */
- A(1,0,0), /* FTRWRITE */
- A(1,0,0), /* FTREXEC */
A(1,0,0), /* FTROWNED */
- A(1,0,0), /* FTIS */
A(1,0,0), /* FTZERO */
A(1,0,0), /* FTSIZE */
+ A(1,0,0), /* 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), /* FTPIPE */
- A(1,0,0), /* FTSOCK */
- A(1,0,0), /* FTBLK */
- A(1,0,0), /* FTCHR */
+ 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), /* DOFILE */
A(1,0,0), /* FTTEXT */
A(1,0,0), /* FTBINARY */
- A(0,3,0), /* UTIME */
- A(0,0,0), /* WAIT */
- A(1,3,0), /* SORT */
- A(0,1,0), /* DELETE */
- A(1,0,0), /* STUDY */
- A(1,1,0), /* ATAN2 */
- A(1,0,0), /* SIN */
- A(1,0,0), /* COS */
- A(1,0,0), /* RAND */
- A(1,0,0), /* SRAND */
- A(1,1,0), /* POW */
- A(0,3,0), /* RETURN */
- A(1,0,0), /* GETC */
- A(1,1,0), /* MKDIR */
- A(1,0,0), /* RMDIR */
- A(0,0,0), /* GETPPID */
- A(1,0,0), /* GETPGRP */
- A(1,1,0), /* SETPGRP */
- A(1,1,0), /* GETPRIORITY */
- A(1,1,1), /* SETPRIORITY */
- A(1,0,0), /* CHROOT */
- A(1,1,1), /* IOCTL */
- A(1,1,1), /* FCNTL */
- A(1,1,0), /* FLOCK */
- A(1,1,1), /* RINDEX */
- A(1,3,0), /* PACK */
- A(1,1,0), /* UNPACK */
- A(1,1,3), /* READ */
- A(0,3,0), /* WARN */
- A(1,1,1), /* DBMOPEN */
- A(1,0,0), /* DBMCLOSE */
- A(0,3,0), /* ASLICE */
- A(0,3,0), /* HSLICE */
- A(0,3,0), /* LASLICE */
- A(0,3,0), /* LHSLICE */
- A(1,0,0), /* F_OR_R */
- A(1,1,0), /* RANGE */
- A(1,1,0), /* RCAT */
- A(3,3,0), /* AASSIGN */
- A(0,0,0), /* SASSIGN */
- A(0,0,0), /* DUMP */
- A(0,3,0), /* REVERSE */
- A(1,0,0), /* ADDROF */
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,1,3), /* SEND */
- A5(1,1,1,1,0), /* RECV */
- A5(1,1,1,1,0), /* SSELECT */
- A5(1,1,1,1,1), /* SOCKPAIR */
- A(0,3,0), /* DBSUBR */
- A(1,0,0), /* DEFINED */
- A(1,0,0), /* UNDEF */
- A(1,0,0), /* READLINK */
- A(1,0,0), /* LSTAT */
- A(0,1,0), /* AELEM */
- A(0,1,0), /* HELEM */
- A(0,1,0), /* LAELEM */
- A(0,1,0), /* LHELEM */
- A(1,0,0), /* LOCAL */
- A(1,1,0), /* PIPE */
- A(1,0,0), /* FILENO */
A(1,0,0), /* GHBYNAME */
A(1,1,0), /* GHBYADDR */
A(0,0,0), /* GHOSTENT */
- A(1,0,0), /* SHOSTENT */
- A(0,0,0), /* EHOSTENT */
- A(1,1,0), /* GSBYNAME */
- A(1,1,0), /* GSBYPORT */
- A(0,0,0), /* GSERVENT */
- A(1,0,0), /* SSERVENT */
- A(0,0,0), /* ESERVENT */
- A(1,0,0), /* GPBYNAME */
- A(1,0,0), /* GPBYNUMBER */
- A(0,0,0), /* GPROTOENT */
- A(1,0,0), /* SPROTOENT */
- A(0,0,0), /* EPROTOENT */
A(1,0,0), /* GNBYNAME */
A(1,1,0), /* GNBYADDR */
A(0,0,0), /* GNETENT */
+ A(1,0,0), /* 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(0,3,0), /* GREP */
A(1,0,0), /* GPWNAM */
A(1,0,0), /* GPWUID */
A(0,0,0), /* GPWENT */
A(0,0,0), /* GGRENT */
A(0,0,0), /* SGRENT */
A(0,0,0), /* EGRENT */
- A(1,1,0), /* SHUTDOWN */
+ 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(0,0,0), /* GETLOGIN */
A(1,3,0), /* SYSCALL */
- A(1,1,1), /* GSOCKOPT */
- A5(1,1,1,1,0), /* SSOCKOPT */
- A(1,0,0), /* GETSOCKNAME */
- A(1,0,0), /* GETPEERNAME */
- A(0,3,3), /* LSLICE */
- A(0,3,1), /* SPLICE */
- A(1,0,0), /* BINMODE */
- A(1,0,0), /* REQUIRE */
- A(1,1,0), /* TRUNCATE */
- A(1,1,0), /* MSGGET */
- A(1,1,1), /* MSGCTL */
- A(1,1,1), /* MSGSND */
- A5(1,1,1,1,1), /* MSGRCV */
- A(1,1,1), /* SEMGET */
- A5(1,1,1,1,0), /* SEMCTL */
- A(1,1,1), /* SEMOP */
- A(1,1,1), /* SHMGET */
- A(1,1,1), /* SHMCTL */
- A5(1,1,1,1,0), /* SHMREAD */
- A5(1,1,1,1,0), /* SHMWRITE */
- A(1,1,0), /* NCMP */
- A(1,1,0), /* SCMP */
- A(1,0,0), /* CALLER */
- A(1,0,0), /* SCALAR */
- A(1,1,3), /* SYSREAD */
- A(1,1,3), /* SYSWRITE */
- A(1,0,0), /* FTMTIME */
- A(1,0,0), /* FTATIME */
- A(1,0,0), /* FTCTIME */
- A(1,1,0), /* WAITPID */
- A(1,0,0), /* ALARM */
+ A(1,1,0), /* PIPE */
0
};
#undef A
-/* $Header: array.c,v 3.0.1.3 90/10/15 14:56:17 lwall Locked $
+/* $Header: array.c,v 4.0 91/03/20 01:03:32 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: array.c,v $
- * Revision 3.0.1.3 90/10/15 14:56:17 lwall
- * patch29: non-existent array values no longer cause core dumps
- *
- * Revision 3.0.1.2 90/08/13 21:52:20 lwall
- * patch28: defined(@array) and defined(%array) didn't work right
- *
- * Revision 3.0.1.1 89/11/17 15:02:52 lwall
- * patch5: nested foreach on same array didn't work
- *
- * Revision 3.0 89/10/18 15:08:33 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:03:32 lwall
+ * 4.0 baseline.
*
*/
if (ar->ary_flags & ARF_REAL)
str = Str_new(5,0);
else
- str = str_static(&str_undef);
+ str = str_mortal(&str_undef);
(void)astore(ar,key,str);
return str;
}
ARRAY *
afake(stab,size,strp)
STAB *stab;
-int size;
-STR **strp;
+register int size;
+register STR **strp;
{
register ARRAY *ar;
ar->ary_fill = size - 1;
ar->ary_max = size - 1;
ar->ary_flags = 0;
+ while (size--) {
+ (*strp++)->str_pok &= ~SP_TEMP;
+ }
return ar;
}
(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; 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*);
}
-/* $Header: array.h,v 3.0.1.1 89/11/17 15:03:42 lwall Locked $
+/* $Header: array.h,v 4.0 91/03/20 01:03:44 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: array.h,v $
- * Revision 3.0.1.1 89/11/17 15:03:42 lwall
- * patch5: nested foreach on same array didn't work
- *
- * Revision 3.0 89/10/18 15:08:41 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:03:44 lwall
+ * 4.0 baseline.
*
*/
-/* $Header: cmd.c,v 3.0.1.10 90/10/20 02:01:56 lwall Locked $
+/* $Header: cmd.c,v 4.0 91/03/20 01:04:18 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cmd.c,v $
- * Revision 3.0.1.10 90/10/20 02:01:56 lwall
- * patch37: cray has weird restrictions on setjmp locations
- *
- * Revision 3.0.1.9 90/10/15 15:32:39 lwall
- * patch29: non-existent array values no longer cause core dumps
- * patch29: scripts now run at almost full speed under the debugger
- * patch29: @ENV = () now works
- * patch29: added caller
- *
- * Revision 3.0.1.8 90/08/09 02:28:49 lwall
- * patch19: did preliminary work toward debugging packages and evals
- * patch19: conditionals now always supply a scalar context to expression
- * patch19: switch optimizer was confused by negative fractional values
- *
- * Revision 3.0.1.7 90/03/27 15:32:37 lwall
- * patch16: non-terminal blocks should never have arrays requested of them
- *
- * Revision 3.0.1.6 90/03/12 16:21:09 lwall
- * patch13: fixed some backwards VOLATILE declarations
- * patch13: while (s/x//) {} still caused some anomolies
- * patch13: greater-than test of numeric switch structures did less-than action
- *
- * Revision 3.0.1.5 90/02/28 16:38:31 lwall
- * patch9: volatilized some more variables for super-optimizing compilers
- * patch9: nested foreach loops didn't reset inner loop on next to outer loop
- * patch9: returned values were read from obsolete stack
- * patch9: added sanity check on longjmp() return value
- * patch9: substitutions that almost always succeed can corrupt label stack
- * patch9: subs which return by both mechanisms can clobber local return data
- *
- * Revision 3.0.1.4 89/12/21 19:17:41 lwall
- * patch7: arranged for certain registers to be restored after longjmp()
- * patch7: made nested or recursive foreach work right
- *
- * Revision 3.0.1.3 89/11/17 15:04:36 lwall
- * patch5: nested foreach on same array didn't work
- *
- * Revision 3.0.1.2 89/11/11 04:08:56 lwall
- * patch2: non-BSD machines required two ^D's for <>
- * patch2: grow_dlevel() not inside #ifdef DEBUGGING
- *
- * Revision 3.0.1.1 89/10/26 23:04:21 lwall
- * patch1: heuristically disabled optimization could cause core dump
- *
- * Revision 3.0 89/10/18 15:09:02 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:04:18 lwall
+ * 4.0 baseline.
*
*/
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 = &str_yes;
goto flipmaybe;
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 = &str_yes;
goto flipmaybe;
str_nset(stab_val(leftstab),retstr->str_ptr,
tmps - retstr->str_ptr);
if (amperstab)
- str_sset(stab_val(amperstab),cmd->c_short);
+ 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 = &str_yes;
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--]);
+ 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];
*tmps = '\0';
retstr->str_nok = 0;
retstr->str_cur = tmps - retstr->str_ptr;
+ STABSET(retstr);
retstr = &str_chop;
goto flipmaybe;
case CFT_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--]);
+ 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,
flipmaybe:
if (match && cmdflags & CF_FLIP) {
- while (tmps_max > tmps_base) /* clean up after last eval */
- str_free(tmps_list[tmps_max--]);
+ 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);
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--]);
+ 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];
if (savestack->ary_fill > oldsave) {
if (cmdflags & CF_TERM) {
for (match = sp + 1; match <= newsp; match++)
- st[match] = str_static(st[match]);
+ st[match] = str_mortal(st[match]);
retstr = st[newsp];
}
restorelist(oldsave);
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);
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);
-/* $Header: cmd.h,v 3.0.1.4 90/10/15 15:34:50 lwall Locked $
+/* $Header: cmd.h,v 4.0 91/03/20 01:04:34 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cmd.h,v $
- * Revision 3.0.1.4 90/10/15 15:34:50 lwall
- * patch29: scripts now run at almost full speed under the debugger
- * patch29: added caller
- *
- * Revision 3.0.1.3 90/08/09 02:29:58 lwall
- * patch19: did preliminary work toward debugging packages and evals
- *
- * Revision 3.0.1.2 90/02/28 16:39:36 lwall
- * patch9: volatilized some more variables for super-optimizing compilers
- *
- * Revision 3.0.1.1 89/10/26 23:05:43 lwall
- * patch1: unless was broken when run under the debugger
- *
- * Revision 3.0 89/10/18 15:09:15 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:04:34 lwall
+ * 4.0 baseline.
*
*/
+#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
*/
-/* EUNICE:
+/* 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:
+/* 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 /**/
-/* BIN:
+/* ALIGNBYTES
+ * This symbol contains the number of bytes required to align a double.
+ * Usual values are 2, 4, and 8.
+ */
+#define ALIGNBYTES 4 /**/
+
+/* BIN
* This symbol holds the name of the directory in which the user wants
- * to put publicly executable images for the package in question. It
+ * 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:
+/* BYTEORDER
* This symbol contains an encoding of the order of bytes in a long.
* Usual values (in octal) are 01234, 04321, 02143, 03412...
*/
-#define BYTEORDER 01234 /**/
+#define BYTEORDER 0x1234 /**/
-/* CPPSTDIN:
+/* 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:
+/* CPPMINUS
* This symbol contains the second part of the string which will invoke
* the C preprocessor on the standard input and produce to standard
* output. This symbol will have the value "-" if CPPSTDIN needs a minus
* to specify standard input, otherwise the value is "".
*/
-#define CPPSTDIN "/lib/cpp"
-#define CPPMINUS ""
+#define CPPSTDIN "cc -E"
+#define CPPMINUS "-"
-/* BCMP:
+/* 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 BCMP /**/
+#define HAS_BCMP /**/
-/* BCOPY:
+/* HAS_BCOPY
* This symbol, if defined, indicates that the bcopy routine is available
* to copy blocks of memory. Otherwise you should probably use memcpy().
*/
-#define BCOPY /**/
+#define HAS_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 /**/
-/* CHARSPRINTF:
+/* 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
*/
#define CHARSPRINTF /**/
-/* CRYPT:
+/* 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 CRYPT /**/
+#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:
+/* 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
* subprocesses to which it must pass the filename rather than the
* file descriptor of the script to be executed.
*/
-#define DOSUID /**/
+/*#undef DOSUID /**/
-/* DUP2:
+/* HAS_DUP2
* This symbol, if defined, indicates that the dup2 routine is available
* to dup file descriptors. Otherwise you should use dup().
*/
-#define DUP2 /**/
+#define HAS_DUP2 /**/
-/* FCHMOD:
+/* HAS_FCHMOD
* This symbol, if defined, indicates that the fchmod routine is available
* to change mode of opened files. If unavailable, use chmod().
*/
-#define FCHMOD /**/
+#define HAS_FCHMOD /**/
-/* FCHOWN:
+/* HAS_FCHOWN
* This symbol, if defined, indicates that the fchown routine is available
* to change ownership of opened files. If unavailable, use chown().
*/
-#define FCHOWN /**/
+#define HAS_FCHOWN /**/
-/* FCNTL:
- * This symbol, if defined, indicates to the C program that it should
- * include fcntl.h.
+/* HAS_FCNTL
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
*/
-#define FCNTL /**/
+#define HAS_FCNTL /**/
-/* FLOCK:
+/* 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 FLOCK /**/
+#define HAS_FLOCK /**/
-/* GETGROUPS:
+/* 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 GETGROUPS /**/
+#define HAS_GETGROUPS /**/
-/* GETHOSTENT:
+/* HAS_GETHOSTENT
* This symbol, if defined, indicates that the gethostent() routine is
* available to lookup host names in some data base or other.
*/
-#define GETHOSTENT /**/
+#define HAS_GETHOSTENT /**/
-/* GETPGRP:
+/* HAS_GETPGRP
* This symbol, if defined, indicates that the getpgrp() routine is
* available to get the current process group.
*/
-#define GETPGRP /**/
+#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 /**/
-/* GETPRIORITY:
+/* HAS_GETPRIORITY
* This symbol, if defined, indicates that the getpriority() routine is
* available to get a process's priority.
*/
-#define GETPRIORITY /**/
+#define HAS_GETPRIORITY /**/
-/* HTONS:
+/* HAS_HTONS
* This symbol, if defined, indicates that the htons routine (and friends)
* are available to do network order byte swapping.
*/
-/* HTONL:
+/* HAS_HTONL
* This symbol, if defined, indicates that the htonl routine (and friends)
* are available to do network order byte swapping.
*/
-/* NTOHS:
+/* HAS_NTOHS
* This symbol, if defined, indicates that the ntohs routine (and friends)
* are available to do network order byte swapping.
*/
-/* NTOHL:
+/* HAS_NTOHL
* This symbol, if defined, indicates that the ntohl routine (and friends)
* are available to do network order byte swapping.
*/
-#define HTONS /**/
-#define HTONL /**/
-#define NTOHS /**/
-#define NTOHL /**/
+#define HAS_HTONS /**/
+#define HAS_HTONL /**/
+#define HAS_NTOHS /**/
+#define HAS_NTOHL /**/
-/* index:
+/* index
* This preprocessor symbol is defined, along with rindex, if the system
* uses the strchr and strrchr routines instead.
*/
-/* rindex:
+/* 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? */
-/* IOCTL:
- * This symbol, if defined, indicates that sys/ioctl.h exists and should
- * be included.
- */
-#define IOCTL /**/
-
-/* KILLPG:
+/* 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 KILLPG /**/
+#define HAS_KILLPG /**/
-/* MEMCMP:
+/* 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 MEMCMP /**/
+#define HAS_MEMCMP /**/
-/* MEMCPY:
+/* 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.
*/
-#define MEMCPY /**/
+#define HAS_MEMCPY /**/
-/* MKDIR:
+/* 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 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 stat symbolic links.
+ */
+#define HAS_MSGCTL /**/
+
+/* HAS_MSGGET
+ * This symbol, if defined, indicates that the msgget() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_MSGGET /**/
+
+/* HAS_MSGRCV
+ * This symbol, if defined, indicates that the msgrcv() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_MSGRCV /**/
-/* NDBM:
+/* HAS_MSGSND
+ * This symbol, if defined, indicates that the msgsnd() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_MSGSND /**/
+
+/* HAS_NDBM
* This symbol, if defined, indicates that ndbm.h exists and should
* be included.
*/
-#define NDBM /**/
+#define HAS_NDBM /**/
-/* ODBM:
+/* HAS_ODBM
* This symbol, if defined, indicates that dbm.h exists and should
* be included.
*/
-#define ODBM /**/
+#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 /**/
-/* READDIR:
+/* HAS_READDIR
* This symbol, if defined, indicates that the readdir routine is available
- * from the C library to create directories.
+ * from the C library to read directories.
*/
-#define READDIR /**/
+#define HAS_READDIR /**/
-/* RENAME:
+/* 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 RENAME /**/
+#define HAS_RENAME /**/
-/* RMDIR:
+/* 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 RMDIR /**/
+#define HAS_RMDIR /**/
+
+/* 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 stat symbolic links.
+ */
+#define HAS_SEMCTL /**/
+
+/* HAS_SEMGET
+ * This symbol, if defined, indicates that the semget() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_SEMGET /**/
+
+/* HAS_SEMOP
+ * This symbol, if defined, indicates that the semop() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_SEMOP /**/
-/* SETEGID:
+/* HAS_SETEGID
* This symbol, if defined, indicates that the setegid routine is available
* to change the effective gid of the current program.
*/
-#define SETEGID /**/
+#define HAS_SETEGID /**/
-/* SETEUID:
+/* HAS_SETEUID
* This symbol, if defined, indicates that the seteuid routine is available
* to change the effective uid of the current program.
*/
-#define SETEUID /**/
+#define HAS_SETEUID /**/
-/* SETPGRP:
+/* HAS_SETPGRP
* This symbol, if defined, indicates that the setpgrp() routine is
* available to set the current process group.
*/
-#define SETPGRP /**/
+#define HAS_SETPGRP /**/
-/* SETPRIORITY:
+/* 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 SETPRIORITY /**/
+#define HAS_SETPRIORITY /**/
-/* SETREGID:
- * This symbol, if defined, indicates that the setregid routine is available
- * to change the real and effective gid of the current program.
+/* HAS_SETREGID
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current program.
*/
-#define SETREGID /**/
+/* 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 /**/
-/* SETREUID:
- * This symbol, if defined, indicates that the setreuid routine is available
- * to change the real and effective uid of the current program.
+/* 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 SETREUID /**/
+#define HAS_SETREUID /**/
+/*#undef HAS_SETRESUID /**/
-/* SETRGID:
+/* HAS_SETRGID
* This symbol, if defined, indicates that the setrgid routine is available
* to change the real gid of the current program.
*/
-#define SETRGID /**/
+#define HAS_SETRGID /**/
-/* SETRUID:
+/* HAS_SETRUID
* This symbol, if defined, indicates that the setruid routine is available
* to change the real uid of the current program.
*/
-#define SETRUID /**/
+#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 stat symbolic links.
+ */
+#define HAS_SHMAT /**/
+
+/* HAS_SHMCTL
+ * This symbol, if defined, indicates that the shmctl() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_SHMCTL /**/
+
+/* HAS_SHMDT
+ * This symbol, if defined, indicates that the shmdt() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_SHMDT /**/
+
+/* HAS_SHMGET
+ * This symbol, if defined, indicates that the shmget() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_SHMGET /**/
-/* SOCKET:
+/* HAS_SOCKET
* This symbol, if defined, indicates that the BSD socket interface is
* supported.
*/
-/* SOCKETPAIR:
+/* HAS_SOCKETPAIR
* This symbol, if defined, indicates that the BSD socketpair call is
* supported.
*/
-/* OLDSOCKET:
+/* OLDSOCKET
* This symbol, if defined, indicates that the 4.1c BSD socket interface
* is supported instead of the 4.2/4.3 BSD socket interface.
*/
-#define SOCKET /**/
+#define HAS_SOCKET /**/
-#define SOCKETPAIR /**/
+#define HAS_SOCKETPAIR /**/
/*#undef OLDSOCKET /**/
-/* STATBLOCKS:
+/* STATBLOCKS
* This symbol is defined if this system has a stat structure declaring
* st_blksize and st_blocks.
*/
#define STATBLOCKS /**/
-/* STDSTDIO:
+/* STDSTDIO
* This symbol is defined if this system has a FILE structure declaring
* _ptr and _cnt in stdio.h.
*/
#define STDSTDIO /**/
-/* STRUCTCOPY:
+/* 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 /**/
-/* SYMLINK:
+/* 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 SYMLINK /**/
+#define HAS_SYMLINK /**/
-/* SYSCALL:
+/* HAS_SYSCALL
* This symbol, if defined, indicates that the syscall routine is available
* to call arbitrary system calls. If undefined, that's tough.
*/
-#define SYSCALL /**/
-
-/* TMINSYS:
- * This symbol is defined if this system declares "struct tm" in
- * in <sys/time.h> rather than <time.h>. We can't just say
- * -I/usr/include/sys because some systems have both time files, and
- * the -I trick gets the wrong one.
- */
-/* I_SYSTIME:
- * This symbol is defined if this system has the file <sys/time.h>.
- */
-/*#undef TMINSYS /**/
-#define I_SYSTIME /**/
+#define HAS_SYSCALL /**/
-/* VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include varargs.h.
+/* HAS_TRUNCATE
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
*/
-#define VARARGS /**/
+#define HAS_TRUNCATE /**/
-/* vfork:
- * This symbol, if defined, remaps the vfork routine to fork if the
- * vfork() routine isn't supported here.
+/* HAS_VFORK
+ * This symbol, if defined, indicates that vfork() exists.
*/
-/*#undef vfork fork /**/
+#define HAS_VFORK /**/
-/* VOIDSIG:
+/* 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)".
+ */
/*#undef VOIDSIG /**/
+#define TO_SIGNAL /**/
-/* VPRINTF:
+/* 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:
+/* CHARVSPRINTF
* This symbol is defined if this system has vsprintf() returning type
* (char*). The trend seems to be to declare it as "int vsprintf()". It
* is up to the package author to declare vsprintf correctly based on the
* symbol.
*/
-/*#undef VPRINTF /**/
+/*#undef HAS_VPRINTF /**/
/*#undef CHARVSPRINTF /**/
-/* GIDTYPE:
+/* HAS_WAIT4
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+#define HAS_WAIT4 /**/
+
+/* HAS_WAITPID
+ * This symbol, if defined, indicates that waitpid() exists.
+ */
+/*#undef 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 /**/
+#define GIDTYPE int /**/
-/* I_DIRENT:
- * This symbol, if defined, indicates to the C program that it should
- * include dirent.h.
+/* I_FCNTL
+ * This manifest constant tells the C program to include <fcntl.h>.
*/
-/* DIRNAMLEN:
- * This symbol, if defined, indicates to the C program that the length
- * of directory entry names is provided by a d_namlen field. Otherwise
- * you need to do strlen() on the d_name field.
- */
-/*#undef I_DIRENT /**/
-#define DIRNAMLEN /**/
+/*#undef I_FCNTL /**/
-/* I_FCNTL:
- * This symbol, if defined, indicates to the C program that it should
- * include fcntl.h.
+/* I_GDBM
+ * This symbol, if defined, indicates that gdbm.h exists and should
+ * be included.
*/
-#define I_FCNTL /**/
+/*#undef I_GDBM /**/
-/* I_GRP:
+/* I_GRP
* This symbol, if defined, indicates to the C program that it should
* include grp.h.
*/
#define I_GRP /**/
-/* I_PWD:
+/* 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:
+/* PWQUOTA
* This symbol, if defined, indicates to the C program that struct passwd
* contains pw_quota.
*/
-/* PWAGE:
+/* 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 /**/
-#define PWQUOTA /**/
+/*#undef PWQUOTA /**/
/*#undef PWAGE /**/
+/*#undef PWCHANGE /**/
+/*#undef PWCLASS /**/
+/*#undef PWEXPIRE /**/
+/*#undef PWCOMMENT /**/
-/* I_SYSDIR:
- * This symbol, if defined, indicates to the C program that it should
- * include sys/dir.h.
+/* I_SYS_FILE
+ * This manifest constant tells the C program to include <sys/file.h>.
*/
-#define I_SYSDIR /**/
+#define I_SYS_FILE /**/
-/* I_SYSIOCTL:
+/* I_SYSIOCTL
* This symbol, if defined, indicates that sys/ioctl.h exists and should
* be included.
*/
#define I_SYSIOCTL /**/
-/* I_VARARGS:
+/* 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.
+ */
+/*#undef I_UTIME /**/
+
+/* I_VARARGS
* This symbol, if defined, indicates to the C program that it should
* include varargs.h.
*/
#define I_VARARGS /**/
-/* INTSIZE:
+/* I_VFORK
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+/*#undef 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 /**/
-/* RANDBITS:
+/* 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 /**/
+
+
+/* RANDBITS
* This symbol contains the number of bits of random number the rand()
* function produces. Usual values are 15, 16, and 31.
*/
#define RANDBITS 31 /**/
-/* SIG_NAME:
+/* SCRIPTDIR
+ * This symbol holds the name of the directory in which the user wants
+ * to put 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","IOT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CHLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","USR1","USR2" /**/
+#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CHLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","LOST","USR1","USR2" /**/
-/* STDCHAR:
+/* STDCHAR
* This symbol is defined to be the type of char used in stdio.h.
* It has the values "unsigned char" or "char".
*/
#define STDCHAR char /**/
-/* UIDTYPE:
+/* UIDTYPE
* This symbol has a value like uid_t, int, ushort, or whatever type is
* used to declare user ids in the kernel.
*/
#define UIDTYPE uid_t /**/
-/* VOIDFLAGS:
+/* VOIDHAVE
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
*
* 4 = supports comparisons between pointers to void functions and
* addresses of void functions
*
- * The package designer should define VOIDUSED to indicate the requirements
- * of the package. This can be done either by #defining VOIDUSED before
- * including config.h, or by defining defvoidused in Myinit.U. If the
- * latter approach is taken, only those flags will be tested. If the
- * level of void support necessary is not present, defines void to int.
- */
-#ifndef VOIDUSED
-#define VOIDUSED 7
+ * 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 1
#endif
-#define VOIDFLAGS 7
-#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+#define VOIDHAVE 1
+#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:
+/* 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
*/
#define PRIVLIB "/usr/local/lib/perl" /**/
+#endif
+: make config.h.SH
case $CONFIG in
'')
if test ! -f config.sh; then
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
echo "Using config.sh from above..."
- fi
+ fi 2>/dev/null
. ./config.sh
;;
esac
echo "Extracting config.h (with variable substitutions)"
sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
+#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
*/
-/* EUNICE:
+/* 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:
+/* VMS
* This symbol, if defined, indicates that the program is running under
* VMS. It is currently only set in conjunction with the EUNICE symbol.
*/
#$d_eunice EUNICE /**/
#$d_eunice VMS /**/
-/* ALIGNBYTES:
+/* ALIGNBYTES
* This symbol contains the number of bytes required to align a double.
* Usual values are 2, 4, and 8.
*/
#define ALIGNBYTES $alignbytes /**/
-/* BIN:
+/* BIN
* This symbol holds the name of the directory in which the user wants
- * to put publicly executable images for the package in question. It
+ * to keep publicly executable images for the package in question. It
* is most often a local directory such as /usr/local/bin.
*/
#define BIN "$bin" /**/
-/* BYTEORDER:
+/* BYTEORDER
* This symbol contains an encoding of the order of bytes in a long.
* Usual values (in octal) are 01234, 04321, 02143, 03412...
*/
#define BYTEORDER 0x$byteorder /**/
-/* CPPSTDIN:
+/* 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:
+/* 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
#define CPPSTDIN "$cppstdin"
#define CPPMINUS "$cppminus"
-/* BCMP:
+/* 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.
*/
-#$d_bcmp BCMP /**/
+#$d_bcmp HAS_BCMP /**/
-/* BCOPY:
+/* HAS_BCOPY
* This symbol, if defined, indicates that the bcopy routine is available
* to copy blocks of memory. Otherwise you should probably use memcpy().
*/
-#$d_bcopy BCOPY /**/
+#$d_bcopy HAS_BCOPY /**/
-/* BZERO:
+/* HAS_BZERO
* This symbol, if defined, indicates that the bzero routine is available
- * to zero blocks of memory. Otherwise you should probably use memcpy().
+ * to zero blocks of memory. Otherwise you should probably use memset()
+ * or roll your own.
*/
-#$d_bzero BZERO /**/
+#$d_bzero HAS_BZERO /**/
-/* CASTNEGFLOAT:
+/* CASTNEGFLOAT
* This symbol, if defined, indicates that this C compiler knows how to
- * cast negative numbers to unsigned longs, ints and shorts.
+ * cast negative or large floating point numbers to unsigned longs, ints
+ * and shorts.
*/
-/* CASTFLAGS:
+/* CASTFLAGS
* This symbol contains flags that say what difficulties the compiler
* has casting odd floating values to unsigned long:
* 1 = couldn't cast < 0
#$d_castneg CASTNEGFLOAT /**/
#define CASTFLAGS $castflags /**/
-/* CHARSPRINTF:
+/* 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
*/
#$d_charsprf CHARSPRINTF /**/
-/* CHSIZE:
+/* 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.
*/
-#$d_chsize CHSIZE /**/
+#$d_chsize HAS_CHSIZE /**/
-/* CRYPT:
+/* HAS_CRYPT
* This symbol, if defined, indicates that the crypt routine is available
* to encrypt passwords and the like.
*/
-#$d_crypt CRYPT /**/
+#$d_crypt HAS_CRYPT /**/
-/* CSH:
+/* CSH
* This symbol, if defined, indicates that the C-shell exists.
* If defined, contains the full pathname of csh.
*/
#$d_csh CSH "$csh" /**/
-/* DOSUID:
+/* 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
*/
#$d_dosuid DOSUID /**/
-/* DUP2:
+/* HAS_DUP2
* This symbol, if defined, indicates that the dup2 routine is available
* to dup file descriptors. Otherwise you should use dup().
*/
-#$d_dup2 DUP2 /**/
+#$d_dup2 HAS_DUP2 /**/
-/* FCHMOD:
+/* HAS_FCHMOD
* This symbol, if defined, indicates that the fchmod routine is available
* to change mode of opened files. If unavailable, use chmod().
*/
-#$d_fchmod FCHMOD /**/
+#$d_fchmod HAS_FCHMOD /**/
-/* FCHOWN:
+/* HAS_FCHOWN
* This symbol, if defined, indicates that the fchown routine is available
* to change ownership of opened files. If unavailable, use chown().
*/
-#$d_fchown FCHOWN /**/
+#$d_fchown HAS_FCHOWN /**/
-/* FCNTL:
- * This symbol, if defined, indicates to the C program that it should
- * include fcntl.h.
+/* HAS_FCNTL
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
*/
-#$d_fcntl FCNTL /**/
+#$d_fcntl HAS_FCNTL /**/
-/* FLEXFILENAMES:
+/* FLEXFILENAMES
* This symbol, if defined, indicates that the system supports filenames
* longer than 14 characters.
*/
#$d_flexfnam FLEXFILENAMES /**/
-/* FLOCK:
+/* HAS_FLOCK
* This symbol, if defined, indicates that the flock() routine is
* available to do file locking.
*/
-#$d_flock FLOCK /**/
+#$d_flock HAS_FLOCK /**/
-/* GETGROUPS:
+/* 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.
*/
-#$d_getgrps GETGROUPS /**/
+#$d_getgrps HAS_GETGROUPS /**/
-/* GETHOSTENT:
+/* HAS_GETHOSTENT
* This symbol, if defined, indicates that the gethostent() routine is
* available to lookup host names in some data base or other.
*/
-#$d_gethent GETHOSTENT /**/
+#$d_gethent HAS_GETHOSTENT /**/
-/* GETPGRP:
+/* HAS_GETPGRP
* This symbol, if defined, indicates that the getpgrp() routine is
* available to get the current process group.
*/
-#$d_getpgrp GETPGRP /**/
+#$d_getpgrp HAS_GETPGRP /**/
-/* GETPGRP2:
+/* HAS_GETPGRP2
* This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
* routine is available to get the current process group.
*/
-#$d_getpgrp2 GETPGRP2 /**/
+#$d_getpgrp2 HAS_GETPGRP2 /**/
-/* GETPRIORITY:
+/* HAS_GETPRIORITY
* This symbol, if defined, indicates that the getpriority() routine is
* available to get a process's priority.
*/
-#$d_getprior GETPRIORITY /**/
+#$d_getprior HAS_GETPRIORITY /**/
-/* HTONS:
+/* HAS_HTONS
* This symbol, if defined, indicates that the htons routine (and friends)
* are available to do network order byte swapping.
*/
-/* HTONL:
+/* HAS_HTONL
* This symbol, if defined, indicates that the htonl routine (and friends)
* are available to do network order byte swapping.
*/
-/* NTOHS:
+/* HAS_NTOHS
* This symbol, if defined, indicates that the ntohs routine (and friends)
* are available to do network order byte swapping.
*/
-/* NTOHL:
+/* HAS_NTOHL
* This symbol, if defined, indicates that the ntohl routine (and friends)
* are available to do network order byte swapping.
*/
-#$d_htonl HTONS /**/
-#$d_htonl HTONL /**/
-#$d_htonl NTOHS /**/
-#$d_htonl NTOHL /**/
+#$d_htonl HAS_HTONS /**/
+#$d_htonl HAS_HTONL /**/
+#$d_htonl HAS_NTOHS /**/
+#$d_htonl HAS_NTOHL /**/
-/* index:
+/* index
* This preprocessor symbol is defined, along with rindex, if the system
* uses the strchr and strrchr routines instead.
*/
-/* rindex:
+/* rindex
* This preprocessor symbol is defined, along with index, if the system
* uses the strchr and strrchr routines instead.
*/
#$d_index index strchr /* cultural */
#$d_index rindex strrchr /* differences? */
-/* IOCTL:
- * This symbol, if defined, indicates that sys/ioctl.h exists and should
- * be included.
- */
-#$d_ioctl IOCTL /**/
-
-/* KILLPG:
+/* 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.
*/
-#$d_killpg KILLPG /**/
+#$d_killpg HAS_KILLPG /**/
-/* LSTAT:
+/* HAS_LSTAT
* This symbol, if defined, indicates that the lstat() routine is
- * available to do file locking.
+ * available to stat symbolic links.
*/
-#$d_lstat LSTAT /**/
+#$d_lstat HAS_LSTAT /**/
-/* MEMCMP:
+/* HAS_MEMCMP
* This symbol, if defined, indicates that the memcmp routine is available
* to compare blocks of memory. If undefined, roll your own.
*/
-#$d_memcmp MEMCMP /**/
+#$d_memcmp HAS_MEMCMP /**/
-/* MEMCPY:
+/* 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.
*/
-#$d_memcpy MEMCPY /**/
+#$d_memcpy HAS_MEMCPY /**/
-/* MKDIR:
+/* 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.
*/
-#$d_mkdir MKDIR /**/
+#$d_mkdir HAS_MKDIR /**/
+
+/* HAS_MSG
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported.
+ */
+#$d_msg HAS_MSG /**/
+
+/* HAS_MSGCTL
+ * This symbol, if defined, indicates that the msgctl() routine is
+ * available to stat symbolic links.
+ */
+#$d_msgctl HAS_MSGCTL /**/
-/* NDBM:
+/* HAS_MSGGET
+ * This symbol, if defined, indicates that the msgget() routine is
+ * available to stat symbolic links.
+ */
+#$d_msgget HAS_MSGGET /**/
+
+/* HAS_MSGRCV
+ * This symbol, if defined, indicates that the msgrcv() routine is
+ * available to stat symbolic links.
+ */
+#$d_msgrcv HAS_MSGRCV /**/
+
+/* HAS_MSGSND
+ * This symbol, if defined, indicates that the msgsnd() routine is
+ * available to stat symbolic links.
+ */
+#$d_msgsnd HAS_MSGSND /**/
+
+/* HAS_NDBM
* This symbol, if defined, indicates that ndbm.h exists and should
* be included.
*/
-#$d_ndbm NDBM /**/
+#$d_ndbm HAS_NDBM /**/
-/* ODBM:
+/* HAS_ODBM
* This symbol, if defined, indicates that dbm.h exists and should
* be included.
*/
-#$d_odbm ODBM /**/
+#$d_odbm HAS_ODBM /**/
-/* READDIR:
+/* HAS_OPEN3
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+#$d_open3 HAS_OPEN3 /**/
+
+/* HAS_READDIR
* This symbol, if defined, indicates that the readdir routine is available
- * from the C library to create directories.
+ * from the C library to read directories.
*/
-#$d_readdir READDIR /**/
+#$d_readdir HAS_READDIR /**/
-/* RENAME:
+/* 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.
*/
-#$d_rename RENAME /**/
+#$d_rename HAS_RENAME /**/
-/* RMDIR:
+/* 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.
*/
-#$d_rmdir RMDIR /**/
+#$d_rmdir HAS_RMDIR /**/
+
+/* HAS_SELECT
+ * This symbol, if defined, indicates that the select() subroutine
+ * exists.
+ */
+#$d_select HAS_SELECT /**/
-/* SELECT:
- * This symbol, if defined, indicates that the select routine is available
- * to select active file descriptors.
+/* HAS_SEM
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+#$d_sem HAS_SEM /**/
+
+/* HAS_SEMCTL
+ * This symbol, if defined, indicates that the semctl() routine is
+ * available to stat symbolic links.
*/
-#$d_select SELECT /**/
+#$d_semctl HAS_SEMCTL /**/
-/* SETEGID:
+/* HAS_SEMGET
+ * This symbol, if defined, indicates that the semget() routine is
+ * available to stat symbolic links.
+ */
+#$d_semget HAS_SEMGET /**/
+
+/* HAS_SEMOP
+ * This symbol, if defined, indicates that the semop() routine is
+ * available to stat symbolic links.
+ */
+#$d_semop HAS_SEMOP /**/
+
+/* HAS_SETEGID
* This symbol, if defined, indicates that the setegid routine is available
* to change the effective gid of the current program.
*/
-#$d_setegid SETEGID /**/
+#$d_setegid HAS_SETEGID /**/
-/* SETEUID:
+/* HAS_SETEUID
* This symbol, if defined, indicates that the seteuid routine is available
* to change the effective uid of the current program.
*/
-#$d_seteuid SETEUID /**/
+#$d_seteuid HAS_SETEUID /**/
-/* SETPGRP:
+/* HAS_SETPGRP
* This symbol, if defined, indicates that the setpgrp() routine is
* available to set the current process group.
*/
-#$d_setpgrp SETPGRP /**/
+#$d_setpgrp HAS_SETPGRP /**/
-/* SETPGRP2:
+/* HAS_SETPGRP2
* This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
* routine is available to set the current process group.
*/
-#$d_setpgrp2 SETPGRP2 /**/
+#$d_setpgrp2 HAS_SETPGRP2 /**/
-/* SETPRIORITY:
+/* HAS_SETPRIORITY
* This symbol, if defined, indicates that the setpriority() routine is
* available to set a process's priority.
*/
-#$d_setprior SETPRIORITY /**/
+#$d_setprior HAS_SETPRIORITY /**/
-/* SETREGID:
+/* HAS_SETREGID
* This symbol, if defined, indicates that the setregid routine is
* available to change the real and effective gid of the current program.
*/
-/* SETRESGID:
+/* 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.
*/
-#$d_setregid SETREGID /**/
-#$d_setresgid SETRESGID /**/
+#$d_setregid HAS_SETREGID /**/
+#$d_setresgid HAS_SETRESGID /**/
-/* SETREUID:
+/* HAS_SETREUID
* This symbol, if defined, indicates that the setreuid routine is
* available to change the real and effective uid of the current program.
*/
-/* SETRESUID:
+/* 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.
*/
-#$d_setreuid SETREUID /**/
-#$d_setresuid SETRESUID /**/
+#$d_setreuid HAS_SETREUID /**/
+#$d_setresuid HAS_SETRESUID /**/
-/* SETRGID:
+/* HAS_SETRGID
* This symbol, if defined, indicates that the setrgid routine is available
* to change the real gid of the current program.
*/
-#$d_setrgid SETRGID /**/
+#$d_setrgid HAS_SETRGID /**/
-/* SETRUID:
+/* HAS_SETRUID
* This symbol, if defined, indicates that the setruid routine is available
* to change the real uid of the current program.
*/
-#$d_setruid SETRUID /**/
+#$d_setruid HAS_SETRUID /**/
+
+/* HAS_SHM
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+#$d_shm HAS_SHM /**/
+
+/* HAS_SHMAT
+ * This symbol, if defined, indicates that the shmat() routine is
+ * available to stat symbolic links.
+ */
+#$d_shmat HAS_SHMAT /**/
+
+/* HAS_SHMCTL
+ * This symbol, if defined, indicates that the shmctl() routine is
+ * available to stat symbolic links.
+ */
+#$d_shmctl HAS_SHMCTL /**/
-/* SOCKET:
+/* HAS_SHMDT
+ * This symbol, if defined, indicates that the shmdt() routine is
+ * available to stat symbolic links.
+ */
+#$d_shmdt HAS_SHMDT /**/
+
+/* HAS_SHMGET
+ * This symbol, if defined, indicates that the shmget() routine is
+ * available to stat symbolic links.
+ */
+#$d_shmget HAS_SHMGET /**/
+
+/* HAS_SOCKET
* This symbol, if defined, indicates that the BSD socket interface is
* supported.
*/
-/* SOCKETPAIR:
+/* HAS_SOCKETPAIR
* This symbol, if defined, indicates that the BSD socketpair call is
* supported.
*/
-/* OLDSOCKET:
+/* OLDSOCKET
* This symbol, if defined, indicates that the 4.1c BSD socket interface
* is supported instead of the 4.2/4.3 BSD socket interface.
*/
-#$d_socket SOCKET /**/
+#$d_socket HAS_SOCKET /**/
-#$d_sockpair SOCKETPAIR /**/
+#$d_sockpair HAS_SOCKETPAIR /**/
#$d_oldsock OLDSOCKET /**/
-/* STATBLOCKS:
+/* STATBLOCKS
* This symbol is defined if this system has a stat structure declaring
* st_blksize and st_blocks.
*/
#$d_statblks STATBLOCKS /**/
-/* STDSTDIO:
+/* STDSTDIO
* This symbol is defined if this system has a FILE structure declaring
* _ptr and _cnt in stdio.h.
*/
#$d_stdstdio STDSTDIO /**/
-/* STRUCTCOPY:
+/* 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.
*/
#$d_strctcpy STRUCTCOPY /**/
-/* STRERROR:
+/* HAS_STRERROR
* This symbol, if defined, indicates that the strerror() routine is
* available to translate error numbers to strings.
*/
-#$d_strerror STRERROR /**/
+#$d_strerror HAS_STRERROR /**/
-/* SYMLINK:
+/* HAS_SYMLINK
* This symbol, if defined, indicates that the symlink routine is available
* to create symbolic links.
*/
-#$d_symlink SYMLINK /**/
+#$d_symlink HAS_SYMLINK /**/
-/* SYSCALL:
+/* HAS_SYSCALL
* This symbol, if defined, indicates that the syscall routine is available
* to call arbitrary system calls. If undefined, that's tough.
*/
-#$d_syscall SYSCALL /**/
-
-/* SYSVIPC:
- * This symbol, if defined, indicates that System V IPC exists.
- */
-/* IPCMSG:
- * This symbol, if defined, indicates that System V IPC messages exist.
- */
-/* IPCSEM:
- * This symbol, if defined, indicates that System V IPC semaphores exist.
- */
-/* IPCSHM:
- * This symbol, if defined, indicates that System V IPC shared memory
- * exists.
- */
-#$d_sysvipc SYSVIPC /**/
-
-#$d_ipcmsg IPCMSG /**/
+#$d_syscall HAS_SYSCALL /**/
-#$d_ipcsem IPCSEM /**/
-
-#$d_ipcshm IPCSHM /**/
-
-/* TRUNCATE:
+/* HAS_TRUNCATE
* This symbol, if defined, indicates that the truncate routine is
* available to truncate files.
*/
-#$d_truncate TRUNCATE /**/
+#$d_truncate HAS_TRUNCATE /**/
-/* VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include varargs.h.
- */
-#$d_varargs VARARGS /**/
-
-/* VFORK:
+/* HAS_VFORK
* This symbol, if defined, indicates that vfork() exists.
*/
-#$d_vfork VFORK /**/
+#$d_vfork HAS_VFORK /**/
-/* VOIDSIG:
+/* 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)".
+ */
#$d_voidsig VOIDSIG /**/
+#$define TO_SIGNAL $d_tosignal /**/
-/* HASVOLATILE:
+/* HASVOLATILE
* This symbol, if defined, indicates that this C compiler knows about
* the volatile declaration.
*/
#$d_volatile HASVOLATILE /**/
-/* VPRINTF:
+/* 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:
+/* CHARVSPRINTF
* This symbol is defined if this system has vsprintf() returning type
* (char*). The trend seems to be to declare it as "int vsprintf()". It
* is up to the package author to declare vsprintf correctly based on the
* symbol.
*/
-#$d_vprintf VPRINTF /**/
+#$d_vprintf HAS_VPRINTF /**/
#$d_charvspr CHARVSPRINTF /**/
-/* WAIT4:
+/* HAS_WAIT4
* This symbol, if defined, indicates that wait4() exists.
*/
-#$d_wait4 WAIT4 /**/
+#$d_wait4 HAS_WAIT4 /**/
-/* WAITPID:
+/* HAS_WAITPID
* This symbol, if defined, indicates that waitpid() exists.
*/
-#$d_waitpid WAITPID /**/
+#$d_waitpid HAS_WAITPID /**/
-/* GIDTYPE:
+/* GIDTYPE
* This symbol has a value like gid_t, int, ushort, or whatever type is
* used to declare group ids in the kernel.
*/
#define GIDTYPE $gidtype /**/
-/* I_DIRENT:
- * This symbol, if defined, indicates to the C program that it should
- * include dirent.h.
+/* I_FCNTL
+ * This manifest constant tells the C program to include <fcntl.h>.
*/
-/* DIRNAMLEN:
- * This symbol, if defined, indicates to the C program that the length
- * of directory entry names is provided by a d_namlen field. Otherwise
- * you need to do strlen() on the d_name field.
- */
-#$i_dirent I_DIRENT /**/
-#$d_dirnamlen DIRNAMLEN /**/
+#$i_fcntl I_FCNTL /**/
-/* I_FCNTL:
- * This symbol, if defined, indicates to the C program that it should
- * include fcntl.h.
+/* I_GDBM
+ * This symbol, if defined, indicates that gdbm.h exists and should
+ * be included.
*/
-#$i_fcntl I_FCNTL /**/
+#$i_gdbm I_GDBM /**/
-/* I_GRP:
+/* I_GRP
* This symbol, if defined, indicates to the C program that it should
* include grp.h.
*/
#$i_grp I_GRP /**/
-/* I_NETINET_IN:
+/* 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.
+ */
#$i_niin I_NETINET_IN /**/
+#$i_sysin I_SYS_IN /**/
-/* I_PWD:
+/* I_PWD
* This symbol, if defined, indicates to the C program that it should
* include pwd.h.
*/
-/* PWCOMMENT:
- * This symbol, if defined, indicates to the C program that struct passwd
- * contains pw_comment.
- */
-/* PWQUOTA:
+/* PWQUOTA
* This symbol, if defined, indicates to the C program that struct passwd
* contains pw_quota.
*/
-/* PWAGE:
+/* PWAGE
* This symbol, if defined, indicates to the C program that struct passwd
* contains pw_age.
*/
-/* PWCHANGE:
+/* PWCHANGE
* This symbol, if defined, indicates to the C program that struct passwd
* contains pw_change.
*/
-/* PWCLASS:
+/* PWCLASS
* This symbol, if defined, indicates to the C program that struct passwd
* contains pw_class.
*/
-/* PWEXPIRE:
+/* 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.
+ */
#$i_pwd I_PWD /**/
-#$d_pwcomment PWCOMMENT /**/
#$d_pwquota PWQUOTA /**/
#$d_pwage PWAGE /**/
#$d_pwchange PWCHANGE /**/
#$d_pwclass PWCLASS /**/
#$d_pwexpire PWEXPIRE /**/
+#$d_pwcomment PWCOMMENT /**/
-/* I_SYSDIR:
- * This symbol, if defined, indicates to the C program that it should
- * include sys/dir.h.
+/* I_SYS_FILE
+ * This manifest constant tells the C program to include <sys/file.h>.
*/
-#$i_sysdir I_SYSDIR /**/
+#$i_sys_file I_SYS_FILE /**/
-/* I_SYSIOCTL:
+/* I_SYSIOCTL
* This symbol, if defined, indicates that sys/ioctl.h exists and should
* be included.
*/
#$i_sysioctl I_SYSIOCTL /**/
-/* I_SYSNDIR:
- * This symbol, if defined, indicates to the C program that it should
- * include sys/ndir.h.
- */
-#$i_sysndir I_SYSNDIR /**/
-
-/* I_TIME:
+/* I_TIME
* This symbol is defined if the program should include <time.h>.
*/
-/* I_SYSTIME:
+/* I_SYS_TIME
* This symbol is defined if the program should include <sys/time.h>.
*/
-/* I_SYSTIMEKERNEL:
+/* SYSTIMEKERNEL
* This symbol is defined if the program should include <sys/time.h>
* with KERNEL defined.
*/
-#$i_time I_TIME /**/
-#$i_systime I_SYSTIME /**/
+/* I_SYS_SELECT
+ * This symbol is defined if the program should include <sys/select.h>.
+ */
+#$i_time I_TIME /**/
+#$i_sys_time I_SYS_TIME /**/
#$d_systimekernel SYSTIMEKERNEL /**/
+#$i_sys_select I_SYS_SELECT /**/
-/* I_UTIME:
+/* I_UTIME
* This symbol, if defined, indicates to the C program that it should
* include utime.h.
*/
#$i_utime I_UTIME /**/
-/* I_VARARGS:
+/* I_VARARGS
* This symbol, if defined, indicates to the C program that it should
* include varargs.h.
*/
#$i_varargs I_VARARGS /**/
-/* I_VFORK:
+/* I_VFORK
* This symbol, if defined, indicates to the C program that it should
* include vfork.h.
*/
#$i_vfork I_VFORK /**/
-/* INTSIZE:
+/* INTSIZE
* This symbol contains the size of an int, so that the C preprocessor
* can make decisions based on it.
*/
#define INTSIZE $intsize /**/
-/* RANDBITS:
+/* 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.
+ */
+#$i_dirent I_DIRENT /**/
+#$i_sys_dir I_SYS_DIR /**/
+#$i_ndir I_NDIR /**/
+#$i_sys_ndir I_SYS_NDIR /**/
+#$i_my_dir I_MY_DIR /**/
+#$d_dirnamlen DIRNAMLEN /**/
+
+
+/* RANDBITS
* This symbol contains the number of bits of random number the rand()
* function produces. Usual values are 15, 16, and 31.
*/
#define RANDBITS $randbits /**/
-/* SCRIPTDIR:
+/* SCRIPTDIR
* This symbol holds the name of the directory in which the user wants
* to put publicly executable scripts for the package in question. It
* is often a directory that is mounted across diverse architectures.
*/
#define SCRIPTDIR "$scriptdir" /**/
-/* SIG_NAME:
+/* SIG_NAME
* This symbol contains an list of signal names in order.
*/
#define SIG_NAME "`echo $sig_name | sed 's/ /","/g'`" /**/
-/* STDCHAR:
+/* STDCHAR
* This symbol is defined to be the type of char used in stdio.h.
* It has the values "unsigned char" or "char".
*/
#define STDCHAR $stdchar /**/
-/* UIDTYPE:
+/* UIDTYPE
* This symbol has a value like uid_t, int, ushort, or whatever type is
* used to declare user ids in the kernel.
*/
#define UIDTYPE $uidtype /**/
-/* VOIDFLAGS:
+/* VOIDHAVE
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
*
* 4 = supports comparisons between pointers to void functions and
* addresses of void functions
*
- * The package designer should define VOIDUSED to indicate the requirements
- * of the package. This can be done either by #defining VOIDUSED before
- * including config.h, or by defining defvoidused in Myinit.U. If the
- * latter approach is taken, only those flags will be tested. If the
- * level of void support necessary is not present, defines void to int.
- */
-#ifndef VOIDUSED
-#define VOIDUSED $defvoidused
+ * 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 $voidwant
#endif
-#define VOIDFLAGS $voidflags
-#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
-#$define void int /* is void to be avoided? */
-#$define M_VOID /* Xenix strikes again */
+#define VOIDHAVE $voidhave
+#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:
+/* 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
*/
#define PRIVLIB "$privlib" /**/
+#endif
!GROK!THIS!
-/* $Header: cons.c,v 3.0.1.10 91/01/11 17:33:33 lwall Locked $
+/* $Header: cons.c,v 4.0 91/03/20 01:05:51 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cons.c,v $
- * Revision 3.0.1.10 91/01/11 17:33:33 lwall
- * patch42: the perl debugger was dumping core frequently
- * patch42: the postincrement to preincrement optimizer was overzealous
- * patch42: foreach didn't localize its temp array properly
- *
- * Revision 3.0.1.9 90/11/10 01:10:50 lwall
- * patch38: random cleanup
- *
- * Revision 3.0.1.8 90/10/15 15:41:09 lwall
- * patch29: added caller
- * patch29: scripts now run at almost full speed under the debugger
- * patch29: the debugger now understands packages and evals
- * patch29: package behavior is now more consistent
- *
- * Revision 3.0.1.7 90/08/09 02:35:52 lwall
- * patch19: did preliminary work toward debugging packages and evals
- * patch19: Added support for linked-in C subroutines
- * patch19: Numeric literals are now stored only in floating point
- * patch19: Added -c switch to do compilation only
- *
- * Revision 3.0.1.6 90/03/27 15:35:21 lwall
- * patch16: formats didn't work inside eval
- * patch16: $foo++ now optimized to ++$foo where value not required
- *
- * Revision 3.0.1.5 90/03/12 16:23:10 lwall
- * patch13: perl -d coredumped on scripts with subs that did explicit return
- *
- * Revision 3.0.1.4 90/02/28 16:44:00 lwall
- * patch9: subs which return by both mechanisms can clobber local return data
- * patch9: changed internal SUB label to _SUB_
- * patch9: line numbers were bogus during certain portions of foreach evaluation
- *
- * Revision 3.0.1.3 89/12/21 19:20:25 lwall
- * patch7: made nested or recursive foreach work right
- *
- * Revision 3.0.1.2 89/11/17 15:08:53 lwall
- * patch5: nested foreach on same array didn't work
- *
- * Revision 3.0.1.1 89/10/26 23:09:01 lwall
- * patch1: numeric switch optimization was broken
- * patch1: unless was broken when run under the debugger
- *
- * Revision 3.0 89/10/18 15:10:23 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:05:51 lwall
+ * 4.0 baseline.
*
*/
}
if (stab_sub(stab)->cmd) {
cmd_free(stab_sub(stab)->cmd);
+ stab_sub(stab)->cmd = Nullcmd;
afree(stab_sub(stab)->tosave);
}
Safefree(stab_sub(stab));
}
+ stab_sub(stab) = sub;
sub->filestab = curcmd->c_filestab;
saw_return = FALSE;
tosave = anew(Nullstab);
cmd->c_flags |= CF_TERM;
}
sub->cmd = cmd;
- stab_sub(stab) = sub;
if (perldb) {
STR *str;
- STR *tmpstr = str_static(&str_undef);
+ STR *tmpstr = str_mortal(&str_undef);
sprintf(buf,"%s:%ld",stab_val(curcmd->c_filestab)->str_ptr,
(long)subline);
STAB *stab = stabent(name,allstabs);
if (!stab) /* unused function */
- return;
+ return Null(SUBR*);
Newz(101,sub,1,SUBR);
if (stab_sub(stab)) {
if (dowarn)
warn("Subroutine %s redefined",name);
if (stab_sub(stab)->cmd) {
cmd_free(stab_sub(stab)->cmd);
+ stab_sub(stab)->cmd = Nullcmd;
afree(stab_sub(stab)->tosave);
}
Safefree(stab_sub(stab));
}
+ stab_sub(stab) = sub;
sub->filestab = fstab(filename);
sub->usersub = subaddr;
sub->userindex = ix;
- stab_sub(stab) = sub;
return sub;
}
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 ||? */
- free_arg(arg);
+ arg_free(arg);
cmd->c_expr = Nullarg;
}
if (!(context & 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;
}
}
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;
}
arg = cmd->ucmd.acmd.ac_expr;
if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD)
cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */
- if (arg && arg->arg_type == O_SUBR)
+ 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;
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;
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;
while (cmd) {
if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */
- if (cmd->c_label)
+ if (cmd->c_label) {
Safefree(cmd->c_label);
- if (cmd->c_short)
+ cmd->c_label = Nullch;
+ }
+ if (cmd->c_short) {
str_free(cmd->c_short);
- if (cmd->c_spat)
- spat_free(cmd->c_spat);
- if (cmd->c_expr)
+ 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)
+ 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)
+ if (cmd->ucmd.acmd.ac_expr) {
arg_free(cmd->ucmd.acmd.ac_expr);
+ cmd->ucmd.acmd.ac_expr = Nullarg;
+ }
break;
}
tofree = cmd;
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 &&
/* 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_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;
}
}
register SPAT *sp;
HENT *entry;
- if (spat->spat_runtime)
+ 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 */
register CMD *lastcmd = Nullcmd;
while (cmd) {
- if (cmd->c_spat)
- shouldsave |= spat_tosave(cmd->c_spat);
if (cmd->c_expr)
shouldsave |= arg_tosave(cmd->c_expr,willsave);
switch (cmd->c_type) {
-/* $Header: consarg.c,v 3.0.1.8 91/01/11 17:37:31 lwall Locked $
+/* $Header: consarg.c,v 4.0 91/03/20 01:06:15 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: consarg.c,v $
- * Revision 3.0.1.8 91/01/11 17:37:31 lwall
- * patch42: assignment to a slice didn't supply an array context to RHS
- * patch42: suppressed variable suicide on local($a,$b) = @_
- *
- * Revision 3.0.1.7 90/10/15 15:55:28 lwall
- * patch29: defined @foo was behaving inconsistently
- * patch29: -5 % 5 was wrong
- * patch29: package behavior is now more consistent
- *
- * Revision 3.0.1.6 90/08/09 02:38:51 lwall
- * patch19: fixed problem with % of negative number
- *
- * Revision 3.0.1.5 90/03/27 15:36:45 lwall
- * patch16: support for machines that can't cast negative floats to unsigned ints
- *
- * Revision 3.0.1.4 90/03/12 16:24:40 lwall
- * patch13: return (@array) did counter-intuitive things
- *
- * Revision 3.0.1.3 90/02/28 16:47:54 lwall
- * patch9: the x operator is now up to 10 times faster
- * patch9: @_ clobbered by ($foo,$bar) = split
- *
- * Revision 3.0.1.2 89/11/17 15:11:34 lwall
- * patch5: defined $foo{'bar'} should not create element
- *
- * Revision 3.0.1.1 89/11/11 04:14:30 lwall
- * patch2: '-' x 26 made warnings about undefined value
- * patch2: eval with no args caused strangeness
- * patch2: local(@foo) didn't work, but local(@foo,$bar) did
- *
- * Revision 3.0 89/10/18 15:10:30 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:06:15 lwall
+ * 4.0 baseline.
*
*/
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;
}
}
- Safefree(pat);
+ free_arg(pat);
}
else {
Newz(202,spat,1,SPAT);
return;
if ((arg[1].arg_type == A_SINGLE || arg->arg_type == O_AELEM) &&
- (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) {
+ (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) {
str = Str_new(20,0);
s1 = arg[1].arg_ptr.arg_str;
if (arg->arg_len > 1)
arg[1].arg_type = A_ARYSTAB; /* $abc[123] is hoistable now */
arg[1].arg_len = i;
str_free(s2);
+ arg[2].arg_type = A_NULL;
+ arg[2].arg_ptr.arg_str = Nullstr;
}
/* FALL THROUGH */
default:
if (value == 0.0)
yyerror("Illegal division by constant zero");
else
- str_numset(str,str_gnum(s1) / value);
+#ifdef cray
+ /* 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:
tmplong = (unsigned long)str_gnum(s2);
else
str_sset(str,arg[3].arg_ptr.arg_str);
str_free(arg[3].arg_ptr.arg_str);
+ arg[3].arg_ptr.arg_str = Nullstr;
}
break;
case O_NEGATE:
str_numset(str,(double)(str_cmp(s1,s2)));
break;
case O_CRYPT:
-#ifdef CRYPT
+#ifdef HAS_CRYPT
tmps = str_get(s1);
str_set(str,crypt(tmps,str_get(s2)));
#else
str_free(s1);
str_free(s2);
arg[1].arg_ptr.arg_str = str;
+ arg[2].arg_ptr.arg_str = Nullstr;
+ arg[2].arg_type = A_NULL;
}
}
}
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 */
}
/* grow string struct to hold an lstring struct */
}
else if (arg1->arg_type == O_ASSIGN) {
- if (arg->arg_type == O_CHOP)
+/* if (arg->arg_type == O_CHOP)
arg[1].arg_flags &= ~AF_ARYOK; /* grandfather chop idiom */
}
else {
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++) {
rcatmaybe(arg)
ARG *arg;
{
- if (arg->arg_type == O_CONCAT && arg[2].arg_type == A_READ) {
- arg->arg_type = O_RCAT;
- arg[2].arg_type = arg[2].arg_ptr.arg_arg[1].arg_type;
- arg[2].arg_ptr = arg[2].arg_ptr.arg_arg[1].arg_ptr;
- free_arg(arg[2].arg_ptr.arg_arg);
+ 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;
}
while (*s) {
if (*s == '$' && s[1]) {
- s = scanreg(s,send,tokenbuf);
+ s = scanident(s,send,tokenbuf);
stab = stabent(tokenbuf,TRUE);
if (marking)
stab_lastexpr(stab) = exprnum;
-/* $Header: doarg.c,v 3.0.1.10 91/01/11 17:41:39 lwall Locked $
+/* $Header: doarg.c,v 4.0 91/03/20 01:06:42 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: doarg.c,v $
- * Revision 3.0.1.10 91/01/11 17:41:39 lwall
- * patch42: added binary and hex pack/unpack options
- * patch42: fixed casting problem with n and N pack options
- * patch42: fixed printf("%c", 0)
- * patch42: the perl debugger was dumping core frequently
- *
- * Revision 3.0.1.9 90/11/10 01:14:31 lwall
- * patch38: random cleanup
- * patch38: optimized join('',...)
- * patch38: printf cleaned up
- *
- * Revision 3.0.1.8 90/10/15 16:04:04 lwall
- * patch29: @ENV = () now works
- * patch29: added caller
- * patch29: tr/// now understands c, d and s options, and handles nulls right
- * patch29: *foo now prints as *package'foo
- * patch29: added caller
- * patch29: local() without initialization now creates undefined values
- *
- * Revision 3.0.1.7 90/08/13 22:14:15 lwall
- * patch28: the NSIG hack didn't work on Xenix
- * patch28: defined(@array) and defined(%array) didn't work right
- *
- * Revision 3.0.1.6 90/08/09 02:48:38 lwall
- * patch19: fixed double include of <signal.h>
- * patch19: pack/unpack can now do native float and double
- * patch19: pack/unpack can now have absolute and negative positioning
- * patch19: pack/unpack can now have use * to specify all the rest of input
- * patch19: unpack can do checksumming
- * patch19: $< and $> better supported on machines without setreuid
- * patch19: Added support for linked-in C subroutines
- *
- * Revision 3.0.1.5 90/03/27 15:39:03 lwall
- * patch16: MSDOS support
- * patch16: support for machines that can't cast negative floats to unsigned ints
- * patch16: sprintf($s,...,$s,...) didn't work
- *
- * Revision 3.0.1.4 90/03/12 16:28:42 lwall
- * patch13: pack of ascii strings could call str_ncat() with negative length
- * patch13: printf("%s", *foo) was busted
- *
- * Revision 3.0.1.3 90/02/28 16:56:58 lwall
- * patch9: split now can split into more than 10000 elements
- * patch9: sped up pack and unpack
- * patch9: pack of unsigned ints and longs blew up some places
- * patch9: sun3 can't cast negative float to unsigned int or long
- * patch9: local($.) didn't work
- * patch9: grep(s/foo/bar/, @abc = @xyz) modified @xyz rather than @abc
- * patch9: syscall returned stack size rather than value of system call
- *
- * Revision 3.0.1.2 89/12/21 19:52:15 lwall
- * patch7: a pattern wouldn't match a null string before the first character
- * patch7: certain patterns didn't match correctly at end of string
- *
- * Revision 3.0.1.1 89/11/11 04:17:20 lwall
- * patch2: printf %c, %D, %X and %O didn't work right
- * patch2: printf of unsigned vs signed needed separate casts on some machines
- *
- * Revision 3.0 89/10/18 15:10:41 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:06:42 lwall
+ * 4.0 baseline.
*
*/
extern unsigned char fold[];
+#ifndef __STDC__
extern char **environ;
+#endif /* ! __STDC__ */
#ifdef BUGGY_MSC
#pragma function(memcmp)
(void)eval(spat->spat_runtime,G_SCALAR,sp);
m = str_get(dstr = stack->ary_array[sp+1]);
nointrp = "";
- if (spat->spat_regexp)
+ 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) {
}
c = str_get(dstr);
clen = dstr->str_cur;
- if (clen <= spat->spat_slen + spat->spat_regexp->regback) {
+ if (clen <= spat->spat_slen + (int)spat->spat_regexp->regback) {
/* can do inplace substitution */
if (regexec(spat->spat_regexp, s, strend, orig, 0,
str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) {
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;
st += ++sp;
if (items-- > 0)
- str_sset(str,*st++);
+ str_sset(str, *st++);
else
str_set(str,"");
if (delimlen) {
while (len-- > 0) {
fromstr = NEXTFROM;
ashort = (short)str_gnum(fromstr);
-#ifdef HTONS
+#ifdef HAS_HTONS
ashort = htons(ashort);
#endif
str_ncat(str,(char*)&ashort,sizeof(short));
while (len-- > 0) {
fromstr = NEXTFROM;
aulong = U_L(str_gnum(fromstr));
-#ifdef HTONL
+#ifdef HAS_HTONL
aulong = htonl(aulong);
#endif
str_ncat(str,(char*)&aulong,sizeof(unsigned long));
s += 3;
len -= 3;
}
+ for (s = str->str_ptr; *s; s++) {
+ if (*s == ' ')
+ *s = '`';
+ }
str_ncat(str, "\n", 1);
}
return str;
}
-int
+void
do_unshift(ary,arglast)
register ARRAY *ary;
int *arglast;
}
if (!stab)
fatal("Undefined subroutine called");
- if (arg->arg_type == O_DBSUBR) {
+ if (arg->arg_type == O_DBSUBR && !sub->usersub) {
str = stab_val(DBsub);
saveitem(str);
stab_fullname(str,stab);
tmps_base = oldtmps_base;
for (items = arglast[0] + 1; items <= sp; items++)
- st[items] = str_static(st[items]);
+ st[items] = str_mortal(st[items]);
/* in case restore wipes old str */
restorelist(oldsave);
return sp;
if (arg->arg_flags & AF_COMMON) {
for (relem = firstrelem; relem <= lastrelem; relem++) {
if (str = *relem)
- *relem = str_static(str);
+ *relem = str_mortal(str);
}
}
relem = firstrelem;
}
if (delaymagic > 1) {
if (delaymagic & DM_REUID) {
-#ifdef SETREUID
+#ifdef HAS_SETREUID
setreuid(uid,euid);
#else
if (uid != euid || setuid(uid) < 0)
#endif
}
if (delaymagic & DM_REGID) {
-#ifdef SETREGID
+#ifdef HAS_SETREGID
setregid(gid,egid);
#else
if (gid != egid || setgid(gid) < 0)
}
else if (type == O_SUBR || type == O_DBSUBR) {
stab = arg[1].arg_ptr.arg_stab;
- cmd_free(stab_sub(stab)->cmd);
- afree(stab_sub(stab)->tosave);
- Safefree(stab_sub(stab));
- stab_sub(stab) = Null(SUBR*);
+ if (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");
*tmps = '\0'; /* wipe it out */
str->str_cur = tmps - str->str_ptr;
str->str_nok = 0;
+ STABSET(str);
}
do_vop(optype,str,left,right)
STR *left;
STR *right;
{
- register char *s = str_get(str);
+ register char *s;
register char *l = str_get(left);
register char *r = str_get(right);
register int len;
STR_GROW(str,len);
(void)bzero(str->str_ptr + str->str_cur, len - str->str_cur);
str->str_cur = len;
- s = str_get(str);
+ }
+ s = str->str_ptr;
+ if (!s) {
+ str_nset(str,"",0);
+ s = str->str_ptr;
}
switch (optype) {
case O_BIT_AND:
register int i = 0;
int retval = -1;
-#ifdef SYSCALL
+#ifdef HAS_SYSCALL
#ifdef TAINT
for (st += ++sp; items--; st++)
tainted |= (*st)->str_tainted;
-/* $Header: doio.c,v 3.0.1.14 91/01/11 17:51:04 lwall Locked $
+/* $Header: doio.c,v 4.0 91/03/20 01:07:06 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: doio.c,v $
- * Revision 3.0.1.14 91/01/11 17:51:04 lwall
- * patch42: ANSIfied the stat mode checking
- * patch42: the -i switch is now much more robust and informative
- * patch42: close on a pipe didn't return failure correctly
- * patch42: stat on temp values could wipe them out prematurely, i.e. grep(-d,<*>)
- * patch42: -l didn't work right with _
- *
- * Revision 3.0.1.13 90/11/10 01:17:37 lwall
- * patch38: -e _ was wrong if last stat failed
- * patch38: more msdos/os2 upgrades
- *
- * Revision 3.0.1.12 90/10/20 02:04:18 lwall
- * patch37: split out separate Sys V IPC features
- *
- * Revision 3.0.1.11 90/10/15 16:16:11 lwall
- * patch29: added SysV IPC
- * patch29: file - didn't auto-close cleanly
- * patch29: close; core dumped
- * patch29: more MSDOS and OS/2 updates, from Kai Uwe Rommel
- * patch29: various portability fixes
- * patch29: *foo now prints as *package'foo
- *
- * Revision 3.0.1.10 90/08/13 22:14:29 lwall
- * patch28: close-on-exec problems on dup'ed file descriptors
- * patch28: F_FREESP wasn't implemented the way I thought
- *
- * Revision 3.0.1.9 90/08/09 02:56:19 lwall
- * patch19: various MSDOS and OS/2 patches folded in
- * patch19: prints now check error status better
- * patch19: printing a list with null elements only printed front of list
- * patch19: on machines with vfork child would allocate memory in parent
- * patch19: getsockname and getpeername gave bogus warning on error
- * patch19: MACH doesn't have seekdir or telldir
- *
- * Revision 3.0.1.8 90/03/27 15:44:02 lwall
- * patch16: MSDOS support
- * patch16: support for machines that can't cast negative floats to unsigned ints
- * patch16: system() can lose arguments passed to shell scripts on SysV machines
- *
- * Revision 3.0.1.7 90/03/14 12:26:24 lwall
- * patch15: commands involving execs could cause malloc arena corruption
- *
- * Revision 3.0.1.6 90/03/12 16:30:07 lwall
- * patch13: system 'FOO=bar command' didn't invoke sh as it should
- *
- * Revision 3.0.1.5 90/02/28 17:01:36 lwall
- * patch9: open(FOO,"$filename\0") will now protect trailing spaces in filename
- * patch9: removed obsolete checks to avoid opening block devices
- * patch9: removed references to acusec and modusec that some utime.h's have
- * patch9: added pipe function
- *
- * Revision 3.0.1.4 89/12/21 19:55:10 lwall
- * patch7: select now works on big-endian machines
- * patch7: errno may now be a macro with an lvalue
- * patch7: ANSI strerror() is now supported
- * patch7: Configure now detects DG/UX thingies like [sg]etpgrp2 and utime.h
- *
- * Revision 3.0.1.3 89/11/17 15:13:06 lwall
- * patch5: some systems have symlink() but not lstat()
- * patch5: some systems have dirent.h but not readdir()
- *
- * Revision 3.0.1.2 89/11/11 04:25:51 lwall
- * patch2: orthogonalized the file modes some so we can have <& +<& etc.
- * patch2: do_open() now detects sockets passed to process from parent
- * patch2: fd's above 2 are now closed on exec
- * patch2: csh code can now use csh from other than /bin
- * patch2: getsockopt, get{sock,peer}name didn't define result properly
- * patch2: warn("shutdown") was replicated
- * patch2: gethostbyname was misdeclared
- * patch2: telldir() is sometimes a macro
- *
- * Revision 3.0.1.1 89/10/26 23:10:05 lwall
- * patch1: Configure now checks for BSD shadow passwords
- *
- * Revision 3.0 89/10/18 15:10:54 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:07:06 lwall
+ * 4.0 baseline.
*
*/
#include "EXTERN.h"
#include "perl.h"
-#ifdef SOCKET
+#ifdef HAS_SOCKET
#include <sys/socket.h>
#include <netdb.h>
#endif
-#if defined(SELECT) && (defined(M_UNIX) || defined(M_XENIX))
+#ifdef M_UNIX
+#if defined(HAS_SELECT) && !defined(I_SYS_TIME)
#include <sys/select.h>
#endif
+#endif
-#ifdef SYSVIPC
+#ifdef M_XENIX
+#ifdef HAS_SELECT
+#include <sys/select.h>
+#endif
+#endif
+
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
#include <sys/ipc.h>
-#ifdef IPCMSG
+#ifdef HAS_MSG
#include <sys/msg.h>
#endif
-#ifdef IPCSEM
+#ifdef HAS_SEM
#include <sys/sem.h>
#endif
-#ifdef IPCSHM
+#ifdef HAS_SHM
#include <sys/shm.h>
#endif
#endif
#ifdef I_FCNTL
#include <fcntl.h>
#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
int laststatval = -1;
+int laststype = O_STAT;
bool
do_open(stab,name,len)
else
fd = -1;
}
- fp = fdopen(dup(fd),mode);
+ if (!(fp = fdopen(fd = dup(fd),mode))) {
+ close(fd);
+ }
}
else {
while (isspace(*name))
stio->type = 's'; /* some OS's return 0 on fstat()ed socket */
#endif
}
-#if defined(FCNTL) && defined(F_SETFD)
+#if defined(HAS_FCNTL) && defined(F_SETFD)
fd = fileno(fp);
fcntl(fd,F_SETFD,fd >= 3);
#endif
if (stio->type != 's')
stio->ofp = fp;
else
- stio->ofp = fdopen(fileno(fp),"w");
+ if (!(stio->ofp = fdopen(fileno(fp),"w"))) {
+ fclose(fp);
+ stio->ifp = Nullfp;
+ }
}
return TRUE;
}
register STAB *stab;
{
register STR *str;
- char *oldname;
int filedev;
int fileino;
- int filemode;
int fileuid;
int filegid;
-
+ static int filemode = 0;
+ static int lastfd;
+ static char *oldname;
+
+ if (!argvoutstab)
+ argvoutstab = stabent("ARGVOUT",TRUE);
+ if (filemode & (S_ISUID|S_ISGID)) {
+ fflush(stab_io(argvoutstab)->ifp); /* chmod must follow last write */
+#ifdef HAS_FCHMOD
+ (void)fchmod(lastfd,filemode);
+#else
+ (void)chmod(oldname,filemode);
+#endif
+ }
+ filemode = 0;
while (alen(stab_xarray(stab)) >= 0) {
str = ashift(stab_xarray(stab));
str_sset(stab_val(stab),str);
continue;
}
#endif
-#ifdef RENAME
+#ifdef HAS_RENAME
#ifndef MSDOS
if (rename(oldname,str->str_ptr) < 0) {
warn("Can't rename %s to %s: %s, skipping file",
}
else {
#ifndef MSDOS
- (void)UNLINK(oldname);
+ 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);
+ continue;
+ }
#else
fatal("Can't do inplace edit without backup");
#endif
str_nset(str,">",1);
str_cat(str,oldname);
errno = 0; /* in case sprintf set errno */
- if (!do_open(argvoutstab,str->str_ptr,str->str_cur))
+ if (!do_open(argvoutstab,str->str_ptr,str->str_cur)) {
warn("Can't do inplace edit on %s: %s",
oldname, strerror(errno) );
+ do_close(stab,FALSE);
+ str_free(str);
+ continue;
+ }
defoutstab = argvoutstab;
-#ifdef FCHMOD
- (void)fchmod(fileno(stab_io(argvoutstab)->ifp),filemode);
+ lastfd = fileno(stab_io(argvoutstab)->ifp);
+ (void)fstat(lastfd,&statbuf);
+#ifdef HAS_FCHMOD
+ (void)fchmod(lastfd,filemode);
#else
(void)chmod(oldname,filemode);
#endif
-#ifdef FCHOWN
- (void)fchown(fileno(stab_io(argvoutstab)->ifp),fileuid,filegid);
+ if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
+#ifdef HAS_FCHOWN
+ (void)fchown(lastfd,fileuid,filegid);
#else
-#ifdef CHOWN
- (void)chown(oldname,fileuid,filegid);
+#ifdef HAS_CHOWN
+ (void)chown(oldname,fileuid,filegid);
#endif
#endif
+ }
}
str_free(str);
return stab_io(stab)->ifp;
return Nullfp;
}
-#ifdef PIPE
+#ifdef HAS_PIPE
void
do_pipe(str, rstab, wstab)
STR *str;
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(str,&str_yes);
return;
(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;
#ifdef MSDOS
fatal("fcntl is not implemented");
#else
-#ifdef I_FCNTL
+#ifdef HAS_FCNTL
retval = fcntl(fileno(stio->ifp), func, s);
#else
fatal("fcntl is not implemented");
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 ||
else {
str_set(statname,str_get(ary->ary_array[sp]));
statstab = Nullstab;
-#ifdef LSTAT
+#ifdef HAS_LSTAT
+ laststype = arg->arg_type;
if (arg->arg_type == O_LSTAT)
laststatval = lstat(str_get(statname),&statcache);
else
if (max) {
#ifndef lint
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_dev)));
+ str_2mortal(str_nmake((double)statcache.st_dev)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_ino)));
+ str_2mortal(str_nmake((double)statcache.st_ino)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_mode)));
+ str_2mortal(str_nmake((double)statcache.st_mode)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_nlink)));
+ str_2mortal(str_nmake((double)statcache.st_nlink)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_uid)));
+ str_2mortal(str_nmake((double)statcache.st_uid)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_gid)));
+ str_2mortal(str_nmake((double)statcache.st_gid)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_rdev)));
+ str_2mortal(str_nmake((double)statcache.st_rdev)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_size)));
+ str_2mortal(str_nmake((double)statcache.st_size)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_atime)));
+ str_2mortal(str_nmake((double)statcache.st_atime)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_mtime)));
+ str_2mortal(str_nmake((double)statcache.st_mtime)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_ctime)));
+ str_2mortal(str_nmake((double)statcache.st_ctime)));
#ifdef STATBLOCKS
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_blksize)));
+ str_2mortal(str_nmake((double)statcache.st_blksize)));
(void)astore(ary,++sp,
- str_2static(str_nmake((double)statcache.st_blocks)));
+ str_2mortal(str_nmake((double)statcache.st_blocks)));
#else
(void)astore(ary,++sp,
- str_2static(str_make("",0)));
+ str_2mortal(str_make("",0)));
(void)astore(ary,++sp,
- str_2static(str_make("",0)));
+ str_2mortal(str_make("",0)));
#endif
#else /* lint */
(void)astore(ary,++sp,str_nmake(0.0));
return sp;
}
-#if !defined(TRUNCATE) && !defined(CHSIZE) && defined(F_FREESP)
+#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
/* code courtesy of William Kucharski */
-#define CHSIZE
+#define HAS_CHSIZE
int chsize(fd, length)
int fd; /* file descriptor */
int result = 1;
STAB *tmpstab;
-#if defined(TRUNCATE) || defined(CHSIZE)
-#ifdef TRUNCATE
+#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) ||
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_static(&str_undef);
+ STR *tmpstr = str_mortal(&str_undef);
stab_fullname(tmpstr,((STAB*)str));/* a stab value, be nice */
str = tmpstr;
tmps = str->str_ptr;
{
STIO *stio;
+ laststype = O_STAT;
if (arg[1].arg_type & A_DONT) {
stio = stab_io(arg[1].arg_ptr.arg_stab);
if (stio && stio->ifp) {
ARG *arg;
STR *str;
{
- if (arg[1].arg_type & A_DONT)
- fatal("You must supply explicit filename with -l");
+ if (arg[1].arg_type & A_DONT) {
+ if (arg[1].arg_ptr.arg_stab == defstab) {
+ if (laststype != O_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));
-#ifdef LSTAT
+#ifdef HAS_LSTAT
return (laststatval = lstat(str_get(str),&statcache));
#else
return (laststatval = stat(str_get(str),&statcache));
return &str_undef;
fstat(i,&statcache);
len = read(i,tbuf,512);
+ (void)close(i);
if (len <= 0) /* null file is anything */
return &str_yes;
- (void)close(i);
s = tbuf;
}
static char **Argv = Null(char **);
static char *Cmd = Nullch;
-int
+void
do_execfree()
{
if (Argv) {
return FALSE;
}
-#ifdef SOCKET
+#ifdef HAS_SOCKET
int
do_socket(stab, arglast)
STAB *stab;
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;
}
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;
optname = (int)str_gnum(st[sp+2]);
switch (optype) {
case O_GSOCKOPT:
- st[sp] = str_2static(str_new(257));
+ st[sp] = str_2mortal(str_new(257));
st[sp]->str_cur = 256;
st[sp]->str_pok = 1;
if (getsockopt(fd, lvl, optname, st[sp]->str_ptr, &st[sp]->str_cur) < 0)
if (!stio || !stio->ifp)
goto nuts;
- st[sp] = str_2static(str_new(257));
+ st[sp] = str_2mortal(str_new(257));
st[sp]->str_cur = 256;
st[sp]->str_pok = 1;
fd = fileno(stio->ifp);
register STR *str;
struct hostent *gethostbyname();
struct hostent *gethostbyaddr();
-#ifdef GETHOSTENT
+#ifdef HAS_GETHOSTENT
struct hostent *gethostent();
#endif
struct hostent *hent;
unsigned long len;
if (gimme != G_ARRAY) {
- astore(ary, ++sp, str_static(&str_undef));
+ astore(ary, ++sp, str_mortal(&str_undef));
return sp;
}
hent = gethostbyaddr(addr,addrstr->str_cur,addrtype);
}
else
-#ifdef GETHOSTENT
+#ifdef HAS_GETHOSTENT
hent = gethostent();
#else
fatal("gethostent not implemented");
#endif
if (hent) {
#ifndef lint
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, hent->h_name);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (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_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_numset(str, (double)hent->h_addrtype);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (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_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_nset(str, *elem, len);
}
#else
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (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_static(&str_no));
+ (void)astore(ary, ++sp, str_mortal(&str_no));
#endif /* lint */
}
struct netent *nent;
if (gimme != G_ARRAY) {
- astore(ary, ++sp, str_static(&str_undef));
+ astore(ary, ++sp, str_mortal(&str_undef));
return sp;
}
nent = getnetbyname(name);
}
else if (which == O_GNBYADDR) {
- STR *addrstr = ary->ary_array[sp+1];
+ unsigned long addr = U_L(str_gnum(ary->ary_array[sp+1]));
int addrtype = (int)str_gnum(ary->ary_array[sp+2]);
- char *addr = str_get(addrstr);
- nent = getnetbyaddr(addr,addrtype);
+ nent = getnetbyaddr((long)addr,addrtype);
}
else
nent = getnetent();
if (nent) {
#ifndef lint
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, nent->n_name);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (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_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_numset(str, (double)nent->n_addrtype);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (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_static(&str_no));
+ (void)astore(ary, ++sp, str_mortal(&str_no));
#endif /* lint */
}
struct protoent *pent;
if (gimme != G_ARRAY) {
- astore(ary, ++sp, str_static(&str_undef));
+ astore(ary, ++sp, str_mortal(&str_undef));
return sp;
}
if (pent) {
#ifndef lint
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, pent->p_name);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (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_static(&str_no));
+ (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_static(&str_no));
+ (void)astore(ary, ++sp, str_mortal(&str_no));
#endif /* lint */
}
struct servent *sent;
if (gimme != G_ARRAY) {
- astore(ary, ++sp, str_static(&str_undef));
+ astore(ary, ++sp, str_mortal(&str_undef));
return sp;
}
sent = getservent();
if (sent) {
#ifndef lint
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, sent->s_name);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (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_static(&str_no));
-#ifdef NTOHS
+ (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_static(&str_no));
+ (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_static(&str_no));
+ (void)astore(ary, ++sp, str_mortal(&str_no));
#endif /* lint */
}
return sp;
}
-#endif /* SOCKET */
+#endif /* HAS_SOCKET */
-#ifdef SELECT
+#ifdef HAS_SELECT
int
do_select(gimme,arglast)
int gimme;
}
#endif
- st[++sp] = str_static(&str_no);
+ 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_static(&str_no);
+ st[++sp] = str_mortal(&str_no);
str_numset(st[sp], value);
}
return sp;
}
#endif /* SELECT */
-#ifdef SOCKET
+#ifdef HAS_SOCKET
int
do_spair(stab1, stab2, arglast)
STAB *stab1;
#ifdef TAINT
taintproper("Insecure dependency in socketpair");
#endif
-#ifdef SOCKETPAIR
+#ifdef HAS_SOCKETPAIR
if (socketpair(domain,type,protocol,fd) < 0)
return FALSE;
#else
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 /* SOCKET */
+#endif /* HAS_SOCKET */
int
do_gpwent(which,gimme,arglast)
struct passwd *pwent;
if (gimme != G_ARRAY) {
- astore(ary, ++sp, str_static(&str_undef));
+ astore(ary, ++sp, str_mortal(&str_undef));
return sp;
}
pwent = getpwent();
if (pwent) {
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, pwent->pw_name);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, pwent->pw_passwd);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_numset(str, (double)pwent->pw_uid);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_numset(str, (double)pwent->pw_gid);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
#ifdef PWCHANGE
str_numset(str, (double)pwent->pw_change);
#else
#endif
#endif
#endif
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
#ifdef PWCLASS
str_set(str,pwent->pw_class);
#else
str_set(str, pwent->pw_comment);
#endif
#endif
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, pwent->pw_gecos);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, pwent->pw_dir);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, pwent->pw_shell);
#ifdef PWEXPIRE
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_numset(str, (double)pwent->pw_expire);
#endif
}
struct group *grent;
if (gimme != G_ARRAY) {
- astore(ary, ++sp, str_static(&str_undef));
+ astore(ary, ++sp, str_mortal(&str_undef));
return sp;
}
grent = getgrent();
if (grent) {
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, grent->gr_name);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_set(str, grent->gr_passwd);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_numset(str, (double)grent->gr_gid);
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
for (elem = grent->gr_mem; *elem; elem++) {
str_cat(str, *elem);
if (elem[1])
int gimme;
int *arglast;
{
-#if defined(DIRENT) && defined(READDIR)
+#if defined(DIRENT) && defined(HAS_READDIR)
register ARRAY *ary = stack;
register STR **st = ary->ary_array;
register int sp = arglast[1];
while (dp = readdir(stio->dirp)) {
#ifdef DIRNAMLEN
(void)astore(ary,++sp,
- str_2static(str_make(dp->d_name,dp->d_namlen)));
+ str_2mortal(str_make(dp->d_name,dp->d_namlen)));
#else
(void)astore(ary,++sp,
- str_2static(str_make(dp->d_name,0)));
+ str_2mortal(str_make(dp->d_name,0)));
#endif
}
}
else {
if (!(dp = readdir(stio->dirp)))
goto nope;
- st[sp] = str_static(&str_undef);
+ st[sp] = str_mortal(&str_undef);
#ifdef DIRNAMLEN
str_nset(st[sp], dp->d_name, dp->d_namlen);
#else
goto nope;
#else
case O_TELLDIR:
- st[sp] = str_static(&str_undef);
+ st[sp] = str_mortal(&str_undef);
str_numset(st[sp], (double)telldir(stio->dirp));
break;
case O_SEEKDIR:
- st[sp] = str_static(&str_undef);
+ st[sp] = str_mortal(&str_undef);
along = (long)str_gnum(st[sp+1]);
(void)seekdir(stio->dirp,along);
break;
#endif
case O_REWINDDIR:
- st[sp] = str_static(&str_undef);
+ st[sp] = str_mortal(&str_undef);
(void)rewinddir(stio->dirp);
break;
case O_CLOSEDIR:
- st[sp] = str_static(&str_undef);
+ st[sp] = str_mortal(&str_undef);
(void)closedir(stio->dirp);
stio->dirp = 0;
break;
}
}
break;
-#ifdef CHOWN
+#ifdef HAS_CHOWN
case O_CHOWN:
#ifdef TAINT
taintproper("Insecure dependency in chown");
}
break;
#endif
-#ifdef KILL
+#ifdef HAS_KILL
case O_KILL:
#ifdef TAINT
taintproper("Insecure dependency in kill");
val = -val;
while (items--) {
int proc = (int)str_gnum(st[++sp]);
-#ifdef KILLPG
+#ifdef HAS_KILLPG
if (killpg(proc,val)) /* BSD */
#else
if (kill(-proc,val)) /* SYSV */
tot--;
}
else { /* don't let root wipe out directories without -U */
-#ifdef LSTAT
+#ifdef HAS_LSTAT
if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
#else
if (stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
int effective;
register struct stat *statbufp;
{
+#ifdef MSDOS
+ /* [Comments and code from Len Reed]
+ * MS-DOS "user" is similar to UNIX's "superuser," but can't write
+ * to write-protected files. The execute permission bit is set
+ * by the Miscrosoft C library stat() function for the following:
+ * .exe files
+ * .com files
+ * .bat files
+ * directories
+ * All files and directories are readable.
+ * Directories and special files, e.g. "CON", cannot be
+ * write-protected.
+ * [Comment by Tom Dinger -- a directory can have the write-protect
+ * bit set in the file system, but DOS permits changes to
+ * the directory anyway. In addition, all bets are off
+ * here for networked software, such as Novell and
+ * Sun's PC-NFS.]
+ */
+
+ return (bit & statbufp->st_mode) ? TRUE : FALSE;
+
+#else /* ! MSDOS */
if ((effective ? euid : uid) == 0) { /* root is special */
if (bit == S_IXUSR) {
if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
else if (statbufp->st_mode & bit >> 6)
return TRUE; /* ok as "other" */
return FALSE;
+#endif /* ! MSDOS */
}
int
{
if (testgid == (effective ? egid : gid))
return TRUE;
-#ifdef GETGROUPS
+#ifdef HAS_GETGROUPS
#ifndef NGROUPS
#define NGROUPS 32
#endif
return FALSE;
}
-#ifdef SYSVIPC
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
int
do_ipcget(optype, arglast)
errno = 0;
switch (optype)
{
-#ifdef IPCMSG
+#ifdef HAS_MSG
case O_MSGGET:
return msgget(key, flags);
#endif
-#ifdef IPCSEM
+#ifdef HAS_SEM
case O_SEMGET:
return semget(key, n, flags);
#endif
-#ifdef IPCSHM
+#ifdef HAS_SHM
case O_SHMGET:
return shmget(key, n, flags);
#endif
-#if !defined(IPCMSG) || !defined(IPCSEM) || !defined(IPCSHM)
+#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
default:
fatal("%s not implemented", opname[optype]);
#endif
switch (optype)
{
-#ifdef IPCMSG
+#ifdef HAS_MSG
case O_MSGCTL:
if (cmd == IPC_STAT || cmd == IPC_SET)
infosize = sizeof(struct msqid_ds);
break;
#endif
-#ifdef IPCSHM
+#ifdef HAS_SHM
case O_SHMCTL:
if (cmd == IPC_STAT || cmd == IPC_SET)
infosize = sizeof(struct shmid_ds);
break;
#endif
-#ifdef IPCSEM
+#ifdef HAS_SEM
case O_SEMCTL:
if (cmd == IPC_STAT || cmd == IPC_SET)
infosize = sizeof(struct semid_ds);
if (semctl(id, 0, IPC_STAT, &semds) == -1)
return -1;
getinfo = (cmd == GETALL);
+#ifdef _POSIX_SOURCE
+ infosize = semds.sem_nsems * sizeof(ushort_t);
+#else
infosize = semds.sem_nsems * sizeof(ushort);
+#endif
}
break;
#endif
-#if !defined(IPCMSG) || !defined(IPCSEM) || !defined(IPCSHM)
+#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
default:
fatal("%s not implemented", opname[optype]);
#endif
errno = 0;
switch (optype)
{
-#ifdef IPCMSG
+#ifdef HAS_MSG
case O_MSGCTL:
ret = msgctl(id, cmd, a);
break;
#endif
-#ifdef IPCSEM
+#ifdef HAS_SEM
case O_SEMCTL:
ret = semctl(id, n, cmd, a);
break;
#endif
-#ifdef IPCSHM
+#ifdef HAS_SHM
case O_SHMCTL:
ret = shmctl(id, cmd, a);
break;
do_msgsnd(arglast)
int *arglast;
{
-#ifdef IPCMSG
+#ifdef HAS_MSG
register STR **st = stack->ary_array;
register int sp = arglast[0];
STR *mstr;
do_msgrcv(arglast)
int *arglast;
{
-#ifdef IPCMSG
+#ifdef HAS_MSG
register STR **st = stack->ary_array;
register int sp = arglast[0];
STR *mstr;
do_semop(arglast)
int *arglast;
{
-#ifdef IPCSEM
+#ifdef HAS_SEM
register STR **st = stack->ary_array;
register int sp = arglast[0];
STR *opstr;
int optype;
int *arglast;
{
-#ifdef IPCSHM
+#ifdef HAS_SHM
register STR **st = stack->ary_array;
register int sp = arglast[0];
STR *mstr;
#endif
}
-#endif /* SYSVIPC */
+#endif /* SYSV IPC */
-/* $Header: dolist.c,v 3.0.1.12 91/01/11 17:54:58 lwall Locked $
+/* $Header: dolist.c,v 4.0 91/03/20 01:08:03 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: dolist.c,v $
- * Revision 3.0.1.12 91/01/11 17:54:58 lwall
- * patch42: added binary and hex pack/unpack options
- * patch42: sort subroutines didn't allow copying $a or $b to other variables.
- * patch42: caller() coredumped when called outside the debugger.
- *
- * Revision 3.0.1.11 90/11/10 01:29:49 lwall
- * patch38: temp string values are now copied less often
- * patch38: sort parameters are now in the right package
- *
- * Revision 3.0.1.10 90/10/15 16:19:48 lwall
- * patch29: added caller
- * patch29: added scalar reverse
- * patch29: sort undefined_subroutine @array is now a fatal error
- *
- * Revision 3.0.1.9 90/08/13 22:15:35 lwall
- * patch28: defined(@array) and defined(%array) didn't work right
- *
- * Revision 3.0.1.8 90/08/09 03:15:56 lwall
- * patch19: certain kinds of matching cause "panic: hint"
- * patch19: $' broke on embedded nulls
- * patch19: split on /\s+/, /^/ and ' ' is now special cased for speed
- * patch19: split on /x/i didn't work
- * patch19: couldn't unpack an 'A' or 'a' field in a scalar context
- * patch19: unpack called bcopy on each character of a C/c field
- * patch19: pack/unpack know about uudecode lines
- * patch19: fixed sort on undefined strings and sped up slightly
- * patch19: each and keys returned garbage on null key in DBM file
- *
- * Revision 3.0.1.7 90/03/27 15:48:42 lwall
- * patch16: MSDOS support
- * patch16: use of $`, $& or $' sometimes causes memory leakage
- * patch16: splice(@array,0,$n) case cause duplicate free
- * patch16: grep blows up on undefined array values
- * patch16: .. now works using magical string increment
- *
- * Revision 3.0.1.6 90/03/12 16:33:02 lwall
- * patch13: added list slice operator (LIST)[LIST]
- * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST)
- * patch13: made split('') act like split(//) rather than split(' ')
- *
- * Revision 3.0.1.5 90/02/28 17:09:44 lwall
- * patch9: split now can split into more than 10000 elements
- * patch9: @_ clobbered by ($foo,$bar) = split
- * patch9: sped up pack and unpack
- * patch9: unpack of single item now works in a scalar context
- * patch9: slices ignored value of $[
- * patch9: grep now returns number of items matched in scalar context
- * patch9: grep iterations no longer in the regexp context of previous iteration
- *
- * Revision 3.0.1.4 89/12/21 19:58:46 lwall
- * patch7: grep(1,@array) didn't work
- * patch7: /$pat/; //; wrongly freed runtime pattern twice
- *
- * Revision 3.0.1.3 89/11/17 15:14:45 lwall
- * patch5: grep() occasionally loses arguments or dumps core
- *
- * Revision 3.0.1.2 89/11/11 04:28:17 lwall
- * patch2: non-existent slice values are now undefined rather than null
- *
- * Revision 3.0.1.1 89/10/26 23:11:51 lwall
- * patch1: split in a subroutine wrongly freed referenced arguments
- * patch1: reverse didn't work
- *
- * Revision 3.0 89/10/18 15:11:02 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:08:03 lwall
+ * 4.0 baseline.
*
*/
if (debug & 8)
deb("2.SPAT /%s/\n",t);
#endif
- if (spat->spat_regexp)
+ if (spat->spat_regexp) {
regfree(spat->spat_regexp);
+ 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->precomp && lastspat)
}
for (i = 1; i <= iters; i++) {
- st[++sp] = str_static(&str_no);
+ st[++sp] = str_mortal(&str_no);
if (s = spat->spat_regexp->startp[i]) {
len = spat->spat_regexp->endp[i] - s;
if (len > 0)
m = dstr->str_ptr;
spat->spat_flags |= SPAT_SKIPWHITE;
}
- if (spat->spat_regexp)
+ 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 ||
ary = stack;
orig = s;
if (spat->spat_flags & SPAT_SKIPWHITE) {
- while (isspace(*s))
+ while (isascii(*s) && isspace(*s))
s++;
}
if (!limit)
limit = maxiters + 2;
if (strEQ("\\s+",spat->spat_regexp->precomp)) {
while (--limit) {
- for (m = s; m < strend && !isspace(*m); m++) ;
+ for (m = s; m < strend && !(isascii(*m)&&isspace(*m)); m++) ;
if (m >= strend)
break;
dstr = Str_new(30,m-s);
str_nset(dstr,s,m-s);
if (!realarray)
- str_2static(dstr);
+ str_2mortal(dstr);
(void)astore(ary, ++sp, dstr);
- for (s = m + 1; s < strend && isspace(*s); s++) ;
+ for (s = m + 1; s < strend && isascii(*s) && isspace(*s); s++) ;
}
}
else if (strEQ("^",spat->spat_regexp->precomp)) {
dstr = Str_new(30,m-s);
str_nset(dstr,s,m-s);
if (!realarray)
- str_2static(dstr);
+ str_2mortal(dstr);
(void)astore(ary, ++sp, dstr);
s = m;
}
dstr = Str_new(30,m-s);
str_nset(dstr,s,m-s);
if (!realarray)
- str_2static(dstr);
+ str_2mortal(dstr);
(void)astore(ary, ++sp, dstr);
s = m + 1;
}
dstr = Str_new(31,m-s);
str_nset(dstr,s,m-s);
if (!realarray)
- str_2static(dstr);
+ str_2mortal(dstr);
(void)astore(ary, ++sp, dstr);
s = m + i;
}
dstr = Str_new(32,m-s);
str_nset(dstr,s,m-s);
if (!realarray)
- str_2static(dstr);
+ str_2mortal(dstr);
(void)astore(ary, ++sp, dstr);
if (spat->spat_regexp->nparens) {
for (i = 1; i <= spat->spat_regexp->nparens; i++) {
dstr = Str_new(33,m-s);
str_nset(dstr,s,m-s);
if (!realarray)
- str_2static(dstr);
+ str_2mortal(dstr);
(void)astore(ary, ++sp, dstr);
}
}
dstr = Str_new(34,strend-s);
str_nset(dstr,s,strend-s);
if (!realarray)
- str_2static(dstr);
+ str_2mortal(dstr);
(void)astore(ary, ++sp, dstr);
iters++;
}
int datumtype;
register int len;
register int bits;
- static char hexchar[] = "0123456789abcdef";
/* These must not be in registers: */
short ashort;
if (datumtype == 'A') {
aptr = s; /* borrow register */
s = str->str_ptr + len - 1;
- while (s >= str->str_ptr && (!*s || isspace(*s)))
+ while (s >= str->str_ptr && (!*s || (isascii(*s)&&isspace(*s))))
s--;
*++s = '\0';
str->str_cur = s - str->str_ptr;
s = aptr; /* unborrow register */
}
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
break;
case 'B':
case 'b':
}
*pat = '\0';
pat = aptr; /* unborrow register */
- (void)astore(stack, ++sp, str_2static(str));
+ (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);
+ str = Str_new(35, len + 1);
str->str_cur = len;
str->str_pok = 1;
aptr = pat; /* borrow register */
bits >>= 4;
else
bits = *s++;
- *pat++ = hexchar[bits & 15];
+ *pat++ = hexdigit[bits & 15];
}
}
else {
bits <<= 4;
else
bits = *s++;
- *pat++ = hexchar[(bits >> 4) & 15];
+ *pat++ = hexdigit[(bits >> 4) & 15];
}
}
*pat = '\0';
pat = aptr; /* unborrow register */
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
break;
case 'c':
if (len > strend - s)
aint -= 256;
str = Str_new(36,0);
str_numset(str,(double)aint);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
auint = *s++ & 255;
str = Str_new(37,0);
str_numset(str,(double)auint);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
s += sizeof(short);
str = Str_new(38,0);
str_numset(str,(double)ashort);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
while (len-- > 0) {
bcopy(s,(char*)&aushort,sizeof(unsigned short));
s += sizeof(unsigned short);
-#ifdef NTOHS
+#ifdef HAS_NTOHS
if (datumtype == 'n')
aushort = ntohs(aushort);
#endif
bcopy(s,(char*)&aushort,sizeof(unsigned short));
s += sizeof(unsigned short);
str = Str_new(39,0);
-#ifdef NTOHS
+#ifdef HAS_NTOHS
if (datumtype == 'n')
aushort = ntohs(aushort);
#endif
str_numset(str,(double)aushort);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
s += sizeof(int);
str = Str_new(40,0);
str_numset(str,(double)aint);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
s += sizeof(unsigned int);
str = Str_new(41,0);
str_numset(str,(double)auint);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
s += sizeof(long);
str = Str_new(42,0);
str_numset(str,(double)along);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
while (len-- > 0) {
bcopy(s,(char*)&aulong,sizeof(unsigned long));
s += sizeof(unsigned long);
-#ifdef NTOHL
+#ifdef HAS_NTOHL
if (datumtype == 'N')
aulong = ntohl(aulong);
#endif
bcopy(s,(char*)&aulong,sizeof(unsigned long));
s += sizeof(unsigned long);
str = Str_new(43,0);
-#ifdef NTOHL
+#ifdef HAS_NTOHL
if (datumtype == 'N')
aulong = ntohl(aulong);
#endif
str_numset(str,(double)aulong);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
str = Str_new(44,0);
if (aptr)
str_set(str,aptr);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
break;
/* float and double added gnb@melba.bby.oz.au 22/11/89 */
s += sizeof(float);
str = Str_new(47, 0);
str_numset(str, (double)afloat);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
s += sizeof(double);
str = Str_new(48, 0);
str_numset(str, (double)adouble);
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
}
}
break;
else if (s[1] == '\n') /* possible checksum byte */
s += 2;
}
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
break;
}
if (checksum) {
str_numset(str,cdouble);
}
else {
- along = (1 << checksum) - 1;
- culong &= (unsigned long)along;
+ if (checksum < 32) {
+ along = (1 << checksum) - 1;
+ culong &= (unsigned long)along;
+ }
str_numset(str,(double)culong);
}
- (void)astore(stack, ++sp, str_2static(str));
+ (void)astore(stack, ++sp, str_2mortal(str));
checksum = 0;
}
}
Copy(ary->ary_array+offset, st+sp, length, STR*);
if (ary->ary_flags & ARF_REAL) {
for (i = length, dst = st+sp; i; i--)
- str_2static(*dst++); /* free them eventualy */
+ 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_2static(st[sp]);
+ str_2mortal(st[sp]);
}
ary->ary_fill += diff;
Copy(tmparyval, st+sp, length, STR*);
if (ary->ary_flags & ARF_REAL) {
for (i = length, dst = st+sp; i; i--)
- str_2static(*dst++); /* free them eventualy */
+ str_2mortal(*dst++); /* free them eventualy */
}
Safefree(tmparyval);
}
else if (length) {
st[sp] = tmparyval[length-1];
if (ary->ary_flags & ARF_REAL)
- str_2static(st[sp]);
+ str_2mortal(st[sp]);
Safefree(tmparyval);
}
else
if (st[src])
stab_val(defstab) = st[src];
else
- stab_val(defstab) = str_static(&str_undef);
+ stab_val(defstab) = str_mortal(&str_undef);
(void)eval(arg,G_SCALAR,sp);
st = stack->ary_array;
if (str_true(st[sp+1]))
if (gimme != G_ARRAY)
fatal("panic: do_range");
- if (st[sp+1]->str_nok ||
+ 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]);
while (i <= max) {
- (void)astore(ary, ++sp, str = str_static(&str_no));
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
str_numset(str,(double)i++);
}
}
else {
- STR *final = str_static(st[sp+2]);
+ STR *final = str_mortal(st[sp+2]);
char *tmps = str_get(final);
- str = str_static(st[sp+1]);
+ 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_2static(str_smake(str));
+ str = str_2mortal(str_smake(str));
str_inc(str);
}
if (strEQ(str->str_ptr,tmps))
}
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 ARRAY *ary = stack;
+ 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;
#ifndef lint
(void)astore(stack,++sp,
- str_2static(str_make(csv->curcmd->c_stash->tbl_name,0)) );
+ str_2mortal(str_make(csv->curcmd->c_stash->tbl_name,0)) );
(void)astore(stack,++sp,
- str_2static(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) );
+ str_2mortal(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) );
(void)astore(stack,++sp,
- str_2static(str_nmake((double)csv->curcmd->c_line)) );
+ str_2mortal(str_nmake((double)csv->curcmd->c_line)) );
if (!maxarg)
return sp;
str = Str_new(49,0);
stab_fullname(str, csv->stab);
- (void)astore(stack,++sp, str_2static(str));
+ (void)astore(stack,++sp, str_2mortal(str));
(void)astore(stack,++sp,
- str_2static(str_nmake((double)csv->hasargs)) );
+ str_2mortal(str_nmake((double)csv->hasargs)) );
(void)astore(stack,++sp,
- str_2static(str_nmake((double)csv->wantarray)) );
+ str_2mortal(str_nmake((double)csv->wantarray)) );
if (csv->hasargs) {
ARRAY *ary = csv->argarray;
}
#else
(void)astore(stack,++sp,
- str_2static(str_make("",0)));
+ str_2mortal(str_make("",0)));
#endif
return sp;
}
#ifndef lint
(void)astore(stack,++sp,
- str_2static(str_nmake(((double)timesbuf.tms_utime)/HZ)));
+ str_2mortal(str_nmake(((double)timesbuf.tms_utime)/HZ)));
(void)astore(stack,++sp,
- str_2static(str_nmake(((double)timesbuf.tms_stime)/HZ)));
+ str_2mortal(str_nmake(((double)timesbuf.tms_stime)/HZ)));
(void)astore(stack,++sp,
- str_2static(str_nmake(((double)timesbuf.tms_cutime)/HZ)));
+ str_2mortal(str_nmake(((double)timesbuf.tms_cutime)/HZ)));
(void)astore(stack,++sp,
- str_2static(str_nmake(((double)timesbuf.tms_cstime)/HZ)));
+ str_2mortal(str_nmake(((double)timesbuf.tms_cstime)/HZ)));
#else
(void)astore(stack,++sp,
- str_2static(str_nmake(0.0)));
+ str_2mortal(str_nmake(0.0)));
#endif
return sp;
#endif
st[++sp] = str;
return sp;
}
- (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_sec)));
- (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_min)));
- (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_hour)));
- (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_mday)));
- (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_mon)));
- (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_year)));
- (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_wday)));
- (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_yday)));
- (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_isdst)));
+ (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;
}
tmps = hiterkey(entry,&i);
if (!i)
tmps = "";
- (void)astore(ary,++sp,str_2static(str_make(tmps,i)));
+ (void)astore(ary,++sp,str_2mortal(str_make(tmps,i)));
}
if (dovalues) {
tmpstr = Str_new(45,0);
else
#endif
str_sset(tmpstr,hiterval(hash,entry));
- (void)astore(ary,++sp,str_2static(tmpstr));
+ (void)astore(ary,++sp,str_2mortal(tmpstr));
}
}
return sp;
-/* $Header: dump.c,v 3.0.1.2 90/10/15 16:22:10 lwall Locked $
+/* $Header: dump.c,v 4.0 91/03/20 01:08:25 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: dump.c,v $
- * Revision 3.0.1.2 90/10/15 16:22:10 lwall
- * patch29: *foo now prints as *package'foo
- *
- * Revision 3.0.1.1 90/03/27 15:49:58 lwall
- * patch16: changed unsigned to unsigned int
- *
- * Revision 3.0 89/10/18 15:11:16 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:08:25 lwall
+ * 4.0 baseline.
*
*/
register int i;
register STAB *stab;
register HENT *entry;
- STR *str = str_static(&str_undef);
+ STR *str = str_mortal(&str_undef);
dump_cmd(main_root,Nullcmd);
for (i = 0; i <= 127; i++) {
}
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:
(void)strcat(b,"UP,");
if (flags & AF_COMMON)
(void)strcat(b,"COMMON,");
- if (flags & AF_UNUSED)
- (void)strcat(b,"UNUSED,");
+ if (flags & AF_DEPR)
+ (void)strcat(b,"DEPR,");
if (flags & AF_LISTISH)
(void)strcat(b,"LISTISH,");
if (flags & AF_LOCAL)
fprintf(stderr,"{}\n");
return;
}
- str = str_static(&str_undef);
+ str = str_mortal(&str_undef);
dumplvl++;
fprintf(stderr,"{\n");
stab_fullname(str,stab);
#!/usr/bin/perl
-# $Header: ADB,v 3.0 89/10/18 15:13:04 lwall Locked $
+# $Header: ADB,v 4.0 91/03/20 01:08:34 lwall Locked $
# This script is only useful when used in your crash directory.
#!/usr/bin/perl -P
-# $Header: changes,v 3.0 89/10/18 15:13:23 lwall Locked $
+# $Header: changes,v 4.0 91/03/20 01:08:56 lwall Locked $
($dir, $days) = @ARGV;
$dir = '/' if $dir eq '';
#!/usr/bin/perl
-# $Header: dus,v 3.0 89/10/18 15:13:43 lwall Locked $
+# $Header: dus,v 4.0 91/03/20 01:09:20 lwall Locked $
# This script does a du -s on any directories in the current directory that
# are not mount points for another filesystem.
#!/usr/bin/perl
-# $Header: findcp,v 3.0 89/10/18 15:13:47 lwall Locked $
+# $Header: findcp,v 4.0 91/03/20 01:09:37 lwall Locked $
# This is a wrapper around the find command that pretends find has a switch
# of the form -cp host:destination. It presumes your find implements -ls.
#!/usr/bin/perl
-# $Header: findtar,v 3.0 89/10/18 15:13:52 lwall Locked $
+# $Header: findtar,v 4.0 91/03/20 01:09:48 lwall Locked $
# findtar takes find-style arguments and spits out a tarfile on stdout.
# It won't work unless your find supports -ls and your tar the I flag.
#!/usr/bin/perl
-# $Header: gcp,v 3.0 89/10/18 15:13:59 lwall Locked $
+# $Header: gcp,v 4.0 91/03/20 01:10:05 lwall Locked $
# Here is a script to do global rcps. See man page.
-.\" $Header: gcp.man,v 3.0 89/10/18 15:14:09 lwall Locked $
+.\" $Header: gcp.man,v 4.0 91/03/20 01:10:13 lwall Locked $
.TH GCP 1C "13 May 1988"
.SH NAME
gcp \- global file copy
#!/usr/bin/perl
-# $Header: ged,v 3.0 89/10/18 15:14:22 lwall Locked $
+# $Header: ged,v 4.0 91/03/20 01:10:22 lwall Locked $
# Does inplace edits on a set of files on a set of machines.
#
#! /usr/bin/perl
-# $Header: gsh,v 3.0.1.2 90/03/12 16:34:11 lwall Locked $
+# $Header: gsh,v 4.0 91/03/20 01:10:40 lwall Locked $
# Do rsh globally--see man page
-.\" $Header: gsh.man,v 3.0 89/10/18 15:14:42 lwall Locked $
+.\" $Header: gsh.man,v 4.0 91/03/20 01:10:46 lwall Locked $
.TH GSH 8 "13 May 1988"
.SH NAME
gsh \- global shell
-.\" $Header: muck.man,v 3.0 89/10/18 15:14:55 lwall Locked $
+.\" $Header: muck.man,v 4.0 91/03/20 01:11:04 lwall Locked $
.TH MUCK 1 "10 Jan 1989"
.SH NAME
muck \- make usage checker
#!/usr/bin/perl
-# $Header: myrup,v 3.0 89/10/18 15:15:06 lwall Locked $
+# $Header: myrup,v 4.0 91/03/20 01:11:16 lwall Locked $
# This was a customization of ruptime requested by someone here who wanted
# to be able to find the least loaded machine easily. It uses the
eval "exec /usr/bin/perl -Spi.bak $0 $*"
if $running_under_some_shell;
-# $Header: nih,v 3.0 89/10/18 15:15:12 lwall Locked $
+# $Header: nih,v 4.0 91/03/20 01:11:29 lwall Locked $
# This script makes #! scripts directly executable on machines that don't
# support #!. It edits in place any scripts mentioned on the command line.
'di';
'ig00';
#
-# $Header: relink,v 3.0.1.2 90/08/09 03:17:44 lwall Locked $
+# $Header: relink,v 4.0 91/03/20 01:11:40 lwall Locked $
#
# $Log: relink,v $
+# Revision 4.0 91/03/20 01:11:40 lwall
+# 4.0 baseline.
+#
# Revision 3.0.1.2 90/08/09 03:17:44 lwall
# patch19: added man page for relink and rename
#
'di';
'ig00';
#
-# $Header: rename,v 3.0.1.2 90/08/09 03:17:57 lwall Locked $
+# $Header: rename,v 4.0 91/03/20 01:11:53 lwall Locked $
#
# $Log: rename,v $
+# Revision 4.0 91/03/20 01:11:53 lwall
+# 4.0 baseline.
+#
# Revision 3.0.1.2 90/08/09 03:17:57 lwall
# patch19: added man page for relink and rename
#
#!/usr/bin/perl -n
-# $Header: rmfrom,v 3.0 89/10/18 15:15:20 lwall Locked $
+# $Header: rmfrom,v 4.0 91/03/20 01:12:02 lwall Locked $
# A handy (but dangerous) script to put after a find ... -print.
#!/usr/bin/perl -P
-# $Header: scan_df,v 3.0 89/10/18 15:15:26 lwall Locked $
+# $Header: scan_df,v 4.0 91/03/20 01:12:28 lwall Locked $
# This report points out filesystems that are in danger of overflowing.
#!/usr/bin/perl -P
-# $Header: scan_last,v 3.0 89/10/18 15:15:31 lwall Locked $
+# $Header: scan_last,v 4.0 91/03/20 01:12:45 lwall Locked $
# This reports who was logged on at weird hours
#!/usr/bin/perl -P
-# $Header: scan_messages,v 3.0 89/10/18 15:15:38 lwall Locked $
+# $Header: scan_messages,v 4.0 91/03/20 01:13:01 lwall Locked $
# This prints out extraordinary console messages. You'll need to customize.
#!/usr/bin/perl
-# $Header: scan_passwd,v 3.0 89/10/18 15:15:43 lwall Locked $
+# $Header: scan_passwd,v 4.0 91/03/20 01:13:18 lwall Locked $
# This scans passwd file for security holes.
#!/usr/bin/perl -P
-# $Header: scan_ps,v 3.0 89/10/18 15:15:47 lwall Locked $
+# $Header: scan_ps,v 4.0 91/03/20 01:13:29 lwall Locked $
# This looks for looping processes.
#!/usr/bin/perl -P
-# $Header: scan_sudo,v 3.0 89/10/18 15:15:52 lwall Locked $
+# $Header: scan_sudo,v 4.0 91/03/20 01:13:44 lwall Locked $
# Analyze the sudo log.
#!/usr/bin/perl -P
-# $Header: scan_suid,v 3.0 89/10/18 15:15:57 lwall Locked $
+# $Header: scan_suid,v 4.0 91/03/20 01:14:00 lwall Locked $
# Look for new setuid root files.
#!/usr/bin/perl
-# $Header: scanner,v 3.0.1.1 90/03/12 16:35:15 lwall Locked $
+# $Header: scanner,v 4.0 91/03/20 01:14:11 lwall Locked $
# 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 3.0 89/10/18 15:16:09 lwall Locked $
+# $Header: shmkill,v 4.0 91/03/20 01:14:20 lwall Locked $
# A script to call from crontab periodically when people are leaving shared
# memory sitting around unattached.
#!/usr/bin/perl
-# $Header: empty,v 3.0 89/10/18 15:16:28 lwall Locked $
+# $Header: empty,v 4.0 91/03/20 01:15:25 lwall Locked $
# This script empties a trashcan.
#!/usr/bin/perl
-# $Header: unvanish,v 3.0 89/10/18 15:16:35 lwall Locked $
+# $Header: unvanish,v 4.0 91/03/20 01:15:38 lwall Locked $
sub it {
if ($olddir ne '.') {
#!/usr/bin/perl
-# $Header: vanexp,v 3.0 89/10/18 15:16:41 lwall Locked $
+# $Header: vanexp,v 4.0 91/03/20 01:15:54 lwall Locked $
# This is for running from a find at night to expire old .deleteds
#!/usr/bin/perl
-# $Header: vanish,v 3.0 89/10/18 15:16:46 lwall Locked $
+# $Header: vanish,v 4.0 91/03/20 01:16:05 lwall Locked $
sub it {
if ($olddir ne '.') {
--- /dev/null
+;; Perl code editing commands for GNU Emacs
+;; Copyright (C) 1990 William F. Mann
+;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the
+;; Free Software Foundation, under terms of its General Public License.
+
+;; This file may be made part of GNU Emacs at the option of the FSF, or
+;; of the perl distribution at the option of Larry Wall.
+
+;; This code is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY. No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing. Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; this code, but only under the conditions described in the
+;; GNU Emacs General Public License. A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities. It should be in a
+;; file named COPYING. Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode")
+;; to your .emacs file and change the first line of your perl script to:
+;; #!/usr/bin/perl -- # -*-Perl-*-
+;; With argments to perl:
+;; #!/usr/bin/perl -P- # -*-Perl-*-
+;; To handle files included with do 'filename.pl';, add something like
+;; (setq auto-mode-alist (append (list (cons "\\.pl$" 'perl-mode))
+;; auto-mode-alist))
+;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode.
+
+;; This code is based on the 18.53 version c-mode.el, with extensive
+;; rewriting. Most of the features of c-mode survived intact.
+
+;; I added a new feature which adds functionality to TAB; it is controlled
+;; by the variable perl-tab-to-comment. With it enabled, TAB does the
+;; first thing it can from the following list: change the indentation;
+;; move past leading white space; delete an empty comment; reindent a
+;; comment; move to end of line; create an empty comment; tell you that
+;; the line ends in a quoted string, or has a # which should be a \#.
+
+;; If your machine is slow, you may want to remove some of the bindings
+;; to electric-perl-terminator. I changed the indenting defaults to be
+;; what Larry Wall uses in perl/lib, but left in all the options.
+
+;; I also tuned a few things: comments and labels starting in column
+;; zero are left there by indent-perl-exp; perl-beginning-of-function
+;; goes back to the first open brace/paren in column zero, the open brace
+;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp
+;; (meta-^q) indents from the current line through the close of the next
+;; brace/paren, so you don't need to start exactly at a brace or paren.
+
+;; It may be good style to put a set of redundant braces around your
+;; main program. This will let you reindent it with meta-^q.
+
+;; Known problems (these are all caused by limitations in the elisp
+;; parsing routine (parse-partial-sexp), which was not designed for such
+;; a rich language; writing a more suitable parser would be a big job):
+;; 1) Regular expression delimitors do not act as quotes, so special
+;; characters such as `'"#:;[](){} may need to be backslashed
+;; in regular expressions and in both parts of s/// and tr///.
+;; 2) The globbing syntax <pattern> is not recognized, so special
+;; characters in the pattern string must be backslashed.
+;; 3) The q, qq, and << quoting operators are not recognized; see below.
+;; 4) \ (backslash) always quotes the next character, so '\' is
+;; treated as the start of a string. Use "\\" as a work-around.
+;; 5) To make variables such a $' and $#array work, perl-mode treats
+;; $ just like backslash, so '$' is the same as problem 5.
+;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an
+;; unmatched }. See below.
+;; 7) When ' (quote) is used as a package name separator, perl-mode
+;; doesn't understand, and thinks it is seeing a quoted string.
+
+;; Here are some ugly tricks to bypass some of these problems: the perl
+;; expression /`/ (that's a back-tick) usually evaluates harmlessly,
+;; but will trick perl-mode into starting a quoted string, which
+;; can be ended with another /`/. Assuming you have no embedded
+;; back-ticks, this can used to help solve problem 3:
+;;
+;; /`/; $ugly = q?"'$?; /`/;
+;;
+;; To solve problem 6, add a /{/; before each use of ${var}:
+;; /{/; while (<${glob_me}>) ...
+;;
+;; Problem 7 is even worse, but this 'fix' does work :-(
+;; $DB'stop#'
+;; [$DB'line#'
+;; ] =~ s/;9$//;
+
+
+(defvar perl-mode-abbrev-table nil
+ "Abbrev table in use in perl-mode buffers.")
+(define-abbrev-table 'perl-mode-abbrev-table ())
+
+(defvar perl-mode-map ()
+ "Keymap used in Perl mode.")
+(if perl-mode-map
+ ()
+ (setq perl-mode-map (make-sparse-keymap))
+ (define-key perl-mode-map "{" 'electric-perl-terminator)
+ (define-key perl-mode-map "}" 'electric-perl-terminator)
+ (define-key perl-mode-map ";" 'electric-perl-terminator)
+ (define-key perl-mode-map ":" 'electric-perl-terminator)
+ (define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function)
+ (define-key perl-mode-map "\e\C-e" 'perl-end-of-function)
+ (define-key perl-mode-map "\e\C-h" 'mark-perl-function)
+ (define-key perl-mode-map "\e\C-q" 'indent-perl-exp)
+ (define-key perl-mode-map "\177" 'backward-delete-char-untabify)
+ (define-key perl-mode-map "\t" 'perl-indent-command))
+
+(autoload 'c-macro-expand "cmacexp"
+ "Display the result of expanding all C macros occurring in the region.
+The expansion is entirely correct because it uses the C preprocessor."
+ t)
+
+(defvar perl-mode-syntax-table nil
+ "Syntax table in use in perl-mode buffers.")
+
+(if perl-mode-syntax-table
+ ()
+ (setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table)))
+ (modify-syntax-entry ?\n ">" perl-mode-syntax-table)
+ (modify-syntax-entry ?# "<" perl-mode-syntax-table)
+ (modify-syntax-entry ?$ "/" perl-mode-syntax-table)
+ (modify-syntax-entry ?% "." perl-mode-syntax-table)
+ (modify-syntax-entry ?& "." perl-mode-syntax-table)
+ (modify-syntax-entry ?\' "\"" perl-mode-syntax-table)
+ (modify-syntax-entry ?* "." perl-mode-syntax-table)
+ (modify-syntax-entry ?+ "." perl-mode-syntax-table)
+ (modify-syntax-entry ?- "." perl-mode-syntax-table)
+ (modify-syntax-entry ?/ "." perl-mode-syntax-table)
+ (modify-syntax-entry ?< "." perl-mode-syntax-table)
+ (modify-syntax-entry ?= "." perl-mode-syntax-table)
+ (modify-syntax-entry ?> "." perl-mode-syntax-table)
+ (modify-syntax-entry ?\\ "\\" perl-mode-syntax-table)
+ (modify-syntax-entry ?` "\"" perl-mode-syntax-table)
+ (modify-syntax-entry ?| "." perl-mode-syntax-table)
+)
+
+(defconst perl-indent-level 4
+ "*Indentation of Perl statements with respect to containing block.")
+(defconst perl-continued-statement-offset 4
+ "*Extra indent for lines not starting new statements.")
+(defconst perl-continued-brace-offset -4
+ "*Extra indent for substatements that start with open-braces.
+This is in addition to perl-continued-statement-offset.")
+(defconst perl-brace-offset 0
+ "*Extra indentation for braces, compared with other text in same context.")
+(defconst perl-brace-imaginary-offset 0
+ "*Imagined indentation of an open brace that actually follows a statement.")
+(defconst perl-label-offset -2
+ "*Offset of Perl label lines relative to usual indentation.")
+
+(defconst perl-tab-always-indent t
+ "*Non-nil means TAB in Perl mode should always indent the current line,
+regardless of where in the line point is when the TAB command is used.")
+
+(defconst perl-tab-to-comment t
+ "*Non-nil means that for lines which don't need indenting, TAB will
+either indent an existing comment, move to end-of-line, or if at end-of-line
+already, create a new comment.")
+
+(defconst perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:"
+ "*Lines starting with this regular expression will not be auto-indented.")
+\f
+(defun perl-mode ()
+ "Major mode for editing Perl code.
+Expression and list commands understand all Perl brackets.
+Tab indents for Perl code.
+Comments are delimited with # ... \\n.
+Paragraphs are separated by blank lines only.
+Delete converts tabs to spaces as it moves back.
+\\{perl-mode-map}
+Variables controlling indentation style:
+ perl-tab-always-indent
+ Non-nil means TAB in Perl mode should always indent the current line,
+ regardless of where in the line point is when the TAB command is used.
+ perl-tab-to-comment
+ Non-nil means that for lines which don't need indenting, TAB will
+ either delete an empty comment, indent an existing comment, move
+ to end-of-line, or if at end-of-line already, create a new comment.
+ perl-nochange
+ Lines starting with this regular expression will not be auto-indented.
+ perl-indent-level
+ Indentation of Perl statements within surrounding block.
+ The surrounding block's indentation is the indentation
+ of the line on which the open-brace appears.
+ perl-continued-statement-offset
+ Extra indentation given to a substatement, such as the
+ then-clause of an if or body of a while.
+ perl-continued-brace-offset
+ Extra indentation given to a brace that starts a substatement.
+ This is in addition to perl-continued-statement-offset.
+ perl-brace-offset
+ Extra indentation for line if it starts with an open brace.
+ perl-brace-imaginary-offset
+ An open brace following other text is treated as if it were
+ this far to the right of the start of its line.
+ perl-label-offset
+ Extra indentation for line that is a label.
+
+Various indentation styles: K&R BSD BLK GNU LW
+ perl-indent-level 5 8 0 2 4
+ perl-continued-statement-offset 5 8 4 2 4
+ perl-continued-brace-offset 0 0 0 0 -4
+ perl-brace-offset -5 -8 0 0 0
+ perl-brace-imaginary-offset 0 0 4 0 0
+ perl-label-offset -5 -8 -2 -2 -2
+
+Turning on Perl mode calls the value of the variable perl-mode-hook with no
+args, if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map perl-mode-map)
+ (setq major-mode 'perl-mode)
+ (setq mode-name "Perl")
+ (setq local-abbrev-table perl-mode-abbrev-table)
+ (set-syntax-table perl-mode-syntax-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'paragraph-ignore-fill-prefix)
+ (setq paragraph-ignore-fill-prefix t)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'perl-indent-line)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline t)
+ (make-local-variable 'comment-start)
+ (setq comment-start "# ")
+ (make-local-variable 'comment-end)
+ (setq comment-end "")
+ (make-local-variable 'comment-column)
+ (setq comment-column 32)
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *")
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'perl-comment-indent)
+ (make-local-variable 'parse-sexp-ignore-comments)
+ (setq parse-sexp-ignore-comments nil)
+ (run-hooks 'perl-mode-hook))
+\f
+;; This is used by indent-for-comment
+;; to decide how much to indent a comment in Perl code
+;; based on its context.
+(defun perl-comment-indent ()
+ (if (and (bolp) (not (eolp)))
+ 0 ;Existing comment at bol stays there.
+ (save-excursion
+ (skip-chars-backward " \t")
+ (max (1+ (current-column)) ;Else indent at comment column
+ comment-column)))) ; except leave at least one space.
+
+(defun electric-perl-terminator (arg)
+ "Insert character. If at end-of-line, and not in a comment or a quote,
+correct the line's indentation."
+ (interactive "P")
+ (let ((insertpos (point)))
+ (and (not arg) ; decide whether to indent
+ (eolp)
+ (save-excursion
+ (beginning-of-line)
+ (and (not ; eliminate comments quickly
+ (re-search-forward comment-start-skip insertpos t))
+ (or (/= last-command-char ?:)
+ ;; Colon is special only after a label ....
+ (looking-at "\\s-*\\(\\w\\|\\s_\\)+$"))
+ (let ((pps (parse-partial-sexp
+ (perl-beginning-of-function) insertpos)))
+ (not (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))
+ (progn ; must insert, indent, delete
+ (insert-char last-command-char 1)
+ (perl-indent-line)
+ (delete-char -1))))
+ (self-insert-command (prefix-numeric-value arg)))
+
+;; not used anymore, but may be useful someday:
+;;(defun perl-inside-parens-p ()
+;; (condition-case ()
+;; (save-excursion
+;; (save-restriction
+;; (narrow-to-region (point)
+;; (perl-beginning-of-function))
+;; (goto-char (point-max))
+;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\()))
+;; (error nil)))
+\f
+(defun perl-indent-command (&optional arg)
+ "Indent current line as Perl code, or optionally, insert a tab character.
+
+With an argument, indent the current line, regardless of other options.
+
+If perl-tab-always-indent is nil and point is not in the indentation
+area at the beginning of the line, simply insert a tab.
+
+Otherwise, indent the current line. If point was within the indentation
+area it is moved to the end of the indentation area. If the line was
+already indented properly and point was not within the indentation area,
+and if perl-tab-to-comment is non-nil (the default), then do the first
+possible action from the following list:
+
+ 1) delete an empty comment
+ 2) move forward to start of comment, indenting if necessary
+ 3) move forward to end of line
+ 4) create an empty comment
+ 5) move backward to start of comment, indenting if necessary."
+ (interactive "P")
+ (if arg ; If arg, just indent this line
+ (perl-indent-line "\f")
+ (if (and (not perl-tab-always-indent)
+ (<= (current-column) (current-indentation)))
+ (insert-tab)
+ (let (bof lsexp delta (oldpnt (point)))
+ (beginning-of-line)
+ (setq lsexp (point))
+ (setq bof (perl-beginning-of-function))
+ (goto-char oldpnt)
+ (setq delta (perl-indent-line "\f\\|;?#" bof))
+ (and perl-tab-to-comment
+ (= oldpnt (point)) ; done if point moved
+ (if (listp delta) ; if line starts in a quoted string
+ (setq lsexp (or (nth 2 delta) bof))
+ (= delta 0)) ; done if indenting occurred
+ (let (eol state)
+ (end-of-line)
+ (setq eol (point))
+ (if (= (char-after bof) ?=)
+ (if (= oldpnt eol)
+ (message "In a format statement"))
+ (setq state (parse-partial-sexp lsexp eol))
+ (if (nth 3 state)
+ (if (= oldpnt eol) ; already at eol in a string
+ (message "In a string which starts with a %c."
+ (nth 3 state)))
+ (if (not (nth 4 state))
+ (if (= oldpnt eol) ; no comment, create one?
+ (indent-for-comment))
+ (beginning-of-line)
+ (if (re-search-forward comment-start-skip eol 'move)
+ (if (eolp)
+ (progn ; kill existing comment
+ (goto-char (match-beginning 0))
+ (skip-chars-backward " \t")
+ (kill-region (point) eol))
+ (if (or (< oldpnt (point)) (= oldpnt eol))
+ (indent-for-comment) ; indent existing comment
+ (end-of-line)))
+ (if (/= oldpnt eol)
+ (end-of-line)
+ (message "Use backslash to quote # characters.")
+ (ding t))))))))))))
+
+(defun perl-indent-line (&optional nochange parse-start)
+ "Indent current line as Perl code. Return the amount the indentation
+changed by, or (parse-state) if line starts in a quoted string."
+ (let ((case-fold-search nil)
+ (pos (- (point-max) (point)))
+ (bof (or parse-start (save-excursion (perl-beginning-of-function))))
+ beg indent shift-amt)
+ (beginning-of-line)
+ (setq beg (point))
+ (setq shift-amt
+ (cond ((= (char-after bof) ?=) 0)
+ ((listp (setq indent (calculate-perl-indent bof))) indent)
+ ((looking-at (or nochange perl-nochange)) 0)
+ (t
+ (skip-chars-forward " \t\f")
+ (cond ((looking-at "\\(\\w\\|\\s_\\)+:")
+ (setq indent (max 1 (+ indent perl-label-offset))))
+ ((= (following-char) ?})
+ (setq indent (- indent perl-indent-level)))
+ ((= (following-char) ?{)
+ (setq indent (+ indent perl-brace-offset))))
+ (- indent (current-column)))))
+ (skip-chars-forward " \t\f")
+ (if (and (numberp shift-amt) (/= 0 shift-amt))
+ (progn (delete-region beg (point))
+ (indent-to indent)))
+ ;; If initial point was within line's indentation,
+ ;; position after the indentation. Else stay at same point in text.
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))
+ shift-amt))
+
+(defun calculate-perl-indent (&optional parse-start)
+ "Return appropriate indentation for current line as Perl code.
+In usual case returns an integer: the column to indent to.
+Returns (parse-state) if line starts inside a string."
+ (save-excursion
+ (beginning-of-line)
+ (let ((indent-point (point))
+ (case-fold-search nil)
+ (colon-line-end 0)
+ state containing-sexp)
+ (if parse-start ;used to avoid searching
+ (goto-char parse-start)
+ (perl-beginning-of-function))
+ (while (< (point) indent-point) ;repeat until right sexp
+ (setq parse-start (point))
+ (setq state (parse-partial-sexp (point) indent-point 0))
+; state = (depth_in_parens innermost_containing_list last_complete_sexp
+; string_terminator_or_nil inside_commentp following_quotep
+; minimum_paren-depth_this_scan)
+; Parsing stops if depth in parentheses becomes equal to third arg.
+ (setq containing-sexp (nth 1 state)))
+ (cond ((nth 3 state) state) ; In a quoted string?
+ ((null containing-sexp) ; Line is at top level.
+ (skip-chars-forward " \t\f")
+ (if (= (following-char) ?{)
+ 0 ; move to beginning of line if it starts a function body
+ ;; indent a little if this is a continuation line
+ (perl-backward-to-noncomment)
+ (if (or (bobp)
+ (memq (preceding-char) '(?\; ?\})))
+ 0 perl-continued-statement-offset)))
+ ((/= (char-after containing-sexp) ?{)
+ ;; line is expression, not statement:
+ ;; indent to just after the surrounding open.
+ (goto-char (1+ containing-sexp))
+ (current-column))
+ (t
+ ;; Statement level. Is it a continuation or a new statement?
+ ;; Find previous non-comment character.
+ (perl-backward-to-noncomment)
+ ;; Back up over label lines, since they don't
+ ;; affect whether our line is a continuation.
+ (while (or (eq (preceding-char) ?\,)
+ (and (eq (preceding-char) ?:)
+ (memq (char-syntax (char-after (- (point) 2)))
+ '(?w ?_))))
+ (if (eq (preceding-char) ?\,)
+ (perl-backward-to-start-of-continued-exp containing-sexp))
+ (beginning-of-line)
+ (perl-backward-to-noncomment))
+ ;; Now we get the answer.
+ (if (not (memq (preceding-char) '(?\; ?\} ?\{)))
+ ;; This line is continuation of preceding line's statement;
+ ;; indent perl-continued-statement-offset more than the
+ ;; previous line of the statement.
+ (progn
+ (perl-backward-to-start-of-continued-exp containing-sexp)
+ (+ perl-continued-statement-offset (current-column)
+ (if (save-excursion (goto-char indent-point)
+ (looking-at "[ \t]*{"))
+ perl-continued-brace-offset 0)))
+ ;; This line starts a new statement.
+ ;; Position at last unclosed open.
+ (goto-char containing-sexp)
+ (or
+ ;; If open paren is in col 0, close brace is special
+ (and (bolp)
+ (save-excursion (goto-char indent-point)
+ (looking-at "[ \t]*}"))
+ perl-indent-level)
+ ;; Is line first statement after an open-brace?
+ ;; If no, find that first statement and indent like it.
+ (save-excursion
+ (forward-char 1)
+ ;; Skip over comments and labels following openbrace.
+ (while (progn
+ (skip-chars-forward " \t\f\n")
+ (cond ((looking-at ";?#")
+ (forward-line 1) t)
+ ((looking-at "\\(\\w\\|\\s_\\)+:")
+ (save-excursion
+ (end-of-line)
+ (setq colon-line-end (point)))
+ (search-forward ":")))))
+ ;; The first following code counts
+ ;; if it is before the line we want to indent.
+ (and (< (point) indent-point)
+ (if (> colon-line-end (point))
+ (- (current-indentation) perl-label-offset)
+ (current-column))))
+ ;; If no previous statement,
+ ;; indent it relative to line brace is on.
+ ;; For open paren in column zero, don't let statement
+ ;; start there too. If perl-indent-level is zero,
+ ;; use perl-brace-offset + perl-continued-statement-offset
+ ;; For open-braces not the first thing in a line,
+ ;; add in perl-brace-imaginary-offset.
+ (+ (if (and (bolp) (zerop perl-indent-level))
+ (+ perl-brace-offset perl-continued-statement-offset)
+ perl-indent-level)
+ ;; Move back over whitespace before the openbrace.
+ ;; If openbrace is not first nonwhite thing on the line,
+ ;; add the perl-brace-imaginary-offset.
+ (progn (skip-chars-backward " \t")
+ (if (bolp) 0 perl-brace-imaginary-offset))
+ ;; If the openbrace is preceded by a parenthesized exp,
+ ;; move to the beginning of that;
+ ;; possibly a different line
+ (progn
+ (if (eq (preceding-char) ?\))
+ (forward-sexp -1))
+ ;; Get initial indentation of the line we are on.
+ (current-indentation))))))))))
+
+(defun perl-backward-to-noncomment ()
+ "Move point backward to after the first non-white-space, skipping comments."
+ (interactive)
+ (let (opoint stop)
+ (while (not stop)
+ (setq opoint (point))
+ (beginning-of-line)
+ (if (re-search-forward comment-start-skip opoint 'move 1)
+ (progn (goto-char (match-end 1))
+ (skip-chars-forward ";")))
+ (skip-chars-backward " \t\f")
+ (setq stop (or (bobp)
+ (not (bolp))
+ (forward-char -1))))))
+
+(defun perl-backward-to-start-of-continued-exp (lim)
+ (if (= (preceding-char) ?\))
+ (forward-sexp -1))
+ (beginning-of-line)
+ (if (<= (point) lim)
+ (goto-char (1+ lim)))
+ (skip-chars-forward " \t\f"))
+\f
+;; note: this may be slower than the c-mode version, but I can understand it.
+(defun indent-perl-exp ()
+ "Indent each line of the Perl grouping following point."
+ (interactive)
+ (let* ((case-fold-search nil)
+ (oldpnt (point-marker))
+ (bof-mark (save-excursion
+ (end-of-line 2)
+ (perl-beginning-of-function)
+ (point-marker)))
+ eol last-mark lsexp-mark delta)
+ (if (= (char-after (marker-position bof-mark)) ?=)
+ (message "Can't indent a format statement")
+ (message "Indenting Perl expression...")
+ (save-excursion (end-of-line) (setq eol (point)))
+ (save-excursion ; locate matching close paren
+ (while (and (not (eobp)) (<= (point) eol))
+ (parse-partial-sexp (point) (point-max) 0))
+ (setq last-mark (point-marker)))
+ (setq lsexp-mark bof-mark)
+ (beginning-of-line)
+ (while (< (point) (marker-position last-mark))
+ (setq delta (perl-indent-line nil (marker-position bof-mark)))
+ (if (numberp delta) ; unquoted start-of-line?
+ (progn
+ (if (eolp)
+ (delete-horizontal-space))
+ (setq lsexp-mark (point-marker))))
+ (end-of-line)
+ (setq eol (point))
+ (if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol))
+ (progn ; line ends in a comment
+ (beginning-of-line)
+ (if (or (not (looking-at "\\s-*;?#"))
+ (listp delta)
+ (and (/= 0 delta)
+ (= (- (current-indentation) delta) comment-column)))
+ (if (re-search-forward comment-start-skip eol t)
+ (indent-for-comment))))) ; indent existing comment
+ (forward-line 1))
+ (goto-char (marker-position oldpnt))
+ (message "Indenting Perl expression...done"))))
+\f
+(defun perl-beginning-of-function (&optional arg)
+ "Move backward to next beginning-of-function, or as far as possible.
+With argument, repeat that many times; negative args move forward.
+Returns new value of point in all cases."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (if (< arg 0) (forward-char 1))
+ (and (/= arg 0)
+ (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*="
+ nil 'move arg)
+ (goto-char (1- (match-end 0))))
+ (point))
+
+;; note: this routine is adapted directly from emacs lisp.el, end-of-defun;
+;; no bugs have been removed :-)
+(defun perl-end-of-function (&optional arg)
+ "Move forward to next end-of-function.
+The end of a function is found by moving forward from the beginning of one.
+With argument, repeat that many times; negative args move backward."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (let ((first t))
+ (while (and (> arg 0) (< (point) (point-max)))
+ (let ((pos (point)) npos)
+ (while (progn
+ (if (and first
+ (progn
+ (forward-char 1)
+ (perl-beginning-of-function 1)
+ (not (bobp))))
+ nil
+ (or (bobp) (forward-char -1))
+ (perl-beginning-of-function -1))
+ (setq first nil)
+ (forward-list 1)
+ (skip-chars-forward " \t")
+ (if (looking-at "[#\n]")
+ (forward-line 1))
+ (<= (point) pos))))
+ (setq arg (1- arg)))
+ (while (< arg 0)
+ (let ((pos (point)))
+ (perl-beginning-of-function 1)
+ (forward-sexp 1)
+ (forward-line 1)
+ (if (>= (point) pos)
+ (if (progn (perl-beginning-of-function 2) (not (bobp)))
+ (progn
+ (forward-list 1)
+ (skip-chars-forward " \t")
+ (if (looking-at "[#\n]")
+ (forward-line 1)))
+ (goto-char (point-min)))))
+ (setq arg (1+ arg)))))
+
+(defun mark-perl-function ()
+ "Put mark at end of Perl function, point at beginning."
+ (interactive)
+ (push-mark (point))
+ (perl-end-of-function)
+ (push-mark (point))
+ (perl-beginning-of-function)
+ (backward-paragraph))
+
+;;;;;;;; That's all, folks! ;;;;;;;;;
--- /dev/null
+;; Run perl -d under Emacs
+;; Based on gdb.el, as written by W. Schelter, and modified by rms.
+;; Modified for Perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990.
+
+;; This file is part of GNU Emacs.
+;; Copyright (C) 1988,1990 Free Software Foundation, Inc.
+
+;; GNU Emacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility
+;; to anyone for the consequences of using it or for whether it serves
+;; any particular purpose or works at all, unless he says so in writing.
+;; Refer to the GNU Emacs General Public License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute GNU
+;; Emacs, but only under the conditions described in the GNU Emacs
+;; General Public License. A copy of this license is supposed to have
+;; been given to you along with GNU Emacs so you can know your rights and
+;; responsibilities. It should be in a file named COPYING. Among other
+;; things, the copyright notice and this notice must be preserved on all
+;; copies.
+
+;; Description of perl -d interface:
+
+;; A facility is provided for the simultaneous display of the source code
+;; in one window, while using perldb to step through a function in the
+;; other. A small arrow in the source window, indicates the current
+;; line.
+
+;; Starting up:
+
+;; In order to use this facility, invoke the command PERLDB to obtain a
+;; shell window with the appropriate command bindings. You will be asked
+;; for the name of a file to run and additional command line arguments.
+;; Perldb will be invoked on this file, in a window named *perldb-foo*
+;; if the file is foo.
+
+;; M-s steps by one line, and redisplays the source file and line.
+
+;; You may easily create additional commands and bindings to interact
+;; with the display. For example to put the perl debugger command n on \M-n
+;; (def-perldb n "\M-n")
+
+;; This causes the emacs command perldb-next to be defined, and runs
+;; perldb-display-frame after the command.
+
+;; perldb-display-frame is the basic display function. It tries to display
+;; in the other window, the file and line corresponding to the current
+;; position in the perldb window. For example after a perldb-step, it would
+;; display the line corresponding to the position for the last step. Or
+;; if you have done a backtrace in the perldb buffer, and move the cursor
+;; into one of the frames, it would display the position corresponding to
+;; that frame.
+
+;; perldb-display-frame is invoked automatically when a filename-and-line-number
+;; appears in the output.
+
+
+(require 'shell)
+
+(defvar perldb-prompt-pattern "^ DB<[0-9]+> "
+ "A regexp to recognize the prompt for perldb.")
+
+(defvar perldb-mode-map nil
+ "Keymap for perldb-mode.")
+
+(if perldb-mode-map
+ nil
+ (setq perldb-mode-map (copy-keymap shell-mode-map))
+ (define-key perldb-mode-map "\C-l" 'perldb-refresh))
+
+(define-key ctl-x-map " " 'perldb-break)
+(define-key ctl-x-map "&" 'send-perldb-command)
+
+;;Of course you may use `def-perldb' with any other perldb command, including
+;;user defined ones.
+
+(defmacro def-perldb (name key &optional doc)
+ (let* ((fun (intern (concat "perldb-" name))))
+ (` (progn
+ (defun (, fun) (arg)
+ (, (or doc ""))
+ (interactive "p")
+ (perldb-call (if (not (= 1 arg))
+ (concat (, name) arg)
+ (, name))))
+ (define-key perldb-mode-map (, key) (quote (, fun)))))))
+
+(def-perldb "s" "\M-s" "Step one source line with display")
+(def-perldb "n" "\M-n" "Step one source line (skip functions)")
+(def-perldb "c" "\M-c" "Continue with display")
+(def-perldb "r" "\C-c\C-r" "Return from current subroutine")
+(def-perldb "A" "\C-c\C-a" "Delete all actions")
+\f
+(defun perldb-mode ()
+ "Major mode for interacting with an inferior Perl debugger process.
+The following commands are available:
+
+\\{perldb-mode-map}
+
+\\[perldb-display-frame] displays in the other window
+the last line referred to in the perldb buffer.
+
+\\[perldb-s],\\[perldb-n], and \\[perldb-n] in the perldb window,
+call perldb to step, next or continue and then update the other window
+with the current file and position.
+
+If you are in a source file, you may select a point to break
+at, by doing \\[perldb-break].
+
+Commands:
+Many commands are inherited from shell mode.
+Additionally we have:
+
+\\[perldb-display-frame] display frames file in other window
+\\[perldb-s] advance one line in program
+\\[perldb-n] advance one line in program (skip over calls).
+\\[send-perldb-command] used for special printing of an arg at the current point.
+C-x SPACE sets break point at current line."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'perldb-mode)
+ (setq mode-name "Inferior Perl")
+ (setq mode-line-process '(": %s"))
+ (use-local-map perldb-mode-map)
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
+ (make-local-variable 'perldb-last-frame)
+ (setq perldb-last-frame nil)
+ (make-local-variable 'perldb-last-frame-displayed-p)
+ (setq perldb-last-frame-displayed-p t)
+ (make-local-variable 'perldb-delete-prompt-marker)
+ (setq perldb-delete-prompt-marker nil)
+ (make-local-variable 'perldb-filter-accumulator)
+ (setq perldb-filter-accumulator nil)
+ (make-local-variable 'shell-prompt-pattern)
+ (setq shell-prompt-pattern perldb-prompt-pattern)
+ (run-hooks 'shell-mode-hook 'perldb-mode-hook))
+
+(defvar current-perldb-buffer nil)
+
+(defvar perldb-command-name "perl"
+ "Pathname for executing perl -d.")
+
+(defun end-of-quoted-arg (argstr start end)
+ (let* ((chr (substring argstr start (1+ start)))
+ (idx (string-match (concat "[^\\]" chr) argstr (1+ start))))
+ (and idx (1+ idx))
+ )
+)
+
+(defun parse-args-helper (arglist argstr start end)
+ (while (and (< start end) (string-match "[ \t\n\f\r\b]"
+ (substring argstr start (1+ start))))
+ (setq start (1+ start)))
+ (cond
+ ((= start end) arglist)
+ ((string-match "[\"']" (substring argstr start (1+ start)))
+ (let ((next (end-of-quoted-arg argstr start end)))
+ (parse-args-helper (cons (substring argstr (1+ start) next) arglist)
+ argstr (1+ next) end)))
+ (t (let ((next (string-match "[ \t\n\f\b\r]" argstr start)))
+ (if next
+ (parse-args-helper (cons (substring argstr start next) arglist)
+ argstr (1+ next) end)
+ (cons (substring argstr start) arglist))))
+ )
+ )
+
+(defun parse-args (args)
+ "Extract arguments from a string ARGS.
+White space separates arguments, with single or double quotes
+used to protect spaces. A list of strings is returned, e.g.,
+(parse-args \"foo bar 'two args'\") => (\"foo\" \"bar\" \"two args\")."
+ (nreverse (parse-args-helper '() args 0 (length args)))
+)
+
+(defun perldb (path args)
+ "Run perldb on program FILE in buffer *perldb-FILE*.
+The default directory for the current buffer becomes the initial
+working directory, by analogy with gdb . If you wish to change this, use
+the Perl command `chdir(DIR)'."
+ (interactive "FRun perl -d on file: \nsCommand line arguments: ")
+ (setq path (expand-file-name path))
+ (let ((file (file-name-nondirectory path))
+ (dir default-directory))
+ (switch-to-buffer (concat "*perldb-" file "*"))
+ (setq default-directory dir)
+ (or (bolp) (newline))
+ (insert "Current directory is " default-directory "\n")
+ (apply 'make-shell
+ (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs"
+ (parse-args args))
+ (perldb-mode)
+ (set-process-filter (get-buffer-process (current-buffer)) 'perldb-filter)
+ (set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel)
+ (perldb-set-buffer)))
+
+(defun perldb-set-buffer ()
+ (cond ((eq major-mode 'perldb-mode)
+ (setq current-perldb-buffer (current-buffer)))))
+\f
+;; This function is responsible for inserting output from Perl
+;; into the buffer.
+;; Aside from inserting the text, it notices and deletes
+;; each filename-and-line-number;
+;; that Perl prints to identify the selected frame.
+;; It records the filename and line number, and maybe displays that file.
+(defun perldb-filter (proc string)
+ (let ((inhibit-quit t))
+ (if perldb-filter-accumulator
+ (perldb-filter-accumulate-marker proc
+ (concat perldb-filter-accumulator string))
+ (perldb-filter-scan-input proc string))))
+
+(defun perldb-filter-accumulate-marker (proc string)
+ (setq perldb-filter-accumulator nil)
+ (if (> (length string) 1)
+ (if (= (aref string 1) ?\032)
+ (let ((end (string-match "\n" string)))
+ (if end
+ (progn
+ (let* ((first-colon (string-match ":" string 2))
+ (second-colon
+ (string-match ":" string (1+ first-colon))))
+ (setq perldb-last-frame
+ (cons (substring string 2 first-colon)
+ (string-to-int
+ (substring string (1+ first-colon)
+ second-colon)))))
+ (setq perldb-last-frame-displayed-p nil)
+ (perldb-filter-scan-input proc
+ (substring string (1+ end))))
+ (setq perldb-filter-accumulator string)))
+ (perldb-filter-insert proc "\032")
+ (perldb-filter-scan-input proc (substring string 1)))
+ (setq perldb-filter-accumulator string)))
+
+(defun perldb-filter-scan-input (proc string)
+ (if (equal string "")
+ (setq perldb-filter-accumulator nil)
+ (let ((start (string-match "\032" string)))
+ (if start
+ (progn (perldb-filter-insert proc (substring string 0 start))
+ (perldb-filter-accumulate-marker proc
+ (substring string start)))
+ (perldb-filter-insert proc string)))))
+
+(defun perldb-filter-insert (proc string)
+ (let ((moving (= (point) (process-mark proc)))
+ (output-after-point (< (point) (process-mark proc)))
+ (old-buffer (current-buffer))
+ start)
+ (set-buffer (process-buffer proc))
+ (unwind-protect
+ (save-excursion
+ ;; Insert the text, moving the process-marker.
+ (goto-char (process-mark proc))
+ (setq start (point))
+ (insert string)
+ (set-marker (process-mark proc) (point))
+ (perldb-maybe-delete-prompt)
+ ;; Check for a filename-and-line number.
+ (perldb-display-frame
+ ;; Don't display the specified file
+ ;; unless (1) point is at or after the position where output appears
+ ;; and (2) this buffer is on the screen.
+ (or output-after-point
+ (not (get-buffer-window (current-buffer))))
+ ;; Display a file only when a new filename-and-line-number appears.
+ t))
+ (set-buffer old-buffer))
+ (if moving (goto-char (process-mark proc)))))
+
+(defun perldb-sentinel (proc msg)
+ (cond ((null (buffer-name (process-buffer proc)))
+ ;; buffer killed
+ ;; Stop displaying an arrow in a source file.
+ (setq overlay-arrow-position nil)
+ (set-process-buffer proc nil))
+ ((memq (process-status proc) '(signal exit))
+ ;; Stop displaying an arrow in a source file.
+ (setq overlay-arrow-position nil)
+ ;; Fix the mode line.
+ (setq mode-line-process
+ (concat ": "
+ (symbol-name (process-status proc))))
+ (let* ((obuf (current-buffer)))
+ ;; save-excursion isn't the right thing if
+ ;; process-buffer is current-buffer
+ (unwind-protect
+ (progn
+ ;; Write something in *compilation* and hack its mode line,
+ (set-buffer (process-buffer proc))
+ ;; Force mode line redisplay soon
+ (set-buffer-modified-p (buffer-modified-p))
+ (if (eobp)
+ (insert ?\n mode-name " " msg)
+ (save-excursion
+ (goto-char (point-max))
+ (insert ?\n mode-name " " msg)))
+ ;; If buffer and mode line will show that the process
+ ;; is dead, we can delete it now. Otherwise it
+ ;; will stay around until M-x list-processes.
+ (delete-process proc))
+ ;; Restore old buffer, but don't restore old point
+ ;; if obuf is the perldb buffer.
+ (set-buffer obuf))))))
+
+
+(defun perldb-refresh ()
+ "Fix up a possibly garbled display, and redraw the arrow."
+ (interactive)
+ (redraw-display)
+ (perldb-display-frame))
+
+(defun perldb-display-frame (&optional nodisplay noauto)
+ "Find, obey and delete the last filename-and-line marker from PERLDB.
+The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
+Obeying it means displaying in another window the specified file and line."
+ (interactive)
+ (perldb-set-buffer)
+ (and perldb-last-frame (not nodisplay)
+ (or (not perldb-last-frame-displayed-p) (not noauto))
+ (progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame))
+ (setq perldb-last-frame-displayed-p t))))
+
+;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
+;; and that its line LINE is visible.
+;; Put the overlay-arrow on the line LINE in that buffer.
+
+(defun perldb-display-line (true-file line)
+ (let* ((buffer (find-file-noselect true-file))
+ (window (display-buffer buffer t))
+ (pos))
+ (save-excursion
+ (set-buffer buffer)
+ (save-restriction
+ (widen)
+ (goto-line line)
+ (setq pos (point))
+ (setq overlay-arrow-string "=>")
+ (or overlay-arrow-position
+ (setq overlay-arrow-position (make-marker)))
+ (set-marker overlay-arrow-position (point) (current-buffer)))
+ (cond ((or (< pos (point-min)) (> pos (point-max)))
+ (widen)
+ (goto-char pos))))
+ (set-window-point window overlay-arrow-position)))
+\f
+(defun perldb-call (command)
+ "Invoke perldb COMMAND displaying source in other window."
+ (interactive)
+ (goto-char (point-max))
+ (setq perldb-delete-prompt-marker (point-marker))
+ (perldb-set-buffer)
+ (send-string (get-buffer-process current-perldb-buffer)
+ (concat command "\n")))
+
+(defun perldb-maybe-delete-prompt ()
+ (if (and perldb-delete-prompt-marker
+ (> (point-max) (marker-position perldb-delete-prompt-marker)))
+ (let (start)
+ (goto-char perldb-delete-prompt-marker)
+ (setq start (point))
+ (beginning-of-line)
+ (delete-region (point) start)
+ (setq perldb-delete-prompt-marker nil))))
+
+(defun perldb-break ()
+ "Set PERLDB breakpoint at this source line."
+ (interactive)
+ (let ((line (save-restriction
+ (widen)
+ (1+ (count-lines 1 (point))))))
+ (send-string (get-buffer-process current-perldb-buffer)
+ (concat "b " line "\n"))))
+
+(defun perldb-read-token()
+ "Return a string containing the token found in the buffer at point.
+A token can be a number or an identifier. If the token is a name prefaced
+by `$', `@', or `%', the leading character is included in the token."
+ (save-excursion
+ (let (begin)
+ (or (looking-at "[$@%]")
+ (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move))
+ (setq begin (point))
+ (or (looking-at "[$@%]") (setq begin (+ begin 1)))
+ (forward-char 1)
+ (buffer-substring begin
+ (if (re-search-forward "[^a-zA-Z_0-9]"
+ (point-max) 'move)
+ (- (point) 1)
+ (point)))
+)))
+
+(defvar perldb-commands nil
+ "List of strings or functions used by send-perldb-command.
+It is for customization by the user.")
+
+(defun send-perldb-command (arg)
+ "Issue a Perl debugger command selected by the prefix arg. A numeric
+arg selects the ARG'th member COMMAND of the list perldb-commands.
+The token under the cursor is passed to the command. If COMMAND is a
+string, (format COMMAND TOKEN) is inserted at the end of the perldb
+buffer, otherwise (funcall COMMAND TOKEN) is inserted. If there is
+no such COMMAND, then the token itself is inserted. For example,
+\"p %s\" is a possible string to be a member of perldb-commands,
+or \"p $ENV{%s}\"."
+ (interactive "P")
+ (let (comm token)
+ (if arg (setq comm (nth arg perldb-commands)))
+ (setq token (perldb-read-token))
+ (if (eq (current-buffer) current-perldb-buffer)
+ (set-mark (point)))
+ (cond (comm
+ (setq comm
+ (if (stringp comm) (format comm token) (funcall comm token))))
+ (t (setq comm token)))
+ (switch-to-buffer-other-window current-perldb-buffer)
+ (goto-char (dot-max))
+ (insert-string comm)))
--- /dev/null
+package DB;
+
+# 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 $';
+#
+# This file is automatically included if you do perl -d.
+# It's probably not useful to include this yourself.
+#
+# Perl supplies the values for @line and %sub. It effectively inserts
+# a do DB'DB(<linenum>); in front of every place that can
+# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
+#
+# $Log: perldb.pl,v $
+# Revision 4.0 91/03/20 01:18:58 lwall
+# 4.0 baseline.
+#
+# Revision 3.0.1.6 91/01/11 18:08:58 lwall
+# patch42: @_ couldn't be accessed from debugger
+#
+# Revision 3.0.1.5 90/11/10 01:40:26 lwall
+# patch38: the debugger wouldn't stop correctly or do action routines
+#
+# Revision 3.0.1.4 90/10/15 17:40:38 lwall
+# patch29: added caller
+# patch29: the debugger now understands packages and evals
+# patch29: scripts now run at almost full speed under the debugger
+# patch29: more variables are settable from debugger
+#
+# Revision 3.0.1.3 90/08/09 04:00:58 lwall
+# patch19: debugger now allows continuation lines
+# patch19: debugger can now dump lists of variables
+# patch19: debugger can now add aliases easily from prompt
+#
+# Revision 3.0.1.2 90/03/12 16:39:39 lwall
+# patch13: perl -d didn't format stack traces of *foo right
+# patch13: perl -d wiped out scalar return values of subroutines
+#
+# Revision 3.0.1.1 89/10/26 23:14:02 lwall
+# patch1: RCS expanded an unintended $Header in lib/perldb.pl
+#
+# Revision 3.0 89/10/18 15:19:46 lwall
+# 3.0 baseline
+#
+# Revision 2.0 88/06/05 00:09:45 root
+# Baseline version 2.0.
+#
+#
+
+open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin
+open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
+select(OUT);
+$| = 1; # for DB'OUT
+select(STDOUT);
+$| = 1; # for real STDOUT
+$sub = '';
+
+# Is Perl being run from Emacs?
+$emacs = $main'ARGV[$[] eq '-emacs';
+shift(@main'ARGV) if $emacs;
+
+$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
+print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
+
+sub DB {
+ &save;
+ ($package, $filename, $line) = caller;
+ $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
+ "package $package;"; # this won't let them modify, alas
+ local(*dbline) = "_<$filename";
+ $max = $#dbline;
+ if (($stop,$action) = split(/\0/,$dbline{$line})) {
+ if ($stop eq '1') {
+ $signal |= 1;
+ }
+ else {
+ $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
+ $dbline{$line} =~ s/;9($|\0)/$1/;
+ }
+ }
+ if ($single || $trace || $signal) {
+ if ($emacs) {
+ print OUT "\032\032$filename:$line:0\n";
+ } else {
+ print OUT "$package'" unless $sub =~ /'/;
+ print OUT "$sub($filename:$line):\t",$dbline[$line];
+ for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
+ last if $dbline[$i] =~ /^\s*(}|#|\n)/;
+ print OUT "$sub($filename:$i):\t",$dbline[$i];
+ }
+ }
+ }
+ $evalarg = $action, &eval if $action;
+ if ($single || $signal) {
+ $evalarg = $pre, &eval if $pre;
+ print OUT $#stack . " levels deep in subroutine calls!\n"
+ if $single & 4;
+ $start = $line;
+ while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) {
+ $single = 0;
+ $signal = 0;
+ $cmd eq '' && exit 0;
+ chop($cmd);
+ $cmd =~ s/\\$// && do {
+ print OUT " cont: ";
+ $cmd .= &gets;
+ redo;
+ };
+ $cmd =~ /^q$/ && exit 0;
+ $cmd =~ /^$/ && ($cmd = $laststep);
+ push(@hist,$cmd) if length($cmd) > 1;
+ ($i) = split(/\s+/,$cmd);
+ eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
+ $cmd =~ /^h$/ && do {
+ print OUT "
+T Stack trace.
+s Single step.
+n Next, steps over subroutine calls.
+r Return from current subroutine.
+c [line] Continue; optionally inserts a one-time-only breakpoint
+ at the specified line.
+<CR> Repeat last n or s.
+l min+incr List incr+1 lines starting at min.
+l min-max List lines.
+l line List line;
+l List next window.
+- List previous window.
+w line List window around line.
+l subname List subroutine.
+f filename Switch to filename.
+/pattern/ Search forwards for pattern; final / is optional.
+?pattern? Search backwards for pattern.
+L List breakpoints and actions.
+S List subroutine names.
+t Toggle trace mode.
+b [line] [condition]
+ Set breakpoint; line defaults to the current execution line;
+ condition breaks if it evaluates to true, defaults to \'1\'.
+b subname [condition]
+ Set breakpoint at first line of subroutine.
+d [line] Delete breakpoint.
+D Delete all breakpoints.
+a [line] command
+ Set an action to be done before the line is executed.
+ Sequence is: check for breakpoint, print line if necessary,
+ do action, prompt user if breakpoint or step, evaluate line.
+A Delete all actions.
+V [pkg [vars]] List some (default all) variables in package (default current).
+X [vars] Same as \"V currentpackage [vars]\".
+< command Define command before prompt.
+| command Define command after prompt.
+! number Redo command (default previous command).
+! -number Redo number\'th to last command.
+H -number Display last number commands (default all).
+q or ^D Quit.
+p expr Same as \"print DB'OUT expr\" in current package.
+= [alias value] Define a command alias, or list current aliases.
+command Execute as a perl statement in current package.
+
+";
+ next; };
+ $cmd =~ /^t$/ && do {
+ $trace = !$trace;
+ print OUT "Trace = ".($trace?"on":"off")."\n";
+ next; };
+ $cmd =~ /^S$/ && do {
+ foreach $subname (sort(keys %sub)) {
+ print OUT $subname,"\n";
+ }
+ next; };
+ $cmd =~ s/^X\b/V $package/;
+ $cmd =~ /^V$/ && do {
+ $cmd = 'V $package'; };
+ $cmd =~ /^V\s*(\S+)\s*(.*)/ && do {
+ $packname = $1;
+ @vars = split(' ',$2);
+ do 'dumpvar.pl' unless defined &main'dumpvar;
+ if (defined &main'dumpvar) {
+ &main'dumpvar($packname,@vars);
+ }
+ else {
+ print DB'OUT "dumpvar.pl not available.\n";
+ }
+ next; };
+ $cmd =~ /^f\s*(.*)/ && do {
+ $file = $1;
+ if (!$file) {
+ print OUT "The old f command is now the r command.\n";
+ print OUT "The new f command switches filenames.\n";
+ next;
+ }
+ if (!defined $_main{'_<' . $file}) {
+ if (($try) = grep(m#^_<.*$file#, keys %_main)) {
+ $file = substr($try,2);
+ print "\n$file:\n";
+ }
+ }
+ if (!defined $_main{'_<' . $file}) {
+ print OUT "There's no code here anything matching $file.\n";
+ next;
+ }
+ elsif ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } };
+ $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
+ $subname = $1;
+ $subname = "main'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($file,$subrange) = split(/:/,$sub{$subname});
+ if ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ }
+ if ($subrange) {
+ if (eval($subrange) < -$window) {
+ $subrange =~ s/-.*/+/;
+ }
+ $cmd = "l $subrange";
+ } else {
+ print OUT "Subroutine $1 not found.\n";
+ next;
+ } };
+ $cmd =~ /^w\s*(\d*)$/ && do {
+ $incr = $window - 1;
+ $start = $1 if $1;
+ $start -= $preview;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^-$/ && do {
+ $incr = $window - 1;
+ $cmd = 'l ' . ($start-$window*2) . '+'; };
+ $cmd =~ /^l$/ && do {
+ $incr = $window - 1;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
+ $start = $1 if $1;
+ $incr = $2;
+ $incr = $window - 1 unless $incr;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
+ $end = (!$2) ? $max : ($4 ? $4 : $2);
+ $end = $max if $end > $max;
+ $i = $2;
+ $i = $line if $i eq '.';
+ $i = 1 if $i < 1;
+ if ($emacs) {
+ print OUT "\032\032$filename:$i:0\n";
+ $i = $end;
+ } else {
+ for (; $i <= $end; $i++) {
+ print OUT "$i:\t", $dbline[$i];
+ last if $signal;
+ }
+ }
+ $start = $i; # remember in case they want more
+ $start = $max if $start > $max;
+ next; };
+ $cmd =~ /^D$/ && do {
+ print OUT "Deleting all breakpoints...\n";
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ($dbline{$i} =~ s/^\0?$//) {
+ delete $dbline{$i};
+ }
+ }
+ }
+ next; };
+ $cmd =~ /^L$/ && do {
+ for ($i = 1; $i <= $max; $i++) {
+ if (defined $dbline{$i}) {
+ print OUT "$i:\t", $dbline[$i];
+ ($stop,$action) = split(/\0/, $dbline{$i});
+ print OUT " break if (", $stop, ")\n"
+ if $stop;
+ print OUT " action: ", $action, "\n"
+ if $action;
+ last if $signal;
+ }
+ }
+ next; };
+ $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
+ $subname = $1;
+ $cond = $2 || '1';
+ $subname = "$package'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($filename,$i) = split(/[:-]/, $sub{$subname});
+ if ($i) {
+ *dbline = "_<$filename";
+ ++$i while $dbline[$i] == 0 && $i < $#dbline;
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ } else {
+ print OUT "Subroutine $subname not found.\n";
+ }
+ next; };
+ $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
+ $i = ($1?$1:$line);
+ $cond = $2 || '1';
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i not breakable.\n";
+ } else {
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ next; };
+ $cmd =~ /^d\s*(\d+)?/ && do {
+ $i = ($1?$1:$line);
+ $dbline{$i} =~ s/^[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ next; };
+ $cmd =~ /^A$/ && do {
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ }
+ next; };
+ $cmd =~ /^<\s*(.*)/ && do {
+ $pre = do action($1);
+ next; };
+ $cmd =~ /^>\s*(.*)/ && do {
+ $post = do action($1);
+ next; };
+ $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
+ $i = $1;
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i may not have an action.\n";
+ } else {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ $dbline{$i} .= "\0" . do action($3);
+ }
+ next; };
+ $cmd =~ /^n$/ && do {
+ $single = 2;
+ $laststep = $cmd;
+ last; };
+ $cmd =~ /^s$/ && do {
+ $single = 1;
+ $laststep = $cmd;
+ last; };
+ $cmd =~ /^c\s*(\d*)\s*$/ && do {
+ $i = $1;
+ if ($i) {
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i not breakable.\n";
+ next;
+ }
+ $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
+ }
+ for ($i=0; $i <= $#stack; ) {
+ $stack[$i++] &= ~1;
+ }
+ last; };
+ $cmd =~ /^r$/ && do {
+ $stack[$#stack] |= 2;
+ last; };
+ $cmd =~ /^T$/ && do {
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @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 OUT $sub[$i];
+ }
+ next; };
+ $cmd =~ /^\/(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])/$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ eval '
+ for (;;) {
+ ++$start;
+ $start = 1 if ($start > $max);
+ last if ($start == $end);
+ if ($dbline[$start] =~ m'."\n$pat\n".'i) {
+ if ($emacs) {
+ print OUT "\032\032$filename:$start:0\n";
+ } else {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ }
+ last;
+ }
+ } ';
+ print OUT "/$pat/: not found\n" if ($start == $end);
+ next; };
+ $cmd =~ /^\?(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])\?$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ eval '
+ for (;;) {
+ --$start;
+ $start = $max if ($start <= 0);
+ last if ($start == $end);
+ if ($dbline[$start] =~ m'."\n$pat\n".'i) {
+ if ($emacs) {
+ print OUT "\032\032$filename:$start:0\n";
+ } else {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ }
+ last;
+ }
+ } ';
+ print OUT "?$pat?: not found\n" if ($start == $end);
+ next; };
+ $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
+ pop(@hist) if length($cmd) > 1;
+ $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
+ $cmd = $hist[$i] . "\n";
+ print OUT $cmd;
+ redo; };
+ $cmd =~ /^!(.+)$/ && do {
+ $pat = "^$1";
+ pop(@hist) if length($cmd) > 1;
+ for ($i = $#hist; $i; --$i) {
+ last if $hist[$i] =~ $pat;
+ }
+ if (!$i) {
+ print OUT "No such command!\n\n";
+ next;
+ }
+ $cmd = $hist[$i] . "\n";
+ print OUT $cmd;
+ redo; };
+ $cmd =~ /^H\s*(-(\d+))?/ && do {
+ $end = $2?($#hist-$2):0;
+ $hist = 0 if $hist < 0;
+ for ($i=$#hist; $i>$end; $i--) {
+ print OUT "$i: ",$hist[$i],"\n"
+ unless $hist[$i] =~ /^.?$/;
+ };
+ next; };
+ $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
+ $cmd =~ /^=/ && do {
+ if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
+ $alias{$k}="s~$k~$v~";
+ print OUT "$k = $v\n";
+ } elsif ($cmd =~ /^=\s*$/) {
+ foreach $k (sort keys(%alias)) {
+ if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
+ print OUT "$k = $v\n";
+ } else {
+ print OUT "$k\t$alias{$k}\n";
+ };
+ };
+ };
+ next; };
+ $evalarg = $cmd; &eval;
+ print OUT "\n";
+ }
+ if ($post) {
+ $evalarg = $post; &eval;
+ }
+ }
+ ($@, $!, $[, $,, $/, $\) = @saved;
+}
+
+sub save {
+ @saved = ($@, $!, $[, $,, $/, $\);
+ $[ = 0; $, = ""; $/ = "\n"; $\ = "";
+}
+
+# The following takes its argument via $evalarg to preserve current @_
+
+sub eval {
+ eval "$usercontext $evalarg; &DB'save";
+ print OUT $@;
+}
+
+sub action {
+ local($action) = @_;
+ while ($action =~ s/\\$//) {
+ print OUT "+ ";
+ $action .= &gets;
+ }
+ $action;
+}
+
+sub gets {
+ local($.);
+ <IN>;
+}
+
+sub catch {
+ $signal = 1;
+}
+
+sub sub {
+ push(@stack, $single);
+ $single &= 1;
+ $single |= 4 if $#stack == $deep;
+ if (wantarray) {
+ @i = &$sub;
+ $single |= pop(@stack);
+ @i;
+ }
+ else {
+ $i = &$sub;
+ $single |= pop(@stack);
+ $i;
+ }
+}
+
+$single = 1; # so it stops on first executable statement
+@hist = ('?');
+$SIG{'INT'} = "DB'catch";
+$deep = 100; # warning if stack gets this deep
+$window = 10;
+$preview = 3;
+
+@stack = (0);
+@ARGS = @ARGV;
+for (@args) {
+ s/'/\\'/g;
+ s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+}
+
+if (-f '.perldb') {
+ do './.perldb';
+}
+elsif (-f "$ENV{'LOGDIR'}/.perldb") {
+ do "$ENV{'LOGDIR'}/.perldb";
+}
+elsif (-f "$ENV{'HOME'}/.perldb") {
+ do "$ENV{'HOME'}/.perldb";
+}
+
+1;
--- /dev/null
+Article 4417 of comp.lang.perl:
+Path: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf
+From: ted@evi.com (Ted Stefanik)
+Newsgroups: comp.lang.perl
+Subject: Correction to Perl fatal error marking in GNU Emacs
+Message-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU>
+Date: 27 Feb 91 06:58:53 GMT
+Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System)
+Reply-To: ted@evi.com (Ted Stefanik)
+Organization: The Internet
+Lines: 282
+
+Reading my own message, it occurred to me that I didn't quite satisfy the
+request of stef@zweig.sun (Stephane Payrard):
+
+| Does anyone has extended perdb/perdb.el to position the
+| point to the first syntax error? It would be cool.
+
+What I posted is a way to use the "M-x compile" command to test perl scripts.
+(Needless to say, the script cannot be not interactive; you can't provide input
+to a *compilation* buffer). When creating new Perl programs, I use "M-x
+compile" until I'm sure that they are syntatically correct; if syntax errors
+occur, C-x` takes me to each in sequence. After I'm sure the syntax is
+correct, I start worrying about semantics, and switch to "M-x perldb" if
+necessary.
+
+Therefore, the stuff I posted works great with "M-x compile", but not at all
+with "M-x perldb".
+
+Next, let me update what I posted. I found that perl's die() command doesn't
+print the same format error message as perl does when it dies with a syntax
+error. If you put the following in your ".emacs" file, it causes C-x` to
+recognize both kinds of errors:
+
+(load-library "compile")
+(setq compilation-error-regexp
+ "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)")
+
+Last, so I don't look like a total fool, let me propose a way to satisfy
+Stephane Payrard's original request (repeated again):
+
+| Does anyone has extended perdb/perdb.el to position the
+| point to the first syntax error? It would be cool.
+
+I'm not satisfied with just the "first syntax error". Perl's parser is better
+than most about not getting out of sync; therefore, if it reports multiple
+errors, you can usually be assured they are all real errors.
+
+So... I hacked in the "next-error" function from "compile.el" to form
+"perldb-next-error". You can apply the patches at the end of this message
+to add "perldb-next-error" to your "perldb.el".
+
+Notes:
+ 1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift
+ of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS).
+
+ 2) "next-error" is meant to work on a single *compilation* buffer; any new
+ "M-x compile" or "M-x grep" command will clear the old *compilation*
+ buffer and reset the compilation-error parser to start at the top of the
+ *compilation* buffer.
+
+ "perldb-next-error", on the other hand, has to deal with multiple
+ *perldb-<foo>* buffers, each of which keep growing. "perldb-next-error"
+ correctly handles the constantly growing *perldb-<foo>* buffers by
+ keeping track of the last reported error in the "current-perldb-buffer".
+
+ Sadly however, when you invoke a new "M-x perldb" on a different Perl
+ script, "perldb-next-error" will start parsing the new *perldb-<bar>*
+ buffer at the top (even if it was previously parsed), and will completely
+ lose the marker of the last reported error in *perldb-<foo>*.
+
+ 3) "perldb-next-error" still uses "compilation-error-regexp" to find
+ fatal errors. Therefore, both the "M-x compile"/C-x` scheme and
+ the "M-x perldb"/C-x~ scheme can be used to find fatal errors that
+ match the common "compilation-error-regexp". You *will* want to install
+ that "compilation-error-regexp" stuff into your .emacs file.
+
+ 4) The patch was developed and tested with GNU Emacs 18.55.
+
+ 5) Since the patch was ripped off from compile.el, the code is (of
+ course) subject to the GNU copyleft.
+
+*** perldb.el.orig Wed Feb 27 00:44:27 1991
+--- perldb.el Wed Feb 27 00:44:30 1991
+***************
+*** 199,205 ****
+
+ (defun perldb-set-buffer ()
+ (cond ((eq major-mode 'perldb-mode)
+! (setq current-perldb-buffer (current-buffer)))))
+ \f
+ ;; This function is responsible for inserting output from Perl
+ ;; into the buffer.
+--- 199,211 ----
+
+ (defun perldb-set-buffer ()
+ (cond ((eq major-mode 'perldb-mode)
+! (cond ((not (eq current-perldb-buffer (current-buffer)))
+! (perldb-forget-errors)
+! (setq perldb-parsing-end 2)) ;; 2 to defeat grep defeater
+! (t
+! (if (> perldb-parsing-end (point-max))
+! (setq perldb-parsing-end (max (point-max) 2)))))
+! (setq current-perldb-buffer (current-buffer)))))
+ \f
+ ;; This function is responsible for inserting output from Perl
+ ;; into the buffer.
+***************
+*** 291,297 ****
+ ;; process-buffer is current-buffer
+ (unwind-protect
+ (progn
+! ;; Write something in *compilation* and hack its mode line,
+ (set-buffer (process-buffer proc))
+ ;; Force mode line redisplay soon
+ (set-buffer-modified-p (buffer-modified-p))
+--- 297,303 ----
+ ;; process-buffer is current-buffer
+ (unwind-protect
+ (progn
+! ;; Write something in *perldb-<foo>* and hack its mode line,
+ (set-buffer (process-buffer proc))
+ ;; Force mode line redisplay soon
+ (set-buffer-modified-p (buffer-modified-p))
+***************
+*** 421,423 ****
+--- 427,593 ----
+ (switch-to-buffer-other-window current-perldb-buffer)
+ (goto-char (dot-max))
+ (insert-string comm)))
++ \f
++ (defvar perldb-error-list nil
++ "List of error message descriptors for visiting erring functions.
++ Each error descriptor is a list of length two.
++ Its car is a marker pointing to an error message.
++ Its cadr is a marker pointing to the text of the line the message is about,
++ or nil if that is not interesting.
++ The value may be t instead of a list;
++ this means that the buffer of error messages should be reparsed
++ the next time the list of errors is wanted.")
++
++ (defvar perldb-parsing-end nil
++ "Position of end of buffer when last error messages parsed.")
++
++ (defvar perldb-error-message "No more fatal Perl errors"
++ "Message to print when no more matches for compilation-error-regexp are found")
++
++ (defun perldb-next-error (&optional argp)
++ "Visit next perldb error message and corresponding source code.
++ This operates on the output from the \\[perldb] command.
++ If all preparsed error messages have been processed,
++ the error message buffer is checked for new ones.
++ A non-nil argument (prefix arg, if interactive)
++ means reparse the error message buffer and start at the first error."
++ (interactive "P")
++ (if (or (eq perldb-error-list t)
++ argp)
++ (progn (perldb-forget-errors)
++ (setq perldb-parsing-end 2))) ;; 2 to defeat grep defeater
++ (if perldb-error-list
++ nil
++ (save-excursion
++ (switch-to-buffer current-perldb-buffer)
++ (perldb-parse-errors)))
++ (let ((next-error (car perldb-error-list)))
++ (if (null next-error)
++ (error (concat perldb-error-message
++ (if (and (get-buffer-process current-perldb-buffer)
++ (eq (process-status
++ (get-buffer-process
++ current-perldb-buffer))
++ 'run))
++ " yet" ""))))
++ (setq perldb-error-list (cdr perldb-error-list))
++ (if (null (car (cdr next-error)))
++ nil
++ (switch-to-buffer (marker-buffer (car (cdr next-error))))
++ (goto-char (car (cdr next-error)))
++ (set-marker (car (cdr next-error)) nil))
++ (let* ((pop-up-windows t)
++ (w (display-buffer (marker-buffer (car next-error)))))
++ (set-window-point w (car next-error))
++ (set-window-start w (car next-error)))
++ (set-marker (car next-error) nil)))
++
++ ;; Set perldb-error-list to nil, and
++ ;; unchain the markers that point to the error messages and their text,
++ ;; so that they no longer slow down gap motion.
++ ;; This would happen anyway at the next garbage collection,
++ ;; but it is better to do it right away.
++ (defun perldb-forget-errors ()
++ (if (eq perldb-error-list t)
++ (setq perldb-error-list nil))
++ (while perldb-error-list
++ (let ((next-error (car perldb-error-list)))
++ (set-marker (car next-error) nil)
++ (if (car (cdr next-error))
++ (set-marker (car (cdr next-error)) nil)))
++ (setq perldb-error-list (cdr perldb-error-list))))
++
++ (defun perldb-parse-errors ()
++ "Parse the current buffer as error messages.
++ This makes a list of error descriptors, perldb-error-list.
++ For each source-file, line-number pair in the buffer,
++ the source file is read in, and the text location is saved in perldb-error-list.
++ The function next-error, assigned to \\[next-error], takes the next error off the list
++ and visits its location."
++ (setq perldb-error-list nil)
++ (message "Parsing error messages...")
++ (let (text-buffer
++ last-filename last-linenum)
++ ;; Don't reparse messages already seen at last parse.
++ (goto-char perldb-parsing-end)
++ ;; Don't parse the first two lines as error messages.
++ ;; This matters for grep.
++ (if (bobp)
++ (forward-line 2))
++ (while (re-search-forward compilation-error-regexp nil t)
++ (let (linenum filename
++ error-marker text-marker)
++ ;; Extract file name and line number from error message.
++ (save-restriction
++ (narrow-to-region (match-beginning 0) (match-end 0))
++ (goto-char (point-max))
++ (skip-chars-backward "[0-9]")
++ ;; If it's a lint message, use the last file(linenum) on the line.
++ ;; Normally we use the first on the line.
++ (if (= (preceding-char) ?\()
++ (progn
++ (narrow-to-region (point-min) (1+ (buffer-size)))
++ (end-of-line)
++ (re-search-backward compilation-error-regexp)
++ (skip-chars-backward "^ \t\n")
++ (narrow-to-region (point) (match-end 0))
++ (goto-char (point-max))
++ (skip-chars-backward "[0-9]")))
++ ;; Are we looking at a "filename-first" or "line-number-first" form?
++ (if (looking-at "[0-9]")
++ (progn
++ (setq linenum (read (current-buffer)))
++ (goto-char (point-min)))
++ ;; Line number at start, file name at end.
++ (progn
++ (goto-char (point-min))
++ (setq linenum (read (current-buffer)))
++ (goto-char (point-max))
++ (skip-chars-backward "^ \t\n")))
++ (setq filename (perldb-grab-filename)))
++ ;; Locate the erring file and line.
++ (if (and (equal filename last-filename)
++ (= linenum last-linenum))
++ nil
++ (beginning-of-line 1)
++ (setq error-marker (point-marker))
++ ;; text-buffer gets the buffer containing this error's file.
++ (if (not (equal filename last-filename))
++ (setq text-buffer
++ (and (file-exists-p (setq last-filename filename))
++ (find-file-noselect filename))
++ last-linenum 0))
++ (if text-buffer
++ ;; Go to that buffer and find the erring line.
++ (save-excursion
++ (set-buffer text-buffer)
++ (if (zerop last-linenum)
++ (progn
++ (goto-char 1)
++ (setq last-linenum 1)))
++ (forward-line (- linenum last-linenum))
++ (setq last-linenum linenum)
++ (setq text-marker (point-marker))
++ (setq perldb-error-list
++ (cons (list error-marker text-marker)
++ perldb-error-list)))))
++ (forward-line 1)))
++ (setq perldb-parsing-end (point-max)))
++ (message "Parsing error messages...done")
++ (setq perldb-error-list (nreverse perldb-error-list)))
++
++ (defun perldb-grab-filename ()
++ "Return a string which is a filename, starting at point.
++ Ignore quotes and parentheses around it, as well as trailing colons."
++ (if (eq (following-char) ?\")
++ (save-restriction
++ (narrow-to-region (point)
++ (progn (forward-sexp 1) (point)))
++ (goto-char (point-min))
++ (read (current-buffer)))
++ (buffer-substring (point)
++ (progn
++ (skip-chars-forward "^ :,\n\t(")
++ (point)))))
++
++ (define-key ctl-x-map "~" 'perldb-next-error)
+
+
-/* $Header: eval.c,v 3.0.1.11 91/01/11 17:58:30 lwall Locked $
+/* $Header: eval.c,v 4.0 91/03/20 01:16:48 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: eval.c,v $
- * Revision 3.0.1.11 91/01/11 17:58:30 lwall
- * patch42: ANSIfied the stat mode checking
- * patch42: perl -D14 crashed on ..
- * patch42: waitpid() emulation was useless because of #ifdef WAITPID
- *
- * Revision 3.0.1.10 90/11/10 01:33:22 lwall
- * patch38: random cleanup
- * patch38: couldn't return from sort routine
- * patch38: added hooks for unexec()
- * patch38: added alarm function
- *
- * Revision 3.0.1.9 90/10/15 16:46:13 lwall
- * patch29: added caller
- * patch29: added scalar
- * patch29: added cmp and <=>
- * patch29: added sysread and syswrite
- * patch29: added -M, -A and -C
- * patch29: index and substr now have optional 3rd args
- * patch29: you can now read into the middle string
- * patch29: ~ now works on vector string
- * patch29: non-existent array values no longer cause core dumps
- * patch29: eof; core dumped
- * patch29: oct and hex now produce unsigned result
- * patch29: unshift did not return the documented value
- *
- * Revision 3.0.1.8 90/08/13 22:17:14 lwall
- * patch28: the NSIG hack didn't work right on Xenix
- * patch28: defined(@array) and defined(%array) didn't work right
- * patch28: rename was busted on systems without rename system call
- *
- * Revision 3.0.1.7 90/08/09 03:33:44 lwall
- * patch19: made ~ do vector operation on strings like &, | and ^
- * patch19: dbmopen(%name...) didn't work right
- * patch19: dbmopen(name, 'filename', undef) now refrains from creating
- * patch19: empty %array now returns 0 in scalar context
- * patch19: die with no arguments no longer exits unconditionally
- * patch19: return outside a subroutine now returns a reasonable message
- * patch19: rename done with unlink()/link()/unlink() now checks for clobbering
- * patch19: -s now returns size of file
- *
- * Revision 3.0.1.6 90/03/27 15:53:51 lwall
- * patch16: MSDOS support
- * patch16: support for machines that can't cast negative floats to unsigned ints
- * patch16: ioctl didn't return values correctly
- *
- * Revision 3.0.1.5 90/03/12 16:37:40 lwall
- * patch13: undef $/ didn't work as advertised
- * patch13: added list slice operator (LIST)[LIST]
- * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST)
- *
- * Revision 3.0.1.4 90/02/28 17:36:59 lwall
- * patch9: added pipe function
- * patch9: a return in scalar context wouldn't return array
- * patch9: !~ now always returns scalar even in array context
- * patch9: some machines can't cast float to long with high bit set
- * patch9: piped opens returned undef in child
- * patch9: @array in scalar context now returns length of array
- * patch9: chdir; coredumped
- * patch9: wait no longer ignores signals
- * patch9: mkdir now handles odd versions of /bin/mkdir
- * patch9: -l FILEHANDLE now disallowed
- *
- * Revision 3.0.1.3 89/12/21 20:03:05 lwall
- * patch7: errno may now be a macro with an lvalue
- * patch7: ANSI strerror() is now supported
- * patch7: send() didn't allow a TO argument
- * patch7: ord() now always returns positive even on signed char machines
- *
- * Revision 3.0.1.2 89/11/17 15:19:34 lwall
- * patch5: constant numeric subscripts get lost inside ?:
- *
- * Revision 3.0.1.1 89/11/11 04:31:51 lwall
- * patch2: mkdir and rmdir needed to quote argument when passed to shell
- * patch2: mkdir and rmdir now return better error codes
- * patch2: fileno, seekdir, rewinddir and closedir now disallow defaults
- *
- * Revision 3.0 89/10/18 15:17:04 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:16:48 lwall
+ * 4.0 baseline.
*
*/
#ifdef I_FCNTL
#include <fcntl.h>
#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
#ifdef I_VFORK
# include <vfork.h>
#endif
static STAB *stab2;
static STIO *stio;
static struct lstring *lstr;
-static int old_record_separator;
+static int old_rschar;
+static int old_rslen;
double sin(), cos(), atan2(), pow();
}
#endif
-#include "evalargs.xc"
+ for (anum = 1; anum <= maxarg; anum++) {
+ argflags = arg[anum].arg_flags;
+ argtype = arg[anum].arg_type;
+ argptr = arg[anum].arg_ptr;
+ re_eval:
+ switch (argtype) {
+ default:
+ st[++sp] = &str_undef;
+#ifdef DEBUGGING
+ tmps = "NULL";
+#endif
+ break;
+ case A_EXPR:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ tmps = "EXPR";
+ deb("%d.EXPR =>\n",anum);
+ }
+#endif
+ sp = eval(argptr.arg_arg,
+ (argflags & AF_ARYOK) ? G_ARRAY : G_SCALAR, sp);
+ if (sp + (maxarg - anum) > stack->ary_max)
+ astore(stack, sp + (maxarg - anum), Nullstr);
+ st = stack->ary_array; /* possibly reallocated */
+ break;
+ case A_CMD:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ tmps = "CMD";
+ deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd);
+ }
+#endif
+ sp = cmd_exec(argptr.arg_cmd, gimme, sp);
+ if (sp + (maxarg - anum) > stack->ary_max)
+ astore(stack, sp + (maxarg - anum), Nullstr);
+ st = stack->ary_array; /* possibly reallocated */
+ break;
+ case A_LARYSTAB:
+ ++sp;
+ switch (optype) {
+ case O_ITEM2: argtype = 2; break;
+ case O_ITEM3: argtype = 3; break;
+ default: argtype = anum; break;
+ }
+ str = afetch(stab_array(argptr.arg_stab),
+ arg[argtype].arg_len - arybase, TRUE);
+#ifdef DEBUGGING
+ if (debug & 8) {
+ (void)sprintf(buf,"LARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
+ arg[argtype].arg_len);
+ tmps = buf;
+ }
+#endif
+ goto do_crement;
+ case A_ARYSTAB:
+ switch (optype) {
+ case O_ITEM2: argtype = 2; break;
+ case O_ITEM3: argtype = 3; break;
+ default: argtype = anum; break;
+ }
+ st[++sp] = afetch(stab_array(argptr.arg_stab),
+ arg[argtype].arg_len - arybase, FALSE);
+#ifdef DEBUGGING
+ if (debug & 8) {
+ (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
+ arg[argtype].arg_len);
+ tmps = buf;
+ }
+#endif
+ break;
+ case A_STAR:
+ stab = argptr.arg_stab;
+ st[++sp] = (STR*)stab;
+ if (!stab_xarray(stab))
+ aadd(stab);
+ if (!stab_xhash(stab))
+ hadd(stab);
+ if (!stab_io(stab))
+ stab_io(stab) = stio_new();
+#ifdef DEBUGGING
+ if (debug & 8) {
+ (void)sprintf(buf,"STAR *%s",stab_name(argptr.arg_stab));
+ tmps = buf;
+ }
+#endif
+ break;
+ case A_LSTAR:
+ str = st[++sp] = (STR*)argptr.arg_stab;
+#ifdef DEBUGGING
+ if (debug & 8) {
+ (void)sprintf(buf,"LSTAR *%s",stab_name(argptr.arg_stab));
+ tmps = buf;
+ }
+#endif
+ break;
+ case A_STAB:
+ st[++sp] = STAB_STR(argptr.arg_stab);
+#ifdef DEBUGGING
+ if (debug & 8) {
+ (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab));
+ tmps = buf;
+ }
+#endif
+ break;
+ case A_LEXPR:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ tmps = "LEXPR";
+ deb("%d.LEXPR =>\n",anum);
+ }
+#endif
+ if (argflags & AF_ARYOK) {
+ sp = eval(argptr.arg_arg, G_ARRAY, sp);
+ if (sp + (maxarg - anum) > stack->ary_max)
+ astore(stack, sp + (maxarg - anum), Nullstr);
+ st = stack->ary_array; /* possibly reallocated */
+ }
+ else {
+ sp = eval(argptr.arg_arg, G_SCALAR, sp);
+ st = stack->ary_array; /* possibly reallocated */
+ str = st[sp];
+ goto do_crement;
+ }
+ break;
+ case A_LVAL:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ (void)sprintf(buf,"LVAL $%s",stab_name(argptr.arg_stab));
+ tmps = buf;
+ }
+#endif
+ ++sp;
+ str = STAB_STR(argptr.arg_stab);
+ if (!str)
+ fatal("panic: A_LVAL");
+ do_crement:
+ assigning = TRUE;
+ if (argflags & AF_PRE) {
+ if (argflags & AF_UP)
+ str_inc(str);
+ else
+ str_dec(str);
+ STABSET(str);
+ st[sp] = str;
+ str = arg->arg_ptr.arg_str;
+ }
+ else if (argflags & AF_POST) {
+ st[sp] = str_mortal(str);
+ if (argflags & AF_UP)
+ str_inc(str);
+ else
+ str_dec(str);
+ STABSET(str);
+ str = arg->arg_ptr.arg_str;
+ }
+ else
+ st[sp] = str;
+ break;
+ case A_LARYLEN:
+ ++sp;
+ stab = argptr.arg_stab;
+ str = stab_array(argptr.arg_stab)->ary_magic;
+ if (optype != O_SASSIGN || argflags & (AF_PRE|AF_POST))
+ str_numset(str,(double)(stab_array(stab)->ary_fill+arybase));
+#ifdef DEBUGGING
+ tmps = "LARYLEN";
+#endif
+ if (!str)
+ fatal("panic: A_LEXPR");
+ goto do_crement;
+ case A_ARYLEN:
+ stab = argptr.arg_stab;
+ st[++sp] = stab_array(stab)->ary_magic;
+ str_numset(st[sp],(double)(stab_array(stab)->ary_fill+arybase));
+#ifdef DEBUGGING
+ tmps = "ARYLEN";
+#endif
+ break;
+ case A_SINGLE:
+ st[++sp] = argptr.arg_str;
+#ifdef DEBUGGING
+ tmps = "SINGLE";
+#endif
+ break;
+ case A_DOUBLE:
+ (void) interp(str,argptr.arg_str,sp);
+ st = stack->ary_array;
+ st[++sp] = str;
+#ifdef DEBUGGING
+ tmps = "DOUBLE";
+#endif
+ break;
+ case A_BACKTICK:
+ tmps = str_get(interp(str,argptr.arg_str,sp));
+ st = stack->ary_array;
+#ifdef TAINT
+ taintproper("Insecure dependency in ``");
+#endif
+ fp = mypopen(tmps,"r");
+ str_set(str,"");
+ if (fp) {
+ if (gimme == G_SCALAR) {
+ while (str_gets(str,fp,str->str_cur) != Nullch)
+ ;
+ }
+ else {
+ for (;;) {
+ if (++sp > stack->ary_max) {
+ astore(stack, sp, Nullstr);
+ st = stack->ary_array;
+ }
+ str = st[sp] = Str_new(56,80);
+ if (str_gets(str,fp,0) == Nullch) {
+ sp--;
+ break;
+ }
+ if (str->str_len - str->str_cur > 20) {
+ str->str_len = str->str_cur+1;
+ Renew(str->str_ptr, str->str_len, char);
+ }
+ str_2mortal(str);
+ }
+ }
+ statusvalue = mypclose(fp);
+ }
+ else
+ statusvalue = -1;
+
+ if (gimme == G_SCALAR)
+ st[++sp] = str;
+#ifdef DEBUGGING
+ tmps = "BACK";
+#endif
+ break;
+ case A_WANTARRAY:
+ {
+ if (curcsv->wantarray == G_ARRAY)
+ st[++sp] = &str_yes;
+ else
+ st[++sp] = &str_no;
+ }
+#ifdef DEBUGGING
+ tmps = "WANTARRAY";
+#endif
+ break;
+ case A_INDREAD:
+ last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE);
+ old_rschar = rschar;
+ old_rslen = rslen;
+ goto do_read;
+ case A_GLOB:
+ argflags |= AF_POST; /* enable newline chopping */
+ last_in_stab = argptr.arg_stab;
+ old_rschar = rschar;
+ old_rslen = rslen;
+ rslen = 1;
+#ifdef MSDOS
+ rschar = 0;
+#else
+#ifdef CSH
+ rschar = 0;
+#else
+ rschar = '\n';
+#endif /* !CSH */
+#endif /* !MSDOS */
+ goto do_read;
+ case A_READ:
+ last_in_stab = argptr.arg_stab;
+ old_rschar = rschar;
+ old_rslen = rslen;
+ do_read:
+ if (anum > 1) /* assign to scalar */
+ gimme = G_SCALAR; /* force context to scalar */
+ if (gimme == G_ARRAY)
+ str = Str_new(57,0);
+ ++sp;
+ fp = Nullfp;
+ if (stab_io(last_in_stab)) {
+ fp = stab_io(last_in_stab)->ifp;
+ if (!fp) {
+ if (stab_io(last_in_stab)->flags & IOF_ARGV) {
+ if (stab_io(last_in_stab)->flags & IOF_START) {
+ stab_io(last_in_stab)->flags &= ~IOF_START;
+ stab_io(last_in_stab)->lines = 0;
+ if (alen(stab_array(last_in_stab)) < 0) {
+ tmpstr = str_make("-",1); /* assume stdin */
+ (void)apush(stab_array(last_in_stab), tmpstr);
+ }
+ }
+ fp = nextargv(last_in_stab);
+ if (!fp) { /* Note: fp != stab_io(last_in_stab)->ifp */
+ (void)do_close(last_in_stab,FALSE); /* now it does*/
+ stab_io(last_in_stab)->flags |= IOF_START;
+ }
+ }
+ else if (argtype == A_GLOB) {
+ (void) interp(str,stab_val(last_in_stab),sp);
+ st = stack->ary_array;
+ tmpstr = Str_new(55,0);
+#ifdef MSDOS
+ str_set(tmpstr, "perlglob ");
+ str_scat(tmpstr,str);
+ str_cat(tmpstr," |");
+#else
+#ifdef CSH
+ str_nset(tmpstr,cshname,cshlen);
+ str_cat(tmpstr," -cf 'set nonomatch; glob ");
+ str_scat(tmpstr,str);
+ str_cat(tmpstr,"'|");
+#else
+ str_set(tmpstr, "echo ");
+ str_scat(tmpstr,str);
+ str_cat(tmpstr,
+ "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
+#endif /* !CSH */
+#endif /* !MSDOS */
+ (void)do_open(last_in_stab,tmpstr->str_ptr,
+ tmpstr->str_cur);
+ fp = stab_io(last_in_stab)->ifp;
+ str_free(tmpstr);
+ }
+ }
+ }
+ if (!fp && dowarn)
+ warn("Read on closed filehandle <%s>",stab_name(last_in_stab));
+ when = str->str_len; /* remember if already alloced */
+ if (!when)
+ Str_Grow(str,80); /* try short-buffering it */
+ keepgoing:
+ if (!fp)
+ st[sp] = &str_undef;
+ else if (!str_gets(str,fp, optype == O_RCAT ? str->str_cur : 0)) {
+ clearerr(fp);
+ if (stab_io(last_in_stab)->flags & IOF_ARGV) {
+ fp = nextargv(last_in_stab);
+ if (fp)
+ goto keepgoing;
+ (void)do_close(last_in_stab,FALSE);
+ stab_io(last_in_stab)->flags |= IOF_START;
+ }
+ else if (argflags & AF_POST) {
+ (void)do_close(last_in_stab,FALSE);
+ }
+ st[sp] = &str_undef;
+ rschar = old_rschar;
+ rslen = old_rslen;
+ if (gimme == G_ARRAY) {
+ --sp;
+ str_2mortal(str);
+ goto array_return;
+ }
+ break;
+ }
+ else {
+ stab_io(last_in_stab)->lines++;
+ st[sp] = str;
+#ifdef TAINT
+ str->str_tainted = 1; /* Anything from the outside world...*/
+#endif
+ if (argflags & AF_POST) {
+ if (str->str_cur > 0)
+ str->str_cur--;
+ if (str->str_ptr[str->str_cur] == rschar)
+ str->str_ptr[str->str_cur] = '\0';
+ else
+ str->str_cur++;
+ for (tmps = str->str_ptr; *tmps; tmps++)
+ if (!isalpha(*tmps) && !isdigit(*tmps) &&
+ index("$&*(){}[]'\";\\|?<>~`",*tmps))
+ break;
+ if (*tmps && stat(str->str_ptr,&statbuf) < 0)
+ goto keepgoing; /* unmatched wildcard? */
+ }
+ if (gimme == G_ARRAY) {
+ if (str->str_len - str->str_cur > 20) {
+ str->str_len = str->str_cur+1;
+ Renew(str->str_ptr, str->str_len, char);
+ }
+ str_2mortal(str);
+ if (++sp > stack->ary_max) {
+ astore(stack, sp, Nullstr);
+ st = stack->ary_array;
+ }
+ str = Str_new(58,80);
+ goto keepgoing;
+ }
+ else if (!when && str->str_len - str->str_cur > 80) {
+ /* try to reclaim a bit of scalar space on 1st alloc */
+ if (str->str_cur < 60)
+ str->str_len = 80;
+ else
+ str->str_len = str->str_cur+40; /* allow some slop */
+ Renew(str->str_ptr, str->str_len, char);
+ }
+ }
+ rschar = old_rschar;
+ rslen = old_rslen;
+#ifdef DEBUGGING
+ tmps = "READ";
+#endif
+ break;
+ }
+#ifdef DEBUGGING
+ if (debug & 8)
+ deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp]));
+#endif
+ if (anum < 8)
+ arglast[anum] = sp;
+ }
st += arglast[0];
+#ifdef SMALLSWITCHES
+ if (optype < O_CHOWN)
+#endif
switch (optype) {
case O_RCAT:
STABSET(str);
STABSET(str);
break;
case O_REPEAT:
- STR_SSET(str,st[1]);
- anum = (int)str_gnum(st[2]);
+ if (gimme == G_ARRAY && arg[1].arg_flags & AF_ARYOK) {
+ sp = do_repeatary(arglast);
+ goto array_return;
+ }
+ STR_SSET(str,st[arglast[1] - arglast[0]]);
+ anum = (int)str_gnum(st[arglast[2] - arglast[0]]);
if (anum >= 1) {
tmpstr = Str_new(50, 0);
- str_sset(tmpstr,str);
+ tmps = str_get(str);
+ str_nset(tmpstr,tmps,str->str_cur);
tmps = str_get(tmpstr); /* force to be string */
STR_GROW(str, (anum * str->str_cur) + 1);
repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum);
str->str_cur *= anum;
str->str_ptr[str->str_cur] = '\0';
+ str->str_nok = 0;
+ str_free(tmpstr);
}
else
str_sset(str,&str_no);
goto array_return;
}
else if (str != stab_val(defstab)) {
+ if (str->str_len) {
+ if (str->str_state == SS_INCR)
+ Str_Grow(str,0);
+ Safefree(str->str_ptr);
+ str->str_ptr = Nullch;
+ str->str_len = 0;
+ }
str->str_pok = str->str_nok = 0;
STABSET(str);
}
value *= str_gnum(st[2]);
goto donumset;
case O_DIVIDE:
- if ((value = str_gnum(st[2])) == 0.0)
- fatal("Illegal division by zero");
+ if ((value = str_gnum(st[2])) == 0.0)
+ fatal("Illegal division by zero");
+#ifdef cray
+ /* insure that 20./5. == 4. */
+ {
+ double x;
+ int k;
+ x = str_gnum(st[1]);
+ if ((double)(int)x == x &&
+ (double)(int)value == value &&
+ (k = (int)x/(int)value)*(int)value == (int)x) {
+ value = k;
+ } else {
+ value = x/value;
+ }
+ }
+#else
value = str_gnum(st[1]) / value;
+#endif
goto donumset;
case O_MODULO:
tmplong = (long) str_gnum(st[2]);
break;
case O_DBMOPEN:
#ifdef SOME_DBM
- stab = arg[1].arg_ptr.arg_stab;
+ anum = arg[1].arg_type & A_MASK;
+ if (anum == A_WORD || anum == A_STAB)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(st[1]),TRUE);
if (st[3]->str_nok || st[3]->str_pok)
anum = (int)str_gnum(st[3]);
else
#endif
case O_DBMCLOSE:
#ifdef SOME_DBM
- stab = arg[1].arg_ptr.arg_stab;
+ if ((arg[1].arg_type & A_MASK) == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(st[1]),TRUE);
hdbmclose(stab_hash(stab));
goto say_yes;
#else
if (!str)
goto say_undef;
if (ary->ary_flags & ARF_REAL)
- (void)str_2static(str);
+ (void)str_2mortal(str);
break;
case O_UNPACK:
sp = do_unpack(str,gimme,arglast);
case O_WARN:
if (arglast[2] - arglast[1] != 1) {
do_join(str,arglast);
- tmps = str_get(st[1]);
+ tmps = str_get(str);
}
else {
str = st[2];
case O_DIE:
if (arglast[2] - arglast[1] != 1) {
do_join(str,arglast);
- tmps = str_get(st[1]);
+ tmps = str_get(str);
}
else {
str = st[2];
maxarg = 0;
if (!stab_io(stab) || !stab_io(stab)->ifp)
goto say_undef;
-#ifdef SOCKET
+#ifdef HAS_SOCKET
if (optype == O_RECV) {
argtype = sizeof buf;
+ STR_GROW(st[2], anum+1), (tmps = str_get(st[2])); /* sneaky */
anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, maxarg,
buf, &argtype);
if (anum >= 0) {
goto badsock;
#endif
STR_GROW(st[2], anum+maxarg+1), (tmps = str_get(st[2])); /* sneaky */
-#ifdef SOCKET
+#ifdef HAS_SOCKET
if (stab_io(stab)->type == 's') {
argtype = sizeof buf;
anum = recvfrom(fileno(stab_io(stab)->ifp), tmps+maxarg, anum, 0,
optype = 0;
anum = write(fileno(stab_io(stab)->ifp), tmps+optype, anum);
}
-#ifdef SOCKET
+#ifdef HAS_SOCKET
else if (maxarg >= 4) {
if (maxarg > 4)
warn("Too many args on send");
lastsize = arglast[2] - arglast[1];
}
else
- lastretstr = str_static(st[arglast[2] - arglast[0]]);
+ lastretstr = str_mortal(st[arglast[2] - arglast[0]]);
goto dopop;
case O_REDO:
case O_NEXT:
optype = loop_stack[loop_ptr].loop_sp - lastspbase; /* negative */
if (optype) {
for (anum = lastsize; anum > 0; anum--,st++)
- st[optype] = str_static(st[0]);
+ st[optype] = str_mortal(st[0]);
}
longjmp(loop_stack[loop_ptr].loop_env, O_LAST);
}
gimme,arglast);
goto array_return;
case O_CRYPT:
-#ifdef CRYPT
+#ifdef HAS_CRYPT
tmps = str_get(st[1]);
#ifdef FCRYPT
str_set(str,fcrypt(tmps,str_get(st[2])));
value = str_gnum(stab_val(defstab));
else
value = str_gnum(st[1]);
+ if (value <= 0.0)
+ fatal("Can't take log of %g\n", value);
value = log(value);
goto donumset;
case O_SQRT:
value = str_gnum(stab_val(defstab));
else
value = str_gnum(st[1]);
+ if (value < 0.0)
+ fatal("Can't take sqrt of %g\n", value);
value = sqrt(value);
goto donumset;
case O_INT:
#endif
goto donumset;
case O_ALARM:
+#ifdef HAS_ALARM
if (maxarg < 1)
tmps = str_get(stab_val(defstab));
else
goto say_undef;
value = (double)anum;
goto donumset;
+#else
+ fatal("Unsupported function alarm");
+ break;
+#endif
case O_SLEEP:
if (maxarg < 1)
tmps = Nullch;
st = stack->ary_array;
maxarg = sp - arglast[0];
str_free(arg[1].arg_ptr.arg_str);
+ arg[1].arg_ptr.arg_str = Nullstr;
str_free(arg[2].arg_ptr.arg_str);
+ arg[2].arg_ptr.arg_str = Nullstr;
arg->arg_type = O_ARRAY;
arg[1].arg_type = A_STAB|A_DONT;
arg->arg_len = 1;
}
break;
case O_FORK:
-#ifdef FORK
+#ifdef HAS_FORK
anum = fork();
if (!anum) {
if (tmpstab = stabent("$",allstabs))
break;
#endif
case O_WAIT:
-#ifdef WAIT
+#ifdef HAS_WAIT
#ifndef lint
anum = wait(&argflags);
if (anum > 0)
break;
#endif
case O_WAITPID:
-#ifdef WAIT
+#ifdef HAS_WAIT
#ifndef lint
anum = (int)str_gnum(st[1]);
optype = (int)str_gnum(st[2]);
break;
#endif
case O_SYSTEM:
-#ifdef FORK
+#ifdef HAS_FORK
#ifdef TAINT
if (arglast[2] - arglast[1] == 1) {
taintenv();
else if (arglast[2] - arglast[1] != 1)
value = (double)do_aexec(Nullstr,arglast);
else {
- value = (double)do_exec(str_get(str_static(st[2])));
+ value = (double)do_exec(str_get(str_mortal(st[2])));
}
_exit(-1);
#else /* ! FORK */
else if (arglast[2] - arglast[1] != 1)
value = (double)do_aspawn(Nullstr,arglast);
else {
- value = (double)do_spawn(str_get(str_static(st[2])));
+ value = (double)do_spawn(str_get(str_mortal(st[2])));
}
goto donumset;
#endif /* FORK */
else if (arglast[2] - arglast[1] != 1)
value = (double)do_aexec(Nullstr,arglast);
else {
- value = (double)do_exec(str_get(str_static(st[2])));
+ value = (double)do_exec(str_get(str_mortal(st[2])));
}
goto donumset;
case O_HEX:
- argtype = 4;
- goto snarfnum;
+ if (maxarg < 1)
+ tmps = str_get(stab_val(defstab));
+ else
+ tmps = str_get(st[1]);
+ value = (double)scanhex(tmps, 99, &argtype);
+ goto donumset;
case O_OCT:
- argtype = 3;
-
- snarfnum:
- tmplong = 0;
if (maxarg < 1)
tmps = str_get(stab_val(defstab));
else
tmps = str_get(st[1]);
- for (;;) {
- switch (*tmps) {
- default:
- goto out;
- case '8': case '9':
- if (argtype != 4)
- goto out;
- /* FALL THROUGH */
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7':
- tmplong <<= argtype;
- tmplong += *tmps++ & 15;
- break;
- case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
- case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
- if (argtype != 4)
- goto out;
- tmplong <<= 4;
- tmplong += (*tmps++ & 7) + 9;
- break;
- case 'x':
- argtype = 4;
- tmps++;
- break;
- }
- }
- out:
- value = (double)tmplong;
+ while (*tmps && isascii(*tmps) && (isspace(*tmps) || *tmps == '0'))
+ tmps++;
+ if (*tmps == 'x')
+ value = (double)scanhex(++tmps, 99, &argtype);
+ else
+ value = (double)scanoct(tmps, 99, &argtype);
goto donumset;
+#ifdef SMALLSWITCHES
+ }
+ else
+ switch (optype) {
+#endif
case O_CHOWN:
-#ifdef CHOWN
+#ifdef HAS_CHOWN
value = (double)apply(optype,arglast);
goto donumset;
#else
break;
#endif
case O_KILL:
-#ifdef KILL
+#ifdef HAS_KILL
value = (double)apply(optype,arglast);
goto donumset;
#else
value = (double)apply(optype,arglast);
goto donumset;
case O_UMASK:
-#ifdef UMASK
+#ifdef HAS_UMASK
if (maxarg < 1) {
anum = umask(0);
(void)umask(anum);
fatal("Unsupported function umask");
break;
#endif
-#ifdef SYSVIPC
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
case O_MSGGET:
case O_SHMGET:
case O_SEMGET:
#ifdef TAINT
taintproper("Insecure dependency in rename");
#endif
-#ifdef RENAME
+#ifdef HAS_RENAME
value = (double)(rename(tmps,tmps2) >= 0);
#else
if (same_dirent(tmps2, tmps)) /* can always rename to same name */
#endif
goto donumset;
case O_LINK:
-#ifdef LINK
+#ifdef HAS_LINK
tmps = str_get(st[1]);
tmps2 = str_get(st[2]);
#ifdef TAINT
#ifdef TAINT
taintproper("Insecure dependency in mkdir");
#endif
-#ifdef MKDIR
+#ifdef HAS_MKDIR
value = (double)(mkdir(tmps,anum) >= 0);
goto donumset;
#else
(void)strcpy(buf,"mkdir ");
#endif
-#if !defined(MKDIR) || !defined(RMDIR)
+#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
one_liner:
for (tmps2 = buf+6; *tmps; ) {
*tmps2++ = '\\';
#ifdef TAINT
taintproper("Insecure dependency in rmdir");
#endif
-#ifdef RMDIR
+#ifdef HAS_RMDIR
value = (double)(rmdir(tmps) >= 0);
goto donumset;
#else
(void)strcpy(buf,"rmdir ");
- goto one_liner; /* see above in MKDIR */
+ goto one_liner; /* see above in HAS_MKDIR */
#endif
case O_GETPPID:
-#ifdef GETPPID
+#ifdef HAS_GETPPID
value = (double)getppid();
goto donumset;
#else
break;
#endif
case O_GETPGRP:
-#ifdef GETPGRP
+#ifdef HAS_GETPGRP
if (maxarg < 1)
anum = 0;
else
break;
#endif
case O_SETPGRP:
-#ifdef SETPGRP
+#ifdef HAS_SETPGRP
argtype = (int)str_gnum(st[1]);
anum = (int)str_gnum(st[2]);
#ifdef TAINT
break;
#endif
case O_GETPRIORITY:
-#ifdef GETPRIORITY
+#ifdef HAS_GETPRIORITY
argtype = (int)str_gnum(st[1]);
anum = (int)str_gnum(st[2]);
value = (double)getpriority(argtype,anum);
break;
#endif
case O_SETPRIORITY:
-#ifdef SETPRIORITY
+#ifdef HAS_SETPRIORITY
argtype = (int)str_gnum(st[1]);
anum = (int)str_gnum(st[2]);
optype = (int)str_gnum(st[3]);
break;
#endif
case O_CHROOT:
-#ifdef CHROOT
+#ifdef HAS_CHROOT
if (maxarg < 1)
tmps = str_get(stab_val(defstab));
else
STABSET(str);
break;
case O_FLOCK:
-#ifdef FLOCK
+#ifdef HAS_FLOCK
if (maxarg <= 0)
stab = last_in_stab;
else if ((arg[1].arg_type & A_MASK) == A_WORD)
goto say_yes;
goto say_no;
case O_SYMLINK:
-#ifdef SYMLINK
+#ifdef HAS_SYMLINK
tmps = str_get(st[1]);
tmps2 = str_get(st[2]);
#ifdef TAINT
fatal("Unsupported function symlink");
#endif
case O_READLINK:
-#ifdef SYMLINK
+#ifdef HAS_SYMLINK
if (maxarg < 1)
tmps = str_get(stab_val(defstab));
else
str_nset(str,buf,anum);
break;
#else
- fatal("Unsupported function readlink");
+ goto say_undef; /* just pretend it's a normal file */
#endif
case O_FTSUID:
#ifdef S_ISUID
case O_FTBINARY:
str = do_fttext(arg,st[1]);
break;
-#ifdef SOCKET
+#ifdef HAS_SOCKET
case O_SOCKET:
if ((arg[1].arg_type & A_MASK) == A_WORD)
stab = arg[1].arg_ptr.arg_stab;
sp = do_getsockname(optype,stab,arglast);
goto array_return;
-#else /* SOCKET not defined */
+#else /* HAS_SOCKET not defined */
case O_SOCKET:
case O_BIND:
case O_CONNECT:
case O_GETPEERNAME:
badsock:
fatal("Unsupported socket function");
-#endif /* SOCKET */
+#endif /* HAS_SOCKET */
case O_SSELECT:
-#ifdef SELECT
+#ifdef HAS_SELECT
sp = do_select(gimme,arglast);
goto array_return;
#else
case O_GPWNAM:
case O_GPWUID:
case O_GPWENT:
-#ifdef PASSWD
+#ifdef HAS_PASSWD
sp = do_gpwent(optype,
gimme,arglast);
goto array_return;
case O_GGRNAM:
case O_GGRGID:
case O_GGRENT:
-#ifdef GROUP
+#ifdef HAS_GROUP
sp = do_ggrent(optype,
gimme,arglast);
goto array_return;
break;
#endif
case O_GETLOGIN:
-#ifdef GETLOGIN
+#ifdef HAS_GETLOGIN
if (!(tmps = getlogin()))
goto say_undef;
str_set(str,tmps);
value = (double)do_syscall(arglast);
goto donumset;
case O_PIPE:
-#ifdef PIPE
+#ifdef HAS_PIPE
if ((arg[1].arg_type & A_MASK) == A_WORD)
stab = arg[1].arg_ptr.arg_stab;
else
+++ /dev/null
-/* This file is included by eval.c. It's separate from eval.c to keep
- * kit sizes from getting too big.
- */
-
-/* $Header: evalargs.xc,v 3.0.1.9 91/01/11 18:00:18 lwall Locked $
- *
- * $Log: evalargs.xc,v $
- * Revision 3.0.1.9 91/01/11 18:00:18 lwall
- * patch42: <> input to individual array elements was suboptimal
- *
- * Revision 3.0.1.8 90/11/10 01:35:49 lwall
- * patch38: array slurps are now faster and take less memory
- *
- * Revision 3.0.1.7 90/10/15 16:48:11 lwall
- * patch29: non-existent array values no longer cause core dumps
- * patch29: added caller
- *
- * Revision 3.0.1.6 90/08/09 03:37:15 lwall
- * patch19: passing *name to subroutine now forces filehandle and array creation
- * patch19: `command` in array context now returns array of lines
- * patch19: <handle> input is a little more efficient
- *
- * Revision 3.0.1.5 90/03/27 15:54:42 lwall
- * patch16: MSDOS support
- *
- * Revision 3.0.1.4 90/02/28 17:38:37 lwall
- * patch9: $#foo -= 2 didn't work
- *
- * Revision 3.0.1.3 89/11/17 15:25:07 lwall
- * patch5: constant numeric subscripts disappeared in ?:
- *
- * Revision 3.0.1.2 89/11/11 04:33:05 lwall
- * patch2: Configure now locates csh
- *
- * Revision 3.0.1.1 89/10/26 23:12:55 lwall
- * patch1: glob didn't free a temporary string
- *
- * Revision 3.0 89/10/18 15:17:16 lwall
- * 3.0 baseline
- *
- */
-
- for (anum = 1; anum <= maxarg; anum++) {
- argflags = arg[anum].arg_flags;
- argtype = arg[anum].arg_type;
- argptr = arg[anum].arg_ptr;
- re_eval:
- switch (argtype) {
- default:
- st[++sp] = &str_undef;
-#ifdef DEBUGGING
- tmps = "NULL";
-#endif
- break;
- case A_EXPR:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "EXPR";
- deb("%d.EXPR =>\n",anum);
- }
-#endif
- sp = eval(argptr.arg_arg,
- (argflags & AF_ARYOK) ? G_ARRAY : G_SCALAR, sp);
- if (sp + (maxarg - anum) > stack->ary_max)
- astore(stack, sp + (maxarg - anum), Nullstr);
- st = stack->ary_array; /* possibly reallocated */
- break;
- case A_CMD:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "CMD";
- deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd);
- }
-#endif
- sp = cmd_exec(argptr.arg_cmd, gimme, sp);
- if (sp + (maxarg - anum) > stack->ary_max)
- astore(stack, sp + (maxarg - anum), Nullstr);
- st = stack->ary_array; /* possibly reallocated */
- break;
- case A_LARYSTAB:
- ++sp;
- switch (optype) {
- case O_ITEM2: argtype = 2; break;
- case O_ITEM3: argtype = 3; break;
- default: argtype = anum; break;
- }
- str = afetch(stab_array(argptr.arg_stab),
- arg[argtype].arg_len - arybase, TRUE);
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
- arg[argtype].arg_len);
- tmps = buf;
- }
-#endif
- goto do_crement;
- case A_ARYSTAB:
- switch (optype) {
- case O_ITEM2: argtype = 2; break;
- case O_ITEM3: argtype = 3; break;
- default: argtype = anum; break;
- }
- st[++sp] = afetch(stab_array(argptr.arg_stab),
- arg[argtype].arg_len - arybase, FALSE);
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
- arg[argtype].arg_len);
- tmps = buf;
- }
-#endif
- break;
- case A_STAR:
- stab = argptr.arg_stab;
- st[++sp] = (STR*)stab;
- if (!stab_xarray(stab))
- aadd(stab);
- if (!stab_xhash(stab))
- hadd(stab);
- if (!stab_io(stab))
- stab_io(stab) = stio_new();
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"STAR *%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_LSTAR:
- str = st[++sp] = (STR*)argptr.arg_stab;
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LSTAR *%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_STAB:
- st[++sp] = STAB_STR(argptr.arg_stab);
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_LEXPR:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "LEXPR";
- deb("%d.LEXPR =>\n",anum);
- }
-#endif
- if (argflags & AF_ARYOK) {
- sp = eval(argptr.arg_arg, G_ARRAY, sp);
- if (sp + (maxarg - anum) > stack->ary_max)
- astore(stack, sp + (maxarg - anum), Nullstr);
- st = stack->ary_array; /* possibly reallocated */
- }
- else {
- sp = eval(argptr.arg_arg, G_SCALAR, sp);
- st = stack->ary_array; /* possibly reallocated */
- str = st[sp];
- goto do_crement;
- }
- break;
- case A_LVAL:
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LVAL $%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- ++sp;
- str = STAB_STR(argptr.arg_stab);
- if (!str)
- fatal("panic: A_LVAL");
- do_crement:
- assigning = TRUE;
- if (argflags & AF_PRE) {
- if (argflags & AF_UP)
- str_inc(str);
- else
- str_dec(str);
- STABSET(str);
- st[sp] = str;
- str = arg->arg_ptr.arg_str;
- }
- else if (argflags & AF_POST) {
- st[sp] = str_static(str);
- if (argflags & AF_UP)
- str_inc(str);
- else
- str_dec(str);
- STABSET(str);
- str = arg->arg_ptr.arg_str;
- }
- else
- st[sp] = str;
- break;
- case A_LARYLEN:
- ++sp;
- stab = argptr.arg_stab;
- str = stab_array(argptr.arg_stab)->ary_magic;
- if (optype != O_SASSIGN || argflags & (AF_PRE|AF_POST))
- str_numset(str,(double)(stab_array(stab)->ary_fill+arybase));
-#ifdef DEBUGGING
- tmps = "LARYLEN";
-#endif
- if (!str)
- fatal("panic: A_LEXPR");
- goto do_crement;
- case A_ARYLEN:
- stab = argptr.arg_stab;
- st[++sp] = stab_array(stab)->ary_magic;
- str_numset(st[sp],(double)(stab_array(stab)->ary_fill+arybase));
-#ifdef DEBUGGING
- tmps = "ARYLEN";
-#endif
- break;
- case A_SINGLE:
- st[++sp] = argptr.arg_str;
-#ifdef DEBUGGING
- tmps = "SINGLE";
-#endif
- break;
- case A_DOUBLE:
- (void) interp(str,argptr.arg_str,sp);
- st = stack->ary_array;
- st[++sp] = str;
-#ifdef DEBUGGING
- tmps = "DOUBLE";
-#endif
- break;
- case A_BACKTICK:
- tmps = str_get(interp(str,argptr.arg_str,sp));
- st = stack->ary_array;
-#ifdef TAINT
- taintproper("Insecure dependency in ``");
-#endif
- fp = mypopen(tmps,"r");
- str_set(str,"");
- if (fp) {
- if (gimme == G_SCALAR) {
- while (str_gets(str,fp,str->str_cur) != Nullch)
- ;
- }
- else {
- for (;;) {
- if (++sp > stack->ary_max) {
- astore(stack, sp, Nullstr);
- st = stack->ary_array;
- }
- str = st[sp] = Str_new(56,80);
- if (str_gets(str,fp,0) == Nullch) {
- sp--;
- break;
- }
- if (str->str_len - str->str_cur > 20) {
- str->str_len = str->str_cur+1;
- Renew(str->str_ptr, str->str_len, char);
- }
- str_2static(str);
- }
- }
- statusvalue = mypclose(fp);
- }
- else
- statusvalue = -1;
-
- if (gimme == G_SCALAR)
- st[++sp] = str;
-#ifdef DEBUGGING
- tmps = "BACK";
-#endif
- break;
- case A_WANTARRAY:
- {
- if (curcsv->wantarray == G_ARRAY)
- st[++sp] = &str_yes;
- else
- st[++sp] = &str_no;
- }
-#ifdef DEBUGGING
- tmps = "WANTARRAY";
-#endif
- break;
- case A_INDREAD:
- last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE);
- old_record_separator = record_separator;
- goto do_read;
- case A_GLOB:
- argflags |= AF_POST; /* enable newline chopping */
- last_in_stab = argptr.arg_stab;
- old_record_separator = record_separator;
-#ifdef MSDOS
- record_separator = 0;
-#else
-#ifdef CSH
- record_separator = 0;
-#else
- record_separator = '\n';
-#endif /* !CSH */
-#endif /* !MSDOS */
- goto do_read;
- case A_READ:
- last_in_stab = argptr.arg_stab;
- old_record_separator = record_separator;
- do_read:
- if (anum > 1) /* assign to scalar */
- gimme = G_SCALAR; /* force context to scalar */
- if (gimme == G_ARRAY)
- str = Str_new(57,0);
- ++sp;
- fp = Nullfp;
- if (stab_io(last_in_stab)) {
- fp = stab_io(last_in_stab)->ifp;
- if (!fp) {
- if (stab_io(last_in_stab)->flags & IOF_ARGV) {
- if (stab_io(last_in_stab)->flags & IOF_START) {
- stab_io(last_in_stab)->flags &= ~IOF_START;
- stab_io(last_in_stab)->lines = 0;
- if (alen(stab_array(last_in_stab)) < 0) {
- tmpstr = str_make("-",1); /* assume stdin */
- (void)apush(stab_array(last_in_stab), tmpstr);
- }
- }
- fp = nextargv(last_in_stab);
- if (!fp) { /* Note: fp != stab_io(last_in_stab)->ifp */
- (void)do_close(last_in_stab,FALSE); /* now it does*/
- stab_io(last_in_stab)->flags |= IOF_START;
- }
- }
- else if (argtype == A_GLOB) {
- (void) interp(str,stab_val(last_in_stab),sp);
- st = stack->ary_array;
- tmpstr = Str_new(55,0);
-#ifdef MSDOS
- str_set(tmpstr, "perlglob ");
- str_scat(tmpstr,str);
- str_cat(tmpstr," |");
-#else
-#ifdef CSH
- str_nset(tmpstr,cshname,cshlen);
- str_cat(tmpstr," -cf 'set nonomatch; glob ");
- str_scat(tmpstr,str);
- str_cat(tmpstr,"'|");
-#else
- str_set(tmpstr, "echo ");
- str_scat(tmpstr,str);
- str_cat(tmpstr,
- "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
-#endif /* !CSH */
-#endif /* !MSDOS */
- (void)do_open(last_in_stab,tmpstr->str_ptr,
- tmpstr->str_cur);
- fp = stab_io(last_in_stab)->ifp;
- str_free(tmpstr);
- }
- }
- }
- if (!fp && dowarn)
- warn("Read on closed filehandle <%s>",stab_name(last_in_stab));
- when = str->str_len; /* remember if already alloced */
- if (!when)
- Str_Grow(str,80); /* try short-buffering it */
- keepgoing:
- if (!fp)
- st[sp] = &str_undef;
- else if (!str_gets(str,fp, optype == O_RCAT ? str->str_cur : 0)) {
- clearerr(fp);
- if (stab_io(last_in_stab)->flags & IOF_ARGV) {
- fp = nextargv(last_in_stab);
- if (fp)
- goto keepgoing;
- (void)do_close(last_in_stab,FALSE);
- stab_io(last_in_stab)->flags |= IOF_START;
- }
- else if (argflags & AF_POST) {
- (void)do_close(last_in_stab,FALSE);
- }
- st[sp] = &str_undef;
- record_separator = old_record_separator;
- if (gimme == G_ARRAY) {
- --sp;
- str_2static(str);
- goto array_return;
- }
- break;
- }
- else {
- stab_io(last_in_stab)->lines++;
- st[sp] = str;
-#ifdef TAINT
- str->str_tainted = 1; /* Anything from the outside world...*/
-#endif
- if (argflags & AF_POST) {
- if (str->str_cur > 0)
- str->str_cur--;
- if (str->str_ptr[str->str_cur] == record_separator)
- str->str_ptr[str->str_cur] = '\0';
- else
- str->str_cur++;
- for (tmps = str->str_ptr; *tmps; tmps++)
- if (!isalpha(*tmps) && !isdigit(*tmps) &&
- index("$&*(){}[]'\";\\|?<>~`",*tmps))
- break;
- if (*tmps && stat(str->str_ptr,&statbuf) < 0)
- goto keepgoing; /* unmatched wildcard? */
- }
- if (gimme == G_ARRAY) {
- if (str->str_len - str->str_cur > 20) {
- str->str_len = str->str_cur+1;
- Renew(str->str_ptr, str->str_len, char);
- }
- str_2static(str);
- if (++sp > stack->ary_max) {
- astore(stack, sp, Nullstr);
- st = stack->ary_array;
- }
- str = Str_new(58,80);
- goto keepgoing;
- }
- else if (!when && str->str_len - str->str_cur > 80) {
- /* try to reclaim a bit of scalar space on 1st alloc */
- if (str->str_cur < 60)
- str->str_len = 80;
- else
- str->str_len = str->str_cur+40; /* allow some slop */
- Renew(str->str_ptr, str->str_len, char);
- }
- }
- record_separator = old_record_separator;
-#ifdef DEBUGGING
- tmps = "READ";
-#endif
- break;
- }
-#ifdef DEBUGGING
- if (debug & 8)
- deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp]));
-#endif
- if (anum < 8)
- arglast[anum] = sp;
- }
-/* $Header: form.c,v 3.0.1.4 91/01/11 18:04:07 lwall Locked $
+/* $Header: form.c,v 4.0 91/03/20 01:19:23 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: form.c,v $
- * Revision 3.0.1.4 91/01/11 18:04:07 lwall
- * patch42: the @* format counted lines wrong
- * patch42: the @* format didn't handle lines with nulls or without newline
- *
- * Revision 3.0.1.3 90/10/15 17:26:24 lwall
- * patch29: added @###.## fields to format
- *
- * Revision 3.0.1.2 90/08/09 03:38:40 lwall
- * patch19: did preliminary work toward debugging packages and evals
- *
- * Revision 3.0.1.1 90/02/28 17:39:34 lwall
- * patch9: ... in format threw off subsequent field
- *
- * Revision 3.0 89/10/18 15:17:26 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:19:23 lwall
+ * 4.0 baseline.
*
*/
}
else if (fcmd->f_flags & FC_REPEAT)
nextfcmd = linebeg;
+ else
+ linebeg = fcmd->f_next;
}
else
linebeg = fcmd->f_next;
-/* $Header: form.h,v 3.0.1.1 90/10/15 17:26:57 lwall Locked $
+/* $Header: form.h,v 4.0 91/03/20 01:19:37 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: form.h,v $
- * Revision 3.0.1.1 90/10/15 17:26:57 lwall
- * patch29: added @###.## fields to format
- *
- * Revision 3.0 89/10/18 15:17:39 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:19:37 lwall
+ * 4.0 baseline.
*
*/
ln ../../config.sh . || \
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
- fi
+ fi 2>/dev/null
. ./config.sh
;;
esac
chdir '/usr/include' || die "Can't cd /usr/include";
-%isatype = ('char',1,'short',1,'int',1,'long',1);
+@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) {
- ($outfile = $file) =~ s/\.h$/.ph/ || next;
- print "$file -> $outfile\n";
- if ($file =~ m|^(.*)/|) {
- $dir = $1;
- if (!-d "$perlincl/$dir") {
- mkdir("$perlincl/$dir",0777);
+ 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";
}
- open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
- open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n";
while (<IN>) {
chop;
while (/\\$/) {
}
next;
};
- s/^(struct\s+\w+)// && do {$new .= "'$1'"; next;};
s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
$new .= '$sizeof';
next;
};
s/^([_a-zA-Z]\w*)// && do {
$id = $1;
+ if ($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;
}
$new .= " &$id";
}
elsif ($isatype{$id}) {
- $new .= "'$id'";
+ if ($new =~ /{\s*$/) {
+ $new .= "'$id'";
+ }
+ elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
+ $new =~ s/\(\s*$//;
+ s/^[\s*]*\)//;
+ }
+ else {
+ $new .= $id;
+ }
}
else {
$new .= ' &' . $id;
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
-/* $Header: handy.h,v 3.0.1.2 90/08/09 03:48:28 lwall Locked $
+/* $Header: handy.h,v 4.0 91/03/20 01:22:15 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: handy.h,v $
- * Revision 3.0.1.2 90/08/09 03:48:28 lwall
- * patch19: various MSDOS and OS/2 patches folded in
- *
- * Revision 3.0.1.1 89/11/17 15:25:55 lwall
- * patch5: some machines already define TRUE and FALSE
- *
- * Revision 3.0 89/10/18 15:18:24 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:22:15 lwall
+ * 4.0 baseline.
*
*/
-/* $Header: hash.c,v 3.0.1.7 90/10/20 02:10:00 lwall Locked $
+/* $Header: hash.c,v 4.0 91/03/20 01:22:26 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: hash.c,v $
- * Revision 3.0.1.7 90/10/20 02:10:00 lwall
- * patch37: hash.c called ndbm function on dbm system
- *
- * Revision 3.0.1.6 90/10/15 17:32:52 lwall
- * patch29: non-existent array values no longer cause core dumps
- * patch29: %foo = () will now clear dbm files
- * patch29: dbm files couldn't be opened read only
- * patch29: the cache array for dbm files wasn't correctly created on fetches
- *
- * Revision 3.0.1.5 90/08/13 22:18:27 lwall
- * patch28: defined(@array) and defined(%array) didn't work right
- *
- * Revision 3.0.1.4 90/08/09 03:50:22 lwall
- * patch19: dbmopen(name, 'filename', undef) now refrains from creating
- *
- * Revision 3.0.1.3 90/03/27 15:59:09 lwall
- * patch16: @dbmvalues{'foo','bar'} could use the same cache entry for both values
- *
- * Revision 3.0.1.2 89/12/21 20:03:39 lwall
- * patch7: errno may now be a macro with an lvalue
- *
- * Revision 3.0.1.1 89/11/11 04:34:18 lwall
- * patch2: CX/UX needed to set the key each time in associative iterators
- *
- * Revision 3.0 89/10/18 15:18:32 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:22:26 lwall
+ * 4.0 baseline.
*
*/
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);
if (bcmp(entry->hent_key,key,klen)) /* is this it? */
continue;
*oentry = entry->hent_next;
- str = str_static(entry->hent_val);
+ str = str_mortal(entry->hent_val);
hentfree(entry);
if (i)
tb->tbl_fill--;
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;
{
if (!hent)
return;
- str_2static(hent->hent_val); /* free between statements */
+ str_2mortal(hent->hent_val); /* free between statements */
Safefree(hent->hent_key);
Safefree(hent);
}
#ifdef SOME_DBM
datum dkey;
datum nextdkey;
-#ifdef NDBM
+#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 NDBM
+#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
#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 */
}
#ifdef SOME_DBM
if (tb->tbl_dbm) {
if (entry) {
-#ifdef NDBM
+#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.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 (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);
}
#ifdef SOME_DBM
-#if defined(FCNTL) && ! defined(O_CREAT)
-#include <fcntl.h>
+
+#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_CREAT 01000
#endif
-#ifndef NDBM
+#ifdef HAS_ODBM
static int dbmrefcnt = 0;
#endif
{
if (!tb)
return FALSE;
-#ifndef NDBM
+#ifdef HAS_ODBM
if (tb->tbl_dbm) /* never really closed it */
return TRUE;
#endif
tb->tbl_dbm = 0;
}
hclear(tb, FALSE); /* clear cache */
-#ifdef NDBM
+#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 = 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;
register HASH *tb;
{
if (tb && tb->tbl_dbm) {
-#ifdef NDBM
+#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");
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 NDBM
+#ifdef HAS_NDBM
dbm_clearerr(tb->tbl_dbm);
#endif
}
-/* $Header: hash.h,v 3.0.1.2 90/10/15 17:33:58 lwall Locked $
+/* $Header: hash.h,v 4.0 91/03/20 01:22:38 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: hash.h,v $
- * Revision 3.0.1.2 90/10/15 17:33:58 lwall
- * patch29: the debugger now understands packages and evals
- *
- * Revision 3.0.1.1 90/08/09 03:51:34 lwall
- * patch19: various MSDOS and OS/2 patches folded in
- *
- * Revision 3.0 89/10/18 15:18:39 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:22:38 lwall
+ * 4.0 baseline.
*
*/
SPAT *tbl_spatroot; /* list of spats for this package */
char *tbl_name; /* name, if a symbol table */
#ifdef SOME_DBM
-#ifdef NDBM
+#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 */
};
@scripts = 'h2ph';
@manpages = ('perl.man', 'h2ph.man');
+$version = sprintf("%5.3f", $]);
+$release = substr($version,0,3);
+$patchlevel = substr($version,3,2);
+
# Read in the config file.
open(CONFIG, "config.sh") || die "You haven't run Configure yet!\n";
if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; }
- $bin || die "No bin directory in config.sh\n";
--d $bin || die "$bin is not a directory\n";
--w $bin || die "$bin is not writable by you\n";
+ $installbin || die "No installbin directory in config.sh\n";
+-d $installbin || die "$installbin is not a directory\n";
+-w $installbin || die "$installbin is not writable by you\n"
+ unless $installbin =~ m#^/afs/#;
--x 'perl' || die "perl isn't executable!\n";
--x 'taintperl' || die "taintperl isn't executable!\n";
--x 'suidperl' || die "suidperl isn't executable!\n" if $d_dosuid;
+-x 'perl' || die "perl isn't executable!\n";
+-x 'taintperl' || die "taintperl isn't executable!\n";
+-x 'suidperl' || die "suidperl isn't executable!\n" if $d_dosuid;
--x 't/TEST' || die "You've never run 'make test'!\n";
+-x 't/TEST' || warn "WARNING: You've never run 'make test'!!!",
+ " (Installing anyway.)\n";
# First we install the version-numbered executables.
$ver = sprintf("%5.3f", $]);
-&unlink("$bin/perl$ver");
-&cmd("cp perl $bin/perl$ver");
+&unlink("$installbin/perl$ver");
+&cmd("cp perl $installbin/perl$ver");
-&unlink("$bin/tperl$ver");
-&cmd("cp taintperl $bin/tperl$ver");
-&chmod(0755, "$bin/tperl$ver"); # force non-suid for security
+&unlink("$installbin/tperl$ver");
+&cmd("cp taintperl $installbin/tperl$ver");
+&chmod(0755, "$installbin/tperl$ver"); # force non-suid for security
-&unlink("$bin/sperl$ver");
+&unlink("$installbin/sperl$ver");
if ($d_dosuid) {
- &cmd("cp suidperl $bin/sperl$ver");
- &chmod(04711, "$bin/sperl$ver");
+ &cmd("cp suidperl $installbin/sperl$ver");
+ &chmod(04711, "$installbin/sperl$ver");
}
exit 0 if $versiononly;
-# Make links to ordinary names if bin directory isn't current directory.
+# Make links to ordinary names if installbin directory isn't current directory.
-($bdev,$bino) = stat($bin);
+($bdev,$bino) = stat($installbin);
($ddev,$dino) = stat('.');
if ($bdev != $ddev || $bino != $dino) {
- &unlink("$bin/perl", "$bin/taintperl", "$bin/suidperl");
- &link("$bin/perl$ver", "$bin/perl");
- &link("$bin/tperl$ver", "$bin/taintperl");
- &link("$bin/sperl$ver", "$bin/suidperl") if $d_dosuid;
+ &unlink("$installbin/perl", "$installbin/taintperl", "$installbin/suidperl");
+ &link("$installbin/perl$ver", "$installbin/perl");
+ &link("$installbin/tperl$ver", "$installbin/taintperl");
+ &link("$installbin/sperl$ver", "$installbin/suidperl") if $d_dosuid;
}
# Make some enemies in the name of standardization. :-)
($udev,$uino) = stat("/usr/bin");
-if (($udev != $ddev || $uino != $dino) && !$nonono) {
+if (-w _ && ($udev != $ddev || $uino != $dino) && !$nonono) {
unlink "/usr/bin/perl";
- eval 'symlink("$bin/perl", "/usr/bin/perl")' ||
- eval 'link("$bin/perl", "/usr/bin/perl")' ||
- &cmd("cp $bin/perl /usr/bin");
+ eval 'symlink("$installbin/perl", "/usr/bin/perl")' ||
+ eval 'link("$installbin/perl", "/usr/bin/perl")' ||
+ &cmd("cp $installbin/perl /usr/bin");
}
# Install scripts.
&makedir($scriptdir);
for (@scripts) {
- &chmod(0755, $_);
&cmd("cp $_ $scriptdir");
+ &chmod(0755, "$scriptdir/$_");
}
# Install library files.
-&makedir($privlib);
+&makedir($installprivlib);
-($pdev,$pino) = stat($privlib);
+($pdev,$pino) = stat($installprivlib);
if ($pdev != $ddev || $pino != $dino) {
- &cmd("cd lib && cp *.pl $privlib");
+ &cmd("cd lib && cp *.pl $installprivlib");
}
# Install man pages.
-&makedir($mansrc);
-
-($mdev,$mino) = stat($mansrc);
-if ($mdev != $ddev || $mino != $dino) {
- for (@manpages) {
- ($new = $_) =~ s/man$/$manext/;
- &cmd("cp $_ $mansrc/$new");
+if ($mansrc ne '') {
+ &makedir($mansrc);
+
+ ($mdev,$mino) = stat($mansrc);
+ if ($mdev != $ddev || $mino != $dino) {
+ for (@manpages) {
+ ($new = $_) =~ s/man$/$manext/;
+ print STDERR " Installing $mansrc/$new\n";
+ next if $nonono;
+ open(MI,$_);
+ open(MO,">$mansrc/$new");
+ print MO ".ds RP Release $release Patchlevel $patchlevel\n";
+ while (<MI>) {
+ print MO;
+ }
+ close MI;
+ close MO;
+ }
}
}
# absolute value
sub main'fabs { #(fnum_str) return fnum_str
local($_) = &'fnorm($_[0]);
- substr($_,0,1) = '+'; # mash sign
+ substr($_,0,1) = '+' unless $_ eq 'NaN'; # mash sign
$_;
}
# absolute value
sub main'rabs { #(rat_num) return $rat_num
local($_) = &'rnorm($_[0]);
- substr($_,0,1) = '+';
+ substr($_,0,1) = '+' unless $_ eq 'NaN';
$_;
}
;#
;# Waldemar Kebsch, Federal Republic of Germany, November 1988
;# kebsch.pad@nixpbe.UUCP
-;# Modified March 1990 to better handle timezones
-;# $Id: ctime.pl,v 1.3 90/03/22 10:49:10 hakanson Exp $
+;# Modified March 1990, Feb 1991 to properly handle timezones
+;# $Id: ctime.pl,v 1.8 91/02/04 18:28:12 hakanson Exp $
;# Marion Hakanson (hakanson@cse.ogi.edu)
;# Oregon Graduate Institute of Science and Technology
;#
local($time) = @_;
local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
- # Use GMT if can't find local TZ
- $TZ = defined($ENV{'TZ'}) ? $ENV{'TZ'} : 'GMT';
+ # Determine what time zone is in effect.
+ # Use GMT if TZ is defined as null, local time if TZ undefined.
+ # There's no portable way to find the system default timezone.
+
+ $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '';
($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
($TZ eq 'GMT') ? gmtime($time) : localtime($time);
+
# Hack to deal with 'PST8PDT' format of TZ
- if ( $TZ =~ /-?\d+/ ) {
- $TZ = $isdst ? $' : $`;
+ # Note that this can't deal with all the esoteric forms, but it
+ # does recognize the most common: [:]STDoff[DST[off][,rule]]
+
+ if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){
+ $TZ = $isdst ? $4 : $1;
}
- $TZ .= " " unless $TZ eq "";
+ $TZ .= ' ' unless $TZ eq '';
+
$year += ($year < 70) ? 2000 : 1900;
sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n",
$DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year);
-;# $Header: getopt.pl,v 3.0.1.1 90/02/28 17:41:59 lwall Locked $
+;# $Header: getopt.pl,v 4.0 91/03/20 01:25:11 lwall Locked $
;# Process single-character switches with switch clustering. Pass one argument
;# which is a string containing all switches that take an argument. For each
-;# $Header: importenv.pl,v 3.0.1.1 90/08/09 03:56:38 lwall Locked $
+;# $Header: importenv.pl,v 4.0 91/03/20 01:25:28 lwall Locked $
;# This file, when interpreted, pulls the environment into normal variables.
;# Usage:
;# (stringwise) to $key. Pass flags for dictionary order and case folding.
sub look {
- local(*FH,$key,$fold) = @_;
+ local(*FH,$key,$dict,$fold) = @_;
local($max,$min,$mid,$_);
local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat(FH);
+++ /dev/null
-#
-# syslog.pl
-#
-# $Log: nsyslog.pl,v $
-# Revision 3.0.1.1 90/08/09 03:57:17 lwall
-# patch19: Initial revision
-#
-# Revision 1.2 90/06/11 18:45:30 18:45:30 root ()
-# - Changed 'warn' to 'mail|warning' in test call (to give example of
-# facility specification, and because 'warn' didn't work on HP-UX).
-# - Fixed typo in &openlog ("ncons" should be "cons").
-# - Added (package-global) $maskpri, and &setlogmask.
-# - In &syslog:
-# - put argument test ahead of &connect (why waste cycles?),
-# - allowed facility to be specified in &syslog's first arg (temporarily
-# overrides any $facility set in &openlog), just as in syslog(3C),
-# - do a return 0 when bit for $numpri not set in log mask (see syslog(3C)),
-# - changed $whoami code to use getlogin, getpwuid($<) and 'syslog'
-# (in that order) when $ident is null,
-# - made PID logging consistent with syslog(3C) and subject to $lo_pid only,
-# - fixed typo in "print CONS" statement ($<facility should be <$facility).
-# - changed \n to \r in print CONS (\r is useful, $message already has a \n).
-# - Changed &xlate to return -1 for an unknown name, instead of croaking.
-#
-#
-# tom christiansen <tchrist@convex.com>
-# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
-# NOTE: openlog now takes three arguments, just like openlog(3)
-#
-# call syslog() with a string priority and a list of printf() args
-# like syslog(3)
-#
-# usage: require 'syslog.pl';
-#
-# then (put these all in a script to test function)
-#
-#
-# do openlog($program,'cons,pid','user');
-# do syslog('info','this is another test');
-# do syslog('mail|warning','this is a better test: %d', time);
-# do closelog();
-#
-# do syslog('debug','this is the last test');
-# do openlog("$program $$",'ndelay','user');
-# do syslog('notice','fooprogram: this is really done');
-#
-# $! = 55;
-# do syslog('info','problem was %m'); # %m == $! in syslog(3)
-
-package syslog;
-
-$host = 'localhost' unless $host; # set $syslog'host to change
-
-require '/usr/local/lib/perl/syslog.ph';
-
-$maskpri = &LOG_UPTO(&LOG_DEBUG);
-
-sub main'openlog {
- ($ident, $logopt, $facility) = @_; # package vars
- $lo_pid = $logopt =~ /\bpid\b/;
- $lo_ndelay = $logopt =~ /\bndelay\b/;
- $lo_cons = $logopt =~ /\bcons\b/;
- $lo_nowait = $logopt =~ /\bnowait\b/;
- &connect if $lo_ndelay;
-}
-
-sub main'closelog {
- $facility = $ident = '';
- &disconnect;
-}
-
-sub main'setlogmask {
- local($oldmask) = $maskpri;
- $maskpri = shift;
- $oldmask;
-}
-
-sub main'syslog {
- local($priority) = shift;
- local($mask) = shift;
- local($message, $whoami);
- local(@words, $num, $numpri, $numfac, $sum);
- local($facility) = $facility; # may need to change temporarily.
-
- die "syslog: expected both priority and mask" unless $mask && $priority;
-
- @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
- undef $numpri;
- undef $numfac;
- foreach (@words) {
- $num = &xlate($_); # Translate word to number.
- if (/^kern$/ || $num < 0) {
- die "syslog: invalid level/facility: $_\n";
- }
- elsif ($num <= &LOG_PRIMASK) {
- die "syslog: too many levels given: $_\n" if defined($numpri);
- $numpri = $num;
- return 0 unless &LOG_MASK($numpri) & $maskpri;
- }
- else {
- die "syslog: too many facilities given: $_\n" if defined($numfac);
- $facility = $_;
- $numfac = $num;
- }
- }
-
- die "syslog: level must be given\n" unless defined($numpri);
-
- if (!defined($numfac)) { # Facility not specified in this call.
- $facility = 'user' unless $facility;
- $numfac = &xlate($facility);
- }
-
- &connect unless $connected;
-
- $whoami = $ident;
-
- if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
- $whoami = $1;
- $mask = $2;
- }
-
- unless ($whoami) {
- ($whoami = getlogin) ||
- ($whoami = getpwuid($<)) ||
- ($whoami = 'syslog');
- }
-
- $whoami .= "[$$]" if $lo_pid;
-
- $mask =~ s/%m/$!/g;
- $mask .= "\n" unless $mask =~ /\n$/;
- $message = sprintf ($mask, @_);
-
- $sum = $numpri + $numfac;
- unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
- if ($lo_cons) {
- if ($pid = fork) {
- unless ($lo_nowait) {
- do {$died = wait;} until $died == $pid || $died < 0;
- }
- }
- else {
- open(CONS,">/dev/console");
- print CONS "<$facility.$priority>$whoami: $message\r";
- exit if defined $pid; # if fork failed, we're parent
- close CONS;
- }
- }
- }
-}
-
-sub xlate {
- local($name) = @_;
- $name =~ y/a-z/A-Z/;
- $name = "LOG_$name" unless $name =~ /^LOG_/;
- $name = "syslog'$name";
- eval &$name || -1;
-}
-
-sub connect {
- $pat = 'S n C4 x8';
-
- $af_unix = 1;
- $af_inet = 2;
-
- $stream = 1;
- $datagram = 2;
-
- ($name,$aliases,$proto) = getprotobyname('udp');
- $udp = $proto;
-
- ($name,$aliase,$port,$proto) = getservbyname('syslog','udp');
- $syslog = $port;
-
- if (chop($myname = `hostname`)) {
- ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname);
- die "Can't lookup $myname\n" unless $name;
- @bytes = unpack("C4",$addrs[0]);
- }
- else {
- @bytes = (0,0,0,0);
- }
- $this = pack($pat, $af_inet, 0, @bytes);
-
- if ($host =~ /^\d+\./) {
- @bytes = split(/\./,$host);
- }
- else {
- ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host);
- die "Can't lookup $host\n" unless $name;
- @bytes = unpack("C4",$addrs[0]);
- }
- $that = pack($pat,$af_inet,$syslog,@bytes);
-
- socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
- bind(SYSLOG,$this) || die "bind: $!\n";
- connect(SYSLOG,$that) || die "connect: $!\n";
-
- local($old) = select(SYSLOG); $| = 1; select($old);
- $connected = 1;
-}
-
-sub disconnect {
- close SYSLOG;
- $connected = 0;
-}
-
-1;
package DB;
-$header = '$Header: perldb.pl,v 3.0.1.6 91/01/11 18:08:58 lwall Locked $';
+$header = '$Header: perldb.pl,v 4.0 91/03/20 01:25:50 lwall Locked $';
#
# 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.0 91/03/20 01:25:50 lwall
+# 4.0 baseline.
+#
# Revision 3.0.1.6 91/01/11 18:08:58 lwall
# patch42: @_ couldn't be accessed from debugger
#
print OUT $#stack . " levels deep in subroutine calls!\n"
if $single & 4;
$start = $line;
+ CMD:
while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) {
- $single = 0;
- $signal = 0;
- $cmd eq '' && exit 0;
- chop($cmd);
- $cmd =~ s/\\$// && do {
- print OUT " cont: ";
- $cmd .= &gets;
- redo;
- };
- $cmd =~ /^q$/ && exit 0;
- $cmd =~ /^$/ && ($cmd = $laststep);
- push(@hist,$cmd) if length($cmd) > 1;
- ($i) = split(/\s+/,$cmd);
- eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
- $cmd =~ /^h$/ && do {
- print OUT "
+ {
+ $single = 0;
+ $signal = 0;
+ $cmd eq '' && exit 0;
+ chop($cmd);
+ $cmd =~ s/\\$// && do {
+ print OUT " cont: ";
+ $cmd .= &gets;
+ redo CMD;
+ };
+ $cmd =~ /^q$/ && exit 0;
+ $cmd =~ /^$/ && ($cmd = $laststep);
+ push(@hist,$cmd) if length($cmd) > 1;
+ ($i) = split(/\s+/,$cmd);
+ eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
+ $cmd =~ /^h$/ && do {
+ print OUT "
T Stack trace.
s Single step.
n Next, steps over subroutine calls.
command Execute as a perl statement in current package.
";
- next; };
- $cmd =~ /^t$/ && do {
- $trace = !$trace;
- print OUT "Trace = ".($trace?"on":"off")."\n";
- next; };
- $cmd =~ /^S$/ && do {
- foreach $subname (sort(keys %sub)) {
- print OUT $subname,"\n";
- }
- next; };
- $cmd =~ s/^X\b/V $package/;
- $cmd =~ /^V$/ && do {
- $cmd = 'V $package'; };
- $cmd =~ /^V\s*(\S+)\s*(.*)/ && do {
- $packname = $1;
- @vars = split(' ',$2);
- do 'dumpvar.pl' unless defined &main'dumpvar;
- if (defined &main'dumpvar) {
- &main'dumpvar($packname,@vars);
- }
- else {
- print DB'OUT "dumpvar.pl not available.\n";
- }
- next; };
- $cmd =~ /^f\s*(.*)/ && do {
- $file = $1;
- if (!$file) {
- print OUT "The old f command is now the r command.\n";
- print OUT "The new f command switches filenames.\n";
- next;
- }
- if (!defined $_main{'_<' . $file}) {
- if (($try) = grep(m#^_<.*$file#, keys %_main)) {
- $file = substr($try,2);
- print "\n$file:\n";
+ next CMD; };
+ $cmd =~ /^t$/ && do {
+ $trace = !$trace;
+ print OUT "Trace = ".($trace?"on":"off")."\n";
+ next CMD; };
+ $cmd =~ /^S$/ && do {
+ foreach $subname (sort(keys %sub)) {
+ print OUT $subname,"\n";
+ }
+ next CMD; };
+ $cmd =~ s/^X\b/V $package/;
+ $cmd =~ /^V$/ && do {
+ $cmd = 'V $package'; };
+ $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
+ $packname = $1;
+ @vars = split(' ',$2);
+ do 'dumpvar.pl' unless defined &main'dumpvar;
+ if (defined &main'dumpvar) {
+ &main'dumpvar($packname,@vars);
+ }
+ else {
+ print DB'OUT "dumpvar.pl not available.\n";
}
- }
- if (!defined $_main{'_<' . $file}) {
- print OUT "There's no code here anything matching $file.\n";
- next;
- }
- elsif ($file ne $filename) {
- *dbline = "_<$file";
- $max = $#dbline;
- $filename = $file;
- $start = 1;
- $cmd = "l";
- } };
- $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
- $subname = $1;
- $subname = "main'" . $subname unless $subname =~ /'/;
- $subname = "main" . $subname if substr($subname,0,1) eq "'";
- ($file,$subrange) = split(/:/,$sub{$subname});
- if ($file ne $filename) {
- *dbline = "_<$file";
- $max = $#dbline;
- $filename = $file;
- }
- if ($subrange) {
- if (eval($subrange) < -$window) {
- $subrange =~ s/-.*/+/;
+ next CMD; };
+ $cmd =~ /^f\b\s*(.*)/ && do {
+ $file = $1;
+ if (!$file) {
+ print OUT "The old f command is now the r command.\n";
+ print OUT "The new f command switches filenames.\n";
+ next CMD;
}
- $cmd = "l $subrange";
- } else {
- print OUT "Subroutine $1 not found.\n";
- next;
- } };
- $cmd =~ /^w\s*(\d*)$/ && do {
- $incr = $window - 1;
- $start = $1 if $1;
- $start -= $preview;
- $cmd = 'l ' . $start . '-' . ($start + $incr); };
- $cmd =~ /^-$/ && do {
- $incr = $window - 1;
- $cmd = 'l ' . ($start-$window*2) . '+'; };
- $cmd =~ /^l$/ && do {
- $incr = $window - 1;
- $cmd = 'l ' . $start . '-' . ($start + $incr); };
- $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
- $start = $1 if $1;
- $incr = $2;
- $incr = $window - 1 unless $incr;
- $cmd = 'l ' . $start . '-' . ($start + $incr); };
- $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
- $end = (!$2) ? $max : ($4 ? $4 : $2);
- $end = $max if $end > $max;
- $i = $2;
- $i = $line if $i eq '.';
- $i = 1 if $i < 1;
- for (; $i <= $end; $i++) {
- print OUT "$i:\t", $dbline[$i];
- last if $signal;
- }
- $start = $i; # remember in case they want more
- $start = $max if $start > $max;
- next; };
- $cmd =~ /^D$/ && do {
- print OUT "Deleting all breakpoints...\n";
- for ($i = 1; $i <= $max ; $i++) {
- if (defined $dbline{$i}) {
- $dbline{$i} =~ s/^[^\0]+//;
- if ($dbline{$i} =~ s/^\0?$//) {
- delete $dbline{$i};
+ if (!defined $_main{'_<' . $file}) {
+ if (($try) = grep(m#^_<.*$file#, keys %_main)) {
+ $file = substr($try,2);
+ print "\n$file:\n";
}
}
- }
- next; };
- $cmd =~ /^L$/ && do {
- for ($i = 1; $i <= $max; $i++) {
- if (defined $dbline{$i}) {
+ if (!defined $_main{'_<' . $file}) {
+ print OUT "There's no code here anything matching $file.\n";
+ next CMD;
+ }
+ elsif ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } };
+ $cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do {
+ $subname = $1;
+ $subname = "main'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($file,$subrange) = split(/:/,$sub{$subname});
+ if ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ }
+ if ($subrange) {
+ if (eval($subrange) < -$window) {
+ $subrange =~ s/-.*/+/;
+ }
+ $cmd = "l $subrange";
+ } else {
+ print OUT "Subroutine $1 not found.\n";
+ next CMD;
+ } };
+ $cmd =~ /^w\b\s*(\d*)$/ && do {
+ $incr = $window - 1;
+ $start = $1 if $1;
+ $start -= $preview;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^-$/ && do {
+ $incr = $window - 1;
+ $cmd = 'l ' . ($start-$window*2) . '+'; };
+ $cmd =~ /^l$/ && do {
+ $incr = $window - 1;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
+ $start = $1 if $1;
+ $incr = $2;
+ $incr = $window - 1 unless $incr;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
+ $end = (!$2) ? $max : ($4 ? $4 : $2);
+ $end = $max if $end > $max;
+ $i = $2;
+ $i = $line if $i eq '.';
+ $i = 1 if $i < 1;
+ for (; $i <= $end; $i++) {
print OUT "$i:\t", $dbline[$i];
- ($stop,$action) = split(/\0/, $dbline{$i});
- print OUT " break if (", $stop, ")\n"
- if $stop;
- print OUT " action: ", $action, "\n"
- if $action;
last if $signal;
}
- }
- next; };
- $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
- $subname = $1;
- $cond = $2 || '1';
- $subname = "$package'" . $subname unless $subname =~ /'/;
- $subname = "main" . $subname if substr($subname,0,1) eq "'";
- ($filename,$i) = split(/[:-]/, $sub{$subname});
- if ($i) {
- *dbline = "_<$filename";
- ++$i while $dbline[$i] == 0 && $i < $#dbline;
- $dbline{$i} =~ s/^[^\0]*/$cond/;
- } else {
- print OUT "Subroutine $subname not found.\n";
- }
- next; };
- $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
- $i = ($1?$1:$line);
- $cond = $2 || '1';
- if ($dbline[$i] == 0) {
- print OUT "Line $i not breakable.\n";
- } else {
- $dbline{$i} =~ s/^[^\0]*/$cond/;
- }
- next; };
- $cmd =~ /^d\s*(\d+)?/ && do {
- $i = ($1?$1:$line);
- $dbline{$i} =~ s/^[^\0]*//;
- delete $dbline{$i} if $dbline{$i} eq '';
- next; };
- $cmd =~ /^A$/ && do {
- for ($i = 1; $i <= $max ; $i++) {
- if (defined $dbline{$i}) {
- $dbline{$i} =~ s/\0[^\0]*//;
- delete $dbline{$i} if $dbline{$i} eq '';
+ $start = $i; # remember in case they want more
+ $start = $max if $start > $max;
+ next CMD; };
+ $cmd =~ /^D$/ && do {
+ print OUT "Deleting all breakpoints...\n";
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ($dbline{$i} =~ s/^\0?$//) {
+ delete $dbline{$i};
+ }
+ }
+ }
+ next CMD; };
+ $cmd =~ /^L$/ && do {
+ for ($i = 1; $i <= $max; $i++) {
+ if (defined $dbline{$i}) {
+ print OUT "$i:\t", $dbline[$i];
+ ($stop,$action) = split(/\0/, $dbline{$i});
+ print OUT " break if (", $stop, ")\n"
+ if $stop;
+ print OUT " action: ", $action, "\n"
+ if $action;
+ last if $signal;
+ }
+ }
+ next CMD; };
+ $cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
+ $subname = $1;
+ $cond = $2 || '1';
+ $subname = "$package'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($filename,$i) = split(/[:-]/, $sub{$subname});
+ if ($i) {
+ *dbline = "_<$filename";
+ ++$i while $dbline[$i] == 0 && $i < $#dbline;
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ } else {
+ print OUT "Subroutine $subname not found.\n";
}
- }
- next; };
- $cmd =~ /^<\s*(.*)/ && do {
- $pre = do action($1);
- next; };
- $cmd =~ /^>\s*(.*)/ && do {
- $post = do action($1);
- next; };
- $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
- $i = $1;
- if ($dbline[$i] == 0) {
- print OUT "Line $i may not have an action.\n";
- } else {
- $dbline{$i} =~ s/\0[^\0]*//;
- $dbline{$i} .= "\0" . do action($3);
- }
- next; };
- $cmd =~ /^n$/ && do {
- $single = 2;
- $laststep = $cmd;
- last; };
- $cmd =~ /^s$/ && do {
- $single = 1;
- $laststep = $cmd;
- last; };
- $cmd =~ /^c\s*(\d*)\s*$/ && do {
- $i = $1;
- if ($i) {
+ next CMD; };
+ $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
+ $i = ($1?$1:$line);
+ $cond = $2 || '1';
if ($dbline[$i] == 0) {
- print OUT "Line $i not breakable.\n";
- next;
+ print OUT "Line $i not breakable.\n";
+ } else {
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
}
- $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
- }
- for ($i=0; $i <= $#stack; ) {
- $stack[$i++] &= ~1;
- }
- last; };
- $cmd =~ /^r$/ && do {
- $stack[$#stack] |= 2;
- last; };
- $cmd =~ /^T$/ && do {
- local($p,$f,$l,$s,$h,$a,@a,@sub);
- for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
- @a = @args;
- for (@a) {
- if (/^StB\000/ && length($_) == length($_main{'_main'})) {
- $_ = sprintf("%s",$_);
+ next CMD; };
+ $cmd =~ /^d\b\s*(\d+)?/ && do {
+ $i = ($1?$1:$line);
+ $dbline{$i} =~ s/^[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ next CMD; };
+ $cmd =~ /^A$/ && do {
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
}
- 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;
+ }
+ next CMD; };
+ $cmd =~ /^<\s*(.*)/ && do {
+ $pre = do action($1);
+ next CMD; };
+ $cmd =~ /^>\s*(.*)/ && do {
+ $post = do action($1);
+ next CMD; };
+ $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
+ $i = $1;
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i may not have an action.\n";
+ } else {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ $dbline{$i} .= "\0" . do action($3);
+ }
+ next CMD; };
+ $cmd =~ /^n$/ && do {
+ $single = 2;
+ $laststep = $cmd;
+ last CMD; };
+ $cmd =~ /^s$/ && do {
+ $single = 1;
+ $laststep = $cmd;
+ last CMD; };
+ $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
+ $i = $1;
+ if ($i) {
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i not breakable.\n";
+ next CMD;
}
+ $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
}
- $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 OUT $sub[$i];
- }
- next; };
- $cmd =~ /^\/(.*)$/ && do {
- $inpat = $1;
- $inpat =~ s:([^\\])/$:$1:;
- if ($inpat ne "") {
- eval '$inpat =~ m'."\n$inpat\n";
- if ($@ ne "") {
- print OUT "$@";
- next;
+ for ($i=0; $i <= $#stack; ) {
+ $stack[$i++] &= ~1;
}
- $pat = $inpat;
- }
- $end = $start;
- eval '
- for (;;) {
- ++$start;
- $start = 1 if ($start > $max);
- last if ($start == $end);
- if ($dbline[$start] =~ m'."\n$pat\n".'i) {
- print OUT "$start:\t", $dbline[$start], "\n";
- last;
+ last CMD; };
+ $cmd =~ /^r$/ && do {
+ $stack[$#stack] |= 2;
+ last CMD; };
+ $cmd =~ /^T$/ && do {
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @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;
}
- } ';
- print OUT "/$pat/: not found\n" if ($start == $end);
- next; };
- $cmd =~ /^\?(.*)$/ && do {
- $inpat = $1;
- $inpat =~ s:([^\\])\?$:$1:;
- if ($inpat ne "") {
- eval '$inpat =~ m'."\n$inpat\n";
- if ($@ ne "") {
- print OUT "$@";
- next;
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ print OUT $sub[$i];
}
- $pat = $inpat;
- }
- $end = $start;
- eval '
- for (;;) {
- --$start;
- $start = $max if ($start <= 0);
- last if ($start == $end);
- if ($dbline[$start] =~ m'."\n$pat\n".'i) {
- print OUT "$start:\t", $dbline[$start], "\n";
- last;
+ next CMD; };
+ $cmd =~ /^\/(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])/$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
}
- } ';
- print OUT "?$pat?: not found\n" if ($start == $end);
- next; };
- $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
- pop(@hist) if length($cmd) > 1;
- $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
- $cmd = $hist[$i] . "\n";
- print OUT $cmd;
- redo; };
- $cmd =~ /^!(.+)$/ && do {
- $pat = "^$1";
- pop(@hist) if length($cmd) > 1;
- for ($i = $#hist; $i; --$i) {
- last if $hist[$i] =~ $pat;
- }
- if (!$i) {
- print OUT "No such command!\n\n";
- next;
- }
- $cmd = $hist[$i] . "\n";
- print OUT $cmd;
- redo; };
- $cmd =~ /^H\s*(-(\d+))?/ && do {
- $end = $2?($#hist-$2):0;
- $hist = 0 if $hist < 0;
- for ($i=$#hist; $i>$end; $i--) {
- print OUT "$i: ",$hist[$i],"\n"
- unless $hist[$i] =~ /^.?$/;
- };
- next; };
- $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
- $cmd =~ /^=/ && do {
- if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
- $alias{$k}="s~$k~$v~";
- print OUT "$k = $v\n";
- } elsif ($cmd =~ /^=\s*$/) {
- foreach $k (sort keys(%alias)) {
- if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
- print OUT "$k = $v\n";
- } else {
- print OUT "$k\t$alias{$k}\n";
+ $end = $start;
+ eval '
+ for (;;) {
+ ++$start;
+ $start = 1 if ($start > $max);
+ last if ($start == $end);
+ if ($dbline[$start] =~ m'."\n$pat\n".'i) {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ last;
+ }
+ } ';
+ print OUT "/$pat/: not found\n" if ($start == $end);
+ next CMD; };
+ $cmd =~ /^\?(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])\?$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ eval '
+ for (;;) {
+ --$start;
+ $start = $max if ($start <= 0);
+ last if ($start == $end);
+ if ($dbline[$start] =~ m'."\n$pat\n".'i) {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ last;
+ }
+ } ';
+ print OUT "?$pat?: not found\n" if ($start == $end);
+ next CMD; };
+ $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
+ pop(@hist) if length($cmd) > 1;
+ $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
+ $cmd = $hist[$i] . "\n";
+ print OUT $cmd;
+ redo CMD; };
+ $cmd =~ /^!(.+)$/ && do {
+ $pat = "^$1";
+ pop(@hist) if length($cmd) > 1;
+ for ($i = $#hist; $i; --$i) {
+ last if $hist[$i] =~ $pat;
+ }
+ if (!$i) {
+ print OUT "No such command!\n\n";
+ next CMD;
+ }
+ $cmd = $hist[$i] . "\n";
+ print OUT $cmd;
+ redo CMD; };
+ $cmd =~ /^H\b\s*(-(\d+))?/ && do {
+ $end = $2?($#hist-$2):0;
+ $hist = 0 if $hist < 0;
+ for ($i=$#hist; $i>$end; $i--) {
+ print OUT "$i: ",$hist[$i],"\n"
+ unless $hist[$i] =~ /^.?$/;
+ };
+ next CMD; };
+ $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
+ $cmd =~ /^=/ && do {
+ if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
+ $alias{$k}="s~$k~$v~";
+ print OUT "$k = $v\n";
+ } elsif ($cmd =~ /^=\s*$/) {
+ foreach $k (sort keys(%alias)) {
+ if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
+ print OUT "$k = $v\n";
+ } else {
+ print OUT "$k\t$alias{$k}\n";
+ };
};
};
- };
- next; };
+ next CMD; };
+ }
$evalarg = $cmd; &eval;
print OUT "\n";
}
;# pwd.pl - keeps track of current working directory in PWD environment var
;#
-;# $Header: pwd.pl,v 3.0.1.2 91/01/11 18:09:24 lwall Locked $
+;# $Header: pwd.pl,v 4.0 91/03/20 01:26:03 lwall Locked $
;#
;# $Log: pwd.pl,v $
+;# Revision 4.0 91/03/20 01:26:03 lwall
+;# 4.0 baseline.
+;#
;# Revision 3.0.1.2 91/01/11 18:09:24 lwall
;# patch42: some .pl files were missing their trailing 1;
;#
-;# $Header: stat.pl,v 3.0.1.1 90/08/09 04:01:34 lwall Locked $
+;# $Header: stat.pl,v 4.0 91/03/20 01:26:16 lwall Locked $
;# Usage:
;# require 'stat.pl';
# syslog.pl
#
# $Log: syslog.pl,v $
+# Revision 4.0 91/03/20 01:26:24 lwall
+# 4.0 baseline.
+#
# Revision 3.0.1.4 90/11/10 01:41:11 lwall
# patch38: syslog.pl was referencing an absolute path
#
# Revision 3.0.1.3 90/10/15 17:42:18 lwall
# patch29: various portability fixes
-#
+#
# Revision 3.0.1.1 90/08/09 03:57:17 lwall
# patch19: Initial revision
#
-;# $Header: termcap.pl,v 3.0.1.3 90/08/09 04:02:53 lwall Locked $
+;# $Header: termcap.pl,v 4.0 91/03/20 01:26:33 lwall Locked $
;#
;# Usage:
;# require 'ioctl.pl';
--- /dev/null
+;# timelocal.pl
+;#
+;# Usage:
+;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year,$junk,$junk,$isdst);
+;# $time = timegm($sec,$min,$hours,$mday,$mon,$year);
+
+;# These routines are quite efficient and yet are always guaranteed to agree
+;# with localtime() and gmtime(). We manage this by caching the start times
+;# of any months we've seen before. If we know the start time of the month,
+;# we can always calculate any time within the month. The start times
+;# themselves are guessed by successive approximation starting at the
+;# current time, since most dates seen in practice are close to the
+;# current date. Unlike algorithms that do a binary search (calling gmtime
+;# once for each bit of the time value, resulting in 32 calls), this algorithm
+;# calls it at most 6 times, and usually only once or twice. If you hit
+;# the month cache, of course, it doesn't call it at all.
+
+;# timelocal is implemented using the same cache. We just assume that we're
+;# translating a GMT time, and then fudge it when we're done for the timezone
+;# and daylight savings arguments. The timezone is determined by examining
+;# the result of localtime(0) when the package is initialized. The daylight
+;# savings offset is currently assumed to be one hour.
+
+CONFIG: {
+ package timelocal;
+
+ @epoch = localtime(0);
+ $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT
+ if ($tzmin > 0) {
+ $tzmin = 24 * 60 - $tzmin; # minutes west of GMT
+ $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line
+ }
+
+ $SEC = 1;
+ $MIN = 60 * $SEC;
+ $HR = 60 * $MIN;
+ $DAYS = 24 * $HR;
+}
+
+sub timegm {
+ package timelocal;
+
+ $ym = pack(C2, @_[5,4]);
+ $cheat = $cheat{$ym} || &cheat;
+ $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS;
+}
+
+sub timelocal {
+ package timelocal;
+
+ $ym = pack(C2, @_[5,4]);
+ $cheat = $cheat{$ym} || &cheat;
+ $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS
+ + $tzmin * $MIN - 60 * 60 * ($_[8] != 0);
+}
+
+package timelocal;
+
+sub cheat {
+ $year = $_[5];
+ $month = $_[4];
+ $guess = $^T;
+ @g = gmtime($guess);
+ while ($diff = $year - $g[5]) {
+ $guess += $diff * (364 * $DAYS);
+ @g = gmtime($guess);
+ }
+ while ($diff = $month - $g[4]) {
+ $guess += $diff * (28 * $DAYS);
+ @g = gmtime($guess);
+ }
+ $g[3]--;
+ $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS;
+ $cheat{$ym} = $guess;
+}
-;# $Header: validate.pl,v 3.0.1.1 90/08/09 04:03:10 lwall Locked $
+;# $Header: validate.pl,v 4.0 91/03/20 01:26:56 lwall Locked $
;# The validate routine takes a single multiline string consisting of
;# lines containing a filename plus a file test to try on it. (The
ln ../../config.sh . || \
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
- fi
+ fi 2>/dev/null
. ./config.sh
;;
esac
echo "Extracting makedepend (with variable substitutions)"
$spitshell >makedepend <<!GROK!THIS!
$startsh
-# $Header: makedepend.SH,v 3.0.1.1 89/11/11 04:35:32 lwall Locked $
+# $Header: makedepend.SH,v 4.0 91/03/20 01:27:04 lwall Locked $
#
# $Log: makedepend.SH,v $
-# Revision 3.0.1.1 89/11/11 04:35:32 lwall
-# patch2: makedepend now uses cppflags determined by Configure
+# Revision 4.0 91/03/20 01:27:04 lwall
+# 4.0 baseline.
#
-# Revision 3.0 89/10/18 15:20:19 lwall
-# 3.0 baseline
#
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
ln ../../config.sh . || \
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
- fi
+ fi 2>/dev/null
. ./config.sh
;;
esac
echo "Extracting makedir (with variable substitutions)"
$spitshell >makedir <<!GROK!THIS!
$startsh
-# $Header: makedir.SH,v 3.0 89/10/18 15:20:27 lwall Locked $
+# $Header: makedir.SH,v 4.0 91/03/20 01:27:13 lwall Locked $
#
# $Log: makedir.SH,v $
-# Revision 3.0 89/10/18 15:20:27 lwall
-# 3.0 baseline
+# 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 \$\$)
+++ /dev/null
-echo "makelib.SH has been renamed to h2ph.SH"
-rm -f makelib
-/* $Header: malloc.c,v 3.0.1.5 91/01/11 18:09:52 lwall Locked $
+/* $Header: malloc.c,v 4.0 91/03/20 01:28:52 lwall Locked $
*
* $Log: malloc.c,v $
- * Revision 3.0.1.5 91/01/11 18:09:52 lwall
- * patch42: Configure now checks alignment requirements
- *
- * Revision 3.0.1.4 90/11/13 15:23:45 lwall
- * patch41: added hp malloc union overhead strut (that sounds very blue collar)
- *
- * Revision 3.0.1.3 90/10/16 15:27:47 lwall
- * patch29: various portability fixes
- *
- * Revision 3.0.1.2 89/11/11 04:36:37 lwall
- * patch2: malloc pointer corruption check made more portable
- *
- * Revision 3.0.1.1 89/10/26 23:15:05 lwall
- * patch1: some declarations were missing from malloc.c
- * patch1: sparc machines had alignment problems in malloc.c
- *
- * Revision 3.0 89/10/18 15:20:39 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:28:52 lwall
+ * 4.0 baseline.
*
*/
}
}
+void
free(cp)
char *cp;
{
Myrsinis 1
GR-145 62 Kifissia
Greece
+
+--------------------------------------------------------------------------
+
+ Revisions to the MS-DOS support in Perl 4.0
+ Tom Dinger, 18 March 1991
+
+The DOS compatibility added to Perl sometime in release 3.x was not
+maintained, and Perl as distributed could not be built without changes.
+
+Both myself and Len Reed more or less "rediscovered" how to get Perl built
+and running reliably for MS-DOS, using the Microsoft C compiler. He and I
+have communicated, and will be putting together additional patches for the
+DOS version of Perl.
+
+1. Compiling Perl
+
+ For now, I have not supplied a makefile, as there is no standard for
+ make utilities under DOS. All the files can be compiled with Microsoft
+ C 5.1, using the switches "-AL -Ox" for Large memory model, maximum
+ optimization (this turned out a few code generation bugs in MSC 5.1).
+ The code will also compile with MSC 6.00A, with the optimization
+ "-Oacegils /Gs" for all files (regcomp.c has special case code to change
+ the aliasing optimizations).
+
+ Generally, you follow the instructions given above to compile and build
+ Perl 4.0 for DOS. I used the output of SunOS yacc run on perly.y,
+ without modification, but I expect both Bison and Berkeley-YACC will work
+ also. From inspection of the generated code, however, I believe AT&T
+ derived YACC produces the smallest tables, i.e. uses the least memory.
+ This is important for a 300K executable file.
+
+2. Editing in-place.
+
+ You will need the file suffix.c from the os2 subdirectory -- it will
+ create a backup file with much less danger for DOS.
+
+3. A "Smarter" chdir() function.
+
+ I have added to the DOS version of Perl 4.0 a replacement chdir()
+ function. Unlike the "normal" behavior, it is aware of drive letters
+ at the start of paths for DOS. So for example:
+
+ perl_chdir( "B:" ) changes to the default directory, on drive B:
+ perl_chdir( "C:\FOO" ) changes to the specified directory, on drive C:
+ perl_chdir( "\BAR" ) changes to the specified directory on the
+ current drive.
+
+4. *.BAT Scripts as Perl scripts
+
+ The strategy described above for turning a Perl script into a *.BAT
+ script do not work. I have been using the following lines at the
+ beginning of a Perl *.BAT script:
+
+ @REM=(qq!
+ @perl -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
+ @goto end !) if 0 ;
+
+ and the following at the end of the *.BAT script:
+
+ @REM=(qq!
+ :end !) if 0 ;
+
+ If you like, with the proper editor you can replace the four '!'
+ characters with some untypeable character, such as Ctrl-A. This will
+ allow you to pass any characters, including ".." strings as arguments.
+
+4. Things to Come
+
+ * Better temporary file handling.
+ * A real Makefile -- Len Reed has one for Dmake 3.6
+ * Swapping code -- swaps most of Perl out of memory (to EMS, XMS or
+ disk) before running a sub-program or pipe.
+ * MKS command line support, both into Perl, and to other programs
+ spawned by Perl.
+ * Smarter pipe functions, not using COMMAND.COM.
+
+
+ Tom Dinger
+ tdinger@East.Sun.COM
+ Martch 18, 1991
--- /dev/null
+/*
+ * (C) Copyright 1990, 1991 Tom Dinger
+ *
+ * You may distribute under the terms of the GNU General Public License
+ * as specified in the README file that comes with the perl 4.0 kit.
+ *
+ */
+
+/*
+ * A "DOS-aware" chdir() function, that will change current drive as well.
+ *
+ * chdir( "B:" ) -- changes to the default directory, on drive B:
+ * chdir( "C:\FOO" ) changes to the specified directory, on drive C:
+ * chdir( "\BAR" ) changes to the specified directory on the current
+ * drive.
+ */
+
+#include <stdlib.h>
+#include <ctype.h>
+#include <direct.h>
+#include <dos.h>
+#include <errno.h>
+
+#include "config.h"
+#ifdef chdir
+#undef chdir
+#endif
+
+/* We should have the line:
+ *
+ * #define chdir perl_chdir
+ *
+ * in some header for perl (I put it in config.h) so that all
+ * references to chdir() become references to this function.
+ */
+
+/*------------------------------------------------------------------*/
+
+#if defined(BUGGY_MSC5) /* only needed for MSC 5.1 */
+
+int _chdrive( int drivenum )
+{
+unsigned int ndrives;
+unsigned int tmpdrive;
+
+
+_dos_setdrive( drivenum, &ndrives );
+
+/* check for illegal drive letter */
+_dos_getdrive( &tmpdrive );
+
+return (tmpdrive != drivenum) ? -1 : 0 ;
+}
+
+#endif
+
+/*-----------------------------------------------------------------*/
+
+int perl_chdir( char * path )
+{
+int drive_letter;
+unsigned int drivenum;
+
+
+if ( path && *path && (path[1] == ':') )
+ {
+ /* The path starts with a drive letter */
+ /* Change current drive */
+ drive_letter = *path;
+ if ( isalpha(drive_letter) )
+ {
+ /* Drive letter legal */
+ if ( islower(drive_letter) )
+ drive_letter = toupper(drive_letter);
+ drivenum = drive_letter - 'A' + 1;
+
+ /* Change drive */
+ if ( _chdrive( drivenum ) == -1 )
+ {
+ /* Drive change failed -- must be illegal drive letter */
+ errno = ENODEV;
+ return -1;
+ }
+
+ /* Now see if that's all we do */
+ if ( ! path[2] )
+ return 0; /* no path after drive -- all done */
+ }
+ /* else drive letter illegal -- fall into "normal" chdir */
+ }
+
+/* Here with some path as well */
+return chdir( path );
+
+/* end perl_chdir() */
+}
+#ifndef config_h
+#define config_h
/* config.h
- * This file is hand tailored for compiling under MS-DOS and MSC 5.1.
- * Diomidis Spinellis, March 1990.
+ *
+ * This file is hand tailored for MS-DOS and MSC 5.1 and 6.00A.
+ * Tom Dinger, March 1991.
+ */
+
+
+/*
+ * BUGGY_MSC5:
+ * This symbol is defined if you are the unfortunate owner of the buggy
+ * Microsoft C compiler version 5.1. It is used as a conditional to
+ * guard code sections that are known to break this compiler.
+ * BUGGY_MSC6:
+ * This symbol is defined if you are the unfortunate owner of the buggy
+ * Microsoft C compiler version 6.0A. It is used as a conditional to
+ * guard code sections that are known to break this compiler.
*/
+#define BUGGY_MSC5 /**/
+/*#undef BUGGY_MSC6 /**/
-/* EUNICE:
+/* 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:
+/* 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 /**/
-/* BIN:
+/* ALIGNBYTES
+ * This symbol contains the number of bytes required to align a double.
+ * Usual values are 2, 4, and 8.
+ */
+#define ALIGNBYTES 4 /**/
+
+/* BIN
* This symbol holds the name of the directory in which the user wants
* to put publicly executable images for the package in question. It
* is most often a local directory such as /usr/local/bin.
*/
#define BIN "/usr/local/bin" /**/
-/* BYTEORDER:
+/* BYTEORDER
* This symbol contains an encoding of the order of bytes in a long.
* Usual values (in octal) are 01234, 04321, 02143, 03412...
*/
-/* CHECK */
#define BYTEORDER 0x1234 /**/
-/* CPPSTDIN:
+/* 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 -{" or "/lib/cpp".
+ * output. Typical value of "cc -E" or "/lib/cpp".
*/
-/* CPPMINUS:
+/* 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 "".
*/
-/* TODO */
-#define CPPSTDIN "cc -{"
+/* TODO: doesn't work for MSC -- it's more complicated than this */
+#define CPPSTDIN "cl "
#define CPPMINUS ""
-/* BCMP:
+/* 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 BCMP /**/
+/*#undef HAS_BCMP /**/
-/* BCOPY:
+/* HAS_BCOPY
* This symbol, if defined, indicates that the bcopy routine is available
* to copy blocks of memory. Otherwise you should probably use memcpy().
*/
-/*#define BCOPY /**/
+/*#undef HAS_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.
+ */
+/*#undef HAS_BZERO /**/
-/* CHARSPRINTF:
+/* 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 /**/
+/*#undef 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.
+ */
+#define HAS_CHSIZE /**/
-/* CRYPT:
+/* HAS_CRYPT
* This symbol, if defined, indicates that the crypt routine is available
* to encrypt passwords and the like.
*/
-/* TODO */
-/*#define CRYPT /**/
+/*#undef HAS_CRYPT /**/
+
+/* CSH
+ * This symbol, if defined, indicates that the C-shell exists.
+ * If defined, contains the full pathname of csh.
+ */
+/*#undef CSH "/usr/bin/csh" /**/
-/* DOSUID:
+/* 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
* subprocesses to which it must pass the filename rather than the
* file descriptor of the script to be executed.
*/
-/*#define DOSUID /**/
+/*#undef DOSUID /**/
-/* DUP2:
+/* HAS_DUP2
* This symbol, if defined, indicates that the dup2 routine is available
* to dup file descriptors. Otherwise you should use dup().
*/
-#define DUP2 /**/
+#define HAS_DUP2 /**/
-/* FCHMOD:
+/* HAS_FCHMOD
* This symbol, if defined, indicates that the fchmod routine is available
* to change mode of opened files. If unavailable, use chmod().
*/
-/*#define FCHMOD /**/
+/*#undef HAS_FCHMOD /**/
-/* FCHOWN:
+/* HAS_FCHOWN
* This symbol, if defined, indicates that the fchown routine is available
* to change ownership of opened files. If unavailable, use chown().
*/
-/*#define FCHOWN /**/
+/*#undef HAS_FCHOWN /**/
-/* FCNTL:
- * This symbol, if defined, indicates to the C program that it should
- * include fcntl.h.
+/* HAS_FCNTL
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
*/
-/*#define FCNTL /**/
+/*#undef HAS_FCNTL /**/
-/* FLOCK:
+/* FLEXFILENAMES
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+/*#undef FLEXFILENAMES /**/
+
+/* HAS_FLOCK
* This symbol, if defined, indicates that the flock() routine is
* available to do file locking.
*/
-/*#define FLOCK /**/
+/*#undef HAS_FLOCK /**/
-/* GETGROUPS:
+/* 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 GETGROUPS /**/
+/*#undef HAS_GETGROUPS /**/
-/* GETHOSTENT:
+/* HAS_GETHOSTENT
* This symbol, if defined, indicates that the gethostent() routine is
* available to lookup host names in some data base or other.
*/
-/*#define GETHOSTENT /**/
+/*#undef HAS_GETHOSTENT /**/
-/* GETPGRP:
+/* HAS_GETPGRP
* This symbol, if defined, indicates that the getpgrp() routine is
* available to get the current process group.
*/
-/*#define GETPGRP /**/
+/*#undef HAS_GETPGRP /**/
-/* GETPRIORITY:
+/* 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 GETPRIORITY /**/
+/*#undef HAS_GETPRIORITY /**/
-/* HTONS:
+/* HAS_HTONS
* This symbol, if defined, indicates that the htons routine (and friends)
* are available to do network order byte swapping.
*/
-/* HTONL:
+/* HAS_HTONL
* This symbol, if defined, indicates that the htonl routine (and friends)
* are available to do network order byte swapping.
*/
-/* NTOHS:
+/* HAS_NTOHS
* This symbol, if defined, indicates that the ntohs routine (and friends)
* are available to do network order byte swapping.
*/
-/* NTOHL:
+/* HAS_NTOHL
* This symbol, if defined, indicates that the ntohl routine (and friends)
* are available to do network order byte swapping.
*/
-/*#define HTONS /**/
-/*#define HTONL /**/
-/*#define NTOHS /**/
-/*#define NTOHL /**/
+/*#undef HAS_HTONS /**/
+/*#undef HAS_HTONL /**/
+/*#undef HAS_NTOHS /**/
+/*#undef HAS_NTOHL /**/
-/* index:
+/* index
* This preprocessor symbol is defined, along with rindex, if the system
* uses the strchr and strrchr routines instead.
*/
-/* rindex:
+/* rindex
* This preprocessor symbol is defined, along with index, if the system
* uses the strchr and strrchr routines instead.
*/
#define index strchr /* cultural */
#define rindex strrchr /* differences? */
-/* IOCTL:
- * This symbol, if defined, indicates that sys/ioctl.h exists and should
- * be included.
- */
-/*#define IOCTL /**/
-
-/* KILLPG:
+/* 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 KILLPG /**/
+/*#undef HAS_KILLPG /**/
-/* MEMCMP:
+/* HAS_LSTAT
+ * This symbol, if defined, indicates that the lstat() routine is
+ * available to stat symbolic links.
+ */
+/*#undef 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 MEMCMP /**/
+#define HAS_MEMCMP /**/
-/* MEMCPY:
+/* 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.
*/
-#define MEMCPY /**/
+#define HAS_MEMCPY /**/
-/* MKDIR:
+/* 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 MKDIR /**/
+#define HAS_MKDIR /**/
+
+/* HAS_MSG
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported.
+ */
+/*#undef HAS_MSG /**/
+
+/* HAS_MSGCTL
+ * This symbol, if defined, indicates that the msgctl() routine is
+ * available to stat symbolic links.
+ */
+/*#undef HAS_MSGCTL /**/
+
+/* HAS_MSGGET
+ * This symbol, if defined, indicates that the msgget() routine is
+ * available to stat symbolic links.
+ */
+/*#undef HAS_MSGGET /**/
+
+/* HAS_MSGRCV
+ * This symbol, if defined, indicates that the msgrcv() routine is
+ * available to stat symbolic links.
+ */
+/*#undef HAS_MSGRCV /**/
+
+/* HAS_MSGSND
+ * This symbol, if defined, indicates that the msgsnd() routine is
+ * available to stat symbolic links.
+ */
+/*#undef HAS_MSGSND /**/
-/* NDBM:
+/* HAS_NDBM
* This symbol, if defined, indicates that ndbm.h exists and should
* be included.
*/
-/*#define NDBM /**/
+/*#undef HAS_NDBM /**/
-/* ODBM:
+/* HAS_ODBM
* This symbol, if defined, indicates that dbm.h exists and should
* be included.
*/
-/*#define ODBM /**/
+/*#undef 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 /**/
-/* READDIR:
+/* HAS_READDIR
* This symbol, if defined, indicates that the readdir routine is available
- * from the C library to create directories.
+ * from the C library to read directories.
*/
-#define READDIR /**/
+#define HAS_READDIR /**/
-/* RENAME:
+/* 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 RENAME /**/
+#define HAS_RENAME /**/
-/* RMDIR:
+/* 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 RMDIR /**/
+#define HAS_RMDIR /**/
+
+/* HAS_SELECT
+ * This symbol, if defined, indicates that the select() subroutine
+ * exists.
+ */
+/*#undef HAS_SELECT /**/
+
+/* HAS_SEM
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+/*#undef HAS_SEM /**/
-/* SETEGID:
+/* HAS_SEMCTL
+ * This symbol, if defined, indicates that the semctl() routine is
+ * available to stat symbolic links.
+ */
+/*#undef HAS_SEMCTL /**/
+
+/* HAS_SEMGET
+ * This symbol, if defined, indicates that the semget() routine is
+ * available to stat symbolic links.
+ */
+/*#undef HAS_SEMGET /**/
+
+/* HAS_SEMOP
+ * This symbol, if defined, indicates that the semop() routine is
+ * available to stat symbolic links.
+ */
+/*#undef 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 SETEGID /**/
+/*#undef HAS_SETEGID /**/
-/* SETEUID:
+/* HAS_SETEUID
* This symbol, if defined, indicates that the seteuid routine is available
* to change the effective uid of the current program.
*/
-/*#define SETEUID /**/
+/*#undef HAS_SETEUID /**/
-/* SETPGRP:
+/* HAS_SETPGRP
* This symbol, if defined, indicates that the setpgrp() routine is
* available to set the current process group.
*/
-/*#define SETPGRP /**/
+/*#undef 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 /**/
-/* SETPRIORITY:
+/* HAS_SETPRIORITY
* This symbol, if defined, indicates that the setpriority() routine is
* available to set a process's priority.
*/
-/*#define SETPRIORITY /**/
+/*#undef HAS_SETPRIORITY /**/
-/* SETREGID:
- * This symbol, if defined, indicates that the setregid routine is available
- * to change the real and effective gid of the current program.
+/* HAS_SETREGID
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current program.
*/
-/*#define SETREGID /**/
+/* 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.
+ */
+/*#undef HAS_SETREGID /**/
+/*#undef HAS_SETRESGID /**/
-/* SETREUID:
- * This symbol, if defined, indicates that the setreuid routine is available
- * to change the real and effective uid of the current program.
+/* 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 SETREUID /**/
+/*#undef HAS_SETREUID /**/
+/*#undef HAS_SETRESUID /**/
-/* SETRGID:
+/* HAS_SETRGID
* This symbol, if defined, indicates that the setrgid routine is available
* to change the real gid of the current program.
*/
-/*#define SETRGID /**/
+/*#undef HAS_SETRGID /**/
-/* SETRUID:
+/* HAS_SETRUID
* This symbol, if defined, indicates that the setruid routine is available
* to change the real uid of the current program.
*/
-/*#define SETRUID /**/
+/*#undef HAS_SETRUID /**/
-/* SOCKET:
- * This symbol, if defined, indicates that the BSD socket interface is
- * supported.
+/* HAS_SHM
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
*/
-/* SOCKETPAIR:
- * This symbol, if defined, indicates that the BSD socketpair call is
- * supported.
+/*#undef HAS_SHM /**/
+
+/* HAS_SHMAT
+ * This symbol, if defined, indicates that the shmat() routine is
+ * available to stat symbolic links.
*/
-/* 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.
+/*#undef HAS_SHMAT /**/
+
+/* HAS_SHMCTL
+ * This symbol, if defined, indicates that the shmctl() routine is
+ * available to stat symbolic links.
*/
-/*#undef SOCKET /**/
+/*#undef HAS_SHMCTL /**/
-/*#undef SOCKETPAIR /**/
+/* HAS_SHMDT
+ * This symbol, if defined, indicates that the shmdt() routine is
+ * available to stat symbolic links.
+ */
+/*#undef HAS_SHMDT /**/
-/*#undef OLDSOCKET /**/
+/* HAS_SHMGET
+ * This symbol, if defined, indicates that the shmget() routine is
+ * available to stat symbolic links.
+ */
+/*#undef HAS_SHMGET /**/
-/* STATBLOCKS:
+/* 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.
+ */
+/*#undef HAS_SOCKET /**/
+
+/*#undef HAS_SOCKETPAIR /**/
+
+/*#undef OLDSOCKET /**/
+
+/* STATBLOCKS
* This symbol is defined if this system has a stat structure declaring
* st_blksize and st_blocks.
*/
-/*#define STATBLOCKS /**/
+/*#undef STATBLOCKS /**/
-/* STDSTDIO:
+/* STDSTDIO
* This symbol is defined if this system has a FILE structure declaring
* _ptr and _cnt in stdio.h.
+ *
+ * NOTE: [Tom Dinger, 23 February 1991] You also need the _filbuf()
+ * function, usually referred to by the getc() macro in stdio.h.
*/
#define STDSTDIO /**/
-/* STRUCTCOPY:
+/* 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 /**/
-/* SYMLINK:
+/* HAS_STRERROR
+ * This symbol, if defined, indicates that the strerror() routine is
+ * available to translate error numbers to strings.
+ */
+#define HAS_STRERROR /**/
+
+/* HAS_SYMLINK
* This symbol, if defined, indicates that the symlink routine is available
* to create symbolic links.
*/
-/*#define SYMLINK /**/
+/*#undef HAS_SYMLINK /**/
-/* SYSCALL:
+/* HAS_SYSCALL
* This symbol, if defined, indicates that the syscall routine is available
* to call arbitrary system calls. If undefined, that's tough.
*/
-/*#define SYSCALL /**/
-
-/* TMINSYS:
- * This symbol is defined if this system declares "struct tm" in
- * in <sys/time.h> rather than <time.h>. We can't just say
- * -I/usr/include/sys because some systems have both time files, and
- * the -I trick gets the wrong one.
- */
-/* I_SYSTIME:
- * This symbol is defined if this system has the file <sys/time.h>.
- */
-/*
- * I_TIME:
- * This symbol is defined if time this system has the file <time.h>.
- */
-/*#undef TMINSYS /**/
-/*#define I_SYSTIME /**/
-#define I_TIME
+/*#undef HAS_SYSCALL /**/
-/* VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include varargs.h.
+/* HAS_TRUNCATE
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
*/
-#define VARARGS /**/
+/*#undef HAS_TRUNCATE /**/
-/* vfork:
- * This symbol, if defined, remaps the vfork routine to fork if the
- * vfork() routine isn't supported here.
+/* HAS_VFORK
+ * This symbol, if defined, indicates that vfork() exists.
*/
-/*#undef vfork fork /**/
+/*#undef HAS_VFORK /**/
-/* VOIDSIG:
+/* 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 /**/
-/* VPRINTF:
+/* 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:
+/* 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 VPRINTF /**/
+#define HAS_VPRINTF /**/
/*#undef CHARVSPRINTF /**/
-/* GIDTYPE:
+/* HAS_WAIT4
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+/*#undef HAS_WAIT4 /**/
+
+/* HAS_WAITPID
+ * This symbol, if defined, indicates that waitpid() exists.
+ */
+/*#undef 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.
*/
-/* TODO */
#define GIDTYPE int /**/
-/* I_DIRENT:
- * This symbol, if defined, indicates to the C program that it should
- * include dirent.h.
- */
-/* DIRNAMLEN:
- * This symbol, if defined, indicates to the C program that the length
- * of directory entry names is provided by a d_namlen field. Otherwise
- * you need to do strlen() on the d_name field.
+/* I_FCNTL
+ * This manifest constant tells the C program to include <fcntl.h>.
*/
-/*#undef I_DIRENT /**/
-#define DIRNAMLEN /**/
+#define I_FCNTL /**/
-/* I_FCNTL:
+/* I_GRP
* This symbol, if defined, indicates to the C program that it should
- * include fcntl.h.
+ * include grp.h.
*/
-#define I_FCNTL /**/
+/*#undef I_GRP /**/
-/* I_GRP:
+/* I_NETINET_IN
* This symbol, if defined, indicates to the C program that it should
- * include grp.h.
+ * include netinet/in.h.
*/
-/*#define I_GRP /**/
+/* I_SYS_IN
+ * This symbol, if defined, indicates to the C program that it should
+ * include sys/in.h.
+ */
+/*#undef I_NETINET_IN /**/
+/*#undef I_SYS_IN /**/
-/* I_PWD:
+/* I_PWD
* This symbol, if defined, indicates to the C program that it should
* include pwd.h.
*/
-/* PWQUOTA:
+/* PWQUOTA
* This symbol, if defined, indicates to the C program that struct passwd
* contains pw_quota.
*/
-/* PWAGE:
+/* PWAGE
* This symbol, if defined, indicates to the C program that struct passwd
* contains pw_age.
*/
-/*#define I_PWD /**/
-/*#define PWQUOTA /**/
+/* 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.
+ */
+/*#undef I_PWD /**/
+/*#undef PWQUOTA /**/
/*#undef PWAGE /**/
+/*#undef PWCHANGE /**/
+/*#undef PWCLASS /**/
+/*#undef PWEXPIRE /**/
+/*#undef PWCOMMENT /**/
-/* I_SYSDIR:
- * This symbol, if defined, indicates to the C program that it should
- * include sys/dir.h.
+/* I_SYS_FILE
+ * This manifest constant tells the C program to include <sys/file.h>.
*/
-#define I_SYSDIR /**/
+/*#undef I_SYS_FILE /**/
-/* I_SYSIOCTL:
+/* I_SYSIOCTL
* This symbol, if defined, indicates that sys/ioctl.h exists and should
* be included.
*/
-/*#define I_SYSIOCTL /**/
+/*#undef 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>.
+ */
+#define I_TIME /**/
+/*#undef I_SYS_TIME /**/
+/*#undef SYSTIMEKERNEL /**/
+/*#undef I_SYS_SELECT /**/
-/* I_VARARGS:
+/* I_UTIME
+ * This symbol, if defined, indicates to the C program that it should
+ * include utime.h.
+ */
+/*#undef I_UTIME /**/
+
+/* I_VARARGS
* This symbol, if defined, indicates to the C program that it should
* include varargs.h.
*/
#define I_VARARGS /**/
-/* INTSIZE:
+/* I_VFORK
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+/*#undef I_VFORK /**/
+
+/* INTSIZE
* This symbol contains the size of an int, so that the C preprocessor
* can make decisions based on it.
*/
#define INTSIZE 2 /**/
-/* RANDBITS:
+/* 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.
+ */
+/*#undef I_DIRENT /**/
+#define I_SYS_DIR /**/
+/*#undef I_NDIR /**/
+/*#undef I_SYS_NDIR /**/
+/*#undef I_MY_DIR /**/
+/*#undef DIRNAMLEN /**/
+
+
+/* RANDBITS
* This symbol contains the number of bits of random number the rand()
* function produces. Usual values are 15, 16, and 31.
*/
#define RANDBITS 31 /**/
-/* SIG_NAME:
+/* SCRIPTDIR
+ * This symbol holds the name of the directory in which the user wants
+ * to put publicly executable scripts for the package in question. It
+ * is often a directory that is mounted across diverse architectures.
+ */
+#define SCRIPTDIR "C:/bin/perl" /**/
+
+/* SIG_NAME
* This symbol contains an list of signal names in order.
+ *
+ * Note: This list is specific for Microsoft C 5.1 and 6.0, which only
+ * support SIGINT, SIGFPE, SIGILL, SIGSEGV, and SIGABRT on
+ * DOS 3.x, but in addition defines SIGTERM, SIGBREAK, SIGUSR1,
+ * SIGUSR2, and SIGUSR3.
*/
-#define SIG_NAME
- "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE","KILL","BUS","SEGV","S
-YS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CHLD","TTIN","TTOU","IO","X
-CPU","XFSZ","VTALRM","PROF","WINCH","USR1","USR2" /**/
+#define SIG_NAME \
+ "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE","KILL",\
+ "BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","TSTP","CONT",\
+ "USR3","BREAK","ABRT" /**/
-/* STDCHAR:
+/* STDCHAR
* This symbol is defined to be the type of char used in stdio.h.
* It has the values "unsigned char" or "char".
*/
#define STDCHAR char /**/
-/* UIDTYPE:
+/* 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 /**/
-/* VOIDFLAGS:
+/* VOIDHAVE
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
*
* 4 = supports comparisons between pointers to void functions and
* addresses of void functions
*
- * The package designer should define VOIDUSED to indicate the requirements
- * of the package. This can be done either by #defining VOIDUSED before
- * including config.h, or by defining defvoidused in Myinit.U. If the
- * latter approach is taken, only those flags will be tested. If the
- * level of void support necessary is not present, defines void to int.
- */
-#ifndef VOIDUSED
-#define VOIDUSED 7
+ * 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 1
#endif
-#define VOIDFLAGS 7
-#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+#define VOIDHAVE 1
+#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:
+/* 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.
+ * should be prepared to do ~ expansion.
*/
#define PRIVLIB "/usr/local/lib/perl" /**/
/*
- * BUGGY_MSC:
- * This symbol is defined if you are the unfortunate owner of a buggy
- * Microsoft C compiler and want to use intrinsic functions. Versions
- * up to 5.1 are known conform to this definition.
- */
-#define BUGGY_MSC /**/
-
-/*
* BINARY:
* This symbol is defined if you run under an operating system that
* distinguishes between binary and text files. If so the function
#define S_ISUID 0
#define S_ISGID 0
-#define CASTNEGFLOAT
+
+/* For MSC5.1, toke.c "runs out of heap space" unless CRIPPLED_CC is
+ * defined.
+ */
+#if defined(BUGGY_MSC5) || defined(BUGGY_MSC6)
+#define CRIPPLED_CC /**/
+#endif
+
+/* MSC (5.1 and 6.0) doesn't know about S_IFBLK or S_IFIFO -- these are
+ * normally found in sys/stat.h
+ */
+#define S_IFBLK (S_IFDIR | S_IFCHR)
+#define S_IFIFO 0010000
+
+/* Define SUFFIX to get special DOS suffix-replacement code */
+#define SUFFIX /**/
+
+/* Add this for the DOS-specific chdir() function */
+#define chdir perl_chdir
+
+#endif
-/* $Header: dir.h,v 3.0.1.1 90/03/27 16:07:08 lwall Locked $
+/* $Header: dir.h,v 4.0 91/03/20 01:34:20 lwall Locked $
*
* (C) Copyright 1987, 1990 Diomidis Spinellis.
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: dir.h,v $
+ * Revision 4.0 91/03/20 01:34:20 lwall
+ * 4.0 baseline.
+ *
* Revision 3.0.1.1 90/03/27 16:07:08 lwall
* patch16: MSDOS support
*
-/* $Header: directory.c,v 3.0.1.1 90/03/27 16:07:37 lwall Locked $
+/* $Header: directory.c,v 4.0 91/03/20 01:34:24 lwall Locked $
*
* (C) Copyright 1987, 1988, 1990 Diomidis Spinellis.
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: directory.c,v $
+ * Revision 4.0 91/03/20 01:34:24 lwall
+ * 4.0 baseline.
+ *
* Revision 3.0.1.1 90/03/27 16:07:37 lwall
* patch16: MSDOS support
*
#define PATHLEN 65
#ifndef lint
-static char rcsid[] = "$Header: director.c;v 1.3 90/03/16 22:39:40 dds Exp
- $";
+static char rcsid[] = "$Header: directory.c,v 4.0 91/03/20 01:34:24 lwall Locked $";
#endif
DIR *
-/* $Header: msdos.c,v 3.0.1.1 90/03/27 16:10:41 lwall Locked $
+/* $Header: msdos.c,v 4.0 91/03/20 01:34:46 lwall Locked $
*
* (C) Copyright 1989, 1990 Diomidis Spinellis.
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: msdos.c,v $
+ * Revision 4.0 91/03/20 01:34:46 lwall
+ * 4.0 baseline.
+ *
* Revision 3.0.1.1 90/03/27 16:10:41 lwall
* patch16: MSDOS support
*
* Various Unix compatibility functions for MS-DOS.
*/
-#include <stdio.h>
-#include <errno.h>
-#include <dos.h>
-#include <time.h>
-#include <process.h>
-
#include "EXTERN.h"
#include "perl.h"
+#include <dos.h>
+#include <process.h>
+
/*
* Interface to the MS-DOS ioctl system call.
* The function is encoded as follows:
struct SREGS segregs;
srv.h.ah = 0x44;
- srv.h.al = function & 0xf;
+ srv.h.al = (unsigned char)(function & 0x0F);
srv.x.bx = handle;
srv.x.cx = function >> 4;
segread(&segregs);
/*
* Just pretend that everyone is a superuser
*/
+#define ROOT_UID 0
+#define ROOT_GID 0
int
getuid(void)
{
- return 0;
+ return ROOT_UID;
}
int
geteuid(void)
{
- return 0;
+ return ROOT_UID;
}
int
getgid(void)
{
- return 0;
+ return ROOT_GID;
}
int
getegid(void)
{
- return 0;
+ return ROOT_GID;
}
+int
+setuid(int uid)
+{ return (uid==ROOT_UID?0:-1); }
+
+int
+setgid(int gid)
+{ return (gid==ROOT_GID?0:-1); }
+
/*
* The following code is based on the do_exec and do_aexec functions
* in file doio.c
return status;
}
-char *getenv(char *name);
int
do_spawn(cmd)
-/* $Header: popen.c,v 3.0.1.2 90/08/09 04:04:42 lwall Locked $
+/* $Header: popen.c,v 4.0 91/03/20 01:34:50 lwall Locked $
*
* (C) Copyright 1988, 1990 Diomidis Spinellis.
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: popen.c,v $
+ * Revision 4.0 91/03/20 01:34:50 lwall
+ * 4.0 baseline.
+ *
* Revision 3.0.1.2 90/08/09 04:04:42 lwall
* patch19: various MSDOS and OS/2 patches folded in
*
else
init++;
- if ((name = tempnam(getenv("TMP"), "pp")) == NULL)
+ if ((name = tempnam((char*)NULL, "pp")) == NULL)
return NULL;
switch (*t) {
case 'r':
- sprintf(buff, "%s>%s", command, name);
+ sprintf(buff, "%s >%s", command, name);
if (system(buff) || (f = fopen(name, "r")) == NULL) {
free(name);
return NULL;
status = EOF;
else
status = 0;
- free(name);
+ free((void*)name);
return status;
case execute:
(void)sprintf(buff, "%s <%s", p->command, p->name);
free(p);
- if (system(buff)) {
+ if (fclose(f) == EOF) {
(void)unlink(name);
status = EOF;
- } else if (fclose(f) == EOF) {
+ } else if (system(buff)) {
(void)unlink(name);
status = EOF;
} else if (unlink(name) < 0)
status = EOF;
else
status = 0;
- free(name);
+ free((void*)name);
return status;
default:
return EOF;
--- /dev/null
+/* usage.c
+ *
+ * Show usage message.
+ */
+
+#include <stdio.h>
+#include <string.h>
+
+
+usage(char *myname)
+{
+char * p;
+char * name_p;
+
+name_p = myname;
+if ( p = strrchr(myname,'/') )
+ name_p = p+1; /* point after final '/' */
+#ifdef MSDOS
+if ( p = strrchr(name_p,'\\') )
+ name_p = p+1; /* point after final '\\' */
+if ( p = strrchr(name_p,':') )
+ name_p = p+1; /* point after final ':' */
+ printf("\nUsage: %s [-acdnpsSvw] [-Dnumber] [-i[extension]] [-Idirectory]"
+#else
+ printf("\nUsage: %s [-acdnpPsSuUvw] [-Dnumber] [-i[extension]] [-Idirectory]"
+#endif
+ "\n [-e \"command\"] [-x[directory]] [filename] [arguments]\n", name_p);
+
+ printf("\n -a autosplit mode with -n or -p"
+ "\n -c syntaxcheck only"
+ "\n -d run scripts under debugger"
+ "\n -n assume 'while (<>) { ...script... }' loop arround your script"
+ "\n -p assume loop like -n but print line also like sed"
+#ifndef MSDOS
+ "\n -P run script through C preprocessor befor compilation"
+#endif
+ "\n -s enable some switch parsing for switches after script name"
+ "\n -S look for the script using PATH environment variable");
+#ifndef MSDOS
+ printf("\n -u dump core after compiling the script"
+ "\n -U allow unsafe operations");
+#endif
+ printf("\n -v print version number and patchlevel of perl"
+ "\n -w turn warnings on for compilation of your script\n"
+ "\n -Dnumber set debugging flags"
+ "\n -i[extension] edit <> files in place (make backup if extension supplied)"
+ "\n -Idirectory specify include directory in conjunction with -P"
+ "\n -e command one line of script, multiple -e options are allowed"
+ "\n [filename] can be ommitted, when -e is used"
+ "\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
+}
os2.c kernel of OS/2 port (see below)
popen.c new popen.c
mktemp.c enhanced mktemp(), uses TMP env. variable, used by popen.c
+alarm.c PD implementation for alarm()
+alarm.h header for alarm.c
perl.cs Compiler Shell script for perl itself
perl.def linker definition file for perl
Kai Uwe Rommel
rommel@lan.informatik.tu-muenchen.dbp.de
- Breslauer Str. 25
- D-8756 Kahl/Main
-
+ Zennerstr. 1
+ D-8000 Muenchen 70
+
+
+ I have verified with patchlevel 37, that the OS/2 port compiles,
after doing two minor changes. HPFS filenames support was also added.
Some bugs were fixed.
October 1990
Kai Uwe Rommel
rommel@lan.informatik.tu-muenchen.dbp.de
+
+
+Verified patchlevel 40.
+Some bugs were fixed. Added alarm() support (using PD implementation).
+
+
+ November 1990
+
+ Kai Uwe Rommel
+ rommel@lan.informatik.tu-muenchen.dbp.de
+
+
+Verified patchlevel 44.
+Only two #ifdefs added to eval.c. Stack size for A2P had to be corrected.
+PERLGLOB separated from DOS version because of HPFS support.
+
+[Note: instead of #ifdef'ing eval.c I fixed it in perl.h--lwall]
+
+ January 1991
+
+ Kai Uwe Rommel
+ rommel@lan.informatik.tu-muenchen.dbp.de
..\os2\a2p.def
a2p.exe
--AL -LB -S0xA000
+-AL -LB -S0x9000
--- /dev/null
+/*
+ * This software is Copyright 1989 by Jack Hudler.
+ *
+ * Permission is hereby granted to copy, reproduce, redistribute or otherwise
+ * use this software as long as: there is no monetary profit gained
+ * specifically from the use or reproduction or this software, it is not
+ * sold, rented, traded or otherwise marketed, and this copyright notice is
+ * included prominently in any copy made.
+ *
+ * The author make no claims as to the fitness or correctness of this software
+ * for any use whatsoever, and it is provided as is. Any use of this software
+ * is at the user's own risk.
+ *
+ */
+
+/****************************** Module Header ******************************\
+* Module Name: alarm.c
+* Created : 11-08-89
+* Author : Jack Hudler [jack@csccat.lonestar.org]
+* Copyright : 1988 Jack Hudler.
+* Function : Unix like alarm signal simulator.
+\***************************************************************************/
+
+/* Tested using OS2 1.2 with Microsoft C 5.1 and 6.0. */
+
+#define INCL_DOSPROCESS
+#define INCL_DOSSIGNALS
+#define INCL_DOS
+#include <os2.h>
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <signal.h>
+
+#include "alarm.h"
+
+#define ALARM_STACK 4096 /* This maybe over kill, but the page size is 4K */
+
+static PBYTE pbAlarmStack;
+static SEL selAlarmStack;
+static TID tidAlarm;
+static PID pidMain;
+static BOOL bAlarmInit=FALSE;
+static BOOL bAlarmRunning=FALSE;
+static USHORT uTime;
+
+static VOID FAR alarm_thread ( VOID )
+{
+ while(1)
+ {
+ if (bAlarmRunning)
+ {
+ DosSleep(1000L);
+ uTime--;
+ if (uTime==0L)
+ {
+ // send signal to the main process.. I could have put raise() here
+ // however that would require the use of the multithreaded library,
+ // and it does not contain raise()!
+ // I tried it with the standard library, this signaled ok, but a
+ // test printf in the signal would not work and even caused SEGV.
+ // So I signal the process through OS/2 and then the process
+ // signals itself.
+ if (bAlarmRunning)
+ DosFlagProcess(pidMain,FLGP_PID, PFLG_A,1);
+ bAlarmRunning=FALSE;
+ }
+ }
+ else
+ DosSleep(500L);
+ }
+}
+
+static VOID PASCAL FAR AlarmSignal(USHORT usSigArg,USHORT usSigNum)
+{
+ /*
+ * this is not executed from the thread. The thread triggers Process
+ * flag A which is in the main processes scope, this inturn triggers
+ * (via the raise) SIGUSR1 which is defined to SIGALRM.
+ */
+ raise(SIGUSR1);
+}
+
+static void alarm_init(void)
+{
+ PFNSIGHANDLER pfnPrev;
+ USHORT pfAction;
+ PIDINFO pid;
+
+ bAlarmInit = TRUE;
+
+ if (!DosAllocSeg( ALARM_STACK, (PSEL) &selAlarmStack, SEG_NONSHARED ))
+ {
+ OFFSETOF(pbAlarmStack) = ALARM_STACK - 2;
+ SELECTOROF(pbAlarmStack) = selAlarmStack;
+ /* Create the thread */
+ if (DosCreateThread( alarm_thread, &tidAlarm, pbAlarmStack ))
+ {
+ fprintf(stderr,"Alarm thread failed to start.\n");
+ exit(1);
+ }
+ /* Setup the signal handler for Process Flag A */
+ if (DosSetSigHandler(AlarmSignal,&pfnPrev,&pfAction,SIGA_ACCEPT,SIG_PFLG_A))
+ {
+ fprintf(stderr,"SigHandler Failed to install.\n");
+ exit(1);
+ }
+ /* Save main process ID, we'll need it for triggering the signal */
+ DosGetPID(&pid);
+ pidMain = pid.pid;
+ }
+ else
+ exit(1);
+}
+
+unsigned alarm(unsigned sec)
+{
+ if (!bAlarmInit) alarm_init();
+
+ if (sec)
+ {
+ uTime = sec;
+ bAlarmRunning = TRUE;
+ }
+ else
+ bAlarmRunning = FALSE;
+
+ return 0;
+}
+
+#ifdef TESTING
+/* A simple test to see if it works */
+BOOL x;
+
+void timeout(void)
+{
+ fprintf(stderr,"ALARM TRIGGERED!!\n");
+ DosBeep(1000,500);
+ x++;
+}
+
+void main(void)
+{
+ (void) signal(SIGALRM, timeout);
+ (void) alarm(1L);
+ printf("ALARM RUNNING!!\n");
+ while(!x);
+}
+#endif
--- /dev/null
+#define SIGALRM SIGUSR1
+unsigned alarm(unsigned);
#ifdef OS2
#define PIPE
#define GETPPID
-#define GETPRIORITY
-#define SETPRIORITY
+#define HAS_GETPRIORITY
+#define HAS_SETPRIORITY
#define KILL
#endif /* OS2 */
#define CPPSTDIN "cc -{"
#define CPPMINUS ""
-/* BCMP:
+/* 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 BCMP /**/
+/*#define HAS_BCMP /**/
-/* BCOPY:
+/* HAS_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
* to copy blocks of memory. Otherwise you should probably use memcpy().
*/
-/*#define BCOPY /**/
+/*#define HAS_BCOPY /**/
/* CHARSPRINTF:
* This symbol is defined if this system declares "char *sprintf()" in
*/
/*#define CHARSPRINTF /**/
-/* CRYPT:
+/* HAS_CRYPT:
* This symbol, if defined, indicates that the crypt routine is available
* to encrypt passwords and the like.
*/
/* TODO */
-/*#define CRYPT /**/
+/*#define HAS_CRYPT /**/
/* DOSUID:
* This symbol, if defined, indicates that the C program should
*/
/*#define DOSUID /**/
-/* DUP2:
+/* HAS_DUP2:
* This symbol, if defined, indicates that the dup2 routine is available
* to dup file descriptors. Otherwise you should use dup().
*/
-#define DUP2 /**/
+#define HAS_DUP2 /**/
-/* FCHMOD:
+/* HAS_FCHMOD:
* This symbol, if defined, indicates that the fchmod routine is available
* to change mode of opened files. If unavailable, use chmod().
*/
-/*#define FCHMOD /**/
+/*#define HAS_FCHMOD /**/
-/* FCHOWN:
+/* HAS_FCHOWN:
* This symbol, if defined, indicates that the fchown routine is available
* to change ownership of opened files. If unavailable, use chown().
*/
-/*#define FCHOWN /**/
+/*#define HAS_FCHOWN /**/
-/* FCNTL:
+/* I_FCNTL:
* This symbol, if defined, indicates to the C program that it should
* include fcntl.h.
*/
-/*#define FCNTL /**/
+/*#define I_FCNTL /**/
-/* FLOCK:
+/* HAS_FLOCK:
* This symbol, if defined, indicates that the flock() routine is
* available to do file locking.
*/
-/*#define FLOCK /**/
+/*#define HAS_FLOCK /**/
-/* GETGROUPS:
+/* 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 GETGROUPS /**/
+/*#define HAS_GETGROUPS /**/
-/* GETHOSTENT:
+/* HAS_GETHOSTENT:
* This symbol, if defined, indicates that the gethostent() routine is
* available to lookup host names in some data base or other.
*/
-/*#define GETHOSTENT /**/
+/*#define HAS_GETHOSTENT /**/
-/* GETPGRP:
+/* HAS_GETPGRP:
* This symbol, if defined, indicates that the getpgrp() routine is
* available to get the current process group.
*/
-/*#define GETPGRP /**/
+/*#define HAS_GETPGRP /**/
-/* GETPRIORITY:
+/* HAS_GETPRIORITY:
* This symbol, if defined, indicates that the getpriority() routine is
* available to get a process's priority.
*/
-/*#define GETPRIORITY /**/
+/*#define HAS_GETPRIORITY /**/
-/* HTONS:
+/* HAS_HTONS:
* This symbol, if defined, indicates that the htons routine (and friends)
* are available to do network order byte swapping.
*/
-/* HTONL:
+/* HAS_HTONL:
* This symbol, if defined, indicates that the htonl routine (and friends)
* are available to do network order byte swapping.
*/
-/* NTOHS:
+/* HAS_NTOHS:
* This symbol, if defined, indicates that the ntohs routine (and friends)
* are available to do network order byte swapping.
*/
-/* NTOHL:
+/* HAS_NTOHL:
* This symbol, if defined, indicates that the ntohl routine (and friends)
* are available to do network order byte swapping.
*/
-/*#define HTONS /**/
-/*#define HTONL /**/
-/*#define NTOHS /**/
-/*#define NTOHL /**/
+/*#define HAS_HTONS /**/
+/*#define HAS_HTONL /**/
+/*#define HAS_NTOHS /**/
+/*#define HAS_NTOHL /**/
/* index:
* This preprocessor symbol is defined, along with rindex, if the system
#define index strchr /* cultural */
#define rindex strrchr /* differences? */
-/* IOCTL:
+/* I_SYSIOCTL:
* This symbol, if defined, indicates that sys/ioctl.h exists and should
* be included.
*/
-/*#define IOCTL /**/
+/*#define I_SYSIOCTL /**/
-/* KILLPG:
+/* 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 KILLPG /**/
+/*#define HAS_KILLPG /**/
-/* MEMCMP:
+/* HAS_MEMCMP:
* This symbol, if defined, indicates that the memcmp routine is available
* to compare blocks of memory. If undefined, roll your own.
*/
-#define MEMCMP /**/
+#define HAS_MEMCMP /**/
-/* MEMCPY:
+/* 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.
*/
-#define MEMCPY /**/
+#define HAS_MEMCPY /**/
-/* MKDIR:
+/* 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 MKDIR /**/
+#define HAS_MKDIR /**/
-/* NDBM:
+/* HAS_NDBM:
* This symbol, if defined, indicates that ndbm.h exists and should
* be included.
*/
-/*#define NDBM /**/
+#define HAS_NDBM /**/
-/* ODBM:
+/* HAS_ODBM:
* This symbol, if defined, indicates that dbm.h exists and should
* be included.
*/
-/*#define ODBM /**/
+/*#define HAS_ODBM /**/
-/* READDIR:
+/* HAS_READDIR:
* This symbol, if defined, indicates that the readdir routine is available
* from the C library to create directories.
*/
-#define READDIR /**/
+#define HAS_READDIR /**/
-/* RENAME:
+/* 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 RENAME /**/
+#define HAS_RENAME /**/
-/* RMDIR:
+/* 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 RMDIR /**/
+#define HAS_RMDIR /**/
-/* SETEGID:
+/* HAS_SETEGID:
* This symbol, if defined, indicates that the setegid routine is available
* to change the effective gid of the current program.
*/
-/*#define SETEGID /**/
+/*#define HAS_SETEGID /**/
-/* SETEUID:
+/* HAS_SETEUID:
* This symbol, if defined, indicates that the seteuid routine is available
* to change the effective uid of the current program.
*/
-/*#define SETEUID /**/
+/*#define HAS_SETEUID /**/
-/* SETPGRP:
+/* HAS_SETPGRP:
* This symbol, if defined, indicates that the setpgrp() routine is
* available to set the current process group.
*/
-/*#define SETPGRP /**/
+/*#define HAS_SETPGRP /**/
-/* SETPRIORITY:
+/* HAS_SETPRIORITY:
* This symbol, if defined, indicates that the setpriority() routine is
* available to set a process's priority.
*/
-/*#define SETPRIORITY /**/
+/*#define HAS_SETPRIORITY /**/
-/* SETREGID:
+/* HAS_SETREGID:
* This symbol, if defined, indicates that the setregid routine is available
* to change the real and effective gid of the current program.
*/
-/*#define SETREGID /**/
+/*#define HAS_SETREGID /**/
-/* SETREUID:
+/* HAS_SETREUID:
* This symbol, if defined, indicates that the setreuid routine is available
* to change the real and effective uid of the current program.
*/
-/*#define SETREUID /**/
+/*#define HAS_SETREUID /**/
-/* SETRGID:
+/* HAS_SETRGID:
* This symbol, if defined, indicates that the setrgid routine is available
* to change the real gid of the current program.
*/
-/*#define SETRGID /**/
+/*#define HAS_SETRGID /**/
-/* SETRUID:
+/* HAS_SETRUID:
* This symbol, if defined, indicates that the setruid routine is available
* to change the real uid of the current program.
*/
-/*#define SETRUID /**/
+/*#define HAS_SETRUID /**/
-/* SOCKET:
+/* HAS_SOCKET:
* This symbol, if defined, indicates that the BSD socket interface is
* supported.
*/
-/* SOCKETPAIR:
+/* HAS_SOCKETPAIR:
* This symbol, if defined, indicates that the BSD socketpair call is
* supported.
*/
* This symbol, if defined, indicates that the 4.1c BSD socket interface
* is supported instead of the 4.2/4.3 BSD socket interface.
*/
-/*#undef SOCKET /**/
+/*#undef HAS_SOCKET /**/
-/*#undef SOCKETPAIR /**/
+/*#undef HAS_SOCKETPAIR /**/
/*#undef OLDSOCKET /**/
*/
#define STRUCTCOPY /**/
-/* SYMLINK:
+/* HAS_SYMLINK:
* This symbol, if defined, indicates that the symlink routine is available
* to create symbolic links.
*/
-/*#define SYMLINK /**/
+/*#define HAS_SYMLINK /**/
-/* SYSCALL:
+/* HAS_SYSCALL:
* This symbol, if defined, indicates that the syscall routine is available
* to call arbitrary system calls. If undefined, that's tough.
*/
-/*#define SYSCALL /**/
+/*#define HAS_SYSCALL /**/
-/* TMINSYS:
+/* s_tm:
* This symbol is defined if this system declares "struct tm" in
* in <sys/time.h> rather than <time.h>. We can't just say
* -I/usr/include/sys because some systems have both time files, and
* the -I trick gets the wrong one.
*/
-/* I_SYSTIME:
+/* I_SYS_TIME:
* This symbol is defined if this system has the file <sys/time.h>.
*/
/*
* I_TIME:
* This symbol is defined if time this system has the file <time.h>.
*/
-/*#undef TMINSYS /**/
-/*#define I_SYSTIME /**/
+/*#undef s_tm /**/
+/*#define I_SYS_TIME /**/
#define I_TIME
/* VARARGS:
*/
#define VOIDSIG /**/
-/* VPRINTF:
+/* 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().
* is up to the package author to declare vsprintf correctly based on the
* symbol.
*/
-#define VPRINTF /**/
+#define HAS_VPRINTF /**/
/*#undef CHARVSPRINTF /**/
/* GIDTYPE:
/*#define PWQUOTA /**/
/*#undef PWAGE /**/
-/* I_SYSDIR:
+/* I_SYS_DIR:
* This symbol, if defined, indicates to the C program that it should
* include sys/dir.h.
*/
-#define I_SYSDIR /**/
+#define I_SYS_DIR /**/
/* I_SYSIOCTL:
* This symbol, if defined, indicates that sys/ioctl.h exists and should
#ifdef OS2
#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE",\
/* 0 1 2 3 4 5 6 7 8 */\
- "KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CLD",\
+ "KILL","BUS","SEGV","SYS","PIPE","UALRM","TERM","ALRM","USR2","CLD",\
/* 9 10 11 12 13 14 15 16 17 18 */\
"PWR","USR3","BREAK","ABRT"
/*19 20 21 22 */
#include <os2.h>
+#ifndef PERLGLOB
int attributes = A_DIR | A_HIDDEN;
}
-static int IsFileSystemFAT(char *dir)
+static
+#endif
+int IsFileSystemFAT(char *dir)
{
USHORT nDrive;
ULONG lMap;
}
}
-
+#ifndef PERLGLOB
static char *getdirent(char *dir)
{
int done;
return NULL;
}
}
+#endif
--- /dev/null
+sub handler {
+ local($sig) = @_;
+ print "Caught a SIG$sig -- shutting down\n";
+ exit(0);
+}
+
+$SIG{'INT'} = 'handler';
+$SIG{'QUIT'} = 'handler';
+$SIG{'ALRM'} = 'handler';
+
+print "Starting execution ...\n";
+alarm(10);
+
+while ( <> ) {
+}
+print "Normal exit.\n";
extproc C:\binp\misc\perl.exe -S
+#!perl
# os2.pl: Demonstrates the OS/2 system calls and shows off some of the
# features in common with the UNIX version.
--- /dev/null
+/*
+ * Globbing for OS/2. Relies on the expansion done by the library
+ * startup code. (dds)
+ */
+
+#include <stdio.h>
+#include <string.h>
+
+main(int argc, char *argv[])
+{
+ register i;
+
+ for (i = 1; i < argc; i++)
+ {
+ fputs(IsFileSystemFAT(argv[i]) ? strlwr(argv[i]) : argv[i], stdout);
+ putchar(0);
+ }
+}
-/* $Header: os2.c,v 3.0.1.2 90/11/10 01:42:38 lwall Locked $
+/* $Header: os2.c,v 4.0 91/03/20 01:36:21 lwall Locked $
*
* (C) Copyright 1989, 1990 Diomidis Spinellis.
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: os2.c,v $
+ * Revision 4.0 91/03/20 01:36:21 lwall
+ * 4.0 baseline.
+ *
* Revision 3.0.1.2 90/11/10 01:42:38 lwall
* patch38: more msdos/os2 upgrades
*
usage(char *myname)
{
#ifdef MSDOS
- printf("\nUsage: %s [-acdnpsSvw] [-Dnumber] [-i[extension]] [-Idirectory]"
+ printf("\nUsage: %s [-acdnpsSvw] [-0[octal]] [-Dnumber] [-i[extension]] [-Idirectory]"
#else
printf("\nUsage: %s [-acdnpPsSuUvw] [-Dnumber] [-i[extension]] [-Idirectory]"
#endif
#endif
printf("\n -v print version number and patchlevel of perl"
"\n -w turn warnings on for compilation of your script\n"
- "\n -Dnumber set debugging flags"
+ "\n -0[octal] specify record separator (0, if no argument)"
+ "\n -Dnumber set debugging flags (argument is a bit mask)"
"\n -i[extension] edit <> files in place (make backup if extension supplied)"
"\n -Idirectory specify include directory in conjunction with -P"
"\n -e command one line of script, multiple -e options are allowed"
DOSSETPRTY
DOSGETPRTY
DOSQFSATTACH
+DOSCREATETHREAD
hash.c perl.c perly.c regcomp.c regexec.c stab.c str.c util.c
)
(-W1 -Od -Olt -B2C2L -B3C3L -DDEBUGGING eval.c{evalargs.xc} toke.c)
-(-W1 -Od -Olt -I.
-os2\os2.c os2\popen.c os2\mktemp.c os2\director.c os2\suffix.c
+(-W1 -Od -Olt -I. -Ios2
+os2\os2.c os2\popen.c os2\mktemp.c os2\director.c os2\suffix.c os2\alarm.c
)
+; link with this library if you have GNU gdbm for OS/2
+; remember to enable the NDBM symbol in config.h before compiling
+lgdbm.lib
setargv.obj
os2\perl.def
os2\perl.bad
perl.exe
--AL -LB -S0x8800
+-AL -LB -S0x8000
NAME PERL WINDOWCOMPAT NEWFILES
-DESCRIPTION 'PERL 3.0, patchlevel 37 - for MS-DOS and OS/2'
+DESCRIPTION 'PERL 3.0 - for MS-DOS and OS/2'
--- /dev/null
+DOSQFSATTACH
-msdos\glob.c
+os2\glob.c
+(-DPERLGLOB os2\director.c)
setargv.obj
os2\perlglob.def
+os2\perlglob.bad
perlglob.exe
-AS -LB -S0x1000
--- /dev/null
+extproc perl -Sx
+#!perl
+
+$bin = 'c:/bin';
+
+# $Header: s2p.cmd,v 4.0 91/03/20 01:37:09 lwall Locked $
+#
+# $Log: s2p.cmd,v $
+# Revision 4.0 91/03/20 01:37:09 lwall
+# 4.0 baseline.
+#
+# Revision 3.0.1.6 90/10/20 02:21:43 lwall
+# patch37: changed some ". config.sh" to ". ./config.sh"
+#
+# Revision 3.0.1.5 90/10/16 11:32:40 lwall
+# patch29: s2p modernized
+#
+# Revision 3.0.1.4 90/08/09 05:50:43 lwall
+# patch19: s2p didn't translate \n right
+#
+# Revision 3.0.1.3 90/03/01 10:31:21 lwall
+# patch9: s2p didn't handle \< and \>
+#
+# Revision 3.0.1.2 89/11/17 15:51:27 lwall
+# patch5: in s2p, line labels without a subsequent statement were done wrong
+# patch5: s2p left residue in /tmp
+#
+# Revision 3.0.1.1 89/11/11 05:08:25 lwall
+# patch2: in s2p, + within patterns needed backslashing
+# patch2: s2p was printing out some debugging info to the output file
+#
+# Revision 3.0 89/10/18 15:35:02 lwall
+# 3.0 baseline
+#
+# Revision 2.0.1.1 88/07/11 23:26:23 root
+# patch2: s2p didn't put a proper prologue on output script
+#
+# Revision 2.0 88/06/05 00:15:55 root
+# Baseline version 2.0.
+#
+#
+
+$indent = 4;
+$shiftwidth = 4;
+$l = '{'; $r = '}';
+
+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,">sperl$$") ||
+ &Die("Can't open temp file: $!\n");
+}
+
+if (!$assumen && !$assumep) {
+ print BODY <<'EOT';
+while ($ARGV[0] =~ /^-/) {
+ $_ = shift;
+ last if /^--/;
+ if (/^-n/) {
+ $nflag++;
+ next;
+ }
+ die "I don't recognize this switch: $_\\n";
+}
+
+EOT
+}
+
+print BODY <<'EOT';
+
+#ifdef PRINTIT
+#ifdef ASSUMEP
+$printit++;
+#else
+$printit++ unless $nflag;
+#endif
+#endif
+LINE: while (<>) {
+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;
+ }
+ $_ = "$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";
+ }
+ 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");
+ }
+ $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;
+}
+
+print BODY "}\n";
+if ($appendseen || $tseen || !$assumen) {
+ $printit++ if $dseen || (!$assumen && !$assumep);
+ print BODY <<'EOT';
+
+continue {
+#ifdef PRINTIT
+#ifdef DSEEN
+#ifdef ASSUMEP
+ print if $printit++;
+#else
+ if ($printit)
+ { print; }
+ else
+ { $printit++ unless $nflag; }
+#endif
+#else
+ print if $printit;
+#endif
+#else
+ print;
+#endif
+#ifdef TSEEN
+ $tflag = '';
+#endif
+#ifdef APPENDSEEN
+ if ($atext) { print $atext; $atext = ''; }
+#endif
+}
+EOT
+}
+
+close BODY;
+
+unless ($debug) {
+ open(HEAD,">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);
+ if ($opens) {print HEAD "$opens\n";}
+ open(BODY,"sperl$$")
+ || &Die("Can't reopen temp file: $!\n");
+ while (<BODY>) {
+ print HEAD $_;
+ }
+ close HEAD;
+
+ print <<"EOT";
+#!$bin/perl
+eval 'exec $bin/perl -S \$0 \$*'
+ if \$running_under_some_shell;
+
+EOT
+ open(BODY,"cc -E sperl2$$.c |") ||
+ &Die("Can't reopen temp file: $!\n");
+ while (<BODY>) {
+ /^# [0-9]/ && next;
+ /^[ \t]*$/ && next;
+ s/^<><>//;
+ print;
+ }
+}
+
+&Cleanup;
+exit;
+
+sub Cleanup {
+ 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) = $_;
+ s/[^a-zA-Z]/_/g;
+ s/^_*//;
+ substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
+ if (!$seen{$_}) {
+ $opens .= <<"EOT";
+open($_,'>$fname') || die "Can't create $fname";
+EOT
+ }
+ $seen{$_} = $_;
+}
+
+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($_ = <<'EOT');
+<<--#ifdef PRINTIT
+$printit = '';
+<<--#endif
+next LINE;
+EOT
+ next;
+ }
+
+ if (/^n/) {
+ chop($_ = <<'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) {print $atext; $atext = '';}
+<<--#endif
+$_ = <>;
+<<--#ifdef TSEEN
+$tflag = '';
+<<--#endif
+EOT
+ next;
+ }
+
+ if (/^a/) {
+ $appendseen++;
+ $command = $space . '$atext .=' . "\n<<--'";
+ $lastline = 0;
+ while (<>) {
+ s/^[ \t]*//;
+ s/^[\\]//;
+ unless (s|\\$||) { $lastline = 1;}
+ s/'/\\'/g;
+ s/^([ \t]*\n)/<><>$1/;
+ $command .= $_;
+ $command .= '<<--';
+ last if $lastline;
+ }
+ $_ = $command . "';";
+ last;
+ }
+
+ if (/^[ic]/) {
+ if (/^c/) { $change = 1; }
+ $addr1 = '$iter = (' . $addr1 . ')';
+ $command = $space . 'if ($iter == 1) { print'
+ . "\n<<--'";
+ $lastline = 0;
+ while (<>) {
+ s/^[ \t]*//;
+ s/^[\\]//;
+ unless (s/\\$//) { $lastline = 1;}
+ s/'/\\'/g;
+ s/^([ \t]*\n)/<><>$1/;
+ $command .= $_;
+ $command .= '<<--';
+ last if $lastline;
+ }
+ $_ = $command . "';}";
+ if ($change) {
+ $dseen++;
+ $change = "$_\n";
+ chop($_ = <<"EOT");
+<<--#ifdef PRINTIT
+$space\$printit = '';
+<<--#endif
+${space}next LINE;
+EOT
+ }
+ 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 ($c eq '[' && !$repl) {
+ $i++ if substr($_,$i,1) eq '^';
+ $i++ if substr($_,$i,1) eq ']';
+ $inbracket = 1;
+ }
+ elsif ($c eq ']') {
+ $inbracket = 0;
+ }
+ elsif (!$repl && index("()+",$c) >= 0) {
+ substr($_, $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);
+ $dol = '$';
+ $repl =~ s/\$/\\$/;
+ $repl =~ s'&'$&'g;
+ $repl =~ s/[\\]([0-9])/$dol$1/g;
+ $subst = "$pat$repl$delim";
+ $cmd = '';
+ while ($end) {
+ if ($end =~ s/^g//) {
+ $subst .= 'g';
+ next;
+ }
+ if ($end =~ s/^p//) {
+ $cmd .= ' && (print)';
+ next;
+ }
+ if ($end =~ s/^w[ \t]*//) {
+ $fh = &make_filehandle($end);
+ $cmd .= " && (print $fh \$_)";
+ $end = '';
+ next;
+ }
+ &Die("Unrecognized substitution command".
+ "($end) at line $.\n");
+ }
+ chop ($_ = <<"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 /(^.*\n)/;';
+ next;
+ }
+
+ if (/^D/) {
+ chop($_ = <<'EOT');
+s/^.*\n//;
+redo LINE if $_;
+next LINE;
+EOT
+ next;
+ }
+
+ if (/^N/) {
+ chop($_ = <<'EOT');
+$_ .= <>;
+<<--#ifdef TSEEN
+$tflag = '';
+<<--#endif
+EOT
+ next;
+ }
+
+ if (/^h/) {
+ $_ = '$hold = $_;';
+ next;
+ }
+
+ if (/^H/) {
+ $_ = '$hold .= $_ ? $_ : "\n";';
+ next;
+ }
+
+ if (/^g/) {
+ $_ = '$_ = $hold;';
+ next;
+ }
+
+ if (/^G/) {
+ $_ = '$_ .= $hold ? $hold : "\n";';
+ next;
+ }
+
+ if (/^x/) {
+ $_ = '($_, $hold) = ($hold, $_);';
+ next;
+ }
+
+ if (/^b$/) {
+ $_ = 'next LINE;';
+ next;
+ }
+
+ if (/^b/) {
+ s/^b[ \t]*//;
+ $lab = &make_label($_);
+ if ($lab eq $toplabel) {
+ $_ = 'redo LINE;';
+ } else {
+ $_ = "goto $lab;";
+ }
+ next;
+ }
+
+ if (/^t$/) {
+ $_ = 'next LINE if $tflag;';
+ $tseen++;
+ next;
+ }
+
+ if (/^t/) {
+ s/^t[ \t]*//;
+ $lab = &make_label($_);
+ $_ = q/if ($tflag) {$tflag = ''; /;
+ if ($lab eq $toplabel) {
+ $_ .= 'redo LINE;}';
+ } else {
+ $_ .= "goto $lab;}";
+ }
+ $tseen++;
+ next;
+ }
+
+ if (/^=/) {
+ $_ = 'print "$.\n";';
+ next;
+ }
+
+ if (/^q/) {
+ chop($_ = <<'EOT');
+close(ARGV);
+@ARGV = ();
+next LINE;
+EOT
+ 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;
+}
--- /dev/null
+@echo off
+perl -x %0.bat
+goto exit
+#!perl
+
+printf "
+This is a self-running perl script for DOS.
+
+"
+
+__END__
+:exit
switch(DosOpen(s, &hf, &usAction, 0L, 0, FILE_OPEN,
OPEN_ACCESS_READONLY | OPEN_SHARE_DENYNONE, 0L)) {
+ case ERROR_INVALID_NAME:
+ case ERROR_FILENAME_EXCED_RANGE:
+ return 0;
case NO_ERROR:
DosClose(hf);
/*FALLTHROUGH*/
default:
return 1;
- case ERROR_FILENAME_EXCED_RANGE:
- return 0;
}
}
#endif /* OS2 */
-#define PATCHLEVEL 44
+#define PATCHLEVEL 0
-char rcsid[] = "$Header: perly.c,v 3.0.1.10 91/01/11 18:22:48 lwall Locked $\nPatch level: ###\n";
+char rcsid[] = "$Header: perl.c,v 4.0 91/03/20 01:37:44 lwall Locked $\nPatch level: ###\n";
/*
* Copyright (c) 1989, Larry Wall
*
* You may distribute under the terms of the GNU General Public License
* as specified in the README file that comes with the perl 3.0 kit.
*
- * $Log: perly.c,v $
- * Revision 3.0.1.10 91/01/11 18:22:48 lwall
- * patch42: added -0 option
- * patch42: ANSIfied the stat mode checking
- * patch42: executables for multiple versions may now coexist
- *
- * Revision 3.0.1.9 90/11/10 01:53:26 lwall
- * patch38: random cleanup
- * patch38: more msdos/os2 upgrades
- * patch38: references to $0 produced core dumps
- * patch38: added hooks for unexec()
- *
- * Revision 3.0.1.8 90/10/16 10:14:20 lwall
- * patch29: *foo now prints as *package'foo
- * patch29: added waitpid
- * patch29: the debugger now understands packages and evals
- * patch29: added -M, -A and -C
- * patch29: -w sometimes printed spurious warnings about ARGV and ENV
- * patch29: require "./foo" didn't work right
- * patch29: require error messages referred to wrong file
- *
- * Revision 3.0.1.7 90/08/13 22:22:22 lwall
- * patch28: defined(@array) and defined(%array) didn't work right
- *
- * Revision 3.0.1.6 90/08/09 04:55:50 lwall
- * patch19: added -x switch to extract script from input trash
- * patch19: Added -c switch to do compilation only
- * patch19: added numeric interpretation of $]
- * patch19: added require operator
- * patch19: $0, %ENV, @ARGV were wrong in dumped script
- * patch19: . is now explicitly in @INC (and last)
- *
- * Revision 3.0.1.5 90/03/27 16:20:57 lwall
- * patch16: MSDOS support
- * patch16: do FILE inside eval blows up
- *
- * Revision 3.0.1.4 90/02/28 18:06:41 lwall
- * patch9: perl can now start up other interpreters scripts
- * patch9: nested evals clobbered their longjmp environment
- * patch9: eval could mistakenly return undef in array context
- *
- * Revision 3.0.1.3 89/12/21 20:15:41 lwall
- * patch7: ANSI strerror() is now supported
- * patch7: errno may now be a macro with an lvalue
- * patch7: allowed setuid scripts to have a space after #!
- *
- * Revision 3.0.1.2 89/11/17 15:34:42 lwall
- * patch5: fixed possible confusion about current effective gid
- *
- * Revision 3.0.1.1 89/11/11 04:50:04 lwall
- * patch2: moved yydebug to where its type didn't matter
- *
- * Revision 3.0 89/10/18 15:22:21 lwall
- * 3.0 baseline
+ * $Log: perl.c,v $
+ * Revision 4.0 91/03/20 01:37:44 lwall
+ * 4.0 baseline.
*
*/
static char* moreswitches();
static char* cddir;
+#ifndef __STDC__
extern char **environ;
+#endif /* ! __STDC__ */
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;
origargv = argv;
origargc = argc;
+ origenviron = environ;
uid = (int)getuid();
euid = (int)geteuid();
gid = (int)getgid();
egid = (int)getegid();
- sprintf(patchlevel,"%3.3s%2.2d", rcsid+19, PATCHLEVEL);
+ 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
case 'd':
case 'D':
case 'i':
+ case 'l':
case 'n':
case 'p':
case 'u':
argc++,argv--;
argv[0] = e_tmpname;
}
+
+#ifdef MSDOS
+#define PERLLIB_SEP ';'
+#else
+#define PERLLIB_SEP ':'
+#endif
+#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
+ {
+ char * s2 = getenv("PERLLIB");
+
+ if ( s2 ) {
+ /* Break at all separators */
+ while ( *s2 ) {
+ /* First, skip any consecutive separators */
+ while ( *s2 == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* (void)apush(stab_array(incstab),str_make(".",1)); */
+ s2++;
+ }
+ if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
+ (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
+ s2 = s+1;
+ } else {
+ (void)apush(stab_array(incstab),str_make(s2,0));
+ break;
+ }
+ }
+ }
+ }
+#endif /* TAINT */
+
#ifndef PRIVLIB
#define PRIVLIB "/usr/local/lib/perl"
#endif
doextract = FALSE;
#ifdef IAMSUID /* actually, this is caught earlier */
if (euid != uid && !euid) /* if running suidperl */
-#ifdef SETEUID
+#ifdef HAS_SETEUID
(void)seteuid(uid); /* musn't stay setuid root */
#else
-#ifdef SETREUID
+#ifdef HAS_SETREUID
(void)setreuid(-1, uid);
#else
setuid(uid);
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? */
int len;
#ifdef IAMSUID
-#ifndef SETREUID
+#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
if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
fatal("Permission denied\n");
}
-#endif /* SETREUID */
+#endif /* HAS_SETREUID */
#endif /* IAMSUID */
if (!S_ISREG(statbuf.st_mode))
}
if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
-#ifdef SETEGID
+#ifdef HAS_SETEGID
(void)setegid(statbuf.st_gid);
#else
-#ifdef SETREGID
+#ifdef HAS_SETREGID
(void)setregid((GIDTYPE)-1,statbuf.st_gid);
#else
setgid(statbuf.st_gid);
#endif
if (statbuf.st_mode & S_ISUID) {
if (statbuf.st_uid != euid)
-#ifdef SETEUID
+#ifdef HAS_SETEUID
(void)seteuid(statbuf.st_uid); /* all that for this */
#else
-#ifdef SETREUID
+#ifdef HAS_SETREUID
(void)setreuid((UIDTYPE)-1,statbuf.st_uid);
#else
setuid(statbuf.st_uid);
#endif
}
else if (uid) /* oops, mustn't run as root */
-#ifdef SETEUID
+#ifdef HAS_SETEUID
(void)seteuid((UIDTYPE)uid);
#else
-#ifdef SETREUID
+#ifdef HAS_SETREUID
(void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
#else
setuid((UIDTYPE)uid);
(void)hadd(sigstab);
}
- magicalize("!#?^~=-%123456789.+&*()<>,\\/[|`':\024");
+ magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\024\027");
userinit(); /* in case linked C routines want magical variables */
amperstab = stabent("&",allstabs);
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;
+ str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
+
if (do_undump)
my_unexec();
argc--,argv++;
break;
}
- str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
+ 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))
+ if (tmpstab = stabent("0",allstabs)) {
str_set(stab_val(tmpstab),origfilename);
+ magicname("0", Nullch, 0);
+ }
+ if (tmpstab = stabent("\020",allstabs))
+ str_set(stab_val(tmpstab),origargv[0]);
if (argvstab = stabent("ARGV",allstabs)) {
argvstab->str_pok |= SP_MULTI;
(void)aadd(argvstab);
/* NOTREACHED */
}
+void
magicalize(list)
register char *list;
{
magicname(sym, Nullch, 0);
}
-int
+void
magicname(sym,name,namlen)
char *sym;
char *name;
}
}
-/* this routine is in perly.c by virtue of being sort of an alternate main() */
+/* this routine is in perl.c by virtue of being sort of an alternate main() */
int
do_eval(str,optype,stash,gimme,arglast)
{
STR **st = stack->ary_array;
int retval;
- CMD *myroot;
+ CMD *myroot = Nullcmd;
ARRAY *ar;
int i;
CMD * VOLATILE oldcurcmd = curcmd;
VOLATILE int oldsave = savestack->ary_fill;
VOLATILE int oldperldb = perldb;
SPAT * VOLATILE oldspat = curspat;
+ SPAT * VOLATILE oldlspat = lastspat;
static char *last_eval = Nullch;
static CMD *last_root = Nullcmd;
VOLATILE int sp = arglast[0];
char *specfilename;
char *tmpfilename;
+ int parsing = 1;
tmps_base = tmps_max;
if (curstash != stash) {
else {
if (last_root && !in_eval) {
Safefree(last_eval);
+ last_eval = Nullch;
cmd_free(last_root);
last_root = Nullcmd;
}
}
curcmd->c_filestab = fstab(tmpfilename);
Safefree(tmpfilename);
+ tmpfilename = Nullch;
if (!rsfp) {
curcmd = oldcurcmd;
tmps_base = oldtmps_base;
deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
}
#endif
+ eval_root = Nullcmd;
if (setjmp(loop_stack[loop_ptr].loop_env)) {
retval = 1;
- last_root = Nullcmd;
}
else {
error_count = 0;
else if (in_eval == 1) {
if (last_root) {
Safefree(last_eval);
+ last_eval = Nullch;
cmd_free(last_root);
}
- last_eval = savestr(bufptr);
last_root = Nullcmd;
+ last_eval = savestr(bufptr);
retval = yyparse();
retval |= error_count;
if (!retval)
last_root = eval_root;
+ if (!last_root) {
+ Safefree(last_eval);
+ last_eval = Nullch;
+ }
}
else
retval = yyparse();
sp = arglast[0];
if (gimme != G_ARRAY)
st[++sp] = &str_undef;
- last_root = Nullcmd; /* can't free on error, for some reason */
+ 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
+ if (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_static(st[i]);
+ st[i] = str_mortal(st[i]);
/* if we don't save result, free zaps it */
if (in_eval != 1 && myroot != last_root)
cmd_free(myroot);
loop_ptr--;
tmps_base = oldtmps_base;
curspat = oldspat;
+ lastspat = oldlspat;
if (savestack->ary_fill > oldsave) /* let them use local() */
restorelist(oldsave);
moreswitches(s)
char *s;
{
+ int numlen;
+
reswitch:
switch (*s) {
case '0':
- record_separator = 0;
- if (s[1] == '0' && !isdigit(s[2]))
- rslen = 0;
- while (*s >= '0' && *s <= '7') {
- record_separator <<= 3;
- record_separator += *s++ & 7;
+ nrschar = scanoct(s, 4, &numlen);
+ nrs = nsavestr("\n",1);
+ *nrs = nrschar;
+ if (nrschar > 0377) {
+ nrslen = 0;
+ nrs = "";
}
- return s;
+ else if (!nrschar && numlen >= 2) {
+ nrslen = 2;
+ nrs = "\n\n";
+ nrschar = '\n';
+ }
+ return s + numlen;
case 'a':
minus_a = TRUE;
s++;
if (euid != uid || egid != gid)
fatal("No -D allowed in setuid scripts");
#endif
- debug = atoi(s+1);
+ debug = atoi(s+1) | 32768;
#else
warn("Recompile perl with -DDEBUGGING to use -D switch\n");
#endif
- break;
+ for (s++; isdigit(*s); s++) ;
+ return s;
case 'i':
inplace = savestr(s+1);
for (s = inplace; *s && !isspace(*s); s++) ;
*s = '\0';
- argvoutstab = stabent("ARGVOUT",TRUE);
break;
case 'I':
#ifdef TAINT
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++;
s++;
return s;
case 'v':
- fputs("\nThis is perl, version 3.0\n\n",stdout);
+ fputs("\nThis is perl, version 4.0\n\n",stdout);
fputs(rcsid,stdout);
- fputs("\nCopyright (c) 1989, 1990, Larry Wall\n",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);
#endif
fputs("\n\
Perl may be copied only under the terms of the GNU General Public License,\n\
-a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
+a copy of which can be found with the Perl 4.0 distribution kit.\n",stdout);
#ifdef MSDOS
usage(origargv[0]);
#endif
fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
exit(status);
#else
- abort(); /* for use with undump */
+# ifndef SIGABRT
+# define SIGABRT SIGILL
+# endif
+# ifndef SIGILL
+# define SIGILL 6 /* blech */
+# endif
+ kill(getpid(),SIGABRT); /* for use with undump */
#endif
}
-/* $Header: perl.h,v 3.0.1.11 91/01/11 18:10:57 lwall Locked $
+/* $Header: perl.h,v 4.0 91/03/20 01:37:56 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: perl.h,v $
- * Revision 3.0.1.11 91/01/11 18:10:57 lwall
- * patch42: ANSIfied the stat mode checking
- *
- * Revision 3.0.1.10 90/11/10 01:44:13 lwall
- * patch38: more msdos/os2 upgrades
- *
- * Revision 3.0.1.9 90/10/15 17:59:41 lwall
- * patch29: some machines didn't like unsigned C preprocessor values
- *
- * Revision 3.0.1.8 90/08/09 04:10:53 lwall
- * patch19: various MSDOS and OS/2 patches folded in
- * patch19: did preliminary work toward debugging packages and evals
- * patch19: added -x switch to extract script from input trash
- *
- * Revision 3.0.1.7 90/03/27 16:12:52 lwall
- * patch16: MSDOS support
- * patch16: support for machines that can't cast negative floats to unsigned ints
- *
- * Revision 3.0.1.6 90/03/12 16:40:43 lwall
- * patch13: did some ndir straightening up for Xenix
- *
- * Revision 3.0.1.5 90/02/28 17:52:28 lwall
- * patch9: Configure now determines whether volatile is supported
- * patch9: volatilized some more variables for super-optimizing compilers
- * patch9: unused VREG symbol deleted
- * patch9: perl can now start up other interpreters scripts
- * patch9: you may now undef $/ to have no input record separator
- * patch9: nested evals clobbered their longjmp environment
- *
- * Revision 3.0.1.4 89/12/21 20:07:35 lwall
- * patch7: arranged for certain registers to be restored after longjmp()
- * patch7: Configure now compiles a test program to figure out time.h fiasco
- * patch7: Configure now detects DG/UX thingies like [sg]etpgrp2 and utime.h
- * patch7: memcpy() and memset() return void in __STDC__
- * patch7: errno may now be a macro with an lvalue
- * patch7: ANSI strerror() is now supported
- * patch7: Xenix support for sys/ndir.h, cross compilation
- *
- * Revision 3.0.1.3 89/11/17 15:28:57 lwall
- * patch5: byteorder now is a hex value
- * patch5: Configure now looks for <time.h> including <sys/time.h>
- *
- * Revision 3.0.1.2 89/11/11 04:39:38 lwall
- * patch2: Configure may now set -DDEBUGGING
- * patch2: netinet/in.h needed sys/types.h some places
- * patch2: more <sys/time.h> and <time.h> wrangling
- * patch2: yydebug moved to where type doesn't matter
- *
- * Revision 3.0.1.1 89/10/26 23:17:08 lwall
- * patch1: vfork now conditionally defined based on VFORK
- * patch1: DEC risc machines have a buggy memcmp
- * patch1: perl.h now includes <netinet/in.h> if it exists
- *
- * Revision 3.0 89/10/18 15:21:21 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:37:56 lwall
+ * 4.0 baseline.
*
*/
#include "config.h"
#ifdef MSDOS
-/*
- * BUGGY_MSC:
- * This symbol is defined if you are the unfortunate owner of a buggy
- * Microsoft C compiler and want to use intrinsic functions. Versions
- * up to 5.1 are known conform to this definition. This is not needed
- * under Unix.
- */
-#define BUGGY_MSC /**/
-/*
- * BINARY:
- * This symbol is defined if you run under an operating system that
- * distinguishes between binary and text files. If so the function
- * setmode will be used to set the file into binary mode. Unix
- * doesn't distinguish.
- */
-#define BINARY /**/
-
-#define I_FCNTL
-
+/* This stuff now in the MS-DOS config.h file. */
#else /* !MSDOS */
/*
* are not checked by the configuration script, but are directly defined
* here.
*/
-#define CHOWN
-#define CHROOT
-#define FORK
-#define GETLOGIN
-#define GETPPID
-#define KILL
-#define LINK
-#define PIPE
-#define WAIT
-#define UMASK
+#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 GROUP
-#define PASSWD
+#define HAS_GROUP
+#define HAS_PASSWD
#endif /* !MSDOS */
# endif
#endif
-#ifndef VFORK
+#ifndef HAS_VFORK
# define vfork fork
#endif
-#ifdef GETPGRP2
-# ifndef GETPGRP
-# define GETPGRP
+#ifdef HAS_GETPGRP2
+# ifndef HAS_GETPGRP
+# define HAS_GETPGRP
# endif
# define getpgrp getpgrp2
#endif
-#ifdef SETPGRP2
-# ifndef SETPGRP
-# define SETPGRP
+#ifdef HAS_SETPGRP2
+# ifndef HAS_SETPGRP
+# define HAS_SETPGRP
# endif
# define setpgrp setpgrp2
#endif
-#if defined(MEMCMP) && defined(mips) && BYTEORDER == 0x1234
-#undef MEMCMP
+#include <stdio.h>
+#include <ctype.h>
+#include <setjmp.h>
+#ifndef MSDOS
+#include <sys/param.h> /* if this needs types.h we're still wrong */
#endif
+#ifdef __STDC__
+/* Use all the "standard" definitions */
+#include <stdlib.h>
+#include <string.h>
+#endif /* __STDC__ */
-#ifdef MEMCPY
-#ifndef memcpy
-#if defined(__STDC__ ) || defined(MSDOS)
-extern void *memcpy(), *memset();
-#else
-extern char *memcpy(), *memset();
+#if defined(HAS_MEMCMP) && defined(mips) && BYTEORDER == 0x1234
+#undef HAS_MEMCMP
#endif
+
+#ifdef HAS_MEMCPY
+
+# ifndef __STDC__
+# ifndef memcpy
+extern char * memcpy(), *memset();
extern int memcmp();
-#endif
+# endif /* ndef memcpy */
+# endif /* ndef __STDC__ */
+
#define bcopy(s1,s2,l) memcpy(s2,s1,l)
#define bzero(s,l) memset(s,0,l)
-#endif
-#ifndef BCMP /* prefer bcmp slightly 'cuz it doesn't order */
-#define bcmp(s1,s2,l) memcmp(s1,s2,l)
-#endif
+#endif /* HAS_MEMCPY */
-#include <stdio.h>
-#include <ctype.h>
-#include <setjmp.h>
-#ifndef MSDOS
-#include <sys/param.h> /* if this needs types.h we're still wrong */
+#ifndef HAS_BCMP /* prefer bcmp slightly 'cuz it doesn't order */
+#define bcmp(s1,s2,l) memcmp(s1,s2,l)
#endif
#ifndef _TYPES_ /* If types.h defines this it's easy. */
# include <time.h>
#endif
-#ifdef I_SYSTIME
+#ifdef I_SYS_TIME
# ifdef SYSTIMEKERNEL
# define KERNEL
# endif
#include <sys/times.h>
#endif
-#if defined(STRERROR) && (!defined(MKDIR) || !defined(RMDIR))
-#undef STRERROR
+#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR))
+#undef HAS_STRERROR
#endif
#include <errno.h>
#endif
#endif
-#ifdef STRERROR
+#ifdef HAS_STRERROR
char *strerror();
#else
extern int sys_nerr;
#endif
#if defined(mc300) || defined(mc500) || defined(mc700) /* MASSCOMP */
-#ifdef SOCKETPAIR
-#undef SOCKETPAIR
+#ifdef HAS_SOCKETPAIR
+#undef HAS_SOCKETPAIR
#endif
-#ifdef NDBM
-#undef NDBM
+#ifdef HAS_NDBM
+#undef HAS_NDBM
#endif
#endif
-#ifdef NDBM
+#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 ODBM
-#undef ODBM
+#ifdef HAS_ODBM
+#undef HAS_ODBM
#endif
#else
-#ifdef ODBM
+#ifdef HAS_ODBM
#ifdef NULL
#undef NULL /* suppress redefinition message */
#endif
#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent)
#define dbm_close(db) dbmclose()
#define dbm_firstkey(db) firstkey()
-#endif /* ODBM */
-#endif /* NDBM */
+#endif /* HAS_ODBM */
+#endif /* HAS_NDBM */
+#endif /* HAS_GDBM */
#ifdef SOME_DBM
EXT char *dbmkey;
EXT int dbmlen;
# include <dirent.h>
# define DIRENT dirent
#else
-# ifdef I_SYSNDIR
+# ifdef I_SYS_NDIR
# include <sys/ndir.h>
# define DIRENT direct
# else
-# ifdef I_SYSDIR
+# ifdef I_SYS_DIR
# ifdef hp9000s500
# include <ndir.h> /* may be wrong in the future */
# else
#endif
#ifndef S_ISBLK
-# define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK)
+# ifdef S_IFBLK
+# define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK)
+# else
+# define S_ISBLK(m) (0)
+# endif
#endif
#ifndef S_ISREG
#endif
#ifndef S_ISFIFO
-# define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO)
+# ifdef S_IFIFO
+# define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO)
+# else
+# define S_ISFIFO(m) (0)
+# endif
#endif
#ifndef S_ISLNK
#define BYTEORDER 0x1234
#endif
-#if defined(htonl) && !defined(HTONL)
-#define HTONL
+#if defined(htonl) && !defined(HAS_HTONL)
+#define HAS_HTONL
#endif
-#if defined(htons) && !defined(HTONS)
-#define HTONS
+#if defined(htons) && !defined(HAS_HTONS)
+#define HAS_HTONS
#endif
-#if defined(ntohl) && !defined(NTOHL)
-#define NTOHL
+#if defined(ntohl) && !defined(HAS_NTOHL)
+#define HAS_NTOHL
#endif
-#if defined(ntohs) && !defined(NTOHS)
-#define NTOHS
+#if defined(ntohs) && !defined(HAS_NTOHS)
+#define HAS_NTOHS
#endif
-#ifndef HTONL
+#ifndef HAS_HTONL
#if (BYTEORDER & 0xffff) != 0x4321
-#define HTONS
-#define HTONL
-#define NTOHS
-#define NTOHL
+#define HAS_HTONS
+#define HAS_HTONL
+#define HAS_NTOHS
+#define HAS_NTOHL
#define MYSWAP
#define htons my_swap
#define htonl my_htonl
#endif
#else
#if (BYTEORDER & 0xffff) == 0x4321
-#undef HTONS
-#undef HTONL
-#undef NTOHS
-#undef NTOHL
+#undef HAS_HTONS
+#undef HAS_HTONL
+#undef HAS_NTOHS
+#undef HAS_NTOHL
#endif
#endif
char *scansubst();
char *scantrans();
char *scanstr();
-char *scanreg();
+char *scanident();
char *str_append_till();
char *str_gets();
char *str_grow();
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();
EXT char **origargv;
EXT int origargc;
+EXT char **origenviron;
EXT line_t subline INIT(0);
EXT STR *subname INIT(Nullstr);
EXT int arybase INIT(0);
EXT int lastspbase;
EXT int lastsize;
+EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEF");
EXT char *origfilename;
EXT FILE * VOLATILE rsfp;
EXT char buf[1024];
EXT STR *linestr INIT(Nullstr);
-EXT int record_separator INIT('\n');
+EXT char *rs INIT("\n");
+EXT int rschar INIT('\n'); /* final char of rs, or 0777 if none */
EXT int rslen INIT(1);
EXT char *ofs INIT(Nullch);
EXT int ofslen INIT(0);
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);
#define YYDEBUG 1
#endif
EXT int perldb INIT(0);
+#define YYMAXDEPTH 300
EXT line_t cmdline INIT(NOLINE);
EXT char *dc;
EXT short *ds;
+/* Fix these up for __STDC__ */
+EXT long basetime INIT(0);
+char *mktemp();
+#ifndef __STDC__
+/* All of these are in stdlib.h or time.h for ANSI C */
double atof();
long time();
-EXT long basetime INIT(0);
struct tm *gmtime(), *localtime();
-char *mktemp();
char *index(), *rindex();
char *strcpy(), *strcat();
+#endif /* ! __STDC__ */
#ifdef EUNICE
#define UNLINK unlnk
#define UNLINK unlink
#endif
-#ifndef SETREUID
-#ifdef SETRESUID
+#ifndef HAS_SETREUID
+#ifdef HAS_SETRESUID
#define setreuid(r,e) setresuid(r,e,-1)
-#define SETREUID
+#define HAS_SETREUID
#endif
#endif
-#ifndef SETREGID
-#ifdef SETRESGID
+#ifndef HAS_SETREGID
+#ifdef HAS_SETRESGID
#define setregid(r,e) setresgid(r,e,-1)
-#define SETREGID
+#define HAS_SETREGID
#endif
#endif
--- /dev/null
+.rn '' }`
+''' $Header: perl.man,v 4.0 91/03/20 01:38:08 lwall Locked $
+'''
+''' $Log: perl.man,v $
+''' Revision 4.0 91/03/20 01:38:08 lwall
+''' 4.0 baseline.
+'''
+'''
+.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 PERL 1 "\*(RP"
+.UC
+.SH NAME
+perl \- Practical Extraction and Report Language
+.SH SYNOPSIS
+.B perl
+[options] filename args
+.SH DESCRIPTION
+.I 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,
+\fIsed\fR, \fIawk\fR, and \fIsh\fR,
+so people familiar with those languages should have little difficulty with it.
+(Language historians will also note some vestiges of \fIcsh\fR, Pascal, and
+even BASIC-PLUS.)
+Expression syntax corresponds quite closely to C expression syntax.
+Unlike most Unix utilities,
+.I perl
+does not arbitrarily limit the size of your data\*(--if you've got
+the memory,
+.I perl
+can slurp in your whole file as a single string.
+Recursion is of unlimited depth.
+And the hash tables used by associative arrays grow as necessary to prevent
+degraded performance.
+.I Perl
+uses sophisticated pattern matching techniques to scan large amounts of
+data very quickly.
+Although optimized for scanning text,
+.I perl
+can also deal with binary data, and can make dbm files look like associative
+arrays (where dbm is available).
+Setuid
+.I perl
+scripts are safer than C programs
+through a dataflow tracing mechanism which prevents many stupid security holes.
+If you have a problem that would ordinarily use \fIsed\fR
+or \fIawk\fR or \fIsh\fR, but it
+exceeds their capabilities or must run a little faster,
+and you don't want to write the silly thing in C, then
+.I perl
+may be for you.
+There are also translators to turn your
+.I sed
+and
+.I awk
+scripts into
+.I perl
+scripts.
+OK, enough hype.
+.PP
+Upon startup,
+.I perl
+looks for your script in one of the following places:
+.Ip 1. 4 2
+Specified line by line via
+.B \-e
+switches on the command line.
+.Ip 2. 4 2
+Contained in the file specified by the first filename on the command line.
+(Note that systems supporting the #! notation invoke interpreters this way.)
+.Ip 3. 4 2
+Passed in implicitly via standard input.
+This only works if there are no filename arguments\*(--to pass
+arguments to a
+.I stdin
+script you must explicitly specify a \- for the script name.
+.PP
+After locating your script,
+.I perl
+compiles it to an internal form.
+If the script is syntactically correct, it is executed.
+.Sh "Options"
+Note: on first reading this section may not make much sense to you. It's here
+at the front for easy reference.
+.PP
+A single-character option may be combined with the following option, if any.
+This is particularly useful when invoking a script using the #! construct which
+only allows one argument. Example:
+.nf
+
+.ne 2
+ #!/usr/bin/perl \-spi.bak # same as \-s \-p \-i.bak
+ .\|.\|.
+
+.fi
+Options include:
+.TP 5
+.BI \-0 digits
+specifies the record separator ($/) as an octal number.
+If there are no digits, the null character is the separator.
+Other switches may precede or follow the digits.
+For example, if you have a version of
+.I find
+which can print filenames terminated by the null character, you can say this:
+.nf
+
+ find . \-name '*.bak' \-print0 | perl \-n0e unlink
+
+.fi
+The special value 00 will cause Perl to slurp files in paragraph mode.
+The value 0777 will cause Perl to slurp files whole since there is no
+legal character with that value.
+.TP 5
+.B \-a
+turns on autosplit mode when used with a
+.B \-n
+or
+.BR \-p .
+An implicit split command to the @F array
+is done as the first thing inside the implicit while loop produced by
+the
+.B \-n
+or
+.BR \-p .
+.nf
+
+ perl \-ane \'print pop(@F), "\en";\'
+
+is equivalent to
+
+ while (<>) {
+ @F = split(\' \');
+ print pop(@F), "\en";
+ }
+
+.fi
+.TP 5
+.B \-c
+causes
+.I perl
+to check the syntax of the script and then exit without executing it.
+.TP 5
+.BI \-d
+runs the script under the perl debugger.
+See the section on Debugging.
+.TP 5
+.BI \-D number
+sets debugging flags.
+To watch how it executes your script, use
+.BR \-D14 .
+(This only works if debugging is compiled into your
+.IR perl .)
+Another nice value is \-D1024, which lists your compiled syntax tree.
+And \-D512 displays compiled regular expressions.
+.TP 5
+.BI \-e " commandline"
+may be used to enter one line of script.
+Multiple
+.B \-e
+commands may be given to build up a multi-line script.
+If
+.B \-e
+is given,
+.I perl
+will not look for a script filename in the argument list.
+.TP 5
+.BI \-i extension
+specifies that files processed by the <> construct are to be edited
+in-place.
+It does this by renaming the input file, opening the output file by the
+same name, and selecting that output file as the default for print statements.
+The extension, if supplied, is added to the name of the
+old file to make a backup copy.
+If no extension is supplied, no backup is made.
+Saying \*(L"perl \-p \-i.bak \-e "s/foo/bar/;" .\|.\|. \*(R" is the same as using
+the script:
+.nf
+
+.ne 2
+ #!/usr/bin/perl \-pi.bak
+ s/foo/bar/;
+
+which is equivalent to
+
+.ne 14
+ #!/usr/bin/perl
+ while (<>) {
+ if ($ARGV ne $oldargv) {
+ rename($ARGV, $ARGV . \'.bak\');
+ open(ARGVOUT, ">$ARGV");
+ select(ARGVOUT);
+ $oldargv = $ARGV;
+ }
+ s/foo/bar/;
+ }
+ continue {
+ print; # this prints to original filename
+ }
+ select(STDOUT);
+
+.fi
+except that the
+.B \-i
+form doesn't need to compare $ARGV to $oldargv to know when
+the filename has changed.
+It does, however, use ARGVOUT for the selected filehandle.
+Note that
+.I STDOUT
+is restored as the default output filehandle after the loop.
+.Sp
+You can use eof to locate the end of each input file, in case you want
+to append to each file, or reset line numbering (see example under eof).
+.TP 5
+.BI \-I directory
+may be used in conjunction with
+.B \-P
+to tell the C preprocessor where to look for include files.
+By default /usr/include and /usr/lib/perl are searched.
+.TP 5
+.BI \-l octnum
+enables automatic line-ending processing. It has two effects:
+first, it automatically chops the line terminator when used with
+.B \-n
+or
+.B \-p ,
+and second, it assigns $\e to have the value of
+.I octnum
+so that any print statements will have that line terminator added back on. If
+.I octnum
+is omitted, sets $\e to the current value of $/.
+For instance, to trim lines to 80 columns:
+.nf
+
+ perl -lpe \'substr($_, 80) = ""\'
+
+.fi
+Note that the assignment $\e = $/ is done when the switch is processed,
+so the input record separator can be different than the output record
+separator if the
+.B \-l
+switch is followed by a
+.B \-0
+switch:
+.nf
+
+ gnufind / -print0 | perl -ln0e 'print "found $_" if -p'
+
+.fi
+This sets $\e to newline and then sets $/ to the null character.
+.TP 5
+.B \-n
+causes
+.I perl
+to assume the following loop around your script, which makes it iterate
+over filename arguments somewhat like \*(L"sed \-n\*(R" or \fIawk\fR:
+.nf
+
+.ne 3
+ while (<>) {
+ .\|.\|. # your script goes here
+ }
+
+.fi
+Note that the lines are not printed by default.
+See
+.B \-p
+to have lines printed.
+Here is an efficient way to delete all files older than a week:
+.nf
+
+ find . \-mtime +7 \-print | perl \-nle \'unlink;\'
+
+.fi
+This is faster than using the \-exec switch of find because you don't have to
+start a process on every filename found.
+.TP 5
+.B \-p
+causes
+.I perl
+to assume the following loop around your script, which makes it iterate
+over filename arguments somewhat like \fIsed\fR:
+.nf
+
+.ne 5
+ while (<>) {
+ .\|.\|. # your script goes here
+ } continue {
+ print;
+ }
+
+.fi
+Note that the lines are printed automatically.
+To suppress printing use the
+.B \-n
+switch.
+A
+.B \-p
+overrides a
+.B \-n
+switch.
+.TP 5
+.B \-P
+causes your script to be run through the C preprocessor before
+compilation by
+.IR perl .
+(Since both comments and cpp directives begin with the # character,
+you should avoid starting comments with any words recognized
+by the C preprocessor such as \*(L"if\*(R", \*(L"else\*(R" or \*(L"define\*(R".)
+.TP 5
+.B \-s
+enables some rudimentary switch parsing for switches on the command line
+after the script name but before any filename arguments (or before a \-\|\-).
+Any switch found there is removed from @ARGV and sets the corresponding variable in the
+.I perl
+script.
+The following script prints \*(L"true\*(R" if and only if the script is
+invoked with a \-xyz switch.
+.nf
+
+.ne 2
+ #!/usr/bin/perl \-s
+ if ($xyz) { print "true\en"; }
+
+.fi
+.TP 5
+.B \-S
+makes
+.I perl
+use the PATH environment variable to search for the script
+(unless the name of the script starts with a slash).
+Typically this is used to emulate #! startup on machines that don't
+support #!, in the following manner:
+.nf
+
+ #!/usr/bin/perl
+ eval "exec /usr/bin/perl \-S $0 $*"
+ if $running_under_some_shell;
+
+.fi
+The system ignores the first line and feeds the script to /bin/sh,
+which proceeds to try to execute the
+.I perl
+script as a shell script.
+The shell executes the second line as a normal shell command, and thus
+starts up the
+.I perl
+interpreter.
+On some systems $0 doesn't always contain the full pathname,
+so the
+.B \-S
+tells
+.I perl
+to search for the script if necessary.
+After
+.I perl
+locates the script, it parses the lines and ignores them because
+the variable $running_under_some_shell is never true.
+A better construct than $* would be ${1+"$@"}, which handles embedded spaces
+and such in the filenames, but doesn't work if the script is being interpreted
+by csh.
+In order to start up sh rather than csh, some systems may have to replace the
+#! line with a line containing just
+a colon, which will be politely ignored by perl.
+Other systems can't control that, and need a totally devious construct that
+will work under any of csh, sh or perl, such as the following:
+.nf
+
+.ne 3
+ eval '(exit $?0)' && eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
+ & eval 'exec /usr/bin/perl -S $0 $argv:q'
+ if 0;
+
+.fi
+.TP 5
+.B \-u
+causes
+.I perl
+to dump core after compiling your script.
+You can then take this core dump and turn it into an executable file
+by using the undump program (not supplied).
+This speeds startup at the expense of some disk space (which you can
+minimize by stripping the executable).
+(Still, a "hello world" executable comes out to about 200K on my machine.)
+If you are going to run your executable as a set-id program then you
+should probably compile it using taintperl rather than normal perl.
+If you want to execute a portion of your script before dumping, use the
+dump operator instead.
+Note: availability of undump is platform specific and may not be available
+for a specific port of perl.
+.TP 5
+.B \-U
+allows
+.I perl
+to do unsafe operations.
+Currently the only \*(L"unsafe\*(R" operation is the unlinking of directories while
+running as superuser.
+.TP 5
+.B \-v
+prints the version and patchlevel of your
+.I perl
+executable.
+.TP 5
+.B \-w
+prints warnings about identifiers that are mentioned only once, and scalar
+variables that are used before being set.
+Also warns about redefined subroutines, and references to undefined
+filehandles or filehandles opened readonly that you are attempting to
+write on.
+Also warns you if you use == on values that don't look like numbers, and if
+your subroutines recurse more than 100 deep.
+.TP 5
+.BI \-x directory
+tells
+.I perl
+that the script is embedded in a message.
+Leading garbage will be discarded until the first line that starts
+with #! and contains the string "perl".
+Any meaningful switches on that line will be applied (but only one
+group of switches, as with normal #! processing).
+If a directory name is specified, Perl will switch to that directory
+before running the script.
+The
+.B \-x
+switch only controls the the disposal of leading garbage.
+The script must be terminated with __END__ if there is trailing garbage
+to be ignored (the script can process any or all of the trailing garbage
+via the DATA filehandle if desired).
+.Sh "Data Types and Objects"
+.PP
+.I Perl
+has three data types: scalars, arrays of scalars, and
+associative arrays of scalars.
+Normal arrays are indexed by number, and associative arrays by string.
+.PP
+The interpretation of operations and values in perl sometimes
+depends on the requirements
+of the context around the operation or value.
+There are three major contexts: string, numeric and array.
+Certain operations return array values
+in contexts wanting an array, and scalar values otherwise.
+(If this is true of an operation it will be mentioned in the documentation
+for that operation.)
+Operations which return scalars don't care whether the context is looking
+for a string or a number, but
+scalar variables and values are interpreted as strings or numbers
+as appropriate to the context.
+A scalar is interpreted as TRUE in the boolean sense if it is not the null
+string or 0.
+Booleans returned by operators are 1 for true and 0 or \'\' (the null
+string) for false.
+.PP
+There are actually two varieties of null string: defined and undefined.
+Undefined null strings are returned when there is no real value for something,
+such as when there was an error, or at end of file, or when you refer
+to an uninitialized variable or element of an array.
+An undefined null string may become defined the first time you access it, but
+prior to that you can use the defined() operator to determine whether the
+value is defined or not.
+.PP
+References to scalar variables always begin with \*(L'$\*(R', even when referring
+to a scalar that is part of an array.
+Thus:
+.nf
+
+.ne 3
+ $days \h'|2i'# a simple scalar variable
+ $days[28] \h'|2i'# 29th element of array @days
+ $days{\'Feb\'}\h'|2i'# one value from an associative array
+ $#days \h'|2i'# last index of array @days
+
+but entire arrays or array slices are denoted by \*(L'@\*(R':
+
+ @days \h'|2i'# ($days[0], $days[1],\|.\|.\|. $days[n])
+ @days[3,4,5]\h'|2i'# same as @days[3.\|.5]
+ @days{'a','c'}\h'|2i'# same as ($days{'a'},$days{'c'})
+
+and entire associative arrays are denoted by \*(L'%\*(R':
+
+ %days \h'|2i'# (key1, val1, key2, val2 .\|.\|.)
+.fi
+.PP
+Any of these eight constructs may serve as an lvalue,
+that is, may be assigned to.
+(It also turns out that an assignment is itself an lvalue in
+certain contexts\*(--see examples under s, tr and chop.)
+Assignment to a scalar evaluates the righthand side in a scalar context,
+while assignment to an array or array slice evaluates the righthand side
+in an array context.
+.PP
+You may find the length of array @days by evaluating
+\*(L"$#days\*(R", as in
+.IR csh .
+(Actually, it's not the length of the array, it's the subscript of the last element, since there is (ordinarily) a 0th element.)
+Assigning to $#days changes the length of the array.
+Shortening an array by this method does not actually destroy any values.
+Lengthening an array that was previously shortened recovers the values that
+were in those elements.
+You can also gain some measure of efficiency by preextending an array that
+is going to get big.
+(You can also extend an array by assigning to an element that is off the
+end of the array.
+This differs from assigning to $#whatever in that intervening values
+are set to null rather than recovered.)
+You can truncate an array down to nothing by assigning the null list () to
+it.
+The following are exactly equivalent
+.nf
+
+ @whatever = ();
+ $#whatever = $[ \- 1;
+
+.fi
+.PP
+If you evaluate an array in a scalar context, it returns the length of
+the array.
+The following is always true:
+.nf
+
+ @whatever == $#whatever \- $[ + 1;
+
+.fi
+.PP
+Multi-dimensional arrays are not directly supported, but see the discussion
+of the $; variable later for a means of emulating multiple subscripts with
+an associative array.
+You could also write a subroutine to turn multiple subscripts into a single
+subscript.
+.PP
+Every data type has its own namespace.
+You can, without fear of conflict, use the same name for a scalar variable,
+an array, an associative array, a filehandle, a subroutine name, and/or
+a label.
+Since variable and array references always start with \*(L'$\*(R', \*(L'@\*(R',
+or \*(L'%\*(R', the \*(L"reserved\*(R" words aren't in fact reserved
+with respect to variable names.
+(They ARE reserved with respect to labels and filehandles, however, which
+don't have an initial special character.
+Hint: you could say open(LOG,\'logfile\') rather than open(log,\'logfile\').
+Using uppercase filehandles also improves readability and protects you
+from conflict with future reserved words.)
+Case IS significant\*(--\*(L"FOO\*(R", \*(L"Foo\*(R" and \*(L"foo\*(R" are all
+different names.
+Names which start with a letter may also contain digits and underscores.
+Names which do not start with a letter are limited to one character,
+e.g. \*(L"$%\*(R" or \*(L"$$\*(R".
+(Most of the one character names have a predefined significance to
+.IR perl .
+More later.)
+.PP
+Numeric literals are specified in any of the usual floating point or
+integer formats:
+.nf
+
+.ne 5
+ 12345
+ 12345.67
+ .23E-10
+ 0xffff # hex
+ 0377 # octal
+
+.fi
+String literals are delimited by either single or double quotes.
+They work much like shell quotes:
+double-quoted string literals are subject to backslash and variable
+substitution; single-quoted strings are not (except for \e\' and \e\e).
+The usual backslash rules apply for making characters such as newline, tab,
+etc., as well as some more exotic forms:
+.nf
+
+ \et tab
+ \en newline
+ \er return
+ \ef form feed
+ \eb backspace
+ \ea alarm (bell)
+ \ee escape
+ \e033 octal char
+ \ex1b hex char
+ \ec[ control char
+ \el lowercase next char
+ \eu uppercase next char
+ \eL lowercase till \eE
+ \eU uppercase till \eE
+ \eE end case modification
+
+.fi
+You can also embed newlines directly in your strings, i.e. they can end on
+a different line than they begin.
+This is nice, but if you forget your trailing quote, the error will not be
+reported until
+.I perl
+finds another line containing the quote character, which
+may be much further on in the script.
+Variable substitution inside strings is limited to scalar variables, normal
+array values, and array slices.
+(In other words, identifiers beginning with $ or @, followed by an optional
+bracketed expression as a subscript.)
+The following code segment prints out \*(L"The price is $100.\*(R"
+.nf
+
+.ne 2
+ $Price = \'$100\';\h'|3.5i'# not interpreted
+ print "The price is $Price.\e\|n";\h'|3.5i'# interpreted
+
+.fi
+Note that you can put curly brackets around the identifier to delimit it
+from following alphanumerics.
+Also note that a single quoted string must be separated from a preceding
+word by a space, since single quote is a valid character in an identifier
+(see Packages).
+.PP
+Two special literals are __LINE__ and __FILE__, which represent the current
+line number and filename at that point in your program.
+They may only be used as separate tokens; they will not be interpolated
+into strings.
+In addition, the token __END__ may be used to indicate the logical end of the
+script before the actual end of file.
+Any following text is ignored (but may be read via the DATA filehandle).
+The two control characters ^D and ^Z are synonyms for __END__.
+.PP
+A word that doesn't have any other interpretation in the grammar will be
+treated as if it had single quotes around it.
+For this purpose, a word consists only of alphanumeric characters and underline,
+and must start with an alphabetic character.
+As with filehandles and labels, a bare word that consists entirely of
+lowercase letters risks conflict with future reserved words, and if you
+use the
+.B \-w
+switch, Perl will warn you about any such words.
+.PP
+Array values are interpolated into double-quoted strings by joining all the
+elements of the array with the delimiter specified in the $" variable,
+space by default.
+(Since in versions of perl prior to 3.0 the @ character was not a metacharacter
+in double-quoted strings, the interpolation of @array, $array[EXPR],
+@array[LIST], $array{EXPR}, or @array{LIST} only happens if array is
+referenced elsewhere in the program or is predefined.)
+The following are equivalent:
+.nf
+
+.ne 4
+ $temp = join($",@ARGV);
+ system "echo $temp";
+
+ system "echo @ARGV";
+
+.fi
+Within search patterns (which also undergo double-quotish substitution)
+there is a bad ambiguity: Is /$foo[bar]/ to be
+interpreted as /${foo}[bar]/ (where [bar] is a character class for the
+regular expression) or as /${foo[bar]}/ (where [bar] is the subscript to
+array @foo)?
+If @foo doesn't otherwise exist, then it's obviously a character class.
+If @foo exists, perl takes a good guess about [bar], and is almost always right.
+If it does guess wrong, or if you're just plain paranoid,
+you can force the correct interpretation with curly brackets as above.
+.PP
+A line-oriented form of quoting is based on the shell here-is syntax.
+Following a << you specify a string to terminate the quoted material, and all lines
+following the current line down to the terminating string are the value
+of the item.
+The terminating string may be either an identifier (a word), or some
+quoted text.
+If quoted, the type of quotes you use determines the treatment of the text,
+just as in regular quoting.
+An unquoted identifier works like double quotes.
+There must be no space between the << and the identifier.
+(If you put a space it will be treated as a null identifier, which is
+valid, and matches the first blank line\*(--see Merry Christmas example below.)
+The terminating string must appear by itself (unquoted and with no surrounding
+whitespace) on the terminating line.
+.nf
+
+ print <<EOF; # same as above
+The price is $Price.
+EOF
+
+ print <<"EOF"; # same as above
+The price is $Price.
+EOF
+
+ print << x 10; # null identifier is delimiter
+Merry Christmas!
+
+ print <<`EOC`; # execute commands
+echo hi there
+echo lo there
+EOC
+
+ print <<foo, <<bar; # you can stack them
+I said foo.
+foo
+I said bar.
+bar
+
+.fi
+Array literals are denoted by separating individual values by commas, and
+enclosing the list in parentheses:
+.nf
+
+ (LIST)
+
+.fi
+In a context not requiring an array value, the value of the array literal
+is the value of the final element, as in the C comma operator.
+For example,
+.nf
+
+.ne 4
+ @foo = (\'cc\', \'\-E\', $bar);
+
+assigns the entire array value to array foo, but
+
+ $foo = (\'cc\', \'\-E\', $bar);
+
+.fi
+assigns the value of variable bar to variable foo.
+Note that the value of an actual array in a scalar context is the length
+of the array; the following assigns to $foo the value 3:
+.nf
+
+.ne 2
+ @foo = (\'cc\', \'\-E\', $bar);
+ $foo = @foo; # $foo gets 3
+
+.fi
+You may have an optional comma before the closing parenthesis of an
+array literal, so that you can say:
+.nf
+
+ @foo = (
+ 1,
+ 2,
+ 3,
+ );
+
+.fi
+When a LIST is evaluated, each element of the list is evaluated in
+an array context, and the resulting array value is interpolated into LIST
+just as if each individual element were a member of LIST. Thus arrays
+lose their identity in a LIST\*(--the list
+
+ (@foo,@bar,&SomeSub)
+
+contains all the elements of @foo followed by all the elements of @bar,
+followed by all the elements returned by the subroutine named SomeSub.
+.PP
+A list value may also be subscripted like a normal array.
+Examples:
+.nf
+
+ $time = (stat($file))[8]; # stat returns array value
+ $digit = ('a','b','c','d','e','f')[$digit-10];
+ return (pop(@foo),pop(@foo))[0];
+
+.fi
+.PP
+Array lists may be assigned to if and only if each element of the list
+is an lvalue:
+.nf
+
+ ($a, $b, $c) = (1, 2, 3);
+
+ ($map{\'red\'}, $map{\'blue\'}, $map{\'green\'}) = (0x00f, 0x0f0, 0xf00);
+
+The final element may be an array or an associative array:
+
+ ($a, $b, @rest) = split;
+ local($a, $b, %rest) = @_;
+
+.fi
+You can actually put an array anywhere in the list, but the first array
+in the list will soak up all the values, and anything after it will get
+a null value.
+This may be useful in a local().
+.PP
+An associative array literal contains pairs of values to be interpreted
+as a key and a value:
+.nf
+
+.ne 2
+ # same as map assignment above
+ %map = ('red',0x00f,'blue',0x0f0,'green',0xf00);
+
+.fi
+Array assignment in a scalar context returns the number of elements
+produced by the expression on the right side of the assignment:
+.nf
+
+ $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2
+
+.fi
+.PP
+There are several other pseudo-literals that you should know about.
+If a string is enclosed by backticks (grave accents), it first undergoes
+variable substitution just like a double quoted string.
+It is then interpreted as a command, and the output of that command
+is the value of the pseudo-literal, like in a shell.
+In a scalar context, a single string consisting of all the output is
+returned.
+In an array context, an array of values is returned, one for each line
+of output.
+(You can set $/ to use a different line terminator.)
+The command is executed each time the pseudo-literal is evaluated.
+The status value of the command is returned in $? (see Predefined Names
+for the interpretation of $?).
+Unlike in \f2csh\f1, no translation is done on the return
+data\*(--newlines remain newlines.
+Unlike in any of the shells, single quotes do not hide variable names
+in the command from interpretation.
+To pass a $ through to the shell you need to hide it with a backslash.
+.PP
+Evaluating a filehandle in angle brackets yields the next line
+from that file (newline included, so it's never false until EOF, at
+which time an undefined value is returned).
+Ordinarily you must assign that value to a variable,
+but there is one situation where an automatic assignment happens.
+If (and only if) the input symbol is the only thing inside the conditional of a
+.I while
+loop, the value is
+automatically assigned to the variable \*(L"$_\*(R".
+(This may seem like an odd thing to you, but you'll use the construct
+in almost every
+.I perl
+script you write.)
+Anyway, the following lines are equivalent to each other:
+.nf
+
+.ne 5
+ while ($_ = <STDIN>) { print; }
+ while (<STDIN>) { print; }
+ for (\|;\|<STDIN>;\|) { print; }
+ print while $_ = <STDIN>;
+ print while <STDIN>;
+
+.fi
+The filehandles
+.IR STDIN ,
+.I STDOUT
+and
+.I STDERR
+are predefined.
+(The filehandles
+.IR stdin ,
+.I stdout
+and
+.I stderr
+will also work except in packages, where they would be interpreted as
+local identifiers rather than global.)
+Additional filehandles may be created with the
+.I open
+function.
+.PP
+If a <FILEHANDLE> is used in a context that is looking for an array, an array
+consisting of all the input lines is returned, one line per array element.
+It's easy to make a LARGE data space this way, so use with care.
+.PP
+The null filehandle <> is special and can be used to emulate the behavior of
+\fIsed\fR and \fIawk\fR.
+Input from <> comes either from standard input, or from each file listed on
+the command line.
+Here's how it works: the first time <> is evaluated, the ARGV array is checked,
+and if it is null, $ARGV[0] is set to \'-\', which when opened gives you standard
+input.
+The ARGV array is then processed as a list of filenames.
+The loop
+.nf
+
+.ne 3
+ while (<>) {
+ .\|.\|. # code for each line
+ }
+
+.ne 10
+is equivalent to
+
+ unshift(@ARGV, \'\-\') \|if \|$#ARGV < $[;
+ while ($ARGV = shift) {
+ open(ARGV, $ARGV);
+ while (<ARGV>) {
+ .\|.\|. # code for each line
+ }
+ }
+
+.fi
+except that it isn't as cumbersome to say.
+It really does shift array ARGV and put the current filename into
+variable ARGV.
+It also uses filehandle ARGV internally.
+You can modify @ARGV before the first <> as long as you leave the first
+filename at the beginning of the array.
+Line numbers ($.) continue as if the input was one big happy file.
+(But see example under eof for how to reset line numbers on each file.)
+.PP
+.ne 5
+If you want to set @ARGV to your own list of files, go right ahead.
+If you want to pass switches into your script, you can
+put a loop on the front like this:
+.nf
+
+.ne 10
+ while ($_ = $ARGV[0], /\|^\-/\|) {
+ shift;
+ last if /\|^\-\|\-$\|/\|;
+ /\|^\-D\|(.*\|)/ \|&& \|($debug = $1);
+ /\|^\-v\|/ \|&& \|$verbose++;
+ .\|.\|. # other switches
+ }
+ while (<>) {
+ .\|.\|. # code for each line
+ }
+
+.fi
+The <> symbol will return FALSE only once.
+If you call it again after this it will assume you are processing another
+@ARGV list, and if you haven't set @ARGV, will input from
+.IR STDIN .
+.PP
+If the string inside the angle brackets is a reference to a scalar variable
+(e.g. <$foo>),
+then that variable contains the name of the filehandle to input from.
+.PP
+If the string inside angle brackets is not a filehandle, it is interpreted
+as a filename pattern to be globbed, and either an array of filenames or the
+next filename in the list is returned, depending on context.
+One level of $ interpretation is done first, but you can't say <$foo>
+because that's an indirect filehandle as explained in the previous
+paragraph.
+You could insert curly brackets to force interpretation as a
+filename glob: <${foo}>.
+Example:
+.nf
+
+.ne 3
+ while (<*.c>) {
+ chmod 0644, $_;
+ }
+
+is equivalent to
+
+.ne 5
+ open(foo, "echo *.c | tr \-s \' \et\er\ef\' \'\e\e012\e\e012\e\e012\e\e012\'|");
+ while (<foo>) {
+ chop;
+ chmod 0644, $_;
+ }
+
+.fi
+In fact, it's currently implemented that way.
+(Which means it will not work on filenames with spaces in them unless
+you have /bin/csh on your machine.)
+Of course, the shortest way to do the above is:
+.nf
+
+ chmod 0644, <*.c>;
+
+.fi
+.Sh "Syntax"
+.PP
+A
+.I perl
+script consists of a sequence of declarations and commands.
+The only things that need to be declared in
+.I perl
+are report formats and subroutines.
+See the sections below for more information on those declarations.
+All uninitialized user-created objects are assumed to
+start with a null or 0 value until they
+are defined by some explicit operation such as assignment.
+The sequence of commands is executed just once, unlike in
+.I sed
+and
+.I awk
+scripts, where the sequence of commands is executed for each input line.
+While this means that you must explicitly loop over the lines of your input file
+(or files), it also means you have much more control over which files and which
+lines you look at.
+(Actually, I'm lying\*(--it is possible to do an implicit loop with either the
+.B \-n
+or
+.B \-p
+switch.)
+.PP
+A declaration can be put anywhere a command can, but has no effect on the
+execution of the primary sequence of commands\*(--declarations all take effect
+at compile time.
+Typically all the declarations are put at the beginning or the end of the script.
+.PP
+.I Perl
+is, for the most part, a free-form language.
+(The only exception to this is format declarations, for fairly obvious reasons.)
+Comments are indicated by the # character, and extend to the end of the line.
+If you attempt to use /* */ C comments, it will be interpreted either as
+division or pattern matching, depending on the context.
+So don't do that.
+.Sh "Compound statements"
+In
+.IR perl ,
+a sequence of commands may be treated as one command by enclosing it
+in curly brackets.
+We will call this a BLOCK.
+.PP
+The following compound commands may be used to control flow:
+.nf
+
+.ne 4
+ if (EXPR) BLOCK
+ if (EXPR) BLOCK else BLOCK
+ if (EXPR) BLOCK elsif (EXPR) BLOCK .\|.\|. else BLOCK
+ LABEL while (EXPR) BLOCK
+ LABEL while (EXPR) BLOCK continue BLOCK
+ LABEL for (EXPR; EXPR; EXPR) BLOCK
+ LABEL foreach VAR (ARRAY) BLOCK
+ LABEL BLOCK continue BLOCK
+
+.fi
+Note that, unlike C and Pascal, these are defined in terms of BLOCKs, not
+statements.
+This means that the curly brackets are \fIrequired\fR\*(--no dangling statements allowed.
+If you want to write conditionals without curly brackets there are several
+other ways to do it.
+The following all do the same thing:
+.nf
+
+.ne 5
+ if (!open(foo)) { die "Can't open $foo: $!"; }
+ die "Can't open $foo: $!" unless open(foo);
+ open(foo) || die "Can't open $foo: $!"; # foo or bust!
+ open(foo) ? \'hi mom\' : die "Can't open $foo: $!";
+ # a bit exotic, that last one
+
+.fi
+.PP
+The
+.I if
+statement is straightforward.
+Since BLOCKs are always bounded by curly brackets, there is never any
+ambiguity about which
+.I if
+an
+.I else
+goes with.
+If you use
+.I unless
+in place of
+.IR if ,
+the sense of the test is reversed.
+.PP
+The
+.I while
+statement executes the block as long as the expression is true
+(does not evaluate to the null string or 0).
+The LABEL is optional, and if present, consists of an identifier followed by
+a colon.
+The LABEL identifies the loop for the loop control statements
+.IR next ,
+.IR last ,
+and
+.I redo
+(see below).
+If there is a
+.I continue
+BLOCK, it is always executed just before
+the conditional is about to be evaluated again, similarly to the third part
+of a
+.I for
+loop in C.
+Thus it can be used to increment a loop variable, even when the loop has
+been continued via the
+.I next
+statement (similar to the C \*(L"continue\*(R" statement).
+.PP
+If the word
+.I while
+is replaced by the word
+.IR until ,
+the sense of the test is reversed, but the conditional is still tested before
+the first iteration.
+.PP
+In either the
+.I if
+or the
+.I while
+statement, you may replace \*(L"(EXPR)\*(R" with a BLOCK, and the conditional
+is true if the value of the last command in that block is true.
+.PP
+The
+.I for
+loop works exactly like the corresponding
+.I while
+loop:
+.nf
+
+.ne 12
+ for ($i = 1; $i < 10; $i++) {
+ .\|.\|.
+ }
+
+is the same as
+
+ $i = 1;
+ while ($i < 10) {
+ .\|.\|.
+ } continue {
+ $i++;
+ }
+.fi
+.PP
+The foreach loop iterates over a normal array value and sets the variable
+VAR to be each element of the array in turn.
+The variable is implicitly local to the loop, and regains its former value
+upon exiting the loop.
+The \*(L"foreach\*(R" keyword is actually identical to the \*(L"for\*(R" keyword,
+so you can use \*(L"foreach\*(R" for readability or \*(L"for\*(R" for brevity.
+If VAR is omitted, $_ is set to each value.
+If ARRAY is an actual array (as opposed to an expression returning an array
+value), you can modify each element of the array
+by modifying VAR inside the loop.
+Examples:
+.nf
+
+.ne 5
+ for (@ary) { s/foo/bar/; }
+
+ foreach $elem (@elements) {
+ $elem *= 2;
+ }
+
+.ne 3
+ for ((10,9,8,7,6,5,4,3,2,1,\'BOOM\')) {
+ print $_, "\en"; sleep(1);
+ }
+
+ for (1..15) { print "Merry Christmas\en"; }
+
+.ne 3
+ foreach $item (split(/:[\e\e\en:]*/, $ENV{\'TERMCAP\'})) {
+ print "Item: $item\en";
+ }
+
+.fi
+.PP
+The BLOCK by itself (labeled or not) is equivalent to a loop that executes
+once.
+Thus you can use any of the loop control statements in it to leave or
+restart the block.
+The
+.I continue
+block is optional.
+This construct is particularly nice for doing case structures.
+.nf
+
+.ne 6
+ foo: {
+ if (/^abc/) { $abc = 1; last foo; }
+ if (/^def/) { $def = 1; last foo; }
+ if (/^xyz/) { $xyz = 1; last foo; }
+ $nothing = 1;
+ }
+
+.fi
+There is no official switch statement in perl, because there
+are already several ways to write the equivalent.
+In addition to the above, you could write
+.nf
+
+.ne 6
+ foo: {
+ $abc = 1, last foo if /^abc/;
+ $def = 1, last foo if /^def/;
+ $xyz = 1, last foo if /^xyz/;
+ $nothing = 1;
+ }
+
+or
+
+.ne 6
+ foo: {
+ /^abc/ && do { $abc = 1; last foo; };
+ /^def/ && do { $def = 1; last foo; };
+ /^xyz/ && do { $xyz = 1; last foo; };
+ $nothing = 1;
+ }
+
+or
+
+.ne 6
+ foo: {
+ /^abc/ && ($abc = 1, last foo);
+ /^def/ && ($def = 1, last foo);
+ /^xyz/ && ($xyz = 1, last foo);
+ $nothing = 1;
+ }
+
+or even
+
+.ne 8
+ if (/^abc/)
+ { $abc = 1; }
+ elsif (/^def/)
+ { $def = 1; }
+ elsif (/^xyz/)
+ { $xyz = 1; }
+ else
+ {$nothing = 1;}
+
+.fi
+As it happens, these are all optimized internally to a switch structure,
+so perl jumps directly to the desired statement, and you needn't worry
+about perl executing a lot of unnecessary statements when you have a string
+of 50 elsifs, as long as you are testing the same simple scalar variable
+using ==, eq, or pattern matching as above.
+(If you're curious as to whether the optimizer has done this for a particular
+case statement, you can use the \-D1024 switch to list the syntax tree
+before execution.)
+.Sh "Simple statements"
+The only kind of simple statement is an expression evaluated for its side
+effects.
+Every expression (simple statement) must be terminated with a semicolon.
+Note that this is like C, but unlike Pascal (and
+.IR awk ).
+.PP
+Any simple statement may optionally be followed by a
+single modifier, just before the terminating semicolon.
+The possible modifiers are:
+.nf
+
+.ne 4
+ if EXPR
+ unless EXPR
+ while EXPR
+ until EXPR
+
+.fi
+The
+.I if
+and
+.I unless
+modifiers have the expected semantics.
+The
+.I while
+and
+.I until
+modifiers also have the expected semantics (conditional evaluated first),
+except when applied to a do-BLOCK or a do-SUBROUTINE command,
+in which case the block executes once before the conditional is evaluated.
+This is so that you can write loops like:
+.nf
+
+.ne 4
+ do {
+ $_ = <STDIN>;
+ .\|.\|.
+ } until $_ \|eq \|".\|\e\|n";
+
+.fi
+(See the
+.I do
+operator below. Note also that the loop control commands described later will
+NOT work in this construct, since modifiers don't take loop labels.
+Sorry.)
+.Sh "Expressions"
+Since
+.I perl
+expressions work almost exactly like C expressions, only the differences
+will be mentioned here.
+.PP
+Here's what
+.I perl
+has that C doesn't:
+.Ip ** 8 2
+The exponentiation operator.
+.Ip **= 8
+The exponentiation assignment operator.
+.Ip (\|) 8 3
+The null list, used to initialize an array to null.
+.Ip . 8
+Concatenation of two strings.
+.Ip .= 8
+The concatenation assignment operator.
+.Ip eq 8
+String equality (== is numeric equality).
+For a mnemonic just think of \*(L"eq\*(R" as a string.
+(If you are used to the
+.I awk
+behavior of using == for either string or numeric equality
+based on the current form of the comparands, beware!
+You must be explicit here.)
+.Ip ne 8
+String inequality (!= is numeric inequality).
+.Ip lt 8
+String less than.
+.Ip gt 8
+String greater than.
+.Ip le 8
+String less than or equal.
+.Ip ge 8
+String greater than or equal.
+.Ip cmp 8
+String comparison, returning -1, 0, or 1.
+.Ip <=> 8
+Numeric comparison, returning -1, 0, or 1.
+.Ip =~ 8 2
+Certain operations search or modify the string \*(L"$_\*(R" by default.
+This operator makes that kind of operation work on some other string.
+The right argument is a search pattern, substitution, or translation.
+The left argument is what is supposed to be searched, substituted, or
+translated instead of the default \*(L"$_\*(R".
+The return value indicates the success of the operation.
+(If the right argument is an expression other than a search pattern,
+substitution, or translation, it is interpreted as a search pattern
+at run time.
+This is less efficient than an explicit search, since the pattern must
+be compiled every time the expression is evaluated.)
+The precedence of this operator is lower than unary minus and autoincrement/decrement, but higher than everything else.
+.Ip !~ 8
+Just like =~ except the return value is negated.
+.Ip x 8
+The repetition operator.
+Returns a string consisting of the left operand repeated the
+number of times specified by the right operand.
+In an array context, if the left operand is a list in parens, it repeats
+the list.
+.nf
+
+ print \'\-\' x 80; # print row of dashes
+ print \'\-\' x80; # illegal, x80 is identifier
+
+ print "\et" x ($tab/8), \' \' x ($tab%8); # tab over
+
+ @ones = (1) x ; # an array of 80 1's
+ @ones = (5) x @ones; # set all elements to 5
+
+.fi
+.Ip x= 8
+The repetition assignment operator.
+Only works on scalars.
+.Ip .\|. 8
+The range operator, which is really two different operators depending
+on the context.
+In an array context, returns an array of values counting (by ones)
+from the left value to the right value.
+This is useful for writing \*(L"for (1..10)\*(R" loops and for doing
+slice operations on arrays.
+.Sp
+In a scalar context, .\|. returns a boolean value.
+The operator is bistable, like a flip-flop..
+Each .\|. operator maintains its own boolean state.
+It is false as long as its left operand is false.
+Once the left operand is true, the range operator stays true
+until the right operand is true,
+AFTER which the range operator becomes false again.
+(It doesn't become false till the next time the range operator is evaluated.
+It can become false on the same evaluation it became true, but it still returns
+true once.)
+The right operand is not evaluated while the operator is in the \*(L"false\*(R" state,
+and the left operand is not evaluated while the operator is in the \*(L"true\*(R" state.
+The scalar .\|. operator is primarily intended for doing line number ranges
+after
+the fashion of \fIsed\fR or \fIawk\fR.
+The precedence is a little lower than || and &&.
+The value returned is either the null string for false, or a sequence number
+(beginning with 1) for true.
+The sequence number is reset for each range encountered.
+The final sequence number in a range has the string \'E0\' appended to it, which
+doesn't affect its numeric value, but gives you something to search for if you
+want to exclude the endpoint.
+You can exclude the beginning point by waiting for the sequence number to be
+greater than 1.
+If either operand of scalar .\|. is static, that operand is implicitly compared
+to the $. variable, the current line number.
+Examples:
+.nf
+
+.ne 6
+As a scalar operator:
+ if (101 .\|. 200) { print; } # print 2nd hundred lines
+
+ next line if (1 .\|. /^$/); # skip header lines
+
+ s/^/> / if (/^$/ .\|. eof()); # quote body
+
+.ne 4
+As an array operator:
+ for (101 .\|. 200) { print; } # print $_ 100 times
+
+ @foo = @foo[$[ .\|. $#foo]; # an expensive no-op
+ @foo = @foo[$#foo-4 .\|. $#foo]; # slice last 5 items
+
+.fi
+.Ip \-x 8
+A file test.
+This unary operator takes one argument, either a filename or a filehandle,
+and tests the associated file to see if something is true about it.
+If the argument is omitted, tests $_, except for \-t, which tests
+.IR STDIN .
+It returns 1 for true and \'\' for false, or the undefined value if the
+file doesn't exist.
+Precedence is higher than logical and relational operators, but lower than
+arithmetic operators.
+The operator may be any of:
+.nf
+ \-r File is readable by effective uid.
+ \-w File is writable by effective uid.
+ \-x File is executable by effective uid.
+ \-o File is owned by effective uid.
+ \-R File is readable by real uid.
+ \-W File is writable by real uid.
+ \-X File is executable by real uid.
+ \-O File is owned by real uid.
+ \-e File exists.
+ \-z File has zero size.
+ \-s File has non-zero size (returns size).
+ \-f File is a plain file.
+ \-d File is a directory.
+ \-l File is a symbolic link.
+ \-p File is a named pipe (FIFO).
+ \-S File is a socket.
+ \-b File is a block special file.
+ \-c File is a character special file.
+ \-u File has setuid bit set.
+ \-g File has setgid bit set.
+ \-k File has sticky bit set.
+ \-t Filehandle is opened to a tty.
+ \-T File is a text file.
+ \-B File is a binary file (opposite of \-T).
+ \-M Age of file in days when script started.
+ \-A Same for access time.
+ \-C Same for inode change time.
+
+.fi
+The interpretation of the file permission operators \-r, \-R, \-w, \-W, \-x and \-X
+is based solely on the mode of the file and the uids and gids of the user.
+There may be other reasons you can't actually read, write or execute the file.
+Also note that, for the superuser, \-r, \-R, \-w and \-W always return 1, and
+\-x and \-X return 1 if any execute bit is set in the mode.
+Scripts run by the superuser may thus need to do a stat() in order to determine
+the actual mode of the file, or temporarily set the uid to something else.
+.Sp
+Example:
+.nf
+.ne 7
+
+ while (<>) {
+ chop;
+ next unless \-f $_; # ignore specials
+ .\|.\|.
+ }
+
+.fi
+Note that \-s/a/b/ does not do a negated substitution.
+Saying \-exp($foo) still works as expected, however\*(--only single letters
+following a minus are interpreted as file tests.
+.Sp
+The \-T and \-B switches work as follows.
+The first block or so of the file is examined for odd characters such as
+strange control codes or metacharacters.
+If too many odd characters (>10%) are found, it's a \-B file, otherwise it's a \-T file.
+Also, any file containing null in the first block is considered a binary file.
+If \-T or \-B is used on a filehandle, the current stdio buffer is examined
+rather than the first block.
+Both \-T and \-B return TRUE on a null file, or a file at EOF when testing
+a filehandle.
+.PP
+If any of the file tests (or either stat operator) are given the special
+filehandle consisting of a solitary underline, then the stat structure
+of the previous file test (or stat operator) is used, saving a system
+call.
+(This doesn't work with \-t, and you need to remember that lstat and -l
+will leave values in the stat structure for the symbolic link, not the
+real file.)
+Example:
+.nf
+
+ print "Can do.\en" if -r $a || -w _ || -x _;
+
+.ne 9
+ stat($filename);
+ print "Readable\en" if -r _;
+ print "Writable\en" if -w _;
+ print "Executable\en" if -x _;
+ print "Setuid\en" if -u _;
+ print "Setgid\en" if -g _;
+ print "Sticky\en" if -k _;
+ print "Text\en" if -T _;
+ print "Binary\en" if -B _;
+
+.fi
+.PP
+Here is what C has that
+.I perl
+doesn't:
+.Ip "unary &" 12
+Address-of operator.
+.Ip "unary *" 12
+Dereference-address operator.
+.Ip "(TYPE)" 12
+Type casting operator.
+.PP
+Like C,
+.I perl
+does a certain amount of expression evaluation at compile time, whenever
+it determines that all of the arguments to an operator are static and have
+no side effects.
+In particular, string concatenation happens at compile time between literals that don't do variable substitution.
+Backslash interpretation also happens at compile time.
+You can say
+.nf
+
+.ne 2
+ \'Now is the time for all\' . "\|\e\|n" .
+ \'good men to come to.\'
+
+.fi
+and this all reduces to one string internally.
+.PP
+The autoincrement operator has a little extra built-in magic to it.
+If you increment a variable that is numeric, or that has ever been used in
+a numeric context, you get a normal increment.
+If, however, the variable has only been used in string contexts since it
+was set, and has a value that is not null and matches the
+pattern /^[a\-zA\-Z]*[0\-9]*$/, the increment is done
+as a string, preserving each character within its range, with carry:
+.nf
+
+ print ++($foo = \'99\'); # prints \*(L'100\*(R'
+ print ++($foo = \'a0\'); # prints \*(L'a1\*(R'
+ print ++($foo = \'Az\'); # prints \*(L'Ba\*(R'
+ print ++($foo = \'zz\'); # prints \*(L'aaa\*(R'
+
+.fi
+The autodecrement is not magical.
+.PP
+The range operator (in an array context) makes use of the magical
+autoincrement algorithm if the minimum and maximum are strings.
+You can say
+
+ @alphabet = (\'A\' .. \'Z\');
+
+to get all the letters of the alphabet, or
+
+ $hexdigit = (0 .. 9, \'a\' .. \'f\')[$num & 15];
+
+to get a hexadecimal digit, or
+
+ @z2 = (\'01\' .. \'31\'); print @z2[$mday];
+
+to get dates with leading zeros.
+(If the final value specified is not in the sequence that the magical increment
+would produce, the sequence goes until the next value would be longer than
+the final value specified.)
+.PP
+The || and && operators differ from C's in that, rather than returning 0 or 1,
+they return the last value evaluated.
+Thus, a portable way to find out the home directory might be:
+.nf
+
+ $home = $ENV{'HOME'} || $ENV{'LOGDIR'} ||
+ (getpwuid($<))[7] || die "You're homeless!\en";
+
+.fi
+''' Beginning of part 2
+''' $Header: perl.man,v 4.0 91/03/20 01:38:08 lwall Locked $
+'''
+''' $Log: perl.man,v $
+''' Revision 4.0 91/03/20 01:38:08 lwall
+''' 4.0 baseline.
+'''
+''' Revision 3.0.1.11 91/01/11 18:17:08 lwall
+''' patch42: fixed some man page entries
+'''
+''' Revision 3.0.1.10 90/11/10 01:46:29 lwall
+''' patch38: random cleanup
+''' patch38: added alarm function
+'''
+''' Revision 3.0.1.9 90/10/15 18:17:37 lwall
+''' patch29: added caller
+''' patch29: index and substr now have optional 3rd args
+''' patch29: added SysV IPC
+'''
+''' Revision 3.0.1.8 90/08/13 22:21:00 lwall
+''' patch28: documented that you can't interpolate $) or $| in pattern
+'''
+''' Revision 3.0.1.7 90/08/09 04:27:04 lwall
+''' patch19: added require operator
+'''
+''' Revision 3.0.1.6 90/08/03 11:15:29 lwall
+''' patch19: Intermediate diffs for Randal
+'''
+''' Revision 3.0.1.5 90/03/27 16:15:17 lwall
+''' patch16: MSDOS support
+'''
+''' Revision 3.0.1.4 90/03/12 16:46:02 lwall
+''' patch13: documented behavior of @array = /noparens/
+'''
+''' Revision 3.0.1.3 90/02/28 17:55:58 lwall
+''' patch9: grep now returns number of items matched in scalar context
+''' patch9: documented in-place modification capabilites of grep
+'''
+''' Revision 3.0.1.2 89/11/17 15:30:16 lwall
+''' patch5: fixed some manual typos and indent problems
+'''
+''' Revision 3.0.1.1 89/11/11 04:43:10 lwall
+''' patch2: made some line breaks depend on troff vs. nroff
+''' patch2: example of unshift had args backwards
+'''
+''' Revision 3.0 89/10/18 15:21:37 lwall
+''' 3.0 baseline
+'''
+'''
+.PP
+Along with the literals and variables mentioned earlier,
+the operations in the following section can serve as terms in an expression.
+Some of these operations take a LIST as an argument.
+Such a list can consist of any combination of scalar arguments or array values;
+the array values will be included in the list as if each individual element were
+interpolated at that point in the list, forming a longer single-dimensional
+array value.
+Elements of the LIST should be separated by commas.
+If an operation is listed both with and without parentheses around its
+arguments, it means you can either use it as a unary operator or
+as a function call.
+To use it as a function call, the next token on the same line must
+be a left parenthesis.
+(There may be intervening white space.)
+Such a function then has highest precedence, as you would expect from
+a function.
+If any token other than a left parenthesis follows, then it is a
+unary operator, with a precedence depending only on whether it is a LIST
+operator or not.
+LIST operators have lowest precedence.
+All other unary operators have a precedence greater than relational operators
+but less than arithmetic operators.
+See the section on Precedence.
+.Ip "/PATTERN/" 8 4
+See m/PATTERN/.
+.Ip "?PATTERN?" 8 4
+This is just like the /pattern/ search, except that it matches only once between
+calls to the
+.I reset
+operator.
+This is a useful optimization when you only want to see the first occurrence of
+something in each file of a set of files, for instance.
+Only ?? patterns local to the current package are reset.
+.Ip "accept(NEWSOCKET,GENERICSOCKET)" 8 2
+Does the same thing that the accept system call does.
+Returns true if it succeeded, false otherwise.
+See example in section on Interprocess Communication.
+.Ip "alarm(SECONDS)" 8 4
+.Ip "alarm SECONDS" 8
+Arranges to have a SIGALRM delivered to this process after the specified number
+of seconds (minus 1, actually) have elapsed. Thus, alarm(15) will cause
+a SIGALRM at some point more than 14 seconds in the future.
+Only one timer may be counting at once. Each call disables the previous
+timer, and an argument of 0 may be supplied to cancel the previous timer
+without starting a new one.
+The returned value is the amount of time remaining on the previous timer.
+.Ip "atan2(Y,X)" 8 2
+Returns the arctangent of Y/X in the range
+.if t \-\(*p to \(*p.
+.if n \-PI to PI.
+.Ip "bind(SOCKET,NAME)" 8 2
+Does the same thing that the bind system call does.
+Returns true if it succeeded, false otherwise.
+NAME should be a packed address of the proper type for the socket.
+See example in section on Interprocess Communication.
+.Ip "binmode(FILEHANDLE)" 8 4
+.Ip "binmode FILEHANDLE" 8 4
+Arranges for the file to be read in \*(L"binary\*(R" mode in operating systems
+that distinguish between binary and text files.
+Files that are not read in binary mode have CR LF sequences translated
+to LF on input and LF translated to CR LF on output.
+Binmode has no effect under Unix.
+If FILEHANDLE is an expression, the value is taken as the name of
+the filehandle.
+.Ip "caller(EXPR)"
+.Ip "caller"
+Returns the context of the current subroutine call:
+.nf
+
+ ($package,$filename,$line) = caller;
+
+.fi
+With EXPR, returns some extra information that the debugger uses to print
+a stack trace. The value of EXPR indicates how many call frames to go
+back before the current one.
+.Ip "chdir(EXPR)" 8 2
+.Ip "chdir EXPR" 8 2
+Changes the working directory to EXPR, if possible.
+If EXPR is omitted, changes to home directory.
+Returns 1 upon success, 0 otherwise.
+See example under
+.IR die .
+.Ip "chmod(LIST)" 8 2
+.Ip "chmod LIST" 8 2
+Changes the permissions of a list of files.
+The first element of the list must be the numerical mode.
+Returns the number of files successfully changed.
+.nf
+
+.ne 2
+ $cnt = chmod 0755, \'foo\', \'bar\';
+ chmod 0755, @executables;
+
+.fi
+.Ip "chop(LIST)" 8 7
+.Ip "chop(VARIABLE)" 8
+.Ip "chop VARIABLE" 8
+.Ip "chop" 8
+Chops off the last character of a string and returns the character chopped.
+It's used primarily to remove the newline from the end of an input record,
+but is much more efficient than s/\en// because it neither scans nor copies
+the string.
+If VARIABLE is omitted, chops $_.
+Example:
+.nf
+
+.ne 5
+ while (<>) {
+ chop; # avoid \en on last field
+ @array = split(/:/);
+ .\|.\|.
+ }
+
+.fi
+You can actually chop anything that's an lvalue, including an assignment:
+.nf
+
+ chop($cwd = \`pwd\`);
+ chop($answer = <STDIN>);
+
+.fi
+If you chop a list, each element is chopped.
+Only the value of the last chop is returned.
+.Ip "chown(LIST)" 8 2
+.Ip "chown LIST" 8 2
+Changes the owner (and group) of a list of files.
+The first two elements of the list must be the NUMERICAL uid and gid,
+in that order.
+Returns the number of files successfully changed.
+.nf
+
+.ne 2
+ $cnt = chown $uid, $gid, \'foo\', \'bar\';
+ chown $uid, $gid, @filenames;
+
+.fi
+.ne 23
+Here's an example of looking up non-numeric uids:
+.nf
+
+ print "User: ";
+ $user = <STDIN>;
+ chop($user);
+ print "Files: "
+ $pattern = <STDIN>;
+ chop($pattern);
+.ie t \{\
+ open(pass, \'/etc/passwd\') || die "Can't open passwd: $!\en";
+'br\}
+.el \{\
+ open(pass, \'/etc/passwd\')
+ || die "Can't open passwd: $!\en";
+'br\}
+ while (<pass>) {
+ ($login,$pass,$uid,$gid) = split(/:/);
+ $uid{$login} = $uid;
+ $gid{$login} = $gid;
+ }
+ @ary = <${pattern}>; # get filenames
+ if ($uid{$user} eq \'\') {
+ die "$user not in passwd file";
+ }
+ else {
+ chown $uid{$user}, $gid{$user}, @ary;
+ }
+
+.fi
+.Ip "chroot(FILENAME)" 8 5
+.Ip "chroot FILENAME" 8
+Does the same as the system call of that name.
+If you don't know what it does, don't worry about it.
+If FILENAME is omitted, does chroot to $_.
+.Ip "close(FILEHANDLE)" 8 5
+.Ip "close FILEHANDLE" 8
+Closes the file or pipe associated with the file handle.
+You don't have to close FILEHANDLE if you are immediately going to
+do another open on it, since open will close it for you.
+(See
+.IR open .)
+However, an explicit close on an input file resets the line counter ($.), while
+the implicit close done by
+.I open
+does not.
+Also, closing a pipe will wait for the process executing on the pipe to complete,
+in case you want to look at the output of the pipe afterwards.
+Closing a pipe explicitly also puts the status value of the command into $?.
+Example:
+.nf
+
+.ne 4
+ open(OUTPUT, \'|sort >foo\'); # pipe to sort
+ .\|.\|. # print stuff to output
+ close OUTPUT; # wait for sort to finish
+ open(INPUT, \'foo\'); # get sort's results
+
+.fi
+FILEHANDLE may be an expression whose value gives the real filehandle name.
+.Ip "closedir(DIRHANDLE)" 8 5
+.Ip "closedir DIRHANDLE" 8
+Closes a directory opened by opendir().
+.Ip "connect(SOCKET,NAME)" 8 2
+Does the same thing that the connect system call does.
+Returns true if it succeeded, false otherwise.
+NAME should be a package address of the proper type for the socket.
+See example in section on Interprocess Communication.
+.Ip "cos(EXPR)" 8 6
+.Ip "cos EXPR" 8 6
+Returns the cosine of EXPR (expressed in radians).
+If EXPR is omitted takes cosine of $_.
+.Ip "crypt(PLAINTEXT,SALT)" 8 6
+Encrypts a string exactly like the crypt() function in the C library.
+Useful for checking the password file for lousy passwords.
+Only the guys wearing white hats should do this.
+.Ip "dbmclose(ASSOC_ARRAY)" 8 6
+.Ip "dbmclose ASSOC_ARRAY" 8
+Breaks the binding between a dbm file and an associative array.
+The values remaining in the associative array are meaningless unless
+you happen to want to know what was in the cache for the dbm file.
+This function is only useful if you have ndbm.
+.Ip "dbmopen(ASSOC,DBNAME,MODE)" 8 6
+This binds a dbm or ndbm file to an associative array.
+ASSOC is the name of the associative array.
+(Unlike normal open, the first argument is NOT a filehandle, even though
+it looks like one).
+DBNAME is the name of the database (without the .dir or .pag extension).
+If the database does not exist, it is created with protection specified
+by MODE (as modified by the umask).
+If your system only supports the older dbm functions, you may only have one
+dbmopen in your program.
+If your system has neither dbm nor ndbm, calling dbmopen produces a fatal
+error.
+.Sp
+Values assigned to the associative array prior to the dbmopen are lost.
+A certain number of values from the dbm file are cached in memory.
+By default this number is 64, but you can increase it by preallocating
+that number of garbage entries in the associative array before the dbmopen.
+You can flush the cache if necessary with the reset command.
+.Sp
+If you don't have write access to the dbm file, you can only read
+associative array variables, not set them.
+If you want to test whether you can write, either use file tests or
+try setting a dummy array entry inside an eval, which will trap the error.
+.Sp
+Note that functions such as keys() and values() may return huge array values
+when used on large dbm files.
+You may prefer to use the each() function to iterate over large dbm files.
+Example:
+.nf
+
+.ne 6
+ # print out history file offsets
+ dbmopen(HIST,'/usr/lib/news/history',0666);
+ while (($key,$val) = each %HIST) {
+ print $key, ' = ', unpack('L',$val), "\en";
+ }
+ dbmclose(HIST);
+
+.fi
+.Ip "defined(EXPR)" 8 6
+.Ip "defined EXPR" 8
+Returns a boolean value saying whether the lvalue EXPR has a real value
+or not.
+Many operations return the undefined value under exceptional conditions,
+such as end of file, uninitialized variable, system error and such.
+This function allows you to distinguish between an undefined null string
+and a defined null string with operations that might return a real null
+string, in particular referencing elements of an array.
+You may also check to see if arrays or subroutines exist.
+Use on predefined variables is not guaranteed to produce intuitive results.
+Examples:
+.nf
+
+.ne 7
+ print if defined $switch{'D'};
+ print "$val\en" while defined($val = pop(@ary));
+ die "Can't readlink $sym: $!"
+ unless defined($value = readlink $sym);
+ eval '@foo = ()' if defined(@foo);
+ die "No XYZ package defined" unless defined %_XYZ;
+ sub foo { defined &bar ? &bar(@_) : die "No bar"; }
+
+.fi
+See also undef.
+.Ip "delete $ASSOC{KEY}" 8 6
+Deletes the specified value from the specified associative array.
+Returns the deleted value, or the undefined value if nothing was deleted.
+Deleting from $ENV{} modifies the environment.
+Deleting from an array bound to a dbm file deletes the entry from the dbm
+file.
+.Sp
+The following deletes all the values of an associative array:
+.nf
+
+.ne 3
+ foreach $key (keys %ARRAY) {
+ delete $ARRAY{$key};
+ }
+
+.fi
+(But it would be faster to use the
+.I reset
+command.
+Saying undef %ARRAY is faster yet.)
+.Ip "die(LIST)" 8
+.Ip "die LIST" 8
+Outside of an eval, prints the value of LIST to
+.I STDERR
+and exits with the current value of $!
+(errno).
+If $! is 0, exits with the value of ($? >> 8) (\`command\` status).
+If ($? >> 8) is 0, exits with 255.
+Inside an eval, the error message is stuffed into $@ and the eval is terminated
+with the undefined value.
+.Sp
+Equivalent examples:
+.nf
+
+.ne 3
+.ie t \{\
+ die "Can't cd to spool: $!\en" unless chdir \'/usr/spool/news\';
+'br\}
+.el \{\
+ die "Can't cd to spool: $!\en"
+ unless chdir \'/usr/spool/news\';
+'br\}
+
+ chdir \'/usr/spool/news\' || die "Can't cd to spool: $!\en"
+
+.fi
+.Sp
+If the value of EXPR does not end in a newline, the current script line
+number and input line number (if any) are also printed, and a newline is
+supplied.
+Hint: sometimes appending \*(L", stopped\*(R" to your message will cause it to make
+better sense when the string \*(L"at foo line 123\*(R" is appended.
+Suppose you are running script \*(L"canasta\*(R".
+.nf
+
+.ne 7
+ die "/etc/games is no good";
+ die "/etc/games is no good, stopped";
+
+produce, respectively
+
+ /etc/games is no good at canasta line 123.
+ /etc/games is no good, stopped at canasta line 123.
+
+.fi
+See also
+.IR exit .
+.Ip "do BLOCK" 8 4
+Returns the value of the last command in the sequence of commands indicated
+by BLOCK.
+When modified by a loop modifier, executes the BLOCK once before testing the
+loop condition.
+(On other statements the loop modifiers test the conditional first.)
+.Ip "do SUBROUTINE (LIST)" 8 3
+Executes a SUBROUTINE declared by a
+.I sub
+declaration, and returns the value
+of the last expression evaluated in SUBROUTINE.
+If there is no subroutine by that name, produces a fatal error.
+(You may use the \*(L"defined\*(R" operator to determine if a subroutine
+exists.)
+If you pass arrays as part of LIST you may wish to pass the length
+of the array in front of each array.
+(See the section on subroutines later on.)
+SUBROUTINE may be a scalar variable, in which case the variable contains
+the name of the subroutine to execute.
+The parentheses are required to avoid confusion with the \*(L"do EXPR\*(R"
+form.
+.Sp
+As an alternate form, you may call a subroutine by prefixing the name with
+an ampersand: &foo(@args).
+If you aren't passing any arguments, you don't have to use parentheses.
+If you omit the parentheses, no @_ array is passed to the subroutine.
+The & form is also used to specify subroutines to the defined and undef
+operators.
+.Ip "do EXPR" 8 3
+Uses the value of EXPR as a filename and executes the contents of the file
+as a
+.I perl
+script.
+Its primary use is to include subroutines from a
+.I perl
+subroutine library.
+.nf
+
+ do \'stat.pl\';
+
+is just like
+
+ eval \`cat stat.pl\`;
+
+.fi
+except that it's more efficient, more concise, keeps track of the current
+filename for error messages, and searches all the
+.B \-I
+libraries if the file
+isn't in the current directory (see also the @INC array in Predefined Names).
+It's the same, however, in that it does reparse the file every time you
+call it, so if you are going to use the file inside a loop you might prefer
+to use \-P and #include, at the expense of a little more startup time.
+(The main problem with #include is that cpp doesn't grok # comments\*(--a
+workaround is to use \*(L";#\*(R" for standalone comments.)
+Note that the following are NOT equivalent:
+.nf
+
+.ne 2
+ do $foo; # eval a file
+ do $foo(); # call a subroutine
+
+.fi
+Note that inclusion of library routines is better done with
+the \*(L"require\*(R" operator.
+.Ip "dump LABEL" 8 6
+This causes an immediate core dump.
+Primarily this is so that you can use the undump program to turn your
+core dump into an executable binary after having initialized all your
+variables at the beginning of the program.
+When the new binary is executed it will begin by executing a "goto LABEL"
+(with all the restrictions that goto suffers).
+Think of it as a goto with an intervening core dump and reincarnation.
+If LABEL is omitted, restarts the program from the top.
+WARNING: any files opened at the time of the dump will NOT be open any more
+when the program is reincarnated, with possible resulting confusion on the part
+of perl.
+See also \-u.
+.Sp
+Example:
+.nf
+
+.ne 16
+ #!/usr/bin/perl
+ require 'getopt.pl';
+ require 'stat.pl';
+ %days = (
+ 'Sun',1,
+ 'Mon',2,
+ 'Tue',3,
+ 'Wed',4,
+ 'Thu',5,
+ 'Fri',6,
+ 'Sat',7);
+
+ dump QUICKSTART if $ARGV[0] eq '-d';
+
+ QUICKSTART:
+ do Getopt('f');
+
+.fi
+.Ip "each(ASSOC_ARRAY)" 8 6
+.Ip "each ASSOC_ARRAY" 8
+Returns a 2 element array consisting of the key and value for the next
+value of an associative array, so that you can iterate over it.
+Entries are returned in an apparently random order.
+When the array is entirely read, a null array is returned (which when
+assigned produces a FALSE (0) value).
+The next call to each() after that will start iterating again.
+The iterator can be reset only by reading all the elements from the array.
+You must not modify the array while iterating over it.
+There is a single iterator for each associative array, shared by all
+each(), keys() and values() function calls in the program.
+The following prints out your environment like the printenv program, only
+in a different order:
+.nf
+
+.ne 3
+ while (($key,$value) = each %ENV) {
+ print "$key=$value\en";
+ }
+
+.fi
+See also keys() and values().
+.Ip "eof(FILEHANDLE)" 8 8
+.Ip "eof()" 8
+.Ip "eof" 8
+Returns 1 if the next read on FILEHANDLE will return end of file, or if
+FILEHANDLE is not open.
+FILEHANDLE may be an expression whose value gives the real filehandle name.
+(Note that this function actually reads a character and then ungetc's it,
+so it is not very useful in an interactive context.)
+An eof without an argument returns the eof status for the last file read.
+Empty parentheses () may be used to indicate the pseudo file formed of the
+files listed on the command line, i.e. eof() is reasonable to use inside
+a while (<>) loop to detect the end of only the last file.
+Use eof(ARGV) or eof without the parentheses to test EACH file in a while (<>) loop.
+Examples:
+.nf
+
+.ne 7
+ # insert dashes just before last line of last file
+ while (<>) {
+ if (eof()) {
+ print "\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\en";
+ }
+ print;
+ }
+
+.ne 7
+ # reset line numbering on each input file
+ while (<>) {
+ print "$.\et$_";
+ if (eof) { # Not eof().
+ close(ARGV);
+ }
+ }
+
+.fi
+.Ip "eval(EXPR)" 8 6
+.Ip "eval EXPR" 8 6
+EXPR is parsed and executed as if it were a little
+.I perl
+program.
+It is executed in the context of the current
+.I perl
+program, so that
+any variable settings, subroutine or format definitions remain afterwards.
+The value returned is the value of the last expression evaluated, just
+as with subroutines.
+If there is a syntax error or runtime error, or a die statement is
+executed, an undefined value is returned by
+eval, and $@ is set to the error message.
+If there was no error, $@ is guaranteed to be a null string.
+If EXPR is omitted, evaluates $_.
+The final semicolon, if any, may be omitted from the expression.
+.Sp
+Note that, since eval traps otherwise-fatal errors, it is useful for
+determining whether a particular feature
+(such as dbmopen or symlink) is implemented.
+It is also Perl's exception trapping mechanism, where the die operator is
+used to raise exceptions.
+.Ip "exec(LIST)" 8 8
+.Ip "exec LIST" 8 6
+If there is more than one argument in LIST, or if LIST is an array with
+more than one value,
+calls execvp() with the arguments in LIST.
+If there is only one scalar argument, the argument is checked for shell metacharacters.
+If there are any, the entire argument is passed to \*(L"/bin/sh \-c\*(R" for parsing.
+If there are none, the argument is split into words and passed directly to
+execvp(), which is more efficient.
+Note: exec (and system) do not flush your output buffer, so you may need to
+set $| to avoid lost output.
+Examples:
+.nf
+
+ exec \'/bin/echo\', \'Your arguments are: \', @ARGV;
+ exec "sort $outfile | uniq";
+
+.fi
+.Sp
+If you don't really want to execute the first argument, but want to lie
+to the program you are executing about its own name, you can specify
+the program you actually want to run by assigning that to a variable and
+putting the name of the variable in front of the LIST without a comma.
+(This always forces interpretation of the LIST as a multi-valued list, even
+if there is only a single scalar in the list.)
+Example:
+.nf
+
+.ne 2
+ $shell = '/bin/csh';
+ exec $shell '-sh'; # pretend it's a login shell
+
+.fi
+.Ip "exit(EXPR)" 8 6
+.Ip "exit EXPR" 8
+Evaluates EXPR and exits immediately with that value.
+Example:
+.nf
+
+.ne 2
+ $ans = <STDIN>;
+ exit 0 \|if \|$ans \|=~ \|/\|^[Xx]\|/\|;
+
+.fi
+See also
+.IR die .
+If EXPR is omitted, exits with 0 status.
+.Ip "exp(EXPR)" 8 3
+.Ip "exp EXPR" 8
+Returns
+.I e
+to the power of EXPR.
+If EXPR is omitted, gives exp($_).
+.Ip "fcntl(FILEHANDLE,FUNCTION,SCALAR)" 8 4
+Implements the fcntl(2) function.
+You'll probably have to say
+.nf
+
+ require "fcntl.ph"; # probably /usr/local/lib/perl/fcntl.ph
+
+.fi
+first to get the correct function definitions.
+If fcntl.ph doesn't exist or doesn't have the correct definitions
+you'll have to roll
+your own, based on your C header files such as <sys/fcntl.h>.
+(There is a perl script called h2ph that comes with the perl kit
+which may help you in this.)
+Argument processing and value return works just like ioctl below.
+Note that fcntl will produce a fatal error if used on a machine that doesn't implement
+fcntl(2).
+.Ip "fileno(FILEHANDLE)" 8 4
+.Ip "fileno FILEHANDLE" 8 4
+Returns the file descriptor for a filehandle.
+Useful for constructing bitmaps for select().
+If FILEHANDLE is an expression, the value is taken as the name of
+the filehandle.
+.Ip "flock(FILEHANDLE,OPERATION)" 8 4
+Calls flock(2) on FILEHANDLE.
+See manual page for flock(2) for definition of OPERATION.
+Returns true for success, false on failure.
+Will produce a fatal error if used on a machine that doesn't implement
+flock(2).
+Here's a mailbox appender for BSD systems.
+.nf
+
+.ne 20
+ $LOCK_SH = 1;
+ $LOCK_EX = 2;
+ $LOCK_NB = 4;
+ $LOCK_UN = 8;
+
+ sub lock {
+ flock(MBOX,$LOCK_EX);
+ # and, in case someone appended
+ # while we were waiting...
+ seek(MBOX, 0, 2);
+ }
+
+ sub unlock {
+ flock(MBOX,$LOCK_UN);
+ }
+
+ open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}")
+ || die "Can't open mailbox: $!";
+
+ do lock();
+ print MBOX $msg,"\en\en";
+ do unlock();
+
+.fi
+.Ip "fork" 8 4
+Does a fork() call.
+Returns the child pid to the parent process and 0 to the child process.
+Note: unflushed buffers remain unflushed in both processes, which means
+you may need to set $| to avoid duplicate output.
+.Ip "getc(FILEHANDLE)" 8 4
+.Ip "getc FILEHANDLE" 8
+.Ip "getc" 8
+Returns the next character from the input file attached to FILEHANDLE, or
+a null string at EOF.
+If FILEHANDLE is omitted, reads from STDIN.
+.Ip "getlogin" 8 3
+Returns the current login from /etc/utmp, if any.
+If null, use getpwuid.
+
+ $login = getlogin || (getpwuid($<))[0] || "Somebody";
+
+.Ip "getpeername(SOCKET)" 8 3
+Returns the packed sockaddr address of other end of the SOCKET connection.
+.nf
+
+.ne 4
+ # An internet sockaddr
+ $sockaddr = 'S n a4 x8';
+ $hersockaddr = getpeername(S);
+.ie t \{\
+ ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr);
+'br\}
+.el \{\
+ ($family, $port, $heraddr) =
+ unpack($sockaddr,$hersockaddr);
+'br\}
+
+.fi
+.Ip "getpgrp(PID)" 8 4
+.Ip "getpgrp PID" 8
+Returns the current process group for the specified PID, 0 for the current
+process.
+Will produce a fatal error if used on a machine that doesn't implement
+getpgrp(2).
+If EXPR is omitted, returns process group of current process.
+.Ip "getppid" 8 4
+Returns the process id of the parent process.
+.Ip "getpriority(WHICH,WHO)" 8 4
+Returns the current priority for a process, a process group, or a user.
+(See getpriority(2).)
+Will produce a fatal error if used on a machine that doesn't implement
+getpriority(2).
+.Ip "getpwnam(NAME)" 8
+.Ip "getgrnam(NAME)" 8
+.Ip "gethostbyname(NAME)" 8
+.Ip "getnetbyname(NAME)" 8
+.Ip "getprotobyname(NAME)" 8
+.Ip "getpwuid(UID)" 8
+.Ip "getgrgid(GID)" 8
+.Ip "getservbyname(NAME,PROTO)" 8
+.Ip "gethostbyaddr(ADDR,ADDRTYPE)" 8
+.Ip "getnetbyaddr(ADDR,ADDRTYPE)" 8
+.Ip "getprotobynumber(NUMBER)" 8
+.Ip "getservbyport(PORT,PROTO)" 8
+.Ip "getpwent" 8
+.Ip "getgrent" 8
+.Ip "gethostent" 8
+.Ip "getnetent" 8
+.Ip "getprotoent" 8
+.Ip "getservent" 8
+.Ip "setpwent" 8
+.Ip "setgrent" 8
+.Ip "sethostent(STAYOPEN)" 8
+.Ip "setnetent(STAYOPEN)" 8
+.Ip "setprotoent(STAYOPEN)" 8
+.Ip "setservent(STAYOPEN)" 8
+.Ip "endpwent" 8
+.Ip "endgrent" 8
+.Ip "endhostent" 8
+.Ip "endnetent" 8
+.Ip "endprotoent" 8
+.Ip "endservent" 8
+These routines perform the same functions as their counterparts in the
+system library.
+The return values from the various get routines are as follows:
+.nf
+
+ ($name,$passwd,$uid,$gid,
+ $quota,$comment,$gcos,$dir,$shell) = getpw.\|.\|.
+ ($name,$passwd,$gid,$members) = getgr.\|.\|.
+ ($name,$aliases,$addrtype,$length,@addrs) = gethost.\|.\|.
+ ($name,$aliases,$addrtype,$net) = getnet.\|.\|.
+ ($name,$aliases,$proto) = getproto.\|.\|.
+ ($name,$aliases,$port,$proto) = getserv.\|.\|.
+
+.fi
+The $members value returned by getgr.\|.\|. is a space separated list
+of the login names of the members of the group.
+.Sp
+The @addrs value returned by the gethost.\|.\|. functions is a list of the
+raw addresses returned by the corresponding system library call.
+In the Internet domain, each address is four bytes long and you can unpack
+it by saying something like:
+.nf
+
+ ($a,$b,$c,$d) = unpack('C4',$addr[0]);
+
+.fi
+.Ip "getsockname(SOCKET)" 8 3
+Returns the packed sockaddr address of this end of the SOCKET connection.
+.nf
+
+.ne 4
+ # An internet sockaddr
+ $sockaddr = 'S n a4 x8';
+ $mysockaddr = getsockname(S);
+.ie t \{\
+ ($family, $port, $myaddr) = unpack($sockaddr,$mysockaddr);
+'br\}
+.el \{\
+ ($family, $port, $myaddr) =
+ unpack($sockaddr,$mysockaddr);
+'br\}
+
+.fi
+.Ip "getsockopt(SOCKET,LEVEL,OPTNAME)" 8 3
+Returns the socket option requested, or undefined if there is an error.
+.Ip "gmtime(EXPR)" 8 4
+.Ip "gmtime EXPR" 8
+Converts a time as returned by the time function to a 9-element array with
+the time analyzed for the Greenwich timezone.
+Typically used as follows:
+.nf
+
+.ne 3
+.ie t \{\
+ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
+'br\}
+.el \{\
+ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
+ gmtime(time);
+'br\}
+
+.fi
+All array elements are numeric, and come straight out of a struct tm.
+In particular this means that $mon has the range 0.\|.11 and $wday has the
+range 0.\|.6.
+If EXPR is omitted, does gmtime(time).
+.Ip "goto LABEL" 8 6
+Finds the statement labeled with LABEL and resumes execution there.
+Currently you may only go to statements in the main body of the program
+that are not nested inside a do {} construct.
+This statement is not implemented very efficiently, and is here only to make
+the
+.IR sed -to- perl
+translator easier.
+I may change its semantics at any time, consistent with support for translated
+.I sed
+scripts.
+Use it at your own risk.
+Better yet, don't use it at all.
+.Ip "grep(EXPR,LIST)" 8 4
+Evaluates EXPR for each element of LIST (locally setting $_ to each element)
+and returns the array value consisting of those elements for which the
+expression evaluated to true.
+In a scalar context, returns the number of times the expression was true.
+.nf
+
+ @foo = grep(!/^#/, @bar); # weed out comments
+
+.fi
+Note that, since $_ is a reference into the array value, it can be
+used to modify the elements of the array.
+While this is useful and supported, it can cause bizarre results if
+the LIST is not a named array.
+.Ip "hex(EXPR)" 8 4
+.Ip "hex EXPR" 8
+Returns the decimal value of EXPR interpreted as an hex string.
+(To interpret strings that might start with 0 or 0x see oct().)
+If EXPR is omitted, uses $_.
+.Ip "index(STR,SUBSTR,POSITION)" 8 4
+.Ip "index(STR,SUBSTR)" 8 4
+Returns the position of the first occurrence of SUBSTR in STR at or after
+POSITION.
+If POSITION is omitted, starts searching from the beginning of the string.
+The return value is based at 0, or whatever you've
+set the $[ variable to.
+If the substring is not found, returns one less than the base, ordinarily \-1.
+.Ip "int(EXPR)" 8 4
+.Ip "int EXPR" 8
+Returns the integer portion of EXPR.
+If EXPR is omitted, uses $_.
+.Ip "ioctl(FILEHANDLE,FUNCTION,SCALAR)" 8 4
+Implements the ioctl(2) function.
+You'll probably have to say
+.nf
+
+ require "ioctl.ph"; # probably /usr/local/lib/perl/ioctl.ph
+
+.fi
+first to get the correct function definitions.
+If ioctl.ph doesn't exist or doesn't have the correct definitions
+you'll have to roll
+your own, based on your C header files such as <sys/ioctl.h>.
+(There is a perl script called h2ph that comes with the perl kit
+which may help you in this.)
+SCALAR will be read and/or written depending on the FUNCTION\*(--a pointer
+to the string value of SCALAR will be passed as the third argument of
+the actual ioctl call.
+(If SCALAR has no string value but does have a numeric value, that value
+will be passed rather than a pointer to the string value.
+To guarantee this to be true, add a 0 to the scalar before using it.)
+The pack() and unpack() functions are useful for manipulating the values
+of structures used by ioctl().
+The following example sets the erase character to DEL.
+.nf
+
+.ne 9
+ require 'ioctl.ph';
+ $sgttyb_t = "ccccs"; # 4 chars and a short
+ if (ioctl(STDIN,$TIOCGETP,$sgttyb)) {
+ @ary = unpack($sgttyb_t,$sgttyb);
+ $ary[2] = 127;
+ $sgttyb = pack($sgttyb_t,@ary);
+ ioctl(STDIN,$TIOCSETP,$sgttyb)
+ || die "Can't ioctl: $!";
+ }
+
+.fi
+The return value of ioctl (and fcntl) is as follows:
+.nf
+
+.ne 4
+ if OS returns:\h'|3i'perl returns:
+ -1\h'|3i' undefined value
+ 0\h'|3i' string "0 but true"
+ anything else\h'|3i' that number
+
+.fi
+Thus perl returns true on success and false on failure, yet you can still
+easily determine the actual value returned by the operating system:
+.nf
+
+ ($retval = ioctl(...)) || ($retval = -1);
+ printf "System returned %d\en", $retval;
+.fi
+.Ip "join(EXPR,LIST)" 8 8
+.Ip "join(EXPR,ARRAY)" 8
+Joins the separate strings of LIST or ARRAY into a single string with fields
+separated by the value of EXPR, and returns the string.
+Example:
+.nf
+
+.ie t \{\
+ $_ = join(\|\':\', $login,$passwd,$uid,$gid,$gcos,$home,$shell);
+'br\}
+.el \{\
+ $_ = join(\|\':\',
+ $login,$passwd,$uid,$gid,$gcos,$home,$shell);
+'br\}
+
+.fi
+See
+.IR split .
+.Ip "keys(ASSOC_ARRAY)" 8 6
+.Ip "keys ASSOC_ARRAY" 8
+Returns a normal array consisting of all the keys of the named associative
+array.
+The keys are returned in an apparently random order, but it is the same order
+as either the values() or each() function produces (given that the associative array
+has not been modified).
+Here is yet another way to print your environment:
+.nf
+
+.ne 5
+ @keys = keys %ENV;
+ @values = values %ENV;
+ while ($#keys >= 0) {
+ print pop(@keys), \'=\', pop(@values), "\en";
+ }
+
+or how about sorted by key:
+
+.ne 3
+ foreach $key (sort(keys %ENV)) {
+ print $key, \'=\', $ENV{$key}, "\en";
+ }
+
+.fi
+.Ip "kill(LIST)" 8 8
+.Ip "kill LIST" 8 2
+Sends a signal to a list of processes.
+The first element of the list must be the signal to send.
+Returns the number of processes successfully signaled.
+.nf
+
+ $cnt = kill 1, $child1, $child2;
+ kill 9, @goners;
+
+.fi
+If the signal is negative, kills process groups instead of processes.
+(On System V, a negative \fIprocess\fR number will also kill process groups,
+but that's not portable.)
+You may use a signal name in quotes.
+.Ip "last LABEL" 8 8
+.Ip "last" 8
+The
+.I last
+command is like the
+.I break
+statement in C (as used in loops); it immediately exits the loop in question.
+If the LABEL is omitted, the command refers to the innermost enclosing loop.
+The
+.I continue
+block, if any, is not executed:
+.nf
+
+.ne 4
+ line: while (<STDIN>) {
+ last line if /\|^$/; # exit when done with header
+ .\|.\|.
+ }
+
+.fi
+.Ip "length(EXPR)" 8 4
+.Ip "length EXPR" 8
+Returns the length in characters of the value of EXPR.
+If EXPR is omitted, returns length of $_.
+.Ip "link(OLDFILE,NEWFILE)" 8 2
+Creates a new filename linked to the old filename.
+Returns 1 for success, 0 otherwise.
+.Ip "listen(SOCKET,QUEUESIZE)" 8 2
+Does the same thing that the listen system call does.
+Returns true if it succeeded, false otherwise.
+See example in section on Interprocess Communication.
+.Ip "local(LIST)" 8 4
+Declares the listed variables to be local to the enclosing block,
+subroutine, eval or \*(L"do\*(R".
+All the listed elements must be legal lvalues.
+This operator works by saving the current values of those variables in LIST
+on a hidden stack and restoring them upon exiting the block, subroutine or eval.
+This means that called subroutines can also reference the local variable,
+but not the global one.
+The LIST may be assigned to if desired, which allows you to initialize
+your local variables.
+(If no initializer is given for a particular variable, it is created with
+an undefined value.)
+Commonly this is used to name the parameters to a subroutine.
+Examples:
+.nf
+
+.ne 13
+ sub RANGEVAL {
+ local($min, $max, $thunk) = @_;
+ local($result) = \'\';
+ local($i);
+
+ # Presumably $thunk makes reference to $i
+
+ for ($i = $min; $i < $max; $i++) {
+ $result .= eval $thunk;
+ }
+
+ $result;
+ }
+
+.ne 6
+ if ($sw eq \'-v\') {
+ # init local array with global array
+ local(@ARGV) = @ARGV;
+ unshift(@ARGV,\'echo\');
+ system @ARGV;
+ }
+ # @ARGV restored
+
+.ne 6
+ # temporarily add to digits associative array
+ if ($base12) {
+ # (NOTE: not claiming this is efficient!)
+ local(%digits) = (%digits,'t',10,'e',11);
+ do parse_num();
+ }
+
+.fi
+Note that local() is a run-time command, and so gets executed every time
+through a loop, using up more stack storage each time until it's all
+released at once when the loop is exited.
+.Ip "localtime(EXPR)" 8 4
+.Ip "localtime EXPR" 8
+Converts a time as returned by the time function to a 9-element array with
+the time analyzed for the local timezone.
+Typically used as follows:
+.nf
+
+.ne 3
+.ie t \{\
+ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
+'br\}
+.el \{\
+ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
+ localtime(time);
+'br\}
+
+.fi
+All array elements are numeric, and come straight out of a struct tm.
+In particular this means that $mon has the range 0.\|.11 and $wday has the
+range 0.\|.6.
+If EXPR is omitted, does localtime(time).
+.Ip "log(EXPR)" 8 4
+.Ip "log EXPR" 8
+Returns logarithm (base
+.IR e )
+of EXPR.
+If EXPR is omitted, returns log of $_.
+.Ip "lstat(FILEHANDLE)" 8 6
+.Ip "lstat FILEHANDLE" 8
+.Ip "lstat(EXPR)" 8
+.Ip "lstat SCALARVARIABLE" 8
+Does the same thing as the stat() function, but stats a symbolic link
+instead of the file the symbolic link points to.
+If symbolic links are unimplemented on your system, a normal stat is done.
+.Ip "m/PATTERN/io" 8 4
+.Ip "/PATTERN/io" 8
+Searches a string for a pattern match, and returns true (1) or false (\'\').
+If no string is specified via the =~ or !~ operator,
+the $_ string is searched.
+(The string specified with =~ need not be an lvalue\*(--it may be the result of an expression evaluation, but remember the =~ binds rather tightly.)
+See also the section on regular expressions.
+.Sp
+If / is the delimiter then the initial \*(L'm\*(R' is optional.
+With the \*(L'm\*(R' you can use any pair of non-alphanumeric characters
+as delimiters.
+This is particularly useful for matching Unix path names that contain \*(L'/\*(R'.
+If the final delimiter is followed by the optional letter \*(L'i\*(R', the matching is
+done in a case-insensitive manner.
+PATTERN may contain references to scalar variables, which will be interpolated
+(and the pattern recompiled) every time the pattern search is evaluated.
+(Note that $) and $| may not be interpolated because they look like end-of-string tests.)
+If you want such a pattern to be compiled only once, add an \*(L"o\*(R" after
+the trailing delimiter.
+This avoids expensive run-time recompilations, and
+is useful when the value you are interpolating won't change over the
+life of the script.
+If the PATTERN evaluates to a null string, the most recent successful
+regular expression is used instead.
+.Sp
+If used in a context that requires an array value, a pattern match returns an
+array consisting of the subexpressions matched by the parentheses in the
+pattern,
+i.e. ($1, $2, $3.\|.\|.).
+It does NOT actually set $1, $2, etc. in this case, nor does it set $+, $`, $&
+or $'.
+If the match fails, a null array is returned.
+If the match succeeds, but there were no parentheses, an array value of (1)
+is returned.
+.Sp
+Examples:
+.nf
+
+.ne 4
+ open(tty, \'/dev/tty\');
+ <tty> \|=~ \|/\|^y\|/i \|&& \|do foo(\|); # do foo if desired
+
+ if (/Version: \|*\|([0\-9.]*\|)\|/\|) { $version = $1; }
+
+ next if m#^/usr/spool/uucp#;
+
+.ne 5
+ # poor man's grep
+ $arg = shift;
+ while (<>) {
+ print if /$arg/o; # compile only once
+ }
+
+ if (($F1, $F2, $Etc) = ($foo =~ /^(\eS+)\es+(\eS+)\es*(.*)/))
+
+.fi
+This last example splits $foo into the first two words and the remainder
+of the line, and assigns those three fields to $F1, $F2 and $Etc.
+The conditional is true if any variables were assigned, i.e. if the pattern
+matched.
+.Ip "mkdir(FILENAME,MODE)" 8 3
+Creates the directory specified by FILENAME, with permissions specified by
+MODE (as modified by umask).
+If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno).
+.Ip "msgctl(ID,CMD,ARG)" 8 4
+Calls the System V IPC function msgctl. If CMD is &IPC_STAT, then ARG
+must be a variable which will hold the returned msqid_ds structure.
+Returns like ioctl: the undefined value for error, "0 but true" for
+zero, or the actual return value otherwise.
+.Ip "msgget(KEY,FLAGS)" 8 4
+Calls the System V IPC function msgget. Returns the message queue id,
+or the undefined value if there is an error.
+.Ip "msgsnd(ID,MSG,FLAGS)" 8 4
+Calls the System V IPC function msgsnd to send the message MSG to the
+message queue ID. MSG must begin with the long integer message type,
+which may be created with pack("L", $type). Returns true if
+successful, or false if there is an error.
+.Ip "msgrcv(ID,VAR,SIZE,TYPE,FLAGS)" 8 4
+Calls the System V IPC function msgrcv to receive a message from
+message queue ID into variable VAR with a maximum message size of
+SIZE. Note that if a message is received, the message type will be
+the first thing in VAR, and the maximum length of VAR is SIZE plus the
+size of the message type. Returns true if successful, or false if
+there is an error.
+''' Beginning of part 3
+''' $Header: perl.man,v 4.0 91/03/20 01:38:08 lwall Locked $
+'''
+''' $Log: perl.man,v $
+''' Revision 4.0 91/03/20 01:38:08 lwall
+''' 4.0 baseline.
+'''
+''' Revision 3.0.1.12 91/01/11 18:18:15 lwall
+''' patch42: added binary and hex pack/unpack options
+'''
+''' Revision 3.0.1.11 90/11/10 01:48:21 lwall
+''' patch38: random cleanup
+''' patch38: documented tr///cds
+'''
+''' Revision 3.0.1.10 90/10/20 02:15:17 lwall
+''' patch37: patch37: fixed various typos in man page
+'''
+''' Revision 3.0.1.9 90/10/16 10:02:43 lwall
+''' patch29: you can now read into the middle string
+''' patch29: index and substr now have optional 3rd args
+''' patch29: added scalar reverse
+''' patch29: added scalar
+''' patch29: added SysV IPC
+''' patch29: added waitpid
+''' patch29: added sysread and syswrite
+'''
+''' Revision 3.0.1.8 90/08/09 04:39:04 lwall
+''' patch19: added require operator
+''' patch19: added truncate operator
+''' patch19: unpack can do checksumming
+'''
+''' Revision 3.0.1.7 90/08/03 11:15:42 lwall
+''' patch19: Intermediate diffs for Randal
+'''
+''' Revision 3.0.1.6 90/03/27 16:17:56 lwall
+''' patch16: MSDOS support
+'''
+''' Revision 3.0.1.5 90/03/12 16:52:21 lwall
+''' patch13: documented that print $filehandle &foo is ambiguous
+''' patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST)
+'''
+''' Revision 3.0.1.4 90/02/28 18:00:09 lwall
+''' patch9: added pipe function
+''' patch9: documented how to handle arbitrary weird characters in filenames
+''' patch9: documented the unflushed buffers problem on piped opens
+''' patch9: documented how to force top of page
+'''
+''' Revision 3.0.1.3 89/12/21 20:10:12 lwall
+''' patch7: documented that s`pat`repl` does command substitution on replacement
+''' patch7: documented that $timeleft from select() is likely not implemented
+'''
+''' Revision 3.0.1.2 89/11/17 15:31:05 lwall
+''' patch5: fixed some manual typos and indent problems
+''' patch5: added warning about print making an array context
+'''
+''' Revision 3.0.1.1 89/11/11 04:45:06 lwall
+''' patch2: made some line breaks depend on troff vs. nroff
+'''
+''' Revision 3.0 89/10/18 15:21:46 lwall
+''' 3.0 baseline
+'''
+.Ip "next LABEL" 8 8
+.Ip "next" 8
+The
+.I next
+command is like the
+.I continue
+statement in C; it starts the next iteration of the loop:
+.nf
+
+.ne 4
+ line: while (<STDIN>) {
+ next line if /\|^#/; # discard comments
+ .\|.\|.
+ }
+
+.fi
+Note that if there were a
+.I continue
+block on the above, it would get executed even on discarded lines.
+If the LABEL is omitted, the command refers to the innermost enclosing loop.
+.Ip "oct(EXPR)" 8 4
+.Ip "oct EXPR" 8
+Returns the decimal value of EXPR interpreted as an octal string.
+(If EXPR happens to start off with 0x, interprets it as a hex string instead.)
+The following will handle decimal, octal and hex in the standard notation:
+.nf
+
+ $val = oct($val) if $val =~ /^0/;
+
+.fi
+If EXPR is omitted, uses $_.
+.Ip "open(FILEHANDLE,EXPR)" 8 8
+.Ip "open(FILEHANDLE)" 8
+.Ip "open FILEHANDLE" 8
+Opens the file whose filename is given by EXPR, and associates it with
+FILEHANDLE.
+If FILEHANDLE is an expression, its value is used as the name of the
+real filehandle wanted.
+If EXPR is omitted, the scalar variable of the same name as the FILEHANDLE
+contains the filename.
+If the filename begins with \*(L"<\*(R" or nothing, the file is opened for
+input.
+If the filename begins with \*(L">\*(R", the file is opened for output.
+If the filename begins with \*(L">>\*(R", the file is opened for appending.
+(You can put a \'+\' in front of the \'>\' or \'<\' to indicate that you
+want both read and write access to the file.)
+If the filename begins with \*(L"|\*(R", the filename is interpreted
+as a command to which output is to be piped, and if the filename ends
+with a \*(L"|\*(R", the filename is interpreted as command which pipes
+input to us.
+(You may not have a command that pipes both in and out.)
+Opening \'\-\' opens
+.I STDIN
+and opening \'>\-\' opens
+.IR STDOUT .
+Open returns non-zero upon success, the undefined value otherwise.
+If the open involved a pipe, the return value happens to be the pid
+of the subprocess.
+Examples:
+.nf
+
+.ne 3
+ $article = 100;
+ open article || die "Can't find article $article: $!\en";
+ while (<article>) {\|.\|.\|.
+
+.ie t \{\
+ open(LOG, \'>>/usr/spool/news/twitlog\'\|); # (log is reserved)
+'br\}
+.el \{\
+ open(LOG, \'>>/usr/spool/news/twitlog\'\|);
+ # (log is reserved)
+'br\}
+
+.ie t \{\
+ open(article, "caesar <$article |"\|); # decrypt article
+'br\}
+.el \{\
+ open(article, "caesar <$article |"\|);
+ # decrypt article
+'br\}
+
+.ie t \{\
+ open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process#
+'br\}
+.el \{\
+ open(extract, "|sort >/tmp/Tmp$$"\|);
+ # $$ is our process#
+'br\}
+
+.ne 7
+ # process argument list of files along with any includes
+
+ foreach $file (@ARGV) {
+ do process($file, \'fh00\'); # no pun intended
+ }
+
+ sub process {
+ local($filename, $input) = @_;
+ $input++; # this is a string increment
+ unless (open($input, $filename)) {
+ print STDERR "Can't open $filename: $!\en";
+ return;
+ }
+.ie t \{\
+ while (<$input>) { # note the use of indirection
+'br\}
+.el \{\
+ while (<$input>) { # note use of indirection
+'br\}
+ if (/^#include "(.*)"/) {
+ do process($1, $input);
+ next;
+ }
+ .\|.\|. # whatever
+ }
+ }
+
+.fi
+You may also, in the Bourne shell tradition, specify an EXPR beginning
+with \*(L">&\*(R", in which case the rest of the string
+is interpreted as the name of a filehandle
+(or file descriptor, if numeric) which is to be duped and opened.
+You may use & after >, >>, <, +>, +>> and +<.
+The mode you specify should match the mode of the original filehandle.
+Here is a script that saves, redirects, and restores
+.I STDOUT
+and
+.IR STDERR :
+.nf
+
+.ne 21
+ #!/usr/bin/perl
+ open(SAVEOUT, ">&STDOUT");
+ open(SAVEERR, ">&STDERR");
+
+ open(STDOUT, ">foo.out") || die "Can't redirect stdout";
+ open(STDERR, ">&STDOUT") || die "Can't dup stdout";
+
+ select(STDERR); $| = 1; # make unbuffered
+ select(STDOUT); $| = 1; # make unbuffered
+
+ print STDOUT "stdout 1\en"; # this works for
+ print STDERR "stderr 1\en"; # subprocesses too
+
+ close(STDOUT);
+ close(STDERR);
+
+ open(STDOUT, ">&SAVEOUT");
+ open(STDERR, ">&SAVEERR");
+
+ print STDOUT "stdout 2\en";
+ print STDERR "stderr 2\en";
+
+.fi
+If you open a pipe on the command \*(L"\-\*(R", i.e. either \*(L"|\-\*(R" or \*(L"\-|\*(R",
+then there is an implicit fork done, and the return value of open
+is the pid of the child within the parent process, and 0 within the child
+process.
+(Use defined($pid) to determine if the open was successful.)
+The filehandle behaves normally for the parent, but i/o to that
+filehandle is piped from/to the
+.IR STDOUT / STDIN
+of the child process.
+In the child process the filehandle isn't opened\*(--i/o happens from/to
+the new
+.I STDOUT
+or
+.IR STDIN .
+Typically this is used like the normal piped open when you want to exercise
+more control over just how the pipe command gets executed, such as when
+you are running setuid, and don't want to have to scan shell commands
+for metacharacters.
+The following pairs are more or less equivalent:
+.nf
+
+.ne 5
+ open(FOO, "|tr \'[a\-z]\' \'[A\-Z]\'");
+ open(FOO, "|\-") || exec \'tr\', \'[a\-z]\', \'[A\-Z]\';
+
+ open(FOO, "cat \-n '$file'|");
+ open(FOO, "\-|") || exec \'cat\', \'\-n\', $file;
+
+.fi
+Explicitly closing any piped filehandle causes the parent process to wait for the
+child to finish, and returns the status value in $?.
+Note: on any operation which may do a fork,
+unflushed buffers remain unflushed in both
+processes, which means you may need to set $| to
+avoid duplicate output.
+.Sp
+The filename that is passed to open will have leading and trailing
+whitespace deleted.
+In order to open a file with arbitrary weird characters in it, it's necessary
+to protect any leading and trailing whitespace thusly:
+.nf
+
+.ne 2
+ $file =~ s#^(\es)#./$1#;
+ open(FOO, "< $file\e0");
+
+.fi
+.Ip "opendir(DIRHANDLE,EXPR)" 8 3
+Opens a directory named EXPR for processing by readdir(), telldir(), seekdir(),
+rewinddir() and closedir().
+Returns true if successful.
+DIRHANDLEs have their own namespace separate from FILEHANDLEs.
+.Ip "ord(EXPR)" 8 4
+.Ip "ord EXPR" 8
+Returns the numeric ascii value of the first character of EXPR.
+If EXPR is omitted, uses $_.
+''' Comments on f & d by gnb@melba.bby.oz.au 22/11/89
+.Ip "pack(TEMPLATE,LIST)" 8 4
+Takes an array or list of values and packs it into a binary structure,
+returning the string containing the structure.
+The TEMPLATE is a sequence of characters that give the order and type
+of values, as follows:
+.nf
+
+ A An ascii string, will be space padded.
+ a An ascii string, will be null padded.
+ c A 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.
+ n A short in \*(L"network\*(R" order.
+ N A long in \*(L"network\*(R" order.
+ f A single-precision float in the native format.
+ d A double-precision float in the native format.
+ p A pointer to a string.
+ x A null byte.
+ X Back up a byte.
+ @ Null fill to absolute position.
+ u A uuencoded string.
+ b A bit string (ascending bit order, like vec()).
+ B A bit string (descending bit order).
+ h A hex string (low nybble first).
+ H A hex string (high nybble first).
+
+.fi
+Each letter may optionally be followed by a number which gives a repeat
+count.
+With all types except "a", "A", "b", "B", "h" and "H",
+the pack function will gobble up that many values
+from the LIST.
+A * for the repeat count means to use however many items are left.
+The "a" and "A" types gobble just one value, but pack it as a string of length
+count,
+padding with nulls or spaces as necessary.
+(When unpacking, "A" strips trailing spaces and nulls, but "a" does not.)
+Likewise, the "b" and "B" fields pack a string that many bits long.
+The "h" and "H" fields pack a string that many nybbles long.
+Real numbers (floats and doubles) are in the native machine format
+only; due to the multiplicity of floating formats around, and the lack
+of a standard \*(L"network\*(R" representation, no facility for
+interchange has been made.
+This means that packed floating point data
+written on one machine may not be readable on another - even if both
+use IEEE floating point arithmetic (as the endian-ness of the memory
+representation is not part of the IEEE spec).
+Note that perl uses
+doubles internally for all numeric calculation, and converting from
+double -> float -> double will lose precision (i.e. unpack("f",
+pack("f", $foo)) will not in general equal $foo).
+.br
+Examples:
+.nf
+
+ $foo = pack("cccc",65,66,67,68);
+ # foo eq "ABCD"
+ $foo = pack("c4",65,66,67,68);
+ # same thing
+
+ $foo = pack("ccxxcc",65,66,67,68);
+ # foo eq "AB\e0\e0CD"
+
+ $foo = pack("s2",1,2);
+ # "\e1\e0\e2\e0" on little-endian
+ # "\e0\e1\e0\e2" on big-endian
+
+ $foo = pack("a4","abcd","x","y","z");
+ # "abcd"
+
+ $foo = pack("aaaa","abcd","x","y","z");
+ # "axyz"
+
+ $foo = pack("a14","abcdefg");
+ # "abcdefg\e0\e0\e0\e0\e0\e0\e0"
+
+ $foo = pack("i9pl", gmtime);
+ # a real struct tm (on my system anyway)
+
+ sub bintodec {
+ unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
+ }
+.fi
+The same template may generally also be used in the unpack function.
+.Ip "pipe(READHANDLE,WRITEHANDLE)" 8 3
+Opens a pair of connected pipes like the corresponding system call.
+Note that if you set up a loop of piped processes, deadlock can occur
+unless you are very careful.
+In addition, note that perl's pipes use stdio buffering, so you may need
+to set $| to flush your WRITEHANDLE after each command, depending on
+the application.
+[Requires version 3.0 patchlevel 9.]
+.Ip "pop(ARRAY)" 8
+.Ip "pop ARRAY" 8 6
+Pops and returns the last value of the array, shortening the array by 1.
+Has the same effect as
+.nf
+
+ $tmp = $ARRAY[$#ARRAY\-\|\-];
+
+.fi
+If there are no elements in the array, returns the undefined value.
+.Ip "print(FILEHANDLE LIST)" 8 10
+.Ip "print(LIST)" 8
+.Ip "print FILEHANDLE LIST" 8
+.Ip "print LIST" 8
+.Ip "print" 8
+Prints a string or a comma-separated list of strings.
+Returns non-zero if successful.
+FILEHANDLE may be a scalar variable name, in which case the variable contains
+the name of the filehandle, thus introducing one level of indirection.
+(NOTE: If FILEHANDLE is a variable and the next token is a term, it may be
+misinterpreted as an operator unless you interpose a + or put parens around
+the arguments.)
+If FILEHANDLE is omitted, prints by default to standard output (or to the
+last selected output channel\*(--see select()).
+If LIST is also omitted, prints $_ to
+.IR STDOUT .
+To set the default output channel to something other than
+.I STDOUT
+use the select operation.
+Note that, because print takes a LIST, anything in the LIST is evaluated
+in an array context, and any subroutine that you call will have one or more
+of its expressions evaluated in an array context.
+Also be careful not to follow the print keyword with a left parenthesis
+unless you want the corresponding right parenthesis to terminate the
+arguments to the print\*(--interpose a + or put parens around all the arguments.
+.Ip "printf(FILEHANDLE LIST)" 8 10
+.Ip "printf(LIST)" 8
+.Ip "printf FILEHANDLE LIST" 8
+.Ip "printf LIST" 8
+Equivalent to a \*(L"print FILEHANDLE sprintf(LIST)\*(R".
+.Ip "push(ARRAY,LIST)" 8 7
+Treats ARRAY (@ is optional) as a stack, and pushes the values of LIST
+onto the end of ARRAY.
+The length of ARRAY increases by the length of LIST.
+Has the same effect as
+.nf
+
+ for $value (LIST) {
+ $ARRAY[++$#ARRAY] = $value;
+ }
+
+.fi
+but is more efficient.
+.Ip "q/STRING/" 8 5
+.Ip "qq/STRING/" 8
+.Ip "qx/STRING/" 8
+These are not really functions, but simply syntactic sugar to let you
+avoid putting too many backslashes into quoted strings.
+The q operator is a generalized single quote, and the qq operator a
+generalized double quote.
+The qx operator is a generalized backquote.
+Any non-alphanumeric delimiter can be used in place of /, including newline.
+If the delimiter is an opening bracket or parenthesis, the final delimiter
+will be the corresponding closing bracket or parenthesis.
+(Embedded occurrences of the closing bracket need to be backslashed as usual.)
+Examples:
+.nf
+
+.ne 5
+ $foo = q!I said, "You said, \'She said it.\'"!;
+ $bar = q(\'This is it.\');
+ $today = qx{ date };
+ $_ .= qq
+*** The previous line contains the naughty word "$&".\en
+ if /(ibm|apple|awk)/; # :-)
+
+.fi
+.Ip "rand(EXPR)" 8 8
+.Ip "rand EXPR" 8
+.Ip "rand" 8
+Returns a random fractional number between 0 and the value of EXPR.
+(EXPR should be positive.)
+If EXPR is omitted, returns a value between 0 and 1.
+See also srand().
+.Ip "read(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5
+.Ip "read(FILEHANDLE,SCALAR,LENGTH)" 8 5
+Attempts to read LENGTH bytes of data into variable SCALAR from the specified
+FILEHANDLE.
+Returns the number of bytes actually read, or undef if there was an error.
+SCALAR will be grown or shrunk to the length actually read.
+An OFFSET may be specified to place the read data at some other place
+than the beginning of the string.
+This call is actually implemented in terms of stdio's fread call. To get
+a true read system call, see sysread.
+.Ip "readdir(DIRHANDLE)" 8 3
+.Ip "readdir DIRHANDLE" 8
+Returns the next directory entry for a directory opened by opendir().
+If used in an array context, returns all the rest of the entries in the
+directory.
+If there are no more entries, returns an undefined value in a scalar context
+or a null list in an array context.
+.Ip "readlink(EXPR)" 8 6
+.Ip "readlink EXPR" 8
+Returns the value of a symbolic link, if symbolic links are implemented.
+If not, gives a fatal error.
+If there is some system error, returns the undefined value and sets $! (errno).
+If EXPR is omitted, uses $_.
+.Ip "recv(SOCKET,SCALAR,LEN,FLAGS)" 8 4
+Receives a message on a socket.
+Attempts to receive LENGTH bytes of data into variable SCALAR from the specified
+SOCKET filehandle.
+Returns the address of the sender, or the undefined value if there's an error.
+SCALAR will be grown or shrunk to the length actually read.
+Takes the same flags as the system call of the same name.
+.Ip "redo LABEL" 8 8
+.Ip "redo" 8
+The
+.I redo
+command restarts the loop block without evaluating the conditional again.
+The
+.I continue
+block, if any, is not executed.
+If the LABEL is omitted, the command refers to the innermost enclosing loop.
+This command is normally used by programs that want to lie to themselves
+about what was just input:
+.nf
+
+.ne 16
+ # a simpleminded Pascal comment stripper
+ # (warning: assumes no { or } in strings)
+ line: while (<STDIN>) {
+ while (s|\|({.*}.*\|){.*}|$1 \||) {}
+ s|{.*}| \||;
+ if (s|{.*| \||) {
+ $front = $_;
+ while (<STDIN>) {
+ if (\|/\|}/\|) { # end of comment?
+ s|^|$front{|;
+ redo line;
+ }
+ }
+ }
+ print;
+ }
+
+.fi
+.Ip "rename(OLDNAME,NEWNAME)" 8 2
+Changes the name of a file.
+Returns 1 for success, 0 otherwise.
+Will not work across filesystem boundaries.
+.Ip "require(EXPR)" 8 6
+.Ip "require EXPR" 8
+.Ip "require" 8
+Includes the library file specified by EXPR, or by $_ if EXPR is not supplied.
+Has semantics similar to the following subroutine:
+.nf
+
+ sub require {
+ local($filename) = @_;
+ return 1 if $INC{$filename};
+ local($realfilename,$result);
+ ITER: {
+ foreach $prefix (@INC) {
+ $realfilename = "$prefix/$filename";
+ if (-f $realfilename) {
+ $result = do $realfilename;
+ last ITER;
+ }
+ }
+ die "Can't find $filename in \e@INC";
+ }
+ die $@ if $@;
+ die "$filename did not return true value" unless $result;
+ $INC{$filename} = $realfilename;
+ $result;
+ }
+
+.fi
+Note that the file will not be included twice under the same specified name.
+.Ip "reset(EXPR)" 8 6
+.Ip "reset EXPR" 8
+.Ip "reset" 8
+Generally used in a
+.I continue
+block at the end of a loop to clear variables and reset ?? searches
+so that they work again.
+The expression is interpreted as a list of single characters (hyphens allowed
+for ranges).
+All variables and arrays beginning with one of those letters are reset to
+their pristine state.
+If the expression is omitted, one-match searches (?pattern?) are reset to
+match again.
+Only resets variables or searches in the current package.
+Always returns 1.
+Examples:
+.nf
+
+.ne 3
+ reset \'X\'; \h'|2i'# reset all X variables
+ reset \'a\-z\';\h'|2i'# reset lower case variables
+ reset; \h'|2i'# just reset ?? searches
+
+.fi
+Note: resetting \*(L"A\-Z\*(R" is not recommended since you'll wipe out your ARGV and ENV
+arrays.
+.Sp
+The use of reset on dbm associative arrays does not change the dbm file.
+(It does, however, flush any entries cached by perl, which may be useful if
+you are sharing the dbm file.
+Then again, maybe not.)
+.Ip "return LIST" 8 3
+Returns from a subroutine with the value specified.
+(Note that a subroutine can automatically return
+the value of the last expression evaluated.
+That's the preferred method\*(--use of an explicit
+.I return
+is a bit slower.)
+.Ip "reverse(LIST)" 8 4
+.Ip "reverse LIST" 8
+In an array context, returns an array value consisting of the elements
+of LIST in the opposite order.
+In a scalar context, returns a string value consisting of the bytes of
+the first element of LIST in the opposite order.
+.Ip "rewinddir(DIRHANDLE)" 8 5
+.Ip "rewinddir DIRHANDLE" 8
+Sets the current position to the beginning of the directory for the readdir() routine on DIRHANDLE.
+.Ip "rindex(STR,SUBSTR,POSITION)" 8 6
+.Ip "rindex(STR,SUBSTR)" 8 4
+Works just like index except that it
+returns the position of the LAST occurrence of SUBSTR in STR.
+If POSITION is specified, returns the last occurrence at or before that
+position.
+.Ip "rmdir(FILENAME)" 8 4
+.Ip "rmdir FILENAME" 8
+Deletes the directory specified by FILENAME if it is empty.
+If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno).
+If FILENAME is omitted, uses $_.
+.Ip "s/PATTERN/REPLACEMENT/gieo" 8 3
+Searches a string for a pattern, and if found, replaces that pattern with the
+replacement text and returns the number of substitutions made.
+Otherwise it returns false (0).
+The \*(L"g\*(R" is optional, and if present, indicates that all occurrences
+of the pattern are to be replaced.
+The \*(L"i\*(R" is also optional, and if present, indicates that matching
+is to be done in a case-insensitive manner.
+The \*(L"e\*(R" is likewise optional, and if present, indicates that
+the replacement string is to be evaluated as an expression rather than just
+as a double-quoted string.
+Any non-alphanumeric delimiter may replace the slashes;
+if single quotes are used, no
+interpretation is done on the replacement string (the e modifier overrides
+this, however); if backquotes are used, the replacement string is a command
+to execute whose output will be used as the actual replacement text.
+If no string is specified via the =~ or !~ operator,
+the $_ string is searched and modified.
+(The string specified with =~ must be a scalar variable, an array element,
+or an assignment to one of those, i.e. an lvalue.)
+If the pattern contains a $ that looks like a variable rather than an
+end-of-string test, the variable will be interpolated into the pattern at
+run-time.
+If you only want the pattern compiled once the first time the variable is
+interpolated, add an \*(L"o\*(R" at the end.
+If the PATTERN evaluates to a null string, the most recent successful
+regular expression is used instead.
+See also the section on regular expressions.
+Examples:
+.nf
+
+ s/\|\e\|bgreen\e\|b/mauve/g; # don't change wintergreen
+
+ $path \|=~ \|s|\|/usr/bin|\|/usr/local/bin|;
+
+ s/Login: $foo/Login: $bar/; # run-time pattern
+
+ ($foo = $bar) =~ s/bar/foo/;
+
+ $_ = \'abc123xyz\';
+ s/\ed+/$&*2/e; # yields \*(L'abc246xyz\*(R'
+ s/\ed+/sprintf("%5d",$&)/e; # yields \*(L'abc 246xyz\*(R'
+ s/\ew/$& x 2/eg; # yields \*(L'aabbcc 224466xxyyzz\*(R'
+
+ s/\|([^ \|]*\|) *\|([^ \|]*\|)\|/\|$2 $1/; # reverse 1st two fields
+
+.fi
+(Note the use of $ instead of \|\e\| in the last example. See section
+on regular expressions.)
+.Ip "scalar(EXPR)" 8 3
+Forces EXPR to be interpreted in a scalar context and returns the value
+of EXPR.
+.Ip "seek(FILEHANDLE,POSITION,WHENCE)" 8 3
+Randomly positions the file pointer for FILEHANDLE, just like the fseek()
+call of stdio.
+FILEHANDLE may be an expression whose value gives the name of the filehandle.
+Returns 1 upon success, 0 otherwise.
+.Ip "seekdir(DIRHANDLE,POS)" 8 3
+Sets the current position for the readdir() routine on DIRHANDLE.
+POS must be a value returned by telldir().
+Has the same caveats about possible directory compaction as the corresponding
+system library routine.
+.Ip "select(FILEHANDLE)" 8 3
+.Ip "select" 8 3
+Returns the currently selected filehandle.
+Sets the current default filehandle for output, if FILEHANDLE is supplied.
+This has two effects: first, a
+.I write
+or a
+.I print
+without a filehandle will default to this FILEHANDLE.
+Second, references to variables related to output will refer to this output
+channel.
+For example, if you have to set the top of form format for more than
+one output channel, you might do the following:
+.nf
+
+.ne 4
+ select(REPORT1);
+ $^ = \'report1_top\';
+ select(REPORT2);
+ $^ = \'report2_top\';
+
+.fi
+FILEHANDLE may be an expression whose value gives the name of the actual filehandle.
+Thus:
+.nf
+
+ $oldfh = select(STDERR); $| = 1; select($oldfh);
+
+.fi
+.Ip "select(RBITS,WBITS,EBITS,TIMEOUT)" 8 3
+This calls the select system call with the bitmasks specified, which can
+be constructed using fileno() and vec(), along these lines:
+.nf
+
+ $rin = $win = $ein = '';
+ vec($rin,fileno(STDIN),1) = 1;
+ vec($win,fileno(STDOUT),1) = 1;
+ $ein = $rin | $win;
+
+.fi
+If you want to select on many filehandles you might wish to write a subroutine:
+.nf
+
+ sub fhbits {
+ local(@fhlist) = split(' ',$_[0]);
+ local($bits);
+ for (@fhlist) {
+ vec($bits,fileno($_),1) = 1;
+ }
+ $bits;
+ }
+ $rin = &fhbits('STDIN TTY SOCK');
+
+.fi
+The usual idiom is:
+.nf
+
+ ($nfound,$timeleft) =
+ select($rout=$rin, $wout=$win, $eout=$ein, $timeout);
+
+or to block until something becomes ready:
+
+.ie t \{\
+ $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef);
+'br\}
+.el \{\
+ $nfound = select($rout=$rin, $wout=$win,
+ $eout=$ein, undef);
+'br\}
+
+.fi
+Any of the bitmasks can also be undef.
+The timeout, if specified, is in seconds, which may be fractional.
+NOTE: not all implementations are capable of returning the $timeleft.
+If not, they always return $timeleft equal to the supplied $timeout.
+.Ip "semctl(ID,SEMNUM,CMD,ARG)" 8 4
+Calls the System V IPC function semctl. If CMD is &IPC_STAT or
+&GETALL, then ARG must be a variable which will hold the returned
+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
+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
+Calls the System V IPC function semop to perform semaphore operations
+such as signaling and waiting. OPSTRING must be a packed array of
+semop structures. Each semop structure can be generated with
+\&'pack("sss", $semnum, $semop, $semflag)'. The number of semaphore
+operations is implied by the length of OPSTRING. Returns true if
+successful, or false if there is an error. As an example, the
+following code waits on semaphore $semnum of semaphore id $semid:
+.nf
+
+ $semop = pack("sss", $semnum, -1, 0);
+ die "Semaphore trouble: $!\en" unless semop($semid, $semop);
+
+.fi
+To signal the semaphore, replace "-1" with "1".
+.Ip "send(SOCKET,MSG,FLAGS,TO)" 8 4
+.Ip "send(SOCKET,MSG,FLAGS)" 8
+Sends a message on a socket.
+Takes the same flags as the system call of the same name.
+On unconnected sockets you must specify a destination to send TO.
+Returns the number of characters sent, or the undefined value if
+there is an error.
+.Ip "setpgrp(PID,PGRP)" 8 4
+Sets the current process group for the specified PID, 0 for the current
+process.
+Will produce a fatal error if used on a machine that doesn't implement
+setpgrp(2).
+.Ip "setpriority(WHICH,WHO,PRIORITY)" 8 4
+Sets the current priority for a process, a process group, or a user.
+(See setpriority(2).)
+Will produce a fatal error if used on a machine that doesn't implement
+setpriority(2).
+.Ip "setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)" 8 3
+Sets the socket option requested.
+Returns undefined if there is an error.
+OPTVAL may be specified as undef if you don't want to pass an argument.
+.Ip "shift(ARRAY)" 8 6
+.Ip "shift ARRAY" 8
+.Ip "shift" 8
+Shifts the first value of the array off and returns it,
+shortening the array by 1 and moving everything down.
+If there are no elements in the array, returns the undefined value.
+If ARRAY is omitted, shifts the @ARGV array in the main program, and the @_
+array in subroutines.
+(This is determined lexically.)
+See also unshift(), push() and pop().
+Shift() and unshift() do the same thing to the left end of an array that push()
+and pop() do to the right end.
+.Ip "shmctl(ID,CMD,ARG)" 8 4
+Calls the System V IPC function shmctl. If CMD is &IPC_STAT, then ARG
+must be a variable which will hold the returned shmid_ds structure.
+Returns like ioctl: the undefined value for error, "0 but true" for
+zero, or the actual return value otherwise.
+.Ip "shmget(KEY,SIZE,FLAGS)" 8 4
+Calls the System V IPC function shmget. Returns the shared memory
+segment id, or the undefined value if there is an error.
+.Ip "shmread(ID,VAR,POS,SIZE)" 8 4
+.Ip "shmwrite(ID,STRING,POS,SIZE)" 8
+Reads or writes the System V shared memory segment ID starting at
+position POS for size SIZE by attaching to it, copying in/out, and
+detaching from it. When reading, VAR must be a variable which
+will hold the data read. When writing, if STRING is too long,
+only SIZE bytes are used; if STRING is too short, nulls are
+written to fill out SIZE bytes. Return true if successful, or
+false if there is an error.
+.Ip "shutdown(SOCKET,HOW)" 8 3
+Shuts down a socket connection in the manner indicated by HOW, which has
+the same interpretation as in the system call of the same name.
+.Ip "sin(EXPR)" 8 4
+.Ip "sin EXPR" 8
+Returns the sine of EXPR (expressed in radians).
+If EXPR is omitted, returns sine of $_.
+.Ip "sleep(EXPR)" 8 6
+.Ip "sleep EXPR" 8
+.Ip "sleep" 8
+Causes the script to sleep for EXPR seconds, or forever if no EXPR.
+May be interrupted by sending the process a SIGALARM.
+Returns the number of seconds actually slept.
+.Ip "socket(SOCKET,DOMAIN,TYPE,PROTOCOL)" 8 3
+Opens a socket of the specified kind and attaches it to filehandle SOCKET.
+DOMAIN, TYPE and PROTOCOL are specified the same as for the system call
+of the same name.
+You may need to run h2ph on sys/socket.h to get the proper values handy
+in a perl library file.
+Return true if successful.
+See the example in the section on Interprocess Communication.
+.Ip "socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)" 8 3
+Creates an unnamed pair of sockets in the specified domain, of the specified
+type.
+DOMAIN, TYPE and PROTOCOL are specified the same as for the system call
+of the same name.
+If unimplemented, yields a fatal error.
+Return true if successful.
+.Ip "sort(SUBROUTINE LIST)" 8 9
+.Ip "sort(LIST)" 8
+.Ip "sort SUBROUTINE LIST" 8
+.Ip "sort LIST" 8
+Sorts the LIST and returns the sorted array value.
+Nonexistent values of arrays are stripped out.
+If SUBROUTINE is omitted, sorts in standard string comparison order.
+If SUBROUTINE is specified, gives the name of a subroutine that returns
+an integer less than, equal to, or greater than 0,
+depending on how the elements of the array are to be ordered.
+In the interests of efficiency the normal calling code for subroutines
+is bypassed, with the following effects: the subroutine may not be a recursive
+subroutine, and the two elements to be compared are passed into the subroutine
+not via @_ but as $a and $b (see example below).
+They are passed by reference so don't modify $a and $b.
+SUBROUTINE may be a scalar variable name, in which case the value provides
+the name of the subroutine to use.
+Examples:
+.nf
+
+.ne 4
+ sub byage {
+ $age{$a} - $age{$b}; # presuming integers
+ }
+ @sortedclass = sort byage @class;
+
+.ne 9
+ sub reverse { $a lt $b ? 1 : $a gt $b ? \-1 : 0; }
+ @harry = (\'dog\',\'cat\',\'x\',\'Cain\',\'Abel\');
+ @george = (\'gone\',\'chased\',\'yz\',\'Punished\',\'Axed\');
+ print sort @harry;
+ # prints AbelCaincatdogx
+ print sort reverse @harry;
+ # prints xdogcatCainAbel
+ print sort @george, \'to\', @harry;
+ # prints AbelAxedCainPunishedcatchaseddoggonetoxyz
+
+.fi
+.Ip "splice(ARRAY,OFFSET,LENGTH,LIST)" 8 8
+.Ip "splice(ARRAY,OFFSET,LENGTH)" 8
+.Ip "splice(ARRAY,OFFSET)" 8
+Removes the elements designated by OFFSET and LENGTH from an array, and
+replaces them with the elements of LIST, if any.
+Returns the elements removed from the array.
+The array grows or shrinks as necessary.
+If LENGTH is omitted, removes everything from OFFSET onward.
+The following equivalencies hold (assuming $[ == 0):
+.nf
+
+ push(@a,$x,$y)\h'|3.5i'splice(@a,$#a+1,0,$x,$y)
+ pop(@a)\h'|3.5i'splice(@a,-1)
+ shift(@a)\h'|3.5i'splice(@a,0,1)
+ unshift(@a,$x,$y)\h'|3.5i'splice(@a,0,0,$x,$y)
+ $a[$x] = $y\h'|3.5i'splice(@a,$x,1,$y);
+
+Example, assuming array lengths are passed before arrays:
+
+ sub aeq { # compare two array values
+ local(@a) = splice(@_,0,shift);
+ local(@b) = splice(@_,0,shift);
+ return 0 unless @a == @b; # same len?
+ while (@a) {
+ return 0 if pop(@a) ne pop(@b);
+ }
+ return 1;
+ }
+ if (&aeq($len,@foo[1..$len],0+@bar,@bar)) { ... }
+
+.fi
+.Ip "split(/PATTERN/,EXPR,LIMIT)" 8 8
+.Ip "split(/PATTERN/,EXPR)" 8 8
+.Ip "split(/PATTERN/)" 8
+.Ip "split" 8
+Splits a string into an array of strings, and returns it.
+(If not in an array context, returns the number of fields found and splits
+into the @_ array.
+(In an array context, you can force the split into @_
+by using ?? as the pattern delimiters, but it still returns the array value.))
+If EXPR is omitted, splits the $_ string.
+If PATTERN is also omitted, splits on whitespace (/[\ \et\en]+/).
+Anything matching PATTERN is taken to be a delimiter separating the fields.
+(Note that the delimiter may be longer than one character.)
+If LIMIT is specified, splits into no more than that many fields (though it
+may split into fewer).
+If LIMIT is unspecified, trailing null fields are stripped (which
+potential users of pop() would do well to remember).
+A pattern matching the null string (not to be confused with a null pattern //,
+which is just one member of the set of patterns matching a null string)
+will split the value of EXPR into separate characters at each point it
+matches that way.
+For example:
+.nf
+
+ print join(\':\', split(/ */, \'hi there\'));
+
+.fi
+produces the output \*(L'h:i:t:h:e:r:e\*(R'.
+.Sp
+The LIMIT parameter can be used to partially split a line
+.nf
+
+ ($login, $passwd, $remainder) = split(\|/\|:\|/\|, $_, 3);
+
+.fi
+(When assigning to a list, if LIMIT is omitted, perl supplies a LIMIT one
+larger than the number of variables in the list, to avoid unnecessary work.
+For the list above LIMIT would have been 4 by default.
+In time critical applications it behooves you not to split into
+more fields than you really need.)
+.Sp
+If the PATTERN contains parentheses, additional array elements are created
+from each matching substring in the delimiter.
+.Sp
+ split(/([,-])/,"1-10,20");
+.Sp
+produces the array value
+.Sp
+ (1,'-',10,',',20)
+.Sp
+The pattern /PATTERN/ may be replaced with an expression to specify patterns
+that vary at runtime.
+(To do runtime compilation only once, use /$variable/o.)
+As a special case, specifying a space (\'\ \') will split on white space
+just as split with no arguments does, but leading white space does NOT
+produce a null first field.
+Thus, split(\'\ \') can be used to emulate
+.IR awk 's
+default behavior, whereas
+split(/\ /) will give you as many null initial fields as there are
+leading spaces.
+.Sp
+Example:
+.nf
+
+.ne 5
+ open(passwd, \'/etc/passwd\');
+ while (<passwd>) {
+.ie t \{\
+ ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(\|/\|:\|/\|);
+'br\}
+.el \{\
+ ($login, $passwd, $uid, $gid, $gcos, $home, $shell)
+ = split(\|/\|:\|/\|);
+'br\}
+ .\|.\|.
+ }
+
+.fi
+(Note that $shell above will still have a newline on it. See chop().)
+See also
+.IR join .
+.Ip "sprintf(FORMAT,LIST)" 8 4
+Returns a string formatted by the usual printf conventions.
+The * character is not supported.
+.Ip "sqrt(EXPR)" 8 4
+.Ip "sqrt EXPR" 8
+Return the square root of EXPR.
+If EXPR is omitted, returns square root of $_.
+.Ip "srand(EXPR)" 8 4
+.Ip "srand EXPR" 8
+Sets the random number seed for the
+.I rand
+operator.
+If EXPR is omitted, does srand(time).
+.Ip "stat(FILEHANDLE)" 8 8
+.Ip "stat FILEHANDLE" 8
+.Ip "stat(EXPR)" 8
+.Ip "stat SCALARVARIABLE" 8
+Returns a 13-element array giving the statistics for a file, either the file
+opened via FILEHANDLE, or named by EXPR.
+Typically used as follows:
+.nf
+
+.ne 3
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = stat($filename);
+
+.fi
+If stat is passed the special filehandle consisting of an underline,
+no stat is done, but the current contents of the stat structure from
+the last stat or filetest are returned.
+Example:
+.nf
+
+.ne 3
+ if (-x $file && (($d) = stat(_)) && $d < 0) {
+ print "$file is executable NFS file\en";
+ }
+
+.fi
+.Ip "study(SCALAR)" 8 6
+.Ip "study SCALAR" 8
+.Ip "study"
+Takes extra time to study SCALAR ($_ if unspecified) in anticipation of
+doing many pattern matches on the string before it is next modified.
+This may or may not save time, depending on the nature and number of patterns
+you are searching on, and on the distribution of character frequencies in
+the string to be searched\*(--you probably want to compare runtimes with and
+without it to see which runs faster.
+Those loops which scan for many short constant strings (including the constant
+parts of more complex patterns) will benefit most.
+You may have only one study active at a time\*(--if you study a different
+scalar the first is \*(L"unstudied\*(R".
+(The way study works is this: a linked list of every character in the string
+to be searched is made, so we know, for example, where all the \*(L'k\*(R' characters
+are.
+From each search string, the rarest character is selected, based on some
+static frequency tables constructed from some C programs and English text.
+Only those places that contain this \*(L"rarest\*(R" character are examined.)
+.Sp
+For example, here is a loop which inserts index producing entries before any line
+containing a certain pattern:
+.nf
+
+.ne 8
+ while (<>) {
+ study;
+ print ".IX foo\en" if /\ebfoo\eb/;
+ print ".IX bar\en" if /\ebbar\eb/;
+ print ".IX blurfl\en" if /\ebblurfl\eb/;
+ .\|.\|.
+ print;
+ }
+
+.fi
+In searching for /\ebfoo\eb/, only those locations in $_ that contain \*(L'f\*(R'
+will be looked at, because \*(L'f\*(R' is rarer than \*(L'o\*(R'.
+In general, this is a big win except in pathological cases.
+The only question is whether it saves you more time than it took to build
+the linked list in the first place.
+.Sp
+Note that if you have to look for strings that you don't know till runtime,
+you can build an entire loop as a string and eval that to avoid recompiling
+all your patterns all the time.
+Together with undefining $/ to input entire files as one record, this can
+be very fast, often faster than specialized programs like fgrep.
+The following scans a list of files (@files)
+for a list of words (@words), and prints out the names of those files that
+contain a match:
+.nf
+
+.ne 12
+ $search = \'while (<>) { study;\';
+ foreach $word (@words) {
+ $search .= "++\e$seen{\e$ARGV} if /\eb$word\eb/;\en";
+ }
+ $search .= "}";
+ @ARGV = @files;
+ undef $/;
+ eval $search; # this screams
+ $/ = "\en"; # put back to normal input delim
+ foreach $file (sort keys(%seen)) {
+ print $file, "\en";
+ }
+
+.fi
+.Ip "substr(EXPR,OFFSET,LEN)" 8 2
+.Ip "substr(EXPR,OFFSET)" 8 2
+Extracts a substring out of EXPR and returns it.
+First character is at offset 0, or whatever you've set $[ to.
+If OFFSET is negative, starts that far from the end of the string.
+If LEN is omitted, returns everything to the end of the string.
+You can use the substr() function as an lvalue, in which case EXPR must
+be an lvalue.
+If you assign something shorter than LEN, the string will shrink, and
+if you assign something longer than LEN, the string will grow to accommodate it.
+To keep the string the same length you may need to pad or chop your value using
+sprintf().
+.Ip "symlink(OLDFILE,NEWFILE)" 8 2
+Creates a new filename symbolically linked to the old filename.
+Returns 1 for success, 0 otherwise.
+On systems that don't support symbolic links, produces a fatal error at
+run time.
+To check for that, use eval:
+.nf
+
+ $symlink_exists = (eval \'symlink("","");\', $@ eq \'\');
+
+.fi
+.Ip "syscall(LIST)" 8 6
+.Ip "syscall LIST" 8
+Calls the system call specified as the first element of the list, passing
+the remaining elements as arguments to the system call.
+If unimplemented, produces a fatal error.
+The arguments are interpreted as follows: if a given argument is numeric,
+the argument is passed as an int.
+If not, the pointer to the string value is passed.
+You are responsible to make sure a string is pre-extended long enough
+to receive any result that might be written into a string.
+If your integer arguments are not literals and have never been interpreted
+in a numeric context, you may need to add 0 to them to force them to look
+like numbers.
+.nf
+
+ require 'syscall.ph'; # may need to run h2ph
+ syscall(&SYS_write, fileno(STDOUT), "hi there\en", 9);
+
+.fi
+.Ip "sysread(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5
+.Ip "sysread(FILEHANDLE,SCALAR,LENGTH)" 8 5
+Attempts to read LENGTH bytes of data into variable SCALAR from the specified
+FILEHANDLE, using the system call read(2).
+It bypasses stdio, so mixing this with other kinds of reads may cause
+confusion.
+Returns the number of bytes actually read, or undef if there was an error.
+SCALAR will be grown or shrunk to the length actually read.
+An OFFSET may be specified to place the read data at some other place
+than the beginning of the string.
+.Ip "system(LIST)" 8 6
+.Ip "system LIST" 8
+Does exactly the same thing as \*(L"exec LIST\*(R" except that a fork
+is done first, and the parent process waits for the child process to complete.
+Note that argument processing varies depending on the number of arguments.
+The return value is the exit status of the program as returned by the wait()
+call.
+To get the actual exit value divide by 256.
+See also
+.IR exec .
+.Ip "syswrite(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5
+.Ip "syswrite(FILEHANDLE,SCALAR,LENGTH)" 8 5
+Attempts to write LENGTH bytes of data from variable SCALAR to the specified
+FILEHANDLE, using the system call write(2).
+It bypasses stdio, so mixing this with prints may cause
+confusion.
+Returns the number of bytes actually written, or undef if there was an error.
+An OFFSET may be specified to place the read data at some other place
+than the beginning of the string.
+.Ip "tell(FILEHANDLE)" 8 6
+.Ip "tell FILEHANDLE" 8 6
+.Ip "tell" 8
+Returns the current file position for FILEHANDLE.
+FILEHANDLE may be an expression whose value gives the name of the actual
+filehandle.
+If FILEHANDLE is omitted, assumes the file last read.
+.Ip "telldir(DIRHANDLE)" 8 5
+.Ip "telldir DIRHANDLE" 8
+Returns the current position of the readdir() routines on DIRHANDLE.
+Value may be given to seekdir() to access a particular location in
+a directory.
+Has the same caveats about possible directory compaction as the corresponding
+system library routine.
+.Ip "time" 8 4
+Returns the number of non-leap seconds since 00:00:00 UTC, January 1, 1970.
+Suitable for feeding to gmtime() and localtime().
+.Ip "times" 8 4
+Returns a four-element array giving the user and system times, in seconds, for this
+process and the children of this process.
+.Sp
+ ($user,$system,$cuser,$csystem) = times;
+.Sp
+.Ip "tr/SEARCHLIST/REPLACEMENTLIST/cds" 8 5
+.Ip "y/SEARCHLIST/REPLACEMENTLIST/cds" 8
+Translates all occurrences of the characters found in the search list with
+the corresponding character in the replacement list.
+It returns the number of characters replaced or deleted.
+If no string is specified via the =~ or !~ operator,
+the $_ string is translated.
+(The string specified with =~ must be a scalar variable, an array element,
+or an assignment to one of those, i.e. an lvalue.)
+For
+.I sed
+devotees,
+.I y
+is provided as a synonym for
+.IR tr .
+.Sp
+If the c modifier is specified, the SEARCHLIST character set is complemented.
+If the d modifier is specified, any characters specified by SEARCHLIST that
+are not found in REPLACEMENTLIST are deleted.
+(Note that this is slightly more flexible than the behavior of some
+.I tr
+programs, which delete anything they find in the SEARCHLIST, period.)
+If the s modifier is specified, sequences of characters that were translated
+to the same character are squashed down to 1 instance of the character.
+.Sp
+If the d modifier was used, the REPLACEMENTLIST is always interpreted exactly
+as specified.
+Otherwise, if the REPLACEMENTLIST is shorter than the SEARCHLIST,
+the final character is replicated till it is long enough.
+If the REPLACEMENTLIST is null, the SEARCHLIST is replicated.
+This latter is useful for counting characters in a class, or for squashing
+character sequences in a class.
+.Sp
+Examples:
+.nf
+
+ $ARGV[1] \|=~ \|y/A\-Z/a\-z/; \h'|3i'# canonicalize to lower case
+
+ $cnt = tr/*/*/; \h'|3i'# count the stars in $_
+
+ $cnt = tr/0\-9//; \h'|3i'# count the digits in $_
+
+ tr/a\-zA\-Z//s; \h'|3i'# bookkeeper \-> bokeper
+
+ ($HOST = $host) =~ tr/a\-z/A\-Z/;
+
+ y/a\-zA\-Z/ /cs; \h'|3i'# change non-alphas to single space
+
+ tr/\e200\-\e377/\e0\-\e177/;\h'|3i'# delete 8th bit
+
+.fi
+.Ip "truncate(FILEHANDLE,LENGTH)" 8 4
+.Ip "truncate(EXPR,LENGTH)" 8
+Truncates the file opened on FILEHANDLE, or named by EXPR, to the specified
+length.
+Produces a fatal error if truncate isn't implemented on your system.
+.Ip "umask(EXPR)" 8 4
+.Ip "umask EXPR" 8
+.Ip "umask" 8
+Sets the umask for the process and returns the old one.
+If EXPR is omitted, merely returns current umask.
+.Ip "undef(EXPR)" 8 6
+.Ip "undef EXPR" 8
+.Ip "undef" 8
+Undefines the value of EXPR, which must be an lvalue.
+Use only on a scalar value, an entire array, or a subroutine name (using &).
+(Undef will probably not do what you expect on most predefined variables or
+dbm array values.)
+Always returns the undefined value.
+You can omit the EXPR, in which case nothing is undefined, but you still
+get an undefined value that you could, for instance, return from a subroutine.
+Examples:
+.nf
+
+.ne 6
+ undef $foo;
+ undef $bar{'blurfl'};
+ undef @ary;
+ undef %assoc;
+ undef &mysub;
+ return (wantarray ? () : undef) if $they_blew_it;
+
+.fi
+.Ip "unlink(LIST)" 8 4
+.Ip "unlink LIST" 8
+Deletes a list of files.
+Returns the number of files successfully deleted.
+.nf
+
+.ne 2
+ $cnt = unlink \'a\', \'b\', \'c\';
+ unlink @goners;
+ unlink <*.bak>;
+
+.fi
+Note: unlink will not delete directories unless you are superuser and the
+.B \-U
+flag is supplied to
+.IR perl .
+Even if these conditions are met, be warned that unlinking a directory
+can inflict damage on your filesystem.
+Use rmdir instead.
+.Ip "unpack(TEMPLATE,EXPR)" 8 4
+Unpack does the reverse of pack: it takes a string representing
+a structure and expands it out into an array value, returning the array
+value.
+(In a scalar context, it merely returns the first value produced.)
+The TEMPLATE has the same format as in the pack function.
+Here's a subroutine that does substring:
+.nf
+
+.ne 4
+ sub substr {
+ local($what,$where,$howmuch) = @_;
+ unpack("x$where a$howmuch", $what);
+ }
+
+.ne 3
+and then there's
+
+ sub ord { unpack("c",$_[0]); }
+
+.fi
+In addition, you may prefix a field with a %<number> to indicate that
+you want a <number>-bit checksum of the items instead of the items themselves.
+Default is a 16-bit checksum.
+For example, the following computes the same number as the System V sum program:
+.nf
+
+.ne 4
+ while (<>) {
+ $checksum += unpack("%16C*", $_);
+ }
+ $checksum %= 65536;
+
+.fi
+.Ip "unshift(ARRAY,LIST)" 8 4
+Does the opposite of a
+.IR shift .
+Or the opposite of a
+.IR push ,
+depending on how you look at it.
+Prepends list to the front of the array, and returns the number of elements
+in the new array.
+.nf
+
+ unshift(ARGV, \'\-e\') unless $ARGV[0] =~ /^\-/;
+
+.fi
+.Ip "utime(LIST)" 8 2
+.Ip "utime LIST" 8 2
+Changes the access and modification times on each file of a list of files.
+The first two elements of the list must be the NUMERICAL access and
+modification times, in that order.
+Returns the number of files successfully changed.
+The inode modification time of each file is set to the current time.
+Example of a \*(L"touch\*(R" command:
+.nf
+
+.ne 3
+ #!/usr/bin/perl
+ $now = time;
+ utime $now, $now, @ARGV;
+
+.fi
+.Ip "values(ASSOC_ARRAY)" 8 6
+.Ip "values ASSOC_ARRAY" 8
+Returns a normal array consisting of all the values of the named associative
+array.
+The values are returned in an apparently random order, but it is the same order
+as either the keys() or each() function would produce on the same array.
+See also keys() and each().
+.Ip "vec(EXPR,OFFSET,BITS)" 8 2
+Treats a string as a vector of unsigned integers, and returns the value
+of the bitfield specified.
+May also be assigned to.
+BITS must be a power of two from 1 to 32.
+.Sp
+Vectors created with vec() can also be manipulated with the logical operators
+|, & and ^,
+which will assume a bit vector operation is desired when both operands are
+strings.
+This interpretation is not enabled unless there is at least one vec() in
+your program, to protect older programs.
+.Sp
+To transform a bit vector into a string or array of 0's and 1's, use these:
+.nf
+
+ $bits = unpack("b*", $vector);
+ @bits = split(//, unpack("b*", $vector));
+
+.fi
+If you know the exact length in bits, it can be used in place of the *.
+.Ip "wait" 8 6
+Waits for a child process to terminate and returns the pid of the deceased
+process, or -1 if there are no child processes.
+The status is returned in $?.
+.Ip "waitpid(PID,FLAGS)" 8 6
+Waits for a particular child process to terminate and returns the pid of the deceased
+process, or -1 if there is no such child process.
+The status is returned in $?.
+If you say
+.nf
+
+ require "sys/wait.h";
+ .\|.\|.
+ waitpid(-1,&WNOHANG);
+
+.fi
+then you can do a non-blocking wait for any process. Non-blocking wait
+is only available on machines supporting either the
+.I waitpid (2)
+or
+.I wait4 (2)
+system calls.
+However, waiting for a particular pid with FLAGS of 0 is implemented
+everywhere. (Perl emulates the system call by remembering the status
+values of processes that have exited but have not been harvested by the
+Perl script yet.)
+.Ip "wantarray" 8 4
+Returns true if the context of the currently executing subroutine
+is looking for an array value.
+Returns false if the context is looking for a scalar.
+.nf
+
+ return wantarray ? () : undef;
+
+.fi
+.Ip "warn(LIST)" 8 4
+.Ip "warn LIST" 8
+Produces a message on STDERR just like \*(L"die\*(R", but doesn't exit.
+.Ip "write(FILEHANDLE)" 8 6
+.Ip "write(EXPR)" 8
+.Ip "write" 8
+Writes a formatted record (possibly multi-line) to the specified file,
+using the format associated with that file.
+By default the format for a file is the one having the same name is the
+filehandle, but the format for the current output channel (see
+.IR select )
+may be set explicitly
+by assigning the name of the format to the $~ variable.
+.Sp
+Top of form processing is handled automatically:
+if there is insufficient room on the current page for the formatted
+record, the page is advanced by writing a form feed,
+a special top-of-page format is used
+to format the new page header, and then the record is written.
+By default the top-of-page format is \*(L"top\*(R", but it
+may be set to the
+format of your choice by assigning the name to the $^ variable.
+The number of lines remaining on the current page is in variable $-, which
+can be set to 0 to force a new page.
+.Sp
+If FILEHANDLE is unspecified, output goes to the current default output channel,
+which starts out as
+.I STDOUT
+but may be changed by the
+.I select
+operator.
+If the FILEHANDLE is an EXPR, then the expression is evaluated and the
+resulting string is used to look up the name of the FILEHANDLE at run time.
+For more on formats, see the section on formats later on.
+.Sp
+Note that write is NOT the opposite of read.
+''' Beginning of part 4
+''' $Header: perl.man,v 4.0 91/03/20 01:38:08 lwall Locked $
+'''
+''' $Log: perl.man,v $
+''' Revision 4.0 91/03/20 01:38:08 lwall
+''' 4.0 baseline.
+'''
+''' Revision 3.0.1.14 91/01/11 18:18:53 lwall
+''' patch42: started an addendum and errata section in the man page
+'''
+''' Revision 3.0.1.13 90/11/10 01:51:00 lwall
+''' patch38: random cleanup
+'''
+''' Revision 3.0.1.12 90/10/20 02:15:43 lwall
+''' patch37: patch37: fixed various typos in man page
+'''
+''' Revision 3.0.1.11 90/10/16 10:04:28 lwall
+''' patch29: added @###.## fields to format
+'''
+''' Revision 3.0.1.10 90/08/09 04:47:35 lwall
+''' patch19: added require operator
+''' patch19: added numeric interpretation of $]
+'''
+''' Revision 3.0.1.9 90/08/03 11:15:58 lwall
+''' patch19: Intermediate diffs for Randal
+'''
+''' Revision 3.0.1.8 90/03/27 16:19:31 lwall
+''' patch16: MSDOS support
+'''
+''' Revision 3.0.1.7 90/03/14 12:29:50 lwall
+''' patch15: man page falsely states that you can't subscript array values
+'''
+''' Revision 3.0.1.6 90/03/12 16:54:04 lwall
+''' patch13: improved documentation of *name
+'''
+''' Revision 3.0.1.5 90/02/28 18:01:52 lwall
+''' patch9: $0 is now always the command name
+'''
+''' Revision 3.0.1.4 89/12/21 20:12:39 lwall
+''' patch7: documented that package'filehandle works as well as $package'variable
+''' patch7: documented which identifiers are always in package main
+'''
+''' Revision 3.0.1.3 89/11/17 15:32:25 lwall
+''' patch5: fixed some manual typos and indent problems
+''' patch5: clarified difference between $! and $@
+'''
+''' Revision 3.0.1.2 89/11/11 04:46:40 lwall
+''' patch2: made some line breaks depend on troff vs. nroff
+''' patch2: clarified operation of ^ and $ when $* is false
+'''
+''' Revision 3.0.1.1 89/10/26 23:18:43 lwall
+''' patch1: documented the desirability of unnecessary parentheses
+'''
+''' Revision 3.0 89/10/18 15:21:55 lwall
+''' 3.0 baseline
+'''
+.Sh "Precedence"
+.I Perl
+operators have the following associativity and precedence:
+.nf
+
+nonassoc\h'|1i'print printf exec system sort reverse
+\h'1.5i'chmod chown kill unlink utime die return
+left\h'|1i',
+right\h'|1i'= += \-= *= etc.
+right\h'|1i'?:
+nonassoc\h'|1i'.\|.
+left\h'|1i'||
+left\h'|1i'&&
+left\h'|1i'| ^
+left\h'|1i'&
+nonassoc\h'|1i'== != <=> eq ne cmp
+nonassoc\h'|1i'< > <= >= lt gt le ge
+nonassoc\h'|1i'chdir exit eval reset sleep rand umask
+nonassoc\h'|1i'\-r \-w \-x etc.
+left\h'|1i'<< >>
+left\h'|1i'+ \- .
+left\h'|1i'* / % x
+left\h'|1i'=~ !~
+right\h'|1i'! ~ and unary minus
+right\h'|1i'**
+nonassoc\h'|1i'++ \-\|\-
+left\h'|1i'\*(L'(\*(R'
+
+.fi
+As mentioned earlier, if any list operator (print, etc.) or
+any unary operator (chdir, etc.)
+is followed by a left parenthesis as the next token on the same line,
+the operator and arguments within parentheses are taken to
+be of highest precedence, just like a normal function call.
+Examples:
+.nf
+
+ chdir $foo || die;\h'|3i'# (chdir $foo) || die
+ chdir($foo) || die;\h'|3i'# (chdir $foo) || die
+ chdir ($foo) || die;\h'|3i'# (chdir $foo) || die
+ chdir +($foo) || die;\h'|3i'# (chdir $foo) || die
+
+but, because * is higher precedence than ||:
+
+ chdir $foo * 20;\h'|3i'# chdir ($foo * 20)
+ chdir($foo) * 20;\h'|3i'# (chdir $foo) * 20
+ chdir ($foo) * 20;\h'|3i'# (chdir $foo) * 20
+ chdir +($foo) * 20;\h'|3i'# chdir ($foo * 20)
+
+ rand 10 * 20;\h'|3i'# rand (10 * 20)
+ rand(10) * 20;\h'|3i'# (rand 10) * 20
+ rand (10) * 20;\h'|3i'# (rand 10) * 20
+ rand +(10) * 20;\h'|3i'# rand (10 * 20)
+
+.fi
+In the absence of parentheses,
+the precedence of list operators such as print, sort or chmod is
+either very high or very low depending on whether you look at the left
+side of operator or the right side of it.
+For example, in
+.nf
+
+ @ary = (1, 3, sort 4, 2);
+ print @ary; # prints 1324
+
+.fi
+the commas on the right of the sort are evaluated before the sort, but
+the commas on the left are evaluated after.
+In other words, list operators tend to gobble up all the arguments that
+follow them, and then act like a simple term with regard to the preceding
+expression.
+Note that you have to be careful with parens:
+.nf
+
+.ne 3
+ # These evaluate exit before doing the print:
+ print($foo, exit); # Obviously not what you want.
+ print $foo, exit; # Nor is this.
+
+.ne 4
+ # These do the print before evaluating exit:
+ (print $foo), exit; # This is what you want.
+ print($foo), exit; # Or this.
+ print ($foo), exit; # Or even this.
+
+Also note that
+
+ print ($foo & 255) + 1, "\en";
+
+.fi
+probably doesn't do what you expect at first glance.
+.Sh "Subroutines"
+A subroutine may be declared as follows:
+.nf
+
+ sub NAME BLOCK
+
+.fi
+.PP
+Any arguments passed to the routine come in as array @_,
+that is ($_[0], $_[1], .\|.\|.).
+The array @_ is a local array, but its values are references to the
+actual scalar parameters.
+The return value of the subroutine is the value of the last expression
+evaluated, and can be either an array value or a scalar value.
+Alternately, a return statement may be used to specify the returned value and
+exit the subroutine.
+To create local variables see the
+.I local
+operator.
+.PP
+A subroutine is called using the
+.I do
+operator or the & operator.
+.nf
+
+.ne 12
+Example:
+
+ sub MAX {
+ local($max) = pop(@_);
+ foreach $foo (@_) {
+ $max = $foo \|if \|$max < $foo;
+ }
+ $max;
+ }
+
+ .\|.\|.
+ $bestday = &MAX($mon,$tue,$wed,$thu,$fri);
+
+.ne 21
+Example:
+
+ # get a line, combining continuation lines
+ # that start with whitespace
+ sub get_line {
+ $thisline = $lookahead;
+ line: while ($lookahead = <STDIN>) {
+ if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) {
+ $thisline \|.= \|$lookahead;
+ }
+ else {
+ last line;
+ }
+ }
+ $thisline;
+ }
+
+ $lookahead = <STDIN>; # get first line
+ while ($_ = do get_line(\|)) {
+ .\|.\|.
+ }
+
+.fi
+.nf
+.ne 6
+Use array assignment to a local list to name your formal arguments:
+
+ sub maybeset {
+ local($key, $value) = @_;
+ $foo{$key} = $value unless $foo{$key};
+ }
+
+.fi
+This also has the effect of turning call-by-reference into call-by-value,
+since the assignment copies the values.
+.Sp
+Subroutines may be called recursively.
+If a subroutine is called using the & form, the argument list is optional.
+If omitted, no @_ array is set up for the subroutine; the @_ array at the
+time of the call is visible to subroutine instead.
+.nf
+
+ do foo(1,2,3); # pass three arguments
+ &foo(1,2,3); # the same
+
+ do foo(); # pass a null list
+ &foo(); # the same
+ &foo; # pass no arguments\*(--more efficient
+
+.fi
+.Sh "Passing By Reference"
+Sometimes you don't want to pass the value of an array to a subroutine but
+rather the name of it, so that the subroutine can modify the global copy
+of it rather than working with a local copy.
+In perl you can refer to all the objects of a particular name by prefixing
+the name with a star: *foo.
+When evaluated, it produces a scalar value that represents all the objects
+of that name, including any filehandle, format or subroutine.
+When assigned to within a local() operation, it causes the name mentioned
+to refer to whatever * value was assigned to it.
+Example:
+.nf
+
+ sub doubleary {
+ local(*someary) = @_;
+ foreach $elem (@someary) {
+ $elem *= 2;
+ }
+ }
+ do doubleary(*foo);
+ do doubleary(*bar);
+
+.fi
+Assignment to *name is currently recommended only inside a local().
+You can actually assign to *name anywhere, but the previous referent of
+*name may be stranded forever.
+This may or may not bother you.
+.Sp
+Note that scalars are already passed by reference, so you can modify scalar
+arguments without using this mechanism by referring explicitly to the $_[nnn]
+in question.
+You can modify all the elements of an array by passing all the elements
+as scalars, but you have to use the * mechanism to push, pop or change the
+size of an array.
+The * mechanism will probably be more efficient in any case.
+.Sp
+Since a *name value contains unprintable binary data, if it is used as
+an argument in a print, or as a %s argument in a printf or sprintf, it
+then has the value '*name', just so it prints out pretty.
+.Sp
+Even if you don't want to modify an array, this mechanism is useful for
+passing multiple arrays in a single LIST, since normally the LIST mechanism
+will merge all the array values so that you can't extract out the
+individual arrays.
+.Sh "Regular Expressions"
+The patterns used in pattern matching are regular expressions such as
+those supplied in the Version 8 regexp routines.
+(In fact, the routines are derived from Henry Spencer's freely redistributable
+reimplementation of the V8 routines.)
+In addition, \ew matches an alphanumeric character (including \*(L"_\*(R") and \eW a nonalphanumeric.
+Word boundaries may be matched by \eb, and non-boundaries by \eB.
+A whitespace character is matched by \es, non-whitespace by \eS.
+A numeric character is matched by \ed, non-numeric by \eD.
+You may use \ew, \es and \ed within character classes.
+Also, \en, \er, \ef, \et and \eNNN have their normal interpretations.
+Within character classes \eb represents backspace rather than a word boundary.
+Alternatives may be separated by |.
+The bracketing construct \|(\ .\|.\|.\ \|) may also be used, in which case \e<digit>
+matches the digit'th substring.
+(Outside of the pattern, always use $ instead of \e in front of the digit.
+The scope of $<digit> (and $\`, $& and $\')
+extends to the end of the enclosing BLOCK or eval string, or to
+the next pattern match with subexpressions.
+The \e<digit> notation sometimes works outside the current pattern, but should
+not be relied upon.)
+You may have as many parentheses as you wish. If you have more than 9
+substrings, the variables $10, $11, ... refer to the corresponding
+substring. Within the pattern, \e10, \e11,
+etc. refer back to substrings if there have been at least that many left parens
+before the backreference. Otherwise (for backward compatibilty) \e10
+is the same as \e010, a backspace,
+and \e11 the same as \e011, a tab.
+And so on.
+(\e1 through \e9 are always backreferences.)
+.PP
+$+ returns whatever the last bracket match matched.
+$& returns the entire matched string.
+($0 used to return the same thing, but not any more.)
+$\` returns everything before the matched string.
+$\' returns everything after the matched string.
+Examples:
+.nf
+
+ s/\|^\|([^ \|]*\|) \|*([^ \|]*\|)\|/\|$2 $1\|/; # swap first two words
+
+.ne 5
+ if (/\|Time: \|(.\|.\|):\|(.\|.\|):\|(.\|.\|)\|/\|) {
+ $hours = $1;
+ $minutes = $2;
+ $seconds = $3;
+ }
+
+.fi
+By default, the ^ character is only guaranteed to match at the beginning
+of the string,
+the $ character only at the end (or before the newline at the end)
+and
+.I perl
+does certain optimizations with the assumption that the string contains
+only one line.
+The behavior of ^ and $ on embedded newlines will be inconsistent.
+You may, however, wish to treat a string as a multi-line buffer, such that
+the ^ will match after any newline within the string, and $ will match
+before any newline.
+At the cost of a little more overhead, you can do this by setting the variable
+$* to 1.
+Setting it back to 0 makes
+.I perl
+revert to its old behavior.
+.PP
+To facilitate multi-line substitutions, the . character never matches a newline
+(even when $* is 0).
+In particular, the following leaves a newline on the $_ string:
+.nf
+
+ $_ = <STDIN>;
+ s/.*(some_string).*/$1/;
+
+If the newline is unwanted, try one of
+
+ s/.*(some_string).*\en/$1/;
+ s/.*(some_string)[^\e000]*/$1/;
+ s/.*(some_string)(.|\en)*/$1/;
+ chop; s/.*(some_string).*/$1/;
+ /(some_string)/ && ($_ = $1);
+
+.fi
+Any item of a regular expression may be followed with digits in curly brackets
+of the form {n,m}, where n gives the minimum number of times to match the item
+and m gives the maximum.
+The form {n} is equivalent to {n,n} and matches exactly n times.
+The form {n,} matches n or more times.
+(If a curly bracket occurs in any other context, it is treated as a regular
+character.)
+The * modifier is equivalent to {0,}, the + modifier to {1,} and the ? modifier
+to {0,1}.
+There is no limit to the size of n or m, but large numbers will chew up
+more memory.
+.Sp
+You will note that all backslashed metacharacters in
+.I perl
+are alphanumeric,
+such as \eb, \ew, \en.
+Unlike some other regular expression languages, there are no backslashed
+symbols that aren't alphanumeric.
+So anything that looks like \e\e, \e(, \e), \e<, \e>, \e{, or \e} is always
+interpreted as a literal character, not a metacharacter.
+This makes it simple to quote a string that you want to use for a pattern
+but that you are afraid might contain metacharacters.
+Simply quote all the non-alphanumeric characters:
+.nf
+
+ $pattern =~ s/(\eW)/\e\e$1/g;
+
+.fi
+.Sh "Formats"
+Output record formats for use with the
+.I write
+operator may declared as follows:
+.nf
+
+.ne 3
+ format NAME =
+ FORMLIST
+ .
+
+.fi
+If name is omitted, format \*(L"STDOUT\*(R" is defined.
+FORMLIST consists of a sequence of lines, each of which may be of one of three
+types:
+.Ip 1. 4
+A comment.
+.Ip 2. 4
+A \*(L"picture\*(R" line giving the format for one output line.
+.Ip 3. 4
+An argument line supplying values to plug into a picture line.
+.PP
+Picture lines are printed exactly as they look, except for certain fields
+that substitute values into the line.
+Each picture field starts with either @ or ^.
+The @ field (not to be confused with the array marker @) is the normal
+case; ^ fields are used
+to do rudimentary multi-line text block filling.
+The length of the field is supplied by padding out the field
+with multiple <, >, or | characters to specify, respectively, left justification,
+right justification, or centering.
+As an alternate form of right justification,
+you may also use # characters (with an optional .) to specify a numeric field.
+(Use of ^ instead of @ causes the field to be blanked if undefined.)
+If any of the values supplied for these fields contains a newline, only
+the text up to the newline is printed.
+The special field @* can be used for printing multi-line values.
+It should appear by itself on a line.
+.PP
+The values are specified on the following line, in the same order as
+the picture fields.
+The values should be separated by commas.
+.PP
+Picture fields that begin with ^ rather than @ are treated specially.
+The value supplied must be a scalar variable name which contains a text
+string.
+.I Perl
+puts as much text as it can into the field, and then chops off the front
+of the string so that the next time the variable is referenced,
+more of the text can be printed.
+Normally you would use a sequence of fields in a vertical stack to print
+out a block of text.
+If you like, you can end the final field with .\|.\|., which will appear in the
+output if the text was too long to appear in its entirety.
+You can change which characters are legal to break on by changing the
+variable $: to a list of the desired characters.
+.PP
+Since use of ^ fields can produce variable length records if the text to be
+formatted is short, you can suppress blank lines by putting the tilde (~)
+character anywhere in the line.
+(Normally you should put it in the front if possible, for visibility.)
+The tilde will be translated to a space upon output.
+If you put a second tilde contiguous to the first, the line will be repeated
+until all the fields on the line are exhausted.
+(If you use a field of the @ variety, the expression you supply had better
+not give the same value every time forever!)
+.PP
+Examples:
+.nf
+.lg 0
+.cs R 25
+.ft C
+
+.ne 10
+# a report on the /etc/passwd file
+format top =
+\& Passwd File
+Name Login Office Uid Gid Home
+------------------------------------------------------------------
+\&.
+format STDOUT =
+@<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<<
+$name, $login, $office,$uid,$gid, $home
+\&.
+
+.ne 29
+# a report from a bug report form
+format top =
+\& Bug Reports
+@<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>>
+$system, $%, $date
+------------------------------------------------------------------
+\&.
+format STDOUT =
+Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+\& $subject
+Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+\& $index, $description
+Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+\& $priority, $date, $description
+From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+\& $from, $description
+Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+\& $programmer, $description
+\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+\& $description
+\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+\& $description
+\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+\& $description
+\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+\& $description
+\&~ ^<<<<<<<<<<<<<<<<<<<<<<<...
+\& $description
+\&.
+
+.ft R
+.cs R
+.lg
+.fi
+It is possible to intermix prints with writes on the same output channel,
+but you'll have to handle $\- (lines left on the page) yourself.
+.PP
+If you are printing lots of fields that are usually blank, you should consider
+using the reset operator between records.
+Not only is it more efficient, but it can prevent the bug of adding another
+field and forgetting to zero it.
+.Sh "Interprocess Communication"
+The IPC facilities of perl are built on the Berkeley socket mechanism.
+If you don't have sockets, you can ignore this section.
+The calls have the same names as the corresponding system calls,
+but the arguments tend to differ, for two reasons.
+First, perl file handles work differently than C file descriptors.
+Second, perl already knows the length of its strings, so you don't need
+to pass that information.
+Here is a sample client (untested):
+.nf
+
+ ($them,$port) = @ARGV;
+ $port = 2345 unless $port;
+ $them = 'localhost' unless $them;
+
+ $SIG{'INT'} = 'dokill';
+ sub dokill { kill 9,$child if $child; }
+
+ require 'sys/socket.ph';
+
+ $sockaddr = 'S n a4 x8';
+ chop($hostname = `hostname`);
+
+ ($name, $aliases, $proto) = getprotobyname('tcp');
+ ($name, $aliases, $port) = getservbyname($port, 'tcp')
+ unless $port =~ /^\ed+$/;
+.ie t \{\
+ ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname);
+'br\}
+.el \{\
+ ($name, $aliases, $type, $len, $thisaddr) =
+ gethostbyname($hostname);
+'br\}
+ ($name, $aliases, $type, $len, $thataddr) = gethostbyname($them);
+
+ $this = pack($sockaddr, &AF_INET, 0, $thisaddr);
+ $that = pack($sockaddr, &AF_INET, $port, $thataddr);
+
+ socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!";
+ bind(S, $this) || die "bind: $!";
+ connect(S, $that) || die "connect: $!";
+
+ select(S); $| = 1; select(stdout);
+
+ if ($child = fork) {
+ while (<>) {
+ print S;
+ }
+ sleep 3;
+ do dokill();
+ }
+ else {
+ while (<S>) {
+ print;
+ }
+ }
+
+.fi
+And here's a server:
+.nf
+
+ ($port) = @ARGV;
+ $port = 2345 unless $port;
+
+ require 'sys/socket.ph';
+
+ $sockaddr = 'S n a4 x8';
+
+ ($name, $aliases, $proto) = getprotobyname('tcp');
+ ($name, $aliases, $port) = getservbyname($port, 'tcp')
+ unless $port =~ /^\ed+$/;
+
+ $this = pack($sockaddr, &AF_INET, $port, "\e0\e0\e0\e0");
+
+ select(NS); $| = 1; select(stdout);
+
+ socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!";
+ bind(S, $this) || die "bind: $!";
+ listen(S, 5) || die "connect: $!";
+
+ select(S); $| = 1; select(stdout);
+
+ for (;;) {
+ print "Listening again\en";
+ ($addr = accept(NS,S)) || die $!;
+ print "accept ok\en";
+
+ ($af,$port,$inetaddr) = unpack($sockaddr,$addr);
+ @inetaddr = unpack('C4',$inetaddr);
+ print "$af $port @inetaddr\en";
+
+ while (<NS>) {
+ print;
+ print NS;
+ }
+ }
+
+.fi
+.Sh "Predefined Names"
+The following names have special meaning to
+.IR perl .
+I could have used alphabetic symbols for some of these, but I didn't want
+to take the chance that someone would say reset \*(L"a\-zA\-Z\*(R" and wipe them all
+out.
+You'll just have to suffer along with these silly symbols.
+Most of them have reasonable mnemonics, or analogues in one of the shells.
+.Ip $_ 8
+The default input and pattern-searching space.
+The following pairs are equivalent:
+.nf
+
+.ne 2
+ while (<>) {\|.\|.\|. # only equivalent in while!
+ while ($_ = <>) {\|.\|.\|.
+
+.ne 2
+ /\|^Subject:/
+ $_ \|=~ \|/\|^Subject:/
+
+.ne 2
+ y/a\-z/A\-Z/
+ $_ =~ y/a\-z/A\-Z/
+
+.ne 2
+ chop
+ chop($_)
+
+.fi
+(Mnemonic: underline is understood in certain operations.)
+.Ip $. 8
+The current input line number of the last filehandle that was read.
+Readonly.
+Remember that only an explicit close on the filehandle resets the line number.
+Since <> never does an explicit close, line numbers increase across ARGV files
+(but see examples under eof).
+(Mnemonic: many programs use . to mean the current line number.)
+.Ip $/ 8
+The input record separator, newline by default.
+Works like
+.IR awk 's
+RS variable, including treating blank lines as delimiters
+if set to the null string.
+You may set it to a multicharacter string to match a multi-character
+delimiter.
+(Mnemonic: / is used to delimit line boundaries when quoting poetry.)
+.Ip $, 8
+The output field separator for the print operator.
+Ordinarily the print operator simply prints out the comma separated fields
+you specify.
+In order to get behavior more like
+.IR awk ,
+set this variable as you would set
+.IR awk 's
+OFS variable to specify what is printed between fields.
+(Mnemonic: what is printed when there is a , in your print statement.)
+.Ip $"" 8
+This is like $, except that it applies to array values interpolated into
+a double-quoted string (or similar interpreted string).
+Default is a space.
+(Mnemonic: obvious, I think.)
+.Ip $\e 8
+The output record separator for the print operator.
+Ordinarily the print operator simply prints out the comma separated fields
+you specify, with no trailing newline or record separator assumed.
+In order to get behavior more like
+.IR awk ,
+set this variable as you would set
+.IR awk 's
+ORS variable to specify what is printed at the end of the print.
+(Mnemonic: you set $\e instead of adding \en at the end of the print.
+Also, it's just like /, but it's what you get \*(L"back\*(R" from
+.IR perl .)
+.Ip $# 8
+The output format for printed numbers.
+This variable is a half-hearted attempt to emulate
+.IR awk 's
+OFMT variable.
+There are times, however, when
+.I awk
+and
+.I perl
+have differing notions of what
+is in fact numeric.
+Also, the initial value is %.20g rather than %.6g, so you need to set $#
+explicitly to get
+.IR awk 's
+value.
+(Mnemonic: # is the number sign.)
+.Ip $% 8
+The current page number of the currently selected output channel.
+(Mnemonic: % is page number in nroff.)
+.Ip $= 8
+The current page length (printable lines) of the currently selected output
+channel.
+Default is 60.
+(Mnemonic: = has horizontal lines.)
+.Ip $\- 8
+The number of lines left on the page of the currently selected output channel.
+(Mnemonic: lines_on_page \- lines_printed.)
+.Ip $~ 8
+The name of the current report format for the currently selected output
+channel.
+(Mnemonic: brother to $^.)
+.Ip $^ 8
+The name of the current top-of-page format for the currently selected output
+channel.
+(Mnemonic: points to top of page.)
+.Ip $| 8
+If set to nonzero, forces a flush after every write or print on the currently
+selected output channel.
+Default is 0.
+Note that
+.I STDOUT
+will typically be line buffered if output is to the
+terminal and block buffered otherwise.
+Setting this variable is useful primarily when you are outputting to a pipe,
+such as when you are running a
+.I perl
+script under rsh and want to see the
+output as it's happening.
+(Mnemonic: when you want your pipes to be piping hot.)
+.Ip $$ 8
+The process number of the
+.I perl
+running this script.
+(Mnemonic: same as shells.)
+.Ip $? 8
+The status returned by the last pipe close, backtick (\`\`) command or
+.I system
+operator.
+Note that this is the status word returned by the wait() system
+call, so the exit value of the subprocess is actually ($? >> 8).
+$? & 255 gives which signal, if any, the process died from, and whether
+there was a core dump.
+(Mnemonic: similar to sh and ksh.)
+.Ip $& 8 4
+The string matched by the last pattern match (not counting any matches hidden
+within a BLOCK or eval enclosed by the current BLOCK).
+(Mnemonic: like & in some editors.)
+.Ip $\` 8 4
+The string preceding whatever was matched by the last pattern match
+(not counting any matches hidden within a BLOCK or eval enclosed by the current
+BLOCK).
+(Mnemonic: \` often precedes a quoted string.)
+.Ip $\' 8 4
+The string following whatever was matched by the last pattern match
+(not counting any matches hidden within a BLOCK or eval enclosed by the current
+BLOCK).
+(Mnemonic: \' often follows a quoted string.)
+Example:
+.nf
+
+.ne 3
+ $_ = \'abcdefghi\';
+ /def/;
+ print "$\`:$&:$\'\en"; # prints abc:def:ghi
+
+.fi
+.Ip $+ 8 4
+The last bracket matched by the last search pattern.
+This is useful if you don't know which of a set of alternative patterns
+matched.
+For example:
+.nf
+
+ /Version: \|(.*\|)|Revision: \|(.*\|)\|/ \|&& \|($rev = $+);
+
+.fi
+(Mnemonic: be positive and forward looking.)
+.Ip $* 8 2
+Set to 1 to do multiline matching within a string, 0 to tell
+.I perl
+that it can assume that strings contain a single line, for the purpose
+of optimizing pattern matches.
+Pattern matches on strings containing multiple newlines can produce confusing
+results when $* is 0.
+Default is 0.
+(Mnemonic: * matches multiple things.)
+Note that this variable only influences the interpretation of ^ and $.
+A literal newline can be searched for even when $* == 0.
+.Ip $0 8
+Contains the name of the file containing the
+.I perl
+script being executed.
+Assigning to $0 modifies the argument area that the ps(1) program sees.
+(Mnemonic: same as sh and ksh.)
+.Ip $<digit> 8
+Contains the subpattern from the corresponding set of parentheses in the last
+pattern matched, not counting patterns matched in nested blocks that have
+been exited already.
+(Mnemonic: like \edigit.)
+.Ip $[ 8 2
+The index of the first element in an array, and of the first character in
+a substring.
+Default is 0, but you could set it to 1 to make
+.I perl
+behave more like
+.I awk
+(or Fortran)
+when subscripting and when evaluating the index() and substr() functions.
+(Mnemonic: [ begins subscripts.)
+.Ip $] 8 2
+The string printed out when you say \*(L"perl -v\*(R".
+It can be used to determine at the beginning of a script whether the perl
+interpreter executing the script is in the right range of versions.
+If used in a numeric context, returns the version + patchlevel / 1000.
+Example:
+.nf
+
+.ne 8
+ # see if getc is available
+ ($version,$patchlevel) =
+ $] =~ /(\ed+\e.\ed+).*\enPatch level: (\ed+)/;
+ print STDERR "(No filename completion available.)\en"
+ if $version * 1000 + $patchlevel < 2016;
+
+or, used numerically,
+
+ warn "No checksumming!\en" if $] < 3.019;
+
+.fi
+(Mnemonic: Is this version of perl in the right bracket?)
+.Ip $; 8 2
+The subscript separator for multi-dimensional array emulation.
+If you refer to an associative array element as
+.nf
+ $foo{$a,$b,$c}
+
+it really means
+
+ $foo{join($;, $a, $b, $c)}
+
+But don't put
+
+ @foo{$a,$b,$c} # a slice\*(--note the @
+
+which means
+
+ ($foo{$a},$foo{$b},$foo{$c})
+
+.fi
+Default is "\e034", the same as SUBSEP in
+.IR awk .
+Note that if your keys contain binary data there might not be any safe
+value for $;.
+(Mnemonic: comma (the syntactic subscript separator) is a semi-semicolon.
+Yeah, I know, it's pretty lame, but $, is already taken for something more
+important.)
+.Ip $! 8 2
+If used in a numeric context, yields the current value of errno, with all the
+usual caveats.
+(This means that you shouldn't depend on the value of $! to be anything
+in particular unless you've gotten a specific error return indicating a
+system error.)
+If used in a string context, yields the corresponding system error string.
+You can assign to $! in order to set errno
+if, for instance, you want $! to return the string for error n, or you want
+to set the exit value for the die operator.
+(Mnemonic: What just went bang?)
+.Ip $@ 8 2
+The perl syntax error message from the last eval command.
+If null, the last eval parsed and executed correctly (although the operations
+you invoked may have failed in the normal fashion).
+(Mnemonic: Where was the syntax error \*(L"at\*(R"?)
+.Ip $< 8 2
+The real uid of this process.
+(Mnemonic: it's the uid you came FROM, if you're running setuid.)
+.Ip $> 8 2
+The effective uid of this process.
+Example:
+.nf
+
+.ne 2
+ $< = $>; # set real uid to the effective uid
+ ($<,$>) = ($>,$<); # swap real and effective uid
+
+.fi
+(Mnemonic: it's the uid you went TO, if you're running setuid.)
+Note: $< and $> can only be swapped on machines supporting setreuid().
+.Ip $( 8 2
+The real gid of this process.
+If you are on a machine that supports membership in multiple groups
+simultaneously, gives a space separated list of groups you are in.
+The first number is the one returned by getgid(), and the subsequent ones
+by getgroups(), one of which may be the same as the first number.
+(Mnemonic: parentheses are used to GROUP things.
+The real gid is the group you LEFT, if you're running setgid.)
+.Ip $) 8 2
+The effective gid of this process.
+If you are on a machine that supports membership in multiple groups
+simultaneously, gives a space separated list of groups you are in.
+The first number is the one returned by getegid(), and the subsequent ones
+by getgroups(), one of which may be the same as the first number.
+(Mnemonic: parentheses are used to GROUP things.
+The effective gid is the group that's RIGHT for you, if you're running setgid.)
+.Sp
+Note: $<, $>, $( and $) can only be set on machines that support the
+corresponding set[re][ug]id() routine.
+$( and $) can only be swapped on machines supporting setregid().
+.Ip $: 8 2
+The current set of characters after which a string may be broken to
+fill continuation fields (starting with ^) in a format.
+Default is "\ \en-", to break on whitespace or hyphens.
+(Mnemonic: a \*(L"colon\*(R" in poetry is a part of a line.)
+.Ip $^D 8 2
+The current value of the debugging flags.
+(Mnemonic: value of
+.B \-D
+switch.)
+.Ip $^I 8 2
+The current value of the inplace-edit extension.
+Use undef to disable inplace editing.
+(Mnemonic: value of
+.B \-i
+switch.)
+.Ip $^P 8 2
+The name that Perl itself was invoked as, from argv[0].
+.Ip $^T 8 2
+The time at which the script began running, in seconds since the epoch.
+The values returned by the
+.B \-M ,
+.B \-A
+and
+.B \-C
+filetests are based on this value.
+.Ip $^W 8 2
+The current value of the warning switch.
+(Mnemonic: related to the
+.B \-w
+switch.)
+.Ip $ARGV 8 3
+contains the name of the current file when reading from <>.
+.Ip @ARGV 8 3
+The array ARGV contains the command line arguments intended for the script.
+Note that $#ARGV is the generally number of arguments minus one, since
+$ARGV[0] is the first argument, NOT the command name.
+See $0 for the command name.
+.Ip @INC 8 3
+The array INC contains the list of places to look for
+.I perl
+scripts to be
+evaluated by the \*(L"do EXPR\*(R" command or the \*(L"require\*(R" command.
+It initially consists of the arguments to any
+.B \-I
+command line switches, followed
+by the default
+.I perl
+library, probably \*(L"/usr/local/lib/perl\*(R",
+followed by \*(L".\*(R", to represent the current directory.
+.Ip %INC 8 3
+The associative array INC contains entries for each filename that has
+been included via \*(L"do\*(R" or \*(L"require\*(R".
+The key is the filename you specified, and the value is the location of
+the file actually found.
+The \*(L"require\*(R" command uses this array to determine whether
+a given file has already been included.
+.Ip $ENV{expr} 8 2
+The associative array ENV contains your current environment.
+Setting a value in ENV changes the environment for child processes.
+.Ip $SIG{expr} 8 2
+The associative array SIG is used to set signal handlers for various signals.
+Example:
+.nf
+
+.ne 12
+ sub handler { # 1st argument is signal name
+ local($sig) = @_;
+ print "Caught a SIG$sig\-\|\-shutting down\en";
+ close(LOG);
+ exit(0);
+ }
+
+ $SIG{\'INT\'} = \'handler\';
+ $SIG{\'QUIT\'} = \'handler\';
+ .\|.\|.
+ $SIG{\'INT\'} = \'DEFAULT\'; # restore default action
+ $SIG{\'QUIT\'} = \'IGNORE\'; # ignore SIGQUIT
+
+.fi
+The SIG array only contains values for the signals actually set within
+the perl script.
+.Sh "Packages"
+Perl provides a mechanism for alternate namespaces to protect packages from
+stomping on each others variables.
+By default, a perl script starts compiling into the package known as \*(L"main\*(R".
+By use of the
+.I package
+declaration, you can switch namespaces.
+The scope of the package declaration is from the declaration itself to the end
+of the enclosing block (the same scope as the local() operator).
+Typically it would be the first declaration in a file to be included by
+the \*(L"require\*(R" operator.
+You can switch into a package in more than one place; it merely influences
+which symbol table is used by the compiler for the rest of that block.
+You can refer to variables and filehandles in other packages by prefixing
+the identifier with the package name and a single quote.
+If the package name is null, the \*(L"main\*(R" package as assumed.
+.PP
+Only identifiers starting with letters are stored in the packages symbol
+table.
+All other symbols are kept in package \*(L"main\*(R".
+In addition, the identifiers STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV, INC
+and SIG are forced to be in package \*(L"main\*(R", even when used for
+other purposes than their built-in one.
+Note also that, if you have a package called \*(L"m\*(R", \*(L"s\*(R"
+or \*(L"y\*(R", the you can't use the qualified form of an identifier since it
+will be interpreted instead as a pattern match, a substitution
+or a translation.
+.PP
+Eval'ed strings are compiled in the package in which the eval was compiled
+in.
+(Assignments to $SIG{}, however, assume the signal handler specified is in the
+main package.
+Qualify the signal handler name if you wish to have a signal handler in
+a package.)
+For an example, examine perldb.pl in the perl library.
+It initially switches to the DB package so that the debugger doesn't interfere
+with variables in the script you are trying to debug.
+At various points, however, it temporarily switches back to the main package
+to evaluate various expressions in the context of the main package.
+.PP
+The symbol table for a package happens to be stored in the associative array
+of that name prepended with an underscore.
+The value in each entry of the associative array is
+what you are referring to when you use the *name notation.
+In fact, the following have the same effect (in package main, anyway),
+though the first is more
+efficient because it does the symbol table lookups at compile time:
+.nf
+
+.ne 2
+ local(*foo) = *bar;
+ local($_main{'foo'}) = $_main{'bar'};
+
+.fi
+You can use this to print out all the variables in a package, for instance.
+Here is dumpvar.pl from the perl library:
+.nf
+.ne 11
+ package dumpvar;
+
+ sub main'dumpvar {
+ \& ($package) = @_;
+ \& local(*stab) = eval("*_$package");
+ \& while (($key,$val) = each(%stab)) {
+ \& {
+ \& local(*entry) = $val;
+ \& if (defined $entry) {
+ \& print "\e$$key = '$entry'\en";
+ \& }
+.ne 7
+ \& if (defined @entry) {
+ \& print "\e@$key = (\en";
+ \& foreach $num ($[ .. $#entry) {
+ \& print " $num\et'",$entry[$num],"'\en";
+ \& }
+ \& print ")\en";
+ \& }
+.ne 10
+ \& if ($key ne "_$package" && defined %entry) {
+ \& print "\e%$key = (\en";
+ \& foreach $key (sort keys(%entry)) {
+ \& print " $key\et'",$entry{$key},"'\en";
+ \& }
+ \& print ")\en";
+ \& }
+ \& }
+ \& }
+ }
+
+.fi
+Note that, even though the subroutine is compiled in package dumpvar, the
+name of the subroutine is qualified so that its name is inserted into package
+\*(L"main\*(R".
+.Sh "Style"
+Each programmer will, of course, have his or her own preferences in regards
+to formatting, but there are some general guidelines that will make your
+programs easier to read.
+.Ip 1. 4 4
+Just because you CAN do something a particular way doesn't mean that
+you SHOULD do it that way.
+.I Perl
+is designed to give you several ways to do anything, so consider picking
+the most readable one.
+For instance
+
+ open(FOO,$foo) || die "Can't open $foo: $!";
+
+is better than
+
+ die "Can't open $foo: $!" unless open(FOO,$foo);
+
+because the second way hides the main point of the statement in a
+modifier.
+On the other hand
+
+ print "Starting analysis\en" if $verbose;
+
+is better than
+
+ $verbose && print "Starting analysis\en";
+
+since the main point isn't whether the user typed -v or not.
+.Sp
+Similarly, just because an operator lets you assume default arguments
+doesn't mean that you have to make use of the defaults.
+The defaults are there for lazy systems programmers writing one-shot
+programs.
+If you want your program to be readable, consider supplying the argument.
+.Sp
+Along the same lines, just because you
+.I can
+omit parentheses in many places doesn't mean that you ought to:
+.nf
+
+ return print reverse sort num values array;
+ return print(reverse(sort num (values(%array))));
+
+.fi
+When in doubt, parenthesize.
+At the very least it will let some poor schmuck bounce on the % key in vi.
+.Sp
+Even if you aren't in doubt, consider the mental welfare of the person who
+has to maintain the code after you, and who will probably put parens in
+the wrong place.
+.Ip 2. 4 4
+Don't go through silly contortions to exit a loop at the top or the
+bottom, when
+.I perl
+provides the "last" operator so you can exit in the middle.
+Just outdent it a little to make it more visible:
+.nf
+
+.ne 7
+ line:
+ for (;;) {
+ statements;
+ last line if $foo;
+ next line if /^#/;
+ statements;
+ }
+
+.fi
+.Ip 3. 4 4
+Don't be afraid to use loop labels\*(--they're there to enhance readability as
+well as to allow multi-level loop breaks.
+See last example.
+.Ip 4. 4 4
+For portability, when using features that may not be implemented on every
+machine, test the construct in an eval to see if it fails.
+If you know what version or patchlevel a particular feature was implemented,
+you can test $] to see if it will be there.
+.Ip 5. 4 4
+Choose mnemonic identifiers.
+.Ip 6. 4 4
+Be consistent.
+.Sh "Debugging"
+If you invoke
+.I perl
+with a
+.B \-d
+switch, your script will be run under a debugging monitor.
+It will halt before the first executable statement and ask you for a
+command, such as:
+.Ip "h" 12 4
+Prints out a help message.
+.Ip "T" 12 4
+Stack trace.
+.Ip "s" 12 4
+Single step.
+Executes until it reaches the beginning of another statement.
+.Ip "n" 12 4
+Next.
+Executes over subroutine calls, until it reaches the beginning of the
+next statement.
+.Ip "f" 12 4
+Finish.
+Executes statements until it has finished the current subroutine.
+.Ip "c" 12 4
+Continue.
+Executes until the next breakpoint is reached.
+.Ip "c line" 12 4
+Continue to the specified line.
+Inserts a one-time-only breakpoint at the specified line.
+.Ip "<CR>" 12 4
+Repeat last n or s.
+.Ip "l min+incr" 12 4
+List incr+1 lines starting at min.
+If min is omitted, starts where last listing left off.
+If incr is omitted, previous value of incr is used.
+.Ip "l min-max" 12 4
+List lines in the indicated range.
+.Ip "l line" 12 4
+List just the indicated line.
+.Ip "l" 12 4
+List next window.
+.Ip "-" 12 4
+List previous window.
+.Ip "w line" 12 4
+List window around line.
+.Ip "l subname" 12 4
+List subroutine.
+If it's a long subroutine it just lists the beginning.
+Use \*(L"l\*(R" to list more.
+.Ip "/pattern/" 12 4
+Regular expression search forward for pattern; the final / is optional.
+.Ip "?pattern?" 12 4
+Regular expression search backward for pattern; the final ? is optional.
+.Ip "L" 12 4
+List lines that have breakpoints or actions.
+.Ip "S" 12 4
+Lists the names of all subroutines.
+.Ip "t" 12 4
+Toggle trace mode on or off.
+.Ip "b line condition" 12 4
+Set a breakpoint.
+If line is omitted, sets a breakpoint on the
+line that is about to be executed.
+If a condition is specified, it is evaluated each time the statement is
+reached and a breakpoint is taken only if the condition is true.
+Breakpoints may only be set on lines that begin an executable statement.
+.Ip "b subname condition" 12 4
+Set breakpoint at first executable line of subroutine.
+.Ip "d line" 12 4
+Delete breakpoint.
+If line is omitted, deletes the breakpoint on the
+line that is about to be executed.
+.Ip "D" 12 4
+Delete all breakpoints.
+.Ip "a line command" 12 4
+Set an action for line.
+A multi-line command may be entered by backslashing the newlines.
+.Ip "A" 12 4
+Delete all line actions.
+.Ip "< command" 12 4
+Set an action to happen before every debugger prompt.
+A multi-line command may be entered by backslashing the newlines.
+.Ip "> command" 12 4
+Set an action to happen after the prompt when you've just given a command
+to return to executing the script.
+A multi-line command may be entered by backslashing the newlines.
+.Ip "V package" 12 4
+List all variables in package.
+Default is main package.
+.Ip "! number" 12 4
+Redo a debugging command.
+If number is omitted, redoes the previous command.
+.Ip "! -number" 12 4
+Redo the command that was that many commands ago.
+.Ip "H -number" 12 4
+Display last n commands.
+Only commands longer than one character are listed.
+If number is omitted, lists them all.
+.Ip "q or ^D" 12 4
+Quit.
+.Ip "command" 12 4
+Execute command as a perl statement.
+A missing semicolon will be supplied.
+.Ip "p expr" 12 4
+Same as \*(L"print DB'OUT expr\*(R".
+The DB'OUT filehandle is opened to /dev/tty, regardless of where STDOUT
+may be redirected to.
+.PP
+If you want to modify the debugger, copy perldb.pl from the perl library
+to your current directory and modify it as necessary.
+(You'll also have to put -I. on your command line.)
+You can do some customization by setting up a .perldb file which contains
+initialization code.
+For instance, you could make aliases like these:
+.nf
+
+ $DB'alias{'len'} = 's/^len(.*)/p length($1)/';
+ $DB'alias{'stop'} = 's/^stop (at|in)/b/';
+ $DB'alias{'.'} =
+ 's/^\e./p "\e$DB\e'sub(\e$DB\e'line):\et",\e$DB\e'line[\e$DB\e'line]/';
+
+.fi
+.Sh "Setuid Scripts"
+.I Perl
+is designed to make it easy to write secure setuid and setgid scripts.
+Unlike shells, which are based on multiple substitution passes on each line
+of the script,
+.I perl
+uses a more conventional evaluation scheme with fewer hidden \*(L"gotchas\*(R".
+Additionally, since the language has more built-in functionality, it
+has to rely less upon external (and possibly untrustworthy) programs to
+accomplish its purposes.
+.PP
+In an unpatched 4.2 or 4.3bsd kernel, setuid scripts are intrinsically
+insecure, but this kernel feature can be disabled.
+If it is,
+.I perl
+can emulate the setuid and setgid mechanism when it notices the otherwise
+useless setuid/gid bits on perl scripts.
+If the kernel feature isn't disabled,
+.I perl
+will complain loudly that your setuid script is insecure.
+You'll need to either disable the kernel setuid script feature, or put
+a C wrapper around the script.
+.PP
+When perl is executing a setuid script, it takes special precautions to
+prevent you from falling into any obvious traps.
+(In some ways, a perl script is more secure than the corresponding
+C program.)
+Any command line argument, environment variable, or input is marked as
+\*(L"tainted\*(R", and may not be used, directly or indirectly, in any
+command that invokes a subshell, or in any command that modifies files,
+directories or processes.
+Any variable that is set within an expression that has previously referenced
+a tainted value also becomes tainted (even if it is logically impossible
+for the tainted value to influence the variable).
+For example:
+.nf
+
+.ne 5
+ $foo = shift; # $foo is tainted
+ $bar = $foo,\'bar\'; # $bar is also tainted
+ $xxx = <>; # Tainted
+ $path = $ENV{\'PATH\'}; # Tainted, but see below
+ $abc = \'abc\'; # Not tainted
+
+.ne 4
+ system "echo $foo"; # Insecure
+ system "/bin/echo", $foo; # Secure (doesn't use sh)
+ system "echo $bar"; # Insecure
+ system "echo $abc"; # Insecure until PATH set
+
+.ne 5
+ $ENV{\'PATH\'} = \'/bin:/usr/bin\';
+ $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\';
+
+ $path = $ENV{\'PATH\'}; # Not tainted
+ system "echo $abc"; # Is secure now!
+
+.ne 5
+ open(FOO,"$foo"); # OK
+ open(FOO,">$foo"); # Not OK
+
+ open(FOO,"echo $foo|"); # Not OK, but...
+ open(FOO,"-|") || exec \'echo\', $foo; # OK
+
+ $zzz = `echo $foo`; # Insecure, zzz tainted
+
+ unlink $abc,$foo; # Insecure
+ umask $foo; # Insecure
+
+.ne 3
+ exec "echo $foo"; # Insecure
+ exec "echo", $foo; # Secure (doesn't use sh)
+ exec "sh", \'-c\', $foo; # Considered secure, alas
+
+.fi
+The taintedness is associated with each scalar value, so some elements
+of an array can be tainted, and others not.
+.PP
+If you try to do something insecure, you will get a fatal error saying
+something like \*(L"Insecure dependency\*(R" or \*(L"Insecure PATH\*(R".
+Note that you can still write an insecure system call or exec,
+but only by explicitly doing something like the last example above.
+You can also bypass the tainting mechanism by referencing
+subpatterns\*(--\c
+.I perl
+presumes that if you reference a substring using $1, $2, etc, you knew
+what you were doing when you wrote the pattern:
+.nf
+
+ $ARGV[0] =~ /^\-P(\ew+)$/;
+ $printer = $1; # Not tainted
+
+.fi
+This is fairly secure since \ew+ doesn't match shell metacharacters.
+Use of .+ would have been insecure, but
+.I perl
+doesn't check for that, so you must be careful with your patterns.
+This is the ONLY mechanism for untainting user supplied filenames if you
+want to do file operations on them (unless you make $> equal to $<).
+.PP
+It's also possible to get into trouble with other operations that don't care
+whether they use tainted values.
+Make judicious use of the file tests in dealing with any user-supplied
+filenames.
+When possible, do opens and such after setting $> = $<.
+.I Perl
+doesn't prevent you from opening tainted filenames for reading, so be
+careful what you print out.
+The tainting mechanism is intended to prevent stupid mistakes, not to remove
+the need for thought.
+.SH ENVIRONMENT
+.I Perl
+uses PATH in executing subprocesses, and in finding the script if \-S
+is used.
+HOME or LOGDIR are used if chdir has no argument.
+.PP
+Apart from these,
+.I perl
+uses no environment variables, except to make them available
+to the script being executed, and to child processes.
+However, scripts running setuid would do well to execute the following lines
+before doing anything else, just to keep people honest:
+.nf
+
+.ne 3
+ $ENV{\'PATH\'} = \'/bin:/usr/bin\'; # or whatever you need
+ $ENV{\'SHELL\'} = \'/bin/sh\' if $ENV{\'SHELL\'} ne \'\';
+ $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\';
+
+.fi
+.SH AUTHOR
+Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
+.br
+MS-DOS port by Diomidis Spinellis <dds@cc.ic.ac.uk>
+.SH FILES
+/tmp/perl\-eXXXXXX temporary file for
+.B \-e
+commands.
+.SH SEE ALSO
+a2p awk to perl translator
+.br
+s2p sed to perl translator
+.SH DIAGNOSTICS
+Compilation errors will tell you the line number of the error, with an
+indication of the next token or token type that was to be examined.
+(In the case of a script passed to
+.I perl
+via
+.B \-e
+switches, each
+.B \-e
+is counted as one line.)
+.PP
+Setuid scripts have additional constraints that can produce error messages
+such as \*(L"Insecure dependency\*(R".
+See the section on setuid scripts.
+.SH TRAPS
+Accustomed
+.IR awk
+users should take special note of the following:
+.Ip * 4 2
+Semicolons are required after all simple statements in
+.IR perl .
+Newline
+is not a statement delimiter.
+.Ip * 4 2
+Curly brackets are required on ifs and whiles.
+.Ip * 4 2
+Variables begin with $ or @ in
+.IR perl .
+.Ip * 4 2
+Arrays index from 0 unless you set $[.
+Likewise string positions in substr() and index().
+.Ip * 4 2
+You have to decide whether your array has numeric or string indices.
+.Ip * 4 2
+Associative array values do not spring into existence upon mere reference.
+.Ip * 4 2
+You have to decide whether you want to use string or numeric comparisons.
+.Ip * 4 2
+Reading an input line does not split it for you. You get to split it yourself
+to an array.
+And the
+.I split
+operator has different arguments.
+.Ip * 4 2
+The current input line is normally in $_, not $0.
+It generally does not have the newline stripped.
+($0 is the name of the program executed.)
+.Ip * 4 2
+$<digit> does not refer to fields\*(--it refers to substrings matched by the last
+match pattern.
+.Ip * 4 2
+The
+.I print
+statement does not add field and record separators unless you set
+$, and $\e.
+.Ip * 4 2
+You must open your files before you print to them.
+.Ip * 4 2
+The range operator is \*(L".\|.\*(R", not comma.
+(The comma operator works as in C.)
+.Ip * 4 2
+The match operator is \*(L"=~\*(R", not \*(L"~\*(R".
+(\*(L"~\*(R" is the one's complement operator, as in C.)
+.Ip * 4 2
+The exponentiation operator is \*(L"**\*(R", not \*(L"^\*(R".
+(\*(L"^\*(R" is the XOR operator, as in C.)
+.Ip * 4 2
+The concatenation operator is \*(L".\*(R", not the null string.
+(Using the null string would render \*(L"/pat/ /pat/\*(R" unparsable,
+since the third slash would be interpreted as a division operator\*(--the
+tokener is in fact slightly context sensitive for operators like /, ?, and <.
+And in fact, . itself can be the beginning of a number.)
+.Ip * 4 2
+.IR Next ,
+.I exit
+and
+.I continue
+work differently.
+.Ip * 4 2
+The following variables work differently
+.nf
+
+ Awk \h'|2.5i'Perl
+ ARGC \h'|2.5i'$#ARGV
+ ARGV[0] \h'|2.5i'$0
+ FILENAME\h'|2.5i'$ARGV
+ FNR \h'|2.5i'$. \- something
+ FS \h'|2.5i'(whatever you like)
+ NF \h'|2.5i'$#Fld, or some such
+ NR \h'|2.5i'$.
+ OFMT \h'|2.5i'$#
+ OFS \h'|2.5i'$,
+ ORS \h'|2.5i'$\e
+ RLENGTH \h'|2.5i'length($&)
+ RS \h'|2.5i'$/
+ RSTART \h'|2.5i'length($\`)
+ SUBSEP \h'|2.5i'$;
+
+.fi
+.Ip * 4 2
+When in doubt, run the
+.I awk
+construct through a2p and see what it gives you.
+.PP
+Cerebral C programmers should take note of the following:
+.Ip * 4 2
+Curly brackets are required on ifs and whiles.
+.Ip * 4 2
+You should use \*(L"elsif\*(R" rather than \*(L"else if\*(R"
+.Ip * 4 2
+.I Break
+and
+.I continue
+become
+.I last
+and
+.IR next ,
+respectively.
+.Ip * 4 2
+There's no switch statement.
+.Ip * 4 2
+Variables begin with $ or @ in
+.IR perl .
+.Ip * 4 2
+Printf does not implement *.
+.Ip * 4 2
+Comments begin with #, not /*.
+.Ip * 4 2
+You can't take the address of anything.
+.Ip * 4 2
+ARGV must be capitalized.
+.Ip * 4 2
+The \*(L"system\*(R" calls link, unlink, rename, etc. return nonzero for success, not 0.
+.Ip * 4 2
+Signal handlers deal with signal names, not numbers.
+.PP
+Seasoned
+.I sed
+programmers should take note of the following:
+.Ip * 4 2
+Backreferences in substitutions use $ rather than \e.
+.Ip * 4 2
+The pattern matching metacharacters (, ), and | do not have backslashes in front.
+.Ip * 4 2
+The range operator is .\|. rather than comma.
+.PP
+Sharp shell programmers should take note of the following:
+.Ip * 4 2
+The backtick operator does variable interpretation without regard to the
+presence of single quotes in the command.
+.Ip * 4 2
+The backtick operator does no translation of the return value, unlike csh.
+.Ip * 4 2
+Shells (especially csh) do several levels of substitution on each command line.
+.I Perl
+does substitution only in certain constructs such as double quotes,
+backticks, angle brackets and search patterns.
+.Ip * 4 2
+Shells interpret scripts a little bit at a time.
+.I Perl
+compiles the whole program before executing it.
+.Ip * 4 2
+The arguments are available via @ARGV, not $1, $2, etc.
+.Ip * 4 2
+The environment is not automatically made available as variables.
+.SH ERRATA\0AND\0ADDENDA
+The Perl book,
+.I Programming\0Perl ,
+has the following omissions and goofs.
+.PP
+On page 5, the examples which read
+.nf
+
+ eval "/usr/bin/perl
+
+should read
+
+ eval "exec /usr/bin/perl
+
+.fi
+.PP
+On page 195, the equivalent to the System V sum program only works for
+very small files. To do larger files, use
+.nf
+
+ undef $/;
+ $checksum = unpack("%32C*",<>) % 32767;
+
+.fi
+.PP
+The
+.B \-0
+switch to set the initial value of $/ was added to Perl after the book
+went to press.
+.PP
+The
+.B \-l
+switch now does automatic line ending processing.
+.PP
+The qx// construct is now a synonym for backticks.
+.PP
+$0 may now be assigned to set the argument displayed by
+.I ps (1).
+.PP
+The new @###.## format was omitted accidentally from the description
+on formats.
+.PP
+It wasn't known at press time that s///ee caused multiple evaluations of
+the replacement expression. This is to be construed as a feature.
+.PP
+(LIST) x $count now does array replication.
+.PP
+There is now no limit on the number of parentheses in a regular expression.
+.PP
+In double-quote context, more escapes are supported: \ee, \ea, \ex1b, \ec[,
+\el, \eL, \eu, \eU, \eE. The latter five control up/lower case translation.
+.PP
+The
+.B $/
+variable may now be set to a multi-character delimiter.
+.SH BUGS
+.PP
+.I Perl
+is at the mercy of your machine's definitions of various operations
+such as type casting, atof() and sprintf().
+.PP
+If your stdio requires an seek or eof between reads and writes on a particular
+stream, so does
+.IR perl .
+.PP
+While none of the built-in data types have any arbitrary size limits (apart
+from memory size), there are still a few arbitrary limits:
+a given identifier may not be longer than 255 characters;
+sprintf is limited on many machines to 128 characters per field (unless the format
+specifier is exactly %s);
+and no component of your PATH may be longer than 255 if you use \-S.
+.PP
+.I Perl
+actually stands for Pathologically Eclectic Rubbish Lister, but don't tell
+anyone I said that.
+.rn }` ''
+++ /dev/null
-.rn '' }`
-''' $Header: perl_man.1,v 3.0.1.11 91/01/11 18:15:46 lwall Locked $
-'''
-''' $Log: perl.man.1,v $
-''' Revision 3.0.1.11 91/01/11 18:15:46 lwall
-''' patch42: added -0 option
-'''
-''' Revision 3.0.1.10 90/11/10 01:45:16 lwall
-''' patch38: random cleanup
-'''
-''' Revision 3.0.1.9 90/10/20 02:14:24 lwall
-''' patch37: fixed various typos in man page
-'''
-''' Revision 3.0.1.8 90/10/15 18:16:19 lwall
-''' patch29: added DATA filehandle to read stuff after __END__
-''' patch29: added cmp and <=>
-''' patch29: added -M, -A and -C
-'''
-''' Revision 3.0.1.7 90/08/09 04:24:03 lwall
-''' patch19: added -x switch to extract script from input trash
-''' patch19: Added -c switch to do compilation only
-''' patch19: bare identifiers are now strings if no other interpretation possible
-''' patch19: -s now returns size of file
-''' patch19: Added __LINE__ and __FILE__ tokens
-''' patch19: Added __END__ token
-'''
-''' Revision 3.0.1.6 90/08/03 11:14:44 lwall
-''' patch19: Intermediate diffs for Randal
-'''
-''' Revision 3.0.1.5 90/03/27 16:14:37 lwall
-''' patch16: .. now works using magical string increment
-'''
-''' Revision 3.0.1.4 90/03/12 16:44:33 lwall
-''' patch13: (LIST,) now legal
-''' patch13: improved LIST documentation
-''' patch13: example of if-elsif switch was wrong
-'''
-''' Revision 3.0.1.3 90/02/28 17:54:32 lwall
-''' patch9: @array in scalar context now returns length of array
-''' patch9: in manual, example of open and ?: was backwards
-'''
-''' Revision 3.0.1.2 89/11/17 15:30:03 lwall
-''' patch5: fixed some manual typos and indent problems
-'''
-''' Revision 3.0.1.1 89/11/11 04:41:22 lwall
-''' patch2: explained about sh and ${1+"$@"}
-''' patch2: documented that space must separate word and '' string
-'''
-''' Revision 3.0 89/10/18 15:21:29 lwall
-''' 3.0 baseline
-'''
-'''
-.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 PERL 1 "\*(RP"
-.UC
-.SH NAME
-perl \- Practical Extraction and Report Language
-.SH SYNOPSIS
-.B perl
-[options] filename args
-.SH DESCRIPTION
-.I 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,
-\fIsed\fR, \fIawk\fR, and \fIsh\fR,
-so people familiar with those languages should have little difficulty with it.
-(Language historians will also note some vestiges of \fIcsh\fR, Pascal, and
-even BASIC-PLUS.)
-Expression syntax corresponds quite closely to C expression syntax.
-Unlike most Unix utilities,
-.I perl
-does not arbitrarily limit the size of your data\*(--if you've got
-the memory,
-.I perl
-can slurp in your whole file as a single string.
-Recursion is of unlimited depth.
-And the hash tables used by associative arrays grow as necessary to prevent
-degraded performance.
-.I Perl
-uses sophisticated pattern matching techniques to scan large amounts of
-data very quickly.
-Although optimized for scanning text,
-.I perl
-can also deal with binary data, and can make dbm files look like associative
-arrays (where dbm is available).
-Setuid
-.I perl
-scripts are safer than C programs
-through a dataflow tracing mechanism which prevents many stupid security holes.
-If you have a problem that would ordinarily use \fIsed\fR
-or \fIawk\fR or \fIsh\fR, but it
-exceeds their capabilities or must run a little faster,
-and you don't want to write the silly thing in C, then
-.I perl
-may be for you.
-There are also translators to turn your
-.I sed
-and
-.I awk
-scripts into
-.I perl
-scripts.
-OK, enough hype.
-.PP
-Upon startup,
-.I perl
-looks for your script in one of the following places:
-.Ip 1. 4 2
-Specified line by line via
-.B \-e
-switches on the command line.
-.Ip 2. 4 2
-Contained in the file specified by the first filename on the command line.
-(Note that systems supporting the #! notation invoke interpreters this way.)
-.Ip 3. 4 2
-Passed in implicitly via standard input.
-This only works if there are no filename arguments\*(--to pass
-arguments to a
-.I stdin
-script you must explicitly specify a \- for the script name.
-.PP
-After locating your script,
-.I perl
-compiles it to an internal form.
-If the script is syntactically correct, it is executed.
-.Sh "Options"
-Note: on first reading this section may not make much sense to you. It's here
-at the front for easy reference.
-.PP
-A single-character option may be combined with the following option, if any.
-This is particularly useful when invoking a script using the #! construct which
-only allows one argument. Example:
-.nf
-
-.ne 2
- #!/usr/bin/perl \-spi.bak # same as \-s \-p \-i.bak
- .\|.\|.
-
-.fi
-Options include:
-.TP 5
-.BI \-0 digits
-specifies the record separator ($/) as an octal number.
-If there are no digits, the null character is the separator.
-Other switches may precede or follow the digits.
-For example, if you have a version of
-.I find
-which can print filenames terminated by the null character, you can say this:
-.nf
-
- find . \-name '*.bak' \-print0 | perl \-n0e unlink
-
-.fi
-The special value 00 will cause Perl to slurp files in paragraph mode.
-The value 0777 will cause Perl to slurp files whole since there is no
-legal character with that value.
-.TP 5
-.B \-a
-turns on autosplit mode when used with a
-.B \-n
-or
-.BR \-p .
-An implicit split command to the @F array
-is done as the first thing inside the implicit while loop produced by
-the
-.B \-n
-or
-.BR \-p .
-.nf
-
- perl \-ane \'print pop(@F), "\en";\'
-
-is equivalent to
-
- while (<>) {
- @F = split(\' \');
- print pop(@F), "\en";
- }
-
-.fi
-.TP 5
-.B \-c
-causes
-.I perl
-to check the syntax of the script and then exit without executing it.
-.TP 5
-.BI \-d
-runs the script under the perl debugger.
-See the section on Debugging.
-.TP 5
-.BI \-D number
-sets debugging flags.
-To watch how it executes your script, use
-.BR \-D14 .
-(This only works if debugging is compiled into your
-.IR perl .)
-Another nice value is \-D1024, which lists your compiled syntax tree.
-And \-D512 displays compiled regular expressions.
-.TP 5
-.BI \-e " commandline"
-may be used to enter one line of script.
-Multiple
-.B \-e
-commands may be given to build up a multi-line script.
-If
-.B \-e
-is given,
-.I perl
-will not look for a script filename in the argument list.
-.TP 5
-.BI \-i extension
-specifies that files processed by the <> construct are to be edited
-in-place.
-It does this by renaming the input file, opening the output file by the
-same name, and selecting that output file as the default for print statements.
-The extension, if supplied, is added to the name of the
-old file to make a backup copy.
-If no extension is supplied, no backup is made.
-Saying \*(L"perl \-p \-i.bak \-e "s/foo/bar/;" .\|.\|. \*(R" is the same as using
-the script:
-.nf
-
-.ne 2
- #!/usr/bin/perl \-pi.bak
- s/foo/bar/;
-
-which is equivalent to
-
-.ne 14
- #!/usr/bin/perl
- while (<>) {
- if ($ARGV ne $oldargv) {
- rename($ARGV, $ARGV . \'.bak\');
- open(ARGVOUT, ">$ARGV");
- select(ARGVOUT);
- $oldargv = $ARGV;
- }
- s/foo/bar/;
- }
- continue {
- print; # this prints to original filename
- }
- select(STDOUT);
-
-.fi
-except that the
-.B \-i
-form doesn't need to compare $ARGV to $oldargv to know when
-the filename has changed.
-It does, however, use ARGVOUT for the selected filehandle.
-Note that
-.I STDOUT
-is restored as the default output filehandle after the loop.
-.Sp
-You can use eof to locate the end of each input file, in case you want
-to append to each file, or reset line numbering (see example under eof).
-.TP 5
-.BI \-I directory
-may be used in conjunction with
-.B \-P
-to tell the C preprocessor where to look for include files.
-By default /usr/include and /usr/lib/perl are searched.
-.TP 5
-.B \-n
-causes
-.I perl
-to assume the following loop around your script, which makes it iterate
-over filename arguments somewhat like \*(L"sed \-n\*(R" or \fIawk\fR:
-.nf
-
-.ne 3
- while (<>) {
- .\|.\|. # your script goes here
- }
-
-.fi
-Note that the lines are not printed by default.
-See
-.B \-p
-to have lines printed.
-Here is an efficient way to delete all files older than a week:
-.nf
-
- find . \-mtime +7 \-print | perl \-ne \'chop;unlink;\'
-
-.fi
-This is faster than using the \-exec switch of find because you don't have to
-start a process on every filename found.
-.TP 5
-.B \-p
-causes
-.I perl
-to assume the following loop around your script, which makes it iterate
-over filename arguments somewhat like \fIsed\fR:
-.nf
-
-.ne 5
- while (<>) {
- .\|.\|. # your script goes here
- } continue {
- print;
- }
-
-.fi
-Note that the lines are printed automatically.
-To suppress printing use the
-.B \-n
-switch.
-A
-.B \-p
-overrides a
-.B \-n
-switch.
-.TP 5
-.B \-P
-causes your script to be run through the C preprocessor before
-compilation by
-.IR perl .
-(Since both comments and cpp directives begin with the # character,
-you should avoid starting comments with any words recognized
-by the C preprocessor such as \*(L"if\*(R", \*(L"else\*(R" or \*(L"define\*(R".)
-.TP 5
-.B \-s
-enables some rudimentary switch parsing for switches on the command line
-after the script name but before any filename arguments (or before a \-\|\-).
-Any switch found there is removed from @ARGV and sets the corresponding variable in the
-.I perl
-script.
-The following script prints \*(L"true\*(R" if and only if the script is
-invoked with a \-xyz switch.
-.nf
-
-.ne 2
- #!/usr/bin/perl \-s
- if ($xyz) { print "true\en"; }
-
-.fi
-.TP 5
-.B \-S
-makes
-.I perl
-use the PATH environment variable to search for the script
-(unless the name of the script starts with a slash).
-Typically this is used to emulate #! startup on machines that don't
-support #!, in the following manner:
-.nf
-
- #!/usr/bin/perl
- eval "exec /usr/bin/perl \-S $0 $*"
- if $running_under_some_shell;
-
-.fi
-The system ignores the first line and feeds the script to /bin/sh,
-which proceeds to try to execute the
-.I perl
-script as a shell script.
-The shell executes the second line as a normal shell command, and thus
-starts up the
-.I perl
-interpreter.
-On some systems $0 doesn't always contain the full pathname,
-so the
-.B \-S
-tells
-.I perl
-to search for the script if necessary.
-After
-.I perl
-locates the script, it parses the lines and ignores them because
-the variable $running_under_some_shell is never true.
-A better construct than $* would be ${1+"$@"}, which handles embedded spaces
-and such in the filenames, but doesn't work if the script is being interpreted
-by csh.
-In order to start up sh rather than csh, some systems may have to replace the
-#! line with a line containing just
-a colon, which will be politely ignored by perl.
-Other systems can't control that, and need a totally devious construct that
-will work under any of csh, sh or perl, such as the following:
-.nf
-
-.ne 3
- eval '(exit $?0)' && eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
- & eval 'exec /usr/bin/perl -S $0 $argv:q'
- if 0;
-
-.fi
-.TP 5
-.B \-u
-causes
-.I perl
-to dump core after compiling your script.
-You can then take this core dump and turn it into an executable file
-by using the undump program (not supplied).
-This speeds startup at the expense of some disk space (which you can
-minimize by stripping the executable).
-(Still, a "hello world" executable comes out to about 200K on my machine.)
-If you are going to run your executable as a set-id program then you
-should probably compile it using taintperl rather than normal perl.
-If you want to execute a portion of your script before dumping, use the
-dump operator instead.
-Note: availability of undump is platform specific and may not be available
-for a specific port of perl.
-.TP 5
-.B \-U
-allows
-.I perl
-to do unsafe operations.
-Currently the only \*(L"unsafe\*(R" operation is the unlinking of directories while
-running as superuser.
-.TP 5
-.B \-v
-prints the version and patchlevel of your
-.I perl
-executable.
-.TP 5
-.B \-w
-prints warnings about identifiers that are mentioned only once, and scalar
-variables that are used before being set.
-Also warns about redefined subroutines, and references to undefined
-filehandles or filehandles opened readonly that you are attempting to
-write on.
-Also warns you if you use == on values that don't look like numbers, and if
-your subroutines recurse more than 100 deep.
-.TP 5
-.BI \-x directory
-tells
-.I perl
-that the script is embedded in a message.
-Leading garbage will be discarded until the first line that starts
-with #! and contains the string "perl".
-Any meaningful switches on that line will be applied (but only one
-group of switches, as with normal #! processing).
-If a directory name is specified, Perl will switch to that directory
-before running the script.
-The
-.B \-x
-switch only controls the the disposal of leading garbage.
-The script must be terminated with __END__ if there is trailing garbage
-to be ignored (the script can process any or all of the trailing garbage
-via the DATA filehandle if desired).
-.Sh "Data Types and Objects"
-.PP
-.I Perl
-has three data types: scalars, arrays of scalars, and
-associative arrays of scalars.
-Normal arrays are indexed by number, and associative arrays by string.
-.PP
-The interpretation of operations and values in perl sometimes
-depends on the requirements
-of the context around the operation or value.
-There are three major contexts: string, numeric and array.
-Certain operations return array values
-in contexts wanting an array, and scalar values otherwise.
-(If this is true of an operation it will be mentioned in the documentation
-for that operation.)
-Operations which return scalars don't care whether the context is looking
-for a string or a number, but
-scalar variables and values are interpreted as strings or numbers
-as appropriate to the context.
-A scalar is interpreted as TRUE in the boolean sense if it is not the null
-string or 0.
-Booleans returned by operators are 1 for true and 0 or \'\' (the null
-string) for false.
-.PP
-There are actually two varieties of null string: defined and undefined.
-Undefined null strings are returned when there is no real value for something,
-such as when there was an error, or at end of file, or when you refer
-to an uninitialized variable or element of an array.
-An undefined null string may become defined the first time you access it, but
-prior to that you can use the defined() operator to determine whether the
-value is defined or not.
-.PP
-References to scalar variables always begin with \*(L'$\*(R', even when referring
-to a scalar that is part of an array.
-Thus:
-.nf
-
-.ne 3
- $days \h'|2i'# a simple scalar variable
- $days[28] \h'|2i'# 29th element of array @days
- $days{\'Feb\'}\h'|2i'# one value from an associative array
- $#days \h'|2i'# last index of array @days
-
-but entire arrays or array slices are denoted by \*(L'@\*(R':
-
- @days \h'|2i'# ($days[0], $days[1],\|.\|.\|. $days[n])
- @days[3,4,5]\h'|2i'# same as @days[3.\|.5]
- @days{'a','c'}\h'|2i'# same as ($days{'a'},$days{'c'})
-
-and entire associative arrays are denoted by \*(L'%\*(R':
-
- %days \h'|2i'# (key1, val1, key2, val2 .\|.\|.)
-.fi
-.PP
-Any of these eight constructs may serve as an lvalue,
-that is, may be assigned to.
-(It also turns out that an assignment is itself an lvalue in
-certain contexts\*(--see examples under s, tr and chop.)
-Assignment to a scalar evaluates the righthand side in a scalar context,
-while assignment to an array or array slice evaluates the righthand side
-in an array context.
-.PP
-You may find the length of array @days by evaluating
-\*(L"$#days\*(R", as in
-.IR csh .
-(Actually, it's not the length of the array, it's the subscript of the last element, since there is (ordinarily) a 0th element.)
-Assigning to $#days changes the length of the array.
-Shortening an array by this method does not actually destroy any values.
-Lengthening an array that was previously shortened recovers the values that
-were in those elements.
-You can also gain some measure of efficiency by preextending an array that
-is going to get big.
-(You can also extend an array by assigning to an element that is off the
-end of the array.
-This differs from assigning to $#whatever in that intervening values
-are set to null rather than recovered.)
-You can truncate an array down to nothing by assigning the null list () to
-it.
-The following are exactly equivalent
-.nf
-
- @whatever = ();
- $#whatever = $[ \- 1;
-
-.fi
-.PP
-If you evaluate an array in a scalar context, it returns the length of
-the array.
-The following is always true:
-.nf
-
- @whatever == $#whatever \- $[ + 1;
-
-.fi
-.PP
-Multi-dimensional arrays are not directly supported, but see the discussion
-of the $; variable later for a means of emulating multiple subscripts with
-an associative array.
-You could also write a subroutine to turn multiple subscripts into a single
-subscript.
-.PP
-Every data type has its own namespace.
-You can, without fear of conflict, use the same name for a scalar variable,
-an array, an associative array, a filehandle, a subroutine name, and/or
-a label.
-Since variable and array references always start with \*(L'$\*(R', \*(L'@\*(R',
-or \*(L'%\*(R', the \*(L"reserved\*(R" words aren't in fact reserved
-with respect to variable names.
-(They ARE reserved with respect to labels and filehandles, however, which
-don't have an initial special character.
-Hint: you could say open(LOG,\'logfile\') rather than open(log,\'logfile\').
-Using uppercase filehandles also improves readability and protects you
-from conflict with future reserved words.)
-Case IS significant\*(--\*(L"FOO\*(R", \*(L"Foo\*(R" and \*(L"foo\*(R" are all
-different names.
-Names which start with a letter may also contain digits and underscores.
-Names which do not start with a letter are limited to one character,
-e.g. \*(L"$%\*(R" or \*(L"$$\*(R".
-(Most of the one character names have a predefined significance to
-.IR perl .
-More later.)
-.PP
-Numeric literals are specified in any of the usual floating point or
-integer formats:
-.nf
-
-.ne 5
- 12345
- 12345.67
- .23E-10
- 0xffff # hex
- 0377 # octal
-
-.fi
-String literals are delimited by either single or double quotes.
-They work much like shell quotes:
-double-quoted string literals are subject to backslash and variable
-substitution; single-quoted strings are not (except for \e\' and \e\e).
-The usual backslash rules apply for making characters such as newline, tab, etc.
-You can also embed newlines directly in your strings, i.e. they can end on
-a different line than they begin.
-This is nice, but if you forget your trailing quote, the error will not be
-reported until
-.I perl
-finds another line containing the quote character, which
-may be much further on in the script.
-Variable substitution inside strings is limited to scalar variables, normal
-array values, and array slices.
-(In other words, identifiers beginning with $ or @, followed by an optional
-bracketed expression as a subscript.)
-The following code segment prints out \*(L"The price is $100.\*(R"
-.nf
-
-.ne 2
- $Price = \'$100\';\h'|3.5i'# not interpreted
- print "The price is $Price.\e\|n";\h'|3.5i'# interpreted
-
-.fi
-Note that you can put curly brackets around the identifier to delimit it
-from following alphanumerics.
-Also note that a single quoted string must be separated from a preceding
-word by a space, since single quote is a valid character in an identifier
-(see Packages).
-.PP
-Two special literals are __LINE__ and __FILE__, which represent the current
-line number and filename at that point in your program.
-They may only be used as separate tokens; they will not be interpolated
-into strings.
-In addition, the token __END__ may be used to indicate the logical end of the
-script before the actual end of file.
-Any following text is ignored (but may be read via the DATA filehandle).
-The two control characters ^D and ^Z are synonyms for __END__.
-.PP
-A word that doesn't have any other interpretation in the grammar will be
-treated as if it had single quotes around it.
-For this purpose, a word consists only of alphanumeric characters and underline,
-and must start with an alphabetic character.
-As with filehandles and labels, a bare word that consists entirely of
-lowercase letters risks conflict with future reserved words, and if you
-use the
-.B \-w
-switch, Perl will warn you about any such words.
-.PP
-Array values are interpolated into double-quoted strings by joining all the
-elements of the array with the delimiter specified in the $" variable,
-space by default.
-(Since in versions of perl prior to 3.0 the @ character was not a metacharacter
-in double-quoted strings, the interpolation of @array, $array[EXPR],
-@array[LIST], $array{EXPR}, or @array{LIST} only happens if array is
-referenced elsewhere in the program or is predefined.)
-The following are equivalent:
-.nf
-
-.ne 4
- $temp = join($",@ARGV);
- system "echo $temp";
-
- system "echo @ARGV";
-
-.fi
-Within search patterns (which also undergo double-quotish substitution)
-there is a bad ambiguity: Is /$foo[bar]/ to be
-interpreted as /${foo}[bar]/ (where [bar] is a character class for the
-regular expression) or as /${foo[bar]}/ (where [bar] is the subscript to
-array @foo)?
-If @foo doesn't otherwise exist, then it's obviously a character class.
-If @foo exists, perl takes a good guess about [bar], and is almost always right.
-If it does guess wrong, or if you're just plain paranoid,
-you can force the correct interpretation with curly brackets as above.
-.PP
-A line-oriented form of quoting is based on the shell here-is syntax.
-Following a << you specify a string to terminate the quoted material, and all lines
-following the current line down to the terminating string are the value
-of the item.
-The terminating string may be either an identifier (a word), or some
-quoted text.
-If quoted, the type of quotes you use determines the treatment of the text,
-just as in regular quoting.
-An unquoted identifier works like double quotes.
-There must be no space between the << and the identifier.
-(If you put a space it will be treated as a null identifier, which is
-valid, and matches the first blank line\*(--see Merry Christmas example below.)
-The terminating string must appear by itself (unquoted and with no surrounding
-whitespace) on the terminating line.
-.nf
-
- print <<EOF; # same as above
-The price is $Price.
-EOF
-
- print <<"EOF"; # same as above
-The price is $Price.
-EOF
-
- print << x 10; # null identifier is delimiter
-Merry Christmas!
-
- print <<`EOC`; # execute commands
-echo hi there
-echo lo there
-EOC
-
- print <<foo, <<bar; # you can stack them
-I said foo.
-foo
-I said bar.
-bar
-
-.fi
-Array literals are denoted by separating individual values by commas, and
-enclosing the list in parentheses:
-.nf
-
- (LIST)
-
-.fi
-In a context not requiring an array value, the value of the array literal
-is the value of the final element, as in the C comma operator.
-For example,
-.nf
-
-.ne 4
- @foo = (\'cc\', \'\-E\', $bar);
-
-assigns the entire array value to array foo, but
-
- $foo = (\'cc\', \'\-E\', $bar);
-
-.fi
-assigns the value of variable bar to variable foo.
-Note that the value of an actual array in a scalar context is the length
-of the array; the following assigns to $foo the value 3:
-.nf
-
-.ne 2
- @foo = (\'cc\', \'\-E\', $bar);
- $foo = @foo; # $foo gets 3
-
-.fi
-You may have an optional comma before the closing parenthesis of an
-array literal, so that you can say:
-.nf
-
- @foo = (
- 1,
- 2,
- 3,
- );
-
-.fi
-When a LIST is evaluated, each element of the list is evaluated in
-an array context, and the resulting array value is interpolated into LIST
-just as if each individual element were a member of LIST. Thus arrays
-lose their identity in a LIST\*(--the list
-
- (@foo,@bar,&SomeSub)
-
-contains all the elements of @foo followed by all the elements of @bar,
-followed by all the elements returned by the subroutine named SomeSub.
-.PP
-A list value may also be subscripted like a normal array.
-Examples:
-.nf
-
- $time = (stat($file))[8]; # stat returns array value
- $digit = ('a','b','c','d','e','f')[$digit-10];
- return (pop(@foo),pop(@foo))[0];
-
-.fi
-.PP
-Array lists may be assigned to if and only if each element of the list
-is an lvalue:
-.nf
-
- ($a, $b, $c) = (1, 2, 3);
-
- ($map{\'red\'}, $map{\'blue\'}, $map{\'green\'}) = (0x00f, 0x0f0, 0xf00);
-
-The final element may be an array or an associative array:
-
- ($a, $b, @rest) = split;
- local($a, $b, %rest) = @_;
-
-.fi
-You can actually put an array anywhere in the list, but the first array
-in the list will soak up all the values, and anything after it will get
-a null value.
-This may be useful in a local().
-.PP
-An associative array literal contains pairs of values to be interpreted
-as a key and a value:
-.nf
-
-.ne 2
- # same as map assignment above
- %map = ('red',0x00f,'blue',0x0f0,'green',0xf00);
-
-.fi
-Array assignment in a scalar context returns the number of elements
-produced by the expression on the right side of the assignment:
-.nf
-
- $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2
-
-.fi
-.PP
-There are several other pseudo-literals that you should know about.
-If a string is enclosed by backticks (grave accents), it first undergoes
-variable substitution just like a double quoted string.
-It is then interpreted as a command, and the output of that command
-is the value of the pseudo-literal, like in a shell.
-In a scalar context, a single string consisting of all the output is
-returned.
-In an array context, an array of values is returned, one for each line
-of output.
-(You can set $/ to use a different line terminator.)
-The command is executed each time the pseudo-literal is evaluated.
-The status value of the command is returned in $? (see Predefined Names
-for the interpretation of $?).
-Unlike in \f2csh\f1, no translation is done on the return
-data\*(--newlines remain newlines.
-Unlike in any of the shells, single quotes do not hide variable names
-in the command from interpretation.
-To pass a $ through to the shell you need to hide it with a backslash.
-.PP
-Evaluating a filehandle in angle brackets yields the next line
-from that file (newline included, so it's never false until EOF, at
-which time an undefined value is returned).
-Ordinarily you must assign that value to a variable,
-but there is one situation where an automatic assignment happens.
-If (and only if) the input symbol is the only thing inside the conditional of a
-.I while
-loop, the value is
-automatically assigned to the variable \*(L"$_\*(R".
-(This may seem like an odd thing to you, but you'll use the construct
-in almost every
-.I perl
-script you write.)
-Anyway, the following lines are equivalent to each other:
-.nf
-
-.ne 5
- while ($_ = <STDIN>) { print; }
- while (<STDIN>) { print; }
- for (\|;\|<STDIN>;\|) { print; }
- print while $_ = <STDIN>;
- print while <STDIN>;
-
-.fi
-The filehandles
-.IR STDIN ,
-.I STDOUT
-and
-.I STDERR
-are predefined.
-(The filehandles
-.IR stdin ,
-.I stdout
-and
-.I stderr
-will also work except in packages, where they would be interpreted as
-local identifiers rather than global.)
-Additional filehandles may be created with the
-.I open
-function.
-.PP
-If a <FILEHANDLE> is used in a context that is looking for an array, an array
-consisting of all the input lines is returned, one line per array element.
-It's easy to make a LARGE data space this way, so use with care.
-.PP
-The null filehandle <> is special and can be used to emulate the behavior of
-\fIsed\fR and \fIawk\fR.
-Input from <> comes either from standard input, or from each file listed on
-the command line.
-Here's how it works: the first time <> is evaluated, the ARGV array is checked,
-and if it is null, $ARGV[0] is set to \'-\', which when opened gives you standard
-input.
-The ARGV array is then processed as a list of filenames.
-The loop
-.nf
-
-.ne 3
- while (<>) {
- .\|.\|. # code for each line
- }
-
-.ne 10
-is equivalent to
-
- unshift(@ARGV, \'\-\') \|if \|$#ARGV < $[;
- while ($ARGV = shift) {
- open(ARGV, $ARGV);
- while (<ARGV>) {
- .\|.\|. # code for each line
- }
- }
-
-.fi
-except that it isn't as cumbersome to say.
-It really does shift array ARGV and put the current filename into
-variable ARGV.
-It also uses filehandle ARGV internally.
-You can modify @ARGV before the first <> as long as you leave the first
-filename at the beginning of the array.
-Line numbers ($.) continue as if the input was one big happy file.
-(But see example under eof for how to reset line numbers on each file.)
-.PP
-.ne 5
-If you want to set @ARGV to your own list of files, go right ahead.
-If you want to pass switches into your script, you can
-put a loop on the front like this:
-.nf
-
-.ne 10
- while ($_ = $ARGV[0], /\|^\-/\|) {
- shift;
- last if /\|^\-\|\-$\|/\|;
- /\|^\-D\|(.*\|)/ \|&& \|($debug = $1);
- /\|^\-v\|/ \|&& \|$verbose++;
- .\|.\|. # other switches
- }
- while (<>) {
- .\|.\|. # code for each line
- }
-
-.fi
-The <> symbol will return FALSE only once.
-If you call it again after this it will assume you are processing another
-@ARGV list, and if you haven't set @ARGV, will input from
-.IR STDIN .
-.PP
-If the string inside the angle brackets is a reference to a scalar variable
-(e.g. <$foo>),
-then that variable contains the name of the filehandle to input from.
-.PP
-If the string inside angle brackets is not a filehandle, it is interpreted
-as a filename pattern to be globbed, and either an array of filenames or the
-next filename in the list is returned, depending on context.
-One level of $ interpretation is done first, but you can't say <$foo>
-because that's an indirect filehandle as explained in the previous
-paragraph.
-You could insert curly brackets to force interpretation as a
-filename glob: <${foo}>.
-Example:
-.nf
-
-.ne 3
- while (<*.c>) {
- chmod 0644, $_;
- }
-
-is equivalent to
-
-.ne 5
- open(foo, "echo *.c | tr \-s \' \et\er\ef\' \'\e\e012\e\e012\e\e012\e\e012\'|");
- while (<foo>) {
- chop;
- chmod 0644, $_;
- }
-
-.fi
-In fact, it's currently implemented that way.
-(Which means it will not work on filenames with spaces in them unless
-you have /bin/csh on your machine.)
-Of course, the shortest way to do the above is:
-.nf
-
- chmod 0644, <*.c>;
-
-.fi
-.Sh "Syntax"
-.PP
-A
-.I perl
-script consists of a sequence of declarations and commands.
-The only things that need to be declared in
-.I perl
-are report formats and subroutines.
-See the sections below for more information on those declarations.
-All uninitialized user-created objects are assumed to
-start with a null or 0 value until they
-are defined by some explicit operation such as assignment.
-The sequence of commands is executed just once, unlike in
-.I sed
-and
-.I awk
-scripts, where the sequence of commands is executed for each input line.
-While this means that you must explicitly loop over the lines of your input file
-(or files), it also means you have much more control over which files and which
-lines you look at.
-(Actually, I'm lying\*(--it is possible to do an implicit loop with either the
-.B \-n
-or
-.B \-p
-switch.)
-.PP
-A declaration can be put anywhere a command can, but has no effect on the
-execution of the primary sequence of commands\(*--declarations all take effect
-at compile time.
-Typically all the declarations are put at the beginning or the end of the script.
-.PP
-.I Perl
-is, for the most part, a free-form language.
-(The only exception to this is format declarations, for fairly obvious reasons.)
-Comments are indicated by the # character, and extend to the end of the line.
-If you attempt to use /* */ C comments, it will be interpreted either as
-division or pattern matching, depending on the context.
-So don't do that.
-.Sh "Compound statements"
-In
-.IR perl ,
-a sequence of commands may be treated as one command by enclosing it
-in curly brackets.
-We will call this a BLOCK.
-.PP
-The following compound commands may be used to control flow:
-.nf
-
-.ne 4
- if (EXPR) BLOCK
- if (EXPR) BLOCK else BLOCK
- if (EXPR) BLOCK elsif (EXPR) BLOCK .\|.\|. else BLOCK
- LABEL while (EXPR) BLOCK
- LABEL while (EXPR) BLOCK continue BLOCK
- LABEL for (EXPR; EXPR; EXPR) BLOCK
- LABEL foreach VAR (ARRAY) BLOCK
- LABEL BLOCK continue BLOCK
-
-.fi
-Note that, unlike C and Pascal, these are defined in terms of BLOCKs, not
-statements.
-This means that the curly brackets are \fIrequired\fR\*(--no dangling statements allowed.
-If you want to write conditionals without curly brackets there are several
-other ways to do it.
-The following all do the same thing:
-.nf
-
-.ne 5
- if (!open(foo)) { die "Can't open $foo: $!"; }
- die "Can't open $foo: $!" unless open(foo);
- open(foo) || die "Can't open $foo: $!"; # foo or bust!
- open(foo) ? \'hi mom\' : die "Can't open $foo: $!";
- # a bit exotic, that last one
-
-.fi
-.PP
-The
-.I if
-statement is straightforward.
-Since BLOCKs are always bounded by curly brackets, there is never any
-ambiguity about which
-.I if
-an
-.I else
-goes with.
-If you use
-.I unless
-in place of
-.IR if ,
-the sense of the test is reversed.
-.PP
-The
-.I while
-statement executes the block as long as the expression is true
-(does not evaluate to the null string or 0).
-The LABEL is optional, and if present, consists of an identifier followed by
-a colon.
-The LABEL identifies the loop for the loop control statements
-.IR next ,
-.IR last ,
-and
-.I redo
-(see below).
-If there is a
-.I continue
-BLOCK, it is always executed just before
-the conditional is about to be evaluated again, similarly to the third part
-of a
-.I for
-loop in C.
-Thus it can be used to increment a loop variable, even when the loop has
-been continued via the
-.I next
-statement (similar to the C \*(L"continue\*(R" statement).
-.PP
-If the word
-.I while
-is replaced by the word
-.IR until ,
-the sense of the test is reversed, but the conditional is still tested before
-the first iteration.
-.PP
-In either the
-.I if
-or the
-.I while
-statement, you may replace \*(L"(EXPR)\*(R" with a BLOCK, and the conditional
-is true if the value of the last command in that block is true.
-.PP
-The
-.I for
-loop works exactly like the corresponding
-.I while
-loop:
-.nf
-
-.ne 12
- for ($i = 1; $i < 10; $i++) {
- .\|.\|.
- }
-
-is the same as
-
- $i = 1;
- while ($i < 10) {
- .\|.\|.
- } continue {
- $i++;
- }
-.fi
-.PP
-The foreach loop iterates over a normal array value and sets the variable
-VAR to be each element of the array in turn.
-The variable is implicitly local to the loop, and regains its former value
-upon exiting the loop.
-The \*(L"foreach\*(R" keyword is actually identical to the \*(L"for\*(R" keyword,
-so you can use \*(L"foreach\*(R" for readability or \*(L"for\*(R" for brevity.
-If VAR is omitted, $_ is set to each value.
-If ARRAY is an actual array (as opposed to an expression returning an array
-value), you can modify each element of the array
-by modifying VAR inside the loop.
-Examples:
-.nf
-
-.ne 5
- for (@ary) { s/foo/bar/; }
-
- foreach $elem (@elements) {
- $elem *= 2;
- }
-
-.ne 3
- for ((10,9,8,7,6,5,4,3,2,1,\'BOOM\')) {
- print $_, "\en"; sleep(1);
- }
-
- for (1..15) { print "Merry Christmas\en"; }
-
-.ne 3
- foreach $item (split(/:[\e\e\en:]*/, $ENV{\'TERMCAP\'})) {
- print "Item: $item\en";
- }
-
-.fi
-.PP
-The BLOCK by itself (labeled or not) is equivalent to a loop that executes
-once.
-Thus you can use any of the loop control statements in it to leave or
-restart the block.
-The
-.I continue
-block is optional.
-This construct is particularly nice for doing case structures.
-.nf
-
-.ne 6
- foo: {
- if (/^abc/) { $abc = 1; last foo; }
- if (/^def/) { $def = 1; last foo; }
- if (/^xyz/) { $xyz = 1; last foo; }
- $nothing = 1;
- }
-
-.fi
-There is no official switch statement in perl, because there
-are already several ways to write the equivalent.
-In addition to the above, you could write
-.nf
-
-.ne 6
- foo: {
- $abc = 1, last foo if /^abc/;
- $def = 1, last foo if /^def/;
- $xyz = 1, last foo if /^xyz/;
- $nothing = 1;
- }
-
-or
-
-.ne 6
- foo: {
- /^abc/ && do { $abc = 1; last foo; };
- /^def/ && do { $def = 1; last foo; };
- /^xyz/ && do { $xyz = 1; last foo; };
- $nothing = 1;
- }
-
-or
-
-.ne 6
- foo: {
- /^abc/ && ($abc = 1, last foo);
- /^def/ && ($def = 1, last foo);
- /^xyz/ && ($xyz = 1, last foo);
- $nothing = 1;
- }
-
-or even
-
-.ne 8
- if (/^abc/)
- { $abc = 1; }
- elsif (/^def/)
- { $def = 1; }
- elsif (/^xyz/)
- { $xyz = 1; }
- else
- {$nothing = 1;}
-
-.fi
-As it happens, these are all optimized internally to a switch structure,
-so perl jumps directly to the desired statement, and you needn't worry
-about perl executing a lot of unnecessary statements when you have a string
-of 50 elsifs, as long as you are testing the same simple scalar variable
-using ==, eq, or pattern matching as above.
-(If you're curious as to whether the optimizer has done this for a particular
-case statement, you can use the \-D1024 switch to list the syntax tree
-before execution.)
-.Sh "Simple statements"
-The only kind of simple statement is an expression evaluated for its side
-effects.
-Every expression (simple statement) must be terminated with a semicolon.
-Note that this is like C, but unlike Pascal (and
-.IR awk ).
-.PP
-Any simple statement may optionally be followed by a
-single modifier, just before the terminating semicolon.
-The possible modifiers are:
-.nf
-
-.ne 4
- if EXPR
- unless EXPR
- while EXPR
- until EXPR
-
-.fi
-The
-.I if
-and
-.I unless
-modifiers have the expected semantics.
-The
-.I while
-and
-.I until
-modifiers also have the expected semantics (conditional evaluated first),
-except when applied to a do-BLOCK command,
-in which case the block executes once before the conditional is evaluated.
-This is so that you can write loops like:
-.nf
-
-.ne 4
- do {
- $_ = <STDIN>;
- .\|.\|.
- } until $_ \|eq \|".\|\e\|n";
-
-.fi
-(See the
-.I do
-operator below. Note also that the loop control commands described later will
-NOT work in this construct, since modifiers don't take loop labels.
-Sorry.)
-.Sh "Expressions"
-Since
-.I perl
-expressions work almost exactly like C expressions, only the differences
-will be mentioned here.
-.PP
-Here's what
-.I perl
-has that C doesn't:
-.Ip ** 8 2
-The exponentiation operator.
-.Ip **= 8
-The exponentiation assignment operator.
-.Ip (\|) 8 3
-The null list, used to initialize an array to null.
-.Ip . 8
-Concatenation of two strings.
-.Ip .= 8
-The concatenation assignment operator.
-.Ip eq 8
-String equality (== is numeric equality).
-For a mnemonic just think of \*(L"eq\*(R" as a string.
-(If you are used to the
-.I awk
-behavior of using == for either string or numeric equality
-based on the current form of the comparands, beware!
-You must be explicit here.)
-.Ip ne 8
-String inequality (!= is numeric inequality).
-.Ip lt 8
-String less than.
-.Ip gt 8
-String greater than.
-.Ip le 8
-String less than or equal.
-.Ip ge 8
-String greater than or equal.
-.Ip cmp 8
-String comparison, returning -1, 0, or 1.
-.Ip <=> 8
-Numeric comparison, returning -1, 0, or 1.
-.Ip =~ 8 2
-Certain operations search or modify the string \*(L"$_\*(R" by default.
-This operator makes that kind of operation work on some other string.
-The right argument is a search pattern, substitution, or translation.
-The left argument is what is supposed to be searched, substituted, or
-translated instead of the default \*(L"$_\*(R".
-The return value indicates the success of the operation.
-(If the right argument is an expression other than a search pattern,
-substitution, or translation, it is interpreted as a search pattern
-at run time.
-This is less efficient than an explicit search, since the pattern must
-be compiled every time the expression is evaluated.)
-The precedence of this operator is lower than unary minus and autoincrement/decrement, but higher than everything else.
-.Ip !~ 8
-Just like =~ except the return value is negated.
-.Ip x 8
-The repetition operator.
-Returns a string consisting of the left operand repeated the
-number of times specified by the right operand.
-.nf
-
- print \'\-\' x 80; # print row of dashes
- print \'\-\' x80; # illegal, x80 is identifier
-
- print "\et" x ($tab/8), \' \' x ($tab%8); # tab over
-
-.fi
-.Ip x= 8
-The repetition assignment operator.
-.Ip .\|. 8
-The range operator, which is really two different operators depending
-on the context.
-In an array context, returns an array of values counting (by ones)
-from the left value to the right value.
-This is useful for writing \*(L"for (1..10)\*(R" loops and for doing
-slice operations on arrays.
-.Sp
-In a scalar context, .\|. returns a boolean value.
-The operator is bistable, like a flip-flop..
-Each .\|. operator maintains its own boolean state.
-It is false as long as its left operand is false.
-Once the left operand is true, the range operator stays true
-until the right operand is true,
-AFTER which the range operator becomes false again.
-(It doesn't become false till the next time the range operator is evaluated.
-It can become false on the same evaluation it became true, but it still returns
-true once.)
-The right operand is not evaluated while the operator is in the \*(L"false\*(R" state,
-and the left operand is not evaluated while the operator is in the \*(L"true\*(R" state.
-The scalar .\|. operator is primarily intended for doing line number ranges
-after
-the fashion of \fIsed\fR or \fIawk\fR.
-The precedence is a little lower than || and &&.
-The value returned is either the null string for false, or a sequence number
-(beginning with 1) for true.
-The sequence number is reset for each range encountered.
-The final sequence number in a range has the string \'E0\' appended to it, which
-doesn't affect its numeric value, but gives you something to search for if you
-want to exclude the endpoint.
-You can exclude the beginning point by waiting for the sequence number to be
-greater than 1.
-If either operand of scalar .\|. is static, that operand is implicitly compared
-to the $. variable, the current line number.
-Examples:
-.nf
-
-.ne 6
-As a scalar operator:
- if (101 .\|. 200) { print; } # print 2nd hundred lines
-
- next line if (1 .\|. /^$/); # skip header lines
-
- s/^/> / if (/^$/ .\|. eof()); # quote body
-
-.ne 4
-As an array operator:
- for (101 .\|. 200) { print; } # print $_ 100 times
-
- @foo = @foo[$[ .\|. $#foo]; # an expensive no-op
- @foo = @foo[$#foo-4 .\|. $#foo]; # slice last 5 items
-
-.fi
-.Ip \-x 8
-A file test.
-This unary operator takes one argument, either a filename or a filehandle,
-and tests the associated file to see if something is true about it.
-If the argument is omitted, tests $_, except for \-t, which tests
-.IR STDIN .
-It returns 1 for true and \'\' for false, or the undefined value if the
-file doesn't exist.
-Precedence is higher than logical and relational operators, but lower than
-arithmetic operators.
-The operator may be any of:
-.nf
- \-r File is readable by effective uid.
- \-w File is writable by effective uid.
- \-x File is executable by effective uid.
- \-o File is owned by effective uid.
- \-R File is readable by real uid.
- \-W File is writable by real uid.
- \-X File is executable by real uid.
- \-O File is owned by real uid.
- \-e File exists.
- \-z File has zero size.
- \-s File has non-zero size (returns size).
- \-f File is a plain file.
- \-d File is a directory.
- \-l File is a symbolic link.
- \-p File is a named pipe (FIFO).
- \-S File is a socket.
- \-b File is a block special file.
- \-c File is a character special file.
- \-u File has setuid bit set.
- \-g File has setgid bit set.
- \-k File has sticky bit set.
- \-t Filehandle is opened to a tty.
- \-T File is a text file.
- \-B File is a binary file (opposite of \-T).
- \-M Age of file in days when script started.
- \-A Same for access time.
- \-C Same for inode change time.
-
-.fi
-The interpretation of the file permission operators \-r, \-R, \-w, \-W, \-x and \-X
-is based solely on the mode of the file and the uids and gids of the user.
-There may be other reasons you can't actually read, write or execute the file.
-Also note that, for the superuser, \-r, \-R, \-w and \-W always return 1, and
-\-x and \-X return 1 if any execute bit is set in the mode.
-Scripts run by the superuser may thus need to do a stat() in order to determine
-the actual mode of the file, or temporarily set the uid to something else.
-.Sp
-Example:
-.nf
-.ne 7
-
- while (<>) {
- chop;
- next unless \-f $_; # ignore specials
- .\|.\|.
- }
-
-.fi
-Note that \-s/a/b/ does not do a negated substitution.
-Saying \-exp($foo) still works as expected, however\*(--only single letters
-following a minus are interpreted as file tests.
-.Sp
-The \-T and \-B switches work as follows.
-The first block or so of the file is examined for odd characters such as
-strange control codes or metacharacters.
-If too many odd characters (>10%) are found, it's a \-B file, otherwise it's a \-T file.
-Also, any file containing null in the first block is considered a binary file.
-If \-T or \-B is used on a filehandle, the current stdio buffer is examined
-rather than the first block.
-Both \-T and \-B return TRUE on a null file, or a file at EOF when testing
-a filehandle.
-.PP
-If any of the file tests (or either stat operator) are given the special
-filehandle consisting of a solitary underline, then the stat structure
-of the previous file test (or stat operator) is used, saving a system
-call.
-(This doesn't work with \-t, and you need to remember that lstat and -l
-will leave values in the stat structure for the symbolic link, not the
-real file.)
-Example:
-.nf
-
- print "Can do.\en" if -r $a || -w _ || -x _;
-
-.ne 9
- stat($filename);
- print "Readable\en" if -r _;
- print "Writable\en" if -w _;
- print "Executable\en" if -x _;
- print "Setuid\en" if -u _;
- print "Setgid\en" if -g _;
- print "Sticky\en" if -k _;
- print "Text\en" if -T _;
- print "Binary\en" if -B _;
-
-.fi
-.PP
-Here is what C has that
-.I perl
-doesn't:
-.Ip "unary &" 12
-Address-of operator.
-.Ip "unary *" 12
-Dereference-address operator.
-.Ip "(TYPE)" 12
-Type casting operator.
-.PP
-Like C,
-.I perl
-does a certain amount of expression evaluation at compile time, whenever
-it determines that all of the arguments to an operator are static and have
-no side effects.
-In particular, string concatenation happens at compile time between literals that don't do variable substitution.
-Backslash interpretation also happens at compile time.
-You can say
-.nf
-
-.ne 2
- \'Now is the time for all\' . "\|\e\|n" .
- \'good men to come to.\'
-
-.fi
-and this all reduces to one string internally.
-.PP
-The autoincrement operator has a little extra built-in magic to it.
-If you increment a variable that is numeric, or that has ever been used in
-a numeric context, you get a normal increment.
-If, however, the variable has only been used in string contexts since it
-was set, and has a value that is not null and matches the
-pattern /^[a\-zA\-Z]*[0\-9]*$/, the increment is done
-as a string, preserving each character within its range, with carry:
-.nf
-
- print ++($foo = \'99\'); # prints \*(L'100\*(R'
- print ++($foo = \'a0\'); # prints \*(L'a1\*(R'
- print ++($foo = \'Az\'); # prints \*(L'Ba\*(R'
- print ++($foo = \'zz\'); # prints \*(L'aaa\*(R'
-
-.fi
-The autodecrement is not magical.
-.PP
-The range operator (in an array context) makes use of the magical
-autoincrement algorithm if the minimum and maximum are strings.
-You can say
-
- @alphabet = (\'A\' .. \'Z\');
-
-to get all the letters of the alphabet, or
-
- $hexdigit = (0 .. 9, \'a\' .. \'f\')[$num & 15];
-
-to get a hexadecimal digit, or
-
- @z2 = (\'01\' .. \'31\'); print @z2[$mday];
-
-to get dates with leading zeros.
-(If the final value specified is not in the sequence that the magical increment
-would produce, the sequence goes until the next value would be longer than
-the final value specified.)
-.PP
-The || and && operators differ from C's in that, rather than returning 0 or 1,
-they return the last value evaluated.
-Thus, a portable way to find out the home directory might be:
-.nf
-
- $home = $ENV{'HOME'} || $ENV{'LOGDIR'} ||
- (getpwuid($<))[7] || die "You're homeless!\en";
-
-.fi
+++ /dev/null
-''' Beginning of part 2
-''' $Header: perl_man.2,v 3.0.1.11 91/01/11 18:17:08 lwall Locked $
-'''
-''' $Log: perl.man.2,v $
-''' Revision 3.0.1.11 91/01/11 18:17:08 lwall
-''' patch42: fixed some man page entries
-'''
-''' Revision 3.0.1.10 90/11/10 01:46:29 lwall
-''' patch38: random cleanup
-''' patch38: added alarm function
-'''
-''' Revision 3.0.1.9 90/10/15 18:17:37 lwall
-''' patch29: added caller
-''' patch29: index and substr now have optional 3rd args
-''' patch29: added SysV IPC
-'''
-''' Revision 3.0.1.8 90/08/13 22:21:00 lwall
-''' patch28: documented that you can't interpolate $) or $| in pattern
-'''
-''' Revision 3.0.1.7 90/08/09 04:27:04 lwall
-''' patch19: added require operator
-'''
-''' Revision 3.0.1.6 90/08/03 11:15:29 lwall
-''' patch19: Intermediate diffs for Randal
-'''
-''' Revision 3.0.1.5 90/03/27 16:15:17 lwall
-''' patch16: MSDOS support
-'''
-''' Revision 3.0.1.4 90/03/12 16:46:02 lwall
-''' patch13: documented behavior of @array = /noparens/
-'''
-''' Revision 3.0.1.3 90/02/28 17:55:58 lwall
-''' patch9: grep now returns number of items matched in scalar context
-''' patch9: documented in-place modification capabilites of grep
-'''
-''' Revision 3.0.1.2 89/11/17 15:30:16 lwall
-''' patch5: fixed some manual typos and indent problems
-'''
-''' Revision 3.0.1.1 89/11/11 04:43:10 lwall
-''' patch2: made some line breaks depend on troff vs. nroff
-''' patch2: example of unshift had args backwards
-'''
-''' Revision 3.0 89/10/18 15:21:37 lwall
-''' 3.0 baseline
-'''
-'''
-.PP
-Along with the literals and variables mentioned earlier,
-the operations in the following section can serve as terms in an expression.
-Some of these operations take a LIST as an argument.
-Such a list can consist of any combination of scalar arguments or array values;
-the array values will be included in the list as if each individual element were
-interpolated at that point in the list, forming a longer single-dimensional
-array value.
-Elements of the LIST should be separated by commas.
-If an operation is listed both with and without parentheses around its
-arguments, it means you can either use it as a unary operator or
-as a function call.
-To use it as a function call, the next token on the same line must
-be a left parenthesis.
-(There may be intervening white space.)
-Such a function then has highest precedence, as you would expect from
-a function.
-If any token other than a left parenthesis follows, then it is a
-unary operator, with a precedence depending only on whether it is a LIST
-operator or not.
-LIST operators have lowest precedence.
-All other unary operators have a precedence greater than relational operators
-but less than arithmetic operators.
-See the section on Precedence.
-.Ip "/PATTERN/" 8 4
-See m/PATTERN/.
-.Ip "?PATTERN?" 8 4
-This is just like the /pattern/ search, except that it matches only once between
-calls to the
-.I reset
-operator.
-This is a useful optimization when you only want to see the first occurrence of
-something in each file of a set of files, for instance.
-Only ?? patterns local to the current package are reset.
-.Ip "accept(NEWSOCKET,GENERICSOCKET)" 8 2
-Does the same thing that the accept system call does.
-Returns true if it succeeded, false otherwise.
-See example in section on Interprocess Communication.
-.Ip "alarm(SECONDS)" 8 4
-.Ip "alarm SECONDS" 8
-Arranges to have a SIGALRM delivered to this process after the specified number
-of seconds (minus 1, actually) have elapsed. Thus, alarm(15) will cause
-a SIGALRM at some point more than 14 seconds in the future.
-Only one timer may be counting at once. Each call disables the previous
-timer, and an argument of 0 may be supplied to cancel the previous timer
-without starting a new one.
-The returned value is the amount of time remaining on the previous timer.
-.Ip "atan2(Y,X)" 8 2
-Returns the arctangent of Y/X in the range
-.if t \-\(*p to \(*p.
-.if n \-PI to PI.
-.Ip "bind(SOCKET,NAME)" 8 2
-Does the same thing that the bind system call does.
-Returns true if it succeeded, false otherwise.
-NAME should be a packed address of the proper type for the socket.
-See example in section on Interprocess Communication.
-.Ip "binmode(FILEHANDLE)" 8 4
-.Ip "binmode FILEHANDLE" 8 4
-Arranges for the file to be read in \*(L"binary\*(R" mode in operating systems
-that distinguish between binary and text files.
-Files that are not read in binary mode have CR LF sequences translated
-to LF on input and LF translated to CR LF on output.
-Binmode has no effect under Unix.
-If FILEHANDLE is an expression, the value is taken as the name of
-the filehandle.
-.Ip "caller(EXPR)"
-.Ip "caller"
-Returns the context of the current subroutine call:
-.nf
-
- ($package,$filename,$line) = caller;
-
-.fi
-With EXPR, returns some extra information that the debugger uses to print
-a stack trace. The value of EXPR indicates how many call frames to go
-back before the current one.
-.Ip "chdir(EXPR)" 8 2
-.Ip "chdir EXPR" 8 2
-Changes the working directory to EXPR, if possible.
-If EXPR is omitted, changes to home directory.
-Returns 1 upon success, 0 otherwise.
-See example under
-.IR die .
-.Ip "chmod(LIST)" 8 2
-.Ip "chmod LIST" 8 2
-Changes the permissions of a list of files.
-The first element of the list must be the numerical mode.
-Returns the number of files successfully changed.
-.nf
-
-.ne 2
- $cnt = chmod 0755, \'foo\', \'bar\';
- chmod 0755, @executables;
-
-.fi
-.Ip "chop(LIST)" 8 7
-.Ip "chop(VARIABLE)" 8
-.Ip "chop VARIABLE" 8
-.Ip "chop" 8
-Chops off the last character of a string and returns the character chopped.
-It's used primarily to remove the newline from the end of an input record,
-but is much more efficient than s/\en// because it neither scans nor copies
-the string.
-If VARIABLE is omitted, chops $_.
-Example:
-.nf
-
-.ne 5
- while (<>) {
- chop; # avoid \en on last field
- @array = split(/:/);
- .\|.\|.
- }
-
-.fi
-You can actually chop anything that's an lvalue, including an assignment:
-.nf
-
- chop($cwd = \`pwd\`);
- chop($answer = <STDIN>);
-
-.fi
-If you chop a list, each element is chopped.
-Only the value of the last chop is returned.
-.Ip "chown(LIST)" 8 2
-.Ip "chown LIST" 8 2
-Changes the owner (and group) of a list of files.
-The first two elements of the list must be the NUMERICAL uid and gid,
-in that order.
-Returns the number of files successfully changed.
-.nf
-
-.ne 2
- $cnt = chown $uid, $gid, \'foo\', \'bar\';
- chown $uid, $gid, @filenames;
-
-.fi
-.ne 23
-Here's an example of looking up non-numeric uids:
-.nf
-
- print "User: ";
- $user = <STDIN>;
- chop($user);
- print "Files: "
- $pattern = <STDIN>;
- chop($pattern);
-.ie t \{\
- open(pass, \'/etc/passwd\') || die "Can't open passwd: $!\en";
-'br\}
-.el \{\
- open(pass, \'/etc/passwd\')
- || die "Can't open passwd: $!\en";
-'br\}
- while (<pass>) {
- ($login,$pass,$uid,$gid) = split(/:/);
- $uid{$login} = $uid;
- $gid{$login} = $gid;
- }
- @ary = <${pattern}>; # get filenames
- if ($uid{$user} eq \'\') {
- die "$user not in passwd file";
- }
- else {
- chown $uid{$user}, $gid{$user}, @ary;
- }
-
-.fi
-.Ip "chroot(FILENAME)" 8 5
-.Ip "chroot FILENAME" 8
-Does the same as the system call of that name.
-If you don't know what it does, don't worry about it.
-If FILENAME is omitted, does chroot to $_.
-.Ip "close(FILEHANDLE)" 8 5
-.Ip "close FILEHANDLE" 8
-Closes the file or pipe associated with the file handle.
-You don't have to close FILEHANDLE if you are immediately going to
-do another open on it, since open will close it for you.
-(See
-.IR open .)
-However, an explicit close on an input file resets the line counter ($.), while
-the implicit close done by
-.I open
-does not.
-Also, closing a pipe will wait for the process executing on the pipe to complete,
-in case you want to look at the output of the pipe afterwards.
-Closing a pipe explicitly also puts the status value of the command into $?.
-Example:
-.nf
-
-.ne 4
- open(OUTPUT, \'|sort >foo\'); # pipe to sort
- .\|.\|. # print stuff to output
- close OUTPUT; # wait for sort to finish
- open(INPUT, \'foo\'); # get sort's results
-
-.fi
-FILEHANDLE may be an expression whose value gives the real filehandle name.
-.Ip "closedir(DIRHANDLE)" 8 5
-.Ip "closedir DIRHANDLE" 8
-Closes a directory opened by opendir().
-.Ip "connect(SOCKET,NAME)" 8 2
-Does the same thing that the connect system call does.
-Returns true if it succeeded, false otherwise.
-NAME should be a package address of the proper type for the socket.
-See example in section on Interprocess Communication.
-.Ip "cos(EXPR)" 8 6
-.Ip "cos EXPR" 8 6
-Returns the cosine of EXPR (expressed in radians).
-If EXPR is omitted takes cosine of $_.
-.Ip "crypt(PLAINTEXT,SALT)" 8 6
-Encrypts a string exactly like the crypt() function in the C library.
-Useful for checking the password file for lousy passwords.
-Only the guys wearing white hats should do this.
-.Ip "dbmclose(ASSOC_ARRAY)" 8 6
-.Ip "dbmclose ASSOC_ARRAY" 8
-Breaks the binding between a dbm file and an associative array.
-The values remaining in the associative array are meaningless unless
-you happen to want to know what was in the cache for the dbm file.
-This function is only useful if you have ndbm.
-.Ip "dbmopen(ASSOC,DBNAME,MODE)" 8 6
-This binds a dbm or ndbm file to an associative array.
-ASSOC is the name of the associative array.
-(Unlike normal open, the first argument is NOT a filehandle, even though
-it looks like one).
-DBNAME is the name of the database (without the .dir or .pag extension).
-If the database does not exist, it is created with protection specified
-by MODE (as modified by the umask).
-If your system only supports the older dbm functions, you may only have one
-dbmopen in your program.
-If your system has neither dbm nor ndbm, calling dbmopen produces a fatal
-error.
-.Sp
-Values assigned to the associative array prior to the dbmopen are lost.
-A certain number of values from the dbm file are cached in memory.
-By default this number is 64, but you can increase it by preallocating
-that number of garbage entries in the associative array before the dbmopen.
-You can flush the cache if necessary with the reset command.
-.Sp
-If you don't have write access to the dbm file, you can only read
-associative array variables, not set them.
-If you want to test whether you can write, either use file tests or
-try setting a dummy array entry inside an eval, which will trap the error.
-.Sp
-Note that functions such as keys() and values() may return huge array values
-when used on large dbm files.
-You may prefer to use the each() function to iterate over large dbm files.
-Example:
-.nf
-
-.ne 6
- # print out history file offsets
- dbmopen(HIST,'/usr/lib/news/history',0666);
- while (($key,$val) = each %HIST) {
- print $key, ' = ', unpack('L',$val), "\en";
- }
- dbmclose(HIST);
-
-.fi
-.Ip "defined(EXPR)" 8 6
-.Ip "defined EXPR" 8
-Returns a boolean value saying whether the lvalue EXPR has a real value
-or not.
-Many operations return the undefined value under exceptional conditions,
-such as end of file, uninitialized variable, system error and such.
-This function allows you to distinguish between an undefined null string
-and a defined null string with operations that might return a real null
-string, in particular referencing elements of an array.
-You may also check to see if arrays or subroutines exist.
-Use on predefined variables is not guaranteed to produce intuitive results.
-Examples:
-.nf
-
-.ne 7
- print if defined $switch{'D'};
- print "$val\en" while defined($val = pop(@ary));
- die "Can't readlink $sym: $!"
- unless defined($value = readlink $sym);
- eval '@foo = ()' if defined(@foo);
- die "No XYZ package defined" unless defined %_XYZ;
- sub foo { defined &bar ? &bar(@_) : die "No bar"; }
-
-.fi
-See also undef.
-.Ip "delete $ASSOC{KEY}" 8 6
-Deletes the specified value from the specified associative array.
-Returns the deleted value, or the undefined value if nothing was deleted.
-Deleting from $ENV{} modifies the environment.
-Deleting from an array bound to a dbm file deletes the entry from the dbm
-file.
-.Sp
-The following deletes all the values of an associative array:
-.nf
-
-.ne 3
- foreach $key (keys %ARRAY) {
- delete $ARRAY{$key};
- }
-
-.fi
-(But it would be faster to use the
-.I reset
-command.
-Saying undef %ARRAY is faster yet.)
-.Ip "die(LIST)" 8
-.Ip "die LIST" 8
-Outside of an eval, prints the value of LIST to
-.I STDERR
-and exits with the current value of $!
-(errno).
-If $! is 0, exits with the value of ($? >> 8) (\`command\` status).
-If ($? >> 8) is 0, exits with 255.
-Inside an eval, the error message is stuffed into $@ and the eval is terminated
-with the undefined value.
-.Sp
-Equivalent examples:
-.nf
-
-.ne 3
-.ie t \{\
- die "Can't cd to spool: $!\en" unless chdir \'/usr/spool/news\';
-'br\}
-.el \{\
- die "Can't cd to spool: $!\en"
- unless chdir \'/usr/spool/news\';
-'br\}
-
- chdir \'/usr/spool/news\' || die "Can't cd to spool: $!\en"
-
-.fi
-.Sp
-If the value of EXPR does not end in a newline, the current script line
-number and input line number (if any) are also printed, and a newline is
-supplied.
-Hint: sometimes appending \*(L", stopped\*(R" to your message will cause it to make
-better sense when the string \*(L"at foo line 123\*(R" is appended.
-Suppose you are running script \*(L"canasta\*(R".
-.nf
-
-.ne 7
- die "/etc/games is no good";
- die "/etc/games is no good, stopped";
-
-produce, respectively
-
- /etc/games is no good at canasta line 123.
- /etc/games is no good, stopped at canasta line 123.
-
-.fi
-See also
-.IR exit .
-.Ip "do BLOCK" 8 4
-Returns the value of the last command in the sequence of commands indicated
-by BLOCK.
-When modified by a loop modifier, executes the BLOCK once before testing the
-loop condition.
-(On other statements the loop modifiers test the conditional first.)
-.Ip "do SUBROUTINE (LIST)" 8 3
-Executes a SUBROUTINE declared by a
-.I sub
-declaration, and returns the value
-of the last expression evaluated in SUBROUTINE.
-If there is no subroutine by that name, produces a fatal error.
-(You may use the \*(L"defined\*(R" operator to determine if a subroutine
-exists.)
-If you pass arrays as part of LIST you may wish to pass the length
-of the array in front of each array.
-(See the section on subroutines later on.)
-SUBROUTINE may be a scalar variable, in which case the variable contains
-the name of the subroutine to execute.
-The parentheses are required to avoid confusion with the \*(L"do EXPR\*(R"
-form.
-.Sp
-As an alternate form, you may call a subroutine by prefixing the name with
-an ampersand: &foo(@args).
-If you aren't passing any arguments, you don't have to use parentheses.
-If you omit the parentheses, no @_ array is passed to the subroutine.
-The & form is also used to specify subroutines to the defined and undef
-operators.
-.Ip "do EXPR" 8 3
-Uses the value of EXPR as a filename and executes the contents of the file
-as a
-.I perl
-script.
-Its primary use is to include subroutines from a
-.I perl
-subroutine library.
-.nf
-
- do \'stat.pl\';
-
-is just like
-
- eval \`cat stat.pl\`;
-
-.fi
-except that it's more efficient, more concise, keeps track of the current
-filename for error messages, and searches all the
-.B \-I
-libraries if the file
-isn't in the current directory (see also the @INC array in Predefined Names).
-It's the same, however, in that it does reparse the file every time you
-call it, so if you are going to use the file inside a loop you might prefer
-to use \-P and #include, at the expense of a little more startup time.
-(The main problem with #include is that cpp doesn't grok # comments\*(--a
-workaround is to use \*(L";#\*(R" for standalone comments.)
-Note that the following are NOT equivalent:
-.nf
-
-.ne 2
- do $foo; # eval a file
- do $foo(); # call a subroutine
-
-.fi
-Note that inclusion of library routines is better done with
-the \*(L"require\*(R" operator.
-.Ip "dump LABEL" 8 6
-This causes an immediate core dump.
-Primarily this is so that you can use the undump program to turn your
-core dump into an executable binary after having initialized all your
-variables at the beginning of the program.
-When the new binary is executed it will begin by executing a "goto LABEL"
-(with all the restrictions that goto suffers).
-Think of it as a goto with an intervening core dump and reincarnation.
-If LABEL is omitted, restarts the program from the top.
-WARNING: any files opened at the time of the dump will NOT be open any more
-when the program is reincarnated, with possible resulting confusion on the part
-of perl.
-See also \-u.
-.Sp
-Example:
-.nf
-
-.ne 16
- #!/usr/bin/perl
- require 'getopt.pl';
- require 'stat.pl';
- %days = (
- 'Sun',1,
- 'Mon',2,
- 'Tue',3,
- 'Wed',4,
- 'Thu',5,
- 'Fri',6,
- 'Sat',7);
-
- dump QUICKSTART if $ARGV[0] eq '-d';
-
- QUICKSTART:
- do Getopt('f');
-
-.fi
-.Ip "each(ASSOC_ARRAY)" 8 6
-.Ip "each ASSOC_ARRAY" 8
-Returns a 2 element array consisting of the key and value for the next
-value of an associative array, so that you can iterate over it.
-Entries are returned in an apparently random order.
-When the array is entirely read, a null array is returned (which when
-assigned produces a FALSE (0) value).
-The next call to each() after that will start iterating again.
-The iterator can be reset only by reading all the elements from the array.
-You must not modify the array while iterating over it.
-There is a single iterator for each associative array, shared by all
-each(), keys() and values() function calls in the program.
-The following prints out your environment like the printenv program, only
-in a different order:
-.nf
-
-.ne 3
- while (($key,$value) = each %ENV) {
- print "$key=$value\en";
- }
-
-.fi
-See also keys() and values().
-.Ip "eof(FILEHANDLE)" 8 8
-.Ip "eof()" 8
-.Ip "eof" 8
-Returns 1 if the next read on FILEHANDLE will return end of file, or if
-FILEHANDLE is not open.
-FILEHANDLE may be an expression whose value gives the real filehandle name.
-(Note that this function actually reads a character and then ungetc's it,
-so it is not very useful in an interactive context.)
-An eof without an argument returns the eof status for the last file read.
-Empty parentheses () may be used to indicate the pseudo file formed of the
-files listed on the command line, i.e. eof() is reasonable to use inside
-a while (<>) loop to detect the end of only the last file.
-Use eof(ARGV) or eof without the parentheses to test EACH file in a while (<>) loop.
-Examples:
-.nf
-
-.ne 7
- # insert dashes just before last line of last file
- while (<>) {
- if (eof()) {
- print "\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\en";
- }
- print;
- }
-
-.ne 7
- # reset line numbering on each input file
- while (<>) {
- print "$.\et$_";
- if (eof) { # Not eof().
- close(ARGV);
- }
- }
-
-.fi
-.Ip "eval(EXPR)" 8 6
-.Ip "eval EXPR" 8 6
-EXPR is parsed and executed as if it were a little
-.I perl
-program.
-It is executed in the context of the current
-.I perl
-program, so that
-any variable settings, subroutine or format definitions remain afterwards.
-The value returned is the value of the last expression evaluated, just
-as with subroutines.
-If there is a syntax error or runtime error, or a die statement is
-executed, an undefined value is returned by
-eval, and $@ is set to the error message.
-If there was no error, $@ is guaranteed to be a null string.
-If EXPR is omitted, evaluates $_.
-The final semicolon, if any, may be omitted from the expression.
-.Sp
-Note that, since eval traps otherwise-fatal errors, it is useful for
-determining whether a particular feature
-(such as dbmopen or symlink) is implemented.
-It is also Perl's exception trapping mechanism, where the die operator is
-used to raise exceptions.
-.Ip "exec(LIST)" 8 8
-.Ip "exec LIST" 8 6
-If there is more than one argument in LIST, or if LIST is an array with
-more than one value,
-calls execvp() with the arguments in LIST.
-If there is only one scalar argument, the argument is checked for shell metacharacters.
-If there are any, the entire argument is passed to \*(L"/bin/sh \-c\*(R" for parsing.
-If there are none, the argument is split into words and passed directly to
-execvp(), which is more efficient.
-Note: exec (and system) do not flush your output buffer, so you may need to
-set $| to avoid lost output.
-Examples:
-.nf
-
- exec \'/bin/echo\', \'Your arguments are: \', @ARGV;
- exec "sort $outfile | uniq";
-
-.fi
-.Sp
-If you don't really want to execute the first argument, but want to lie
-to the program you are executing about its own name, you can specify
-the program you actually want to run by assigning that to a variable and
-putting the name of the variable in front of the LIST without a comma.
-(This always forces interpretation of the LIST as a multi-valued list, even
-if there is only a single scalar in the list.)
-Example:
-.nf
-
-.ne 2
- $shell = '/bin/csh';
- exec $shell '-sh'; # pretend it's a login shell
-
-.fi
-.Ip "exit(EXPR)" 8 6
-.Ip "exit EXPR" 8
-Evaluates EXPR and exits immediately with that value.
-Example:
-.nf
-
-.ne 2
- $ans = <STDIN>;
- exit 0 \|if \|$ans \|=~ \|/\|^[Xx]\|/\|;
-
-.fi
-See also
-.IR die .
-If EXPR is omitted, exits with 0 status.
-.Ip "exp(EXPR)" 8 3
-.Ip "exp EXPR" 8
-Returns
-.I e
-to the power of EXPR.
-If EXPR is omitted, gives exp($_).
-.Ip "fcntl(FILEHANDLE,FUNCTION,SCALAR)" 8 4
-Implements the fcntl(2) function.
-You'll probably have to say
-.nf
-
- require "fcntl.ph"; # probably /usr/local/lib/perl/fcntl.ph
-
-.fi
-first to get the correct function definitions.
-If fcntl.ph doesn't exist or doesn't have the correct definitions
-you'll have to roll
-your own, based on your C header files such as <sys/fcntl.h>.
-(There is a perl script called h2ph that comes with the perl kit
-which may help you in this.)
-Argument processing and value return works just like ioctl below.
-Note that fcntl will produce a fatal error if used on a machine that doesn't implement
-fcntl(2).
-.Ip "fileno(FILEHANDLE)" 8 4
-.Ip "fileno FILEHANDLE" 8 4
-Returns the file descriptor for a filehandle.
-Useful for constructing bitmaps for select().
-If FILEHANDLE is an expression, the value is taken as the name of
-the filehandle.
-.Ip "flock(FILEHANDLE,OPERATION)" 8 4
-Calls flock(2) on FILEHANDLE.
-See manual page for flock(2) for definition of OPERATION.
-Returns true for success, false on failure.
-Will produce a fatal error if used on a machine that doesn't implement
-flock(2).
-Here's a mailbox appender for BSD systems.
-.nf
-
-.ne 20
- $LOCK_SH = 1;
- $LOCK_EX = 2;
- $LOCK_NB = 4;
- $LOCK_UN = 8;
-
- sub lock {
- flock(MBOX,$LOCK_EX);
- # and, in case someone appended
- # while we were waiting...
- seek(MBOX, 0, 2);
- }
-
- sub unlock {
- flock(MBOX,$LOCK_UN);
- }
-
- open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}")
- || die "Can't open mailbox: $!";
-
- do lock();
- print MBOX $msg,"\en\en";
- do unlock();
-
-.fi
-.Ip "fork" 8 4
-Does a fork() call.
-Returns the child pid to the parent process and 0 to the child process.
-Note: unflushed buffers remain unflushed in both processes, which means
-you may need to set $| to avoid duplicate output.
-.Ip "getc(FILEHANDLE)" 8 4
-.Ip "getc FILEHANDLE" 8
-.Ip "getc" 8
-Returns the next character from the input file attached to FILEHANDLE, or
-a null string at EOF.
-If FILEHANDLE is omitted, reads from STDIN.
-.Ip "getlogin" 8 3
-Returns the current login from /etc/utmp, if any.
-If null, use getpwuid.
-
- $login = getlogin || (getpwuid($<))[0] || "Somebody";
-
-.Ip "getpeername(SOCKET)" 8 3
-Returns the packed sockaddr address of other end of the SOCKET connection.
-.nf
-
-.ne 4
- # An internet sockaddr
- $sockaddr = 'S n a4 x8';
- $hersockaddr = getpeername(S);
-.ie t \{\
- ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr);
-'br\}
-.el \{\
- ($family, $port, $heraddr) =
- unpack($sockaddr,$hersockaddr);
-'br\}
-
-.fi
-.Ip "getpgrp(PID)" 8 4
-.Ip "getpgrp PID" 8
-Returns the current process group for the specified PID, 0 for the current
-process.
-Will produce a fatal error if used on a machine that doesn't implement
-getpgrp(2).
-If EXPR is omitted, returns process group of current process.
-.Ip "getppid" 8 4
-Returns the process id of the parent process.
-.Ip "getpriority(WHICH,WHO)" 8 4
-Returns the current priority for a process, a process group, or a user.
-(See getpriority(2).)
-Will produce a fatal error if used on a machine that doesn't implement
-getpriority(2).
-.Ip "getpwnam(NAME)" 8
-.Ip "getgrnam(NAME)" 8
-.Ip "gethostbyname(NAME)" 8
-.Ip "getnetbyname(NAME)" 8
-.Ip "getprotobyname(NAME)" 8
-.Ip "getpwuid(UID)" 8
-.Ip "getgrgid(GID)" 8
-.Ip "getservbyname(NAME,PROTO)" 8
-.Ip "gethostbyaddr(ADDR,ADDRTYPE)" 8
-.Ip "getnetbyaddr(ADDR,ADDRTYPE)" 8
-.Ip "getprotobynumber(NUMBER)" 8
-.Ip "getservbyport(PORT,PROTO)" 8
-.Ip "getpwent" 8
-.Ip "getgrent" 8
-.Ip "gethostent" 8
-.Ip "getnetent" 8
-.Ip "getprotoent" 8
-.Ip "getservent" 8
-.Ip "setpwent" 8
-.Ip "setgrent" 8
-.Ip "sethostent(STAYOPEN)" 8
-.Ip "setnetent(STAYOPEN)" 8
-.Ip "setprotoent(STAYOPEN)" 8
-.Ip "setservent(STAYOPEN)" 8
-.Ip "endpwent" 8
-.Ip "endgrent" 8
-.Ip "endhostent" 8
-.Ip "endnetent" 8
-.Ip "endprotoent" 8
-.Ip "endservent" 8
-These routines perform the same functions as their counterparts in the
-system library.
-The return values from the various get routines are as follows:
-.nf
-
- ($name,$passwd,$uid,$gid,
- $quota,$comment,$gcos,$dir,$shell) = getpw.\|.\|.
- ($name,$passwd,$gid,$members) = getgr.\|.\|.
- ($name,$aliases,$addrtype,$length,@addrs) = gethost.\|.\|.
- ($name,$aliases,$addrtype,$net) = getnet.\|.\|.
- ($name,$aliases,$proto) = getproto.\|.\|.
- ($name,$aliases,$port,$proto) = getserv.\|.\|.
-
-.fi
-The $members value returned by getgr.\|.\|. is a space separated list
-of the login names of the members of the group.
-.Sp
-The @addrs value returned by the gethost.\|.\|. functions is a list of the
-raw addresses returned by the corresponding system library call.
-In the Internet domain, each address is four bytes long and you can unpack
-it by saying something like:
-.nf
-
- ($a,$b,$c,$d) = unpack('C4',$addr[0]);
-
-.fi
-.Ip "getsockname(SOCKET)" 8 3
-Returns the packed sockaddr address of this end of the SOCKET connection.
-.nf
-
-.ne 4
- # An internet sockaddr
- $sockaddr = 'S n a4 x8';
- $mysockaddr = getsockname(S);
-.ie t \{\
- ($family, $port, $myaddr) = unpack($sockaddr,$mysockaddr);
-'br\}
-.el \{\
- ($family, $port, $myaddr) =
- unpack($sockaddr,$mysockaddr);
-'br\}
-
-.fi
-.Ip "getsockopt(SOCKET,LEVEL,OPTNAME)" 8 3
-Returns the socket option requested, or undefined if there is an error.
-.Ip "gmtime(EXPR)" 8 4
-.Ip "gmtime EXPR" 8
-Converts a time as returned by the time function to a 9-element array with
-the time analyzed for the Greenwich timezone.
-Typically used as follows:
-.nf
-
-.ne 3
-.ie t \{\
- ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
-'br\}
-.el \{\
- ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
- gmtime(time);
-'br\}
-
-.fi
-All array elements are numeric, and come straight out of a struct tm.
-In particular this means that $mon has the range 0.\|.11 and $wday has the
-range 0.\|.6.
-If EXPR is omitted, does gmtime(time).
-.Ip "goto LABEL" 8 6
-Finds the statement labeled with LABEL and resumes execution there.
-Currently you may only go to statements in the main body of the program
-that are not nested inside a do {} construct.
-This statement is not implemented very efficiently, and is here only to make
-the
-.IR sed -to- perl
-translator easier.
-I may change its semantics at any time, consistent with support for translated
-.I sed
-scripts.
-Use it at your own risk.
-Better yet, don't use it at all.
-.Ip "grep(EXPR,LIST)" 8 4
-Evaluates EXPR for each element of LIST (locally setting $_ to each element)
-and returns the array value consisting of those elements for which the
-expression evaluated to true.
-In a scalar context, returns the number of times the expression was true.
-.nf
-
- @foo = grep(!/^#/, @bar); # weed out comments
-
-.fi
-Note that, since $_ is a reference into the array value, it can be
-used to modify the elements of the array.
-While this is useful and supported, it can cause bizarre results if
-the LIST is not a named array.
-.Ip "hex(EXPR)" 8 4
-.Ip "hex EXPR" 8
-Returns the decimal value of EXPR interpreted as an hex string.
-(To interpret strings that might start with 0 or 0x see oct().)
-If EXPR is omitted, uses $_.
-.Ip "index(STR,SUBSTR,POSITION)" 8 4
-.Ip "index(STR,SUBSTR)" 8 4
-Returns the position of the first occurrence of SUBSTR in STR at or after
-POSITION.
-If POSITION is omitted, starts searching from the beginning of the string.
-The return value is based at 0, or whatever you've
-set the $[ variable to.
-If the substring is not found, returns one less than the base, ordinarily \-1.
-.Ip "int(EXPR)" 8 4
-.Ip "int EXPR" 8
-Returns the integer portion of EXPR.
-If EXPR is omitted, uses $_.
-.Ip "ioctl(FILEHANDLE,FUNCTION,SCALAR)" 8 4
-Implements the ioctl(2) function.
-You'll probably have to say
-.nf
-
- require "ioctl.ph"; # probably /usr/local/lib/perl/ioctl.ph
-
-.fi
-first to get the correct function definitions.
-If ioctl.ph doesn't exist or doesn't have the correct definitions
-you'll have to roll
-your own, based on your C header files such as <sys/ioctl.h>.
-(There is a perl script called h2ph that comes with the perl kit
-which may help you in this.)
-SCALAR will be read and/or written depending on the FUNCTION\*(--a pointer
-to the string value of SCALAR will be passed as the third argument of
-the actual ioctl call.
-(If SCALAR has no string value but does have a numeric value, that value
-will be passed rather than a pointer to the string value.
-To guarantee this to be true, add a 0 to the scalar before using it.)
-The pack() and unpack() functions are useful for manipulating the values
-of structures used by ioctl().
-The following example sets the erase character to DEL.
-.nf
-
-.ne 9
- require 'ioctl.ph';
- $sgttyb_t = "ccccs"; # 4 chars and a short
- if (ioctl(STDIN,$TIOCGETP,$sgttyb)) {
- @ary = unpack($sgttyb_t,$sgttyb);
- $ary[2] = 127;
- $sgttyb = pack($sgttyb_t,@ary);
- ioctl(STDIN,$TIOCSETP,$sgttyb)
- || die "Can't ioctl: $!";
- }
-
-.fi
-The return value of ioctl (and fcntl) is as follows:
-.nf
-
-.ne 4
- if OS returns:\h'|3i'perl returns:
- -1\h'|3i' undefined value
- 0\h'|3i' string "0 but true"
- anything else\h'|3i' that number
-
-.fi
-Thus perl returns true on success and false on failure, yet you can still
-easily determine the actual value returned by the operating system:
-.nf
-
- ($retval = ioctl(...)) || ($retval = -1);
- printf "System returned %d\en", $retval;
-.fi
-.Ip "join(EXPR,LIST)" 8 8
-.Ip "join(EXPR,ARRAY)" 8
-Joins the separate strings of LIST or ARRAY into a single string with fields
-separated by the value of EXPR, and returns the string.
-Example:
-.nf
-
-.ie t \{\
- $_ = join(\|\':\', $login,$passwd,$uid,$gid,$gcos,$home,$shell);
-'br\}
-.el \{\
- $_ = join(\|\':\',
- $login,$passwd,$uid,$gid,$gcos,$home,$shell);
-'br\}
-
-.fi
-See
-.IR split .
-.Ip "keys(ASSOC_ARRAY)" 8 6
-.Ip "keys ASSOC_ARRAY" 8
-Returns a normal array consisting of all the keys of the named associative
-array.
-The keys are returned in an apparently random order, but it is the same order
-as either the values() or each() function produces (given that the associative array
-has not been modified).
-Here is yet another way to print your environment:
-.nf
-
-.ne 5
- @keys = keys %ENV;
- @values = values %ENV;
- while ($#keys >= 0) {
- print pop(@keys), \'=\', pop(@values), "\en";
- }
-
-or how about sorted by key:
-
-.ne 3
- foreach $key (sort(keys %ENV)) {
- print $key, \'=\', $ENV{$key}, "\en";
- }
-
-.fi
-.Ip "kill(LIST)" 8 8
-.Ip "kill LIST" 8 2
-Sends a signal to a list of processes.
-The first element of the list must be the signal to send.
-Returns the number of processes successfully signaled.
-.nf
-
- $cnt = kill 1, $child1, $child2;
- kill 9, @goners;
-
-.fi
-If the signal is negative, kills process groups instead of processes.
-(On System V, a negative \fIprocess\fR number will also kill process groups,
-but that's not portable.)
-You may use a signal name in quotes.
-.Ip "last LABEL" 8 8
-.Ip "last" 8
-The
-.I last
-command is like the
-.I break
-statement in C (as used in loops); it immediately exits the loop in question.
-If the LABEL is omitted, the command refers to the innermost enclosing loop.
-The
-.I continue
-block, if any, is not executed:
-.nf
-
-.ne 4
- line: while (<STDIN>) {
- last line if /\|^$/; # exit when done with header
- .\|.\|.
- }
-
-.fi
-.Ip "length(EXPR)" 8 4
-.Ip "length EXPR" 8
-Returns the length in characters of the value of EXPR.
-If EXPR is omitted, returns length of $_.
-.Ip "link(OLDFILE,NEWFILE)" 8 2
-Creates a new filename linked to the old filename.
-Returns 1 for success, 0 otherwise.
-.Ip "listen(SOCKET,QUEUESIZE)" 8 2
-Does the same thing that the listen system call does.
-Returns true if it succeeded, false otherwise.
-See example in section on Interprocess Communication.
-.Ip "local(LIST)" 8 4
-Declares the listed variables to be local to the enclosing block,
-subroutine, eval or \*(L"do\*(R".
-All the listed elements must be legal lvalues.
-This operator works by saving the current values of those variables in LIST
-on a hidden stack and restoring them upon exiting the block, subroutine or eval.
-This means that called subroutines can also reference the local variable,
-but not the global one.
-The LIST may be assigned to if desired, which allows you to initialize
-your local variables.
-(If no initializer is given for a particular variable, it is created with
-an undefined value.)
-Commonly this is used to name the parameters to a subroutine.
-Examples:
-.nf
-
-.ne 13
- sub RANGEVAL {
- local($min, $max, $thunk) = @_;
- local($result) = \'\';
- local($i);
-
- # Presumably $thunk makes reference to $i
-
- for ($i = $min; $i < $max; $i++) {
- $result .= eval $thunk;
- }
-
- $result;
- }
-
-.ne 6
- if ($sw eq \'-v\') {
- # init local array with global array
- local(@ARGV) = @ARGV;
- unshift(@ARGV,\'echo\');
- system @ARGV;
- }
- # @ARGV restored
-
-.ne 6
- # temporarily add to digits associative array
- if ($base12) {
- # (NOTE: not claiming this is efficient!)
- local(%digits) = (%digits,'t',10,'e',11);
- do parse_num();
- }
-
-.fi
-Note that local() is a run-time command, and so gets executed every time
-through a loop, using up more stack storage each time until it's all
-released at once when the loop is exited.
-.Ip "localtime(EXPR)" 8 4
-.Ip "localtime EXPR" 8
-Converts a time as returned by the time function to a 9-element array with
-the time analyzed for the local timezone.
-Typically used as follows:
-.nf
-
-.ne 3
-.ie t \{\
- ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
-'br\}
-.el \{\
- ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
- localtime(time);
-'br\}
-
-.fi
-All array elements are numeric, and come straight out of a struct tm.
-In particular this means that $mon has the range 0.\|.11 and $wday has the
-range 0.\|.6.
-If EXPR is omitted, does localtime(time).
-.Ip "log(EXPR)" 8 4
-.Ip "log EXPR" 8
-Returns logarithm (base
-.IR e )
-of EXPR.
-If EXPR is omitted, returns log of $_.
-.Ip "lstat(FILEHANDLE)" 8 6
-.Ip "lstat FILEHANDLE" 8
-.Ip "lstat(EXPR)" 8
-.Ip "lstat SCALARVARIABLE" 8
-Does the same thing as the stat() function, but stats a symbolic link
-instead of the file the symbolic link points to.
-If symbolic links are unimplemented on your system, a normal stat is done.
-.Ip "m/PATTERN/io" 8 4
-.Ip "/PATTERN/io" 8
-Searches a string for a pattern match, and returns true (1) or false (\'\').
-If no string is specified via the =~ or !~ operator,
-the $_ string is searched.
-(The string specified with =~ need not be an lvalue\*(--it may be the result of an expression evaluation, but remember the =~ binds rather tightly.)
-See also the section on regular expressions.
-.Sp
-If / is the delimiter then the initial \*(L'm\*(R' is optional.
-With the \*(L'm\*(R' you can use any pair of non-alphanumeric characters
-as delimiters.
-This is particularly useful for matching Unix path names that contain \*(L'/\*(R'.
-If the final delimiter is followed by the optional letter \*(L'i\*(R', the matching is
-done in a case-insensitive manner.
-PATTERN may contain references to scalar variables, which will be interpolated
-(and the pattern recompiled) every time the pattern search is evaluated.
-(Note that $) and $| may not be interpolated because they look like end-of-string tests.)
-If you want such a pattern to be compiled only once, add an \*(L"o\*(R" after
-the trailing delimiter.
-This avoids expensive run-time recompilations, and
-is useful when the value you are interpolating won't change over the
-life of the script.
-.Sp
-If used in a context that requires an array value, a pattern match returns an
-array consisting of the subexpressions matched by the parentheses in the
-pattern,
-i.e. ($1, $2, $3.\|.\|.).
-It does NOT actually set $1, $2, etc. in this case, nor does it set $+, $`, $&
-or $'.
-If the match fails, a null array is returned.
-If the match succeeds, but there were no parentheses, an array value of (1)
-is returned.
-.Sp
-Examples:
-.nf
-
-.ne 4
- open(tty, \'/dev/tty\');
- <tty> \|=~ \|/\|^y\|/i \|&& \|do foo(\|); # do foo if desired
-
- if (/Version: \|*\|([0\-9.]*\|)\|/\|) { $version = $1; }
-
- next if m#^/usr/spool/uucp#;
-
-.ne 5
- # poor man's grep
- $arg = shift;
- while (<>) {
- print if /$arg/o; # compile only once
- }
-
- if (($F1, $F2, $Etc) = ($foo =~ /^(\eS+)\es+(\eS+)\es*(.*)/))
-
-.fi
-This last example splits $foo into the first two words and the remainder
-of the line, and assigns those three fields to $F1, $F2 and $Etc.
-The conditional is true if any variables were assigned, i.e. if the pattern
-matched.
-.Ip "mkdir(FILENAME,MODE)" 8 3
-Creates the directory specified by FILENAME, with permissions specified by
-MODE (as modified by umask).
-If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno).
-.Ip "msgctl(ID,CMD,ARG)" 8 4
-Calls the System V IPC function msgctl. If CMD is &IPC_STAT, then ARG
-must be a variable which will hold the returned msqid_ds structure.
-Returns like ioctl: the undefined value for error, "0 but true" for
-zero, or the actual return value otherwise.
-.Ip "msgget(KEY,FLAGS)" 8 4
-Calls the System V IPC function msgget. Returns the message queue id,
-or the undefined value if there is an error.
-.Ip "msgsnd(ID,MSG,FLAGS)" 8 4
-Calls the System V IPC function msgsnd to send the message MSG to the
-message queue ID. MSG must begin with the long integer message type,
-which may be created with pack("L", $type). Returns true if
-successful, or false if there is an error.
-.Ip "msgrcv(ID,VAR,SIZE,TYPE,FLAGS)" 8 4
-Calls the System V IPC function msgrcv to receive a message from
-message queue ID into variable VAR with a maximum message size of
-SIZE. Note that if a message is received, the message type will be
-the first thing in VAR, and the maximum length of VAR is SIZE plus the
-size of the message type. Returns true if successful, or false if
-there is an error.
+++ /dev/null
-''' Beginning of part 3
-''' $Header: perl_man.3,v 3.0.1.12 91/01/11 18:18:15 lwall Locked $
-'''
-''' $Log: perl.man.3,v $
-''' Revision 3.0.1.12 91/01/11 18:18:15 lwall
-''' patch42: added binary and hex pack/unpack options
-'''
-''' Revision 3.0.1.11 90/11/10 01:48:21 lwall
-''' patch38: random cleanup
-''' patch38: documented tr///cds
-'''
-''' Revision 3.0.1.10 90/10/20 02:15:17 lwall
-''' patch37: patch37: fixed various typos in man page
-'''
-''' Revision 3.0.1.9 90/10/16 10:02:43 lwall
-''' patch29: you can now read into the middle string
-''' patch29: index and substr now have optional 3rd args
-''' patch29: added scalar reverse
-''' patch29: added scalar
-''' patch29: added SysV IPC
-''' patch29: added waitpid
-''' patch29: added sysread and syswrite
-'''
-''' Revision 3.0.1.8 90/08/09 04:39:04 lwall
-''' patch19: added require operator
-''' patch19: added truncate operator
-''' patch19: unpack can do checksumming
-'''
-''' Revision 3.0.1.7 90/08/03 11:15:42 lwall
-''' patch19: Intermediate diffs for Randal
-'''
-''' Revision 3.0.1.6 90/03/27 16:17:56 lwall
-''' patch16: MSDOS support
-'''
-''' Revision 3.0.1.5 90/03/12 16:52:21 lwall
-''' patch13: documented that print $filehandle &foo is ambiguous
-''' patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST)
-'''
-''' Revision 3.0.1.4 90/02/28 18:00:09 lwall
-''' patch9: added pipe function
-''' patch9: documented how to handle arbitrary weird characters in filenames
-''' patch9: documented the unflushed buffers problem on piped opens
-''' patch9: documented how to force top of page
-'''
-''' Revision 3.0.1.3 89/12/21 20:10:12 lwall
-''' patch7: documented that s`pat`repl` does command substitution on replacement
-''' patch7: documented that $timeleft from select() is likely not implemented
-'''
-''' Revision 3.0.1.2 89/11/17 15:31:05 lwall
-''' patch5: fixed some manual typos and indent problems
-''' patch5: added warning about print making an array context
-'''
-''' Revision 3.0.1.1 89/11/11 04:45:06 lwall
-''' patch2: made some line breaks depend on troff vs. nroff
-'''
-''' Revision 3.0 89/10/18 15:21:46 lwall
-''' 3.0 baseline
-'''
-.Ip "next LABEL" 8 8
-.Ip "next" 8
-The
-.I next
-command is like the
-.I continue
-statement in C; it starts the next iteration of the loop:
-.nf
-
-.ne 4
- line: while (<STDIN>) {
- next line if /\|^#/; # discard comments
- .\|.\|.
- }
-
-.fi
-Note that if there were a
-.I continue
-block on the above, it would get executed even on discarded lines.
-If the LABEL is omitted, the command refers to the innermost enclosing loop.
-.Ip "oct(EXPR)" 8 4
-.Ip "oct EXPR" 8
-Returns the decimal value of EXPR interpreted as an octal string.
-(If EXPR happens to start off with 0x, interprets it as a hex string instead.)
-The following will handle decimal, octal and hex in the standard notation:
-.nf
-
- $val = oct($val) if $val =~ /^0/;
-
-.fi
-If EXPR is omitted, uses $_.
-.Ip "open(FILEHANDLE,EXPR)" 8 8
-.Ip "open(FILEHANDLE)" 8
-.Ip "open FILEHANDLE" 8
-Opens the file whose filename is given by EXPR, and associates it with
-FILEHANDLE.
-If FILEHANDLE is an expression, its value is used as the name of the
-real filehandle wanted.
-If EXPR is omitted, the scalar variable of the same name as the FILEHANDLE
-contains the filename.
-If the filename begins with \*(L"<\*(R" or nothing, the file is opened for
-input.
-If the filename begins with \*(L">\*(R", the file is opened for output.
-If the filename begins with \*(L">>\*(R", the file is opened for appending.
-(You can put a \'+\' in front of the \'>\' or \'<\' to indicate that you
-want both read and write access to the file.)
-If the filename begins with \*(L"|\*(R", the filename is interpreted
-as a command to which output is to be piped, and if the filename ends
-with a \*(L"|\*(R", the filename is interpreted as command which pipes
-input to us.
-(You may not have a command that pipes both in and out.)
-Opening \'\-\' opens
-.I STDIN
-and opening \'>\-\' opens
-.IR STDOUT .
-Open returns non-zero upon success, the undefined value otherwise.
-If the open involved a pipe, the return value happens to be the pid
-of the subprocess.
-Examples:
-.nf
-
-.ne 3
- $article = 100;
- open article || die "Can't find article $article: $!\en";
- while (<article>) {\|.\|.\|.
-
-.ie t \{\
- open(LOG, \'>>/usr/spool/news/twitlog\'\|); # (log is reserved)
-'br\}
-.el \{\
- open(LOG, \'>>/usr/spool/news/twitlog\'\|);
- # (log is reserved)
-'br\}
-
-.ie t \{\
- open(article, "caesar <$article |"\|); # decrypt article
-'br\}
-.el \{\
- open(article, "caesar <$article |"\|);
- # decrypt article
-'br\}
-
-.ie t \{\
- open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process#
-'br\}
-.el \{\
- open(extract, "|sort >/tmp/Tmp$$"\|);
- # $$ is our process#
-'br\}
-
-.ne 7
- # process argument list of files along with any includes
-
- foreach $file (@ARGV) {
- do process($file, \'fh00\'); # no pun intended
- }
-
- sub process {
- local($filename, $input) = @_;
- $input++; # this is a string increment
- unless (open($input, $filename)) {
- print STDERR "Can't open $filename: $!\en";
- return;
- }
-.ie t \{\
- while (<$input>) { # note the use of indirection
-'br\}
-.el \{\
- while (<$input>) { # note use of indirection
-'br\}
- if (/^#include "(.*)"/) {
- do process($1, $input);
- next;
- }
- .\|.\|. # whatever
- }
- }
-
-.fi
-You may also, in the Bourne shell tradition, specify an EXPR beginning
-with \*(L">&\*(R", in which case the rest of the string
-is interpreted as the name of a filehandle
-(or file descriptor, if numeric) which is to be duped and opened.
-You may use & after >, >>, <, +>, +>> and +<.
-The mode you specify should match the mode of the original filehandle.
-Here is a script that saves, redirects, and restores
-.I STDOUT
-and
-.IR STDERR :
-.nf
-
-.ne 21
- #!/usr/bin/perl
- open(SAVEOUT, ">&STDOUT");
- open(SAVEERR, ">&STDERR");
-
- open(STDOUT, ">foo.out") || die "Can't redirect stdout";
- open(STDERR, ">&STDOUT") || die "Can't dup stdout";
-
- select(STDERR); $| = 1; # make unbuffered
- select(STDOUT); $| = 1; # make unbuffered
-
- print STDOUT "stdout 1\en"; # this works for
- print STDERR "stderr 1\en"; # subprocesses too
-
- close(STDOUT);
- close(STDERR);
-
- open(STDOUT, ">&SAVEOUT");
- open(STDERR, ">&SAVEERR");
-
- print STDOUT "stdout 2\en";
- print STDERR "stderr 2\en";
-
-.fi
-If you open a pipe on the command \*(L"\-\*(R", i.e. either \*(L"|\-\*(R" or \*(L"\-|\*(R",
-then there is an implicit fork done, and the return value of open
-is the pid of the child within the parent process, and 0 within the child
-process.
-(Use defined($pid) to determine if the open was successful.)
-The filehandle behaves normally for the parent, but i/o to that
-filehandle is piped from/to the
-.IR STDOUT / STDIN
-of the child process.
-In the child process the filehandle isn't opened\*(--i/o happens from/to
-the new
-.I STDOUT
-or
-.IR STDIN .
-Typically this is used like the normal piped open when you want to exercise
-more control over just how the pipe command gets executed, such as when
-you are running setuid, and don't want to have to scan shell commands
-for metacharacters.
-The following pairs are more or less equivalent:
-.nf
-
-.ne 5
- open(FOO, "|tr \'[a\-z]\' \'[A\-Z]\'");
- open(FOO, "|\-") || exec \'tr\', \'[a\-z]\', \'[A\-Z]\';
-
- open(FOO, "cat \-n '$file'|");
- open(FOO, "\-|") || exec \'cat\', \'\-n\', $file;
-
-.fi
-Explicitly closing any piped filehandle causes the parent process to wait for the
-child to finish, and returns the status value in $?.
-Note: on any operation which may do a fork,
-unflushed buffers remain unflushed in both
-processes, which means you may need to set $| to
-avoid duplicate output.
-.Sp
-The filename that is passed to open will have leading and trailing
-whitespace deleted.
-In order to open a file with arbitrary weird characters in it, it's necessary
-to protect any leading and trailing whitespace thusly:
-.nf
-
-.ne 2
- $file =~ s#^(\es)#./$1#;
- open(FOO, "< $file\e0");
-
-.fi
-.Ip "opendir(DIRHANDLE,EXPR)" 8 3
-Opens a directory named EXPR for processing by readdir(), telldir(), seekdir(),
-rewinddir() and closedir().
-Returns true if successful.
-DIRHANDLEs have their own namespace separate from FILEHANDLEs.
-.Ip "ord(EXPR)" 8 4
-.Ip "ord EXPR" 8
-Returns the numeric ascii value of the first character of EXPR.
-If EXPR is omitted, uses $_.
-''' Comments on f & d by gnb@melba.bby.oz.au 22/11/89
-.Ip "pack(TEMPLATE,LIST)" 8 4
-Takes an array or list of values and packs it into a binary structure,
-returning the string containing the structure.
-The TEMPLATE is a sequence of characters that give the order and type
-of values, as follows:
-.nf
-
- A An ascii string, will be space padded.
- a An ascii string, will be null padded.
- c A 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.
- n A short in \*(L"network\*(R" order.
- N A long in \*(L"network\*(R" order.
- f A single-precision float in the native format.
- d A double-precision float in the native format.
- p A pointer to a string.
- x A null byte.
- X Back up a byte.
- @ Null fill to absolute position.
- u A uuencoded string.
- b A bit string (ascending bit order, like vec()).
- B A bit string (descending bit order).
- h A hex string (low nybble first).
- H A hex string (high nybble first).
-
-.fi
-Each letter may optionally be followed by a number which gives a repeat
-count.
-With all types except "a", "A", "b", "B", "h" and "H",
-the pack function will gobble up that many values
-from the LIST.
-A * for the repeat count means to use however many items are left.
-The "a" and "A" types gobble just one value, but pack it as a string of length
-count,
-padding with nulls or spaces as necessary.
-(When unpacking, "A" strips trailing spaces and nulls, but "a" does not.)
-Likewise, the "b" and "B" fields pack a string that many bits long.
-The "h" and "H" fields pack a string that many nybbles long.
-Real numbers (floats and doubles) are in the native machine format
-only; due to the multiplicity of floating formats around, and the lack
-of a standard \*(L"network\*(R" representation, no facility for
-interchange has been made.
-This means that packed floating point data
-written on one machine may not be readable on another - even if both
-use IEEE floating point arithmetic (as the endian-ness of the memory
-representation is not part of the IEEE spec).
-Note that perl uses
-doubles internally for all numeric calculation, and converting from
-double -> float -> double will lose precision (i.e. unpack("f",
-pack("f", $foo)) will not in general equal $foo).
-.br
-Examples:
-.nf
-
- $foo = pack("cccc",65,66,67,68);
- # foo eq "ABCD"
- $foo = pack("c4",65,66,67,68);
- # same thing
-
- $foo = pack("ccxxcc",65,66,67,68);
- # foo eq "AB\e0\e0CD"
-
- $foo = pack("s2",1,2);
- # "\e1\e0\e2\e0" on little-endian
- # "\e0\e1\e0\e2" on big-endian
-
- $foo = pack("a4","abcd","x","y","z");
- # "abcd"
-
- $foo = pack("aaaa","abcd","x","y","z");
- # "axyz"
-
- $foo = pack("a14","abcdefg");
- # "abcdefg\e0\e0\e0\e0\e0\e0\e0"
-
- $foo = pack("i9pl", gmtime);
- # a real struct tm (on my system anyway)
-
- sub bintodec {
- unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
- }
-.fi
-The same template may generally also be used in the unpack function.
-.Ip "pipe(READHANDLE,WRITEHANDLE)" 8 3
-Opens a pair of connected pipes like the corresponding system call.
-Note that if you set up a loop of piped processes, deadlock can occur
-unless you are very careful.
-In addition, note that perl's pipes use stdio buffering, so you may need
-to set $| to flush your WRITEHANDLE after each command, depending on
-the application.
-[Requires version 3.0 patchlevel 9.]
-.Ip "pop(ARRAY)" 8
-.Ip "pop ARRAY" 8 6
-Pops and returns the last value of the array, shortening the array by 1.
-Has the same effect as
-.nf
-
- $tmp = $ARRAY[$#ARRAY\-\|\-];
-
-.fi
-If there are no elements in the array, returns the undefined value.
-.Ip "print(FILEHANDLE LIST)" 8 10
-.Ip "print(LIST)" 8
-.Ip "print FILEHANDLE LIST" 8
-.Ip "print LIST" 8
-.Ip "print" 8
-Prints a string or a comma-separated list of strings.
-Returns non-zero if successful.
-FILEHANDLE may be a scalar variable name, in which case the variable contains
-the name of the filehandle, thus introducing one level of indirection.
-(NOTE: If FILEHANDLE is a variable and the next token is a term, it may be
-misinterpreted as an operator unless you interpose a + or put parens around
-the arguments.)
-If FILEHANDLE is omitted, prints by default to standard output (or to the
-last selected output channel\*(--see select()).
-If LIST is also omitted, prints $_ to
-.IR STDOUT .
-To set the default output channel to something other than
-.I STDOUT
-use the select operation.
-Note that, because print takes a LIST, anything in the LIST is evaluated
-in an array context, and any subroutine that you call will have one or more
-of its expressions evaluated in an array context.
-Also be careful not to follow the print keyword with a left parenthesis
-unless you want the corresponding right parenthesis to terminate the
-arguments to the print\*(--interpose a + or put parens around all the arguments.
-.Ip "printf(FILEHANDLE LIST)" 8 10
-.Ip "printf(LIST)" 8
-.Ip "printf FILEHANDLE LIST" 8
-.Ip "printf LIST" 8
-Equivalent to a \*(L"print FILEHANDLE sprintf(LIST)\*(R".
-.Ip "push(ARRAY,LIST)" 8 7
-Treats ARRAY (@ is optional) as a stack, and pushes the values of LIST
-onto the end of ARRAY.
-The length of ARRAY increases by the length of LIST.
-Has the same effect as
-.nf
-
- for $value (LIST) {
- $ARRAY[++$#ARRAY] = $value;
- }
-
-.fi
-but is more efficient.
-.Ip "q/STRING/" 8 5
-.Ip "qq/STRING/" 8
-These are not really functions, but simply syntactic sugar to let you
-avoid putting too many backslashes into quoted strings.
-The q operator is a generalized single quote, and the qq operator a
-generalized double quote.
-Any non-alphanumeric delimiter can be used in place of /, including newline.
-If the delimiter is an opening bracket or parenthesis, the final delimiter
-will be the corresponding closing bracket or parenthesis.
-(Embedded occurrences of the closing bracket need to be backslashed as usual.)
-Examples:
-.nf
-
-.ne 5
- $foo = q!I said, "You said, \'She said it.\'"!;
- $bar = q(\'This is it.\');
- $_ .= qq
-*** The previous line contains the naughty word "$&".\en
- if /(ibm|apple|awk)/; # :-)
-
-.fi
-.Ip "rand(EXPR)" 8 8
-.Ip "rand EXPR" 8
-.Ip "rand" 8
-Returns a random fractional number between 0 and the value of EXPR.
-(EXPR should be positive.)
-If EXPR is omitted, returns a value between 0 and 1.
-See also srand().
-.Ip "read(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5
-.Ip "read(FILEHANDLE,SCALAR,LENGTH)" 8 5
-Attempts to read LENGTH bytes of data into variable SCALAR from the specified
-FILEHANDLE.
-Returns the number of bytes actually read, or undef if there was an error.
-SCALAR will be grown or shrunk to the length actually read.
-An OFFSET may be specified to place the read data at some other place
-than the beginning of the string.
-This call is actually implemented in terms of stdio's fread call. To get
-a true read system call, see sysread.
-.Ip "readdir(DIRHANDLE)" 8 3
-.Ip "readdir DIRHANDLE" 8
-Returns the next directory entry for a directory opened by opendir().
-If used in an array context, returns all the rest of the entries in the
-directory.
-If there are no more entries, returns an undefined value in a scalar context
-or a null list in an array context.
-.Ip "readlink(EXPR)" 8 6
-.Ip "readlink EXPR" 8
-Returns the value of a symbolic link, if symbolic links are implemented.
-If not, gives a fatal error.
-If there is some system error, returns the undefined value and sets $! (errno).
-If EXPR is omitted, uses $_.
-.Ip "recv(SOCKET,SCALAR,LEN,FLAGS)" 8 4
-Receives a message on a socket.
-Attempts to receive LENGTH bytes of data into variable SCALAR from the specified
-SOCKET filehandle.
-Returns the address of the sender, or the undefined value if there's an error.
-SCALAR will be grown or shrunk to the length actually read.
-Takes the same flags as the system call of the same name.
-.Ip "redo LABEL" 8 8
-.Ip "redo" 8
-The
-.I redo
-command restarts the loop block without evaluating the conditional again.
-The
-.I continue
-block, if any, is not executed.
-If the LABEL is omitted, the command refers to the innermost enclosing loop.
-This command is normally used by programs that want to lie to themselves
-about what was just input:
-.nf
-
-.ne 16
- # a simpleminded Pascal comment stripper
- # (warning: assumes no { or } in strings)
- line: while (<STDIN>) {
- while (s|\|({.*}.*\|){.*}|$1 \||) {}
- s|{.*}| \||;
- if (s|{.*| \||) {
- $front = $_;
- while (<STDIN>) {
- if (\|/\|}/\|) { # end of comment?
- s|^|$front{|;
- redo line;
- }
- }
- }
- print;
- }
-
-.fi
-.Ip "rename(OLDNAME,NEWNAME)" 8 2
-Changes the name of a file.
-Returns 1 for success, 0 otherwise.
-Will not work across filesystem boundaries.
-.Ip "require(EXPR)" 8 6
-.Ip "require EXPR" 8
-.Ip "require" 8
-Includes the library file specified by EXPR, or by $_ if EXPR is not supplied.
-Has semantics similar to the following subroutine:
-.nf
-
- sub require {
- local($filename) = @_;
- return 1 if $INC{$filename};
- local($realfilename,$result);
- ITER: {
- foreach $prefix (@INC) {
- $realfilename = "$prefix/$filename";
- if (-f $realfilename) {
- $result = do $realfilename;
- last ITER;
- }
- }
- die "Can't find $filename in \e@INC";
- }
- die $@ if $@;
- die "$filename did not return true value" unless $result;
- $INC{$filename} = $realfilename;
- $result;
- }
-
-.fi
-Note that the file will not be included twice under the same specified name.
-.Ip "reset(EXPR)" 8 6
-.Ip "reset EXPR" 8
-.Ip "reset" 8
-Generally used in a
-.I continue
-block at the end of a loop to clear variables and reset ?? searches
-so that they work again.
-The expression is interpreted as a list of single characters (hyphens allowed
-for ranges).
-All variables and arrays beginning with one of those letters are reset to
-their pristine state.
-If the expression is omitted, one-match searches (?pattern?) are reset to
-match again.
-Only resets variables or searches in the current package.
-Always returns 1.
-Examples:
-.nf
-
-.ne 3
- reset \'X\'; \h'|2i'# reset all X variables
- reset \'a\-z\';\h'|2i'# reset lower case variables
- reset; \h'|2i'# just reset ?? searches
-
-.fi
-Note: resetting \*(L"A\-Z\*(R" is not recommended since you'll wipe out your ARGV and ENV
-arrays.
-.Sp
-The use of reset on dbm associative arrays does not change the dbm file.
-(It does, however, flush any entries cached by perl, which may be useful if
-you are sharing the dbm file.
-Then again, maybe not.)
-.Ip "return LIST" 8 3
-Returns from a subroutine with the value specified.
-(Note that a subroutine can automatically return
-the value of the last expression evaluated.
-That's the preferred method\*(--use of an explicit
-.I return
-is a bit slower.)
-.Ip "reverse(LIST)" 8 4
-.Ip "reverse LIST" 8
-In an array context, returns an array value consisting of the elements
-of LIST in the opposite order.
-In a scalar context, returns a string value consisting of the bytes of
-the first element of LIST in the opposite order.
-.Ip "rewinddir(DIRHANDLE)" 8 5
-.Ip "rewinddir DIRHANDLE" 8
-Sets the current position to the beginning of the directory for the readdir() routine on DIRHANDLE.
-.Ip "rindex(STR,SUBSTR,POSITION)" 8 6
-.Ip "rindex(STR,SUBSTR)" 8 4
-Works just like index except that it
-returns the position of the LAST occurrence of SUBSTR in STR.
-If POSITION is specified, returns the last occurrence at or before that
-position.
-.Ip "rmdir(FILENAME)" 8 4
-.Ip "rmdir FILENAME" 8
-Deletes the directory specified by FILENAME if it is empty.
-If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno).
-If FILENAME is omitted, uses $_.
-.Ip "s/PATTERN/REPLACEMENT/gieo" 8 3
-Searches a string for a pattern, and if found, replaces that pattern with the
-replacement text and returns the number of substitutions made.
-Otherwise it returns false (0).
-The \*(L"g\*(R" is optional, and if present, indicates that all occurrences
-of the pattern are to be replaced.
-The \*(L"i\*(R" is also optional, and if present, indicates that matching
-is to be done in a case-insensitive manner.
-The \*(L"e\*(R" is likewise optional, and if present, indicates that
-the replacement string is to be evaluated as an expression rather than just
-as a double-quoted string.
-Any non-alphanumeric delimiter may replace the slashes;
-if single quotes are used, no
-interpretation is done on the replacement string (the e modifier overrides
-this, however); if backquotes are used, the replacement string is a command
-to execute whose output will be used as the actual replacement text.
-If no string is specified via the =~ or !~ operator,
-the $_ string is searched and modified.
-(The string specified with =~ must be a scalar variable, an array element,
-or an assignment to one of those, i.e. an lvalue.)
-If the pattern contains a $ that looks like a variable rather than an
-end-of-string test, the variable will be interpolated into the pattern at
-run-time.
-If you only want the pattern compiled once the first time the variable is
-interpolated, add an \*(L"o\*(R" at the end.
-See also the section on regular expressions.
-Examples:
-.nf
-
- s/\|\e\|bgreen\e\|b/mauve/g; # don't change wintergreen
-
- $path \|=~ \|s|\|/usr/bin|\|/usr/local/bin|;
-
- s/Login: $foo/Login: $bar/; # run-time pattern
-
- ($foo = $bar) =~ s/bar/foo/;
-
- $_ = \'abc123xyz\';
- s/\ed+/$&*2/e; # yields \*(L'abc246xyz\*(R'
- s/\ed+/sprintf("%5d",$&)/e; # yields \*(L'abc 246xyz\*(R'
- s/\ew/$& x 2/eg; # yields \*(L'aabbcc 224466xxyyzz\*(R'
-
- s/\|([^ \|]*\|) *\|([^ \|]*\|)\|/\|$2 $1/; # reverse 1st two fields
-
-.fi
-(Note the use of $ instead of \|\e\| in the last example. See section
-on regular expressions.)
-.Ip "scalar(EXPR)" 8 3
-Forces EXPR to be interpreted in a scalar context and returns the value
-of EXPR.
-.Ip "seek(FILEHANDLE,POSITION,WHENCE)" 8 3
-Randomly positions the file pointer for FILEHANDLE, just like the fseek()
-call of stdio.
-FILEHANDLE may be an expression whose value gives the name of the filehandle.
-Returns 1 upon success, 0 otherwise.
-.Ip "seekdir(DIRHANDLE,POS)" 8 3
-Sets the current position for the readdir() routine on DIRHANDLE.
-POS must be a value returned by telldir().
-Has the same caveats about possible directory compaction as the corresponding
-system library routine.
-.Ip "select(FILEHANDLE)" 8 3
-.Ip "select" 8 3
-Returns the currently selected filehandle.
-Sets the current default filehandle for output, if FILEHANDLE is supplied.
-This has two effects: first, a
-.I write
-or a
-.I print
-without a filehandle will default to this FILEHANDLE.
-Second, references to variables related to output will refer to this output
-channel.
-For example, if you have to set the top of form format for more than
-one output channel, you might do the following:
-.nf
-
-.ne 4
- select(REPORT1);
- $^ = \'report1_top\';
- select(REPORT2);
- $^ = \'report2_top\';
-
-.fi
-FILEHANDLE may be an expression whose value gives the name of the actual filehandle.
-Thus:
-.nf
-
- $oldfh = select(STDERR); $| = 1; select($oldfh);
-
-.fi
-.Ip "select(RBITS,WBITS,EBITS,TIMEOUT)" 8 3
-This calls the select system call with the bitmasks specified, which can
-be constructed using fileno() and vec(), along these lines:
-.nf
-
- $rin = $win = $ein = '';
- vec($rin,fileno(STDIN),1) = 1;
- vec($win,fileno(STDOUT),1) = 1;
- $ein = $rin | $win;
-
-.fi
-If you want to select on many filehandles you might wish to write a subroutine:
-.nf
-
- sub fhbits {
- local(@fhlist) = split(' ',$_[0]);
- local($bits);
- for (@fhlist) {
- vec($bits,fileno($_),1) = 1;
- }
- $bits;
- }
- $rin = &fhbits('STDIN TTY SOCK');
-
-.fi
-The usual idiom is:
-.nf
-
- ($nfound,$timeleft) =
- select($rout=$rin, $wout=$win, $eout=$ein, $timeout);
-
-or to block until something becomes ready:
-
-.ie t \{\
- $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef);
-'br\}
-.el \{\
- $nfound = select($rout=$rin, $wout=$win,
- $eout=$ein, undef);
-'br\}
-
-.fi
-Any of the bitmasks can also be undef.
-The timeout, if specified, is in seconds, which may be fractional.
-NOTE: not all implementations are capable of returning the $timeleft.
-If not, they always return $timeleft equal to the supplied $timeout.
-.Ip "semctl(ID,SEMNUM,CMD,ARG)" 8 4
-Calls the System V IPC function semctl. If CMD is &IPC_STAT or
-&GETALL, then ARG must be a variable which will hold the returned
-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
-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
-Calls the System V IPC function semop to perform semaphore operations
-such as signaling and waiting. OPSTRING must be a packed array of
-semop structures. Each semop structure can be generated with
-\&'pack("sss", $semnum, $semop, $semflag)'. The number of semaphore
-operations is implied by the length of OPSTRING. Returns true if
-successful, or false if there is an error. As an example, the
-following code waits on semaphore $semnum of semaphore id $semid:
-.nf
-
- $semop = pack("sss", $semnum, -1, 0);
- die "Semaphore trouble: $!\en" unless semop($semid, $semop);
-
-.fi
-To signal the semaphore, replace "-1" with "1".
-.Ip "send(SOCKET,MSG,FLAGS,TO)" 8 4
-.Ip "send(SOCKET,MSG,FLAGS)" 8
-Sends a message on a socket.
-Takes the same flags as the system call of the same name.
-On unconnected sockets you must specify a destination to send TO.
-Returns the number of characters sent, or the undefined value if
-there is an error.
-.Ip "setpgrp(PID,PGRP)" 8 4
-Sets the current process group for the specified PID, 0 for the current
-process.
-Will produce a fatal error if used on a machine that doesn't implement
-setpgrp(2).
-.Ip "setpriority(WHICH,WHO,PRIORITY)" 8 4
-Sets the current priority for a process, a process group, or a user.
-(See setpriority(2).)
-Will produce a fatal error if used on a machine that doesn't implement
-setpriority(2).
-.Ip "setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)" 8 3
-Sets the socket option requested.
-Returns undefined if there is an error.
-OPTVAL may be specified as undef if you don't want to pass an argument.
-.Ip "shift(ARRAY)" 8 6
-.Ip "shift ARRAY" 8
-.Ip "shift" 8
-Shifts the first value of the array off and returns it,
-shortening the array by 1 and moving everything down.
-If there are no elements in the array, returns the undefined value.
-If ARRAY is omitted, shifts the @ARGV array in the main program, and the @_
-array in subroutines.
-(This is determined lexically.)
-See also unshift(), push() and pop().
-Shift() and unshift() do the same thing to the left end of an array that push()
-and pop() do to the right end.
-.Ip "shmctl(ID,CMD,ARG)" 8 4
-Calls the System V IPC function shmctl. If CMD is &IPC_STAT, then ARG
-must be a variable which will hold the returned shmid_ds structure.
-Returns like ioctl: the undefined value for error, "0 but true" for
-zero, or the actual return value otherwise.
-.Ip "shmget(KEY,SIZE,FLAGS)" 8 4
-Calls the System V IPC function shmget. Returns the shared memory
-segment id, or the undefined value if there is an error.
-.Ip "shmread(ID,VAR,POS,SIZE)" 8 4
-.Ip "shmwrite(ID,STRING,POS,SIZE)" 8
-Reads or writes the System V shared memory segment ID starting at
-position POS for size SIZE by attaching to it, copying in/out, and
-detaching from it. When reading, VAR must be a variable which
-will hold the data read. When writing, if STRING is too long,
-only SIZE bytes are used; if STRING is too short, nulls are
-written to fill out SIZE bytes. Return true if successful, or
-false if there is an error.
-.Ip "shutdown(SOCKET,HOW)" 8 3
-Shuts down a socket connection in the manner indicated by HOW, which has
-the same interpretation as in the system call of the same name.
-.Ip "sin(EXPR)" 8 4
-.Ip "sin EXPR" 8
-Returns the sine of EXPR (expressed in radians).
-If EXPR is omitted, returns sine of $_.
-.Ip "sleep(EXPR)" 8 6
-.Ip "sleep EXPR" 8
-.Ip "sleep" 8
-Causes the script to sleep for EXPR seconds, or forever if no EXPR.
-May be interrupted by sending the process a SIGALARM.
-Returns the number of seconds actually slept.
-.Ip "socket(SOCKET,DOMAIN,TYPE,PROTOCOL)" 8 3
-Opens a socket of the specified kind and attaches it to filehandle SOCKET.
-DOMAIN, TYPE and PROTOCOL are specified the same as for the system call
-of the same name.
-You may need to run h2ph on sys/socket.h to get the proper values handy
-in a perl library file.
-Return true if successful.
-See the example in the section on Interprocess Communication.
-.Ip "socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)" 8 3
-Creates an unnamed pair of sockets in the specified domain, of the specified
-type.
-DOMAIN, TYPE and PROTOCOL are specified the same as for the system call
-of the same name.
-If unimplemented, yields a fatal error.
-Return true if successful.
-.Ip "sort(SUBROUTINE LIST)" 8 9
-.Ip "sort(LIST)" 8
-.Ip "sort SUBROUTINE LIST" 8
-.Ip "sort LIST" 8
-Sorts the LIST and returns the sorted array value.
-Nonexistent values of arrays are stripped out.
-If SUBROUTINE is omitted, sorts in standard string comparison order.
-If SUBROUTINE is specified, gives the name of a subroutine that returns
-an integer less than, equal to, or greater than 0,
-depending on how the elements of the array are to be ordered.
-In the interests of efficiency the normal calling code for subroutines
-is bypassed, with the following effects: the subroutine may not be a recursive
-subroutine, and the two elements to be compared are passed into the subroutine
-not via @_ but as $a and $b (see example below).
-They are passed by reference so don't modify $a and $b.
-SUBROUTINE may be a scalar variable name, in which case the value provides
-the name of the subroutine to use.
-Examples:
-.nf
-
-.ne 4
- sub byage {
- $age{$a} - $age{$b}; # presuming integers
- }
- @sortedclass = sort byage @class;
-
-.ne 9
- sub reverse { $a lt $b ? 1 : $a gt $b ? \-1 : 0; }
- @harry = (\'dog\',\'cat\',\'x\',\'Cain\',\'Abel\');
- @george = (\'gone\',\'chased\',\'yz\',\'Punished\',\'Axed\');
- print sort @harry;
- # prints AbelCaincatdogx
- print sort reverse @harry;
- # prints xdogcatCainAbel
- print sort @george, \'to\', @harry;
- # prints AbelAxedCainPunishedcatchaseddoggonetoxyz
-
-.fi
-.Ip "splice(ARRAY,OFFSET,LENGTH,LIST)" 8 8
-.Ip "splice(ARRAY,OFFSET,LENGTH)" 8
-.Ip "splice(ARRAY,OFFSET)" 8
-Removes the elements designated by OFFSET and LENGTH from an array, and
-replaces them with the elements of LIST, if any.
-Returns the elements removed from the array.
-The array grows or shrinks as necessary.
-If LENGTH is omitted, removes everything from OFFSET onward.
-The following equivalencies hold (assuming $[ == 0):
-.nf
-
- push(@a,$x,$y)\h'|3.5i'splice(@a,$#a+1,0,$x,$y)
- pop(@a)\h'|3.5i'splice(@a,-1)
- shift(@a)\h'|3.5i'splice(@a,0,1)
- unshift(@a,$x,$y)\h'|3.5i'splice(@a,0,0,$x,$y)
- $a[$x] = $y\h'|3.5i'splice(@a,$x,1,$y);
-
-Example, assuming array lengths are passed before arrays:
-
- sub aeq { # compare two array values
- local(@a) = splice(@_,0,shift);
- local(@b) = splice(@_,0,shift);
- return 0 unless @a == @b; # same len?
- while (@a) {
- return 0 if pop(@a) ne pop(@b);
- }
- return 1;
- }
- if (&aeq($len,@foo[1..$len],0+@bar,@bar)) { ... }
-
-.fi
-.Ip "split(/PATTERN/,EXPR,LIMIT)" 8 8
-.Ip "split(/PATTERN/,EXPR)" 8 8
-.Ip "split(/PATTERN/)" 8
-.Ip "split" 8
-Splits a string into an array of strings, and returns it.
-(If not in an array context, returns the number of fields found and splits
-into the @_ array.
-(In an array context, you can force the split into @_
-by using ?? as the pattern delimiters, but it still returns the array value.))
-If EXPR is omitted, splits the $_ string.
-If PATTERN is also omitted, splits on whitespace (/[\ \et\en]+/).
-Anything matching PATTERN is taken to be a delimiter separating the fields.
-(Note that the delimiter may be longer than one character.)
-If LIMIT is specified, splits into no more than that many fields (though it
-may split into fewer).
-If LIMIT is unspecified, trailing null fields are stripped (which
-potential users of pop() would do well to remember).
-A pattern matching the null string (not to be confused with a null pattern //,
-which is just one member of the set of patterns matching a null string)
-will split the value of EXPR into separate characters at each point it
-matches that way.
-For example:
-.nf
-
- print join(\':\', split(/ */, \'hi there\'));
-
-.fi
-produces the output \*(L'h:i:t:h:e:r:e\*(R'.
-.Sp
-The LIMIT parameter can be used to partially split a line
-.nf
-
- ($login, $passwd, $remainder) = split(\|/\|:\|/\|, $_, 3);
-
-.fi
-(When assigning to a list, if LIMIT is omitted, perl supplies a LIMIT one
-larger than the number of variables in the list, to avoid unnecessary work.
-For the list above LIMIT would have been 4 by default.
-In time critical applications it behooves you not to split into
-more fields than you really need.)
-.Sp
-If the PATTERN contains parentheses, additional array elements are created
-from each matching substring in the delimiter.
-.Sp
- split(/([,-])/,"1-10,20");
-.Sp
-produces the array value
-.Sp
- (1,'-',10,',',20)
-.Sp
-The pattern /PATTERN/ may be replaced with an expression to specify patterns
-that vary at runtime.
-(To do runtime compilation only once, use /$variable/o.)
-As a special case, specifying a space (\'\ \') will split on white space
-just as split with no arguments does, but leading white space does NOT
-produce a null first field.
-Thus, split(\'\ \') can be used to emulate
-.IR awk 's
-default behavior, whereas
-split(/\ /) will give you as many null initial fields as there are
-leading spaces.
-.Sp
-Example:
-.nf
-
-.ne 5
- open(passwd, \'/etc/passwd\');
- while (<passwd>) {
-.ie t \{\
- ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(\|/\|:\|/\|);
-'br\}
-.el \{\
- ($login, $passwd, $uid, $gid, $gcos, $home, $shell)
- = split(\|/\|:\|/\|);
-'br\}
- .\|.\|.
- }
-
-.fi
-(Note that $shell above will still have a newline on it. See chop().)
-See also
-.IR join .
-.Ip "sprintf(FORMAT,LIST)" 8 4
-Returns a string formatted by the usual printf conventions.
-The * character is not supported.
-.Ip "sqrt(EXPR)" 8 4
-.Ip "sqrt EXPR" 8
-Return the square root of EXPR.
-If EXPR is omitted, returns square root of $_.
-.Ip "srand(EXPR)" 8 4
-.Ip "srand EXPR" 8
-Sets the random number seed for the
-.I rand
-operator.
-If EXPR is omitted, does srand(time).
-.Ip "stat(FILEHANDLE)" 8 8
-.Ip "stat FILEHANDLE" 8
-.Ip "stat(EXPR)" 8
-.Ip "stat SCALARVARIABLE" 8
-Returns a 13-element array giving the statistics for a file, either the file
-opened via FILEHANDLE, or named by EXPR.
-Typically used as follows:
-.nf
-
-.ne 3
- ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
- $atime,$mtime,$ctime,$blksize,$blocks)
- = stat($filename);
-
-.fi
-If stat is passed the special filehandle consisting of an underline,
-no stat is done, but the current contents of the stat structure from
-the last stat or filetest are returned.
-Example:
-.nf
-
-.ne 3
- if (-x $file && (($d) = stat(_)) && $d < 0) {
- print "$file is executable NFS file\en";
- }
-
-.fi
-.Ip "study(SCALAR)" 8 6
-.Ip "study SCALAR" 8
-.Ip "study"
-Takes extra time to study SCALAR ($_ if unspecified) in anticipation of
-doing many pattern matches on the string before it is next modified.
-This may or may not save time, depending on the nature and number of patterns
-you are searching on, and on the distribution of character frequencies in
-the string to be searched\*(--you probably want to compare runtimes with and
-without it to see which runs faster.
-Those loops which scan for many short constant strings (including the constant
-parts of more complex patterns) will benefit most.
-You may have only one study active at a time\*(--if you study a different
-scalar the first is \*(L"unstudied\*(R".
-(The way study works is this: a linked list of every character in the string
-to be searched is made, so we know, for example, where all the \*(L'k\*(R' characters
-are.
-From each search string, the rarest character is selected, based on some
-static frequency tables constructed from some C programs and English text.
-Only those places that contain this \*(L"rarest\*(R" character are examined.)
-.Sp
-For example, here is a loop which inserts index producing entries before any line
-containing a certain pattern:
-.nf
-
-.ne 8
- while (<>) {
- study;
- print ".IX foo\en" if /\ebfoo\eb/;
- print ".IX bar\en" if /\ebbar\eb/;
- print ".IX blurfl\en" if /\ebblurfl\eb/;
- .\|.\|.
- print;
- }
-
-.fi
-In searching for /\ebfoo\eb/, only those locations in $_ that contain \*(L'f\*(R'
-will be looked at, because \*(L'f\*(R' is rarer than \*(L'o\*(R'.
-In general, this is a big win except in pathological cases.
-The only question is whether it saves you more time than it took to build
-the linked list in the first place.
-.Sp
-Note that if you have to look for strings that you don't know till runtime,
-you can build an entire loop as a string and eval that to avoid recompiling
-all your patterns all the time.
-Together with setting $/ to input entire files as one record, this can
-be very fast, often faster than specialized programs like fgrep.
-The following scans a list of files (@files)
-for a list of words (@words), and prints out the names of those files that
-contain a match:
-.nf
-
-.ne 12
- $search = \'while (<>) { study;\';
- foreach $word (@words) {
- $search .= "++\e$seen{\e$ARGV} if /\eb$word\eb/;\en";
- }
- $search .= "}";
- @ARGV = @files;
- $/ = "\e177"; # something that doesn't occur
- eval $search; # this screams
- $/ = "\en"; # put back to normal input delim
- foreach $file (sort keys(%seen)) {
- print $file, "\en";
- }
-
-.fi
-.Ip "substr(EXPR,OFFSET,LEN)" 8 2
-.Ip "substr(EXPR,OFFSET)" 8 2
-Extracts a substring out of EXPR and returns it.
-First character is at offset 0, or whatever you've set $[ to.
-If OFFSET is negative, starts that far from the end of the string.
-If LEN is omitted, returns everything to the end of the string.
-You can use the substr() function as an lvalue, in which case EXPR must
-be an lvalue.
-If you assign something shorter than LEN, the string will shrink, and
-if you assign something longer than LEN, the string will grow to accommodate it.
-To keep the string the same length you may need to pad or chop your value using
-sprintf().
-.Ip "symlink(OLDFILE,NEWFILE)" 8 2
-Creates a new filename symbolically linked to the old filename.
-Returns 1 for success, 0 otherwise.
-On systems that don't support symbolic links, produces a fatal error at
-run time.
-To check for that, use eval:
-.nf
-
- $symlink_exists = (eval \'symlink("","");\', $@ eq \'\');
-
-.fi
-.Ip "syscall(LIST)" 8 6
-.Ip "syscall LIST" 8
-Calls the system call specified as the first element of the list, passing
-the remaining elements as arguments to the system call.
-If unimplemented, produces a fatal error.
-The arguments are interpreted as follows: if a given argument is numeric,
-the argument is passed as an int.
-If not, the pointer to the string value is passed.
-You are responsible to make sure a string is pre-extended long enough
-to receive any result that might be written into a string.
-If your integer arguments are not literals and have never been interpreted
-in a numeric context, you may need to add 0 to them to force them to look
-like numbers.
-.nf
-
- require 'syscall.ph'; # may need to run h2ph
- syscall(&SYS_write, fileno(STDOUT), "hi there\en", 9);
-
-.fi
-.Ip "sysread(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5
-.Ip "sysread(FILEHANDLE,SCALAR,LENGTH)" 8 5
-Attempts to read LENGTH bytes of data into variable SCALAR from the specified
-FILEHANDLE, using the system call read(2).
-It bypasses stdio, so mixing this with other kinds of reads may cause
-confusion.
-Returns the number of bytes actually read, or undef if there was an error.
-SCALAR will be grown or shrunk to the length actually read.
-An OFFSET may be specified to place the read data at some other place
-than the beginning of the string.
-.Ip "system(LIST)" 8 6
-.Ip "system LIST" 8
-Does exactly the same thing as \*(L"exec LIST\*(R" except that a fork
-is done first, and the parent process waits for the child process to complete.
-Note that argument processing varies depending on the number of arguments.
-The return value is the exit status of the program as returned by the wait()
-call.
-To get the actual exit value divide by 256.
-See also
-.IR exec .
-.Ip "syswrite(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5
-.Ip "syswrite(FILEHANDLE,SCALAR,LENGTH)" 8 5
-Attempts to write LENGTH bytes of data from variable SCALAR to the specified
-FILEHANDLE, using the system call write(2).
-It bypasses stdio, so mixing this with prints may cause
-confusion.
-Returns the number of bytes actually written, or undef if there was an error.
-An OFFSET may be specified to place the read data at some other place
-than the beginning of the string.
-.Ip "tell(FILEHANDLE)" 8 6
-.Ip "tell FILEHANDLE" 8 6
-.Ip "tell" 8
-Returns the current file position for FILEHANDLE.
-FILEHANDLE may be an expression whose value gives the name of the actual
-filehandle.
-If FILEHANDLE is omitted, assumes the file last read.
-.Ip "telldir(DIRHANDLE)" 8 5
-.Ip "telldir DIRHANDLE" 8
-Returns the current position of the readdir() routines on DIRHANDLE.
-Value may be given to seekdir() to access a particular location in
-a directory.
-Has the same caveats about possible directory compaction as the corresponding
-system library routine.
-.Ip "time" 8 4
-Returns the number of non-leap seconds since 00:00:00 UTC, January 1, 1970.
-Suitable for feeding to gmtime() and localtime().
-.Ip "times" 8 4
-Returns a four-element array giving the user and system times, in seconds, for this
-process and the children of this process.
-.Sp
- ($user,$system,$cuser,$csystem) = times;
-.Sp
-.Ip "tr/SEARCHLIST/REPLACEMENTLIST/cds" 8 5
-.Ip "y/SEARCHLIST/REPLACEMENTLIST/cds" 8
-Translates all occurrences of the characters found in the search list with
-the corresponding character in the replacement list.
-It returns the number of characters replaced or deleted.
-If no string is specified via the =~ or !~ operator,
-the $_ string is translated.
-(The string specified with =~ must be a scalar variable, an array element,
-or an assignment to one of those, i.e. an lvalue.)
-For
-.I sed
-devotees,
-.I y
-is provided as a synonym for
-.IR tr .
-.Sp
-If the c modifier is specified, the SEARCHLIST character set is complemented.
-If the d modifier is specified, any characters specified by SEARCHLIST that
-are not found in REPLACEMENTLIST are deleted.
-(Note that this is slightly more flexible than the behavior of some
-.I tr
-programs, which delete anything they find in the SEARCHLIST, period.)
-If the s modifier is specified, sequences of characters that were translated
-to the same character are squashed down to 1 instance of the character.
-.Sp
-If the d modifier was used, the REPLACEMENTLIST is always interpreted exactly
-as specified.
-Otherwise, if the REPLACEMENTLIST is shorter than the SEARCHLIST,
-the final character is replicated till it is long enough.
-If the REPLACEMENTLIST is null, the SEARCHLIST is replicated.
-This latter is useful for counting characters in a class, or for squashing
-character sequences in a class.
-.Sp
-Examples:
-.nf
-
- $ARGV[1] \|=~ \|y/A\-Z/a\-z/; \h'|3i'# canonicalize to lower case
-
- $cnt = tr/*/*/; \h'|3i'# count the stars in $_
-
- $cnt = tr/0\-9//; \h'|3i'# count the digits in $_
-
- tr/a\-zA\-Z//s; \h'|3i'# bookkeeper \-> bokeper
-
- ($HOST = $host) =~ tr/a\-z/A\-Z/;
-
- y/a\-zA\-Z/ /cs; \h'|3i'# change non-alphas to single space
-
- tr/\e200\-\e377/\e0\-\e177/;\h'|3i'# delete 8th bit
-
-.fi
-.Ip "truncate(FILEHANDLE,LENGTH)" 8 4
-.Ip "truncate(EXPR,LENGTH)" 8
-Truncates the file opened on FILEHANDLE, or named by EXPR, to the specified
-length.
-Produces a fatal error if truncate isn't implemented on your system.
-.Ip "umask(EXPR)" 8 4
-.Ip "umask EXPR" 8
-.Ip "umask" 8
-Sets the umask for the process and returns the old one.
-If EXPR is omitted, merely returns current umask.
-.Ip "undef(EXPR)" 8 6
-.Ip "undef EXPR" 8
-.Ip "undef" 8
-Undefines the value of EXPR, which must be an lvalue.
-Use only on a scalar value, an entire array, or a subroutine name (using &).
-(Undef will probably not do what you expect on most predefined variables or
-dbm array values.)
-Always returns the undefined value.
-You can omit the EXPR, in which case nothing is undefined, but you still
-get an undefined value that you could, for instance, return from a subroutine.
-Examples:
-.nf
-
-.ne 6
- undef $foo;
- undef $bar{'blurfl'};
- undef @ary;
- undef %assoc;
- undef &mysub;
- return (wantarray ? () : undef) if $they_blew_it;
-
-.fi
-.Ip "unlink(LIST)" 8 4
-.Ip "unlink LIST" 8
-Deletes a list of files.
-Returns the number of files successfully deleted.
-.nf
-
-.ne 2
- $cnt = unlink \'a\', \'b\', \'c\';
- unlink @goners;
- unlink <*.bak>;
-
-.fi
-Note: unlink will not delete directories unless you are superuser and the
-.B \-U
-flag is supplied to
-.IR perl .
-Even if these conditions are met, be warned that unlinking a directory
-can inflict damage on your filesystem.
-Use rmdir instead.
-.Ip "unpack(TEMPLATE,EXPR)" 8 4
-Unpack does the reverse of pack: it takes a string representing
-a structure and expands it out into an array value, returning the array
-value.
-(In a scalar context, it merely returns the first value produced.)
-The TEMPLATE has the same format as in the pack function.
-Here's a subroutine that does substring:
-.nf
-
-.ne 4
- sub substr {
- local($what,$where,$howmuch) = @_;
- unpack("x$where a$howmuch", $what);
- }
-
-.ne 3
-and then there's
-
- sub ord { unpack("c",$_[0]); }
-
-.fi
-In addition, you may prefix a field with a %<number> to indicate that
-you want a <number>-bit checksum of the items instead of the items themselves.
-Default is a 16-bit checksum.
-For example, the following computes the same number as the System V sum program:
-.nf
-
-.ne 4
- while (<>) {
- $checksum += unpack("%16C*", $_);
- }
- $checksum %= 65536;
-
-.fi
-.Ip "unshift(ARRAY,LIST)" 8 4
-Does the opposite of a
-.IR shift .
-Or the opposite of a
-.IR push ,
-depending on how you look at it.
-Prepends list to the front of the array, and returns the number of elements
-in the new array.
-.nf
-
- unshift(ARGV, \'\-e\') unless $ARGV[0] =~ /^\-/;
-
-.fi
-.Ip "utime(LIST)" 8 2
-.Ip "utime LIST" 8 2
-Changes the access and modification times on each file of a list of files.
-The first two elements of the list must be the NUMERICAL access and
-modification times, in that order.
-Returns the number of files successfully changed.
-The inode modification time of each file is set to the current time.
-Example of a \*(L"touch\*(R" command:
-.nf
-
-.ne 3
- #!/usr/bin/perl
- $now = time;
- utime $now, $now, @ARGV;
-
-.fi
-.Ip "values(ASSOC_ARRAY)" 8 6
-.Ip "values ASSOC_ARRAY" 8
-Returns a normal array consisting of all the values of the named associative
-array.
-The values are returned in an apparently random order, but it is the same order
-as either the keys() or each() function would produce on the same array.
-See also keys() and each().
-.Ip "vec(EXPR,OFFSET,BITS)" 8 2
-Treats a string as a vector of unsigned integers, and returns the value
-of the bitfield specified.
-May also be assigned to.
-BITS must be a power of two from 1 to 32.
-.Sp
-Vectors created with vec() can also be manipulated with the logical operators
-|, & and ^,
-which will assume a bit vector operation is desired when both operands are
-strings.
-This interpretation is not enabled unless there is at least one vec() in
-your program, to protect older programs.
-.Sp
-To transform a bit vector into a string or array of 0's and 1's, use these:
-.nf
-
- $bits = unpack("b*", $vector);
- @bits = split(//, unpack("b*", $vector));
-
-.fi
-If you know the exact length in bits, it can be used in place of the *.
-.Ip "wait" 8 6
-Waits for a child process to terminate and returns the pid of the deceased
-process, or -1 if there are no child processes.
-The status is returned in $?.
-.Ip "waitpid(PID,FLAGS)" 8 6
-Waits for a particular child process to terminate and returns the pid of the deceased
-process, or -1 if there is no such child process.
-The status is returned in $?.
-If you say
-.nf
-
- require "sys/wait.h";
- .\|.\|.
- waitpid(-1,&WNOHANG);
-
-.fi
-then you can do a non-blocking wait for any process. Non-blocking wait
-is only available on machines supporting either the
-.I waitpid (2)
-or
-.I wait4 (2)
-system calls.
-However, waiting for a particular pid with FLAGS of 0 is implemented
-everywhere. (Perl emulates the system call by remembering the status
-values of processes that have exited but have not been harvested by the
-Perl script yet.)
-.Ip "wantarray" 8 4
-Returns true if the context of the currently executing subroutine
-is looking for an array value.
-Returns false if the context is looking for a scalar.
-.nf
-
- return wantarray ? () : undef;
-
-.fi
-.Ip "warn(LIST)" 8 4
-.Ip "warn LIST" 8
-Produces a message on STDERR just like \*(L"die\*(R", but doesn't exit.
-.Ip "write(FILEHANDLE)" 8 6
-.Ip "write(EXPR)" 8
-.Ip "write" 8
-Writes a formatted record (possibly multi-line) to the specified file,
-using the format associated with that file.
-By default the format for a file is the one having the same name is the
-filehandle, but the format for the current output channel (see
-.IR select )
-may be set explicitly
-by assigning the name of the format to the $~ variable.
-.Sp
-Top of form processing is handled automatically:
-if there is insufficient room on the current page for the formatted
-record, the page is advanced by writing a form feed,
-a special top-of-page format is used
-to format the new page header, and then the record is written.
-By default the top-of-page format is \*(L"top\*(R", but it
-may be set to the
-format of your choice by assigning the name to the $^ variable.
-The number of lines remaining on the current page is in variable $-, which
-can be set to 0 to force a new page.
-.Sp
-If FILEHANDLE is unspecified, output goes to the current default output channel,
-which starts out as
-.I STDOUT
-but may be changed by the
-.I select
-operator.
-If the FILEHANDLE is an EXPR, then the expression is evaluated and the
-resulting string is used to look up the name of the FILEHANDLE at run time.
-For more on formats, see the section on formats later on.
-.Sp
-Note that write is NOT the opposite of read.
+++ /dev/null
-''' Beginning of part 4
-''' $Header: perl_man.4,v 3.0.1.14 91/01/11 18:18:53 lwall Locked $
-'''
-''' $Log: perl.man.4,v $
-''' Revision 3.0.1.14 91/01/11 18:18:53 lwall
-''' patch42: started an addendum and errata section in the man page
-'''
-''' Revision 3.0.1.13 90/11/10 01:51:00 lwall
-''' patch38: random cleanup
-'''
-''' Revision 3.0.1.12 90/10/20 02:15:43 lwall
-''' patch37: patch37: fixed various typos in man page
-'''
-''' Revision 3.0.1.11 90/10/16 10:04:28 lwall
-''' patch29: added @###.## fields to format
-'''
-''' Revision 3.0.1.10 90/08/09 04:47:35 lwall
-''' patch19: added require operator
-''' patch19: added numeric interpretation of $]
-'''
-''' Revision 3.0.1.9 90/08/03 11:15:58 lwall
-''' patch19: Intermediate diffs for Randal
-'''
-''' Revision 3.0.1.8 90/03/27 16:19:31 lwall
-''' patch16: MSDOS support
-'''
-''' Revision 3.0.1.7 90/03/14 12:29:50 lwall
-''' patch15: man page falsely states that you can't subscript array values
-'''
-''' Revision 3.0.1.6 90/03/12 16:54:04 lwall
-''' patch13: improved documentation of *name
-'''
-''' Revision 3.0.1.5 90/02/28 18:01:52 lwall
-''' patch9: $0 is now always the command name
-'''
-''' Revision 3.0.1.4 89/12/21 20:12:39 lwall
-''' patch7: documented that package'filehandle works as well as $package'variable
-''' patch7: documented which identifiers are always in package main
-'''
-''' Revision 3.0.1.3 89/11/17 15:32:25 lwall
-''' patch5: fixed some manual typos and indent problems
-''' patch5: clarified difference between $! and $@
-'''
-''' Revision 3.0.1.2 89/11/11 04:46:40 lwall
-''' patch2: made some line breaks depend on troff vs. nroff
-''' patch2: clarified operation of ^ and $ when $* is false
-'''
-''' Revision 3.0.1.1 89/10/26 23:18:43 lwall
-''' patch1: documented the desirability of unnecessary parentheses
-'''
-''' Revision 3.0 89/10/18 15:21:55 lwall
-''' 3.0 baseline
-'''
-.Sh "Precedence"
-.I Perl
-operators have the following associativity and precedence:
-.nf
-
-nonassoc\h'|1i'print printf exec system sort reverse
-\h'1.5i'chmod chown kill unlink utime die return
-left\h'|1i',
-right\h'|1i'= += \-= *= etc.
-right\h'|1i'?:
-nonassoc\h'|1i'.\|.
-left\h'|1i'||
-left\h'|1i'&&
-left\h'|1i'| ^
-left\h'|1i'&
-nonassoc\h'|1i'== != <=> eq ne cmp
-nonassoc\h'|1i'< > <= >= lt gt le ge
-nonassoc\h'|1i'chdir exit eval reset sleep rand umask
-nonassoc\h'|1i'\-r \-w \-x etc.
-left\h'|1i'<< >>
-left\h'|1i'+ \- .
-left\h'|1i'* / % x
-left\h'|1i'=~ !~
-right\h'|1i'! ~ and unary minus
-right\h'|1i'**
-nonassoc\h'|1i'++ \-\|\-
-left\h'|1i'\*(L'(\*(R'
-
-.fi
-As mentioned earlier, if any list operator (print, etc.) or
-any unary operator (chdir, etc.)
-is followed by a left parenthesis as the next token on the same line,
-the operator and arguments within parentheses are taken to
-be of highest precedence, just like a normal function call.
-Examples:
-.nf
-
- chdir $foo || die;\h'|3i'# (chdir $foo) || die
- chdir($foo) || die;\h'|3i'# (chdir $foo) || die
- chdir ($foo) || die;\h'|3i'# (chdir $foo) || die
- chdir +($foo) || die;\h'|3i'# (chdir $foo) || die
-
-but, because * is higher precedence than ||:
-
- chdir $foo * 20;\h'|3i'# chdir ($foo * 20)
- chdir($foo) * 20;\h'|3i'# (chdir $foo) * 20
- chdir ($foo) * 20;\h'|3i'# (chdir $foo) * 20
- chdir +($foo) * 20;\h'|3i'# chdir ($foo * 20)
-
- rand 10 * 20;\h'|3i'# rand (10 * 20)
- rand(10) * 20;\h'|3i'# (rand 10) * 20
- rand (10) * 20;\h'|3i'# (rand 10) * 20
- rand +(10) * 20;\h'|3i'# rand (10 * 20)
-
-.fi
-In the absence of parentheses,
-the precedence of list operators such as print, sort or chmod is
-either very high or very low depending on whether you look at the left
-side of operator or the right side of it.
-For example, in
-.nf
-
- @ary = (1, 3, sort 4, 2);
- print @ary; # prints 1324
-
-.fi
-the commas on the right of the sort are evaluated before the sort, but
-the commas on the left are evaluated after.
-In other words, list operators tend to gobble up all the arguments that
-follow them, and then act like a simple term with regard to the preceding
-expression.
-Note that you have to be careful with parens:
-.nf
-
-.ne 3
- # These evaluate exit before doing the print:
- print($foo, exit); # Obviously not what you want.
- print $foo, exit; # Nor is this.
-
-.ne 4
- # These do the print before evaluating exit:
- (print $foo), exit; # This is what you want.
- print($foo), exit; # Or this.
- print ($foo), exit; # Or even this.
-
-Also note that
-
- print ($foo & 255) + 1, "\en";
-
-.fi
-probably doesn't do what you expect at first glance.
-.Sh "Subroutines"
-A subroutine may be declared as follows:
-.nf
-
- sub NAME BLOCK
-
-.fi
-.PP
-Any arguments passed to the routine come in as array @_,
-that is ($_[0], $_[1], .\|.\|.).
-The array @_ is a local array, but its values are references to the
-actual scalar parameters.
-The return value of the subroutine is the value of the last expression
-evaluated, and can be either an array value or a scalar value.
-Alternately, a return statement may be used to specify the returned value and
-exit the subroutine.
-To create local variables see the
-.I local
-operator.
-.PP
-A subroutine is called using the
-.I do
-operator or the & operator.
-.nf
-
-.ne 12
-Example:
-
- sub MAX {
- local($max) = pop(@_);
- foreach $foo (@_) {
- $max = $foo \|if \|$max < $foo;
- }
- $max;
- }
-
- .\|.\|.
- $bestday = &MAX($mon,$tue,$wed,$thu,$fri);
-
-.ne 21
-Example:
-
- # get a line, combining continuation lines
- # that start with whitespace
- sub get_line {
- $thisline = $lookahead;
- line: while ($lookahead = <STDIN>) {
- if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) {
- $thisline \|.= \|$lookahead;
- }
- else {
- last line;
- }
- }
- $thisline;
- }
-
- $lookahead = <STDIN>; # get first line
- while ($_ = do get_line(\|)) {
- .\|.\|.
- }
-
-.fi
-.nf
-.ne 6
-Use array assignment to a local list to name your formal arguments:
-
- sub maybeset {
- local($key, $value) = @_;
- $foo{$key} = $value unless $foo{$key};
- }
-
-.fi
-This also has the effect of turning call-by-reference into call-by-value,
-since the assignment copies the values.
-.Sp
-Subroutines may be called recursively.
-If a subroutine is called using the & form, the argument list is optional.
-If omitted, no @_ array is set up for the subroutine; the @_ array at the
-time of the call is visible to subroutine instead.
-.nf
-
- do foo(1,2,3); # pass three arguments
- &foo(1,2,3); # the same
-
- do foo(); # pass a null list
- &foo(); # the same
- &foo; # pass no arguments\*(--more efficient
-
-.fi
-.Sh "Passing By Reference"
-Sometimes you don't want to pass the value of an array to a subroutine but
-rather the name of it, so that the subroutine can modify the global copy
-of it rather than working with a local copy.
-In perl you can refer to all the objects of a particular name by prefixing
-the name with a star: *foo.
-When evaluated, it produces a scalar value that represents all the objects
-of that name, including any filehandle, format or subroutine.
-When assigned to within a local() operation, it causes the name mentioned
-to refer to whatever * value was assigned to it.
-Example:
-.nf
-
- sub doubleary {
- local(*someary) = @_;
- foreach $elem (@someary) {
- $elem *= 2;
- }
- }
- do doubleary(*foo);
- do doubleary(*bar);
-
-.fi
-Assignment to *name is currently recommended only inside a local().
-You can actually assign to *name anywhere, but the previous referent of
-*name may be stranded forever.
-This may or may not bother you.
-.Sp
-Note that scalars are already passed by reference, so you can modify scalar
-arguments without using this mechanism by referring explicitly to the $_[nnn]
-in question.
-You can modify all the elements of an array by passing all the elements
-as scalars, but you have to use the * mechanism to push, pop or change the
-size of an array.
-The * mechanism will probably be more efficient in any case.
-.Sp
-Since a *name value contains unprintable binary data, if it is used as
-an argument in a print, or as a %s argument in a printf or sprintf, it
-then has the value '*name', just so it prints out pretty.
-.Sp
-Even if you don't want to modify an array, this mechanism is useful for
-passing multiple arrays in a single LIST, since normally the LIST mechanism
-will merge all the array values so that you can't extract out the
-individual arrays.
-.Sh "Regular Expressions"
-The patterns used in pattern matching are regular expressions such as
-those supplied in the Version 8 regexp routines.
-(In fact, the routines are derived from Henry Spencer's freely redistributable
-reimplementation of the V8 routines.)
-In addition, \ew matches an alphanumeric character (including \*(L"_\*(R") and \eW a nonalphanumeric.
-Word boundaries may be matched by \eb, and non-boundaries by \eB.
-A whitespace character is matched by \es, non-whitespace by \eS.
-A numeric character is matched by \ed, non-numeric by \eD.
-You may use \ew, \es and \ed within character classes.
-Also, \en, \er, \ef, \et and \eNNN have their normal interpretations.
-Within character classes \eb represents backspace rather than a word boundary.
-Alternatives may be separated by |.
-The bracketing construct \|(\ .\|.\|.\ \|) may also be used, in which case \e<digit>
-matches the digit'th substring, where digit can range from 1 to 9.
-(Outside of the pattern, always use $ instead of \e in front of the digit.
-The scope of $<digit> (and $\`, $& and $\')
-extends to the end of the enclosing BLOCK or eval string, or to
-the next pattern match with subexpressions.
-The \e<digit> notation sometimes works outside the current pattern, but should
-not be relied upon.)
-$+ returns whatever the last bracket match matched.
-$& returns the entire matched string.
-($0 used to return the same thing, but not any more.)
-$\` returns everything before the matched string.
-$\' returns everything after the matched string.
-Examples:
-.nf
-
- s/\|^\|([^ \|]*\|) \|*([^ \|]*\|)\|/\|$2 $1\|/; # swap first two words
-
-.ne 5
- if (/\|Time: \|(.\|.\|):\|(.\|.\|):\|(.\|.\|)\|/\|) {
- $hours = $1;
- $minutes = $2;
- $seconds = $3;
- }
-
-.fi
-By default, the ^ character is only guaranteed to match at the beginning
-of the string,
-the $ character only at the end (or before the newline at the end)
-and
-.I perl
-does certain optimizations with the assumption that the string contains
-only one line.
-The behavior of ^ and $ on embedded newlines will be inconsistent.
-You may, however, wish to treat a string as a multi-line buffer, such that
-the ^ will match after any newline within the string, and $ will match
-before any newline.
-At the cost of a little more overhead, you can do this by setting the variable
-$* to 1.
-Setting it back to 0 makes
-.I perl
-revert to its old behavior.
-.PP
-To facilitate multi-line substitutions, the . character never matches a newline
-(even when $* is 0).
-In particular, the following leaves a newline on the $_ string:
-.nf
-
- $_ = <STDIN>;
- s/.*(some_string).*/$1/;
-
-If the newline is unwanted, try one of
-
- s/.*(some_string).*\en/$1/;
- s/.*(some_string)[^\e000]*/$1/;
- s/.*(some_string)(.|\en)*/$1/;
- chop; s/.*(some_string).*/$1/;
- /(some_string)/ && ($_ = $1);
-
-.fi
-Any item of a regular expression may be followed with digits in curly brackets
-of the form {n,m}, where n gives the minimum number of times to match the item
-and m gives the maximum.
-The form {n} is equivalent to {n,n} and matches exactly n times.
-The form {n,} matches n or more times.
-(If a curly bracket occurs in any other context, it is treated as a regular
-character.)
-The * modifier is equivalent to {0,}, the + modifier to {1,} and the ? modifier
-to {0,1}.
-There is no limit to the size of n or m, but large numbers will chew up
-more memory.
-.Sp
-You will note that all backslashed metacharacters in
-.I perl
-are alphanumeric,
-such as \eb, \ew, \en.
-Unlike some other regular expression languages, there are no backslashed
-symbols that aren't alphanumeric.
-So anything that looks like \e\e, \e(, \e), \e<, \e>, \e{, or \e} is always
-interpreted as a literal character, not a metacharacter.
-This makes it simple to quote a string that you want to use for a pattern
-but that you are afraid might contain metacharacters.
-Simply quote all the non-alphanumeric characters:
-.nf
-
- $pattern =~ s/(\eW)/\e\e$1/g;
-
-.fi
-.Sh "Formats"
-Output record formats for use with the
-.I write
-operator may declared as follows:
-.nf
-
-.ne 3
- format NAME =
- FORMLIST
- .
-
-.fi
-If name is omitted, format \*(L"STDOUT\*(R" is defined.
-FORMLIST consists of a sequence of lines, each of which may be of one of three
-types:
-.Ip 1. 4
-A comment.
-.Ip 2. 4
-A \*(L"picture\*(R" line giving the format for one output line.
-.Ip 3. 4
-An argument line supplying values to plug into a picture line.
-.PP
-Picture lines are printed exactly as they look, except for certain fields
-that substitute values into the line.
-Each picture field starts with either @ or ^.
-The @ field (not to be confused with the array marker @) is the normal
-case; ^ fields are used
-to do rudimentary multi-line text block filling.
-The length of the field is supplied by padding out the field
-with multiple <, >, or | characters to specify, respectively, left justification,
-right justification, or centering.
-As an alternate form of right justification,
-you may also use # characters (with an optional .) to specify a numeric field.
-(Use of ^ instead of @ causes the field to be blanked if undefined.)
-If any of the values supplied for these fields contains a newline, only
-the text up to the newline is printed.
-The special field @* can be used for printing multi-line values.
-It should appear by itself on a line.
-.PP
-The values are specified on the following line, in the same order as
-the picture fields.
-The values should be separated by commas.
-.PP
-Picture fields that begin with ^ rather than @ are treated specially.
-The value supplied must be a scalar variable name which contains a text
-string.
-.I Perl
-puts as much text as it can into the field, and then chops off the front
-of the string so that the next time the variable is referenced,
-more of the text can be printed.
-Normally you would use a sequence of fields in a vertical stack to print
-out a block of text.
-If you like, you can end the final field with .\|.\|., which will appear in the
-output if the text was too long to appear in its entirety.
-You can change which characters are legal to break on by changing the
-variable $: to a list of the desired characters.
-.PP
-Since use of ^ fields can produce variable length records if the text to be
-formatted is short, you can suppress blank lines by putting the tilde (~)
-character anywhere in the line.
-(Normally you should put it in the front if possible, for visibility.)
-The tilde will be translated to a space upon output.
-If you put a second tilde contiguous to the first, the line will be repeated
-until all the fields on the line are exhausted.
-(If you use a field of the @ variety, the expression you supply had better
-not give the same value every time forever!)
-.PP
-Examples:
-.nf
-.lg 0
-.cs R 25
-.ft C
-
-.ne 10
-# a report on the /etc/passwd file
-format top =
-\& Passwd File
-Name Login Office Uid Gid Home
-------------------------------------------------------------------
-\&.
-format STDOUT =
-@<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<<
-$name, $login, $office,$uid,$gid, $home
-\&.
-
-.ne 29
-# a report from a bug report form
-format top =
-\& Bug Reports
-@<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>>
-$system, $%, $date
-------------------------------------------------------------------
-\&.
-format STDOUT =
-Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-\& $subject
-Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-\& $index, $description
-Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-\& $priority, $date, $description
-From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-\& $from, $description
-Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-\& $programmer, $description
-\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-\& $description
-\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-\& $description
-\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-\& $description
-\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-\& $description
-\&~ ^<<<<<<<<<<<<<<<<<<<<<<<...
-\& $description
-\&.
-
-.ft R
-.cs R
-.lg
-.fi
-It is possible to intermix prints with writes on the same output channel,
-but you'll have to handle $\- (lines left on the page) yourself.
-.PP
-If you are printing lots of fields that are usually blank, you should consider
-using the reset operator between records.
-Not only is it more efficient, but it can prevent the bug of adding another
-field and forgetting to zero it.
-.Sh "Interprocess Communication"
-The IPC facilities of perl are built on the Berkeley socket mechanism.
-If you don't have sockets, you can ignore this section.
-The calls have the same names as the corresponding system calls,
-but the arguments tend to differ, for two reasons.
-First, perl file handles work differently than C file descriptors.
-Second, perl already knows the length of its strings, so you don't need
-to pass that information.
-Here is a sample client (untested):
-.nf
-
- ($them,$port) = @ARGV;
- $port = 2345 unless $port;
- $them = 'localhost' unless $them;
-
- $SIG{'INT'} = 'dokill';
- sub dokill { kill 9,$child if $child; }
-
- require 'sys/socket.ph';
-
- $sockaddr = 'S n a4 x8';
- chop($hostname = `hostname`);
-
- ($name, $aliases, $proto) = getprotobyname('tcp');
- ($name, $aliases, $port) = getservbyname($port, 'tcp')
- unless $port =~ /^\ed+$/;
-.ie t \{\
- ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname);
-'br\}
-.el \{\
- ($name, $aliases, $type, $len, $thisaddr) =
- gethostbyname($hostname);
-'br\}
- ($name, $aliases, $type, $len, $thataddr) = gethostbyname($them);
-
- $this = pack($sockaddr, &AF_INET, 0, $thisaddr);
- $that = pack($sockaddr, &AF_INET, $port, $thataddr);
-
- socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!";
- bind(S, $this) || die "bind: $!";
- connect(S, $that) || die "connect: $!";
-
- select(S); $| = 1; select(stdout);
-
- if ($child = fork) {
- while (<>) {
- print S;
- }
- sleep 3;
- do dokill();
- }
- else {
- while (<S>) {
- print;
- }
- }
-
-.fi
-And here's a server:
-.nf
-
- ($port) = @ARGV;
- $port = 2345 unless $port;
-
- require 'sys/socket.ph';
-
- $sockaddr = 'S n a4 x8';
-
- ($name, $aliases, $proto) = getprotobyname('tcp');
- ($name, $aliases, $port) = getservbyname($port, 'tcp')
- unless $port =~ /^\ed+$/;
-
- $this = pack($sockaddr, &AF_INET, $port, "\e0\e0\e0\e0");
-
- select(NS); $| = 1; select(stdout);
-
- socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!";
- bind(S, $this) || die "bind: $!";
- listen(S, 5) || die "connect: $!";
-
- select(S); $| = 1; select(stdout);
-
- for (;;) {
- print "Listening again\en";
- ($addr = accept(NS,S)) || die $!;
- print "accept ok\en";
-
- ($af,$port,$inetaddr) = unpack($sockaddr,$addr);
- @inetaddr = unpack('C4',$inetaddr);
- print "$af $port @inetaddr\en";
-
- while (<NS>) {
- print;
- print NS;
- }
- }
-
-.fi
-.Sh "Predefined Names"
-The following names have special meaning to
-.IR perl .
-I could have used alphabetic symbols for some of these, but I didn't want
-to take the chance that someone would say reset \*(L"a\-zA\-Z\*(R" and wipe them all
-out.
-You'll just have to suffer along with these silly symbols.
-Most of them have reasonable mnemonics, or analogues in one of the shells.
-.Ip $_ 8
-The default input and pattern-searching space.
-The following pairs are equivalent:
-.nf
-
-.ne 2
- while (<>) {\|.\|.\|. # only equivalent in while!
- while ($_ = <>) {\|.\|.\|.
-
-.ne 2
- /\|^Subject:/
- $_ \|=~ \|/\|^Subject:/
-
-.ne 2
- y/a\-z/A\-Z/
- $_ =~ y/a\-z/A\-Z/
-
-.ne 2
- chop
- chop($_)
-
-.fi
-(Mnemonic: underline is understood in certain operations.)
-.Ip $. 8
-The current input line number of the last filehandle that was read.
-Readonly.
-Remember that only an explicit close on the filehandle resets the line number.
-Since <> never does an explicit close, line numbers increase across ARGV files
-(but see examples under eof).
-(Mnemonic: many programs use . to mean the current line number.)
-.Ip $/ 8
-The input record separator, newline by default.
-Works like
-.IR awk 's
-RS variable, including treating blank lines as delimiters
-if set to the null string.
-If set to a value longer than one character, only the first character is used.
-(Mnemonic: / is used to delimit line boundaries when quoting poetry.)
-.Ip $, 8
-The output field separator for the print operator.
-Ordinarily the print operator simply prints out the comma separated fields
-you specify.
-In order to get behavior more like
-.IR awk ,
-set this variable as you would set
-.IR awk 's
-OFS variable to specify what is printed between fields.
-(Mnemonic: what is printed when there is a , in your print statement.)
-.Ip $"" 8
-This is like $, except that it applies to array values interpolated into
-a double-quoted string (or similar interpreted string).
-Default is a space.
-(Mnemonic: obvious, I think.)
-.Ip $\e 8
-The output record separator for the print operator.
-Ordinarily the print operator simply prints out the comma separated fields
-you specify, with no trailing newline or record separator assumed.
-In order to get behavior more like
-.IR awk ,
-set this variable as you would set
-.IR awk 's
-ORS variable to specify what is printed at the end of the print.
-(Mnemonic: you set $\e instead of adding \en at the end of the print.
-Also, it's just like /, but it's what you get \*(L"back\*(R" from
-.IR perl .)
-.Ip $# 8
-The output format for printed numbers.
-This variable is a half-hearted attempt to emulate
-.IR awk 's
-OFMT variable.
-There are times, however, when
-.I awk
-and
-.I perl
-have differing notions of what
-is in fact numeric.
-Also, the initial value is %.20g rather than %.6g, so you need to set $#
-explicitly to get
-.IR awk 's
-value.
-(Mnemonic: # is the number sign.)
-.Ip $% 8
-The current page number of the currently selected output channel.
-(Mnemonic: % is page number in nroff.)
-.Ip $= 8
-The current page length (printable lines) of the currently selected output
-channel.
-Default is 60.
-(Mnemonic: = has horizontal lines.)
-.Ip $\- 8
-The number of lines left on the page of the currently selected output channel.
-(Mnemonic: lines_on_page \- lines_printed.)
-.Ip $~ 8
-The name of the current report format for the currently selected output
-channel.
-(Mnemonic: brother to $^.)
-.Ip $^ 8
-The name of the current top-of-page format for the currently selected output
-channel.
-(Mnemonic: points to top of page.)
-.Ip $| 8
-If set to nonzero, forces a flush after every write or print on the currently
-selected output channel.
-Default is 0.
-Note that
-.I STDOUT
-will typically be line buffered if output is to the
-terminal and block buffered otherwise.
-Setting this variable is useful primarily when you are outputting to a pipe,
-such as when you are running a
-.I perl
-script under rsh and want to see the
-output as it's happening.
-(Mnemonic: when you want your pipes to be piping hot.)
-.Ip $$ 8
-The process number of the
-.I perl
-running this script.
-(Mnemonic: same as shells.)
-.Ip $? 8
-The status returned by the last pipe close, backtick (\`\`) command or
-.I system
-operator.
-Note that this is the status word returned by the wait() system
-call, so the exit value of the subprocess is actually ($? >> 8).
-$? & 255 gives which signal, if any, the process died from, and whether
-there was a core dump.
-(Mnemonic: similar to sh and ksh.)
-.Ip $& 8 4
-The string matched by the last pattern match (not counting any matches hidden
-within a BLOCK or eval enclosed by the current BLOCK).
-(Mnemonic: like & in some editors.)
-.Ip $\` 8 4
-The string preceding whatever was matched by the last pattern match
-(not counting any matches hidden within a BLOCK or eval enclosed by the current
-BLOCK).
-(Mnemonic: \` often precedes a quoted string.)
-.Ip $\' 8 4
-The string following whatever was matched by the last pattern match
-(not counting any matches hidden within a BLOCK or eval enclosed by the current
-BLOCK).
-(Mnemonic: \' often follows a quoted string.)
-Example:
-.nf
-
-.ne 3
- $_ = \'abcdefghi\';
- /def/;
- print "$\`:$&:$\'\en"; # prints abc:def:ghi
-
-.fi
-.Ip $+ 8 4
-The last bracket matched by the last search pattern.
-This is useful if you don't know which of a set of alternative patterns
-matched.
-For example:
-.nf
-
- /Version: \|(.*\|)|Revision: \|(.*\|)\|/ \|&& \|($rev = $+);
-
-.fi
-(Mnemonic: be positive and forward looking.)
-.Ip $* 8 2
-Set to 1 to do multiline matching within a string, 0 to tell
-.I perl
-that it can assume that strings contain a single line, for the purpose
-of optimizing pattern matches.
-Pattern matches on strings containing multiple newlines can produce confusing
-results when $* is 0.
-Default is 0.
-(Mnemonic: * matches multiple things.)
-Note that this variable only influences the interpretation of ^ and $.
-A literal newline can be searched for even when $* == 0.
-.Ip $0 8
-Contains the name of the file containing the
-.I perl
-script being executed.
-(Mnemonic: same as sh and ksh.)
-.Ip $<digit> 8
-Contains the subpattern from the corresponding set of parentheses in the last
-pattern matched, not counting patterns matched in nested blocks that have
-been exited already.
-(Mnemonic: like \edigit.)
-.Ip $[ 8 2
-The index of the first element in an array, and of the first character in
-a substring.
-Default is 0, but you could set it to 1 to make
-.I perl
-behave more like
-.I awk
-(or Fortran)
-when subscripting and when evaluating the index() and substr() functions.
-(Mnemonic: [ begins subscripts.)
-.Ip $] 8 2
-The string printed out when you say \*(L"perl -v\*(R".
-It can be used to determine at the beginning of a script whether the perl
-interpreter executing the script is in the right range of versions.
-If used in a numeric context, returns the version + patchlevel / 1000.
-Example:
-.nf
-
-.ne 8
- # see if getc is available
- ($version,$patchlevel) =
- $] =~ /(\ed+\e.\ed+).*\enPatch level: (\ed+)/;
- print STDERR "(No filename completion available.)\en"
- if $version * 1000 + $patchlevel < 2016;
-
-or, used numerically,
-
- warn "No checksumming!\en" if $] < 3.019;
-
-.fi
-(Mnemonic: Is this version of perl in the right bracket?)
-.Ip $; 8 2
-The subscript separator for multi-dimensional array emulation.
-If you refer to an associative array element as
-.nf
- $foo{$a,$b,$c}
-
-it really means
-
- $foo{join($;, $a, $b, $c)}
-
-But don't put
-
- @foo{$a,$b,$c} # a slice\*(--note the @
-
-which means
-
- ($foo{$a},$foo{$b},$foo{$c})
-
-.fi
-Default is "\e034", the same as SUBSEP in
-.IR awk .
-Note that if your keys contain binary data there might not be any safe
-value for $;.
-(Mnemonic: comma (the syntactic subscript separator) is a semi-semicolon.
-Yeah, I know, it's pretty lame, but $, is already taken for something more
-important.)
-.Ip $! 8 2
-If used in a numeric context, yields the current value of errno, with all the
-usual caveats.
-(This means that you shouldn't depend on the value of $! to be anything
-in particular unless you've gotten a specific error return indicating a
-system error.)
-If used in a string context, yields the corresponding system error string.
-You can assign to $! in order to set errno
-if, for instance, you want $! to return the string for error n, or you want
-to set the exit value for the die operator.
-(Mnemonic: What just went bang?)
-.Ip $@ 8 2
-The perl syntax error message from the last eval command.
-If null, the last eval parsed and executed correctly (although the operations
-you invoked may have failed in the normal fashion).
-(Mnemonic: Where was the syntax error \*(L"at\*(R"?)
-.Ip $< 8 2
-The real uid of this process.
-(Mnemonic: it's the uid you came FROM, if you're running setuid.)
-.Ip $> 8 2
-The effective uid of this process.
-Example:
-.nf
-
-.ne 2
- $< = $>; # set real uid to the effective uid
- ($<,$>) = ($>,$<); # swap real and effective uid
-
-.fi
-(Mnemonic: it's the uid you went TO, if you're running setuid.)
-Note: $< and $> can only be swapped on machines supporting setreuid().
-.Ip $( 8 2
-The real gid of this process.
-If you are on a machine that supports membership in multiple groups
-simultaneously, gives a space separated list of groups you are in.
-The first number is the one returned by getgid(), and the subsequent ones
-by getgroups(), one of which may be the same as the first number.
-(Mnemonic: parentheses are used to GROUP things.
-The real gid is the group you LEFT, if you're running setgid.)
-.Ip $) 8 2
-The effective gid of this process.
-If you are on a machine that supports membership in multiple groups
-simultaneously, gives a space separated list of groups you are in.
-The first number is the one returned by getegid(), and the subsequent ones
-by getgroups(), one of which may be the same as the first number.
-(Mnemonic: parentheses are used to GROUP things.
-The effective gid is the group that's RIGHT for you, if you're running setgid.)
-.Sp
-Note: $<, $>, $( and $) can only be set on machines that support the
-corresponding set[re][ug]id() routine.
-$( and $) can only be swapped on machines supporting setregid().
-.Ip $: 8 2
-The current set of characters after which a string may be broken to
-fill continuation fields (starting with ^) in a format.
-Default is "\ \en-", to break on whitespace or hyphens.
-(Mnemonic: a \*(L"colon\*(R" in poetry is a part of a line.)
-.Ip $ARGV 8 3
-contains the name of the current file when reading from <>.
-.Ip @ARGV 8 3
-The array ARGV contains the command line arguments intended for the script.
-Note that $#ARGV is the generally number of arguments minus one, since
-$ARGV[0] is the first argument, NOT the command name.
-See $0 for the command name.
-.Ip @INC 8 3
-The array INC contains the list of places to look for
-.I perl
-scripts to be
-evaluated by the \*(L"do EXPR\*(R" command or the \*(L"require\*(R" command.
-It initially consists of the arguments to any
-.B \-I
-command line switches, followed
-by the default
-.I perl
-library, probably \*(L"/usr/local/lib/perl\*(R",
-followed by \*(L".\*(R", to represent the current directory.
-.Ip %INC 8 3
-The associative array INC contains entries for each filename that has
-been included via \*(L"do\*(R" or \*(L"require\*(R".
-The key is the filename you specified, and the value is the location of
-the file actually found.
-The \*(L"require\*(R" command uses this array to determine whether
-a given file has already been included.
-.Ip $ENV{expr} 8 2
-The associative array ENV contains your current environment.
-Setting a value in ENV changes the environment for child processes.
-.Ip $SIG{expr} 8 2
-The associative array SIG is used to set signal handlers for various signals.
-Example:
-.nf
-
-.ne 12
- sub handler { # 1st argument is signal name
- local($sig) = @_;
- print "Caught a SIG$sig\-\|\-shutting down\en";
- close(LOG);
- exit(0);
- }
-
- $SIG{\'INT\'} = \'handler\';
- $SIG{\'QUIT\'} = \'handler\';
- .\|.\|.
- $SIG{\'INT\'} = \'DEFAULT\'; # restore default action
- $SIG{\'QUIT\'} = \'IGNORE\'; # ignore SIGQUIT
-
-.fi
-The SIG array only contains values for the signals actually set within
-the perl script.
-.Sh "Packages"
-Perl provides a mechanism for alternate namespaces to protect packages from
-stomping on each others variables.
-By default, a perl script starts compiling into the package known as \*(L"main\*(R".
-By use of the
-.I package
-declaration, you can switch namespaces.
-The scope of the package declaration is from the declaration itself to the end
-of the enclosing block (the same scope as the local() operator).
-Typically it would be the first declaration in a file to be included by
-the \*(L"require\*(R" operator.
-You can switch into a package in more than one place; it merely influences
-which symbol table is used by the compiler for the rest of that block.
-You can refer to variables and filehandles in other packages by prefixing
-the identifier with the package name and a single quote.
-If the package name is null, the \*(L"main\*(R" package as assumed.
-.PP
-Only identifiers starting with letters are stored in the packages symbol
-table.
-All other symbols are kept in package \*(L"main\*(R".
-In addition, the identifiers STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV, INC
-and SIG are forced to be in package \*(L"main\*(R", even when used for
-other purposes than their built-in one.
-Note also that, if you have a package called \*(L"m\*(R", \*(L"s\*(R"
-or \*(L"y\*(R", the you can't use the qualified form of an identifier since it
-will be interpreted instead as a pattern match, a substitution
-or a translation.
-.PP
-Eval'ed strings are compiled in the package in which the eval was compiled
-in.
-(Assignments to $SIG{}, however, assume the signal handler specified is in the
-main package.
-Qualify the signal handler name if you wish to have a signal handler in
-a package.)
-For an example, examine perldb.pl in the perl library.
-It initially switches to the DB package so that the debugger doesn't interfere
-with variables in the script you are trying to debug.
-At various points, however, it temporarily switches back to the main package
-to evaluate various expressions in the context of the main package.
-.PP
-The symbol table for a package happens to be stored in the associative array
-of that name prepended with an underscore.
-The value in each entry of the associative array is
-what you are referring to when you use the *name notation.
-In fact, the following have the same effect (in package main, anyway),
-though the first is more
-efficient because it does the symbol table lookups at compile time:
-.nf
-
-.ne 2
- local(*foo) = *bar;
- local($_main{'foo'}) = $_main{'bar'};
-
-.fi
-You can use this to print out all the variables in a package, for instance.
-Here is dumpvar.pl from the perl library:
-.nf
-.ne 11
- package dumpvar;
-
- sub main'dumpvar {
- \& ($package) = @_;
- \& local(*stab) = eval("*_$package");
- \& while (($key,$val) = each(%stab)) {
- \& {
- \& local(*entry) = $val;
- \& if (defined $entry) {
- \& print "\e$$key = '$entry'\en";
- \& }
-.ne 7
- \& if (defined @entry) {
- \& print "\e@$key = (\en";
- \& foreach $num ($[ .. $#entry) {
- \& print " $num\et'",$entry[$num],"'\en";
- \& }
- \& print ")\en";
- \& }
-.ne 10
- \& if ($key ne "_$package" && defined %entry) {
- \& print "\e%$key = (\en";
- \& foreach $key (sort keys(%entry)) {
- \& print " $key\et'",$entry{$key},"'\en";
- \& }
- \& print ")\en";
- \& }
- \& }
- \& }
- }
-
-.fi
-Note that, even though the subroutine is compiled in package dumpvar, the
-name of the subroutine is qualified so that its name is inserted into package
-\*(L"main\*(R".
-.Sh "Style"
-Each programmer will, of course, have his or her own preferences in regards
-to formatting, but there are some general guidelines that will make your
-programs easier to read.
-.Ip 1. 4 4
-Just because you CAN do something a particular way doesn't mean that
-you SHOULD do it that way.
-.I Perl
-is designed to give you several ways to do anything, so consider picking
-the most readable one.
-For instance
-
- open(FOO,$foo) || die "Can't open $foo: $!";
-
-is better than
-
- die "Can't open $foo: $!" unless open(FOO,$foo);
-
-because the second way hides the main point of the statement in a
-modifier.
-On the other hand
-
- print "Starting analysis\en" if $verbose;
-
-is better than
-
- $verbose && print "Starting analysis\en";
-
-since the main point isn't whether the user typed -v or not.
-.Sp
-Similarly, just because an operator lets you assume default arguments
-doesn't mean that you have to make use of the defaults.
-The defaults are there for lazy systems programmers writing one-shot
-programs.
-If you want your program to be readable, consider supplying the argument.
-.Sp
-Along the same lines, just because you
-.I can
-omit parentheses in many places doesn't mean that you ought to:
-.nf
-
- return print reverse sort num values array;
- return print(reverse(sort num (values(%array))));
-
-.fi
-When in doubt, parenthesize.
-At the very least it will let some poor schmuck bounce on the % key in vi.
-.Sp
-Even if you aren't in doubt, consider the mental welfare of the person who
-has to maintain the code after you, and who will probably put parens in
-the wrong place.
-.Ip 2. 4 4
-Don't go through silly contortions to exit a loop at the top or the
-bottom, when
-.I perl
-provides the "last" operator so you can exit in the middle.
-Just outdent it a little to make it more visible:
-.nf
-
-.ne 7
- line:
- for (;;) {
- statements;
- last line if $foo;
- next line if /^#/;
- statements;
- }
-
-.fi
-.Ip 3. 4 4
-Don't be afraid to use loop labels\*(--they're there to enhance readability as
-well as to allow multi-level loop breaks.
-See last example.
-.Ip 4. 4 4
-For portability, when using features that may not be implemented on every
-machine, test the construct in an eval to see if it fails.
-If you know what version or patchlevel a particular feature was implemented,
-you can test $] to see if it will be there.
-.Ip 5. 4 4
-Choose mnemonic identifiers.
-.Ip 6. 4 4
-Be consistent.
-.Sh "Debugging"
-If you invoke
-.I perl
-with a
-.B \-d
-switch, your script will be run under a debugging monitor.
-It will halt before the first executable statement and ask you for a
-command, such as:
-.Ip "h" 12 4
-Prints out a help message.
-.Ip "T" 12 4
-Stack trace.
-.Ip "s" 12 4
-Single step.
-Executes until it reaches the beginning of another statement.
-.Ip "n" 12 4
-Next.
-Executes over subroutine calls, until it reaches the beginning of the
-next statement.
-.Ip "f" 12 4
-Finish.
-Executes statements until it has finished the current subroutine.
-.Ip "c" 12 4
-Continue.
-Executes until the next breakpoint is reached.
-.Ip "c line" 12 4
-Continue to the specified line.
-Inserts a one-time-only breakpoint at the specified line.
-.Ip "<CR>" 12 4
-Repeat last n or s.
-.Ip "l min+incr" 12 4
-List incr+1 lines starting at min.
-If min is omitted, starts where last listing left off.
-If incr is omitted, previous value of incr is used.
-.Ip "l min-max" 12 4
-List lines in the indicated range.
-.Ip "l line" 12 4
-List just the indicated line.
-.Ip "l" 12 4
-List next window.
-.Ip "-" 12 4
-List previous window.
-.Ip "w line" 12 4
-List window around line.
-.Ip "l subname" 12 4
-List subroutine.
-If it's a long subroutine it just lists the beginning.
-Use \*(L"l\*(R" to list more.
-.Ip "/pattern/" 12 4
-Regular expression search forward for pattern; the final / is optional.
-.Ip "?pattern?" 12 4
-Regular expression search backward for pattern; the final ? is optional.
-.Ip "L" 12 4
-List lines that have breakpoints or actions.
-.Ip "S" 12 4
-Lists the names of all subroutines.
-.Ip "t" 12 4
-Toggle trace mode on or off.
-.Ip "b line condition" 12 4
-Set a breakpoint.
-If line is omitted, sets a breakpoint on the
-line that is about to be executed.
-If a condition is specified, it is evaluated each time the statement is
-reached and a breakpoint is taken only if the condition is true.
-Breakpoints may only be set on lines that begin an executable statement.
-.Ip "b subname condition" 12 4
-Set breakpoint at first executable line of subroutine.
-.Ip "d line" 12 4
-Delete breakpoint.
-If line is omitted, deletes the breakpoint on the
-line that is about to be executed.
-.Ip "D" 12 4
-Delete all breakpoints.
-.Ip "a line command" 12 4
-Set an action for line.
-A multi-line command may be entered by backslashing the newlines.
-.Ip "A" 12 4
-Delete all line actions.
-.Ip "< command" 12 4
-Set an action to happen before every debugger prompt.
-A multi-line command may be entered by backslashing the newlines.
-.Ip "> command" 12 4
-Set an action to happen after the prompt when you've just given a command
-to return to executing the script.
-A multi-line command may be entered by backslashing the newlines.
-.Ip "V package" 12 4
-List all variables in package.
-Default is main package.
-.Ip "! number" 12 4
-Redo a debugging command.
-If number is omitted, redoes the previous command.
-.Ip "! -number" 12 4
-Redo the command that was that many commands ago.
-.Ip "H -number" 12 4
-Display last n commands.
-Only commands longer than one character are listed.
-If number is omitted, lists them all.
-.Ip "q or ^D" 12 4
-Quit.
-.Ip "command" 12 4
-Execute command as a perl statement.
-A missing semicolon will be supplied.
-.Ip "p expr" 12 4
-Same as \*(L"print DB'OUT expr\*(R".
-The DB'OUT filehandle is opened to /dev/tty, regardless of where STDOUT
-may be redirected to.
-.PP
-If you want to modify the debugger, copy perldb.pl from the perl library
-to your current directory and modify it as necessary.
-(You'll also have to put -I. on your command line.)
-You can do some customization by setting up a .perldb file which contains
-initialization code.
-For instance, you could make aliases like these:
-.nf
-
- $DB'alias{'len'} = 's/^len(.*)/p length($1)/';
- $DB'alias{'stop'} = 's/^stop (at|in)/b/';
- $DB'alias{'.'} =
- 's/^\e./p "\e$DB\e'sub(\e$DB\e'line):\et",\e$DB\e'line[\e$DB\e'line]/';
-
-.fi
-.Sh "Setuid Scripts"
-.I Perl
-is designed to make it easy to write secure setuid and setgid scripts.
-Unlike shells, which are based on multiple substitution passes on each line
-of the script,
-.I perl
-uses a more conventional evaluation scheme with fewer hidden \*(L"gotchas\*(R".
-Additionally, since the language has more built-in functionality, it
-has to rely less upon external (and possibly untrustworthy) programs to
-accomplish its purposes.
-.PP
-In an unpatched 4.2 or 4.3bsd kernel, setuid scripts are intrinsically
-insecure, but this kernel feature can be disabled.
-If it is,
-.I perl
-can emulate the setuid and setgid mechanism when it notices the otherwise
-useless setuid/gid bits on perl scripts.
-If the kernel feature isn't disabled,
-.I perl
-will complain loudly that your setuid script is insecure.
-You'll need to either disable the kernel setuid script feature, or put
-a C wrapper around the script.
-.PP
-When perl is executing a setuid script, it takes special precautions to
-prevent you from falling into any obvious traps.
-(In some ways, a perl script is more secure than the corresponding
-C program.)
-Any command line argument, environment variable, or input is marked as
-\*(L"tainted\*(R", and may not be used, directly or indirectly, in any
-command that invokes a subshell, or in any command that modifies files,
-directories or processes.
-Any variable that is set within an expression that has previously referenced
-a tainted value also becomes tainted (even if it is logically impossible
-for the tainted value to influence the variable).
-For example:
-.nf
-
-.ne 5
- $foo = shift; # $foo is tainted
- $bar = $foo,\'bar\'; # $bar is also tainted
- $xxx = <>; # Tainted
- $path = $ENV{\'PATH\'}; # Tainted, but see below
- $abc = \'abc\'; # Not tainted
-
-.ne 4
- system "echo $foo"; # Insecure
- system "/bin/echo", $foo; # Secure (doesn't use sh)
- system "echo $bar"; # Insecure
- system "echo $abc"; # Insecure until PATH set
-
-.ne 5
- $ENV{\'PATH\'} = \'/bin:/usr/bin\';
- $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\';
-
- $path = $ENV{\'PATH\'}; # Not tainted
- system "echo $abc"; # Is secure now!
-
-.ne 5
- open(FOO,"$foo"); # OK
- open(FOO,">$foo"); # Not OK
-
- open(FOO,"echo $foo|"); # Not OK, but...
- open(FOO,"-|") || exec \'echo\', $foo; # OK
-
- $zzz = `echo $foo`; # Insecure, zzz tainted
-
- unlink $abc,$foo; # Insecure
- umask $foo; # Insecure
-
-.ne 3
- exec "echo $foo"; # Insecure
- exec "echo", $foo; # Secure (doesn't use sh)
- exec "sh", \'-c\', $foo; # Considered secure, alas
-
-.fi
-The taintedness is associated with each scalar value, so some elements
-of an array can be tainted, and others not.
-.PP
-If you try to do something insecure, you will get a fatal error saying
-something like \*(L"Insecure dependency\*(R" or \*(L"Insecure PATH\*(R".
-Note that you can still write an insecure system call or exec,
-but only by explicitly doing something like the last example above.
-You can also bypass the tainting mechanism by referencing
-subpatterns\*(--\c
-.I perl
-presumes that if you reference a substring using $1, $2, etc, you knew
-what you were doing when you wrote the pattern:
-.nf
-
- $ARGV[0] =~ /^\-P(\ew+)$/;
- $printer = $1; # Not tainted
-
-.fi
-This is fairly secure since \ew+ doesn't match shell metacharacters.
-Use of .+ would have been insecure, but
-.I perl
-doesn't check for that, so you must be careful with your patterns.
-This is the ONLY mechanism for untainting user supplied filenames if you
-want to do file operations on them (unless you make $> equal to $<).
-.PP
-It's also possible to get into trouble with other operations that don't care
-whether they use tainted values.
-Make judicious use of the file tests in dealing with any user-supplied
-filenames.
-When possible, do opens and such after setting $> = $<.
-.I Perl
-doesn't prevent you from opening tainted filenames for reading, so be
-careful what you print out.
-The tainting mechanism is intended to prevent stupid mistakes, not to remove
-the need for thought.
-.SH ENVIRONMENT
-.I Perl
-uses PATH in executing subprocesses, and in finding the script if \-S
-is used.
-HOME or LOGDIR are used if chdir has no argument.
-.PP
-Apart from these,
-.I perl
-uses no environment variables, except to make them available
-to the script being executed, and to child processes.
-However, scripts running setuid would do well to execute the following lines
-before doing anything else, just to keep people honest:
-.nf
-
-.ne 3
- $ENV{\'PATH\'} = \'/bin:/usr/bin\'; # or whatever you need
- $ENV{\'SHELL\'} = \'/bin/sh\' if $ENV{\'SHELL\'} ne \'\';
- $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\';
-
-.fi
-.SH AUTHOR
-Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
-.br
-MS-DOS port by Diomidis Spinellis <dds@cc.ic.ac.uk>
-.SH FILES
-/tmp/perl\-eXXXXXX temporary file for
-.B \-e
-commands.
-.SH SEE ALSO
-a2p awk to perl translator
-.br
-s2p sed to perl translator
-.SH DIAGNOSTICS
-Compilation errors will tell you the line number of the error, with an
-indication of the next token or token type that was to be examined.
-(In the case of a script passed to
-.I perl
-via
-.B \-e
-switches, each
-.B \-e
-is counted as one line.)
-.PP
-Setuid scripts have additional constraints that can produce error messages
-such as \*(L"Insecure dependency\*(R".
-See the section on setuid scripts.
-.SH TRAPS
-Accustomed
-.IR awk
-users should take special note of the following:
-.Ip * 4 2
-Semicolons are required after all simple statements in
-.IR perl .
-Newline
-is not a statement delimiter.
-.Ip * 4 2
-Curly brackets are required on ifs and whiles.
-.Ip * 4 2
-Variables begin with $ or @ in
-.IR perl .
-.Ip * 4 2
-Arrays index from 0 unless you set $[.
-Likewise string positions in substr() and index().
-.Ip * 4 2
-You have to decide whether your array has numeric or string indices.
-.Ip * 4 2
-Associative array values do not spring into existence upon mere reference.
-.Ip * 4 2
-You have to decide whether you want to use string or numeric comparisons.
-.Ip * 4 2
-Reading an input line does not split it for you. You get to split it yourself
-to an array.
-And the
-.I split
-operator has different arguments.
-.Ip * 4 2
-The current input line is normally in $_, not $0.
-It generally does not have the newline stripped.
-($0 is the name of the program executed.)
-.Ip * 4 2
-$<digit> does not refer to fields\*(--it refers to substrings matched by the last
-match pattern.
-.Ip * 4 2
-The
-.I print
-statement does not add field and record separators unless you set
-$, and $\e.
-.Ip * 4 2
-You must open your files before you print to them.
-.Ip * 4 2
-The range operator is \*(L".\|.\*(R", not comma.
-(The comma operator works as in C.)
-.Ip * 4 2
-The match operator is \*(L"=~\*(R", not \*(L"~\*(R".
-(\*(L"~\*(R" is the one's complement operator, as in C.)
-.Ip * 4 2
-The exponentiation operator is \*(L"**\*(R", not \*(L"^\*(R".
-(\*(L"^\*(R" is the XOR operator, as in C.)
-.Ip * 4 2
-The concatenation operator is \*(L".\*(R", not the null string.
-(Using the null string would render \*(L"/pat/ /pat/\*(R" unparsable,
-since the third slash would be interpreted as a division operator\*(--the
-tokener is in fact slightly context sensitive for operators like /, ?, and <.
-And in fact, . itself can be the beginning of a number.)
-.Ip * 4 2
-.IR Next ,
-.I exit
-and
-.I continue
-work differently.
-.Ip * 4 2
-The following variables work differently
-.nf
-
- Awk \h'|2.5i'Perl
- ARGC \h'|2.5i'$#ARGV
- ARGV[0] \h'|2.5i'$0
- FILENAME\h'|2.5i'$ARGV
- FNR \h'|2.5i'$. \- something
- FS \h'|2.5i'(whatever you like)
- NF \h'|2.5i'$#Fld, or some such
- NR \h'|2.5i'$.
- OFMT \h'|2.5i'$#
- OFS \h'|2.5i'$,
- ORS \h'|2.5i'$\e
- RLENGTH \h'|2.5i'length($&)
- RS \h'|2.5i'$/
- RSTART \h'|2.5i'length($\`)
- SUBSEP \h'|2.5i'$;
-
-.fi
-.Ip * 4 2
-When in doubt, run the
-.I awk
-construct through a2p and see what it gives you.
-.PP
-Cerebral C programmers should take note of the following:
-.Ip * 4 2
-Curly brackets are required on ifs and whiles.
-.Ip * 4 2
-You should use \*(L"elsif\*(R" rather than \*(L"else if\*(R"
-.Ip * 4 2
-.I Break
-and
-.I continue
-become
-.I last
-and
-.IR next ,
-respectively.
-.Ip * 4 2
-There's no switch statement.
-.Ip * 4 2
-Variables begin with $ or @ in
-.IR perl .
-.Ip * 4 2
-Printf does not implement *.
-.Ip * 4 2
-Comments begin with #, not /*.
-.Ip * 4 2
-You can't take the address of anything.
-.Ip * 4 2
-ARGV must be capitalized.
-.Ip * 4 2
-The \*(L"system\*(R" calls link, unlink, rename, etc. return nonzero for success, not 0.
-.Ip * 4 2
-Signal handlers deal with signal names, not numbers.
-.PP
-Seasoned
-.I sed
-programmers should take note of the following:
-.Ip * 4 2
-Backreferences in substitutions use $ rather than \e.
-.Ip * 4 2
-The pattern matching metacharacters (, ), and | do not have backslashes in front.
-.Ip * 4 2
-The range operator is .\|. rather than comma.
-.PP
-Sharp shell programmers should take note of the following:
-.Ip * 4 2
-The backtick operator does variable interpretation without regard to the
-presence of single quotes in the command.
-.Ip * 4 2
-The backtick operator does no translation of the return value, unlike csh.
-.Ip * 4 2
-Shells (especially csh) do several levels of substitution on each command line.
-.I Perl
-does substitution only in certain constructs such as double quotes,
-backticks, angle brackets and search patterns.
-.Ip * 4 2
-Shells interpret scripts a little bit at a time.
-.I Perl
-compiles the whole program before executing it.
-.Ip * 4 2
-The arguments are available via @ARGV, not $1, $2, etc.
-.Ip * 4 2
-The environment is not automatically made available as variables.
-.SH ERRATA\0AND\0ADDENDA
-The Perl book,
-.I Programming\0Perl ,
-has the following omissions and goofs.
-.PP
-The
-.B \-0
-switch was added to Perl after the book went to press.
-.PP
-The new @###.## format was omitted accidentally.
-.PP
-It wasn't known at press time that s///ee caused multiple evaluations.
-.SH BUGS
-.PP
-.I Perl
-is at the mercy of your machine's definitions of various operations
-such as type casting, atof() and sprintf().
-.PP
-If your stdio requires an seek or eof between reads and writes on a particular
-stream, so does
-.IR perl .
-.PP
-While none of the built-in data types have any arbitrary size limits (apart
-from memory size), there are still a few arbitrary limits:
-a given identifier may not be longer than 255 characters;
-sprintf is limited on many machines to 128 characters per field (unless the format
-specifier is exactly %s);
-and no component of your PATH may be longer than 255 if you use \-S.
-.PP
-.I Perl
-actually stands for Pathologically Eclectic Rubbish Lister, but don't tell
-anyone I said that.
-.rn }` ''
--- /dev/null
+#!/bin/sh
+
+input=$1
+output=$2
+tmp=/tmp/f$$
+
+egrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];
+short[ ]*yys\[ *YYMAXDEPTH *\] *;
+yyps *= *&yys\[ *-1 *\];
+yypv *= *&yyv\[ *-1 *\];
+if *\( *\+\+yyps *> *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
+set `wc -l $tmp`
+
+case "$1" in
+5) echo "Patching perly.c to allow dynamic yacc stack allocation";;
+*) mv $input $output; rm -f $tmp; exit;;
+esac
+
+cat >$tmp <<'END'
+/YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];/c\
+int yymaxdepth = YYMAXDEPTH;\
+YYSTYPE *yyv; /* where the values are stored */\
+short *yys;\
+short *maxyyps;
+
+/short[ ]*yys\[ *YYMAXDEPTH *\] *;/d
+
+/yyps *= *&yys\[ *-1 *\];/d
+
+/yypv *= *&yyv\[ *-1 *\];/c\
+\ if (!yyv) {\
+\ yyv = (YYSTYPE*) malloc(yymaxdepth * sizeof(YYSTYPE));\
+\ yys = (short*) malloc(yymaxdepth * sizeof(short));\
+\ maxyyps = &yys[yymaxdepth];\
+\ }\
+\ yyps = &yys[-1];\
+\ yypv = &yyv[-1];
+
+
+/if *( *\+\+yyps *> *&yys\[ *YYMAXDEPTH *\] *)/c\
+\ if( ++yyps >= maxyyps ) {\
+\ int tv = yypv - yyv;\
+\ int ts = yyps - yys;\
+\
+\ yymaxdepth *= 2;\
+\ yyv = (YYSTYPE*)realloc((char*)yyv,\
+\ yymaxdepth*sizeof(YYSTYPE));\
+\ yys = (short*)realloc((char*)yys,\
+\ yymaxdepth*sizeof(short));\
+\ yyps = yys + ts;\
+\ yypv = yyv + tv;\
+\ maxyyps = &yys[yymaxdepth];\
+\ }
+
+/yacc stack overflow.*}/d
+/yacc stack overflow/,/}/d
+END
+
+sed -f $tmp <$input >$output
+rm -rf $tmp $input
-/* $Header: perl.y,v 3.0.1.11 91/01/11 21:57:40 lwall Locked $
+/* $Header: perly.y,v 4.0 91/03/20 01:38:40 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* You may distribute under the terms of the GNU General Public License
* as specified in the README file that comes with the perl 3.0 kit.
*
- * $Log: perl.y,v $
- * Revision 3.0.1.11 91/01/11 21:57:40 lwall
- * patch42: addendum
- *
- * Revision 3.0.1.10 91/01/11 18:14:28 lwall
- * patch42: package didn't create symbol tables that could be reset
- * patch42: split with no arguments could wipe out next operator
- *
- * Revision 3.0.1.9 90/10/15 18:01:45 lwall
- * patch29: added SysV IPC
- * patch29: package behavior is now more consistent
- * patch29: index and substr now have optional 3rd args
- *
- * Revision 3.0.1.8 90/08/13 22:19:55 lwall
- * patch28: lowercase unquoted strings caused infinite loop
- *
- * Revision 3.0.1.7 90/08/09 04:17:44 lwall
- * patch19: did preliminary work toward debugging packages and evals
- * patch19: added require operator
- * patch19: bare identifiers are now strings if no other interpretation possible
- * patch19: null-label lines threw off line number of next statement
- * patch19: split; didn't pass correct bufend to scanpat
- *
- * Revision 3.0.1.6 90/03/27 16:13:45 lwall
- * patch16: formats didn't work inside eval
- *
- * Revision 3.0.1.5 90/03/12 16:55:56 lwall
- * patch13: added list slice operator (LIST)[LIST]
- * patch13: (LIST,) now legal
- *
- * Revision 3.0.1.4 90/02/28 18:03:23 lwall
- * patch9: line numbers were bogus during certain portions of foreach evaluation
- *
- * Revision 3.0.1.3 89/12/21 20:13:41 lwall
- * patch7: send() didn't allow a TO argument
- *
- * Revision 3.0.1.2 89/11/11 04:49:04 lwall
- * patch2: moved yydebug to where its type doesn't matter
- * patch2: !$foo++ was unreasonably illegal
- * patch2: local(@foo) didn't work
- * patch2: default args to unary operators didn't work
- *
- * Revision 3.0.1.1 89/10/26 23:20:41 lwall
- * patch1: grandfathered "format stdout"
- * patch1: operator(); is now normally equivalent to operator;
- *
- * Revision 3.0 89/10/18 15:22:04 lwall
- * 3.0 baseline
+ * $Log: perly.y,v $
+ * Revision 4.0 91/03/20 01:38:40 lwall
+ * 4.0 baseline.
*
*/
make_form(stabent("STDERR",TRUE),$4);
else
make_form(stabent($2,TRUE),$4);
- Safefree($2);}
+ Safefree($2); $2 = Nullch; }
| FORMAT '=' FORMLIST
{ make_form(stabent("STDOUT",TRUE),$3); }
;
if (!curstash->tbl_name)
curstash->tbl_name = savestr($2);
curstash->tbl_coeffsize = 0;
- Safefree($2);
+ Safefree($2); $2 = Nullch;
cmdline = NOLINE;
}
;
| sexpr POW sexpr
{ $$ = make_op(O_POW, 2, $1, $3, Nullarg); }
| sexpr MULOP sexpr
- { $$ = make_op($2, 2, $1, $3, Nullarg); }
+ { 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
localize(listish(make_list($3))),
Nullarg,Nullarg))); }
| '(' expr ',' ')'
- { $$ = make_list(hide_ary($2)); }
+ { $$ = make_list($2); }
| '(' expr ')'
- { $$ = make_list(hide_ary($2)); }
+ { $$ = make_list($2); }
| '(' ')'
{ $$ = make_list(Nullarg); }
| DO sexpr %prec FILETEST
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)),
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_WORD,stabent($2,TRUE)),
make_list($4),
- Nullarg); Safefree($2); }
+ Nullarg); Safefree($2); $2 = Nullch;
+ $$->arg_flags |= AF_DEPR; }
| AMPER WORD '(' expr ')'
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_WORD,stabent($2,TRUE)),
make_list($4),
- Nullarg); Safefree($2); }
+ Nullarg); Safefree($2); $2 = Nullch; }
| DO WORD '(' ')'
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_WORD,stabent($2,TRUE)),
make_list(Nullarg),
- Nullarg); }
+ Nullarg);
+ $$->arg_flags |= AF_DEPR; }
| AMPER WORD '(' ')'
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_WORD,stabent($2,TRUE)),
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_STAB,$2),
make_list($4),
- Nullarg); }
+ Nullarg);
+ $$->arg_flags |= AF_DEPR; }
| AMPER REG '(' expr ')'
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_STAB,$2),
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_STAB,$2),
make_list(Nullarg),
- Nullarg); }
+ Nullarg);
+ $$->arg_flags |= AF_DEPR; }
| AMPER REG '(' ')'
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_STAB,$2),
{ $$ = make_op($1, 1,
stab2arg(A_WORD,stabent($2,TRUE)),
Nullarg, Nullarg);
- Safefree($2); }
+ Safefree($2); $2 = Nullch; }
| FILOP REG
{ $$ = make_op($1, 1,
stab2arg(A_STAB,$2),
{ $$ = make_op($1,2,
stab2arg(A_WORD,stabent($2,TRUE)),
maybelistish($1,make_list($3)),
- Nullarg); Safefree($2); }
+ Nullarg); Safefree($2); $2 = Nullch; }
| LISTOP REG expr
{ $$ = make_op($1,2,
stab2arg(A_STAB,$2),
;
handle : WORD
- { $$ = stab2arg(A_WORD,stabent($1,TRUE)); Safefree($1);}
+ { $$ = stab2arg(A_WORD,stabent($1,TRUE));
+ Safefree($1); $1 = Nullch;}
| sexpr
;
aryword : WORD
{ $$ = stab2arg(A_WORD,aadd(stabent($1,TRUE)));
- Safefree($1); }
+ Safefree($1); $1 = Nullch; }
| ARY
{ $$ = stab2arg(A_STAB,$1); }
;
hshword : WORD
{ $$ = stab2arg(A_WORD,hadd(stabent($1,TRUE)));
- Safefree($1); }
+ Safefree($1); $1 = Nullch; }
| HSH
{ $$ = stab2arg(A_STAB,$1); }
;
* blame Henry for some of the lack of readability.
*/
-/* $Header: regcomp.c,v 3.0.1.8 90/11/10 01:57:46 lwall Locked $
+/* $Header: regcomp.c,v 4.0 91/03/20 01:39:01 lwall Locked $
*
* $Log: regcomp.c,v $
- * Revision 3.0.1.8 90/11/10 01:57:46 lwall
- * patch38: patterns with multiple constant strings occasionally malfed
- * patch38: patterns like /foo.*foo/ sped up some
- *
- * Revision 3.0.1.7 90/10/20 02:18:32 lwall
- * patch37: /foo.*bar$/ wrongly optimized to do tail matching on "foo"
- *
- * Revision 3.0.1.6 90/10/16 10:17:33 lwall
- * patch29: patterns with multiple short literal strings sometimes failed
- *
- * Revision 3.0.1.5 90/08/13 22:23:29 lwall
- * patch28: /x{m}/ didn't work right
- *
- * Revision 3.0.1.4 90/08/09 05:05:33 lwall
- * patch19: sped up /x+y/ patterns greatly by not retrying on every x
- * patch19: inhibited backoff on patterns anchored to the end like /\s+$/
- * patch19: sped up {m,n} on simple items
- * patch19: optimized /.*whatever/ to /^.*whatever/
- * patch19: fixed character classes to allow backslashing hyphen
- *
- * Revision 3.0.1.3 90/03/12 16:59:22 lwall
- * patch13: pattern matches can now use \0 to mean \000
- *
- * Revision 3.0.1.2 90/02/28 18:08:35 lwall
- * patch9: /[\200-\377]/ didn't work on machines with signed chars
- *
- * Revision 3.0.1.1 89/11/11 04:51:04 lwall
- * patch2: /[\000]/ didn't work
- *
- * Revision 3.0 89/10/18 15:22:29 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:39:01 lwall
+ * 4.0 baseline.
*
*/
#include "INTERN.h"
#include "regcomp.h"
+#ifdef MSDOS
+# if defined(BUGGY_MSC6)
+ /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
+ # pragma optimize("a",off)
+ /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
+ # pragma optimize("w",on )
+# endif /* BUGGY_MSC6 */
+#endif /* MSDOS */
+
#ifndef STATIC
#define STATIC static
#endif
STATIC char *regatom();
STATIC char *regclass();
STATIC char *regnode();
+STATIC char *reganode();
STATIC void regc();
STATIC void reginsert();
STATIC void regtail();
regc(MAGIC);
if (reg(0, &flags) == NULL) {
Safefree(regprecomp);
+ regprecomp = Nullch;
return(NULL);
}
scan = NEXTOPER(scan);
first = scan;
- while ((OP(first) > OPEN && OP(first) < CLOSE) ||
+ while (OP(first) == OPEN ||
(OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
(OP(first) == PLUS) ||
(OP(first) == CURLY && ARG1(first) > 0) ) {
- if (OP(first) == CURLY)
- first += 4;
- else if (OP(first) == PLUS)
+ if (OP(first) == PLUS)
sawplus = 2;
+ else
+ first += regarglen[OP(first)];
first = NEXTOPER(first);
}
scan = NEXTOPER(scan);
}
if (OP(scan) == EXACTLY) {
+ char *t;
+
first = scan;
- while (OP(regnext(scan)) >= CLOSE)
- scan = regnext(scan);
+ while (OP(t = regnext(scan)) == CLOSE)
+ scan = t;
if (curback - backish == len) {
str_ncat(longish, OPERAND(first)+1,
*OPERAND(first));
if (OP(first) == EOL && longish->str_cur)
r->regmust->str_pok |= SP_TAIL;
}
- else
+ else {
str_free(longest);
+ longest = Nullstr;
+ }
str_free(longish);
}
r->do_folding = fold;
r->nparens = regnpar - 1;
+ New(1002, r->startp, regnpar, char*);
+ New(1002, r->endp, regnpar, char*);
#ifdef DEBUGGING
if (debug & 512)
regdump(r);
/* Make an OPEN node, if parenthesized. */
if (paren) {
- if (regnpar >= NSUBEXP)
- FAIL("too many () in regexp");
parno = regnpar;
regnpar++;
- ret = regnode(OPEN+parno);
+ ret = reganode(OPEN, parno);
} else
ret = NULL;
}
/* Make a closing node, and hook it on the end. */
- ender = regnode((paren) ? CLOSE+parno : END);
+ if (paren)
+ ender = reganode(CLOSE, parno);
+ else
+ ender = regnode(END);
regtail(ret, ender);
/* Hook the tails of the branches to the closing node. */
int tmp;
reginsert(CURLY, ret);
+ if (iter > 0)
+ *flagp = (WORST|HASWIDTH);
if (*max == ',')
max++;
else
case 'r':
case 't':
case 'f':
+ case 'e':
+ case 'a':
+ case 'x':
+ case 'c':
+ case '0':
goto defchar;
- case '0': case '1': case '2': case '3': case '4':
+ case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
- if (isdigit(regparse[1]) || *regparse == '0')
+ {
+ int num = atoi(regparse);
+
+ if (num > 9 && num >= regnpar)
goto defchar;
- else {
- ret = regnode(REF + *regparse++ - '0');
+ else {
+ ret = reganode(REF, num);
+ while (isascii(*regparse) && isdigit(*regparse))
+ regparse++;
*flagp |= SIMPLE;
+ }
}
break;
case '\0':
register char ender;
register char *p;
char *oldp;
- int foo;
+ int numlen;
defchar:
ret = regnode(EXACTLY);
ender = '\f';
p++;
break;
+ case 'e':
+ ender = '\033';
+ p++;
+ break;
+ case 'a':
+ ender = '\007';
+ p++;
+ break;
+ case 'x':
+ ender = scanhex(++p, 2, &numlen);
+ p += numlen;
+ break;
+ case 'c':
+ p++;
+ ender = *p++;
+ if (islower(ender))
+ ender = toupper(ender);
+ ender ^= 64;
+ break;
case '0': case '1': case '2': case '3':case '4':
case '5': case '6': case '7': case '8':case '9':
- if (isdigit(p[1]) || *p == '0') {
- foo = *p - '0';
- if (isdigit(p[1]))
- foo = (foo<<3) + *++p - '0';
- if (isdigit(p[1]))
- foo = (foo<<3) + *++p - '0';
- ender = foo;
- p++;
+ if (*p == '0' ||
+ (isdigit(p[1]) && atoi(p) >= regnpar) ) {
+ ender = scanoct(p, 3, &numlen);
+ p += numlen;
}
else {
--p;
register int range = 0;
register char *ret;
register int def;
+ int numlen;
ret = regnode(ANYOF);
if (*regparse == '^') { /* Complement of range. */
case 'b':
class = '\b';
break;
+ case 'e':
+ class = '\033';
+ break;
+ case 'a':
+ class = '\007';
+ break;
+ case 'x':
+ class = scanhex(regparse, 2, &numlen);
+ regparse += numlen;
+ break;
+ case 'c':
+ class = *regparse++;
+ if (islower(class))
+ class = toupper(class);
+ class ^= 64;
+ break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
- class -= '0';
- if (isdigit(*regparse)) {
- class <<= 3;
- class += *regparse++ - '0';
- }
- if (isdigit(*regparse)) {
- class <<= 3;
- class += *regparse++ - '0';
- }
+ class = scanoct(--regparse, 3, &numlen);
+ regparse += numlen;
break;
}
}
}
/*
+ - reganode - emit a node with an argument
+ */
+static char * /* Location. */
+reganode(op, arg)
+char op;
+unsigned short arg;
+{
+ register char *ret;
+ register char *ptr;
+
+ ret = regcode;
+ if (ret == ®dummy) {
+#ifdef REGALIGN
+ if (!(regsize & 1))
+ regsize++;
+#endif
+ regsize += 5;
+ return(ret);
+ }
+
+#ifdef REGALIGN
+#ifndef lint
+ if (!((long)ret & 1))
+ *ret++ = 127;
+#endif
+#endif
+ ptr = ret;
+ *ptr++ = op;
+ *ptr++ = '\0'; /* Null "next" pointer. */
+ *ptr++ = '\0';
+#ifdef REGALIGN
+ *(unsigned short *)(ret+3) = arg;
+#else
+ ret[3] = arg >> 8; ret[4] = arg & 0377;
+#endif
+ ptr += 2;
+ regcode = ptr;
+
+ return(ret);
+}
+
+/*
- regc - emit (if appropriate) a byte of code
*/
static void
register char *s;
register char op = EXACTLY; /* Arbitrary non-END op. */
register char *next;
- extern char *index();
s = r->program + 1;
#endif
op = OP(s);
fprintf(stderr,"%2d%s", s-r->program, regprop(s)); /* Where, what. */
- if (op == CURLY)
- s += 4;
next = regnext(s);
+ s += regarglen[op];
if (next == NULL) /* Next ptr. */
fprintf(stderr,"(0)");
else
p = NULL;
break;
case REF:
- case REF+1:
- case REF+2:
- case REF+3:
- case REF+4:
- case REF+5:
- case REF+6:
- case REF+7:
- case REF+8:
- case REF+9:
- (void)sprintf(buf+strlen(buf), "REF%d", OP(op)-REF);
+ (void)sprintf(buf+strlen(buf), "REF%d", ARG1(op));
p = NULL;
break;
- case OPEN+1:
- case OPEN+2:
- case OPEN+3:
- case OPEN+4:
- case OPEN+5:
- case OPEN+6:
- case OPEN+7:
- case OPEN+8:
- case OPEN+9:
- (void)sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
+ case OPEN:
+ (void)sprintf(buf+strlen(buf), "OPEN%d", ARG1(op));
p = NULL;
break;
- case CLOSE+1:
- case CLOSE+2:
- case CLOSE+3:
- case CLOSE+4:
- case CLOSE+5:
- case CLOSE+6:
- case CLOSE+7:
- case CLOSE+8:
- case CLOSE+9:
- (void)sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
+ case CLOSE:
+ (void)sprintf(buf+strlen(buf), "CLOSE%d", ARG1(op));
p = NULL;
break;
case STAR:
regfree(r)
struct regexp *r;
{
- if (r->precomp)
+ if (r->precomp) {
Safefree(r->precomp);
- if (r->subbase)
+ r->precomp = Nullch;
+ }
+ if (r->subbase) {
Safefree(r->subbase);
- if (r->regmust)
+ r->subbase = Nullch;
+ }
+ if (r->regmust) {
str_free(r->regmust);
- if (r->regstart)
+ r->regmust = Nullstr;
+ }
+ if (r->regstart) {
str_free(r->regstart);
+ r->regstart = Nullstr;
+ }
+ Safefree(r->startp);
+ Safefree(r->endp);
Safefree(r);
}
-/* $Header: regcomp.h,v 3.0.1.2 90/11/10 01:58:28 lwall Locked $
+/* $Header: regcomp.h,v 4.0 91/03/20 01:39:09 lwall Locked $
*
* $Log: regcomp.h,v $
- * Revision 3.0.1.2 90/11/10 01:58:28 lwall
- * patch38: random cleanup
- *
- * Revision 3.0.1.1 90/08/09 05:06:49 lwall
- * patch19: sped up {m,n} on simple items
- *
- * Revision 3.0 89/10/18 15:22:39 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:39:09 lwall
+ * 4.0 baseline.
*
*/
#define NSPACE 17 /* no Match any non-whitespace character */
#define DIGIT 18 /* no Match any numeric character */
#define NDIGIT 19 /* no Match any non-numeric character */
-#define REF 20 /* no Match some already matched string */
-#define OPEN 30 /* no Mark this point in input as start of #n. */
- /* OPEN+1 is number 1, etc. */
-#define CLOSE 40 /* no Analogous to OPEN. */
-/* CLOSE must be last one! see regmust finder */
+#define REF 20 /* num Match some already matched string */
+#define OPEN 21 /* num Mark this point in input as start of #n. */
+#define CLOSE 22 /* num Analogous to OPEN. */
/*
* Opcode notes:
* OPEN,CLOSE ...are numbered at compile time.
*/
+#ifndef DOINIT
+extern char regarglen[];
+#else
+char regarglen[] = {0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,2,2};
+#endif
+
/* The following have no fixed length. */
#ifndef DOINIT
extern char varies[];
#else
-char varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,
- REF+1,REF+2,REF+3,REF+4,REF+5,REF+6,REF+7,REF+8,REF+9,0};
+char varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,REF,0};
#endif
/* The following always have a length of 1. */
* blame Henry for some of the lack of readability.
*/
-/* $Header: regexec.c,v 3.0.1.6 90/11/10 02:00:57 lwall Locked $
+/* $Header: regexec.c,v 4.0 91/03/20 01:39:16 lwall Locked $
*
* $Log: regexec.c,v $
- * Revision 3.0.1.6 90/11/10 02:00:57 lwall
- * patch38: patterns like /^foo.*bar/ sped up some
- * patch38: /[^whatever]+/ could scan past end of string
- *
- * Revision 3.0.1.5 90/10/16 10:25:36 lwall
- * patch29: /^pat/ occasionally matched in middle of string when $* = 0
- * patch29: /.{n,m}$/ could match with fewer than n characters remaining
- * patch29: /\d{9}/ could match more than 9 characters
- *
- * Revision 3.0.1.4 90/08/09 05:12:03 lwall
- * patch19: sped up /x+y/ patterns greatly by not retrying on every x
- * patch19: inhibited backoff on patterns anchored to the end like /\s+$/
- * patch19: sped up {m,n} on simple items
- * patch19: $' broke on embedded nulls
- * patch19: $ will now only match at end of string if $* == 0
- *
- * Revision 3.0.1.3 90/02/28 18:14:39 lwall
- * patch9: /[\200-\377]/ didn't work on machines with signed chars
- * patch9: \d, \w, and \s could misfire on characters with high bit set
- * patch9: /\bfoo/i didn't work
- *
- * Revision 3.0.1.2 89/12/21 20:16:27 lwall
- * patch7: certain patterns didn't match correctly at end of string
- *
- * Revision 3.0.1.1 89/11/11 04:52:04 lwall
- * patch2: /\b$foo/ didn't work
- *
- * Revision 3.0 89/10/18 15:22:53 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:39:16 lwall
+ * 4.0 baseline.
*
*/
sp = prog->startp;
ep = prog->endp;
if (prog->nparens) {
- for (i = NSUBEXP; i > 0; i--) {
+ for (i = prog->nparens; i >= 0; i--) {
*sp++ = NULL;
*ep++ = NULL;
}
((nextchar || locinput < regeol) &&
locinput[-1] == '\n') )
{
- regtill = regbol;
+ /* regtill = regbol; */
break;
}
return(0);
return(0);
if (!multiline && regeol - locinput > 1)
return 0;
- regtill = regbol;
+ /* regtill = regbol; */
break;
case ANY:
if ((nextchar == '\0' && locinput >= regeol) ||
nextchar = *++locinput;
break;
case REF:
- case REF+1:
- case REF+2:
- case REF+3:
- case REF+4:
- case REF+5:
- case REF+6:
- case REF+7:
- case REF+8:
- case REF+9:
- n = OP(scan) - REF;
+ n = ARG1(scan); /* which paren pair */
s = regmystartp[n];
if (!s)
return(0);
break;
case BACK:
break;
- case OPEN+1:
- case OPEN+2:
- case OPEN+3:
- case OPEN+4:
- case OPEN+5:
- case OPEN+6:
- case OPEN+7:
- case OPEN+8:
- case OPEN+9:
- n = OP(scan) - OPEN;
+ case OPEN:
+ n = ARG1(scan); /* which paren pair */
reginput = locinput;
regmystartp[n] = locinput; /* for REF */
} else
return(0);
/* NOTREACHED */
- case CLOSE+1:
- case CLOSE+2:
- case CLOSE+3:
- case CLOSE+4:
- case CLOSE+5:
- case CLOSE+6:
- case CLOSE+7:
- case CLOSE+8:
- case CLOSE+9: {
- n = OP(scan) - CLOSE;
+ case CLOSE: {
+ n = ARG1(scan); /* which paren pair */
reginput = locinput;
regmyendp[n] = locinput; /* for REF */
* not the System V one.
*/
-/* $Header: regexp.h,v 3.0.1.1 90/08/09 05:12:55 lwall Locked $
+/* $Header: regexp.h,v 4.0 91/03/20 01:39:23 lwall Locked $
*
* $Log: regexp.h,v $
- * Revision 3.0.1.1 90/08/09 05:12:55 lwall
- * patch19: $' broke on embedded nulls
- *
- * Revision 3.0 89/10/18 15:22:46 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:39:23 lwall
+ * 4.0 baseline.
*
*/
-#define NSUBEXP 10
-
typedef struct regexp {
- char *startp[NSUBEXP];
- char *endp[NSUBEXP];
+ char **startp;
+ char **endp;
STR *regstart; /* Internal use only. */
char *regstclass;
STR *regmust; /* Internal use only. */
-/* $Header: spat.h,v 3.0 89/10/18 15:23:14 lwall Locked $
+/* $Header: spat.h,v 4.0 91/03/20 01:39:36 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: spat.h,v $
- * Revision 3.0 89/10/18 15:23:14 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:39:36 lwall
+ * 4.0 baseline.
*
*/
-/* $Header: stab.c,v 3.0.1.11 91/01/11 18:23:44 lwall Locked $
+/* $Header: stab.c,v 4.0 91/03/20 01:39:41 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: stab.c,v $
- * Revision 3.0.1.11 91/01/11 18:23:44 lwall
- * patch42: added -0 option
- *
- * Revision 3.0.1.10 90/11/10 02:02:05 lwall
- * patch38: random cleanup
- *
- * Revision 3.0.1.9 90/10/16 10:32:05 lwall
- * patch29: added -M, -A and -C
- * patch29: taintperl now checks for world writable PATH components
- * patch29: *foo now prints as *package'foo
- * patch29: scripts now run at almost full speed under the debugger
- * patch29: package behavior is now more consistent
- *
- * Revision 3.0.1.8 90/08/13 22:30:17 lwall
- * patch28: the NSIG hack didn't work right on Xenix
- *
- * Revision 3.0.1.7 90/08/09 05:17:48 lwall
- * patch19: fixed double include of <signal.h>
- * patch19: $' broke on embedded nulls
- * patch19: $< and $> better supported on machines without setreuid
- * patch19: Added support for linked-in C subroutines
- * patch19: %ENV wasn't forced to be global like it should
- * patch19: $| didn't work before the filehandle was opened
- * patch19: $! now returns "" in string context if errno == 0
- *
- * Revision 3.0.1.6 90/03/27 16:22:11 lwall
- * patch16: support for machines that can't cast negative floats to unsigned ints
- *
- * Revision 3.0.1.5 90/03/12 17:00:11 lwall
- * patch13: undef $/ didn't work as advertised
- *
- * Revision 3.0.1.4 90/02/28 18:19:14 lwall
- * patch9: $0 is now always the command name
- * patch9: you may now undef $/ to have no input record separator
- * patch9: local($.) didn't work
- * patch9: sometimes perl thought ordinary data was a symbol table entry
- * patch9: stab_array() and stab_hash() weren't defined on MICROPORT
- *
- * Revision 3.0.1.3 89/12/21 20:18:40 lwall
- * patch7: ANSI strerror() is now supported
- * patch7: errno may now be a macro with an lvalue
- * patch7: in stab.c, sighandler() may now return either void or int
- *
- * Revision 3.0.1.2 89/11/17 15:35:37 lwall
- * patch5: sighandler() needed to be static
- *
- * Revision 3.0.1.1 89/11/11 04:55:07 lwall
- * patch2: sys_errlist[sys_nerr] is illegal
- *
- * Revision 3.0 89/10/18 15:23:23 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:39:41 lwall
+ * 4.0 baseline.
*
*/
static handlertype sighandler();
+static int origalen = 0;
+
STR *
stab_str(str)
STR *str;
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 '\t': /* ^I */
+ if (inplace)
+ str_set(stab_val(stab), inplace);
+ else
+ str_sset(stab_val(stab),&str_undef);
+ 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) {
break;
#endif
case '/':
- if (record_separator != 0777) {
- *tokenbuf = record_separator;
- tokenbuf[1] = '\0';
- str_nset(stab_val(stab),tokenbuf,rslen);
- }
break;
case '[':
str_numset(stab_val(stab),(double)arybase);
(void)sprintf(s,"%d",(int)egid);
add_groups:
while (*s) s++;
-#ifdef GETGROUPS
+#ifdef HAS_GETGROUPS
#ifndef NGROUPS
#define NGROUPS 32
#endif
#endif
str_set(stab_val(stab),buf);
break;
+ case '*':
+ break;
+ case '0':
+ break;
default:
{
struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
STR *str;
{
STAB *stab = mstr->str_u.str_stab;
- char *s;
+ register char *s;
int i;
switch (mstr->str_rare) {
strcpy(stab_magic(stab),"StB");
stab_val(stab) = Str_new(70,0);
stab_line(stab) = curcmd->c_line;
+ stab_stash(stab) = curcmd->c_stash;
}
else {
stab = stabent(s,TRUE);
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,
- str->str_ptr,str->str_cur);
+ tmps,str->str_cur);
}
break;
case 0:
switch (*stab->str_magic->str_ptr) {
+ case '\004': /* ^D */
+#ifdef DEBUGGING
+ debug = (int)(str_gnum(str)) | 32768;
+#endif
+ 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 '\024': /* ^T */
basetime = (long)str_gnum(str);
break;
+ case '\027': /* ^W */
+ dowarn = (bool)str_gnum(str);
+ break;
case '.':
if (localizing)
savesptr((STR**)&last_in_stab);
break;
case '/':
if (str->str_pok) {
- record_separator = *str_get(str);
+ rs = str_get(str);
rslen = str->str_cur;
+ if (!rslen) {
+ rs = "\n\n";
+ rslen = 2;
+ }
+ rschar = rs[rslen - 1];
}
else {
- record_separator = 0777; /* fake a non-existent char */
+ rschar = 0777; /* fake a non-existent char */
rslen = 1;
}
break;
break;
case '<':
uid = (int)str_gnum(str);
-#ifdef SETREUID
+#ifdef HAS_SETREUID
if (delaymagic) {
delaymagic |= DM_REUID;
break; /* don't do magic till later */
}
-#endif /* SETREUID */
-#ifdef SETRUID
+#endif /* HAS_SETREUID */
+#ifdef HAS_SETRUID
if (setruid((UIDTYPE)uid) < 0)
uid = (int)getuid();
#else
-#ifdef SETREUID
+#ifdef HAS_SETREUID
if (setreuid((UIDTYPE)uid, (UIDTYPE)-1) < 0)
uid = (int)getuid();
#else
break;
case '>':
euid = (int)str_gnum(str);
-#ifdef SETREUID
+#ifdef HAS_SETREUID
if (delaymagic) {
delaymagic |= DM_REUID;
break; /* don't do magic till later */
}
-#endif /* SETREUID */
-#ifdef SETEUID
+#endif /* HAS_SETREUID */
+#ifdef HAS_SETEUID
if (seteuid((UIDTYPE)euid) < 0)
euid = (int)geteuid();
#else
-#ifdef SETREUID
+#ifdef HAS_SETREUID
if (setreuid((UIDTYPE)-1, (UIDTYPE)euid) < 0)
euid = (int)geteuid();
#else
break;
case '(':
gid = (int)str_gnum(str);
-#ifdef SETREGID
+#ifdef HAS_SETREGID
if (delaymagic) {
delaymagic |= DM_REGID;
break; /* don't do magic till later */
}
-#endif /* SETREGID */
-#ifdef SETRGID
+#endif /* HAS_SETREGID */
+#ifdef HAS_SETRGID
(void)setrgid((GIDTYPE)gid);
#else
-#ifdef SETREGID
+#ifdef HAS_SETREGID
(void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
#else
fatal("setrgid() not implemented");
break;
case ')':
egid = (int)str_gnum(str);
-#ifdef SETREGID
+#ifdef HAS_SETREGID
if (delaymagic) {
delaymagic |= DM_REGID;
break; /* don't do magic till later */
}
-#endif /* SETREGID */
-#ifdef SETEGID
+#endif /* HAS_SETREGID */
+#ifdef HAS_SETEGID
(void)setegid((GIDTYPE)egid);
#else
-#ifdef SETREGID
+#ifdef HAS_SETREGID
(void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
#else
fatal("setegid() not implemented");
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? */
+ 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';
+ bcopy(s, origargv[0], i);
+ }
+ else {
+ bcopy(s, origargv[0], i);
+ s = origargv[0]+i;
+ *s++ = '\0';
+ while (++i < origalen)
+ *s++ = ' ';
+ }
+ break;
default:
{
struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
sub->depth--; /* assuming no longjumps out of here */
str_free(stack->ary_array[0]); /* free the one real string */
+ stack->ary_array[0] = Nullstr;
afree(stab_xarray(defstab)); /* put back old $_[] */
stab_xarray(defstab) = savearray;
stack = oldstack;
stab_line(stab) = curcmd->c_line;
str_magic(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);
+ }
return stab;
}
}
STR *str;
STAB *stab;
{
- str_set(str,stab_stash(stab)->tbl_name);
+ HASH *tb = stab_stash(stab);
+
+ if (!tb)
+ return;
+ str_set(str,tb->tbl_name);
str_ncat(str,"'", 1);
str_scat(str,stab->str_magic);
}
SUBR *sub;
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;
if (stio = stab_io(stab)) {
do_close(stab,FALSE);
Safefree(stio->top_name);
-/* $Header: stab.h,v 3.0.1.4 90/10/16 10:33:08 lwall Locked $
+/* $Header: stab.h,v 4.0 91/03/20 01:39:49 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: stab.h,v $
- * Revision 3.0.1.4 90/10/16 10:33:08 lwall
- * patch29: *foo now prints as *package'foo
- * patch29: package behavior is now more consistent
- *
- * Revision 3.0.1.3 90/08/09 05:18:42 lwall
- * patch19: Added support for linked-in C subroutines
- *
- * Revision 3.0.1.2 90/03/12 17:00:43 lwall
- * patch13: did some ndir straightening up for Xenix
- *
- * Revision 3.0.1.1 89/12/21 20:19:53 lwall
- * patch7: in stab.h, added some CRIPPLED_CC support for Microport
- *
- * Revision 3.0 89/10/18 15:23:30 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:39:49 lwall
+ * 4.0 baseline.
*
*/
struct stio {
FILE *ifp; /* ifp and ofp are normally the same */
FILE *ofp; /* but sockets need separate streams */
-#ifdef READDIR
+#ifdef HAS_READDIR
DIR *dirp; /* for opendir, readdir, etc */
#endif
long lines; /* $. */
-/* $Header: str.c,v 3.0.1.12 91/01/11 18:26:54 lwall Locked $
+#undef STDSTDIO
+/* $Header: str.c,v 4.0 91/03/20 01:39:55 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: str.c,v $
- * Revision 3.0.1.12 91/01/11 18:26:54 lwall
- * patch42: s/^foo/bar/ occasionally brought on core dumps
- * patch42: undid unwarranted assumptions about memcmp() return value
- * patch42: ('a' .. 'z') could lose its value in a loop
- *
- * Revision 3.0.1.11 90/11/13 15:27:14 lwall
- * patch41: fixed a couple of malloc/free problems
- *
- * Revision 3.0.1.10 90/11/10 02:06:29 lwall
- * patch38: temp string values are now copied less often
- * patch38: array slurps are now faster and take less memory
- * patch38: fixed a memory leakage on local(*foo)
- *
- * Revision 3.0.1.9 90/10/16 10:41:21 lwall
- * patch29: the undefined value could get defined by devious means
- * patch29: undefined values compared inconsistently
- * patch29: taintperl now checks for world writable PATH components
- *
- * Revision 3.0.1.8 90/08/09 05:22:18 lwall
- * patch19: the number to string converter wasn't allocating enough space
- * patch19: tainting didn't work on setgid scripts
- *
- * Revision 3.0.1.7 90/03/27 16:24:11 lwall
- * patch16: strings with prefix chopped off sometimes freed wrong
- * patch16: taint check blows up on undefined array element
- *
- * Revision 3.0.1.6 90/03/12 17:02:14 lwall
- * patch13: substr as lvalue didn't invalidate old numeric value
- *
- * Revision 3.0.1.5 90/02/28 18:30:38 lwall
- * patch9: you may now undef $/ to have no input record separator
- * patch9: nested evals clobbered their longjmp environment
- * patch9: sometimes perl thought ordinary data was a symbol table entry
- * patch9: insufficient space allocated for numeric string on sun4
- * patch9: underscore in an array name in a double-quoted string not recognized
- * patch9: "@foo{}" not recognized unless %foo defined
- * patch9: "$foo[$[]" gives error
- *
- * Revision 3.0.1.4 89/12/21 20:21:35 lwall
- * patch7: errno may now be a macro with an lvalue
- * patch7: made nested or recursive foreach work right
- *
- * Revision 3.0.1.3 89/11/17 15:38:23 lwall
- * patch5: some machines typedef unchar too
- * patch5: substitution on leading components occasionally caused <> corruption
- *
- * Revision 3.0.1.2 89/11/11 04:56:22 lwall
- * patch2: uchar gives Crays fits
- *
- * Revision 3.0.1.1 89/10/26 23:23:41 lwall
- * patch1: string ordering tests were wrong
- * patch1: $/ now works even when STDSTDIO undefined
- *
- * Revision 3.0 89/10/18 15:23:38 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:39:55 lwall
+ * 4.0 baseline.
*
*/
#include "perl.h"
#include "perly.h"
+#ifndef __STDC__
extern char **environ;
+#endif /* ! __STDC__ */
#ifndef str_get
char *
{
register STRLEN delta;
- if (!(str->str_pok))
- fatal("str_chop: internal inconsistency");
+ if (!ptr || !(str->str_pok))
+ return;
delta = ptr - str->str_ptr;
str->str_len -= delta;
str->str_cur -= delta;
}
if (str->str_magic)
str_free(str->str_magic);
+ str->str_magic = freestrroot;
#ifdef LEAKTEST
- if (str->str_len)
+ 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);
#ifdef TAINT
str->str_tainted = 0;
#endif
- str->str_magic = freestrroot;
freestrroot = str;
#endif /* LEAKTEST */
}
register char *bp; /* we're going to steal some values */
register int cnt; /* from the stdio struct and put EVERYTHING */
register STDCHAR *ptr; /* in the innermost loop into registers */
- register int newline = record_separator;/* (assuming >= 6 registers) */
+ register int newline = rschar;/* (assuming >= 6 registers) */
int i;
STRLEN bpx;
- STRLEN obpx;
- register int get_paragraph;
- register char *oldbp;
int shortbuffered;
if (str == &str_undef)
return Nullch;
- if (get_paragraph = !rslen) { /* yes, that's an assignment */
- newline = '\n';
- oldbp = Nullch; /* remember last \n position (none) */
- }
#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */
cnt = fp->_cnt; /* get count into register */
str->str_nok = 0; /* invalidate number */
if (shortbuffered) { /* oh well, must extend */
cnt = shortbuffered;
shortbuffered = 0;
- if (get_paragraph && oldbp)
- obpx = oldbp - str->str_ptr;
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 */
- if (get_paragraph && oldbp)
- oldbp = str->str_ptr + obpx;
continue;
}
ptr = fp->_ptr; /* reregisterize cnt and ptr */
bpx = bp - str->str_ptr; /* prepare for possible relocation */
- if (get_paragraph && oldbp)
- obpx = oldbp - str->str_ptr;
str->str_cur = bpx;
STR_GROW(str, bpx + cnt + 2);
bp = str->str_ptr + bpx; /* reconstitute our pointer */
- if (get_paragraph && oldbp)
- oldbp = str->str_ptr + obpx;
if (i == newline) { /* all done for now? */
*bp++ = i;
}
thats_all_folks:
- if (get_paragraph && bp - 1 != oldbp) {
- oldbp = bp; /* remember where this newline was */
- goto screamer; /* and go back to the fray */
- }
+ 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;
screamer:
bp = buf;
-filler:
- while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe);
- if (i == newline && get_paragraph &&
- (i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe)
- goto filler;
+ 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 != newline && i != EOF) {
+ 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;
}
fatal("panic: error in parselist %d %x %d", cmd->c_type,
cmd->c_next, arg ? arg->arg_type : -1);
Safefree(cmd);
+ eval_root = Nullcmd;
return arg;
}
register char *d;
STAB *stab;
char *checkpoint;
+ int sawcase = 0;
toparse = Str_new(76,0);
str = Str_new(77,0);
str_nset(toparse,"",0);
t = s;
while (s < send) {
- if (*s == '\\' && s[1] && index("$@[{\\]}",s[1])) {
+ if (*s == '\\' && s[1] && index("$@[{\\]}lLuUE",s[1])) {
str_ncat(str, t, s - t);
++s;
- if (*nointrp && s+1 < send)
- if (*s != '@' && (*s != '$' || index(nointrp,s[1])))
- str_ncat(str,s-1,1);
- str_ncat(str, "$b", 2);
+ if (isalpha(*s)) {
+ str_ncat(str, "$c", 2);
+ sawcase = (*s != 'E');
+ }
+ else {
+ if (*nointrp && s+1 < send)
+ if (*s != '@' && (*s != '$' || index(nointrp,s[1])))
+ str_ncat(str,s-1,1);
+ str_ncat(str, "$b", 2);
+ }
str_ncat(str, s, 1);
++s;
t = s;
t = s;
if (*s == '$' && s[1] == '#' && (isalpha(s[2]) || s[2] == '_'))
s++;
- s = scanreg(s,send,tokenbuf);
+ s = scanident(s,send,tokenbuf);
if (*t == '@' &&
(!(stab = stabent(tokenbuf,FALSE)) ||
(*s == '{' ? !stab_xhash(stab) : !stab_xarray(stab)) )) {
weight -= seen[un_char] * 10;
if (isalpha(d[1]) || isdigit(d[1]) ||
d[1] == '_') {
- d = scanreg(d,s,tokenbuf);
+ d = scanident(d,s,tokenbuf);
if (stabent(tokenbuf,FALSE))
weight -= 100;
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);
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;
str_nset(str,"",0);
while (s < send) {
if (*s == '$' && s+1 < send) {
- str_ncat(str,t,s-t);
+ if (s-t > 0)
+ str_ncat(str,t,s-t);
switch(*++s) {
case 'a':
str_scat(str,*++elem);
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++;
}
- str_ncat(str,t,s-t);
+ if (s-t > 0)
+ str_ncat(str,t,s-t);
return str;
}
+ucase(s,send)
+register char *s;
+register char *send;
+{
+ while (s < send) {
+ if (isascii(*s) && islower(*s))
+ *s = toupper(*s);
+ s++;
+ }
+}
+
+lcase(s,send)
+register char *s;
+register char *send;
+{
+ while (s < send) {
+ if (isascii(*s) && isupper(*s))
+ *s = tolower(*s);
+ s++;
+ }
+}
+
void
str_inc(str)
register STR *str;
static long tmps_size = -1;
STR *
-str_static(oldstr)
+str_mortal(oldstr)
STR *oldstr;
{
register STR *str = Str_new(78,0);
/* same thing without the copying */
STR *
-str_2static(str)
+str_2mortal(str)
register STR *str;
{
if (str == &str_undef)
-/* $Header: str.h,v 3.0.1.4 90/11/10 02:07:52 lwall Locked $
+/* $Header: str.h,v 4.0 91/03/20 01:40:04 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: str.h,v $
- * Revision 3.0.1.4 90/11/10 02:07:52 lwall
- * patch38: temp string values are now copied less often
- *
- * Revision 3.0.1.3 90/10/16 10:44:04 lwall
- * patch29: added caller
- * patch29: scripts now run at almost full speed under the debugger
- *
- * Revision 3.0.1.2 90/08/09 05:23:24 lwall
- * patch19: various MSDOS and OS/2 patches folded in
- *
- * Revision 3.0.1.1 89/10/26 23:24:42 lwall
- * patch1: rearranged some structures to align doubles better on Gould
- *
- * Revision 3.0 89/10/18 15:23:49 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:40:04 lwall
+ * 4.0 baseline.
*
*/
char *str_2ptr();
double str_2num();
-STR *str_static();
-STR *str_2static();
+STR *str_mortal();
+STR *str_2mortal();
STR *str_make();
STR *str_nmake();
STR *str_smake();
#!./perl
-# $Header: TEST,v 3.0.1.3 91/01/11 18:28:17 lwall Locked $
+# $Header: TEST,v 4.0 91/03/20 01:40:22 lwall Locked $
# This is written in a peculiar style, since we're trying to avoid
# most of the constructs we'll be testing for.
chdir 't' if -f 't/TEST';
if ($ARGV[0] eq '') {
- @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.* lib.*`);
+ @ARGV = split(/[ \n]/,
+ `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`);
}
open(CONFIG,"../config.sh");
}
$bad = 0;
while ($test = shift) {
- if ($test =~ /\.orig$/) {
+ if ($test =~ /^$/) {
next;
}
- if ($test =~ /\.rej$/) {
- next;
- }
- if ($test =~ /~$/) {
- next;
- }
- print "$test" . '.' x (16 - length($test));
+ $te = $test;
+ chop($te);
+ print "$te" . '.' x (15 - length($te));
if ($sharpbang) {
open(results,"./$test|") || (print "can't run.\n");
} else {
#!./perl
-# $Header: base.cond,v 3.0 89/10/18 15:24:11 lwall Locked $
+# $Header: cond.t,v 4.0 91/03/20 01:48:54 lwall Locked $
# make sure conditional operators work
#!./perl
-# $Header: base.if,v 3.0 89/10/18 15:24:17 lwall Locked $
+# $Header: if.t,v 4.0 91/03/20 01:49:03 lwall Locked $
print "1..2\n";
#!./perl
-# $Header: base.lex,v 3.0.1.1 90/08/09 05:24:43 lwall Locked $
+# $Header: lex.t,v 4.0 91/03/20 01:49:08 lwall Locked $
print "1..18\n";
#!./perl
-# $Header: base.pat,v 3.0 89/10/18 15:24:30 lwall Locked $
+# $Header: pat.t,v 4.0 91/03/20 01:49:12 lwall Locked $
print "1..2\n";
#!./perl
-# $Header: base.term,v 3.0.1.1 90/02/28 18:31:56 lwall Locked $
+# $Header: term.t,v 4.0 91/03/20 01:49:17 lwall Locked $
print "1..6\n";
#!./perl
-# $Header: cmd.elsif,v 3.0 89/10/18 15:24:38 lwall Locked $
+# $Header: elsif.t,v 4.0 91/03/20 01:49:21 lwall Locked $
sub foo {
if ($_[0] == 1) {
#!./perl
-# $Header: cmd.for,v 3.0 89/10/18 15:24:43 lwall Locked $
+# $Header: for.t,v 4.0 91/03/20 01:49:26 lwall Locked $
print "1..7\n";
#!./perl
-# $Header: cmd.mod,v 3.0 89/10/18 15:24:48 lwall Locked $
+# $Header: mod.t,v 4.0 91/03/20 01:49:33 lwall Locked $
print "1..7\n";
#!./perl
-# $Header: cmd.subval,v 3.0.1.1 90/10/16 10:46:53 lwall Locked $
+# $Header: subval.t,v 4.0 91/03/20 01:49:40 lwall Locked $
sub foo1 {
'true1';
#!./perl
-# $Header: cmd.switch,v 3.0 89/10/18 15:25:00 lwall Locked $
+# $Header: switch.t,v 4.0 91/03/20 01:49:44 lwall Locked $
print "1..18\n";
#!./perl
-# $Header: cmd.while,v 3.0 89/10/18 15:25:07 lwall Locked $
+# $Header: while.t,v 4.0 91/03/20 01:49:51 lwall Locked $
print "1..10\n";
#!./perl
-# $Header: comp.cmdopt,v 3.0 89/10/18 15:25:13 lwall Locked $
+# $Header: cmdopt.t,v 4.0 91/03/20 01:49:58 lwall Locked $
print "1..40\n";
#!./perl -P
-# $Header: comp.cpp,v 3.0.1.2 90/11/10 02:10:17 lwall Locked $
+# $Header: cpp.t,v 4.0 91/03/20 01:50:05 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: comp.decl,v 3.0 89/10/18 15:25:25 lwall Locked $
+# $Header: decl.t,v 4.0 91/03/20 01:50:09 lwall Locked $
# check to see if subroutine declarations work everwhere
#!./perl
-# $Header: comp.multiline,v 3.0 89/10/18 15:25:39 lwall Locked $
+# $Header: multiline.t,v 4.0 91/03/20 01:50:15 lwall Locked $
print "1..5\n";
#!./perl
-# $Header: comp.script,v 3.0 89/10/18 15:25:55 lwall Locked $
+# $Header: script.t,v 4.0 91/03/20 01:50:26 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: comp.term,v 3.0 89/10/18 15:26:04 lwall Locked $
+# $Header: term.t,v 4.0 91/03/20 01:50:36 lwall Locked $
# tests that aren't important enough for base.term
#!./perl
-# $Header: io.argv,v 3.0.1.1 89/11/11 04:59:05 lwall Locked $
+# $Header: argv.t,v 4.0 91/03/20 01:50:46 lwall Locked $
print "1..5\n";
#!./perl
-# $Header: io.dup,v 3.0 89/10/18 15:26:15 lwall Locked $
+# $Header: dup.t,v 4.0 91/03/20 01:50:49 lwall Locked $
print "1..6\n";
#!./perl
-# $Header: io.fs,v 3.0.1.1 90/08/13 22:31:17 lwall Locked $
+# $Header: fs.t,v 4.0 91/03/20 01:50:55 lwall Locked $
print "1..22\n";
-#!./perl -i.bak
+#!./perl
-# $Header: io.inplace,v 3.0 89/10/18 15:26:25 lwall Locked $
+$^I = '.bak';
+
+# $Header: inplace.t,v 4.0 91/03/20 01:50:59 lwall Locked $
print "1..2\n";
#!./perl
-# $Header: io.pipe,v 3.0.1.1 90/02/28 18:32:41 lwall Locked $
+# $Header: pipe.t,v 4.0 91/03/20 01:51:02 lwall Locked $
$| = 1;
print "1..8\n";
#!./perl
-# $Header: io.print,v 3.0 89/10/18 15:26:36 lwall Locked $
+# $Header: print.t,v 4.0 91/03/20 01:51:08 lwall Locked $
print "1..16\n";
#!./perl
-# $Header: io.tell,v 3.0 89/10/18 15:26:45 lwall Locked $
+# $Header: tell.t,v 4.0 91/03/20 01:51:14 lwall Locked $
print "1..13\n";
+++ /dev/null
-#!./perl
-
-# $Header: op.s,v 3.0.1.1 90/02/28 18:37:30 lwall Locked $
-
-print "1..42\n";
-
-$x = 'foo';
-$_ = "x";
-s/x/\$x/;
-print "#1\t:$_: eq :\$x:\n";
-if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";}
-
-$_ = "x";
-s/x/$x/;
-print "#2\t:$_: eq :foo:\n";
-if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";}
-
-$_ = "x";
-s/x/\$x $x/;
-print "#3\t:$_: eq :\$x foo:\n";
-if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";}
-
-$b = 'cd';
-($a = 'abcdef') =~ s'(b${b}e)'\n$1';
-print "#4\t:$1: eq :bcde:\n";
-print "#4\t:$a: eq :a\\n\$1f:\n";
-if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";}
-
-$a = 'abacada';
-if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx')
- {print "ok 5\n";} else {print "not ok 5\n";}
-
-if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx')
- {print "ok 6\n";} else {print "not ok 6 $a\n";}
-
-if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx')
- {print "ok 7\n";} else {print "not ok 7 $a\n";}
-
-$_ = 'ABACADA';
-if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";}
-
-$_ = '\\' x 4;
-if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";}
-s/\\/\\\\/g;
-if ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10 $_\n";}
-
-$_ = '\/' x 4;
-if (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\n";}
-s/\//\/\//g;
-if ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";}
-if (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";}
-
-$_ = 'aaaXXXXbbb';
-s/^a//;
-print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n";
-
-$_ = 'aaaXXXXbbb';
-s/a//;
-print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n";
-
-$_ = 'aaaXXXXbbb';
-s/^a/b/;
-print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n";
-
-$_ = 'aaaXXXXbbb';
-s/a/b/;
-print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n";
-
-$_ = 'aaaXXXXbbb';
-s/aa//;
-print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n";
-
-$_ = 'aaaXXXXbbb';
-s/aa/b/;
-print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n";
-
-$_ = 'aaaXXXXbbb';
-s/b$//;
-print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n";
-
-$_ = 'aaaXXXXbbb';
-s/b//;
-print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n";
-
-$_ = 'aaaXXXXbbb';
-s/bb//;
-print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n";
-
-$_ = 'aaaXXXXbbb';
-s/aX/y/;
-print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n";
-
-$_ = 'aaaXXXXbbb';
-s/Xb/z/;
-print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n";
-
-$_ = 'aaaXXXXbbb';
-s/aaX.*Xbb//;
-print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n";
-
-$_ = 'aaaXXXXbbb';
-s/bb/x/;
-print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n";
-
-# now for some unoptimized versions of the same.
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/^a//;
-print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/a//;
-print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/^a/b/;
-print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/a/b/;
-print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/aa//;
-print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/aa/b/;
-print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/b$//;
-print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/b//;
-print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/bb//;
-print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/aX/y/;
-print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/Xb/z/;
-print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/aaX.*Xbb//;
-print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n";
-
-$_ = 'aaaXXXXbbb';
-$x ne $x || s/bb/x/;
-print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n";
-
-$_ = 'abc123xyz';
-s/\d+/$&*2/e; # yields 'abc246xyz'
-print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n";
-s/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz'
-print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n";
-s/\w/$& x 2/eg; # yields 'aabbcc 224466xxyyzz'
-print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n";
#!./perl
-# $Header: op.append,v 3.0 89/10/18 15:26:51 lwall Locked $
+# $Header: append.t,v 4.0 91/03/20 01:51:23 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: op.array,v 3.0.1.1 90/03/12 17:03:03 lwall Locked $
+# $Header: array.t,v 4.0 91/03/20 01:51:31 lwall Locked $
print "1..36\n";
#!./perl
-# $Header: op.auto,v 3.0 89/10/18 15:27:00 lwall Locked $
+# $Header: auto.t,v 4.0 91/03/20 01:51:35 lwall Locked $
print "1..34\n";
#!./perl
-# $Header: op.chop,v 3.0 89/10/18 15:28:19 lwall Locked $
+# $Header: chop.t,v 4.0 91/03/20 01:51:42 lwall Locked $
print "1..4\n";
#!./perl
-# $Header: op.cond,v 3.0 89/10/18 15:28:26 lwall Locked $
+# $Header: cond.t,v 4.0 91/03/20 01:51:47 lwall Locked $
print "1..4\n";
#!./perl
-# $Header: op.dbm,v 3.0.1.2 91/01/11 18:29:12 lwall Locked $
+# $Header: dbm.t,v 4.0 91/03/20 01:51:52 lwall Locked $
if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') {
print "1..0\n";
exit;
}
-print "1..10\n";
+print "1..12\n";
unlink <Op.dbmx.*>;
umask(0);
@keys = ('blurfl', keys(h), 'dyick');
if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+$h{'foo'} = '';
+$h{''} = 'bar';
+
# check cache overflow and numeric keys and contents
$ok = 1;
for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
@h{0..200} = 200..400;
@foo = @h{0..200};
-print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "no ok 10\n";
+print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+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';
#!./perl
-# $Header: op.delete,v 3.0 89/10/18 15:28:36 lwall Locked $
+# $Header: delete.t,v 4.0 91/03/20 01:51:56 lwall Locked $
print "1..6\n";
#!./perl
-# $Header: op.do,v 3.0 89/10/18 15:28:43 lwall Locked $
+# $Header: do.t,v 4.0 91/03/20 01:52:08 lwall Locked $
sub foo1
{
#!./perl
-# $Header: op.each,v 3.0 89/10/18 15:28:48 lwall Locked $
+# $Header: each.t,v 4.0 91/03/20 01:52:14 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: op.eval,v 3.0 89/10/18 15:28:53 lwall Locked $
+# $Header: eval.t,v 4.0 91/03/20 01:52:20 lwall Locked $
print "1..10\n";
#!./perl
-# $Header: op.exec,v 3.0 89/10/18 15:28:57 lwall Locked $
+# $Header: exec.t,v 4.0 91/03/20 01:52:25 lwall Locked $
$| = 1; # flush stdout
print "1..8\n";
#!./perl
-# $Header: op.exp,v 3.0 89/10/18 15:29:01 lwall Locked $
+# $Header: exp.t,v 4.0 91/03/20 01:52:31 lwall Locked $
print "1..6\n";
#!./perl
-# $Header: op.flip,v 3.0 89/10/18 15:29:07 lwall Locked $
+# $Header: flip.t,v 4.0 91/03/20 01:52:36 lwall Locked $
print "1..8\n";
#!./perl
-# $Header: op.fork,v 3.0 89/10/18 15:29:12 lwall Locked $
+# $Header: fork.t,v 4.0 91/03/20 01:52:43 lwall Locked $
$| = 1;
print "1..2\n";
#!./perl
-# $Header: op.glob,v 3.0 89/10/18 15:29:19 lwall Locked $
+# $Header: glob.t,v 4.0 91/03/20 01:52:49 lwall Locked $
print "1..4\n";
-@ops = <op.*>;
+@ops = <op/*>;
$list = join(' ',@ops);
-chop($otherway = `echo op.*`);
+chop($otherway = `echo op/*`);
print $list eq $otherway ? "ok 1\n" : "not ok 1\n$list\n$otherway\n";
print $/ eq "\n" ? "ok 2\n" : "not ok 2\n";
-while (<jskdfjskdfj* op.* jskdjfjkosvk*>) {
+while (<jskdfjskdfj* op/* jskdjfjkosvk*>) {
$not = "not " unless $_ eq shift @ops;
$not = "not at all " if $/ eq "\0";
}
#!./perl
-# $Header: op.goto,v 3.0 89/10/18 15:29:24 lwall Locked $
+# $Header: goto.t,v 4.0 91/03/20 01:52:52 lwall Locked $
print "1..3\n";
--- /dev/null
+#!./perl
+
+if (! -x '/usr/ucb/groups') {
+ print "1..0\n";
+ exit 0;
+}
+
+print "1..1\n";
+
+for (split(' ', $()) {
+ next if $seen{$_}++;
+ push(@gr, (getgrgid($_))[0]);
+}
+$gr1 = join(' ',sort @gr);
+$gr2 = join(' ', sort split(' ',`groups`));
+#print "gr1 is <$gr1>\n";
+#print "gr2 is <$gr2>\n";
+print +($gr1 eq $gr2) ? "ok 1\n" : "not ok 1\n";
#!./perl
-# $Header: op.index,v 3.0.1.1 90/10/16 10:50:28 lwall Locked $
+# $Header: index.t,v 4.0 91/03/20 01:53:05 lwall Locked $
print "1..20\n";
#!./perl
-# $Header: op.int,v 3.0 89/10/18 15:29:33 lwall Locked $
+# $Header: int.t,v 4.0 91/03/20 01:53:08 lwall Locked $
print "1..4\n";
#!./perl
-# $Header: op.join,v 3.0 89/10/18 15:29:38 lwall Locked $
+# $Header: join.t,v 4.0 91/03/20 01:53:17 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: op.list,v 3.0 89/10/18 15:29:44 lwall Locked $
+# $Header: list.t,v 4.0 91/03/20 01:53:24 lwall Locked $
print "1..27\n";
#!./perl
-# $Header: op.local,v 3.0 89/10/18 15:29:49 lwall Locked $
+# $Header: local.t,v 4.0 91/03/20 01:53:29 lwall Locked $
print "1..20\n";
#!./perl
-# $Header: op.magic,v 3.0.1.1 89/11/11 05:00:07 lwall Locked $
+# $Header: magic.t,v 4.0 91/03/20 01:53:35 lwall Locked $
$| = 1; # command buffering
#!./perl
-# $Header: op.mkdir,v 3.0.1.4 91/01/11 18:30:00 lwall Locked $
+# $Header: mkdir.t,v 4.0 91/03/20 01:53:39 lwall Locked $
print "1..7\n";
#!./perl
-# $Header: op.oct,v 3.0 89/10/18 15:30:15 lwall Locked $
+# $Header: oct.t,v 4.0 91/03/20 01:53:43 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: op.ord,v 3.0 89/10/18 15:30:29 lwall Locked $
+# $Header: ord.t,v 4.0 91/03/20 01:53:50 lwall Locked $
print "1..2\n";
#!./perl
-# $Header: op.pack,v 3.0.1.1 90/08/09 05:27:04 lwall Locked $
+# $Header: pack.t,v 4.0 91/03/20 01:53:57 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: op.pat,v 3.0 89/10/18 15:30:44 lwall Locked $
+# $Header: pat.t,v 4.0 91/03/20 01:54:01 lwall Locked $
print "1..43\n";
#!./perl
-# $Header: op.push,v 3.0.1.1 90/03/12 17:04:27 lwall Locked $
+# $Header: push.t,v 4.0 91/03/20 01:54:07 lwall Locked $
@tests = split(/\n/, <<EOF);
0 3, 0 1 2, 3 4 5 6 7
#!./perl
-# $Header: op.range,v 3.0.1.1 90/03/27 16:27:58 lwall Locked $
+# $Header: range.t,v 4.0 91/03/20 01:54:11 lwall Locked $
print "1..8\n";
(bc+d$|ef*g.|h?i(j|k)) effg n - -
(bc+d$|ef*g.|h?i(j|k)) bcdd n - -
(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz-
-((((((((((a)))))))))) - c - -
+((((((((((a)))))))))) a y $10 a
+((((((((((a))))))))))\10 aa y $& aa
+((((((((((a))))))))))\41 aa n - -
+((((((((((a))))))))))\41 a! y $& a!
(((((((((a))))))))) a y $& a
multiple words of text uh-uh n - -
multiple words multiple words, yeah y $& multiple words
#!./perl
-# $Header: op.read,v 3.0 89/10/18 15:30:58 lwall Locked $
+# $Header: read.t,v 4.0 91/03/20 01:54:16 lwall Locked $
print "1..4\n";
-open(FOO,'op.read') || open(FOO,'t/op.read') || die "Can't open op.read";
+open(FOO,'op/read.t') || open(FOO,'t/op/read.t') || die "Can't open op.read";
seek(FOO,4,0);
$got = read(FOO,$buf,4);
#!./perl
-# $Header: op.regexp,v 3.0 89/10/18 15:31:02 lwall Locked $
+# $Header: regexp.t,v 4.0 91/03/20 01:54:22 lwall Locked $
-open(TESTS,'re_tests') || open(TESTS,'t/re_tests') || die "Can't open re_tests";
+open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
+ || die "Can't open re_tests";
while (<TESTS>) { }
$numtests = $.;
close(TESTS);
print "1..$numtests\n";
-open(TESTS,'re_tests') || open(TESTS,'t/re_tests') || die "Can't open re_tests";
+open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
+ || die "Can't open re_tests";
while (<TESTS>) {
($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_);
$input = join(':',$pat,$subject,$result,$repl,$expect);
#!./perl
-# $Header: op.repeat,v 3.0 89/10/18 15:31:07 lwall Locked $
+# $Header: repeat.t,v 4.0 91/03/20 01:54:26 lwall Locked $
-print "1..11\n";
+print "1..19\n";
# compile time
$a x= 0;
if ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";}
+@x = (1,2,3);
+
+print join('', @x x 4) eq '3333' ? "ok 12\n" : "not ok 12\n";
+print join('', (@x) x 4) eq '123123123123' ? "ok 13\n" : "not ok 13\n";
+print join('', (@x,()) x 4) eq '123123123123' ? "ok 14\n" : "not ok 14\n";
+print join('', (@x,1) x 4) eq '1231123112311231' ? "ok 15\n" : "not ok 15\n";
+print join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n";
+print join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n";
+print join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n";
+print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n";
#!./perl
-# $Header: op.s,v 3.0.1.2 90/10/16 10:51:50 lwall Locked $
+# $Header: s.t,v 4.0 91/03/20 01:54:30 lwall Locked $
print "1..51\n";
#!./perl
-# $Header: op.sleep,v 3.0.1.1 90/03/14 12:31:39 lwall Locked $
+# $Header: sleep.t,v 4.0 91/03/20 01:54:34 lwall Locked $
print "1..1\n";
#!./perl
-# $Header: op.sort,v 3.0.1.1 89/10/26 23:25:37 lwall Locked $
+# $Header: sort.t,v 4.0 91/03/20 01:54:38 lwall Locked $
print "1..8\n";
#!./perl
-# $Header: op.split,v 3.0.1.1 89/11/11 05:01:44 lwall Locked $
+# $Header: split.t,v 4.0 91/03/20 01:54:42 lwall Locked $
print "1..12\n";
#!./perl
-# $Header: op.sprintf,v 3.0 89/10/18 15:31:28 lwall Locked $
+# $Header: sprintf.t,v 4.0 91/03/20 01:54:46 lwall Locked $
print "1..1\n";
#!./perl
-# $Header: op.stat,v 3.0.1.5 90/10/16 10:55:42 lwall Locked $
+# $Header: stat.t,v 4.0 91/03/20 01:54:55 lwall Locked $
print "1..56\n";
if (! -z 'Op.stat.tmp') {print "ok 7\n";} else {print "not ok 7\n";}
if (-s 'Op.stat.tmp') {print "ok 8\n";} else {print "not ok 8\n";}
-chmod 0,'Op.stat.tmp';
+unlink 'Op.stat.tmp';
$olduid = $>; # can't test -r if uid == 0
+`echo hi >Op.stat.tmp`;
+chmod 0,'Op.stat.tmp';
eval '$> = 1;'; # so switch uid (may not be implemented)
if (!$> || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";}
if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";}
eval '$> = $olduid;'; # switch uid back (may not be implemented)
+print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid);
if (! -x 'Op.stat.tmp') {print "ok 11\n";} else {print "not ok 11\n";}
foreach ((12,13,14,15,16,17)) {
$cnt = $uid = 0;
-die "Can't run op.stat test 35 without pwd working" unless $cwd;
+die "Can't run op/stat.t test 35 without pwd working" unless $cwd;
chdir '/usr/bin' || die "Can't cd to /usr/bin";
while (defined($_ = <*>)) {
$cnt++;
# These aren't strictly "stat" calls, but so what?
-if (-T 'op.stat') {print "ok 41\n";} else {print "not ok 41\n";}
-if (! -B 'op.stat') {print "ok 42\n";} else {print "not ok 42\n";}
+if (-T 'op/stat.t') {print "ok 41\n";} else {print "not ok 41\n";}
+if (! -B 'op/stat.t') {print "ok 42\n";} else {print "not ok 42\n";}
if (-B './perl') {print "ok 43\n";} else {print "not ok 43\n";}
if (! -T './perl') {print "ok 44\n";} else {print "not ok 44\n";}
-open(foo,'op.stat');
+open(foo,'op/stat.t');
if (-T foo) {print "ok 45\n";} else {print "not ok 45\n";}
if (! -B foo) {print "ok 46\n";} else {print "not ok 46\n";}
$_ = <foo>;
if (! -B foo) {print "ok 49\n";} else {print "not ok 49\n";}
close(foo);
-open(foo,'op.stat');
+open(foo,'op/stat.t');
$_ = <foo>;
if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
if (-T foo) {print "ok 51\n";} else {print "not ok 51\n";}
#!./perl
-# $Header: op.study,v 3.0 89/10/18 15:31:38 lwall Locked $
+# $Header: study.t,v 4.0 91/03/20 01:54:59 lwall Locked $
print "1..24\n";
#!./perl
-# $Header: op.substr,v 3.0.1.1 90/10/16 10:56:35 lwall Locked $
+# $Header: substr.t,v 4.0 91/03/20 01:55:05 lwall Locked $
print "1..22\n";
#!./perl
-# $Header: op.time,v 3.0 89/10/18 15:31:56 lwall Locked $
+# $Header: time.t,v 4.0 91/03/20 01:55:09 lwall Locked $
print "1..5\n";
#!./perl
-# $Header: op.undef,v 3.0 89/10/18 15:32:01 lwall Locked $
+# $Header: undef.t,v 4.0 91/03/20 01:55:16 lwall Locked $
print "1..21\n";
undef %ary;
print defined(%ary) ? "not ok 16\n" : "ok 16\n";
@ary = (1);
-print defined @ary ? "ok 17\n" : "not ok 18\n";
+print defined @ary ? "ok 17\n" : "not ok 17\n";
%ary = (1,1);
print defined %ary ? "ok 18\n" : "not ok 18\n";
#!./perl
-# $Header: op.unshift,v 3.0 89/10/18 15:32:06 lwall Locked $
+# $Header: unshift.t,v 4.0 91/03/20 01:55:21 lwall Locked $
print "1..2\n";
#!./perl
-# $Header: op.vec,v 3.0 89/10/18 15:32:11 lwall Locked $
+# $Header: vec.t,v 4.0 91/03/20 01:55:28 lwall Locked $
print "1..13\n";
#!./perl
-# $Header: op.write,v 3.0.1.1 90/03/27 16:29:00 lwall Locked $
+# $Header: write.t,v 4.0 91/03/20 01:55:34 lwall Locked $
print "1..3\n";
-/* $Header: toke.c,v 3.0.1.12 91/01/11 18:31:45 lwall Locked $
+/* $Header: toke.c,v 4.0 91/03/20 01:42:14 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: toke.c,v $
- * Revision 3.0.1.12 91/01/11 18:31:45 lwall
- * patch42: eval'ed formats without proper termination blew up
- * patch42: whitespace now allowed after terminating . of format
- *
- * Revision 3.0.1.11 90/11/10 02:13:44 lwall
- * patch38: added alarm function
- * patch38: tr was busted in metacharacters on signed char machines
- *
- * Revision 3.0.1.10 90/10/16 11:20:46 lwall
- * patch29: the length of a search pattern was limited
- * patch29: added DATA filehandle to read stuff after __END__
- * patch29: added -M, -A and -C
- * patch29: added cmp and <=>
- * patch29: added caller
- * patch29: added scalar
- * patch29: added sysread and syswrite
- * patch29: added SysV IPC
- * patch29: added waitpid
- * patch29: tr/// now understands c, d and s options, and handles nulls right
- * patch29: 0x80000000 now makes unsigned value
- * patch29: Null could not be used as a delimiter
- * patch29: added @###.## fields to format
- *
- * Revision 3.0.1.9 90/08/13 22:37:25 lwall
- * patch28: defined(@array) and defined(%array) didn't work right
- *
- * Revision 3.0.1.8 90/08/09 05:39:58 lwall
- * patch19: added require operator
- * patch19: added -x switch to extract script from input trash
- * patch19: bare @name didn't add array to symbol table
- * patch19: Added __LINE__ and __FILE__ tokens
- * patch19: Added __END__ token
- * patch19: Numeric literals are now stored only in floating point
- * patch19: some support for FPS compiler misfunction
- * patch19: "\\$foo" not handled right
- * patch19: program and data can now both come from STDIN
- * patch19: "here" strings caused warnings about uninitialized variables
- *
- * Revision 3.0.1.7 90/03/27 16:32:37 lwall
- * patch16: MSDOS support
- * patch16: formats didn't work inside eval
- * patch16: final semicolon in program wasn't optional with -p or -n
- *
- * Revision 3.0.1.6 90/03/12 17:06:36 lwall
- * patch13: last semicolon of program is now optional, just for Randal
- * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST)
- *
- * Revision 3.0.1.5 90/02/28 18:47:06 lwall
- * patch9: return grandfathered to never be function call
- * patch9: non-existent perldb.pl now gives reasonable error message
- * patch9: perl can now start up other interpreters scripts
- * patch9: line numbers were bogus during certain portions of foreach evaluation
- * patch9: null hereis core dumped
- *
- * Revision 3.0.1.4 89/12/21 20:26:56 lwall
- * patch7: -d switch incompatible with -p or -n
- * patch7: " ''$foo'' " didn't parse right
- * patch7: grandfathered m'pat' and s'pat'repl' to not be package qualifiers
- *
- * Revision 3.0.1.3 89/11/17 15:43:15 lwall
- * patch5: IBM PC/RT compiler can't deal with UNI() and LOP() macros
- * patch5: } misadjusted expection of subsequent term or operator
- * patch5: y/abcde// didn't work
- *
- * Revision 3.0.1.2 89/11/11 05:04:42 lwall
- * patch2: fixed a CLINE macro conflict
- *
- * Revision 3.0.1.1 89/10/26 23:26:21 lwall
- * patch1: disambiguated word after "sort" better
- *
- * Revision 3.0 89/10/18 15:32:33 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:42:14 lwall
+ * 4.0 baseline.
*
*/
#ifdef I_FCNTL
#include <fcntl.h>
#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
/* which backslash sequences to keep in m// or s// */
static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtf0123456789[{]}";
-char *reparse; /* if non-null, scanreg found ${foo[$bar]} */
+char *reparse; /* if non-null, scanident found ${foo[$bar]} */
+
+void checkcomma();
#ifdef CLINE
#undef CLINE
if ((*s & 127) == '(')
*s++ = '(';
else
- warn("Unrecognized character \\%03o ignored", *s++);
+ warn("Unrecognized character \\%03o ignored", *s++ & 255);
goto retry;
}
#endif
if ((*s & 127) == '(')
*s++ = '(';
else
- warn("Unrecognized character \\%03o ignored", *s++);
+ warn("Unrecognized character \\%03o ignored", *s++ & 255);
goto retry;
case 4:
case 26:
}
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(' ');");
}
}
}
goto retry;
- case ' ': case '\t': case '\f':
+ case ' ': case '\t': case '\f': case '\r': case 013:
s++;
goto retry;
case '#':
case '*':
if (expectterm) {
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(s,bufend,tokenbuf);
yylval.stabval = stabent(tokenbuf,TRUE);
TERM(STAR);
}
MOP(O_MULTIPLY);
case '%':
if (expectterm) {
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(s,bufend,tokenbuf);
yylval.stabval = hadd(stabent(tokenbuf,TRUE));
TERM(HSH);
}
case '$':
if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) {
s++;
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(s,bufend,tokenbuf);
yylval.stabval = aadd(stabent(tokenbuf,TRUE));
TERM(ARYLEN);
}
d = s;
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(s,bufend,tokenbuf);
if (reparse) { /* turn ${foo[bar]} into ($foo[bar]) */
do_reparse:
s[-1] = ')';
case '@':
d = s;
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(s,bufend,tokenbuf);
if (reparse)
goto do_reparse;
yylval.stabval = aadd(stabent(tokenbuf,TRUE));
stab->str_pok |= SP_MULTI;
stab_io(stab) = stio_new();
stab_io(stab)->ifp = rsfp;
-#if defined(FCNTL) && defined(F_SETFD)
+#if defined(HAS_FCNTL) && defined(F_SETFD)
fd = fileno(rsfp);
fcntl(fd,F_SETFD,fd >= 3);
#endif
s = scanstr(s-2);
TERM(RSTRING);
}
+ if (strEQ(d,"qx")) {
+ s = scanstr(s-2);
+ TERM(RSTRING);
+ }
break;
case 'r': case 'R':
SNARFWORD;
return (CLINE, bufptr = s, (int)WORD);
}
-int
+void
checkcomma(s,what)
register char *s;
char *what;
{
- char *word;
+ char *someword;
if (*s == '(')
s++;
while (s < bufend && isascii(*s) && isspace(*s))
s++;
if (isascii(*s) && (isalpha(*s) || *s == '_')) {
- word = s++;
+ someword = s++;
while (isalpha(*s) || isdigit(*s) || *s == '_')
s++;
while (s < bufend && isspace(*s))
s++;
if (*s == ',') {
*s = '\0';
- word = instr(
+ someword = instr(
"tell eof times getlogin wait length shift umask getppid \
cos exp int log rand sin sqrt ord wantarray",
- word);
+ someword);
*s = ',';
- if (word)
+ if (someword)
return;
fatal("No comma allowed after %s", what);
}
}
char *
-scanreg(s,send,dest)
+scanident(s,send,dest)
register char *s;
register char *send;
char *dest;
else
d[1] = '\0';
}
- if (*d == '^' && !isspace(*s))
- *d = *s++ & 31;
+ if (*d == '^' && (isupper(*s) || index("[\\]^_?",*s)))
+ *d = *s++ ^ 64;
return s;
}
e = d;
break;
case '\\':
- if (d[1] && index("wWbB0123456789sSdD",d[1])) {
+ if (d[1] && index("wWbB0123456789sSdDlLuUE",d[1])) {
e = d;
break;
}
case 'r':
*d = '\r';
break;
+ case 'e':
+ *d = '\033';
+ break;
+ case 'a':
+ *d = '\007';
+ break;
}
/* FALL THROUGH */
default:
arg->arg_type = O_ITEM;
arg[1].arg_type = A_DOUBLE;
arg[1].arg_ptr.arg_str = str_smake(str);
- d = scanreg(d,bufend,buf);
+ 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 = scanreg(d,bufend,buf);
+ d = scanident(d,bufend,buf);
(void)stabent(buf,TRUE);
}
else if (*d == '@') {
- d = scanreg(d,bufend,buf);
+ d = scanident(d,bufend,buf);
if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
strEQ(buf,"SIG") || strEQ(buf,"INC"))
(void)stabent(buf,TRUE);
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,1);
+ spat->spat_flags & SPAT_FOLD);
hoistmust(spat);
}
got_pat:
arg->arg_type = O_ITEM;
arg[1].arg_type = A_DOUBLE;
arg[1].arg_ptr.arg_str = str_smake(str);
- d = scanreg(d,bufend,buf);
+ d = scanident(d,bufend,buf);
(void)stabent(buf,TRUE); /* make sure it's created */
for (; *d; d++) {
if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
- d = scanreg(d,bufend,buf);
+ d = scanident(d,bufend,buf);
(void)stabent(buf,TRUE);
}
else if (*d == '@' && d[-1] != '\\') {
- d = scanreg(d,bufend,buf);
+ d = scanident(d,bufend,buf);
if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
strEQ(buf,"SIG") || strEQ(buf,"INC"))
(void)stabent(buf,TRUE);
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,1);
+ spat->spat_flags & SPAT_FOLD);
hoistmust(spat);
}
yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat);
while (s < send && d - t <= 256) {
if (s[1] == '-' && s+2 < send) {
- for (i = s[0]; i <= s[2]; i++)
+ for (i = (s[0] & 0377); i <= (s[2] & 0377); i++)
*d++ = i;
s += 3;
}
}
t = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr,
yylval.arg[1].arg_ptr.arg_str->str_cur,&tlen);
- free_arg(yylval.arg);
+ arg_free(yylval.arg);
s = scanstr(s-1);
if (s >= bufend) {
yyerror("Translation replacement not terminated");
}
r = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr,
yylval.arg[1].arg_ptr.arg_str->str_cur,&rlen);
- free_arg(yylval.arg);
+ arg_free(yylval.arg);
arg[2].arg_len = delete|squash;
yylval.arg = arg;
if (!rlen && !delete) {
Zero(tbl, 256, short);
for (i = 0; i < tlen; i++)
tbl[t[i] & 0377] = -1;
- for (i = 0, j = 0; i < 256; i++,j++) {
+ for (i = 0, j = 0; i < 256; i++) {
if (!tbl[i]) {
if (j >= rlen) {
- if (delete) {
+ if (delete)
tbl[i] = -2;
- continue;
- }
- --j;
+ else
+ tbl[i] = r[j-1];
}
- tbl[i] = r[j];
+ else
+ tbl[i] = r[j++];
}
}
}
bool hereis = FALSE;
STR *herewas;
STR *str;
- char *leave = "\\$@nrtfb0123456789[{]}"; /* which backslash sequences to keep */
+ char *leave = "\\$@nrtfbeacx0123456789[{]}lLuUE"; /* which backslash sequences to keep */
int len;
arg = op_new(1);
s++;
goto do_double;
}
+ if (*s == 'x') {
+ s++;
+ goto do_back;
+ }
/* FALL THROUGH */
case '\'':
do_single:
makesingle = FALSE; /* force interpretation */
}
else if (*s == '\\' && s+1 < send) {
+ if (index("lLuUE",s[1]))
+ makesingle = FALSE;
s++;
}
s++;
if ((*s == '$' && s+1 < send &&
(alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) ||
(*s == '@' && s+1 < send) ) {
- len = scanreg(s,send,tokenbuf) - s;
+ len = scanident(s,send,tokenbuf) - s;
if (*s == '$' || strEQ(tokenbuf,"ARGV")
|| strEQ(tokenbuf,"ENV")
|| strEQ(tokenbuf,"SIG")
continue;
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
- *d = *s++ - '0';
- if (s < send && *s && index("01234567",*s)) {
- *d <<= 3;
- *d += *s++ - '0';
- }
- if (s < send && *s && index("01234567",*s)) {
- *d <<= 3;
- *d += *s++ - '0';
- }
- d++;
+ *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';
case 't':
*d++ = '\t';
break;
+ case 'e':
+ *d++ = '\033';
+ break;
+ case 'a':
+ *d++ = '\007';
+ break;
}
s++;
continue;
case '$':
str_ncat(str, t, s - t);
t = s;
- s = scanreg(s,eol,tokenbuf);
+ s = scanident(s,eol,tokenbuf);
str_ncat(str, t, s - t);
t = s;
if (s < eol && *s && index("$'\"",*s))
-/* $Header: usersub.c,v 3.0.1.2 90/10/16 11:22:04 lwall Locked $
+/* $Header: usersub.c,v 4.0 91/03/20 01:55:56 lwall Locked $
*
* 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 3.0.1.2 90/10/16 11:22:04 lwall
- * patch29: added waitpid
- *
- * Revision 3.0.1.1 90/08/09 05:40:45 lwall
- * patch19: Initial revision
+ * Revision 4.0 91/03/20 01:55:56 lwall
+ * 4.0 baseline.
*
*/
--- /dev/null
+This directory contains an example of how you might link in C subroutines
+with perl to make your own special copy of perl. In the perl distribution
+directory, there will be (after make is run) a file called uperl.o, which
+is all of perl except for a single undefined subroutine, named userinit().
+See usersub.c.
+
+The sole purpose of the userinit() routine is to call the initialization
+routines for any modules that you want to link in. In this example, we just
+call init_curses(), which sets up to link in the BSD curses routines.
+You'll find this in the file curses.c, which is the processed output of
+curses.mus.
+
+The magicname() routine adds variable names into the symbol table. Along
+with the name of the variable as Perl knows it, we pass a structure containing
+an index identifying the variable, and the names of two C functions that
+know how to set or evaluate a variable given the index of the variable.
+Our example uses a macro to handle this conveniently.
+
+The init routine calls make_usub() to add user-defined subroutine names
+into the symbol table. The arguments are
+
+ make_usub(subname, subindex, subfunc, filename);
+ char *subname;
+ int subindex;
+ int subfunc();
+ char *filename;
+
+The subname is the name that will be used in the Perl program. The subindex
+will be passed to subfunc() when it is called to tell it which C function
+is desired. subfunc() is a glue routine that translates the arguments
+from Perl internal stack form to the form required by the routine in
+question, calls the desired C function, and then translates any return
+value back into the stack format. The glue routine used by curses just
+has a large switch statement, each branch of which does the processing
+for a particular C function. The subindex could, however, be used to look
+up a function in a dynamically linked library. No example of this is
+provided.
+
+As a help in producing the glue routine, a preprocessor called "mus" lets
+you specify argument and return value types in a tabular format. An entry
+such as:
+
+ CASE int waddstr
+ I WINDOW* win
+ I char* str
+ END
+
+indicates that waddstr takes two input arguments, the first of which is a
+pointer to a window, and the second of which is an ordinary C string. It
+also indicates that an integer is returned. The mus program turns this into:
+
+ case US_waddstr:
+ if (items != 2)
+ fatal("Usage: &waddstr($win, $str)");
+ else {
+ int retval;
+ WINDOW* win = *(WINDOW**) str_get(st[1]);
+ char* str = (char*) str_get(st[2]);
+
+ retval = waddstr(win, str);
+ str_numset(st[0], (double) retval);
+ }
+ return sp;
+
+It's also possible to have output parameters, indicated by O, and input/ouput
+parameters indicated by IO.
+
+The mus program isn't perfect. You'll note that curses.mus has some
+cases which are hand coded. They'll be passed straight through unmodified.
+You can produce similar cases by analogy to what's in curses.c, as well
+as similar routines in the doarg.c, dolist.c and doio.c routines of Perl.
+The mus program is only intended to get you about 90% there. It's not clear,
+for instance, how a given structure should be passed to Perl. But that
+shouldn't bother you--if you've gotten this far, it's already obvious
+that you are totally mad.
+
+Here's an example of how to return an array value:
+
+ case US_appl_errlist:
+ if (!wantarray) {
+ str_numset(st[0], (double) appl_nerr);
+ return sp;
+ }
+ astore(stack, sp + appl_nerr, Nullstr); /* extend stack */
+ st = stack->ary_array + sp; /* possibly realloced */
+ for (i = 0; i < appl_nerr; i++) {
+ tmps = appl_errlist[i];
+ st[i] = str_2mortal(str_make(tmps,strlen(tmps)));
+ }
+ return sp + appl_nerr - 1;
+
+
+In addition, there is a program, man2mus, that will scan a man page for
+function prototypes and attempt to construct a mus CASE entry for you. It has
+to guess about input/output parameters, so you'll have to tidy up after it.
+But it can save you a lot of time if the man pages for a library are
+reasonably well formed.
+
+If you happen to have BSD curses on your machine, you might try compiling
+a copy of curseperl. The "pager" program in this directory is a rudimentary
+start on writing a pager--don't believe the help message, which is stolen
+from the less program.
+
+There is currently no official way to call a Perl routine back from C,
+but we're working on it. It might be easiest to fake up a call to do_eval()
+or do_subr(). This is not for the faint of heart. If you come up with
+such a glue routine, I'll be glad to add it into the distribution.
+
+User-defined subroutines may not currently be called as a signal handler,
+though a signal handler may itself call a user-defined subroutine.
-/* $Header: curses.mus,v 3.0.1.1 90/08/09 04:05:21 lwall Locked $
+/* $Header: curses.mus,v 4.0 91/03/20 01:56:13 lwall Locked $
*
* $Log: curses.mus,v $
+ * Revision 4.0 91/03/20 01:56:13 lwall
+ * 4.0 baseline.
+ *
* Revision 3.0.1.1 90/08/09 04:05:21 lwall
* patch19: Initial revision
*
#!./curseperl
-eval <<'EndOfMain'; $evaloffset = 3; # line number of this line
+eval <<'EndOfMain'; $evaloffset = __LINE__;
+ $SIG{'INT'} = 'endit';
$| = 1; # command buffering on stdout
&initterm;
&inithelp;
EndOfMain
-&endwin;
-
-if ($@) {
- print ""; # force flush of stdout
- $@ =~ s/\(eval\)/$0/ && $@ =~ s/line (\d+)/'line ' . ($1 + $evaloffset)/e;
- die $@;
-}
-
-exit;
+&endit;
################################################################################
for (&drawscreen;;&drawscreen) {
$ch = &getch;
- $ch = "j" if $ch eq "\n";
+ $ch = 'j' if $ch eq "\n";
if ($ch eq ' ') {
last if $percent >= 100;
&move(0,0);
$line = 0 if $line < 0;
}
- elsif ($ch eq "j") {
+ elsif ($ch eq 'j') {
+ next if $percent >= 100;
$line += 1;
- if ($dl) {
+ if ($dl && $ho) {
print $ho, $dl;
&mvcur(0,0,$lines2,0);
print $ce,$lines[$line+$lines2],$ce;
&refresh;
redo;
}
- elsif ($ch eq "k") {
+ elsif ($ch eq 'k') {
next if $line <= 0;
$line -= 1;
- if ($al) {
+ if ($al && $ho && $ce) {
print $ho, $al, $ce, $lines[$line];
&wmove($curscr,0,0);
&winsertln($curscr);
elsif ($ch eq "\f") {
&clear;
}
- elsif ($ch eq "q") {
+ elsif ($ch eq 'q') {
last;
}
- elsif ($ch eq "h") {
+ elsif ($ch eq 'h') {
&clear;
&help;
&clear;
sub inithelp {
@helplines = split(/\n/,<<'EOT');
- Commands marked with * may be preceeded by a number, N.
-
h Display this help.
q Exit.
- f, SPACE * Forward N lines, default one screen.
- b * Backward N lines, default one screen.
- e, j, CR * Forward N lines, default 1 line.
- y, k * Backward N lines, default 1 line.
- d * Forward N lines, default 10 or last N to d or u command.
- u * Backward N lines, default 10 or last N to d or u command.
- r Repaint screen.
- R Repaint screen, discarding buffered input.
-
- /pattern * Search forward for N-th line containing the pattern.
- ?pattern * Search backward for N-th line containing the pattern.
- n * Repeat previous search (for N-th occurence).
-
- g * Go to line N, default 1.
- G * Like g, but default is last line in file.
- p, % * Position to N percent into the file.
- m<letter> Mark the current position with <letter>.
- '<letter> Return to a previously marked position.
- '' Return to previous position.
-
- E [file] Examine a new file.
- N * Examine the next file (from the command line).
- P * Examine the previous file (from the command line).
- = Print current file name.
- V Print version number of "less".
-
- -<flag> Toggle a command line flag.
- +cmd Execute the less cmd each time a new file is examined.
-
- !command Passes the command to a shell to be executed.
- v Edit the current file with $EDITOR.
+ SPACE Forward screen.
+ b Backward screen.
+ j, CR Forward 1 line.
+ k Backward 1 line.
+ FF Repaint screen.
EOT
for (@helplines) {
s/$/\n/;
&standend;
&clrtoeol;
}
+
+sub endit {
+ &move($lines1,0);
+ &clrtoeol;
+ &refresh;
+ &endwin;
+
+ if ($@) {
+ print ""; # force flush of stdout
+ $@ =~ s/\(eval\)/$0/ && $@ =~ s/line (\d+)/'line ' . ($1 + $evaloffset)/e;
+ die $@;
+ }
+
+ exit;
+}
-/* $Header: usersub.c,v 3.0.1.1 90/08/09 04:06:10 lwall Locked $
+/* $Header: usersub.c,v 4.0 91/03/20 01:56:34 lwall Locked $
*
* $Log: usersub.c,v $
+ * 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
*
-/* $Header: util.c,v 3.0.1.11 91/01/11 18:33:10 lwall Locked $
+/* $Header: util.c,v 4.0 91/03/20 01:56:39 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: util.c,v $
- * Revision 3.0.1.11 91/01/11 18:33:10 lwall
- * patch42: die could exit with 0 value on some machines
- * patch42: Configure checks typecasting behavior better
- *
- * Revision 3.0.1.10 90/11/10 02:19:28 lwall
- * patch38: random cleanup
- * patch38: sequence of s/^x//; s/x$//; could screw up malloc
- *
- * Revision 3.0.1.9 90/10/20 02:21:01 lwall
- * patch37: tried to take strlen of integer on systems without wait4 or waitpid
- * patch37: unreachable return eliminated
- *
- * Revision 3.0.1.8 90/10/16 11:26:57 lwall
- * patch29: added waitpid
- * patch29: various portability fixes
- * patch29: scripts now run at almost full speed under the debugger
- *
- * Revision 3.0.1.7 90/08/13 22:40:26 lwall
- * patch28: the NSIG hack didn't work right on Xenix
- * patch28: rename was busted on systems without rename system call
- *
- * Revision 3.0.1.6 90/08/09 05:44:55 lwall
- * patch19: fixed double include of <signal.h>
- * patch19: various MSDOS and OS/2 patches folded in
- * patch19: open(STDOUT,"|command") left wrong descriptor attached to STDOUT
- *
- * Revision 3.0.1.5 90/03/27 16:35:13 lwall
- * patch16: MSDOS support
- * patch16: support for machines that can't cast negative floats to unsigned ints
- * patch16: tail anchored pattern could dump if string to search was shorter
- *
- * Revision 3.0.1.4 90/03/01 10:26:48 lwall
- * patch9: fbminstr() called instr() rather than ninstr()
- * patch9: nested evals clobbered their longjmp environment
- * patch9: piped opens returned undefined rather than 0 in child
- * patch9: the x operator is now up to 10 times faster
- *
- * Revision 3.0.1.3 89/12/21 20:27:41 lwall
- * patch7: errno may now be a macro with an lvalue
- *
- * Revision 3.0.1.2 89/11/17 15:46:35 lwall
- * patch5: BZERO separate from BCOPY now
- * patch5: byteorder now is a hex value
- *
- * Revision 3.0.1.1 89/11/11 05:06:13 lwall
- * patch2: made dup2 a little better
- *
- * Revision 3.0 89/10/18 15:32:43 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:56:39 lwall
+ * 4.0 baseline.
*
*/
# include <varargs.h>
#endif
+#ifdef I_FCNTL
+# include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+# include <sys/file.h>
+#endif
+
#define FLUSH
static char nomem[] = "Out of memory!\n";
#endif /* MSDOS */
{
char *ptr;
+#ifndef __STDC__
char *malloc();
+#endif /* ! __STDC__ */
#ifdef MSDOS
if (size > 0xffff) {
#endif /* MSDOS */
{
char *ptr;
+#ifndef __STDC__
char *realloc();
+#endif /* ! __STDC__ */
#ifdef MSDOS
if (size > 0xffff) {
}
#endif
-static bool firstsetenv = TRUE;
+#ifndef __STDC__
extern char **environ;
+#endif
void
setenv(nam,val)
{
register int i=envix(nam); /* where does it go? */
+ if (environ == origenviron) { /* need we copy environment? */
+ int j;
+ int max;
+ char **tmpenv;
+
+ for (max = i; environ[max]; max++) ;
+ New(901,tmpenv, max+2, char*);
+ for (j=0; j<max; j++) /* copy environment */
+ tmpenv[j] = savestr(environ[j]);
+ tmpenv[max] = Nullch;
+ environ = tmpenv; /* tell exec where it is now */
+ }
if (!val) {
while (environ[i]) {
environ[i] = environ[i+1];
return;
}
if (!environ[i]) { /* does not exist yet */
- if (firstsetenv) { /* need we copy environment? */
- int j;
- char **tmpenv;
-
- New(901,tmpenv, i+2, char*);
- firstsetenv = FALSE;
- for (j=0; j<i; j++) /* copy environment */
- tmpenv[j] = environ[j];
- environ = tmpenv; /* tell exec where it is now */
- }
- else
- Renew(environ, i+2, char*); /* just expand it a bit */
+ Renew(environ, i+2, char*); /* just expand it a bit */
environ[i+1] = Nullch; /* make sure it's null terminated */
}
+ else
+ Safefree(environ[i]);
New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
- /* this may or may not be in */
- /* the old environ structure */
#ifndef MSDOS
(void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
#else
/* MS-DOS requires environment variable names to be in uppercase */
- strcpy(environ[i],nam); strupr(environ[i],nam);
+ /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
+ * some utilities and applications may break because they only look
+ * for upper case strings. (Fixed strupr() bug here.)]
+ */
+ strcpy(environ[i],nam); strupr(environ[i]);
(void)sprintf(environ[i] + strlen(nam),"=%s",val);
#endif /* MSDOS */
}
}
#endif
-#ifndef MEMCPY
-#ifndef BCOPY
+#ifndef HAS_MEMCPY
+#ifndef HAS_BCOPY
char *
bcopy(from,to,len)
register char *from;
}
#endif
-#ifndef BZERO
+#ifndef HAS_BZERO
char *
bzero(loc,len)
register char *loc;
#endif
#ifdef VARARGS
-#ifndef VPRINTF
+#ifndef HAS_VPRINTF
#ifdef CHARVSPRINTF
char *
return 0; /* wrong, but perl doesn't use the return value */
}
#endif
-#endif /* VPRINTF */
+#endif /* HAS_VPRINTF */
#endif /* VARARGS */
#ifdef MYSWAP
}
#endif /* BYTEORDER != 0x4321 */
-#endif /* HTONS */
+#endif /* HAS_HTONS */
#ifndef MSDOS
FILE *
close(p[THIS]);
}
if (doexec) {
-#if !defined(FCNTL) || !defined(F_SETFD)
+#if !defined(I_FCNTL) || !defined(F_SETFD)
int fd;
#ifndef NOFILE
if (tmpstab = stabent("$",allstabs))
str_numset(STAB_STR(tmpstab),(double)getpid());
forkprocess = 0;
- hclear(pidstatus); /* we have no children */
+ hclear(pidstatus, FALSE); /* we have no children */
return Nullfp;
#undef THIS
#undef THAT
}
#endif
-#ifndef DUP2
+#ifndef HAS_DUP2
dup2(oldfd,newfd)
int oldfd;
int newfd;
{
-#if defined(FCNTL) && defined(F_DUPFD)
+#if defined(HAS_FCNTL) && defined(F_DUPFD)
close(newfd);
fcntl(oldfd, F_DUPFD, newfd);
#else
int fdx = 0;
int fd;
+ if (oldfd == newfd)
+ return 0;
close(newfd);
while ((fd = dup(oldfd)) != newfd) /* good enough for low fd's */
fdtmp[fdx++] = fd;
if (!pid)
return -1;
-#ifdef WAIT4
- return wait4(pid,statusp,flags,Null(struct rusage *));
+#ifdef HAS_WAIT4
+ return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
#else
-#ifdef WAITPID
+#ifdef HAS_WAITPID
return waitpid(pid,statusp,flags);
#else
if (pid > 0) {
if (flags)
fatal("Can't do waitpid with flags");
else {
- register int count;
- register STR *str;
-
while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
pidgone(result,*statusp);
if (result < 0)
#endif
#endif
}
-#endif /* !MSDOS */
pidgone(pid,status)
int pid;
int status;
{
-#if defined(WAIT4) || defined(WAITPID)
+#if defined(HAS_WAIT4) || defined(HAS_WAITPID)
#else
register STR *str;
char spid[16];
#endif
return;
}
+#endif /* !MSDOS */
-#ifndef MEMCMP
+#ifndef HAS_MEMCMP
memcmp(s1,s2,len)
register unsigned char *s1;
register unsigned char *s2;
}
return 0;
}
-#endif /* MEMCMP */
+#endif /* HAS_MEMCMP */
void
repeatcpy(to,from,len,count)
}
#endif
-#ifndef RENAME
+#ifndef HAS_RENAME
int
same_dirent(a,b)
char *a;
return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
}
-#endif /* !RENAME */
+#endif /* !HAS_RENAME */
+
+unsigned long
+scanoct(start, len, retlen)
+char *start;
+int len;
+int *retlen;
+{
+ register char *s = start;
+ register unsigned long retval = 0;
+
+ while (len-- && *s >= '0' && *s <= '7') {
+ retval <<= 3;
+ retval |= *s++ - '0';
+ }
+ *retlen = s - start;
+ return retval;
+}
+
+unsigned long
+scanhex(start, len, retlen)
+char *start;
+int len;
+int *retlen;
+{
+ register char *s = start;
+ register unsigned long retval = 0;
+ char *tmp;
+
+ while (len-- && *s && (tmp = index(hexdigit, *s))) {
+ retval <<= 4;
+ retval |= (tmp - hexdigit) & 15;
+ s++;
+ }
+ *retlen = s - start;
+ return retval;
+}
-/* $Header: util.h,v 3.0.1.2 89/11/17 15:48:01 lwall Locked $
+/* $Header: util.h,v 4.0 91/03/20 01:56:48 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: util.h,v $
- * Revision 3.0.1.2 89/11/17 15:48:01 lwall
- * patch5: BZERO separate from BCOPY now
- *
- * Revision 3.0.1.1 89/10/26 23:28:25 lwall
- * patch1: declared bcopy if necessary
- *
- * Revision 3.0 89/10/18 15:33:18 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:56:48 lwall
+ * 4.0 baseline.
*
*/
char *nsavestr();
FILE *mypopen();
int mypclose();
-#ifndef MEMCPY
-#ifndef BCOPY
+#ifndef HAS_MEMCPY
+#ifndef HAS_BCOPY
char *bcopy();
#endif
-#ifndef BZERO
+#ifndef HAS_BZERO
char *bzero();
#endif
#endif
+unsigned long scanoct();
+unsigned long scanhex();
-/* $Header: EXTERN.h,v 3.0 89/10/18 15:33:37 lwall Locked $
+/* $Header: EXTERN.h,v 4.0 91/03/20 01:56:53 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: EXTERN.h,v $
- * Revision 3.0 89/10/18 15:33:37 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:56:53 lwall
+ * 4.0 baseline.
*
*/
-/* $Header: INTERN.h,v 3.0 89/10/18 15:33:45 lwall Locked $
+/* $Header: INTERN.h,v 4.0 91/03/20 01:56:58 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: INTERN.h,v $
- * Revision 3.0 89/10/18 15:33:45 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:56:58 lwall
+ * 4.0 baseline.
*
*/
ln ../../config.sh . || \
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
- fi
+ fi 2>/dev/null
. ./config.sh
;;
esac
esac
echo "Extracting x2p/Makefile (with variable substitutions)"
cat >Makefile <<!GROK!THIS!
-# $Header: Makefile.SH,v 3.0.1.8 91/01/11 18:34:40 lwall Locked $
+# $Header: Makefile.SH,v 4.0 91/03/20 01:57:03 lwall Locked $
#
# $Log: Makefile.SH,v $
-# Revision 3.0.1.8 91/01/11 18:34:40 lwall
-# patch42: x2p/Makefile.SH blew up on /afs misfeature
-#
-# Revision 3.0.1.7 90/11/10 02:20:15 lwall
-# patch38: random cleanup
-#
-# Revision 3.0.1.6 90/10/16 11:28:18 lwall
-# patch29: various portability fixes
-#
-# Revision 3.0.1.5 90/08/13 22:41:05 lwall
-# patch28: shift/reduce count was off for a2p's Makefile
-#
-# Revision 3.0.1.4 90/03/01 10:28:09 lwall
-# patch9: a2p didn't allow logical expressions everywhere it should
-#
-# Revision 3.0.1.3 89/12/21 20:29:00 lwall
-# patch7: Configure now lets you pick between yacc or bison
-#
-# Revision 3.0.1.2 89/11/17 15:49:55 lwall
-# patch: in x2p/Makefile.SH, removed reference to nm library
-#
-# Revision 3.0.1.1 89/10/26 23:29:11 lwall
-# patch1: in x2p/Makefile.SH, added dependency on ../config.sh
-#
-# Revision 3.0 89/10/18 15:33:52 lwall
-# 3.0 baseline
-#
-# Revision 2.0.1.2 88/09/07 17:13:30 lwall
-# patch14: added redirection of stderr to /dev/null
-#
-# Revision 2.0.1.1 88/07/11 23:13:39 root
-# patch2: now expects more shift/reduce errors
-#
-# Revision 2.0 88/06/05 00:15:31 root
-# Baseline version 2.0.
+# Revision 4.0 91/03/20 01:57:03 lwall
+# 4.0 baseline.
#
#
cat >>Makefile <<'!NO!SUBS!'
-public = a2p s2p
+public = a2p s2p find2perl
private =
-/* $Header: a2p.h,v 3.0.1.3 90/03/01 10:29:29 lwall Locked $
+/* $Header: a2p.h,v 4.0 91/03/20 01:57:07 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: a2p.h,v $
- * Revision 3.0.1.3 90/03/01 10:29:29 lwall
- * patch9: a2p.h had bzero() definition depending on BCOPY
- *
- * Revision 3.0.1.2 89/12/21 20:30:29 lwall
- * patch7: arranged so a2p has a chance of running on a 286
- *
- * Revision 3.0.1.1 89/11/11 05:07:00 lwall
- * patch2: Configure may now set -DDEBUGGING
- *
- * Revision 3.0 89/10/18 15:34:14 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:57:07 lwall
+ * 4.0 baseline.
*
*/
#define VOIDUSED 1
#include "../config.h"
-#ifndef BCOPY
+#ifndef HAS_BCOPY
# define bcopy(s1,s2,l) memcpy(s2,s1,l)
#endif
-#ifndef BZERO
+#ifndef HAS_BZERO
# define bzero(s,l) memset(s,0,l)
#endif
EXT int line INIT(0);
EXT FILE *rsfp;
-EXT char buf[1024];
+EXT char buf[2048];
EXT char *bufptr INIT(buf);
EXT STR *linestr INIT(Nullstr);
-EXT char tokenbuf[256];
+EXT char tokenbuf[2048];
EXT int expectterm INIT(TRUE);
#ifdef DEBUGGING
.rn '' }`
-''' $Header: a2p.man,v 3.0 89/10/18 15:34:22 lwall Locked $
+''' $Header: a2p.man,v 4.0 91/03/20 01:57:11 lwall Locked $
'''
''' $Log: a2p.man,v $
+''' Revision 4.0 91/03/20 01:57:11 lwall
+''' 4.0 baseline.
+'''
''' Revision 3.0 89/10/18 15:34:22 lwall
''' 3.0 baseline
'''
%{
-/* $Header: a2p.y,v 3.0.1.3 91/01/11 18:35:57 lwall Locked $
+/* $Header: a2p.y,v 4.0 91/03/20 01:57:21 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: a2p.y,v $
- * Revision 3.0.1.3 91/01/11 18:35:57 lwall
- * patch42: a2p didn't recognize split with regular expression
- * patch42: a2p didn't handle > redirection right
- *
- * Revision 3.0.1.2 90/08/09 05:47:26 lwall
- * patch19: a2p didn't handle {foo = (bar == 123)}
- *
- * Revision 3.0.1.1 90/03/01 10:30:08 lwall
- * patch9: a2p didn't allow logical expressions everywhere it should
- *
- * Revision 3.0 89/10/18 15:34:29 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:57:21 lwall
+ * 4.0 baseline.
*
*/
-/* $Header: a2py.c,v 3.0.1.2 90/10/16 11:30:34 lwall Locked $
+/* $Header: a2py.c,v 4.0 91/03/20 01:57:26 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: a2py.c,v $
- * Revision 3.0.1.2 90/10/16 11:30:34 lwall
- * patch29: various portability fixes
- *
- * Revision 3.0.1.1 90/08/09 05:48:53 lwall
- * patch19: a2p didn't emit a chop when NF was referenced though split needs it
- *
- * Revision 3.0 89/10/18 15:34:35 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:57:26 lwall
+ * 4.0 baseline.
*
*/
d--;
}
if (d > t+3) {
- *d = '\0';
+ char save[2048];
+ strcpy(save, d);
+ *d = '\n';
+ d[1] = '\0';
putone();
putchar('\n');
if (d[-1] != ';' && !(newpos % 4)) {
*t++ = ' ';
newpos += 2;
}
- strcpy(t,d+1);
+ strcpy(t,save+1);
newpos += strlen(t);
d = t + strlen(t);
pos = newpos;
--- /dev/null
+case $CONFIG in
+'')
+ if test ! -f config.sh; then
+ ln ../config.sh . || \
+ ln ../../config.sh . || \
+ ln ../../../config.sh . || \
+ (echo "Can't find config.sh."; exit 1)
+ fi
+ . config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting find2perl (with variable substitutions)"
+: This section of the file will have variable substitutions done on it.
+: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
+: Protect any dollar signs and backticks that you do not want interpreted
+: by putting a backslash in front. You may delete these comments.
+$spitshell >find2perl <<!GROK!THIS!
+#!$bin/perl
+
+\$bin = "$bin";
+
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>find2perl <<'!NO!SUBS!'
+
+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;
+ 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($indent) = $indent - 4;
+ $out .= "\n" . &tab . "||\n";
+ shift;
+ }
+ else {
+ $out .= " &&" unless $ARGV[0] eq ')';
+ $out .= "\n";
+ shift if $ARGV[0] eq '-a';
+ }
+ }
+}
+
+print <<"END";
+#!$bin/perl
+
+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;
+
+print <<"END";
+# Traverse desired filesystems
+
+&dodirs($roots);
+$flushall
+exit;
+
+sub wanted {
+$out;
+}
+
+END
+
+print <<'END';
+sub dodirs {
+ chop($cwd = `pwd`);
+ foreach $topdir (@_) {
+ (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+ || (warn("Can't stat $topdir: $!\n"), next);
+ if (-d _) {
+ if (chdir($topdir)) {
+END
+if ($depth) {
+ print <<'END';
+ $topdir = '' if $topdir eq '/';
+ &dodir($topdir,$topnlink);
+ ($dir,$_) = ($topdir,'.');
+ $name = $topdir;
+ &wanted;
+END
+}
+else {
+ print <<'END';
+ ($dir,$_) = ($topdir,'.');
+ $name = $topdir;
+ &wanted;
+ $topdir = '' if $topdir eq '/';
+ &dodir($topdir,$topnlink);
+END
+}
+print <<'END';
+ }
+ else {
+ warn "Can't cd to $topdir: $!\n";
+ }
+ }
+ else {
+ unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ ($dir,$_) = ('.', $topdir);
+ }
+ chdir $dir && &wanted;
+ }
+ chdir $cwd;
+ }
+}
+
+sub dodir {
+ local($dir,$nlink) = @_;
+ local($dev,$ino,$mode,$subcount);
+ local($name);
+
+ # Get the list of files in the current directory.
+
+ opendir(DIR,'.') || warn "Can't open $dir: $!\n";
+ local(@filenames) = readdir(DIR);
+ closedir(DIR);
+
+ if ($nlink == 2) { # This dir has no subdirectories.
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $name = "$dir/$_";
+ &wanted;
+ }
+ }
+ else { # This dir has subdirectories.
+ $subcount = $nlink - 2;
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $nlink = $prune = 0;
+ $name = "$dir/$_";
+END
+print <<'END' unless $depth;
+ &wanted;
+END
+print <<'END';
+ if ($subcount > 0) { # Seen all the subdirs?
+
+ # Get link count and check for directoriness.
+
+ ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+
+ if (-d _) {
+
+ # It really is a directory, so do it recursively.
+
+ if (!$prune && chdir $_) {
+ &dodir($name,$nlink);
+ chdir '..';
+ }
+ --$subcount;
+ }
+ }
+END
+print <<'END' if $depth;
+ &wanted;
+END
+print <<'END';
+ }
+ }
+}
+
+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, $_) || 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, $_) || 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 ($_ !~ /^(name|print)/) {
+ if (!$statdone) {
+ $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/^-0*/< / || $n =~ s/^\+0*/> / || $n =~ s/^0*/== /;
+ $n;
+}
+
+sub quote {
+ local($string) = @_;
+ $string =~ s/'/\\'/;
+ "'$string'";
+}
+!NO!SUBS!
+chmod 755 find2perl
+$eunicefix find2perl
-/* $Header: handy.h,v 3.0 89/10/18 15:34:44 lwall Locked $
+/* $Header: handy.h,v 4.0 91/03/20 01:57:45 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: handy.h,v $
- * Revision 3.0 89/10/18 15:34:44 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:57:45 lwall
+ * 4.0 baseline.
*
*/
-/* $Header: hash.c,v 3.0 89/10/18 15:34:50 lwall Locked $
+/* $Header: hash.c,v 4.0 91/03/20 01:57:49 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: hash.c,v $
- * Revision 3.0 89/10/18 15:34:50 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:57:49 lwall
+ * 4.0 baseline.
*
*/
continue;
if (strNE(entry->hent_key,key)) /* is this it? */
continue;
+ /*NOSTRICT*/
safefree((char*)entry->hent_val);
entry->hent_val = val;
return TRUE;
}
+ /*NOSTRICT*/
entry = (HENT*) safemalloc(sizeof(HENT));
entry->hent_key = savestr(key);
-/* $Header: hash.h,v 3.0 89/10/18 15:34:57 lwall Locked $
+/* $Header: hash.h,v 4.0 91/03/20 01:57:53 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: hash.h,v $
- * Revision 3.0 89/10/18 15:34:57 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:57:53 lwall
+ * 4.0 baseline.
*
*/
ln ../../config.sh . || \
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
- fi
+ fi 2>/dev/null
. ./config.sh
;;
esac
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>s2p <<'!NO!SUBS!'
-# $Header: s2p.SH,v 3.0.1.7 91/01/11 18:36:44 lwall Locked $
+# $Header: s2p.SH,v 4.0 91/03/20 01:57:59 lwall Locked $
#
# $Log: s2p.SH,v $
-# Revision 3.0.1.7 91/01/11 18:36:44 lwall
-# patch42: x2p/s2p.SH blew up on /afs misfeature
-#
-# Revision 3.0.1.6 90/10/20 02:21:43 lwall
-# patch37: changed some ". config.sh" to ". ./config.sh"
-#
-# Revision 3.0.1.5 90/10/16 11:32:40 lwall
-# patch29: s2p modernized
-#
-# Revision 3.0.1.4 90/08/09 05:50:43 lwall
-# patch19: s2p didn't translate \n right
-#
-# Revision 3.0.1.3 90/03/01 10:31:21 lwall
-# patch9: s2p didn't handle \< and \>
-#
-# Revision 3.0.1.2 89/11/17 15:51:27 lwall
-# patch5: in s2p, line labels without a subsequent statement were done wrong
-# patch5: s2p left residue in /tmp
-#
-# Revision 3.0.1.1 89/11/11 05:08:25 lwall
-# patch2: in s2p, + within patterns needed backslashing
-# patch2: s2p was printing out some debugging info to the output file
-#
-# Revision 3.0 89/10/18 15:35:02 lwall
-# 3.0 baseline
-#
-# Revision 2.0.1.1 88/07/11 23:26:23 root
-# patch2: s2p didn't put a proper prologue on output script
-#
-# Revision 2.0 88/06/05 00:15:55 root
-# Baseline version 2.0.
+# Revision 4.0 91/03/20 01:57:59 lwall
+# 4.0 baseline.
#
#
.rn '' }`
-''' $Header: s2p.man,v 3.0 89/10/18 15:35:09 lwall Locked $
+''' $Header: s2p.man,v 4.0 91/03/20 01:58:07 lwall Locked $
'''
''' $Log: s2p.man,v $
+''' Revision 4.0 91/03/20 01:58:07 lwall
+''' 4.0 baseline.
+'''
''' Revision 3.0 89/10/18 15:35:09 lwall
''' 3.0 baseline
'''
-/* $Header: str.c,v 3.0 89/10/18 15:35:18 lwall Locked $
+/* $Header: str.c,v 4.0 91/03/20 01:58:15 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: str.c,v $
- * Revision 3.0 89/10/18 15:35:18 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:58:15 lwall
+ * 4.0 baseline.
*
*/
/* make a string that will exist for the duration of the expression eval */
STR *
-str_static(oldstr)
+str_mortal(oldstr)
STR *oldstr;
{
register STR *str = str_new(0);
-/* $Header: str.h,v 3.0 89/10/18 15:35:27 lwall Locked $
+/* $Header: str.h,v 4.0 91/03/20 01:58:21 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: str.h,v $
- * Revision 3.0 89/10/18 15:35:27 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:58:21 lwall
+ * 4.0 baseline.
*
*/
char *str_2ptr();
double str_2num();
-STR *str_static();
+STR *str_mortal();
STR *str_make();
STR *str_nmake();
char *str_gets();
-/* $Header: util.c,v 3.0.1.1 90/10/16 11:34:06 lwall Locked $
+/* $Header: util.c,v 4.0 91/03/20 01:58:25 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: util.c,v $
- * Revision 3.0.1.1 90/10/16 11:34:06 lwall
- * patch29: removed #ifdef undef
- *
- * Revision 3.0 89/10/18 15:35:35 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:58:25 lwall
+ * 4.0 baseline.
*
*/
-/* $Header: util.h,v 3.0 89/10/18 15:35:41 lwall Locked $
+/* $Header: util.h,v 4.0 91/03/20 01:58:29 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: util.h,v $
- * Revision 3.0 89/10/18 15:35:41 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:58:29 lwall
+ * 4.0 baseline.
*
*/
-/* $Header: walk.c,v 3.0.1.6 90/10/16 11:35:51 lwall Locked $
+/* $Header: walk.c,v 4.0 91/03/20 01:58:36 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: walk.c,v $
- * Revision 3.0.1.6 90/10/16 11:35:51 lwall
- * patch29: a2p mistranslated certain weird field separators
- *
- * Revision 3.0.1.5 90/08/09 05:55:01 lwall
- * patch19: a2p emited local($_) without a semicolon
- * patch19: a2p didn't make explicit split on whitespace skip leading whitespace
- * patch19: foreach on a normal array was iterating on values instead of indexes
- *
- * Revision 3.0.1.4 90/03/01 10:32:45 lwall
- * patch9: a2p didn't put a $ on ExitValue
- *
- * Revision 3.0.1.3 89/12/21 20:32:35 lwall
- * patch7: in a2p, user-defined functions didn't work on some machines
- *
- * Revision 3.0.1.2 89/11/17 15:53:00 lwall
- * patch5: on Pyramids, index(s, '}' + 128) doesn't find meta-}
- *
- * Revision 3.0.1.1 89/11/11 05:09:33 lwall
- * patch2: in a2p, awk script with no line actions still needs main loop
- *
- * Revision 3.0 89/10/18 15:35:48 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:58:36 lwall
+ * 4.0 baseline.
*
*/
s = "\"";
*d++ = *t++ + 128;
switch (*t) {
- case '\\': case '"': case 'n': case 't':
+ case '\\': case '"': case 'n': case 't': case '$':
break;
default: /* hide this from perl */
*d++ = '\\' + 128;
tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
else
tmpstr = str_new(0);;
- if (!*tmpstr->str_ptr) {
+ if (!tmpstr->str_ptr || !*tmpstr->str_ptr) {
if (lval_field) {
t = saw_OFS ? "$," : "' '";
if (split_to_array) {
https://perl5.git.perl.org / perl5.git / commitdiff