diff options
| -rw-r--r-- | eg/who | 6 | ||||
| -rw-r--r-- | lib/perldb.pl | 9 | ||||
| -rw-r--r-- | lib/syslog.pl | 11 | ||||
| -rw-r--r-- | os2/perldb.dif | 52 | ||||
| -rw-r--r-- | os2/perlglob.cs | 4 | ||||
| -rw-r--r-- | os2/perlglob.def | 1 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.man.3 | 52 | ||||
| -rw-r--r-- | perl.man.4 | 17 | ||||
| -rw-r--r-- | perly.c | 55 | ||||
| -rw-r--r-- | regcomp.c | 45 | ||||
| -rw-r--r-- | regcomp.h | 7 | ||||
| -rw-r--r-- | regexec.c | 13 | ||||
| -rw-r--r-- | stab.c | 10 | ||||
| -rw-r--r-- | str.c | 89 | ||||
| -rw-r--r-- | str.h | 6 | ||||
| -rw-r--r-- | toke.c | 10 | ||||
| -rw-r--r-- | util.c | 27 |
18 files changed, 339 insertions, 77 deletions
@@ -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; diff --git a/lib/perldb.pl b/lib/perldb.pl index cff7cb381a..c86fb16506 100644 --- a/lib/perldb.pl +++ b/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 @@ $header = '$Header: perldb.pl,v 3.0.1.4 90/10/15 17:40:38 lwall Locked $'; # 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 @@ command Execute as a perl statement in current package. 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 { diff --git a/lib/syslog.pl b/lib/syslog.pl index 1d7becf66a..fe9b183be3 100644 --- a/lib/syslog.pl +++ b/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); diff --git a/os2/perldb.dif b/os2/perldb.dif new file mode 100644 index 0000000000..a1716821e3 --- /dev/null +++ b/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; diff --git a/os2/perlglob.cs b/os2/perlglob.cs index ca3967e847..5f6758acfa 100644 --- a/os2/perlglob.cs +++ b/os2/perlglob.cs @@ -1,7 +1,7 @@ -glob.c +msdos\glob.c setargv.obj -perlglob.def +os2\perlglob.def perlglob.exe -AS -LB -S0x1000 diff --git a/os2/perlglob.def b/os2/perlglob.def index cfa07392ff..52bddd1b00 100644 --- a/os2/perlglob.def +++ b/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' diff --git a/patchlevel.h b/patchlevel.h index 314cba1648..8763a9e18d 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 39 +#define PATCHLEVEL 40 diff --git a/perl.man.3 b/perl.man.3 index 80b2ad3c85..be1cc72e2b 100644 --- a/perl.man.3 +++ b/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,7 +1166,7 @@ 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 @@ -1170,11 +1174,11 @@ 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,6 +1189,24 @@ 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 @@ -1192,9 +1214,15 @@ Examples: $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 diff --git a/perl.man.4 b/perl.man.4 index 6a0ef6c971..7100e80a22 100644 --- a/perl.man.4 +++ b/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 @@ -1,4 +1,4 @@ -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 * @@ -6,6 +6,12 @@ char rcsid[] = "$Header: perly.c,v 3.0.1.8 90/10/16 10:14:20 lwall Locked $\nPat * 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 +} + @@ -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,15 +293,19 @@ 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); @@ -303,15 +313,26 @@ int fold; /* 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); @@ -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)) @@ -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) @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,9 @@ * 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; @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,11 @@ * 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 @@ thats_all_folks: 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; } @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,9 @@ * 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*) @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,10 @@ * 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) @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,10 @@ * 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; |