See patch #4.
-yacc='/usr/bin/yacc -m25000'
+yacc='/usr/bin/yacc -Sm25000'
i_dirent=undef
-yacc='/usr/bin/yacc -m25000'
+yacc='/usr/bin/yacc -Sm25000'
i_dirent=undef
-yacc='/usr/bin/yacc -m25000'
+yacc='/usr/bin/yacc -Sm25000'
libswanted=`echo $libswanted | sed 's/ x / /'`
-yacc='/usr/bin/yacc -m25000'
+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."
yacc='/usr/bin/yacc -Sm11000'
libswanted=`echo $libswanted | sed 's/ x / /'`
i_varargs=undef
+ccflags="$ccflags -U M_XENIX"
-optimize='-O0'
+optimize='-O1'
usemymalloc='y'
mallocsrc='malloc.c'
mallocobj='malloc.o'
-ccflags="$ccflags -Uf_next"
d_voidsig=define
d_vfork=undef
package DB;
-$header = '$Header: perldb.pl,v 4.0 91/03/20 01:25:50 lwall Locked $';
+$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.
# 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.
#
($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})) {
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)/;
+ last if $dbline[$i] =~ /^\s*(;|}|#|\n)/;
print OUT "$sub($filename:$i):\t",$dbline[$i];
}
}
--- /dev/null
+#; 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;
-/* $Header: popen.c,v 4.0 91/03/20 01:34:50 lwall Locked $
+/* $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 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: 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.
*
-#define PATCHLEVEL 7
+#define PATCHLEVEL 8
# Hacks to make it work with Interactive's SysVr3 Version 2.2
# doughera@lafvax.lafayette.edu (Andy Dougherty) 3/23/91
+#
+# Additional information to make the BSD section work with SunOS 4.0.2
+# tdinger@East.Sun.COM (Tom Dinger) 4/15/1991
input=$1
output=$2
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
+if *\( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
set `wc -l $tmp`
if test "$1" = "5"; then
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"
\ 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];\
\ yypv = &yyv[-1];
-/if *( *\+\+yyps *> *&yys\[ *YYMAXDEPTH *\] *)/c\
+/if *( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *)/c\
\ if( ++yyps >= maxyyps ) {\
\ int tv = yypv - yyv;\
\ int ts = yyps - yys;\
\ 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];\
-/* $Header: perly.y,v 4.0 91/03/20 01:38:40 lwall Locked $
+/* $RCSfile: perly.y,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:42:34 $
*
- * 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: 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.
*
"\"%s\" may clash with future reserved word",
$1 );
}
-
+ ;
%% /* PROGRAM */
* 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 $
+/* $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
*
*
**** Alterations to Henry's code are...
****
- **** 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.
+
*
* Beware that some of this code is subtly aware of the way operator
* precedence is structured in regular expressions. Serious changes in
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.
extern char *safemalloc();
extern char *savestr();
int sawplus = 0;
+ int sawopen = 0;
if (exp == NULL)
fatal("NULL regexp argument");
regxend = xend;
regprecomp = nsavestr(exp,xend-exp);
regsawbracket = 0;
+ regsawback = 0;
regnpar = 1;
regsize = 0L;
regcode = ®dummy;
/* Second pass: emit code. */
if (regsawbracket)
bcopy(regprecomp,exp,xend-exp);
+ r->prelen = xend-exp;
r->precomp = regprecomp;
- r->subbase = NULL;
+ r->subbeg = r->subbase = NULL;
regparse = exp;
regnpar = 1;
regcode = r->program;
scan = NEXTOPER(scan);
first = scan;
- while (OP(first) == OPEN ||
+ 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 = 2;
+ sawplus = 1;
else
first += regarglen[OP(first)];
first = NEXTOPER(first);
}
/* Starting-point info. */
+ again:
if (OP(first) == EXACTLY) {
r->regstart =
str_make(OPERAND(first)+1,*OPERAND(first));
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;
+ (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)
if (num > 9 && num >= regnpar)
goto defchar;
else {
+ regsawback = 1;
ret = reganode(REF, num);
while (isascii(*regparse) && isdigit(*regparse))
regparse++;
fprintf(stderr,"start `%s' ", r->regstart->str_ptr);
if (r->regstclass)
fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
- if (r->reganch & 1)
+ if (r->reganch & ROPT_ANCH)
fprintf(stderr,"anchored ");
- if (r->reganch & 2)
+ if (r->reganch & ROPT_SKIP)
fprintf(stderr,"plus ");
if (r->regmust != NULL)
fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
-/* $Header: regcomp.h,v 4.0 91/03/20 01:39:09 lwall Locked $
+/* $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.
*
* 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 $
+/* $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
*
*
**** Alterations to Henry's code are...
****
- **** 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.
*
* Beware that some of this code is subtly aware of the way operator
* precedence is structured in regular expressions. Serious changes in
/* If there is a "must appear" string, look for it. */
s = string;
if (prog->regmust != Nullstr &&
- (!(prog->reganch & 1) || (multiline && prog->regback >= 0)) ) {
+ (!(prog->reganch & ROPT_ANCH)
+ || (multiline && prog->regback >= 0)) ) {
if (stringarg == strbeg && screamer) {
if (screamfirst[prog->regmust->str_rare] >= 0)
s = screaminstr(screamer,prog->regmust);
/* Simplest case: anchored match need be tried only once. */
/* [unless multiline is set] */
- if (prog->reganch & 1) {
+ if (prog->reganch & ROPT_ANCH) {
if (regtry(prog, string))
goto got_it;
else if (multiline) {
/* Messy cases: unanchored match. */
if (prog->regstart) {
- if (prog->reganch & 2) { /* we have /x+whatever/ */
+ 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) {
goto phooey;
}
if (c = prog->regstclass) {
- int doevery = (prog->reganch & 2) == 0;
+ int doevery = (prog->reganch & ROPT_SKIP) == 0;
if (minlen)
dontbother = minlen - 1;
s = nsavestr(strbeg,i); /* so $digit will work later */
if (prog->subbase)
Safefree(prog->subbase);
- prog->subbase = s;
+ prog->subbeg = prog->subbase = s;
prog->subend = s+i;
}
else
* not the System V one.
*/
-/* $Header: regexp.h,v 4.0 91/03/20 01:39:23 lwall Locked $
+/* $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.
*
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? */
char program[1]; /* Unwarranted chumminess with compiler. */
} regexp;
+#define ROPT_ANCH 1
+#define ROPT_SKIP 2
+
regexp *regcomp();
int regexec();
-/* $Header: spat.h,v 4.0 91/03/20 01:39:36 lwall Locked $
+/* $RCSfile: spat.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:51:59 $
*
- * 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: 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.
*
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;
+ short spat_flags;
char spat_slen;
};
#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 */
-/* $RCSfile: stab.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:10:24 $
+/* $RCSfile: stab.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:55:53 $
*
- * 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: 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
str_numset(stab_val(stab),(double)(debug & 32767));
#endif
break;
+ case '\006': /* ^F */
+ str_numset(stab_val(stab),(double)maxsysfd);
+ break;
case '\t': /* ^I */
if (inplace)
str_set(stab_val(stab), inplace);
else
str_sset(stab_val(stab),&str_undef);
break;
+ case '\020': /* ^P */
+ str_numset(stab_val(stab),(double)perldb);
+ break;
case '\024': /* ^T */
str_numset(stab_val(stab),(double)basetime);
break;
case '`':
if (curspat) {
if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->subbase) ) {
+ (s = curspat->spat_regexp->subbeg) ) {
i = curspat->spat_regexp->startp[0] - s;
if (i >= 0)
str_nset(stab_val(stab),s,i);
break;
case '^':
s = stab_io(curoutstab)->top_name;
- str_set(stab_val(stab),s);
+ 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
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;
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);
else
inplace = Nullch;
break;
+ case '\020': /* ^P */
+ perldb = (int)str_gnum(str);
+ break;
case '\024': /* ^T */
basetime = (long)str_gnum(str);
break;
break;
case '<':
uid = (int)str_gnum(str);
-#ifdef HAS_SETREUID
+#if defined(HAS_SETREUID) || !defined(HAS_SETRUID)
if (delaymagic) {
delaymagic |= DM_REUID;
break; /* don't do magic till later */
}
-#endif /* HAS_SETREUID */
+#endif /* HAS_SETREUID or not HASSETRUID */
#ifdef HAS_SETRUID
if (setruid((UIDTYPE)uid) < 0)
uid = (int)getuid();
break;
case '>':
euid = (int)str_gnum(str);
-#ifdef HAS_SETREUID
+#if defined(HAS_SETREUID) || !defined(HAS_SETEUID)
if (delaymagic) {
delaymagic |= DM_REUID;
break; /* don't do magic till later */
}
-#endif /* HAS_SETREUID */
+#endif /* HAS_SETREUID or not HAS_SETEUID */
#ifdef HAS_SETEUID
if (seteuid((UIDTYPE)euid) < 0)
euid = (int)geteuid();
break;
case '(':
gid = (int)str_gnum(str);
-#ifdef HAS_SETREGID
+#if defined(HAS_SETREGID) || !defined(HAS_SETRGID)
if (delaymagic) {
delaymagic |= DM_REGID;
break; /* don't do magic till later */
}
-#endif /* HAS_SETREGID */
+#endif /* HAS_SETREGID or not HAS_SETRGID */
#ifdef HAS_SETRGID
(void)setrgid((GIDTYPE)gid);
#else
break;
case ')':
egid = (int)str_gnum(str);
-#ifdef HAS_SETREGID
+#if defined(HAS_SETREGID) || !defined(HAS_SETEGID)
if (delaymagic) {
delaymagic |= DM_REGID;
break; /* don't do magic till later */
}
-#endif /* HAS_SETREGID */
+#endif /* HAS_SETREGID or not HAS_SETEGID */
#ifdef HAS_SETEGID
(void)setegid((GIDTYPE)egid);
#else
: 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 $
+# $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.
#
}
if (!$assumen && !$assumep) {
- print BODY <<'EOT';
-while ($ARGV[0] =~ /^-/) {
- $_ = shift;
- last if /^--/;
- if (/^-n/) {
- $nflag++;
- next;
- }
- die "I don't recognize this switch: $_\\n";
-}
-
+ 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 <<'EOT';
-
-#ifdef PRINTIT
-#ifdef ASSUMEP
-$printit++;
-#else
-$printit++ unless $nflag;
-#endif
-#endif
-LINE: while (<>) {
+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 (<>) {
+LINE:
+while (<>) {
# Wipe out surrounding whitespace.
$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++) {
$addr2 = '';
if (s/^([0-9]+)//) {
$addr1 = "$1";
+ $addr1 = "\$. == $addr1" unless /^,/;
}
elsif (s/^\$//) {
$addr1 = 'eof()';
$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
-}
+ 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
}
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 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");
}
close HEAD;
- print <<"EOT";
-#!$bin/perl
-eval 'exec $bin/perl -S \$0 \$*'
- if \$running_under_some_shell;
-
+ 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");
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";
+ 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{$_} = $_;
+ $seen{$fname};
}
sub make_label {
{ # case
if (/^d/) {
$dseen++;
- chop($_ = <<'EOT');
-<<--#ifdef PRINTIT
-$printit = '';
-<<--#endif
-next LINE;
+ chop($_ = &q(<<'EOT'));
+: <<--#ifdef PRINTIT
+: $printit = 0;
+: <<--#endif
+: next LINE;
EOT
+ $sawnext++;
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
+ chop($_ = &q(<<'EOT'));
+: <<--#ifdef PRINTIT
+: <<--#ifdef DSEEN
+: <<--#ifdef ASSUMEP
+: print if $printit++;
+: <<--#else
+: if ($printit)
+: { print; }
+: else
+: { $printit++ unless $nflag; }
+: <<--#endif
+: <<--#else
+: print if $printit;
+: <<--#endif
+: <<--#else
+: print;
+: <<--#endif
+: <<--#ifdef APPENDSEEN
+: if ($atext) {chop $atext; print $atext; $atext = '';}
+: <<--#endif
+: $_ = <>;
+: chop;
+: <<--#ifdef TSEEN
+: $tflag = 0;
+: <<--#endif
EOT
next;
}
if (/^a/) {
$appendseen++;
- $command = $space . '$atext .=' . "\n<<--'";
+ $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
$lastline = 0;
while (<>) {
s/^[ \t]*//;
s/^[\\]//;
unless (s|\\$||) { $lastline = 1;}
- s/'/\\'/g;
s/^([ \t]*\n)/<><>$1/;
$command .= $_;
$command .= '<<--';
last if $lastline;
}
- $_ = $command . "';";
+ $_ = $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'
- . "\n<<--'";
+ $command = $space .
+ " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
$lastline = 0;
while (<>) {
s/^[ \t]*//;
$command .= '<<--';
last if $lastline;
}
- $_ = $command . "';}";
+ $_ = $command . "End_Of_Text";
if ($change) {
$dseen++;
$change = "$_\n";
- chop($_ = <<"EOT");
-<<--#ifdef PRINTIT
-$space\$printit = '';
-<<--#endif
-${space}next LINE;
+ chop($_ = &q(<<"EOT"));
+: <<--#ifdef PRINTIT
+: $space\$printit = 0;
+: <<--#endif
+: ${space}next LINE;
EOT
+ $sawnext++;
}
last;
}
elsif ($c eq ']') {
$inbracket = 0;
}
+ elsif ($c eq "\t") {
+ substr($_, $i, 1) = '\\t';
+ $i++;
+ $len++;
+ }
elsif (!$repl && index("()+",$c) >= 0) {
substr($_, $i, 0) = '\\';
$i++;
$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;
&Die("Unrecognized substitution command".
"($end) at line $.\n");
}
- chop ($_ = <<"EOT");
-<<--#ifdef TSEEN
-$subst && \$tflag++$cmd;
-<<--#else
-$subst$cmd;
-<<--#endif
+ chop ($_ = &q(<<"EOT"));
+: <<--#ifdef TSEEN
+: $subst && \$tflag++$cmd;
+: <<--#else
+: $subst$cmd;
+: <<--#endif
EOT
next;
}
}
if (/^P/) {
- $_ = 'print $1 if /(^.*\n)/;';
+ $_ = 'print $1 if /^(.*)/;';
next;
}
if (/^D/) {
- chop($_ = <<'EOT');
-s/^.*\n//;
-redo LINE if $_;
-next LINE;
+ chop($_ = &q(<<'EOT'));
+: s/^.*\n?//;
+: redo LINE if $_;
+: next LINE;
EOT
+ $sawnext++;
next;
}
if (/^N/) {
- chop($_ = <<'EOT');
-$_ .= <>;
-<<--#ifdef TSEEN
-$tflag = '';
-<<--#endif
+ chop($_ = &q(<<'EOT'));
+: $_ .= "\n";
+: $len1 = length;
+: $_ .= <>;
+: chop if $len1 < length;
+: <<--#ifdef TSEEN
+: $tflag = 0;
+: <<--#endif
EOT
next;
}
}
if (/^H/) {
- $_ = '$hold .= $_ ? $_ : "\n";';
+ $_ = '$hold .= "\n"; $hold .= $_;';
next;
}
}
if (/^G/) {
- $_ = '$_ .= $hold ? $hold : "\n";';
+ $_ = '$_ .= "\n"; $_ .= $hold;';
next;
}
if (/^b$/) {
$_ = 'next LINE;';
+ $sawnext++;
next;
}
if (/^t$/) {
$_ = 'next LINE if $tflag;';
+ $sawnext++;
$tseen++;
next;
}
if (/^t/) {
s/^t[ \t]*//;
$lab = &make_label($_);
- $_ = q/if ($tflag) {$tflag = ''; /;
+ $_ = q/if ($tflag) {$tflag = 0; /;
if ($lab eq $toplabel) {
$_ .= 'redo LINE;}';
} else {
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 "$.\n";';
+ $_ = 'print $.;';
next;
}
if (/^q/) {
- chop($_ = <<'EOT');
-close(ARGV);
-@ARGV = ();
-next LINE;
+ chop($_ = &q(<<'EOT'));
+: close(ARGV);
+: @ARGV = ();
+: next LINE;
EOT
+ $sawnext++;
next;
}
} continue {
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!
chmod 755 s2p
$eunicefix s2p
.rn '' }`
-''' $Header: s2p.man,v 4.0 91/03/20 01:58:07 lwall Locked $
+''' $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.
'''
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
projects / p5sagit/p5-mst-13.2.git / commitdiff