See patch #11.
--- /dev/null
+optimize="-O0"
+ccflags="$ccflags -nw"
package DB;
-$header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:17:44 $';
+# modified Perl debugger, to be run from Emacs in perldb-mode
+# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
+# Johan Vromans -- upgrade to 4.0 pl 10
+
+$header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:55:58 $';
#
# 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.2 91/11/05 17:55:58 lwall
+# patch11: perldb.pl modified to run within emacs in perldb-mode
+#
# 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
$| = 1; # for real STDOUT
$sub = '';
+# Is Perl being run from Emacs?
+$emacs = $main'ARGV[$[] eq '-emacs';
+shift(@main'ARGV) if $emacs;
+
$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
-print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
+print OUT "\nLoading DB routines from $header\n";
+print OUT ("Emacs support ",
+ $emacs ? "enabled" : "available",
+ ".\n");
+print OUT "\nEnter h for help.\n\n";
sub DB {
&save;
}
}
if ($single || $trace || $signal) {
- 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];
+ if ($emacs) {
+ print OUT "\032\032$filename:$line:0\n";
+ } else {
+ print OUT "$package'" unless $sub =~ /'/;
+ print OUT "$sub($filename:$line):\t",$dbline[$line];
+ for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
+ last if $dbline[$i] =~ /^\s*(}|#|\n)/;
+ print OUT "$sub($filename:$i):\t",$dbline[$i];
+ }
}
}
$evalarg = $action, &eval if $action;
$i = $2;
$i = $line if $i eq '.';
$i = 1 if $i < 1;
- for (; $i <= $end; $i++) {
- print OUT "$i:\t", $dbline[$i];
- last if $signal;
+ if ($emacs) {
+ print OUT "\032\032$filename:$i:0\n";
+ $i = $end;
+ } else {
+ for (; $i <= $end; $i++) {
+ print OUT "$i:\t", $dbline[$i];
+ last if $signal;
+ }
}
$start = $i; # remember in case they want more
$start = $max if $start > $max;
$start = 1 if ($start > $max);
last if ($start == $end);
if ($dbline[$start] =~ m'."\n$pat\n".'i) {
- print OUT "$start:\t", $dbline[$start], "\n";
+ if ($emacs) {
+ print OUT "\032\032$filename:$start:0\n";
+ } else {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ }
last;
}
} ';
$start = $max if ($start <= 0);
last if ($start == $end);
if ($dbline[$start] =~ m'."\n$pat\n".'i) {
- print OUT "$start:\t", $dbline[$start], "\n";
+ if ($emacs) {
+ print OUT "\032\032$filename:$start:0\n";
+ } else {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ }
last;
}
} ';
-#define PATCHLEVEL 15
+#define PATCHLEVEL 16
-/* $RCSfile: perly.y,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:42:34 $
+/* $RCSfile: perly.y,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:17:38 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: perly.y,v $
+ * Revision 4.0.1.2 91/11/05 18:17:38 lwall
+ * patch11: extra comma at end of list is now allowed in more places (Hi, Felix!)
+ * patch11: once-thru blocks didn't display right in the debugger
+ * patch11: debugger got confused over nested subroutine definitions
+ *
* Revision 4.0.1.1 91/06/07 11:42:34 lwall
* patch4: new copyright notice
*
#include "INTERN.h"
#include "perl.h"
+/*SUPPRESS 530*/
+/*SUPPRESS 593*/
+/*SUPPRESS 595*/
+
STAB *scrstab;
ARG *arg4; /* rarely used arguments to make_op() */
ARG *arg5;
FCMD *formval;
}
+%token <ival> '{' ')'
+
%token <cval> WORD
%token <ival> APPEND OPEN SSELECT LOOPEX
%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
%token <arg> SUBST PATTERN
%token <arg> RSTRING TRANS
-%type <ival> prog decl format remember
+%type <ival> prog decl format remember crp
%type <cmdval> block lineseq line loop cond sideff nexpr else
%type <arg> expr sexpr cexpr csexpr term handle aryword hshword
%type <arg> texpr listop bareword
block : '{' remember lineseq '}'
{ $$ = block_head($3);
+ if (cmdline > $1)
+ cmdline = $1;
if (savestack->ary_fill > $2)
restorelist($2); }
;
{ cmdline = $2;
$$ = wopt(add_label($1,
invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); }
- | label FOR REG '(' expr ')' compblock
+ | label FOR REG '(' expr crp compblock
{ cmdline = $2;
/*
* The following gobbledygook catches EXPRs that
make_ccmd(C_WHILE,$5,$7) )));
}
}
- | label FOR '(' expr ')' compblock
+ | label FOR '(' expr crp compblock
{ cmdline = $2;
if ($4->arg_type != O_ARRAY) {
scrstab = aadd(genstab());
;
subrout : SUB WORD block
- { make_sub($2,$3); }
+ { make_sub($2,$3);
+ cmdline = NOLINE;
+ if (savestack->ary_fill > $1)
+ restorelist($1); }
;
package : PACKAGE WORD ';'
stab2arg(A_STAB,
$1 == O_FTTTY?stabent("STDIN",TRUE):defstab),
Nullarg, Nullarg); }
- | LOCAL '(' expr ')'
+ | LOCAL '(' expr crp
{ $$ = l(localize(make_op(O_ASSIGN, 1,
localize(listish(make_list($3))),
Nullarg,Nullarg))); }
- | '(' expr ',' ')'
- { $$ = make_list($2); }
- | '(' expr ')'
+ | '(' expr crp
{ $$ = make_list($2); }
| '(' ')'
{ $$ = make_list(Nullarg); }
stab2arg(A_STAB,hadd($1)),
jmaybe($3),
Nullarg); }
- | '(' expr ')' '[' expr ']' %prec '('
+ | '(' expr crp '[' expr ']' %prec '('
{ $$ = make_op(O_LSLICE, 3,
Nullarg,
listish(make_list($5)),
{ $$ = $1; }
| TRANS %prec '('
{ $$ = $1; }
- | DO WORD '(' expr ')'
+ | DO WORD '(' expr crp
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,TRUE)),
+ stab2arg(A_WORD,stabent($2,MULTI)),
make_list($4),
Nullarg); Safefree($2); $2 = Nullch;
$$->arg_flags |= AF_DEPR; }
- | AMPER WORD '(' expr ')'
+ | AMPER WORD '(' expr crp
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,TRUE)),
+ stab2arg(A_WORD,stabent($2,MULTI)),
make_list($4),
Nullarg); Safefree($2); $2 = Nullch; }
| DO WORD '(' ')'
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,TRUE)),
+ stab2arg(A_WORD,stabent($2,MULTI)),
make_list(Nullarg),
Nullarg);
$$->arg_flags |= AF_DEPR; }
| AMPER WORD '(' ')'
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,TRUE)),
+ stab2arg(A_WORD,stabent($2,MULTI)),
make_list(Nullarg),
Nullarg); }
| AMPER WORD
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
- stab2arg(A_WORD,stabent($2,TRUE)),
+ stab2arg(A_WORD,stabent($2,MULTI)),
Nullarg,
Nullarg); }
- | DO REG '(' expr ')'
+ | DO REG '(' expr crp
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_STAB,$2),
make_list($4),
Nullarg);
$$->arg_flags |= AF_DEPR; }
- | AMPER REG '(' expr ')'
+ | AMPER REG '(' expr crp
{ $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
stab2arg(A_STAB,$2),
make_list($4),
Nullarg,Nullarg); }
| UNIOP
{ $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); }
+ | UNIOP block
+ { $$ = make_op($1,1,cmd_to_arg($2),Nullarg,Nullarg); }
| UNIOP sexpr
{ $$ = make_op($1,1,$2,Nullarg,Nullarg); }
| SSELECT
{ $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);}
+ | SSELECT WORD
+ { $$ = make_op(O_SELECT, 1,
+ stab2arg(A_WORD,stabent($2,TRUE)),
+ Nullarg,
+ Nullarg);
+ Safefree($2); $2 = Nullch; }
| SSELECT '(' handle ')'
{ $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg); }
| SSELECT '(' sexpr csexpr csexpr csexpr ')'
| FILOP25 '(' handle ',' handle csexpr csexpr cexpr ')'
{ arg4 = $7; arg5 = $8;
$$ = make_op($1, 5, $3, $5, $6); }
- | PUSH '(' aryword cexpr ')'
+ | PUSH '(' aryword ',' expr crp
{ $$ = make_op($1, 2,
$3,
- make_list($4),
+ make_list($5),
Nullarg); }
| POP aryword %prec '('
{ $$ = make_op(O_POP, 1, $2, Nullarg, Nullarg); }
$3,
listish(make_list($4)),
Nullarg); }
- | FLIST '(' expr ')'
+ | FLIST '(' expr crp
{ $$ = make_op($1, 1,
make_list($3),
Nullarg,
stab2arg(A_STAB,$2),
maybelistish($1,make_list($3)),
Nullarg); }
+ | LISTOP block expr
+ { $$ = make_op($1,2,
+ cmd_to_arg($2),
+ maybelistish($1,make_list($3)),
+ Nullarg); }
;
handle : WORD
{ $$ = stab2arg(A_STAB,$1); }
;
+crp : ',' ')'
+ { $$ = 1; }
+ | ')'
+ { $$ = 0; }
+ ;
+
/*
* NOTE: The following entry must stay at the end of the file so that
* reduce/reduce conflicts resolve to it only if it's the only option.
$$->arg_type = O_ITEM;
$$[1].arg_type = A_SINGLE;
$$[1].arg_ptr.arg_str = str_make($1,0);
- for (s = $1; *s && islower(*s); s++) ;
+ for (s = $1; *s && isLOWER(*s); s++) ;
if (dowarn && !*s)
warn(
"\"%s\" may clash with future reserved word",
* 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 $
+/* $RCSfile: regcomp.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:22:28 $
*
* $Log: regcomp.c,v $
+ * Revision 4.0.1.3 91/11/05 18:22:28 lwall
+ * patch11: minimum match length calculation in regexp is now cumulative
+ * patch11: initial .* in pattern had dependency on value of $*
+ * patch11: certain patterns made use of garbage pointers from uncleared memory
+ * patch11: prepared for ctype implementations that don't define isascii()
+ *
* 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"
* 4.0 baseline.
*
*/
-
+/*SUPPRESS 112*/
/*
* regcomp and regexec -- regsub and regerror are not used in perl
*
int backish;
int backest;
int curback;
+ int minlen;
extern char *safemalloc();
extern char *savestr();
int sawplus = 0;
regnpar = 1;
regsize = 0L;
regcode = ®dummy;
- regc(MAGIC);
+ regc((char)MAGIC);
if (reg(0, &flags) == NULL) {
Safefree(regprecomp);
regprecomp = Nullch;
regparse = exp;
regnpar = 1;
regcode = r->program;
- regc(MAGIC);
+ regc((char)MAGIC);
if (reg(0, &flags) == NULL)
return(NULL);
r->regstclass = first;
else if (OP(first) == BOL ||
(OP(first) == STAR && OP(NEXTOPER(first)) == ANY) ) {
- r->reganch = ROPT_ANCH; /* kinda turn .* into ^.* */
+ /* kinda turn .* into ^.* */
+ r->reganch = ROPT_ANCH | ROPT_IMPLICIT;
first = NEXTOPER(first);
goto again;
}
longish = str_make("",0);
longest = str_make("",0);
len = 0;
+ minlen = 0;
curback = 0;
backish = 0;
backest = 0;
first = scan;
while (OP(t = regnext(scan)) == CLOSE)
scan = t;
+ minlen += *OPERAND(first);
if (curback - backish == len) {
str_ncat(longish, OPERAND(first)+1,
*OPERAND(first));
backest = backish;
}
str_nset(longish,"",0);
+ if (OP(scan) == PLUS &&
+ index(simple,OP(NEXTOPER(scan))))
+ minlen++;
+ else if (OP(scan) == CURLY &&
+ index(simple,OP(NEXTOPER(scan)+4)))
+ minlen += ARG1(scan);
}
else if (index(simple,OP(scan))) {
curback++;
+ minlen++;
len = 0;
if (longish->str_cur > longest->str_cur) {
str_sset(longest,longish);
&&
(!r->regstart
||
- !fbminstr(r->regstart->str_ptr,
- r->regstart->str_ptr + r->regstart->str_cur,
+ !fbminstr((unsigned char*) r->regstart->str_ptr,
+ (unsigned char *) r->regstart->str_ptr
+ + r->regstart->str_cur,
longest)
)
)
r->do_folding = fold;
r->nparens = regnpar - 1;
- New(1002, r->startp, regnpar, char*);
- New(1002, r->endp, regnpar, char*);
+ r->minlen = minlen;
+ Newz(1002, r->startp, regnpar, char*);
+ Newz(1002, r->endp, regnpar, char*);
#ifdef DEBUGGING
if (debug & 512)
regdump(r);
if (op == '{' && regcurly(regparse)) {
next = regparse + 1;
max = Nullch;
- while (isdigit(*next) || *next == ',') {
+ while (isDIGIT(*next) || *next == ',') {
if (*next == ',') {
if (max)
break;
else {
regsawback = 1;
ret = reganode(REF, num);
- while (isascii(*regparse) && isdigit(*regparse))
+ while (isDIGIT(*regparse))
regparse++;
*flagp |= SIMPLE;
}
case 'c':
p++;
ender = *p++;
- if (islower(ender))
+ if (isLOWER(ender))
ender = toupper(ender);
ender ^= 64;
break;
case '0': case '1': case '2': case '3':case '4':
case '5': case '6': case '7': case '8':case '9':
if (*p == '0' ||
- (isdigit(p[1]) && atoi(p) >= regnpar) ) {
+ (isDIGIT(p[1]) && atoi(p) >= regnpar) ) {
ender = scanoct(p, 3, &numlen);
p += numlen;
}
ender = *p++;
break;
}
- if (regfold && isupper(ender))
+ if (regfold && isUPPER(ender))
ender = tolower(ender);
if (ISMULT2(p)) { /* Back off on ?+*. */
if (len)
break;
case 'c':
class = *regparse++;
- if (islower(class))
+ if (isLOWER(class))
class = toupper(class);
class ^= 64;
break;
}
for ( ; lastclass <= class; lastclass++) {
regset(bits,def,lastclass);
- if (regfold && isupper(lastclass))
+ if (regfold && isUPPER(lastclass))
regset(bits,def,tolower(lastclass));
}
lastclass = class;
{
if (*s++ != '{')
return FALSE;
- if (!isdigit(*s))
+ if (!isDIGIT(*s))
return FALSE;
- while (isdigit(*s))
+ while (isDIGIT(*s))
s++;
if (*s == ',')
s++;
- while (isdigit(*s))
+ while (isDIGIT(*s))
s++;
if (*s != '}')
return FALSE;
fprintf(stderr,"anchored ");
if (r->reganch & ROPT_SKIP)
fprintf(stderr,"plus ");
+ if (r->reganch & ROPT_IMPLICIT)
+ fprintf(stderr,"implicit ");
if (r->regmust != NULL)
fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
r->regback);
+ fprintf(stderr, "minlen %d ", r->minlen);
fprintf(stderr,"\n");
}
* 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 $
+/* $RCSfile: regexec.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:23:55 $
*
* $Log: regexec.c,v $
+ * Revision 4.0.1.3 91/11/05 18:23:55 lwall
+ * patch11: prepared for ctype implementations that don't define isascii()
+ * patch11: initial .* in pattern had dependency on value of $*
+ *
* 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
* 4.0 baseline.
*
*/
-
+/*SUPPRESS 112*/
/*
* regcomp and regexec -- regsub and regerror are not used in perl
*
int regnarrate = 0;
#endif
-#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_'))
-#define isSPACE(c) (isascii(c) && isspace(c))
-#define isDIGIT(c) (isascii(c) && isdigit(c))
-#define isUPPER(c) (isascii(c) && isupper(c))
-
/*
* regexec and friends
*/
if (prog->reganch & ROPT_ANCH) {
if (regtry(prog, string))
goto got_it;
- else if (multiline) {
+ else if (multiline || (prog->reganch & ROPT_IMPLICIT)) {
if (minlen)
dontbother = minlen - 1;
strend -= dontbother;
}
goto phooey;
}
+ /*SUPPRESS 560*/
if (c = prog->regstclass) {
int doevery = (prog->reganch & ROPT_SKIP) == 0;
if (regmatch(NEXTOPER(scan)))
return(1);
#ifdef REGALIGN
+ /*SUPPRESS 560*/
if (n = NEXT(scan))
scan += n;
else
-/* $RCSfile: stab.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:55:53 $
+/* $RCSfile: stab.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:35:33 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: stab.c,v $
+ * Revision 4.0.1.3 91/11/05 18:35:33 lwall
+ * patch11: length($x) was sometimes wrong for numeric $x
+ * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
+ * patch11: *foo = undef coredumped
+ * patch11: solitary subroutine references no longer trigger typo warnings
+ * patch11: local(*FILEHANDLE) had a memory leak
+ *
* Revision 4.0.1.2 91/06/07 11:55:53 lwall
* patch4: new copyright notice
* patch4: added $^P variable to control calling of perldb routines
char *s;
if (str->str_rare)
- return stab_val(stab)->str_cur;
+ return str_len(stab_val(stab));
switch (*stab->str_magic->str_ptr) {
case '1': case '2': case '3': case '4':
case '\\':
return (STRLEN)orslen;
default:
- return stab_str(str)->str_cur;
+ return str_len(stab_str(str));
}
}
register STR *mstr;
STR *str;
{
- STAB *stab = mstr->str_u.str_stab;
+ STAB *stab;
register char *s;
int i;
case 'S':
s = str_get(str);
i = whichsig(mstr->str_ptr); /* ...no, a brick */
+ if (!i && (dowarn || strEQ(mstr->str_ptr,"ALARM")))
+ warn("No such signal: SIG%s", mstr->str_ptr);
if (strEQ(s,"IGNORE"))
#ifndef lint
(void)signal(i,SIG_IGN);
break;
#ifdef SOME_DBM
case 'D':
+ stab = mstr->str_u.str_stab;
hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
break;
#endif
{
CMD *cmd;
+ stab = mstr->str_u.str_stab;
i = str_true(str);
str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
cmd = str->str_magic->str_u.str_cmd;
}
break;
case '#':
+ stab = mstr->str_u.str_stab;
afill(stab_array(stab), (int)str_gnum(str) - arybase);
break;
case 'X': /* merely a copy of a * string */
break;
case '*':
- s = str_get(str);
+ s = str->str_pok ? str_get(str) : "";
if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
+ stab = mstr->str_u.str_stab;
if (!*s) {
STBP *stbp;
+ /*SUPPRESS 701*/
(void)savenostab(stab); /* schedule a free of this stab */
if (stab->str_len)
Safefree(stab->str_ptr);
if (!stab_io(stab))
stab_io(stab) = stio_new();
}
- str_sset(str,stab);
+ str_sset(str, (STR*) stab);
}
break;
case 's': {
break;
case 0:
+ /*SUPPRESS 560*/
+ if (!(stab = mstr->str_u.str_stab))
+ break;
switch (*stab->str_magic->str_ptr) {
case '\004': /* ^D */
#ifdef DEBUGGING
sig_name[sig], stab_name(stab) );
return;
}
+ /*SUPPRESS 701*/
saveaptr(&stack);
str = Str_new(15, sizeof(CSV));
str->str_state = SS_SCSV;
char *prevquote = Nullch;
bool global = FALSE;
- if (isascii(*name) && isupper(*name)) {
+ if (isUPPER(*name)) {
if (*name > 'I') {
if (*name == 'S' && (
strEQ(name, "SIG") ||
sawquote = Nullch;
name++;
}
- else if (!isalpha(*name) || global)
+ else if (!isALPHA(*name) || global)
stash = defstash;
- else if (curcmd == &compiling)
+ else if ((CMD*)curcmd == &compiling)
stash = curstash;
else
stash = curcmd->c_stash;
char *s, *d;
*sawquote = '\0';
+ /*SUPPRESS 560*/
if (s = prevquote) {
strncpy(tmpbuf,name,s-name+1);
d = tmpbuf+(s-name+1);
strcpy(stab_magic(stab),"StB");
stab_val(stab) = Str_new(72,0);
stab_line(stab) = curcmd->c_line;
- str_magic(stab,stab,'*',name,len);
+ str_magic((STR*)stab, stab, '*', name, len);
stab_stash(stab) = stash;
- if (isdigit(*name) && *name != '0') {
+ if (isDIGIT(*name) && *name != '0') {
stab_flags(stab) = SF_VMAGIC;
str_magic(stab_val(stab), stab, 0, Nullch, 0);
}
+ if (add & 2)
+ stab->str_pok |= SP_MULTI;
return stab;
}
}
stab_xhash(stab) = Null(HASH*);
str_free(stab_val(stab));
stab_val(stab) = Nullstr;
+ /*SUPPRESS 560*/
if (stio = stab_io(stab)) {
do_close(stab,FALSE);
Safefree(stio->top_name);
Safefree(stio->fmt_name);
+ Safefree(stio);
}
+ /*SUPPRESS 560*/
if (sub = stab_sub(stab)) {
afree(sub->tosave);
cmd_free(sub->cmd);
-/* $RCSfile: stab.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:56:35 $
+/* $RCSfile: stab.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:36:15 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: stab.h,v $
+ * Revision 4.0.1.2 91/11/05 18:36:15 lwall
+ * patch11: length($x) was sometimes wrong for numeric $x
+ *
* Revision 4.0.1.1 91/06/07 11:56:35 lwall
* patch4: new copyright notice
* patch4: length($`), length($&), length($') now optimized to avoid string copy
STRLEN stab_len();
#define STAB_STR(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_str(stab_val(tmpstab)->str_magic) : stab_val(tmpstab))
-#define STAB_LEN(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_len(stab_val(tmpstab)->str_magic) : stab_val(tmpstab)->str_cur)
+#define STAB_LEN(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_len(stab_val(tmpstab)->str_magic) : str_len(stab_val(tmpstab)))
#define STAB_GET(s) (tmpstab = (s), str_get(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
#define STAB_GNUM(s) (tmpstab = (s), str_gnum(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
-/* $RCSfile: str.c,v $$Revision: 4.0.1.3 $$Date: 91/06/10 01:27:54 $
+/* $RCSfile: str.c,v $$Revision: 4.0.1.4 $$Date: 91/11/05 18:40:51 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: str.c,v $
+ * Revision 4.0.1.4 91/11/05 18:40:51 lwall
+ * patch11: $foo .= <BAR> could overrun malloced memory
+ * patch11: \$ didn't always make it through double-quoter to regexp routines
+ * patch11: prepared for ctype implementations that don't define isascii()
+ *
* Revision 4.0.1.3 91/06/10 01:27:54 lwall
* patch10: $) and $| incorrectly handled in run-time patterns
*
}
str_nset(dstr,sstr->str_ptr,sstr->str_cur);
}
+ /*SUPPRESS 560*/
if (dstr->str_nok = sstr->str_nok)
dstr->str_u.str_nval = sstr->str_u.str_nval;
else {
*mid = '\0';
bigstr->str_cur = mid - big;
}
+ /*SUPPRESS 560*/
else if (i = mid - big) { /* faster from front */
midend -= littlelen;
mid = midend;
(void)str_2ptr(str2);
if (str1->str_cur < str2->str_cur) {
+ /*SUPPRESS 560*/
if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
return retval < 0 ? -1 : 1;
else
return -1;
}
+ /*SUPPRESS 560*/
else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
return retval < 0 ? -1 : 1;
else if (str1->str_cur == str2->str_cur)
cnt = fp->_cnt; /* get count into register */
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
- if (str->str_len <= cnt + 1) { /* make sure we have the room */
+ if (str->str_len - append <= cnt + 1) { /* make sure we have the room */
if (cnt > 80 && str->str_len > append) {
shortbuffered = cnt - str->str_len + append + 1;
cnt -= shortbuffered;
if (*s == '\\' && s[1] && index("$@[{\\]}lLuUE",s[1])) {
str_ncat(str, t, s - t);
++s;
- if (isalpha(*s)) {
+ if (isALPHA(*s)) {
str_ncat(str, "$c", 2);
sawcase = (*s != 'E');
}
else {
- if (*nointrp && s+1 < send)
- if (*s != '@' && (*s != '$' || index(nointrp,s[1])))
+ if (*nointrp) { /* in a regular expression */
+ if (*s == '@') /* always strip \@ */ /*SUPPRESS 530*/
+ ;
+ else if (*s == '$') {
+ if (s+1 >= send || index(nointrp, s[1]))
+ str_ncat(str,s-1,1); /* only strip \$ for vars */
+ }
+ else /* don't strip \\, \[, \{ etc. */
str_ncat(str,s-1,1);
+ }
str_ncat(str, "$b", 2);
}
str_ncat(str, s, 1);
else if ((*s == '@' || *s == '$') && s+1 < send) {
str_ncat(str,t,s-t);
t = s;
- if (*s == '$' && s[1] == '#' && (isalpha(s[2]) || s[2] == '_'))
+ if (*s == '$' && s[1] == '#' && (isALPHA(s[2]) || s[2] == '_'))
s++;
s = scanident(s,send,tokenbuf);
if (*t == '@' &&
case '\'':
case '"':
if (s[-1] != '$') {
+ /*SUPPRESS 68*/
s = cpytill(tokenbuf,s+1,send,*s,&len);
if (s >= send)
fatal("Unterminated string");
d = checkpoint;
if (*d == '{' && s[-1] == '}') { /* maybe {n,m} */
++d;
- if (isdigit(*d)) { /* matches /^{\d,?\d*}$/ */
+ if (isDIGIT(*d)) { /* matches /^{\d,?\d*}$/ */
if (*++d == ',')
++d;
- while (isdigit(*d))
+ while (isDIGIT(*d))
d++;
if (d == s - 1)
s = checkpoint; /* Is {n,m}! Backoff! */
weight += 150;
else if (d[1] == '$')
weight -= 3;
- if (isdigit(d[1])) {
+ if (isDIGIT(d[1])) {
if (d[2]) {
- if (isdigit(d[2]) && !d[3])
+ if (isDIGIT(d[2]) && !d[3])
weight -= 10;
}
else
case '&':
case '$':
weight -= seen[un_char] * 10;
- if (isalpha(d[1]) || isdigit(d[1]) ||
- d[1] == '_') {
+ if (isALNUM(d[1])) {
d = scanident(d,s,tokenbuf);
if (stabent(tokenbuf,FALSE))
weight -= 100;
weight += 1;
else if (index("rnftb",d[1]))
weight += 40;
- else if (isdigit(d[1])) {
+ else if (isDIGIT(d[1])) {
weight += 40;
- while (d[1] && isdigit(d[1]))
+ while (d[1] && isDIGIT(d[1]))
d++;
}
}
else
weight -= 1;
default:
- if (isalpha(*d) && d[1] && isalpha(d[1])) {
+ if (isALPHA(*d) && d[1] && isALPHA(d[1])) {
bufptr = d;
if (yylex() != WORD)
weight -= 150;
register char *send;
{
while (s < send) {
- if (isascii(*s) && islower(*s))
+ if (isLOWER(*s))
*s = toupper(*s);
s++;
}
register char *send;
{
while (s < send) {
- if (isascii(*s) && isupper(*s))
+ if (isUPPER(*s))
*s = tolower(*s);
s++;
}
return;
}
d = str->str_ptr;
- while (isalpha(*d)) d++;
- while (isdigit(*d)) d++;
+ while (isALPHA(*d)) d++;
+ while (isDIGIT(*d)) d++;
if (*d) {
str_numset(str,atof(str->str_ptr) + 1.0); /* punt */
return;
}
d--;
while (d >= str->str_ptr) {
- if (isdigit(*d)) {
+ if (isDIGIT(*d)) {
if (++*d <= '9')
return;
*(d--) = '0';
}
else {
++*d;
- if (isalpha(*d))
+ if (isALPHA(*d))
return;
*(d--) -= 'z' - 'a' + 1;
}
str->str_cur++;
for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--)
*d = d[-1];
- if (isdigit(d[1]))
+ if (isDIGIT(d[1]))
*d = '1';
else
*d = d[1];
#!./perl
-# $RCSfile: stat.t,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:02:42 $
+# $RCSfile: stat.t,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:44:44 $
print "1..56\n";
$DEV = `ls -l /dev`;
unlink "Op.stat.tmp";
-open(foo, ">Op.stat.tmp");
+open(FOO, ">Op.stat.tmp");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat(foo);
+ $blksize,$blocks) = stat(FOO);
if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";}
if ($mtime && $mtime == $ctime) {print "ok 2\n";} else {print "not ok 2\n";}
-print foo "Now is the time for all good men to come to.\n";
-close(foo);
+print FOO "Now is the time for all good men to come to.\n";
+close(FOO);
sleep 2;
if (-B './perl') {print "ok 43\n";} else {print "not ok 43\n";}
if (! -T './perl') {print "ok 44\n";} else {print "not ok 44\n";}
-open(foo,'op/stat.t');
-if (-T foo) {print "ok 45\n";} else {print "not ok 45\n";}
-if (! -B foo) {print "ok 46\n";} else {print "not ok 46\n";}
-$_ = <foo>;
-if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";}
-if (-T foo) {print "ok 48\n";} else {print "not ok 48\n";}
-if (! -B foo) {print "ok 49\n";} else {print "not ok 49\n";}
-close(foo);
-
-open(foo,'op/stat.t');
-$_ = <foo>;
-if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
-if (-T foo) {print "ok 51\n";} else {print "not ok 51\n";}
-if (! -B foo) {print "ok 52\n";} else {print "not ok 52\n";}
-seek(foo,0,0);
-if (-T foo) {print "ok 53\n";} else {print "not ok 53\n";}
-if (! -B foo) {print "ok 54\n";} else {print "not ok 54\n";}
-close(foo);
+open(FOO,'op/stat.t');
+eval { -T FOO; };
+if ($@ =~ /not implemented/) {
+ print "# $@";
+ for (45 .. 54) {
+ print "ok $_\n";
+ }
+}
+else {
+ if (-T FOO) {print "ok 45\n";} else {print "not ok 45\n";}
+ if (! -B FOO) {print "ok 46\n";} else {print "not ok 46\n";}
+ $_ = <FOO>;
+ if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";}
+ if (-T FOO) {print "ok 48\n";} else {print "not ok 48\n";}
+ if (! -B FOO) {print "ok 49\n";} else {print "not ok 49\n";}
+ close(FOO);
+
+ open(FOO,'op/stat.t');
+ $_ = <FOO>;
+ if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
+ if (-T FOO) {print "ok 51\n";} else {print "not ok 51\n";}
+ if (! -B FOO) {print "ok 52\n";} else {print "not ok 52\n";}
+ seek(FOO,0,0);
+ if (-T FOO) {print "ok 53\n";} else {print "not ok 53\n";}
+ if (! -B FOO) {print "ok 54\n";} else {print "not ok 54\n";}
+}
+close(FOO);
if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";}
if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";}
projects / p5sagit/p5-mst-13.2.git / commitdiff