See patch #4.
(or arg (setq arg 1))
(if (< arg 0) (forward-char 1))
(and (/= arg 0)
- (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*="
+ (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*=\\|^\\."
nil 'move arg)
(goto-char (1- (match-end 0))))
(point))
$val = eval "&$var;";
if ($@) {
warn "$@: $_";
- print <<EOT
+ print <<EOT;
warn "\$$var isn't correctly set" if defined \$_main{'$var'};
EOT
next;
-/* $Header: hash.h,v 4.0 91/03/20 01:22:38 lwall Locked $
+/* $RCSfile: hash.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:10:33 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, 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.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: hash.h,v $
+ * Revision 4.0.1.1 91/06/07 11:10:33 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:22:38 lwall
* 4.0 baseline.
*
-d_syscall=$undef
echo " "
echo "NOTE: regression test op.read may fail due to an NFS bug in HP/UX."
echo "If so, don't worry about it."
+case `(uname -r) 2>/dev/null` in
+*3.1*) d_syscall=$undef ;;
+*2.1*) libswanted=`echo $libswanted | sed 's/ malloc / /'` ;;
+esac
-optimize='-g'
+cmd_cflags='optimize="-g"'
+perl_cflags='optimize="-g"'
+tcmd_cflags='optimize="-g"'
+tperl_cflags='optimize="-g"'
d_volatile=undef
d_castneg=undef
cc=cc
libpth="/usr/lib/cmplrs/cc $libpth"
groupstype=int
+nm_opts='-B'
+case $PATH in
+*bsd*:/bin:*) cat <<END
+NOTE: Some people have reported having much better luck with Mips CC than
+with the BSD cc. Put /bin first in your PATH if you have difficulties.
+END
+;;
+esac
: Just disable defaulting to -fpcc-struct-return, since gcc is native compiler.
-ccflags="$ccflags "
+nativegcc='define'
+groupstype="int"
+usemymalloc="n"
shift;
}
-@scripts = 'h2ph';
-@manpages = ('perl.man', 'h2ph.man');
+@scripts = ('h2ph', 'x2p/s2p', 'x2p/find2perl');
+@manpages = ('perl.man', 'h2ph.man', 'x2p/a2p.man', 'x2p/s2p.man');
$version = sprintf("%5.3f", $]);
$release = substr($version,0,3);
&link("$installbin/sperl$ver", "$installbin/suidperl") if $d_dosuid;
}
+($bdev,$bino) = stat($installbin);
+($ddev,$dino) = stat('x2p');
+
+if ($bdev != $ddev || $bino != $dino) {
+ &unlink("$installbin/a2p");
+ &cmd("cp x2p/a2p $installbin/a2p");
+}
+
# Make some enemies in the name of standardization. :-)
($udev,$uino) = stat("/usr/bin");
# Install scripts.
-&makedir($scriptdir);
+&makedir($installscr);
for (@scripts) {
- &cmd("cp $_ $scriptdir");
- &chmod(0755, "$scriptdir/$_");
+ &cmd("cp $_ $installscr");
+ s#.*/##; &chmod(0755, "$installscr/$_");
}
# Install library files.
if ($mdev != $ddev || $mino != $dino) {
for (@manpages) {
($new = $_) =~ s/man$/$manext/;
+ $new =~ s#.*/##;
print STDERR " Installing $mansrc/$new\n";
next if $nonono;
open(MI,$_);
--- /dev/null
+# newgetopt.pl -- new options parsing
+
+# SCCS Status : @(#)@ newgetopt.pl 1.7
+# Author : Johan Vromans
+# Created On : Tue Sep 11 15:00:12 1990
+# Last Modified By: Johan Vromans
+# Last Modified On: Sun Oct 14 14:35:36 1990
+# Update Count : 34
+# Status : Okay
+
+# This package implements a new getopt function. This function adheres
+# to the new syntax (long option names, no bundling).
+#
+# Arguments to the function are:
+#
+# - a list of possible options. These should designate valid perl
+# identifiers, optionally followed by an argument specifier ("="
+# for mandatory arguments or ":" for optional arguments) and an
+# argument type specifier: "n" or "i" for integer numbers, "f" for
+# real (fix) numbers or "s" for strings.
+#
+# - if the first option of the list consists of non-alphanumeric
+# characters only, it is interpreted as a generic option starter.
+# Everything starting with one of the characters from the starter
+# will be considered an option.
+# Likewise, a double occurrence (e.g. "--") signals end of
+# the options list.
+# The default value for the starter is "-".
+#
+# Upon return, the option variables, prefixed with "opt_", are defined
+# and set to the respective option arguments, if any.
+# Options that do not take an argument are set to 1. Note that an
+# option with an optional argument will be defined, but set to '' if
+# no actual argument has been supplied.
+# A return status of 0 (false) indicates that the function detected
+# one or more errors.
+#
+# Special care is taken to give a correct treatment to optional arguments.
+#
+# E.g. if option "one:i" (i.e. takes an optional integer argument),
+# then the following situations are handled:
+#
+# -one -two -> $opt_one = '', -two is next option
+# -one -2 -> $opt_one = -2
+#
+# Also, assume "foo=s" and "bar:s" :
+#
+# -bar -xxx -> $opt_bar = '', '-xxx' is next option
+# -foo -bar -> $opt_foo = '-bar'
+# -foo -- -> $opt_foo = '--'
+#
+
+# HISTORY
+# 20-Sep-1990 Johan Vromans
+# Set options w/o argument to 1.
+# Correct the dreadful semicolon/require bug.
+
+
+package newgetopt;
+
+$debug = 0; # for debugging
+
+sub main'NGetOpt {
+ local (@optionlist) = @_;
+ local ($[) = 0;
+ local ($genprefix) = "-";
+ local ($error) = 0;
+ local ($opt, $optx, $arg, $type, $mand, @hits);
+
+ # See if the first element of the optionlist contains option
+ # starter characters.
+ $genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
+
+ # Turn into regexp.
+ $genprefix =~ s/(\W)/\\\1/g;
+ $genprefix = "[" . $genprefix . "]";
+
+ # Verify correctness of optionlist.
+ @hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
+ if ( $#hits >= 0 ) {
+ foreach $opt ( @hits ) {
+ print STDERR ("Error in option spec: \"", $opt, "\"\n");
+ $error++;
+ }
+ return 0;
+ }
+
+ # Process argument list
+
+ while ( $#main'ARGV >= 0 ) { #'){
+
+ # >>> See also the continue block <<<
+
+ # Get next argument
+ $opt = shift (@main'ARGV); #');
+ print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+ $arg = undef;
+
+ # Check for exhausted list.
+ if ( $opt =~ /^$genprefix/o ) {
+ # Double occurrence is terminator
+ return ($error == 0) if $opt eq "$+$+";
+ $opt = $'; # option name (w/o prefix)
+ }
+ else {
+ # Apparently not an option - push back and exit.
+ unshift (@main'ARGV, $opt); #');
+ return ($error == 0);
+ }
+
+ # Grep in option list. Hide regexp chars from option.
+ ($optx = $opt) =~ s/(\W)/\\\1/g;
+ @hits = grep (/^$optx([=:].+)?$/, @optionlist);
+ if ( $#hits != 0 ) {
+ print STDERR ("Unknown option: ", $opt, "\n");
+ $error++;
+ next;
+ }
+
+ # Determine argument status.
+ undef $type;
+ $type = $+ if $hits[0] =~ /[=:].+$/;
+ print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
+
+ # If it is an option w/o argument, we're almost finished with it.
+ if ( ! defined $type ) {
+ $arg = 1; # supply explicit value
+ next;
+ }
+
+ # Get mandatory status and type info.
+ ($mand, $type) = $type =~ /^(.)(.)$/;
+
+ # Check if the argument list is exhausted.
+ if ( $#main'ARGV < 0 ) { #'){
+
+ # Complain if this option needs an argument.
+ if ( $mand eq "=" ) {
+ print STDERR ("Option ", $opt, " requires an argument\n");
+ $error++;
+ }
+ next;
+ }
+
+ # Get (possibly optional) argument.
+ $arg = shift (@main'ARGV); #');
+
+ # Check if it is a valid argument. A mandatory string takes
+ # anything.
+ if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
+
+ # Check for option list terminator.
+ if ( $arg eq "$+$+" ) {
+ # Complain if an argument is required.
+ if ($mand eq "=") {
+ print STDERR ("Option ", $opt, " requires an argument\n");
+ $error++;
+ }
+ # Push back so the outer loop will terminate.
+ unshift (@main'ARGV, $arg); #');
+ $arg = ""; # don't assign it
+ next;
+ }
+
+ # Maybe the optional argument is the next option?
+ if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
+ # Yep. Push back.
+ unshift (@main'ARGV, $arg); #');
+ $arg = ""; # don't assign it
+ next;
+ }
+ }
+
+ if ( $type eq "n" || $type eq "i" ) { # numeric/integer
+ if ( $arg !~ /^-?[0-9]+$/ ) {
+ print STDERR ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (numeric required)\n");
+ $error++;
+ }
+ next;
+ }
+
+ if ( $type eq "f" ) { # fixed real number, int is also ok
+ if ( $arg !~ /^-?[0-9.]+$/ ) {
+ print STDERR ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number required)\n");
+ $error++;
+ }
+ next;
+ }
+
+ if ( $type eq "s" ) { # string
+ next;
+ }
+
+ }
+ continue {
+ print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
+ eval ("\$main'opt_$opt = \$arg");
+ }
+
+ return ($error == 0);
+}
+1;
echo "Extracting makedepend (with variable substitutions)"
$spitshell >makedepend <<!GROK!THIS!
$startsh
-# $Header: makedepend.SH,v 4.0 91/03/20 01:27:04 lwall Locked $
+# $RCSfile: makedepend.SH,v $$Revision: 4.0.1.2 $$Date: 91/06/07 15:40:06 $
#
# $Log: makedepend.SH,v $
+# Revision 4.0.1.2 91/06/07 15:40:06 lwall
+# patch4: fixed cppstdin to run in the right directory
+#
+# Revision 4.0.1.1 91/06/07 11:20:06 lwall
+# patch4: Makefile is no longer self-modifying code under makedepend
+#
# Revision 4.0 91/03/20 01:27:04 lwall
# 4.0 baseline.
#
cat='$cat'
cppflags='$cppflags'
cp='$cp'
-cpp='$cppstdin'
+cppstdin='$cppstdin'
+cppminus='$cppminus'
echo='$echo'
egrep='$egrep'
expr='$expr'
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
- mf=Makefile
-else
- mf=makefile
+ cp Makefile makefile
fi
+mf=makefile
if test -f $mf; then
defrule=`<$mf sed -n \
-e '/^\.c\.o:.*;/{' \
-e 's|\\$||' \
-e p \
-e '}'
- $cpp -I/usr/local/include -I. $cppflags $file.c | \
+ $cppstdin -I/usr/local/include -I. $cppflags $cppminus <$file.c | sed -e 's#\.[0-9][0-9]*\.c#'"$file.c#" | \
$sed \
-e '/^# *[0-9]/!d' \
-e 's/^.*"\(.*\)".*$/'$filebase'.o: \1/' \
$uniq | $sort | $uniq >> .deptmp
done
-$sed <Makefile >Makefile.new -e '1,/^# AUTOMATICALLY/!d'
+$sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d'
make shlist || ($echo "Searching for .SH files..."; \
$echo *.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist)
if $test -s .deptmp; then
for file in `cat .shlist`; do
- $echo `$expr X$file : 'X\(.*\).SH`: $file config.sh \; \
+ $echo `$expr X$file : 'X\(.*\).SH'`: $file config.sh \; \
/bin/sh $file >> .deptmp
done
- $echo "Updating Makefile..."
+ $echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
- >> Makefile.new
+ >> $mf.new
$sed 's|^\(.*\.o:\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
- >>Makefile.new
+ >>$mf.new
else
make hlist || ($echo "Searching for .h files..."; \
$echo *.h | $tr ' ' '\012' | $egrep -v '\*' >.hlist)
$echo "You don't seem to have a proper C preprocessor. Using grep instead."
$egrep '^#include ' `cat .clist` `cat .hlist` >.deptmp
- $echo "Updating Makefile..."
+ $echo "Updating $mf..."
<.clist $sed -n \
-e '/\//{' \
-e 's|^\(.*\)/\(.*\)\.c|\2.o: \1/\2.c; '"$defrule \1/\2.c|p" \
-e d \
-e '}' \
- -e 's|^\(.*\)\.c|\1.o: \1.c|p' >> Makefile.new
+ -e 's|^\(.*\)\.c|\1.o: \1.c|p' >> $mf.new
<.hlist $sed -n 's|\(.*/\)\(.*\)|s= \2= \1\2=|p' >.hsed
<.deptmp $sed -n 's|c:#include "\(.*\)".*$|o: \1|p' | \
$sed 's|^[^;]*/||' | \
- $sed -f .hsed >> Makefile.new
+ $sed -f .hsed >> $mf.new
<.deptmp $sed -n 's|c:#include <\(.*\)>.*$|o: /usr/include/\1|p' \
- >> Makefile.new
+ >> $mf.new
<.deptmp $sed -n 's|h:#include "\(.*\)".*$|h: \1|p' | \
- $sed -f .hsed >> Makefile.new
+ $sed -f .hsed >> $mf.new
<.deptmp $sed -n 's|h:#include <\(.*\)>.*$|h: /usr/include/\1|p' \
- >> Makefile.new
+ >> $mf.new
for file in `$cat .shlist`; do
- $echo `$expr X$file : 'X\(.*\).SH`: $file config.sh \; \
- /bin/sh $file >> Makefile.new
+ $echo `$expr X$file : 'X\(.*\).SH'`: $file config.sh \; \
+ /bin/sh $file >> $mf.new
done
fi
-$rm -f Makefile.old
-$cp Makefile Makefile.old
-$cp Makefile.new Makefile
-$rm Makefile.new
-$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> Makefile
+$rm -f $mf.old
+$cp $mf $mf.old
+$cp $mf.new $mf
+$rm $mf.new
+$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
$rm -f .deptmp `sed 's/\.c/.c.c/' .clist` .shlist .clist .hlist .hsed
!NO!SUBS!
-/* $RCSfile: malloc.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:48:31 $
+/* $RCSfile: malloc.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:20:45 $
*
* $Log: malloc.c,v $
+ * Revision 4.0.1.2 91/06/07 11:20:45 lwall
+ * patch4: many, many itty-bitty portability fixes
+ *
* Revision 4.0.1.1 91/04/11 17:48:31 lwall
* patch1: Configure now figures out malloc ptr type
*
p->ov_rmagic = RMAGIC;
*((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
#endif
- return ((char *)(p + 1));
+ return ((MALLOCPTRTYPE *)(p + 1));
}
/*
}
void
-free(cp)
- char *cp;
+free(mp)
+ MALLOCPTRTYPE *mp;
{
register int size;
register union overhead *op;
+ char *cp = (char*)mp;
if (cp == NULL)
return;
int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */
MALLOCPTRTYPE *
-realloc(cp, nbytes)
- char *cp;
+realloc(mp, nbytes)
+ MALLOCPTRTYPE *mp;
unsigned nbytes;
{
register u_int onb;
char *res;
register int i;
int was_alloced = 0;
+ char *cp = (char*)mp;
if (cp == NULL)
return (malloc(nbytes));
*((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
}
#endif
- return(cp);
+ return((MALLOCPTRTYPE*)cp);
}
- if ((res = malloc(nbytes)) == NULL)
+ if ((res = (char*)malloc(nbytes)) == NULL)
return (NULL);
if (cp != res) /* common optimization */
(void)bcopy(cp, res, (int)((nbytes < onb) ? nbytes : onb));
if (was_alloced)
free(cp);
- return (res);
+ return ((MALLOCPTRTYPE*)res);
}
/*
-/* $Header: msdos.c,v 4.0 91/03/20 01:34:46 lwall Locked $
+/* $RCSfile: msdos.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:37 $
*
* (C) Copyright 1989, 1990 Diomidis Spinellis.
*
- * 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.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: msdos.c,v $
+ * Revision 4.0.1.1 91/06/07 11:22:37 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:34:46 lwall
* 4.0 baseline.
*
-/* $Header: os2.c,v 4.0 91/03/20 01:36:21 lwall Locked $
+/* $RCSfile: os2.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:23:06 $
*
* (C) Copyright 1989, 1990 Diomidis Spinellis.
*
- * 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.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: os2.c,v $
+ * Revision 4.0.1.1 91/06/07 11:23:06 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:36:21 lwall
* 4.0 baseline.
*
-#define PATCHLEVEL 6
+#define PATCHLEVEL 7
-char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:49:05 $\nPatch level: ###\n";
+char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.3 $$Date: 91/06/07 11:40:18 $\nPatch level: ###\n";
/*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, 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.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: perl.c,v $
+ * Revision 4.0.1.3 91/06/07 11:40:18 lwall
+ * patch4: changed old $^P to $^X
+ *
+ * Revision 4.0.1.2 91/06/07 11:26:16 lwall
+ * patch4: new copyright notice
+ * patch4: added $^P variable to control calling of perldb routines
+ * patch4: added $^F variable to specify maximum system fd, default 2
+ * patch4: debugger lost track of lines in eval
+ *
* Revision 4.0.1.1 91/04/11 17:49:05 lwall
* patch1: fixed undefined environ problem
*
#include "patchlevel.h"
#endif
+char *getenv();
+
#ifdef IAMSUID
#ifndef DOSUID
#define DOSUID
{
register STR *str;
register char *s;
- char *index(), *strcpy(), *getenv();
+ char *getenv();
bool dosearch = FALSE;
#ifdef DOSUID
char *validarg = "";
(void)hadd(sigstab);
}
- magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\024\027");
+ magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
userinit(); /* in case linked C routines want magical variables */
amperstab = stabent("&",allstabs);
str_set(stab_val(tmpstab),origfilename);
magicname("0", Nullch, 0);
}
- if (tmpstab = stabent("\020",allstabs))
+ if (tmpstab = stabent("\030",allstabs))
str_set(stab_val(tmpstab),origargv[0]);
if (argvstab = stabent("ARGV",allstabs)) {
argvstab->str_pok |= SP_MULTI;
}
}
+void
+savelines(array, str)
+ARRAY *array;
+STR *str;
+{
+ register char *s = str->str_ptr;
+ register char *send = str->str_ptr + str->str_cur;
+ register char *t;
+ register int line = 1;
+
+ while (s && s < send) {
+ STR *tmpstr = Str_new(85,0);
+
+ t = index(s, '\n');
+ if (t)
+ t++;
+ else
+ t = send;
+
+ str_nset(tmpstr, s, t - s);
+ astore(array, line++, tmpstr);
+ s = t;
+ }
+}
+
/* this routine is in perl.c by virtue of being sort of an alternate main() */
int
curcmd->c_filestab = fstab("(eval)");
curcmd->c_line = 1;
str_sset(linestr,str);
- str_cat(linestr,";"); /* be kind to them */
+ str_cat(linestr,";\n"); /* be kind to them */
+ if (perldb)
+ savelines(stab_xarray(curcmd->c_filestab), linestr);
}
else {
if (last_root && !in_eval) {
fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
exit(status);
#else
+#ifdef MSDOS
+ abort(); /* nothing else to do */
+#else /* ! MSDOS */
# ifndef SIGABRT
# define SIGABRT SIGILL
# endif
# define SIGILL 6 /* blech */
# endif
kill(getpid(),SIGABRT); /* for use with undump */
+#endif /* ! MSDOS */
#endif
}
-/* $RCSfile: perl.h,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:49:51 $
+/* $RCSfile: perl.h,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:28:33 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, 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.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: perl.h,v $
+ * Revision 4.0.1.2 91/06/07 11:28:33 lwall
+ * patch4: new copyright notice
+ * patch4: made some allowances for "semi-standard" C
+ * patch4: many, many itty-bitty portability fixes
+ *
* Revision 4.0.1.1 91/04/11 17:49:51 lwall
* patch1: hopefully straightened out some of the Xenix mess
*
#endif /* !MSDOS */
-#if defined(HASVOLATILE) || defined(__STDC__)
+#if defined(__STDC__) || defined(_AIX) || defined(__stdc__)
+# define STANDARD_C 1
+#endif
+
+#if defined(HASVOLATILE) || defined(STANDARD_C)
#define VOLATILE volatile
#else
#define VOLATILE
#include <ctype.h>
#include <setjmp.h>
#ifndef MSDOS
-#include <sys/param.h> /* if this needs types.h we're still wrong */
+#ifdef PARAM_NEEDS_TYPES
+#include <sys/types.h>
#endif
-#ifdef __STDC__
+#include <sys/param.h>
+#endif
+#ifdef STANDARD_C
/* Use all the "standard" definitions */
#include <stdlib.h>
#include <string.h>
-#endif /* __STDC__ */
+#endif /* STANDARD_C */
#if defined(HAS_MEMCMP) && defined(mips) && BYTEORDER == 0x1234
#undef HAS_MEMCMP
#ifdef HAS_MEMCPY
-# ifndef __STDC__
+# ifndef STANDARD_C
# ifndef memcpy
extern char * memcpy(), *memset();
extern int memcmp();
# endif /* ndef memcpy */
-# endif /* ndef __STDC__ */
+# endif /* ndef STANDARD_C */
-#define bcopy(s1,s2,l) memcpy(s2,s1,l)
-#define bzero(s,l) memset(s,0,l)
+# ifndef bcopy
+# define bcopy(s1,s2,l) memcpy(s2,s1,l)
+# endif
+# ifndef bzero
+# define bzero(s,l) memset(s,0,l)
+# endif
#endif /* HAS_MEMCPY */
#ifndef HAS_BCMP /* prefer bcmp slightly 'cuz it doesn't order */
-#define bcmp(s1,s2,l) memcmp(s1,s2,l)
+# ifndef bcmp
+# define bcmp(s1,s2,l) memcmp(s1,s2,l)
+# endif
#endif
#ifndef _TYPES_ /* If types.h defines this it's easy. */
# endif
#endif
+#ifdef FPUTS_BOTCH
+/* work around botch in SunOS 4.0.1 and 4.0.2 */
+# ifndef fputs
+# define fputs(str,fp) fprintf(fp,"%s",str)
+# endif
+#endif
+
/*
* The following gobbledygook brought to you on behalf of __STDC__.
* (I could just use #ifndef __STDC__, but this is more bulletproof
# define S_ISGID 02000
#endif
+#ifdef f_next
+#undef f_next
+#endif
+
typedef unsigned int STRLEN;
typedef struct arg ARG;
# define I286
#endif
-#ifndef __STDC__
+#ifndef STANDARD_C
#ifdef CHARSPRINTF
char *sprintf();
#else
EXT bool sawvec INIT(FALSE);
EXT bool localizing INIT(FALSE); /* are we processing a local() list? */
+#ifndef MAXSYSFD
+# define MAXSYSFD 2
+#endif
+EXT int maxsysfd INIT(MAXSYSFD); /* top fd to pass to subprocesses */
+
#ifdef CSH
char *cshname INIT(CSH);
int cshlen INIT(0);
/* Fix these up for __STDC__ */
EXT long basetime INIT(0);
char *mktemp();
-#ifndef __STDC__
+#ifndef STANDARD_C
/* All of these are in stdlib.h or time.h for ANSI C */
double atof();
long time();
struct tm *gmtime(), *localtime();
char *index(), *rindex();
char *strcpy(), *strcat();
-#endif /* ! __STDC__ */
+#endif /* ! STANDARD_C */
#ifdef EUNICE
#define UNLINK unlnk
.rn '' }`
-''' $RCSfile: perl.man,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:50:44 $
+''' $RCSfile: perl.man,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:41:23 $
'''
''' $Log: perl.man,v $
+''' Revision 4.0.1.2 91/06/07 11:41:23 lwall
+''' patch4: added global modifier for pattern matches
+''' patch4: default top-of-form format is now FILEHANDLE_TOP
+''' patch4: added $^P variable to control calling of perldb routines
+''' patch4: added $^F variable to specify maximum system fd, default 2
+''' patch4: changed old $^P to $^X
+'''
''' Revision 4.0.1.1 91/04/11 17:50:44 lwall
''' patch1: fixed some typos
'''
(getpwuid($<))[7] || die "You're homeless!\en";
.fi
-''' Beginning of part 2
-''' $RCSfile: perl.man,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:50:44 $
-'''
-''' $Log: perl.man,v $
-''' Revision 4.0.1.1 91/04/11 17:50:44 lwall
-''' patch1: fixed some typos
-'''
-''' 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.
.fi
.ne 23
-Here's an example of looking up non-numeric uids:
+Here's an example that looks up non-numeric uids in the passwd file:
.nf
print "User: ";
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
+.Ip "m/PATTERN/gio" 8 4
+.Ip "/PATTERN/gio" 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.
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.
+.Sp
+The \*(L"g\*(R" modifier specifies global pattern matching\*(--that is,
+matching as many times as possible within the string. How it behaves
+depends on the context. In an array context, it returns a list of
+all the substrings matched by all the parentheses in the regular expression.
+If there are no parentheses, it returns a list of all the matched strings,
+as if there were parentheses around the whole pattern. In a scalar context,
+it iterates through the string, returning TRUE each time it matches, and
+FALSE when it eventually runs out of matches. (In other words, it remembers
+where it left off last time and restarts the search at that point.) It
+presumes that you have not modified the string since the last match.
+Modifying the string between matches may result in undefined behavior.
+(You can actually get away with in-place modifications via substr()
+that do not change the length of the entire string. In general, however,
+you should be using s///g for such modifications.) Examples:
+.nf
+
+ # array context
+ ($one,$five,$fifteen) = (\`uptime\` =~ /(\ed+\e.\ed+)/g);
+
+ # scalar context
+ $/ = 1; $* = 1;
+ while ($paragraph = <>) {
+ while ($paragraph =~ /[a-z][\'")]*[.!?]+[\'")]*\es/g) {
+ $sentences++;
+ }
+ }
+ print "$sentences\en";
+
+.fi
.Ip "mkdir(FILENAME,MODE)" 8 3
Creates the directory specified by FILENAME, with permissions specified by
MODE (as modified by umask).
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
-''' $RCSfile: perl.man,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:50:44 $
-'''
-''' $Log: perl.man,v $
-''' Revision 4.0.1.1 91/04/11 17:50:44 lwall
-''' patch1: fixed some typos
-'''
-''' 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
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.
+(The <=> and cmp operators are extremely useful in such routines.)
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
.ne 4
sub byage {
- $age{$a} - $age{$b}; # presuming integers
+ $age{$a} <=> $age{$b}; # presuming integers
}
@sortedclass = sort byage @class;
.ne 9
- sub reverse { $a lt $b ? 1 : $a gt $b ? \-1 : 0; }
+ sub reverse { $b cmp $a; }
@harry = (\'dog\',\'cat\',\'x\',\'Cain\',\'Abel\');
@george = (\'gone\',\'chased\',\'yz\',\'Punished\',\'Axed\');
print sort @harry;
}
.fi
+(This only works on machines for which the device number is negative under NFS.)
.Ip "study(SCALAR)" 8 6
.Ip "study SCALAR" 8
.Ip "study"
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
-''' $RCSfile: perl.man,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:50:44 $
-'''
-''' $Log: perl.man,v $
-''' Revision 4.0.1.1 91/04/11 17:50:44 lwall
-''' patch1: fixed some typos
-'''
-''' 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:
.ne 10
# a report on the /etc/passwd file
-format top =
+format STDOUT_TOP =
\& Passwd File
Name Login Office Uid Gid Home
------------------------------------------------------------------
.ne 29
# a report from a bug report form
-format top =
+format STDOUT_TOP =
\& Bug Reports
@<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>>
$system, $%, $date
.Ip $~ 8
The name of the current report format for the currently selected output
channel.
+Default is name of the filehandle.
(Mnemonic: brother to $^.)
.Ip $^ 8
The name of the current top-of-page format for the currently selected output
channel.
+Default is name of the filehandle with \*(L"_TOP\*(R" appended.
(Mnemonic: points to top of page.)
.Ip $| 8
If set to nonzero, forces a flush after every write or print on the currently
(Mnemonic: value of
.B \-D
switch.)
+.Ip $^F 8 2
+The maximum system file descriptor, ordinarily 2. System file descriptors
+are passed to subprocesses, while higher file descriptors are not.
+During an open, system file descriptors are preserved even if the open
+fails. Ordinary file descriptors are closed before the open is attempted.
.Ip $^I 8 2
The current value of the inplace-edit extension.
Use undef to disable inplace editing.
.B \-i
switch.)
.Ip $^P 8 2
-The name that Perl itself was invoked as, from argv[0].
+The internal flag that the debugger clears so that it doesn't
+debug itself. You could conceivable disable debugging yourself
+by clearing it.
.Ip $^T 8 2
The time at which the script began running, in seconds since the epoch.
The values returned by the
(Mnemonic: related to the
.B \-w
switch.)
+.Ip $^X 8 2
+The name that Perl itself was executed as, from argv[0].
.Ip $ARGV 8 3
contains the name of the current file when reading from <>.
.Ip @ARGV 8 3
#!./perl
-# $Header: pat.t,v 4.0 91/03/20 01:54:01 lwall Locked $
+# $RCSfile: pat.t,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:01:26 $
-print "1..43\n";
+print "1..48\n";
$x = "abc\ndef\n";
print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n";
print /x {3,4}/ ? "not ok 42\n" : "ok 42\n";
print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n";
+
+$_ = "now is the time for all good men to come to.";
+@words = /(\w+)/g;
+print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
+ ? "ok 44\n"
+ : "not ok 44\n";
+
+@words = ();
+while (/\w+/g) {
+ push(@words, $&);
+}
+print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
+ ? "ok 45\n"
+ : "not ok 45\n";
+
+@words = ();
+while (/to/g) {
+ push(@words, $&);
+}
+print join(':',@words) eq "to:to"
+ ? "ok 46\n"
+ : "not ok 46 @words\n";
+
+@words = /to/g;
+print join(':',@words) eq "to:to"
+ ? "ok 47\n"
+ : "not ok 47 @words\n";
+
+$_ = "abcdefghi";
+
+$pat1 = 'def';
+$pat2 = '^def';
+$pat3 = '.def.';
+$pat4 = 'abc';
+$pat5 = '^abc';
+$pat6 = 'abc$';
+$pat7 = 'ghi';
+$pat8 = '\w*ghi';
+$pat9 = 'ghi$';
+
+$t1=$t2=$t3=$t4=$t5=$t6=$t7=$t8=$t9=0;
+
+for $iter (1..5) {
+ $t1++ if /$pat1/o;
+ $t2++ if /$pat2/o;
+ $t3++ if /$pat3/o;
+ $t4++ if /$pat4/o;
+ $t5++ if /$pat5/o;
+ $t6++ if /$pat6/o;
+ $t7++ if /$pat7/o;
+ $t8++ if /$pat8/o;
+ $t9++ if /$pat9/o;
+}
+
+$x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9";
+print $x eq '505550555' ? "ok 48\n" : "not ok 48 $x\n";
-/* $Header: hash.c,v 4.0 91/03/20 01:57:49 lwall Locked $
+/* $RCSfile: hash.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:15:55 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, 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.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: hash.c,v $
+ * Revision 4.0.1.1 91/06/07 12:15:55 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:57:49 lwall
* 4.0 baseline.
*
-/* $Header: hash.h,v 4.0 91/03/20 01:57:53 lwall Locked $
+/* $RCSfile: hash.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:16:04 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, 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.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: hash.h,v $
+ * Revision 4.0.1.1 91/06/07 12:16:04 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:57:53 lwall
* 4.0 baseline.
*
projects / platform / upstream / perl.git / commitdiff