Skip to content
Browse files

perl 3.0 patch #40 patch #38, continued

See patch #38.
  • Loading branch information...
1 parent 57ebbfd commit 34de22dd6ede167a09e3a3ee571665ba2c647f94 Larry Wall committed Nov 9, 1990
Showing with 339 additions and 77 deletions.
  1. +3 −3 eg/who
  2. +6 −3 lib/perldb.pl
  3. +7 −4 lib/syslog.pl
  4. +52 −0 os2/perldb.dif
  5. +2 −2 os2/perlglob.cs
  6. +0 −1 os2/perlglob.def
  7. +1 −1 patchlevel.h
  8. +40 −12 perl.man.3
  9. +13 −4 perl.man.4
  10. +50 −5 perly.c
  11. +33 −12 regcomp.c
  12. +6 −1 regcomp.h
  13. +9 −4 regexec.c
  14. +7 −3 stab.c
  15. +75 −14 str.c
  16. +5 −1 str.h
  17. +8 −2 toke.c
  18. +22 −5 util.c
View
6 eg/who
@@ -1,8 +1,8 @@
#!/usr/bin/perl
# This assumes your /etc/utmp file looks like ours
-open(utmp,'/etc/utmp');
-@mo = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
-while (read(utmp,$utmp,36)) {
+open(UTMP,'/etc/utmp');
+@mo = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
+while (read(UTMP,$utmp,36)) {
($line,$name,$host,$time) = unpack('A8A8A16l',$utmp);
if ($name) {
$host = "($host)" if $host;
View
9 lib/perldb.pl
@@ -1,6 +1,6 @@
package DB;
-$header = '$Header: perldb.pl,v 3.0.1.4 90/10/15 17:40:38 lwall Locked $';
+$header = '$Header: perldb.pl,v 3.0.1.5 90/11/10 01:40:26 lwall Locked $';
#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
@@ -10,6 +10,9 @@ package DB;
# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
#
# $Log: perldb.pl,v $
+# Revision 3.0.1.5 90/11/10 01:40:26 lwall
+# patch38: the debugger wouldn't stop correctly or do action routines
+#
# Revision 3.0.1.4 90/10/15 17:40:38 lwall
# patch29: added caller
# patch29: the debugger now understands packages and evals
@@ -59,7 +62,7 @@ sub DB {
$signal |= 1;
}
else {
- $signal |= &eval($stop);
+ &eval("\$DB'signal |= do {$stop;}");
$dbline{$line} =~ s/;9($|\0)/$1/;
}
}
@@ -307,7 +310,7 @@ sub DB {
print OUT "Line $i may not have an action.\n";
} else {
$dbline{$i} =~ s/\0[^\0]*//;
- $dbline .= "\0" . do action($3);
+ $dbline{$i} .= "\0" . do action($3);
}
next; };
$cmd =~ /^n$/ && do {
View
11 lib/syslog.pl
@@ -2,9 +2,12 @@
# syslog.pl
#
# $Log: syslog.pl,v $
-Revision 3.0.1.3 90/10/15 17:42:18 lwall
-patch29: various portability fixes
-
+# Revision 3.0.1.4 90/11/10 01:41:11 lwall
+# patch38: syslog.pl was referencing an absolute path
+#
+# Revision 3.0.1.3 90/10/15 17:42:18 lwall
+# patch29: various portability fixes
+#
# Revision 3.0.1.1 90/08/09 03:57:17 lwall
# patch19: Initial revision
#
@@ -54,7 +57,7 @@ package syslog;
$host = 'localhost' unless $host; # set $syslog'host to change
-require '/usr/local/lib/perl/syslog.ph';
+require 'syslog.ph';
$maskpri = &LOG_UPTO(&LOG_DEBUG);
View
52 os2/perldb.dif
@@ -0,0 +1,52 @@
+*** lib/perldb.pl Tue Oct 23 23:14:20 1990
+--- os2/perldb.pl Tue Nov 06 21:13:42 1990
+***************
+*** 36,43 ****
+ #
+ #
+
+! open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin
+! open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
+ select(OUT);
+ $| = 1; # for DB'OUT
+ select(STDOUT);
+--- 36,43 ----
+ #
+ #
+
+! open(IN, "<con") || open(IN, "<&STDIN"); # so we don't dingle stdin
+! open(OUT,">con") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
+ select(OUT);
+ $| = 1; # for DB'OUT
+ select(STDOUT);
+***************
+*** 517,530 ****
+ s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+ }
+
+! if (-f '.perldb') {
+! do './.perldb';
+ }
+! elsif (-f "$ENV{'LOGDIR'}/.perldb") {
+! do "$ENV{'LOGDIR'}/.perldb";
+ }
+! elsif (-f "$ENV{'HOME'}/.perldb") {
+! do "$ENV{'HOME'}/.perldb";
+ }
+
+ 1;
+--- 517,530 ----
+ s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+ }
+
+! if (-f 'perldb.ini') {
+! do './perldb.ini';
+ }
+! elsif (-f "$ENV{'INIT'}/perldb.ini") {
+! do "$ENV{'INIT'}/perldb.ini";
+ }
+! elsif (-f "$ENV{'HOME'}/perldb.ini") {
+! do "$ENV{'HOME'}/perldb.ini";
+ }
+
+ 1;
View
4 os2/perlglob.cs
@@ -1,7 +1,7 @@
-glob.c
+msdos\glob.c
setargv.obj
-perlglob.def
+os2\perlglob.def
perlglob.exe
-AS -LB -S0x1000
View
1 os2/perlglob.def
@@ -1,3 +1,2 @@
NAME PERLGLOB WINDOWCOMPAT NEWFILES
DESCRIPTION 'Filename globbing for PERL - for MS-DOS and OS/2'
-STUB 'REALGLOB.EXE'
View
2 patchlevel.h
@@ -1 +1 @@
-#define PATCHLEVEL 39
+#define PATCHLEVEL 40
View
52 perl.man.3
@@ -1,7 +1,11 @@
''' Beginning of part 3
-''' $Header: perl_man.3,v 3.0.1.10 90/10/20 02:15:17 lwall Locked $
+''' $Header: perl_man.3,v 3.0.1.11 90/11/10 01:48:21 lwall Locked $
'''
''' $Log: perl.man.3,v $
+''' Revision 3.0.1.11 90/11/10 01:48:21 lwall
+''' patch38: random cleanup
+''' patch38: documented tr///cds
+'''
''' Revision 3.0.1.10 90/10/20 02:15:17 lwall
''' patch37: patch37: fixed various typos in man page
'''
@@ -298,7 +302,7 @@ The "a" and "A" types gobble just one value, but pack it as a string of length
count,
padding with nulls or spaces as necessary.
(When unpacking, "A" strips trailing spaces and nulls, but "a" does not.)
-Real numbers (floats and doubles) are in the nnativeative machine format
+Real numbers (floats and doubles) are in the native machine format
only; due to the multiplicity of floating formats around, and the lack
of a standard \*(L"network\*(R" representation, no facility for
interchange has been made.
@@ -308,7 +312,7 @@ use IEEE floating point arithmetic (as the endian-ness of the memory
representation is not part of the IEEE spec).
Note that perl uses
doubles internally for all numeric calculation, and converting from
-double -> float -> double will loose precision (i.e. unpack("f",
+double -> float -> double will lose precision (i.e. unpack("f",
pack("f", $foo)) will not in general equal $foo).
.br
Examples:
@@ -382,7 +386,7 @@ in an array context, and any subroutine that you call will have one or more
of its expressions evaluated in an array context.
Also be careful not to follow the print keyword with a left parenthesis
unless you want the corresponding right parenthesis to terminate the
-arguments to the print--interpose a + or put parens around all the arguments.
+arguments to the print\*(--interpose a + or put parens around all the arguments.
.Ip "printf(FILEHANDLE LIST)" 8 10
.Ip "printf(LIST)" 8
.Ip "printf FILEHANDLE LIST" 8
@@ -639,7 +643,7 @@ FILEHANDLE may be an expression whose value gives the name of the filehandle.
Returns 1 upon success, 0 otherwise.
.Ip "seekdir(DIRHANDLE,POS)" 8 3
Sets the current position for the readdir() routine on DIRHANDLE.
-POS must be a value returned by seekdir().
+POS must be a value returned by telldir().
Has the same caveats about possible directory compaction as the corresponding
system library routine.
.Ip "select(FILEHANDLE)" 8 3
@@ -808,7 +812,7 @@ Returns the number of seconds actually slept.
Opens a socket of the specified kind and attaches it to filehandle SOCKET.
DOMAIN, TYPE and PROTOCOL are specified the same as for the system call
of the same name.
-You may need to run makelib on sys/socket.h to get the proper values handy
+You may need to run h2ph on sys/socket.h to get the proper values handy
in a perl library file.
Return true if successful.
See the example in the section on Interprocess Communication.
@@ -1114,7 +1118,7 @@ in a numeric context, you may need to add 0 to them to force them to look
like numbers.
.nf
- require 'syscall.ph'; # may need to run makelib
+ require 'syscall.ph'; # may need to run h2ph
syscall(&SYS_write, fileno(STDOUT), "hi there\en", 9);
.fi
@@ -1162,19 +1166,19 @@ a directory.
Has the same caveats about possible directory compaction as the corresponding
system library routine.
.Ip "time" 8 4
-Returns the number of non-leap seconds since January 1, 1970, UTC.
+Returns the number of non-leap seconds since 00:00:00 UTC, January 1, 1970.
Suitable for feeding to gmtime() and localtime().
.Ip "times" 8 4
Returns a four-element array giving the user and system times, in seconds, for this
process and the children of this process.
.Sp
($user,$system,$cuser,$csystem) = times;
.Sp
-.Ip "tr/SEARCHLIST/REPLACEMENTLIST/" 8 5
-.Ip "y/SEARCHLIST/REPLACEMENTLIST/" 8
+.Ip "tr/SEARCHLIST/REPLACEMENTLIST/cds" 8 5
+.Ip "y/SEARCHLIST/REPLACEMENTLIST/cds" 8
Translates all occurrences of the characters found in the search list with
the corresponding character in the replacement list.
-It returns the number of characters replaced.
+It returns the number of characters replaced or deleted.
If no string is specified via the =~ or !~ operator,
the $_ string is translated.
(The string specified with =~ must be a scalar variable, an array element,
@@ -1185,16 +1189,40 @@ devotees,
.I y
is provided as a synonym for
.IR tr .
+.Sp
+If the c modifier is specified, the SEARCHLIST character set is complemented.
+If the d modifier is specified, any characters specified by SEARCHLIST that
+are not found in REPLACEMENTLIST are deleted.
+(Note that this is slightly more flexible than the behavior of some
+.I tr
+programs, which delete anything they find in the SEARCHLIST, period.)
+If the s modifier is specified, sequences of characters that were translated
+to the same character are squashed down to 1 instance of the character.
+.Sp
+If the d modifier was used, the REPLACEMENTLIST is always interpreted exactly
+as specified.
+Otherwise, if the REPLACEMENTLIST is shorter than the SEARCHLIST,
+the final character is replicated till it is long enough.
+If the REPLACEMENTLIST is null, the SEARCHLIST is replicated.
+This latter is useful for counting characters in a class, or for squashing
+character sequences in a class.
+.Sp
Examples:
.nf
$ARGV[1] \|=~ \|y/A\-Z/a\-z/; \h'|3i'# canonicalize to lower case
$cnt = tr/*/*/; \h'|3i'# count the stars in $_
+ $cnt = tr/0\-9//; \h'|3i'# count the digits in $_
+
+ tr/a\-zA\-Z//s; \h'|3i'# bookkeeper \-> bokeper
+
($HOST = $host) =~ tr/a\-z/A\-Z/;
- y/\e001\-@[\-_{\-\e177/ /; \h'|3i'# change non-alphas to space
+ y/a\-zA\-Z/ /cs; \h'|3i'# change non-alphas to single space
+
+ tr/\e200\-\e377/\e0\-\e177/;\h'|3i'# delete 8th bit
.fi
.Ip "truncate(FILEHANDLE,LENGTH)" 8 4
View
17 perl.man.4
@@ -1,7 +1,10 @@
''' Beginning of part 4
-''' $Header: perl_man.4,v 3.0.1.12 90/10/20 02:15:43 lwall Locked $
+''' $Header: perl_man.4,v 3.0.1.13 90/11/10 01:51:00 lwall Locked $
'''
''' $Log: perl.man.4,v $
+''' Revision 3.0.1.13 90/11/10 01:51:00 lwall
+''' patch38: random cleanup
+'''
''' Revision 3.0.1.12 90/10/20 02:15:43 lwall
''' patch37: patch37: fixed various typos in man page
'''
@@ -60,7 +63,7 @@ left\h'|1i'||
left\h'|1i'&&
left\h'|1i'| ^
left\h'|1i'&
-nonassoc\h'|1i'== != eq ne
+nonassoc\h'|1i'== != <=> eq ne cmp
nonassoc\h'|1i'< > <= >= lt gt le ge
nonassoc\h'|1i'chdir exit eval reset sleep rand umask
nonassoc\h'|1i'\-r \-w \-x etc.
@@ -223,7 +226,7 @@ time of the call is visible to subroutine instead.
do foo(); # pass a null list
&foo(); # the same
- &foo; # pass no arguments--more efficient
+ &foo; # pass no arguments\*(--more efficient
.fi
.Sh "Passing By Reference"
@@ -774,6 +777,8 @@ Pattern matches on strings containing multiple newlines can produce confusing
results when $* is 0.
Default is 0.
(Mnemonic: * matches multiple things.)
+Note that this variable only influences the interpretation of ^ and $.
+A literal newline can be searched for even when $* == 0.
.Ip $0 8
Contains the name of the file containing the
.I perl
@@ -827,7 +832,7 @@ it really means
But don't put
- @foo{$a,$b,$c} # a slice--note the @
+ @foo{$a,$b,$c} # a slice\*(--note the @
which means
@@ -1088,6 +1093,10 @@ omit parentheses in many places doesn't mean that you ought to:
.fi
When in doubt, parenthesize.
At the very least it will let some poor schmuck bounce on the % key in vi.
+.Sp
+Even if you aren't in doubt, consider the mental welfare of the person who
+has to maintain the code after you, and who will probably put parens in
+the wrong place.
.Ip 2. 4 4
Don't go through silly contortions to exit a loop at the top or the
bottom, when
View
55 perly.c
@@ -1,11 +1,17 @@
-char rcsid[] = "$Header: perly.c,v 3.0.1.8 90/10/16 10:14:20 lwall Locked $\nPatch level: ###\n";
+char rcsid[] = "$Header: perly.c,v 3.0.1.9 90/11/10 01:53:26 lwall Locked $\nPatch level: ###\n";
/*
* Copyright (c) 1989, Larry Wall
*
* You may distribute under the terms of the GNU General Public License
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: perly.c,v $
+ * Revision 3.0.1.9 90/11/10 01:53:26 lwall
+ * patch38: random cleanup
+ * patch38: more msdos/os2 upgrades
+ * patch38: references to $0 produced core dumps
+ * patch38: added hooks for unexec()
+ *
* Revision 3.0.1.8 90/10/16 10:14:20 lwall
* patch29: *foo now prints as *package'foo
* patch29: added waitpid
@@ -245,7 +251,15 @@ setuid perl scripts securely.\n");
/* open script */
if (argv[0] == Nullch)
+#ifdef MSDOS
+ {
+ if ( isatty(fileno(stdin)) )
+ moreswitches("v");
+ argv[0] = "-";
+ }
+#else
argv[0] = "-";
+#endif
if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
char *xfound = Nullch, *xfailed = Nullch;
int len;
@@ -316,7 +330,13 @@ setuid perl scripts securely.\n");
#endif
(doextract ? "-e '1,/^#/d\n'" : ""),
argv[0], CPPSTDIN, str_get(str), CPPMINUS);
- doextract = FALSE;
+#ifdef DEBUGGING
+ if (debug & 64) {
+ fputs(buf,stderr);
+ fputs("\n",stderr);
+ }
+#endif
+ doextract = FALSE;
#ifdef IAMSUID /* actually, this is caught earlier */
if (euid != uid && !euid) /* if running suidperl */
#ifdef SETEUID
@@ -639,7 +659,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
(void)hadd(sigstab);
}
- magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':\024");
+ magicalize("!#?^~=-%123456789.+&*()<>,\\/[|`':\024");
userinit(); /* in case linked C routines want magical variables */
amperstab = stabent("&",allstabs);
@@ -693,7 +713,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
statname = Str_new(66,0); /* last filename we did stat on */
if (do_undump)
- abort();
+ my_unexec();
just_doit: /* come here if running an undumped a.out */
argc--,argv++; /* skip name of script */
@@ -710,7 +730,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
tainted = 1;
#endif
if (tmpstab = stabent("0",allstabs))
- str_set(STAB_STR(tmpstab),origfilename);
+ str_set(stab_val(tmpstab),origfilename);
if (argvstab = stabent("ARGV",allstabs)) {
argvstab->str_pok |= SP_MULTI;
(void)aadd(argvstab);
@@ -1096,3 +1116,28 @@ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
}
return Nullch;
}
+
+/* compliments of Tom Christiansen */
+
+/* unexec() can be found in the Gnu emacs distribution */
+
+my_unexec()
+{
+#ifdef UNEXEC
+ int status;
+ extern int etext;
+ static char dumpname[BUFSIZ];
+ static char perlpath[256];
+
+ sprintf (dumpname, "%s.perldump", origfilename);
+ sprintf (perlpath, "%s/perl", BIN);
+
+ status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
+ if (status)
+ fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
+ exit(status);
+#else
+ abort(); /* for use with undump */
+#endif
+}
+
View
45 regcomp.c
@@ -7,9 +7,13 @@
* blame Henry for some of the lack of readability.
*/
-/* $Header: regcomp.c,v 3.0.1.7 90/10/20 02:18:32 lwall Locked $
+/* $Header: regcomp.c,v 3.0.1.8 90/11/10 01:57:46 lwall Locked $
*
* $Log: regcomp.c,v $
+ * Revision 3.0.1.8 90/11/10 01:57:46 lwall
+ * patch38: patterns with multiple constant strings occasionally malfed
+ * patch38: patterns like /foo.*foo/ sped up some
+ *
* Revision 3.0.1.7 90/10/20 02:18:32 lwall
* patch37: /foo.*bar$/ wrongly optimized to do tail matching on "foo"
*
@@ -149,7 +153,8 @@ int fold;
register int len;
register char *first;
int flags;
- int back;
+ int backish;
+ int backest;
int curback;
extern char *safemalloc();
extern char *savestr();
@@ -252,7 +257,8 @@ int fold;
longest = str_make("",0);
len = 0;
curback = 0;
- back = 0;
+ backish = 0;
+ backest = 0;
while (OP(scan) != END) {
if (OP(scan) == BRANCH) {
if (OP(regnext(scan)) == BRANCH) {
@@ -267,7 +273,7 @@ int fold;
first = scan;
while (OP(regnext(scan)) >= CLOSE)
scan = regnext(scan);
- if (curback - back == len) {
+ if (curback - backish == len) {
str_ncat(longish, OPERAND(first)+1,
*OPERAND(first));
len += *OPERAND(first);
@@ -277,7 +283,7 @@ int fold;
else if (*OPERAND(first) >= len + (curback >= 0)) {
len = *OPERAND(first);
str_nset(longish, OPERAND(first)+1,len);
- back = curback;
+ backish = curback;
curback += len;
first = regnext(scan);
}
@@ -287,31 +293,46 @@ int fold;
else if (index(varies,OP(scan))) {
curback = -30000;
len = 0;
- if (longish->str_cur > longest->str_cur)
+ if (longish->str_cur > longest->str_cur) {
str_sset(longest,longish);
+ backest = backish;
+ }
str_nset(longish,"",0);
}
else if (index(simple,OP(scan))) {
curback++;
len = 0;
- if (longish->str_cur > longest->str_cur)
+ if (longish->str_cur > longest->str_cur) {
str_sset(longest,longish);
+ backest = backish;
+ }
str_nset(longish,"",0);
}
scan = regnext(scan);
}
/* Prefer earlier on tie, unless we can tail match latter */
- if (longish->str_cur + (OP(first) == EOL) > longest->str_cur)
+ if (longish->str_cur + (OP(first) == EOL) > longest->str_cur) {
str_sset(longest,longish);
+ backest = backish;
+ }
else
str_nset(longish,"",0);
- if (longest->str_cur) {
+ if (longest->str_cur
+ &&
+ (!r->regstart
+ ||
+ !fbminstr(r->regstart->str_ptr,
+ r->regstart->str_ptr + r->regstart->str_cur,
+ longest)
+ )
+ )
+ {
r->regmust = longest;
- if (back < 0)
- back = -1;
- r->regback = back;
+ if (backest < 0)
+ backest = -1;
+ r->regback = backest;
if (longest->str_cur
> !(sawstudy || fold || OP(first) == EOL) )
fbmcompile(r->regmust,fold);
View
7 regcomp.h
@@ -1,6 +1,9 @@
-/* $Header: regcomp.h,v 3.0.1.1 90/08/09 05:06:49 lwall Locked $
+/* $Header: regcomp.h,v 3.0.1.2 90/11/10 01:58:28 lwall Locked $
*
* $Log: regcomp.h,v $
+ * Revision 3.0.1.2 90/11/10 01:58:28 lwall
+ * patch38: random cleanup
+ *
* Revision 3.0.1.1 90/08/09 05:06:49 lwall
* patch19: sped up {m,n} on simple items
*
@@ -139,9 +142,11 @@ EXT char regdummy;
#ifndef gould
#ifndef cray
+#ifndef eta10
#define REGALIGN
#endif
#endif
+#endif
#define OP(p) (*(p))
View
13 regexec.c
@@ -7,9 +7,13 @@
* blame Henry for some of the lack of readability.
*/
-/* $Header: regexec.c,v 3.0.1.5 90/10/16 10:25:36 lwall Locked $
+/* $Header: regexec.c,v 3.0.1.6 90/11/10 02:00:57 lwall Locked $
*
* $Log: regexec.c,v $
+ * Revision 3.0.1.6 90/11/10 02:00:57 lwall
+ * patch38: patterns like /^foo.*bar/ sped up some
+ * patch38: /[^whatever]+/ could scan past end of string
+ *
* Revision 3.0.1.5 90/10/16 10:25:36 lwall
* patch29: /^pat/ occasionally matched in middle of string when $* = 0
* patch29: /.{n,m}$/ could match with fewer than n characters remaining
@@ -169,7 +173,8 @@ int safebase; /* no need to remember string in subbase */
/* If there is a "must appear" string, look for it. */
s = string;
- if (prog->regmust != Nullstr) {
+ 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);
@@ -590,9 +595,9 @@ char *prog;
nextchar = UCHARAT(locinput);
if (s[nextchar >> 3] & (1 << (nextchar&7)))
return(0);
- nextchar = *++locinput;
- if (!nextchar && locinput > regeol)
+ if (!nextchar && locinput >= regeol)
return 0;
+ nextchar = *++locinput;
break;
case ALNUM:
if (!nextchar)
View
10 stab.c
@@ -1,11 +1,14 @@
-/* $Header: stab.c,v 3.0.1.9 90/10/16 10:32:05 lwall Locked $
+/* $Header: stab.c,v 3.0.1.10 90/11/10 02:02:05 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: stab.c,v $
+ * Revision 3.0.1.10 90/11/10 02:02:05 lwall
+ * patch38: random cleanup
+ *
* Revision 3.0.1.9 90/10/16 10:32:05 lwall
* patch29: added -M, -A and -C
* patch29: taintperl now checks for world writable PATH components
@@ -71,6 +74,8 @@ static char *sig_name[] = {
#define handlertype int
#endif
+static handlertype sighandler();
+
STR *
stab_str(str)
STR *str;
@@ -244,7 +249,6 @@ STR *str;
STAB *stab = mstr->str_u.str_stab;
char *s;
int i;
- static handlertype sighandler();
switch (mstr->str_rare) {
case 'E':
@@ -295,7 +299,7 @@ STR *str;
CMD *cmd;
i = str_true(str);
- str = afetch(stab_xarray(stab),atoi(mstr->str_ptr));
+ str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
cmd = str->str_magic->str_u.str_cmd;
cmd->c_flags &= ~CF_OPTIMIZE;
cmd->c_flags |= i? CFT_D1 : CFT_D0;
View
89 str.c
@@ -1,11 +1,16 @@
-/* $Header: str.c,v 3.0.1.9 90/10/16 10:41:21 lwall Locked $
+/* $Header: str.c,v 3.0.1.10 90/11/10 02:06:29 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: str.c,v $
+ * Revision 3.0.1.10 90/11/10 02:06:29 lwall
+ * patch38: temp string values are now copied less often
+ * patch38: array slurps are now faster and take less memory
+ * patch38: fixed a memory leakage on local(*foo)
+ *
* Revision 3.0.1.9 90/10/16 10:41:21 lwall
* patch29: the undefined value could get defined by devious means
* patch29: undefined values compared inconsistently
@@ -232,6 +237,11 @@ register STR *str;
return str->str_u.str_nval;
}
+/* Note: str_sset() should not be called with a source string that needs
+ * be reused, since it may destroy the source string if it is marked
+ * as temporary.
+ */
+
str_sset(dstr,sstr)
STR *dstr;
register STR *sstr;
@@ -245,19 +255,38 @@ register STR *sstr;
if (!sstr)
dstr->str_pok = dstr->str_nok = 0;
else if (sstr->str_pok) {
- str_nset(dstr,sstr->str_ptr,sstr->str_cur);
- if (sstr->str_nok) {
- dstr->str_u.str_nval = sstr->str_u.str_nval;
- dstr->str_nok = 1;
- dstr->str_state = SS_NORM;
+
+ /*
+ * Check to see if we can just swipe the string. If so, it's a
+ * possible small lose on short strings, but a big win on long ones.
+ */
+
+ if (sstr->str_pok & SP_TEMP) { /* slated for free anyway? */
+ if (dstr->str_ptr)
+ Safefree(dstr->str_ptr);
+#ifdef STRUCTCOPY
+ *dstr = *sstr;
+#else
+ Copy(sstr, dstr, 1, STR);
+#endif
+ Zero(sstr, 1, STR); /* (probably overkill) */
+ dstr->str_pok &= ~SP_TEMP;
}
- else if (sstr->str_cur == sizeof(STBP)) {
- char *tmps = sstr->str_ptr;
+ else { /* have to copy piecemeal */
+ str_nset(dstr,sstr->str_ptr,sstr->str_cur);
+ if (sstr->str_nok) {
+ dstr->str_u.str_nval = sstr->str_u.str_nval;
+ dstr->str_nok = 1;
+ dstr->str_state = SS_NORM;
+ }
+ else if (sstr->str_cur == sizeof(STBP)) {
+ char *tmps = sstr->str_ptr;
- if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) {
- if (!dstr->str_magic) {
- dstr->str_magic = str_smake(sstr->str_magic);
- dstr->str_magic->str_rare = 'X';
+ if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) {
+ if (!dstr->str_magic) {
+ dstr->str_magic = str_smake(sstr->str_magic);
+ dstr->str_magic->str_rare = 'X';
+ }
}
}
}
@@ -590,6 +619,8 @@ register STR *nstr;
#ifdef TAINT
str->str_tainted = nstr->str_tainted;
#endif
+ if (nstr->str_magic)
+ str_free(nstr->str_magic);
Safefree(nstr);
}
@@ -718,6 +749,7 @@ int append;
STRLEN obpx;
register int get_paragraph;
register char *oldbp;
+ int shortbuffered;
if (str == &str_undef)
return Nullch;
@@ -729,8 +761,18 @@ int append;
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 */
- STR_GROW(str, append+cnt+2); /* (remembering cnt can be -1) */
+ if (str->str_len <= cnt + 1) { /* make sure we have the room */
+ if (cnt > 80 && str->str_len > 0) {
+ shortbuffered = cnt - str->str_len;
+ cnt = str->str_len;
+ }
+ else {
+ shortbuffered = 0;
+ STR_GROW(str, append+cnt+2);/* (remembering cnt can be -1) */
+ }
+ }
+ else
+ shortbuffered = 0;
bp = str->str_ptr + append; /* move these two too to registers */
ptr = fp->_ptr;
for (;;) {
@@ -740,6 +782,19 @@ int append;
goto thats_all_folks; /* screams */ /* sed :-) */
}
+ if (shortbuffered) { /* oh well, must extend */
+ cnt = shortbuffered;
+ shortbuffered = 0;
+ if (get_paragraph && oldbp)
+ obpx = oldbp - str->str_ptr;
+ bpx = bp - str->str_ptr; /* prepare for possible relocation */
+ STR_GROW(str, str->str_len + append + cnt + 2);
+ bp = str->str_ptr + bpx; /* reconstitute our pointer */
+ if (get_paragraph && oldbp)
+ oldbp = str->str_ptr + obpx;
+ continue;
+ }
+
fp->_cnt = cnt; /* deregisterize cnt and ptr */
fp->_ptr = ptr;
i = _filbuf(fp); /* get more characters */
@@ -770,6 +825,8 @@ int append;
goto screamer; /* and go back to the fray */
}
thats_really_all_folks:
+ if (shortbuffered)
+ cnt += shortbuffered;
fp->_cnt = cnt; /* put these back or we're in trouble */
fp->_ptr = ptr;
*bp = '\0';
@@ -1230,6 +1287,8 @@ STR *oldstr;
}
}
tmps_list[tmps_max] = str;
+ if (str->str_pok)
+ str->str_pok |= SP_TEMP;
return str;
}
@@ -1251,6 +1310,8 @@ register STR *str;
}
}
tmps_list[tmps_max] = str;
+ if (str->str_pok)
+ str->str_pok |= SP_TEMP;
return str;
}
View
6 str.h
@@ -1,11 +1,14 @@
-/* $Header: str.h,v 3.0.1.3 90/10/16 10:44:04 lwall Locked $
+/* $Header: str.h,v 3.0.1.4 90/11/10 02:07:52 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: str.h,v $
+ * Revision 3.0.1.4 90/11/10 02:07:52 lwall
+ * patch38: temp string values are now copied less often
+ *
* Revision 3.0.1.3 90/10/16 10:44:04 lwall
* patch29: added caller
* patch29: scripts now run at almost full speed under the debugger
@@ -87,6 +90,7 @@ struct lstring {
#define SP_INTRP 16 /* string was compiled for interping */
#define SP_TAIL 32 /* fbm string is tail anchored: /foo$/ */
#define SP_MULTI 64 /* symbol table entry probably isn't a typo */
+#define SP_TEMP 128 /* string slated to die, so can be plundered */
#define Nullstr Null(STR*)
View
10 toke.c
@@ -1,11 +1,15 @@
-/* $Header: toke.c,v 3.0.1.10 90/10/16 11:20:46 lwall Locked $
+/* $Header: toke.c,v 3.0.1.11 90/11/10 02:13:44 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: toke.c,v $
+ * Revision 3.0.1.11 90/11/10 02:13:44 lwall
+ * patch38: added alarm function
+ * patch38: tr was busted in metacharacters on signed char machines
+ *
* Revision 3.0.1.10 90/10/16 11:20:46 lwall
* patch29: the length of a search pattern was limited
* patch29: added DATA filehandle to read stuff after __END__
@@ -680,6 +684,8 @@ yylex()
break;
case 'a': case 'A':
SNARFWORD;
+ if (strEQ(d,"alarm"))
+ UNI(O_ALARM);
if (strEQ(d,"accept"))
FOP22(O_ACCEPT);
if (strEQ(d,"atan2"))
@@ -1923,7 +1929,7 @@ register char *s;
--j;
}
if (tbl[t[i] & 0377] == -1)
- tbl[t[i] & 0377] = r[j];
+ tbl[t[i] & 0377] = r[j] & 0377;
}
}
if (r != t)
View
27 util.c
@@ -1,11 +1,15 @@
-/* $Header: util.c,v 3.0.1.9 90/10/20 02:21:01 lwall Locked $
+/* $Header: util.c,v 3.0.1.10 90/11/10 02:19:28 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: util.c,v $
+ * Revision 3.0.1.10 90/11/10 02:19:28 lwall
+ * patch38: random cleanup
+ * patch38: sequence of s/^x//; s/x$//; could screw up malloc
+ *
* Revision 3.0.1.9 90/10/20 02:21:01 lwall
* patch37: tried to take strlen of integer on systems without wait4 or waitpid
* patch37: unreachable return eliminated
@@ -97,6 +101,10 @@ MEM_SIZE size;
exit(1);
}
#endif /* MSDOS */
+#ifdef DEBUGGING
+ if ((long)size < 0)
+ fatal("panic: malloc");
+#endif
ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
#ifdef DEBUGGING
# ifndef I286
@@ -110,7 +118,7 @@ MEM_SIZE size;
if (ptr != Nullch)
return ptr;
else {
- fputs(nomem,stdout) FLUSH;
+ fputs(nomem,stderr) FLUSH;
exit(1);
}
/*NOTREACHED*/
@@ -141,6 +149,10 @@ unsigned long size;
#endif /* MSDOS */
if (!where)
fatal("Null realloc");
+#ifdef DEBUGGING
+ if ((long)size < 0)
+ fatal("panic: realloc");
+#endif
ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
#ifdef DEBUGGING
# ifndef I286
@@ -158,7 +170,7 @@ unsigned long size;
if (ptr != Nullch)
return ptr;
else {
- fputs(nomem,stdout) FLUSH;
+ fputs(nomem,stderr) FLUSH;
exit(1);
}
/*NOTREACHED*/
@@ -551,7 +563,8 @@ STR *littlestr;
s = bigend - littlelen;
if (*s == *little && bcmp(s,little,littlelen)==0)
return (char*)s; /* how sweet it is */
- else if (bigend[-1] == '\n' && little[littlelen-1] != '\n') {
+ else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
+ && s > big) {
s--;
if (*s == *little && bcmp(s,little,littlelen)==0)
return (char*)s;
@@ -1368,7 +1381,6 @@ int flags;
if (flags)
fatal("Can't do waitpid with flags");
else {
- int result;
register int count;
register STR *str;
@@ -1446,6 +1458,11 @@ double f;
{
long along;
+#ifdef mips
+# define BIGDOUBLE 2147483648.0
+ if (f >= BIGDOUBLE)
+ return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
+#endif
if (f >= 0.0)
return (unsigned long)f;
along = (long)f;

0 comments on commit 34de22d

Please sign in to comment.
Something went wrong with that request. Please try again.