v20i060: perl - The perl programming language, Patch08
Larry Wall
lwall at netlabs.com
Thu Jun 20 13:07:15 AEST 1991
Submitted-by: Larry Wall <lwall at netlabs.com>
Posting-number: Volume 20, Issue 60
Archive-name: perl/patch08
Patch-To: perl: Volume 18, Issue 19-54
System: perl version 4.0
Patch #: 8
Priority: High
Subject: patch #4, continued
Description:
See patch #4.
Fix: From rn, say "| patch -p -N -d DIR", where DIR is your perl source
directory. Outside of rn, say "cd DIR; patch -p -N <thisarticle".
If you don't have the patch program, apply the following by hand,
or get patch (version 2.0, latest patchlevel).
After patching:
*** DO NOTHING--INSTALL ALL PATCHES UP THROUGH #09 FIRST ***
If patch indicates that patchlevel is the wrong version, you may need
to apply one or more previous patches, or the patch may already
have been applied. See the patchlevel.h file to find out what has or
has not been applied. In any event, don't continue with the patch.
If you are missing previous patches they can be obtained from me:
Larry Wall
lwall at netlabs.com
If you send a mail message of the following form it will greatly speed
processing:
Subject: Command
@SH mailpatch PATH perl 4.0 LIST
^ note the c
where PATH is a return path FROM ME TO YOU either in Internet notation,
or in bang notation from some well-known host, and LIST is the number
of one or more patches you need, separated by spaces, commas, and/or
hyphens. Saying 35- says everything from 35 to the end.
Index: patchlevel.h
Prereq: 7
1c1
< #define PATCHLEVEL 7
---
> #define PATCHLEVEL 8
Index: lib/perldb.pl
Prereq: 4.0
*** lib/perldb.pl.old Fri Jun 7 12:25:19 1991
--- lib/perldb.pl Fri Jun 7 12:25:20 1991
***************
*** 1,6 ****
package DB;
! $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.
--- 1,6 ----
package DB;
! $header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:17:44 $';
#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
***************
*** 10,15 ****
--- 10,19 ----
# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
#
# $Log: perldb.pl,v $
+ # Revision 4.0.1.1 91/06/07 11:17:44 lwall
+ # patch4: added $^P variable to control calling of perldb routines
+ # patch4: debugger sometimes listed wrong number of lines for a statement
+ #
# Revision 4.0 91/03/20 01:25:50 lwall
# 4.0 baseline.
#
***************
*** 61,66 ****
--- 65,71 ----
($package, $filename, $line) = caller;
$usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
"package $package;"; # this won't let them modify, alas
+ local($^P) = 0; # don't debug our own evals
local(*dbline) = "_<$filename";
$max = $#dbline;
if (($stop,$action) = split(/\0/,$dbline{$line})) {
***************
*** 76,82 ****
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];
}
}
--- 81,87 ----
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];
}
}
Index: perly.fixer
*** perly.fixer.old Fri Jun 7 12:26:21 1991
--- perly.fixer Fri Jun 7 12:26:21 1991
***************
*** 2,7 ****
--- 2,10 ----
# Hacks to make it work with Interactive's SysVr3 Version 2.2
# doughera at lafvax.lafayette.edu (Andy Dougherty) 3/23/91
+ #
+ # Additional information to make the BSD section work with SunOS 4.0.2
+ # tdinger at East.Sun.COM (Tom Dinger) 4/15/1991
input=$1
output=$2
***************
*** 10,20 ****
plan="unknown"
# Test for BSD 4.3 version.
egrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];
short[ ]*yys\[ *YYMAXDEPTH *\] *;
yyps *= *&yys\[ *-1 *\];
yypv *= *&yyv\[ *-1 *\];
! if *\( *\+\+yyps *> *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
set `wc -l $tmp`
if test "$1" = "5"; then
--- 13,24 ----
plan="unknown"
# Test for BSD 4.3 version.
+ # Also tests for the SunOS 4.0.2 version
egrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];
short[ ]*yys\[ *YYMAXDEPTH *\] *;
yyps *= *&yys\[ *-1 *\];
yypv *= *&yyv\[ *-1 *\];
! if *\( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
set `wc -l $tmp`
if test "$1" = "5"; then
***************
*** 36,42 ****
fi
case "$plan" in
! #######################################################
"bsd43")
echo "Patching perly.c to allow dynamic yacc stack allocation"
echo "Assuming bsd4.3 yaccpar"
--- 40,49 ----
fi
case "$plan" in
! ##################################################################
! # The SunOS 4.0.2 version has the comparison fixed already.
! # Also added are out of memory checks (makes porting the generated
! # code easier) For most systems, it can't hurt. -- TD
"bsd43")
echo "Patching perly.c to allow dynamic yacc stack allocation"
echo "Assuming bsd4.3 yaccpar"
***************
*** 55,60 ****
--- 62,71 ----
\ if (!yyv) {\
\ yyv = (YYSTYPE*) malloc(yymaxdepth * sizeof(YYSTYPE));\
\ yys = (short*) malloc(yymaxdepth * sizeof(short));\
+ \ if ( !yyv || !yys ) {\
+ \ yyerror( "out of memory" );\
+ \ return(1);\
+ \ }\
\ maxyyps = &yys[yymaxdepth];\
\ }\
\ yyps = &yys[-1];\
***************
*** 61,67 ****
\ yypv = &yyv[-1];
! /if *( *\+\+yyps *> *&yys\[ *YYMAXDEPTH *\] *)/c\
\ if( ++yyps >= maxyyps ) {\
\ int tv = yypv - yyv;\
\ int ts = yyps - yys;\
--- 72,78 ----
\ yypv = &yyv[-1];
! /if *( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *)/c\
\ if( ++yyps >= maxyyps ) {\
\ int tv = yypv - yyv;\
\ int ts = yyps - yys;\
***************
*** 71,76 ****
--- 82,91 ----
\ yymaxdepth*sizeof(YYSTYPE));\
\ yys = (short*)realloc((char*)yys,\
\ yymaxdepth*sizeof(short));\
+ \ if ( !yyv || !yys ) {\
+ \ yyerror( "yacc stack overflow" );\
+ \ return(1);\
+ \ }\
\ yyps = yys + ts;\
\ yypv = yyv + tv;\
\ maxyyps = &yys[yymaxdepth];\
Index: perly.y
Prereq: 4.0
*** perly.y.old Fri Jun 7 12:26:24 1991
--- perly.y Fri Jun 7 12:26:25 1991
***************
*** 1,11 ****
! /* $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: perly.y,v $
* Revision 4.0 91/03/20 01:38:40 lwall
* 4.0 baseline.
*
--- 1,14 ----
! /* $RCSfile: perly.y,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:42:34 $
*
! * Copyright (c) 1991, Larry Wall
*
! * You may distribute under the terms of either the GNU General Public
! * License or the Artistic License, as specified in the README file.
*
* $Log: perly.y,v $
+ * Revision 4.0.1.1 91/06/07 11:42:34 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:38:40 lwall
* 4.0 baseline.
*
***************
*** 788,792 ****
"\"%s\" may clash with future reserved word",
$1 );
}
!
%% /* PROGRAM */
--- 791,795 ----
"\"%s\" may clash with future reserved word",
$1 );
}
! ;
%% /* PROGRAM */
Index: msdos/popen.c
Prereq: 4.0
*** msdos/popen.c.old Fri Jun 7 12:25:48 1991
--- msdos/popen.c Fri Jun 7 12:25:49 1991
***************
*** 1,11 ****
! /* $Header: popen.c,v 4.0 91/03/20 01:34:50 lwall Locked $
*
* (C) Copyright 1988, 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.
*
* $Log: popen.c,v $
* Revision 4.0 91/03/20 01:34:50 lwall
* 4.0 baseline.
*
--- 1,14 ----
! /* $RCSfile: popen.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:52 $
*
* (C) Copyright 1988, 1990 Diomidis Spinellis.
*
! * You may distribute under the terms of either the GNU General Public
! * License or the Artistic License, as specified in the README file.
*
* $Log: popen.c,v $
+ * Revision 4.0.1.1 91/06/07 11:22:52 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:34:50 lwall
* 4.0 baseline.
*
Index: regcomp.c
*** regcomp.c.old Fri Jun 7 12:26:29 1991
--- regcomp.c Fri Jun 7 12:26:30 1991
***************
*** 7,15 ****
* blame Henry for some of the lack of readability.
*/
! /* $RCSfile: regcomp.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:04:45 $
*
* $Log: regcomp.c,v $
* Revision 4.0.1.1 91/04/12 09:04:45 lwall
* patch1: random cleanup in cpp namespace
*
--- 7,20 ----
* blame Henry for some of the lack of readability.
*/
! /* $RCSfile: regcomp.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:48:24 $
*
* $Log: regcomp.c,v $
+ * Revision 4.0.1.2 91/06/07 11:48:24 lwall
+ * patch4: new copyright notice
+ * patch4: /(x+) \1/ incorrectly optimized to not match "xxx xx"
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ *
* Revision 4.0.1.1 91/04/12 09:04:45 lwall
* patch1: random cleanup in cpp namespace
*
***************
*** 41,50 ****
*
**** Alterations to Henry's code are...
****
! **** Copyright (c) 1989, Larry Wall
****
! **** You may distribute under the terms of the GNU General Public License
! **** as specified in the README file that comes with the perl 3.0 kit.
*
* Beware that some of this code is subtly aware of the way operator
* precedence is structured in regular expressions. Serious changes in
--- 46,56 ----
*
**** Alterations to Henry's code are...
****
! **** Copyright (c) 1991, Larry Wall
****
! **** You may distribute under the terms of either the GNU General Public
! **** License or the Artistic License, as specified in the README file.
!
*
* Beware that some of this code is subtly aware of the way operator
* precedence is structured in regular expressions. Serious changes in
***************
*** 95,100 ****
--- 101,107 ----
static long regsize; /* Code size. */
static int regfold;
static int regsawbracket; /* Did we do {d,d} trick? */
+ static int regsawback; /* Did we see \1, ...? */
/*
* Forward declarations for regcomp()'s friends.
***************
*** 146,151 ****
--- 153,159 ----
extern char *safemalloc();
extern char *savestr();
int sawplus = 0;
+ int sawopen = 0;
if (exp == NULL)
fatal("NULL regexp argument");
***************
*** 156,161 ****
--- 164,170 ----
regxend = xend;
regprecomp = nsavestr(exp,xend-exp);
regsawbracket = 0;
+ regsawback = 0;
regnpar = 1;
regsize = 0L;
regcode = ®dummy;
***************
*** 178,185 ****
/* Second pass: emit code. */
if (regsawbracket)
bcopy(regprecomp,exp,xend-exp);
r->precomp = regprecomp;
! r->subbase = NULL;
regparse = exp;
regnpar = 1;
regcode = r->program;
--- 187,195 ----
/* Second pass: emit code. */
if (regsawbracket)
bcopy(regprecomp,exp,xend-exp);
+ r->prelen = xend-exp;
r->precomp = regprecomp;
! r->subbeg = r->subbase = NULL;
regparse = exp;
regnpar = 1;
regcode = r->program;
***************
*** 198,209 ****
scan = NEXTOPER(scan);
first = scan;
! while (OP(first) == OPEN ||
(OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
(OP(first) == PLUS) ||
(OP(first) == CURLY && ARG1(first) > 0) ) {
if (OP(first) == PLUS)
! sawplus = 2;
else
first += regarglen[OP(first)];
first = NEXTOPER(first);
--- 208,219 ----
scan = NEXTOPER(scan);
first = scan;
! while ((OP(first) == OPEN && (sawopen = 1)) ||
(OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
(OP(first) == PLUS) ||
(OP(first) == CURLY && ARG1(first) > 0) ) {
if (OP(first) == PLUS)
! sawplus = 1;
else
first += regarglen[OP(first)];
first = NEXTOPER(first);
***************
*** 210,215 ****
--- 220,226 ----
}
/* Starting-point info. */
+ again:
if (OP(first) == EXACTLY) {
r->regstart =
str_make(OPERAND(first)+1,*OPERAND(first));
***************
*** 221,229 ****
else if (OP(first) == BOUND || OP(first) == NBOUND)
r->regstclass = first;
else if (OP(first) == BOL ||
! (OP(first) == STAR && OP(NEXTOPER(first)) == ANY) )
! r->reganch = 1; /* kinda turn .* into ^.* */
! r->reganch |= sawplus;
#ifdef DEBUGGING
if (debug & 512)
--- 232,244 ----
else if (OP(first) == BOUND || OP(first) == NBOUND)
r->regstclass = first;
else if (OP(first) == BOL ||
! (OP(first) == STAR && OP(NEXTOPER(first)) == ANY) ) {
! r->reganch = ROPT_ANCH; /* kinda turn .* into ^.* */
! first = NEXTOPER(first);
! goto again;
! }
! if (sawplus && (!sawopen || !regsawback))
! r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */
#ifdef DEBUGGING
if (debug & 512)
***************
*** 741,746 ****
--- 756,762 ----
if (num > 9 && num >= regnpar)
goto defchar;
else {
+ regsawback = 1;
ret = reganode(REF, num);
while (isascii(*regparse) && isdigit(*regparse))
regparse++;
***************
*** 1272,1280 ****
fprintf(stderr,"start `%s' ", r->regstart->str_ptr);
if (r->regstclass)
fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
! if (r->reganch & 1)
fprintf(stderr,"anchored ");
! if (r->reganch & 2)
fprintf(stderr,"plus ");
if (r->regmust != NULL)
fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
--- 1288,1296 ----
fprintf(stderr,"start `%s' ", r->regstart->str_ptr);
if (r->regstclass)
fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
! if (r->reganch & ROPT_ANCH)
fprintf(stderr,"anchored ");
! if (r->reganch & ROPT_SKIP)
fprintf(stderr,"plus ");
if (r->regmust != NULL)
fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
Index: regcomp.h
Prereq: 4.0
*** regcomp.h.old Fri Jun 7 12:26:33 1991
--- regcomp.h Fri Jun 7 12:26:34 1991
***************
*** 1,6 ****
! /* $Header: regcomp.h,v 4.0 91/03/20 01:39:09 lwall Locked $
*
* $Log: regcomp.h,v $
* Revision 4.0 91/03/20 01:39:09 lwall
* 4.0 baseline.
*
--- 1,9 ----
! /* $RCSfile: regcomp.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:49:40 $
*
* $Log: regcomp.h,v $
+ * Revision 4.0.1.1 91/06/07 11:49:40 lwall
+ * patch4: no change
+ *
* Revision 4.0 91/03/20 01:39:09 lwall
* 4.0 baseline.
*
Index: regexec.c
*** regexec.c.old Fri Jun 7 12:26:37 1991
--- regexec.c Fri Jun 7 12:26:38 1991
***************
*** 7,15 ****
* blame Henry for some of the lack of readability.
*/
! /* $RCSfile: regexec.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:07:39 $
*
* $Log: regexec.c,v $
* Revision 4.0.1.1 91/04/12 09:07:39 lwall
* patch1: regexec only allocated space for 9 subexpresssions
*
--- 7,19 ----
* blame Henry for some of the lack of readability.
*/
! /* $RCSfile: regexec.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:50:33 $
*
* $Log: regexec.c,v $
+ * Revision 4.0.1.2 91/06/07 11:50:33 lwall
+ * patch4: new copyright notice
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ *
* Revision 4.0.1.1 91/04/12 09:07:39 lwall
* patch1: regexec only allocated space for 9 subexpresssions
*
***************
*** 40,49 ****
*
**** Alterations to Henry's code are...
****
! **** Copyright (c) 1989, Larry Wall
****
! **** You may distribute under the terms of the GNU General Public License
! **** as specified in the README file that comes with the perl 3.0 kit.
*
* Beware that some of this code is subtly aware of the way operator
* precedence is structured in regular expressions. Serious changes in
--- 44,53 ----
*
**** Alterations to Henry's code are...
****
! **** Copyright (c) 1991, Larry Wall
****
! **** You may distribute under the terms of either the GNU General Public
! **** License or the Artistic License, as specified in the README file.
*
* Beware that some of this code is subtly aware of the way operator
* precedence is structured in regular expressions. Serious changes in
***************
*** 151,157 ****
/* If there is a "must appear" string, look for it. */
s = string;
if (prog->regmust != Nullstr &&
! (!(prog->reganch & 1) || (multiline && prog->regback >= 0)) ) {
if (stringarg == strbeg && screamer) {
if (screamfirst[prog->regmust->str_rare] >= 0)
s = screaminstr(screamer,prog->regmust);
--- 155,162 ----
/* If there is a "must appear" string, look for it. */
s = string;
if (prog->regmust != Nullstr &&
! (!(prog->reganch & ROPT_ANCH)
! || (multiline && prog->regback >= 0)) ) {
if (stringarg == strbeg && screamer) {
if (screamfirst[prog->regmust->str_rare] >= 0)
s = screaminstr(screamer,prog->regmust);
***************
*** 213,219 ****
/* Simplest case: anchored match need be tried only once. */
/* [unless multiline is set] */
! if (prog->reganch & 1) {
if (regtry(prog, string))
goto got_it;
else if (multiline) {
--- 218,224 ----
/* Simplest case: anchored match need be tried only once. */
/* [unless multiline is set] */
! if (prog->reganch & ROPT_ANCH) {
if (regtry(prog, string))
goto got_it;
else if (multiline) {
***************
*** 235,241 ****
/* Messy cases: unanchored match. */
if (prog->regstart) {
! if (prog->reganch & 2) { /* we have /x+whatever/ */
/* it must be a one character string */
i = prog->regstart->str_ptr[0];
while (s < strend) {
--- 240,246 ----
/* Messy cases: unanchored match. */
if (prog->regstart) {
! if (prog->reganch & ROPT_SKIP) { /* we have /x+whatever/ */
/* it must be a one character string */
i = prog->regstart->str_ptr[0];
while (s < strend) {
***************
*** 275,281 ****
goto phooey;
}
if (c = prog->regstclass) {
! int doevery = (prog->reganch & 2) == 0;
if (minlen)
dontbother = minlen - 1;
--- 280,286 ----
goto phooey;
}
if (c = prog->regstclass) {
! int doevery = (prog->reganch & ROPT_SKIP) == 0;
if (minlen)
dontbother = minlen - 1;
***************
*** 445,451 ****
s = nsavestr(strbeg,i); /* so $digit will work later */
if (prog->subbase)
Safefree(prog->subbase);
! prog->subbase = s;
prog->subend = s+i;
}
else
--- 450,456 ----
s = nsavestr(strbeg,i); /* so $digit will work later */
if (prog->subbase)
Safefree(prog->subbase);
! prog->subbeg = prog->subbase = s;
prog->subend = s+i;
}
else
Index: regexp.h
Prereq: 4.0
*** regexp.h.old Fri Jun 7 12:26:40 1991
--- regexp.h Fri Jun 7 12:26:41 1991
***************
*** 5,13 ****
* not the System V one.
*/
! /* $Header: regexp.h,v 4.0 91/03/20 01:39:23 lwall Locked $
*
* $Log: regexp.h,v $
* Revision 4.0 91/03/20 01:39:23 lwall
* 4.0 baseline.
*
--- 5,18 ----
* not the System V one.
*/
! /* $RCSfile: regexp.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:51:18 $
*
* $Log: regexp.h,v $
+ * Revision 4.0.1.1 91/06/07 11:51:18 lwall
+ * patch4: new copyright notice
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * patch4: $` was busted inside s///
+ *
* Revision 4.0 91/03/20 01:39:23 lwall
* 4.0 baseline.
*
***************
*** 20,27 ****
--- 25,34 ----
char *regstclass;
STR *regmust; /* Internal use only. */
int regback; /* Can regmust locate first try? */
+ int prelen; /* length of precomp */
char *precomp; /* pre-compilation regular expression */
char *subbase; /* saved string so \digit works forever */
+ char *subbeg; /* same, but not responsible for allocation */
char *subend; /* end of subbase */
char reganch; /* Internal use only. */
char do_folding; /* do case-insensitive match? */
***************
*** 29,34 ****
--- 36,44 ----
char nparens; /* number of parentheses */
char program[1]; /* Unwarranted chumminess with compiler. */
} regexp;
+
+ #define ROPT_ANCH 1
+ #define ROPT_SKIP 2
regexp *regcomp();
int regexec();
Index: x2p/s2p.SH
Prereq: 4.0
*** x2p/s2p.SH.old Fri Jun 7 12:28:10 1991
--- x2p/s2p.SH Fri Jun 7 12:28:11 1991
***************
*** 29,37 ****
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>s2p <<'!NO!SUBS!'
! # $Header: s2p.SH,v 4.0 91/03/20 01:57:59 lwall Locked $
#
# $Log: s2p.SH,v $
# Revision 4.0 91/03/20 01:57:59 lwall
# 4.0 baseline.
#
--- 29,40 ----
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>s2p <<'!NO!SUBS!'
! # $RCSfile: s2p.SH,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:18 $
#
# $Log: s2p.SH,v $
+ # Revision 4.0.1.1 91/06/07 12:19:18 lwall
+ # patch4: s2p now handles embedded newlines better and optimizes common idioms
+ #
# Revision 4.0 91/03/20 01:57:59 lwall
# 4.0 baseline.
#
***************
*** 66,98 ****
}
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.
--- 69,111 ----
}
if (!$assumen && !$assumep) {
! print BODY &q(<<'EOT');
! : while ($ARGV[0] =~ /^-/) {
! : $_ = shift;
! : last if /^--/;
! : if (/^-n/) {
! : $nflag++;
! : next;
! : }
! : die "I don't recognize this switch: $_\\n";
! : }
! :
EOT
}
! print BODY &q(<<'EOT');
! : #ifdef PRINTIT
! : #ifdef ASSUMEP
! : $printit++;
! : #else
! : $printit++ unless $nflag;
! : #endif
! : #endif
! : <><>
! : $\ = "\n"; # automatically add newline on print
! : <><>
! : #ifdef TOPLABEL
! : LINE:
! : while (chop($_ = <>)) {
! : #else
! : LINE:
! : while (<>) {
! : chop;
! : #endif
EOT
! LINE:
! while (<>) {
# Wipe out surrounding whitespace.
***************
*** 105,110 ****
--- 118,127 ----
$label = &make_label($_);
if ($. == 1) {
$toplabel = $label;
+ if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
+ $_ = <>;
+ redo LINE; # Never referenced, so delete it if not a comment.
+ }
}
$_ = "$label:";
if ($lastlinewaslabel++) {
***************
*** 127,132 ****
--- 144,150 ----
$addr2 = '';
if (s/^([0-9]+)//) {
$addr1 = "$1";
+ $addr1 = "\$. == $addr1" unless /^,/;
}
elsif (s/^\$//) {
$addr1 = 'eof()';
***************
*** 213,247 ****
$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
}
--- 231,269 ----
$indent -= 4;
}
if ($appendseen || $tseen || !$assumen) {
$printit++ if $dseen || (!$assumen && !$assumep);
! print BODY &q(<<'EOT');
! : #ifdef SAWNEXT
! : }
! : continue {
! : #endif
! : #ifdef PRINTIT
! : #ifdef DSEEN
! : #ifdef ASSUMEP
! : print if $printit++;
! : #else
! : if ($printit)
! : { print; }
! : else
! : { $printit++ unless $nflag; }
! : #endif
! : #else
! : print if $printit;
! : #endif
! : #else
! : print;
! : #endif
! : #ifdef TSEEN
! : $tflag = 0;
! : #endif
! : #ifdef APPENDSEEN
! : if ($atext) { chop $atext; print $atext; $atext = ''; }
! : #endif
! EOT
! print BODY &q(<<'EOT');
! : }
EOT
}
***************
*** 250,261 ****
unless ($debug) {
open(HEAD,">/tmp/sperl2$$.c")
|| &Die("Can't open temp file 2: $!\n");
! print HEAD "#define PRINTIT\n" if ($printit);
! print HEAD "#define APPENDSEEN\n" if ($appendseen);
! print HEAD "#define TSEEN\n" if ($tseen);
! print HEAD "#define DSEEN\n" if ($dseen);
! print HEAD "#define ASSUMEN\n" if ($assumen);
! print HEAD "#define ASSUMEP\n" if ($assumep);
if ($opens) {print HEAD "$opens\n";}
open(BODY,"/tmp/sperl$$")
|| &Die("Can't reopen temp file: $!\n");
--- 272,285 ----
unless ($debug) {
open(HEAD,">/tmp/sperl2$$.c")
|| &Die("Can't open temp file 2: $!\n");
! print HEAD "#define PRINTIT\n" if $printit;
! print HEAD "#define APPENDSEEN\n" if $appendseen;
! print HEAD "#define TSEEN\n" if $tseen;
! print HEAD "#define DSEEN\n" if $dseen;
! print HEAD "#define ASSUMEN\n" if $assumen;
! print HEAD "#define ASSUMEP\n" if $assumep;
! print HEAD "#define TOPLABEL\n" if $toplabel;
! print HEAD "#define SAWNEXT\n" if $sawnext;
if ($opens) {print HEAD "$opens\n";}
open(BODY,"/tmp/sperl$$")
|| &Die("Can't reopen temp file: $!\n");
***************
*** 264,274 ****
}
close HEAD;
! print <<"EOT";
! #!$bin/perl
! eval 'exec $bin/perl -S \$0 \$*'
! if \$running_under_some_shell;
!
EOT
open(BODY,"cc -E /tmp/sperl2$$.c |") ||
&Die("Can't reopen temp file: $!\n");
--- 288,298 ----
}
close HEAD;
! print &q(<<"EOT");
! : #!$bin/perl
! : eval 'exec $bin/perl -S \$0 \${1+"\$@"}'
! : if \$running_under_some_shell;
! :
EOT
open(BODY,"cc -E /tmp/sperl2$$.c |") ||
&Die("Can't reopen temp file: $!\n");
***************
*** 297,311 ****
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 {
--- 321,342 ----
sub make_filehandle {
local($_) = $_[0];
local($fname) = $_;
! if (!$seen{$fname}) {
! $_ = "FH_" . $_ if /^\d/;
! s/[^a-zA-Z0-9]/_/g;
! s/^_*//;
! $_ = "\U$_";
! if ($fhseen{$_}) {
! for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
! $_ .= $tmp;
! }
! $fhseen{$_} = 1;
! $opens .= &q(<<"EOT");
! : open($_, '>$fname') || die "Can't create $fname: \$!";
EOT
+ $seen{$fname} = $_;
}
! $seen{$fname};
}
sub make_label {
***************
*** 325,364 ****
{ # 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;
}
--- 356,397 ----
{ # case
if (/^d/) {
$dseen++;
! chop($_ = &q(<<'EOT'));
! : <<--#ifdef PRINTIT
! : $printit = 0;
! : <<--#endif
! : next LINE;
EOT
+ $sawnext++;
next;
}
if (/^n/) {
! chop($_ = &q(<<'EOT'));
! : <<--#ifdef PRINTIT
! : <<--#ifdef DSEEN
! : <<--#ifdef ASSUMEP
! : print if $printit++;
! : <<--#else
! : if ($printit)
! : { print; }
! : else
! : { $printit++ unless $nflag; }
! : <<--#endif
! : <<--#else
! : print if $printit;
! : <<--#endif
! : <<--#else
! : print;
! : <<--#endif
! : <<--#ifdef APPENDSEEN
! : if ($atext) {chop $atext; print $atext; $atext = '';}
! : <<--#endif
! : $_ = <>;
! : chop;
! : <<--#ifdef TSEEN
! : $tflag = 0;
! : <<--#endif
EOT
next;
}
***************
*** 365,391 ****
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]*//;
--- 398,424 ----
if (/^a/) {
$appendseen++;
! $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
$lastline = 0;
while (<>) {
s/^[ \t]*//;
s/^[\\]//;
unless (s|\\$||) { $lastline = 1;}
s/^([ \t]*\n)/<><>$1/;
$command .= $_;
$command .= '<<--';
last if $lastline;
}
! $_ = $command . "End_Of_Text";
last;
}
if (/^[ic]/) {
if (/^c/) { $change = 1; }
+ $addr1 = 1 if $addr1 eq '';
$addr1 = '$iter = (' . $addr1 . ')';
! $command = $space .
! " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
$lastline = 0;
while (<>) {
s/^[ \t]*//;
***************
*** 397,412 ****
$command .= '<<--';
last if $lastline;
}
! $_ = $command . "';}";
if ($change) {
$dseen++;
$change = "$_\n";
! chop($_ = <<"EOT");
! <<--#ifdef PRINTIT
! $space\$printit = '';
! <<--#endif
! ${space}next LINE;
EOT
}
last;
}
--- 430,446 ----
$command .= '<<--';
last if $lastline;
}
! $_ = $command . "End_Of_Text";
if ($change) {
$dseen++;
$change = "$_\n";
! chop($_ = &q(<<"EOT"));
! : <<--#ifdef PRINTIT
! : $space\$printit = 0;
! : <<--#endif
! : ${space}next LINE;
EOT
+ $sawnext++;
}
last;
}
***************
*** 463,468 ****
--- 497,507 ----
elsif ($c eq ']') {
$inbracket = 0;
}
+ elsif ($c eq "\t") {
+ substr($_, $i, 1) = '\\t';
+ $i++;
+ $len++;
+ }
elsif (!$repl && index("()+",$c) >= 0) {
substr($_, $i, 0) = '\\';
$i++;
***************
*** 474,479 ****
--- 513,519 ----
$pat = substr($_, 0, $repl + 1);
$repl = substr($_, $repl+1, $end-$repl-1);
$end = substr($_, $end + 1, 1000);
+ &simplify($pat);
$dol = '$';
$repl =~ s/\$/\\$/;
$repl =~ s'&'$&'g;
***************
*** 498,509 ****
&Die("Unrecognized substitution command".
"($end) at line $.\n");
}
! chop ($_ = <<"EOT");
! <<--#ifdef TSEEN
! $subst && \$tflag++$cmd;
! <<--#else
! $subst$cmd;
! <<--#endif
EOT
next;
}
--- 538,549 ----
&Die("Unrecognized substitution command".
"($end) at line $.\n");
}
! chop ($_ = &q(<<"EOT"));
! : <<--#ifdef TSEEN
! : $subst && \$tflag++$cmd;
! : <<--#else
! : $subst$cmd;
! : <<--#endif
EOT
next;
}
***************
*** 529,553 ****
}
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;
}
--- 569,597 ----
}
if (/^P/) {
! $_ = 'print $1 if /^(.*)/;';
next;
}
if (/^D/) {
! chop($_ = &q(<<'EOT'));
! : s/^.*\n?//;
! : redo LINE if $_;
! : next LINE;
EOT
+ $sawnext++;
next;
}
if (/^N/) {
! chop($_ = &q(<<'EOT'));
! : $_ .= "\n";
! : $len1 = length;
! : $_ .= <>;
! : chop if $len1 < length;
! : <<--#ifdef TSEEN
! : $tflag = 0;
! : <<--#endif
EOT
next;
}
***************
*** 558,564 ****
}
if (/^H/) {
! $_ = '$hold .= $_ ? $_ : "\n";';
next;
}
--- 602,608 ----
}
if (/^H/) {
! $_ = '$hold .= "\n"; $hold .= $_;';
next;
}
***************
*** 568,574 ****
}
if (/^G/) {
! $_ = '$_ .= $hold ? $hold : "\n";';
next;
}
--- 612,618 ----
}
if (/^G/) {
! $_ = '$_ .= "\n"; $_ .= $hold;';
next;
}
***************
*** 579,584 ****
--- 623,629 ----
if (/^b$/) {
$_ = 'next LINE;';
+ $sawnext++;
next;
}
***************
*** 595,600 ****
--- 640,646 ----
if (/^t$/) {
$_ = 'next LINE if $tflag;';
+ $sawnext++;
$tseen++;
next;
}
***************
*** 602,608 ****
if (/^t/) {
s/^t[ \t]*//;
$lab = &make_label($_);
! $_ = q/if ($tflag) {$tflag = ''; /;
if ($lab eq $toplabel) {
$_ .= 'redo LINE;}';
} else {
--- 648,654 ----
if (/^t/) {
s/^t[ \t]*//;
$lab = &make_label($_);
! $_ = q/if ($tflag) {$tflag = 0; /;
if ($lab eq $toplabel) {
$_ .= 'redo LINE;}';
} else {
***************
*** 612,628 ****
next;
}
if (/^=/) {
! $_ = 'print "$.\n";';
next;
}
if (/^q/) {
! chop($_ = <<'EOT');
! close(ARGV);
! @ARGV = ();
! next LINE;
EOT
next;
}
} continue {
--- 658,685 ----
next;
}
+ if (/^y/) {
+ s/abcdefghijklmnopqrstuvwxyz/a-z/g;
+ s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
+ s/abcdef/a-f/g;
+ s/ABCDEF/A-F/g;
+ s/0123456789/0-9/g;
+ s/01234567/0-7/g;
+ $_ .= ';';
+ }
+
if (/^=/) {
! $_ = 'print $.;';
next;
}
if (/^q/) {
! chop($_ = &q(<<'EOT'));
! : close(ARGV);
! : @ARGV = ();
! : next LINE;
EOT
+ $sawnext++;
next;
}
} continue {
***************
*** 670,676 ****
--- 727,763 ----
last DELIM;
}
}
+ $addr =~ s/\t/\\t/g;
+ &simplify($addr);
$addr;
+ }
+
+ sub q {
+ local($string) = @_;
+ local($*) = 1;
+ $string =~ s/^:\t?//g;
+ $string;
+ }
+
+ sub simplify {
+ $_[0] =~ s/_a-za-z0-9/\\w/ig;
+ $_[0] =~ s/a-z_a-z0-9/\\w/ig;
+ $_[0] =~ s/a-za-z_0-9/\\w/ig;
+ $_[0] =~ s/a-za-z0-9_/\\w/ig;
+ $_[0] =~ s/_0-9a-za-z/\\w/ig;
+ $_[0] =~ s/0-9_a-za-z/\\w/ig;
+ $_[0] =~ s/0-9a-z_a-z/\\w/ig;
+ $_[0] =~ s/0-9a-za-z_/\\w/ig;
+ $_[0] =~ s/\[\\w\]/\\w/g;
+ $_[0] =~ s/\[^\\w\]/\\W/g;
+ $_[0] =~ s/\[0-9\]/\\d/g;
+ $_[0] =~ s/\[^0-9\]/\\D/g;
+ $_[0] =~ s/\\d\\d\*/\\d+/g;
+ $_[0] =~ s/\\D\\D\*/\\D+/g;
+ $_[0] =~ s/\\w\\w\*/\\w+/g;
+ $_[0] =~ s/\\t\\t\*/\\t+/g;
+ $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
+ $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
}
!NO!SUBS!
Index: x2p/s2p.man
Prereq: 4.0
*** x2p/s2p.man.old Fri Jun 7 12:28:14 1991
--- x2p/s2p.man Fri Jun 7 12:28:14 1991
***************
*** 1,7 ****
.rn '' }`
! ''' $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.
'''
--- 1,10 ----
.rn '' }`
! ''' $RCSfile: s2p.man,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:57 $
'''
''' $Log: s2p.man,v $
+ ''' Revision 4.0.1.1 91/06/07 12:19:57 lwall
+ ''' patch4: s2p now handles embedded newlines better and optimizes common idioms
+ '''
''' Revision 4.0 91/03/20 01:58:07 lwall
''' 4.0 baseline.
'''
***************
*** 86,91 ****
--- 89,96 ----
sed script.
If you're only interested in speed you'll just have to try it both ways.
Of course, if you want to do something sed doesn't do, you have no choice.
+ It's often possible to speed up the perl script by various methods, such
+ as deleting all references to $\e and chop.
.SH ENVIRONMENT
S2p uses no environment variables.
.SH AUTHOR
Index: hints/sco_2_3_0.sh
*** hints/sco_2_3_0.sh.old Fri Jun 7 12:24:35 1991
--- hints/sco_2_3_0.sh Fri Jun 7 12:24:36 1991
***************
*** 1,2 ****
! yacc='/usr/bin/yacc -m25000'
i_dirent=undef
--- 1,2 ----
! yacc='/usr/bin/yacc -Sm25000'
i_dirent=undef
Index: hints/sco_2_3_1.sh
*** hints/sco_2_3_1.sh.old Fri Jun 7 12:24:38 1991
--- hints/sco_2_3_1.sh Fri Jun 7 12:24:38 1991
***************
*** 1,2 ****
! yacc='/usr/bin/yacc -m25000'
i_dirent=undef
--- 1,2 ----
! yacc='/usr/bin/yacc -Sm25000'
i_dirent=undef
Index: hints/sco_2_3_2.sh
*** hints/sco_2_3_2.sh.old Fri Jun 7 12:24:40 1991
--- hints/sco_2_3_2.sh Fri Jun 7 12:24:41 1991
***************
*** 1,2 ****
! yacc='/usr/bin/yacc -m25000'
libswanted=`echo $libswanted | sed 's/ x / /'`
--- 1,2 ----
! yacc='/usr/bin/yacc -Sm25000'
libswanted=`echo $libswanted | sed 's/ x / /'`
Index: hints/sco_2_3_3.sh
*** hints/sco_2_3_3.sh.old Fri Jun 7 12:24:43 1991
--- hints/sco_2_3_3.sh Fri Jun 7 12:24:43 1991
***************
*** 1,2 ****
! yacc='/usr/bin/yacc -m25000'
libswanted=`echo $libswanted | sed 's/ x / /'`
--- 1,4 ----
! yacc='/usr/bin/yacc -Sm25000'
libswanted=`echo $libswanted | sed 's/ x / /'`
+ echo "NOTE: you may have problems due to a spurious semicolon on the strerror()"
+ echo "macro definition in /usr/include/string.h. If so, delete the semicolon."
Index: hints/sco_3.sh
*** hints/sco_3.sh.old Fri Jun 7 12:24:46 1991
--- hints/sco_3.sh Fri Jun 7 12:24:46 1991
***************
*** 1,3 ****
--- 1,4 ----
yacc='/usr/bin/yacc -Sm11000'
libswanted=`echo $libswanted | sed 's/ x / /'`
i_varargs=undef
+ ccflags="$ccflags -U M_XENIX"
Index: hints/sgi.sh
*** hints/sgi.sh.old Fri Jun 7 12:24:48 1991
--- hints/sgi.sh Fri Jun 7 12:24:49 1991
***************
*** 1,7 ****
! optimize='-O0'
usemymalloc='y'
mallocsrc='malloc.c'
mallocobj='malloc.o'
- ccflags="$ccflags -Uf_next"
d_voidsig=define
d_vfork=undef
--- 1,6 ----
! optimize='-O1'
usemymalloc='y'
mallocsrc='malloc.c'
mallocobj='malloc.o'
d_voidsig=define
d_vfork=undef
Index: lib/shellwords.pl
*** lib/shellwords.pl.old Fri Jun 7 12:25:22 1991
--- lib/shellwords.pl Fri Jun 7 12:25:23 1991
***************
*** 0 ****
--- 1,42 ----
+ #; shellwords.pl
+ #;
+ #; Usage:
+ #; require 'shellwords.pl';
+ #; @words = &shellwords($line);
+ #; or
+ #; @words = &shellwords(@lines);
+ #; or
+ #; @words = &shellwords; # defaults to $_ (and clobbers it)
+
+ sub shellwords {
+ package shellwords;
+ local($_) = join('', @_) if @_;
+ local(@words,$snippet,$field);
+
+ s/^\s+//;
+ while ($_ ne '') {
+ $field = '';
+ for (;;) {
+ if (s/^"(([^"\\]+|\\[\\"])*)"//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (s/^'(([^'\\]+|\\[\\'])*)'//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (s/^\\(.)//) {
+ $snippet = $1;
+ }
+ elsif (s/^([^\s\\'"]+)//) {
+ $snippet = $1;
+ }
+ else {
+ s/^\s+//;
+ last;
+ }
+ $field .= $snippet;
+ }
+ push(@words, $field);
+ }
+ @words;
+ }
+ 1;
Index: spat.h
Prereq: 4.0
*** spat.h.old Fri Jun 7 12:26:43 1991
--- spat.h Fri Jun 7 12:26:44 1991
***************
*** 1,11 ****
! /* $Header: spat.h,v 4.0 91/03/20 01:39:36 lwall Locked $
*
! * Copyright (c) 1989, Larry Wall
*
! * You may distribute under the terms of the GNU General Public License
! * as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: spat.h,v $
* Revision 4.0 91/03/20 01:39:36 lwall
* 4.0 baseline.
*
--- 1,15 ----
! /* $RCSfile: spat.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:51:59 $
*
! * Copyright (c) 1991, Larry Wall
*
! * You may distribute under the terms of either the GNU General Public
! * License or the Artistic License, as specified in the README file.
*
* $Log: spat.h,v $
+ * Revision 4.0.1.1 91/06/07 11:51:59 lwall
+ * patch4: new copyright notice
+ * patch4: added global modifier for pattern matches
+ *
* Revision 4.0 91/03/20 01:39:36 lwall
* 4.0 baseline.
*
***************
*** 17,23 ****
ARG *spat_repl; /* replacement string for subst */
ARG *spat_runtime; /* compile pattern at runtime */
STR *spat_short; /* for a fast bypass of execute() */
! bool spat_flags;
char spat_slen;
};
--- 21,27 ----
ARG *spat_repl; /* replacement string for subst */
ARG *spat_runtime; /* compile pattern at runtime */
STR *spat_short; /* for a fast bypass of execute() */
! short spat_flags;
char spat_slen;
};
***************
*** 29,34 ****
--- 33,39 ----
#define SPAT_FOLD 32 /* case insensitivity */
#define SPAT_CONST 64 /* subst replacement is constant */
#define SPAT_KEEP 128 /* keep 1st runtime pattern forever */
+ #define SPAT_GLOBAL 256 /* pattern had a g modifier */
EXT SPAT *curspat; /* what to do \ interps from */
EXT SPAT *lastspat; /* what to use in place of null pattern */
Index: stab.c
*** stab.c.old Fri Jun 7 12:26:47 1991
--- stab.c Fri Jun 7 12:26:47 1991
***************
*** 1,11 ****
! /* $RCSfile: stab.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:10:24 $
*
! * 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: stab.c,v $
* Revision 4.0.1.1 91/04/12 09:10:24 lwall
* patch1: Configure now differentiates getgroups() type from getgid() type
* patch1: you may now use "die" and "caller" in a signal handler
--- 1,20 ----
! /* $RCSfile: stab.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:55:53 $
*
! * Copyright (c) 1991, Larry Wall
*
! * You may distribute under the terms of either the GNU General Public
! * License or the Artistic License, as specified in the README file.
*
* $Log: stab.c,v $
+ * Revision 4.0.1.2 91/06/07 11:55:53 lwall
+ * patch4: new copyright notice
+ * patch4: added $^P variable to control calling of perldb routines
+ * patch4: added $^F variable to specify maximum system fd, default 2
+ * patch4: $` was busted inside s///
+ * patch4: default top-of-form format is now FILEHANDLE_TOP
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ * patch4: $^D |= 1024 now does syntax tree dump at run-time
+ *
* Revision 4.0.1.1 91/04/12 09:10:24 lwall
* patch1: Configure now differentiates getgroups() type from getgid() type
* patch1: you may now use "die" and "caller" in a signal handler
***************
*** 54,59 ****
--- 63,71 ----
str_numset(stab_val(stab),(double)(debug & 32767));
#endif
break;
+ case '\006': /* ^F */
+ str_numset(stab_val(stab),(double)maxsysfd);
+ break;
case '\t': /* ^I */
if (inplace)
str_set(stab_val(stab), inplace);
***************
*** 60,65 ****
--- 72,80 ----
else
str_sset(stab_val(stab),&str_undef);
break;
+ case '\020': /* ^P */
+ str_numset(stab_val(stab),(double)perldb);
+ break;
case '\024': /* ^T */
str_numset(stab_val(stab),(double)basetime);
break;
***************
*** 93,99 ****
case '`':
if (curspat) {
if (curspat->spat_regexp &&
! (s = curspat->spat_regexp->subbase) ) {
i = curspat->spat_regexp->startp[0] - s;
if (i >= 0)
str_nset(stab_val(stab),s,i);
--- 108,114 ----
case '`':
if (curspat) {
if (curspat->spat_regexp &&
! (s = curspat->spat_regexp->subbeg) ) {
i = curspat->spat_regexp->startp[0] - s;
if (i >= 0)
str_nset(stab_val(stab),s,i);
***************
*** 126,135 ****
break;
case '^':
s = stab_io(curoutstab)->top_name;
! str_set(stab_val(stab),s);
break;
case '~':
s = stab_io(curoutstab)->fmt_name;
str_set(stab_val(stab),s);
break;
#ifndef lint
--- 141,157 ----
break;
case '^':
s = stab_io(curoutstab)->top_name;
! if (s)
! str_set(stab_val(stab),s);
! else {
! str_set(stab_val(stab),stab_name(curoutstab));
! str_cat(stab_val(stab),"_TOP");
! }
break;
case '~':
s = stab_io(curoutstab)->fmt_name;
+ if (!s)
+ s = stab_name(curoutstab);
str_set(stab_val(stab),s);
break;
#ifndef lint
***************
*** 215,220 ****
--- 237,312 ----
return stab_val(stab);
}
+ STRLEN
+ stab_len(str)
+ STR *str;
+ {
+ STAB *stab = str->str_u.str_stab;
+ int paren;
+ int i;
+ char *s;
+
+ if (str->str_rare)
+ return stab_val(stab)->str_cur;
+
+ switch (*stab->str_magic->str_ptr) {
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': case '&':
+ if (curspat) {
+ paren = atoi(stab_name(stab));
+ getparen:
+ if (curspat->spat_regexp &&
+ paren <= curspat->spat_regexp->nparens &&
+ (s = curspat->spat_regexp->startp[paren]) ) {
+ i = curspat->spat_regexp->endp[paren] - s;
+ if (i >= 0)
+ return i;
+ else
+ return 0;
+ }
+ else
+ return 0;
+ }
+ break;
+ case '+':
+ if (curspat) {
+ paren = curspat->spat_regexp->lastparen;
+ goto getparen;
+ }
+ break;
+ case '`':
+ if (curspat) {
+ if (curspat->spat_regexp &&
+ (s = curspat->spat_regexp->subbeg) ) {
+ i = curspat->spat_regexp->startp[0] - s;
+ if (i >= 0)
+ return i;
+ else
+ return 0;
+ }
+ else
+ return 0;
+ }
+ break;
+ case '\'':
+ if (curspat) {
+ if (curspat->spat_regexp &&
+ (s = curspat->spat_regexp->endp[0]) ) {
+ return (STRLEN) (curspat->spat_regexp->subend - s);
+ }
+ else
+ return 0;
+ }
+ break;
+ case ',':
+ return (STRLEN)ofslen;
+ case '\\':
+ return (STRLEN)orslen;
+ default:
+ return stab_str(str)->str_cur;
+ }
+ }
+
stabset(mstr,str)
register STR *mstr;
STR *str;
***************
*** 334,341 ****
--- 426,438 ----
case '\004': /* ^D */
#ifdef DEBUGGING
debug = (int)(str_gnum(str)) | 32768;
+ if (debug & 1024)
+ dump_all();
#endif
break;
+ case '\006': /* ^F */
+ maxsysfd = (int)str_gnum(str);
+ break;
case '\t': /* ^I */
if (inplace)
Safefree(inplace);
***************
*** 344,349 ****
--- 441,449 ----
else
inplace = Nullch;
break;
+ case '\020': /* ^P */
+ perldb = (int)str_gnum(str);
+ break;
case '\024': /* ^T */
basetime = (long)str_gnum(str);
break;
***************
*** 430,441 ****
break;
case '<':
uid = (int)str_gnum(str);
! #ifdef HAS_SETREUID
if (delaymagic) {
delaymagic |= DM_REUID;
break; /* don't do magic till later */
}
! #endif /* HAS_SETREUID */
#ifdef HAS_SETRUID
if (setruid((UIDTYPE)uid) < 0)
uid = (int)getuid();
--- 530,541 ----
break;
case '<':
uid = (int)str_gnum(str);
! #if defined(HAS_SETREUID) || !defined(HAS_SETRUID)
if (delaymagic) {
delaymagic |= DM_REUID;
break; /* don't do magic till later */
}
! #endif /* HAS_SETREUID or not HASSETRUID */
#ifdef HAS_SETRUID
if (setruid((UIDTYPE)uid) < 0)
uid = (int)getuid();
***************
*** 453,464 ****
break;
case '>':
euid = (int)str_gnum(str);
! #ifdef HAS_SETREUID
if (delaymagic) {
delaymagic |= DM_REUID;
break; /* don't do magic till later */
}
! #endif /* HAS_SETREUID */
#ifdef HAS_SETEUID
if (seteuid((UIDTYPE)euid) < 0)
euid = (int)geteuid();
--- 553,564 ----
break;
case '>':
euid = (int)str_gnum(str);
! #if defined(HAS_SETREUID) || !defined(HAS_SETEUID)
if (delaymagic) {
delaymagic |= DM_REUID;
break; /* don't do magic till later */
}
! #endif /* HAS_SETREUID or not HAS_SETEUID */
#ifdef HAS_SETEUID
if (seteuid((UIDTYPE)euid) < 0)
euid = (int)geteuid();
***************
*** 476,487 ****
break;
case '(':
gid = (int)str_gnum(str);
! #ifdef HAS_SETREGID
if (delaymagic) {
delaymagic |= DM_REGID;
break; /* don't do magic till later */
}
! #endif /* HAS_SETREGID */
#ifdef HAS_SETRGID
(void)setrgid((GIDTYPE)gid);
#else
--- 576,587 ----
break;
case '(':
gid = (int)str_gnum(str);
! #if defined(HAS_SETREGID) || !defined(HAS_SETRGID)
if (delaymagic) {
delaymagic |= DM_REGID;
break; /* don't do magic till later */
}
! #endif /* HAS_SETREGID or not HAS_SETRGID */
#ifdef HAS_SETRGID
(void)setrgid((GIDTYPE)gid);
#else
***************
*** 494,505 ****
break;
case ')':
egid = (int)str_gnum(str);
! #ifdef HAS_SETREGID
if (delaymagic) {
delaymagic |= DM_REGID;
break; /* don't do magic till later */
}
! #endif /* HAS_SETREGID */
#ifdef HAS_SETEGID
(void)setegid((GIDTYPE)egid);
#else
--- 594,605 ----
break;
case ')':
egid = (int)str_gnum(str);
! #if defined(HAS_SETREGID) || !defined(HAS_SETEGID)
if (delaymagic) {
delaymagic |= DM_REGID;
break; /* don't do magic till later */
}
! #endif /* HAS_SETREGID or not HAS_SETEGID */
#ifdef HAS_SETEGID
(void)setegid((GIDTYPE)egid);
#else
*** End of Patch 8 ***
exit 0 # Just in case...
--
Kent Landfield INTERNET: kent at sparky.IMD.Sterling.COM
Sterling Software, IMD UUCP: uunet!sparky!kent
Phone: (402) 291-8300 FAX: (402) 291-4362
Please send comp.sources.misc-related mail to kent at uunet.uu.net.
More information about the Comp.sources.misc
mailing list