Newsgroups: comp.sources.misc From: lwall@netlabs.com (Larry Wall) Subject: v25i068: perl - The perl programming language, Patch19 Message-ID: <1991Nov13.214841.4272@sparky.imd.sterling.com> X-Md4-Signature: 7020affa705e9d173a8d35be360fc0b5 Date: Wed, 13 Nov 1991 21:48:41 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: lwall@netlabs.com (Larry Wall) Posting-number: Volume 25, Issue 68 Archive-name: perl/patch19 Environment: UNIX, MS-DOS, OS2 Patch-To: perl: Volume 18, Issue 19-54 System: perl version 4.0 Patch #: 19 Priority: HIGH Ok, here's the cleanup patch I suggested you wait for. Have at it... Subject: added little-endian pack/unpack options This is the only enhancement in this patch, but it seemed unlikely to bust anything else, and added functionality that it was very difficult to do any other way. Compliments of David W. Sanderson. Subject: op/regexp.t failed from missing arg to bcmp() Subject: study was busted by 4.018 Subject: sort $subname was busted by changes in 4.018 Subject: default arg for shift was wrong after first subroutine definition Things that broke in 4.018. Shame on me. Subject: do {$foo ne "bar";} returned wrong value A bug of long standing. How come nobody saw this one? Or if you did, why didn't you report it before now? Or if you did, why did I ignore you? :-) Subject: some machines need -lsocket before -lnsl Subject: some earlier patches weren't propagated to alternate 286 code Subject: compile in the x2p directory couldn't find cppstdin Subject: more hints for aix, isc, hp, sco, uts Subject: installperl no longer updates unchanged library files Subject: uts wrongly defines S_ISDIR() et al Subject: too many preprocessors can't expand a macro right in #if The usual pastiche of portability kludges. Subject: deleted some unused functions from usersub.c And fixed the spelling of John Macdonald's name, and included his suggested workaround for a certain vendor's stdio bug... Subject: added readdir test Subject: made op/groups.t more reliable Subject: added test for sort $subname to op/sort.t Subject: added some hacks to op/stat.t for weird filesystem architectures Improvements (hopefully) to the regression tests. Fix: From rn, say "| patch -p -N -d DIR", where DIR is your perl source directory. Outside of rn, say "cd DIR; patch -p -N #define PATCHLEVEL 19 Index: Configure Prereq: 4.0.1.5 *** Configure.old Mon Nov 11 16:49:01 1991 --- Configure Mon Nov 11 16:49:03 1991 *************** *** 8,14 **** # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # ! # $RCSfile: Configure,v $$Revision: 4.0.1.5 $$Date: 91/11/05 23:11:32 $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than --- 8,14 ---- # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # ! # $RCSfile: Configure,v $$Revision: 4.0.1.6 $$Date: 91/11/11 16:26:51 $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than *************** *** 354,360 **** d_ndir=ndir voidwant=1 voidwant=7 ! libswanted="c_s net_s net nsl_s nsl socket nm ndir ndbm dbm PW malloc sun m bsd BSD x posix ucb" inclwanted='/usr/include /usr/netinclude /usr/include/sun /usr/include/bsd /usr/include/lan /usr/ucbinclude' : Now test for existence of everything in MANIFEST --- 354,360 ---- d_ndir=ndir voidwant=1 voidwant=7 ! libswanted="c_s net_s net socket nsl_s nsl nm ndir ndbm dbm PW malloc sun m bsd BSD x posix ucb" inclwanted='/usr/include /usr/netinclude /usr/include/sun /usr/include/bsd /usr/include/lan /usr/ucbinclude' : Now test for existence of everything in MANIFEST *************** *** 596,602 **** --- 596,604 ---- cpp csh egrep + line nroff + perl test uname yacc *************** *** 2292,2298 **** : index or strcpy echo " " case "$d_index" in ! n) dflt=n;; *) if $test -f /unix; then dflt=n else --- 2294,2300 ---- : index or strcpy echo " " case "$d_index" in ! undef) dflt=n;; *) if $test -f /unix; then dflt=n else *************** *** 2377,2382 **** --- 2379,2444 ---- set d_msg eval $setvar + : determine which malloc to compile in + echo " " + case "$d_mymalloc" in + '') + case "$usemymalloc" in + '') + if bsd || v7; then + dflt='y' + else + dflt='n' + fi + ;; + n*) dflt=n;; + *) dflt=y;; + esac + ;; + define) dflt="y" + ;; + *) dflt="n" + ;; + esac + rp="Do you wish to attempt to use the malloc that comes with $package? [$dflt]" + $echo $n "$rp $c" + . myread + case "$ans" in + '') ans=$dflt;; + esac + case "$ans" in + y*) mallocsrc='malloc.c'; mallocobj='malloc.o' + libs=`echo $libs | sed 's/-lmalloc//'` + val="$define" + case "$mallocptrtype" in + '') + cat >usemymalloc.c <<'END' + #ifdef __STDC__ + #include + #else + #include + #endif + void *malloc(); + END + if $cc $ccflags -c usemymalloc.c >/dev/null 2>&1; then + mallocptrtype=void + else + mallocptrtype=char + fi + ;; + esac + echo " " + echo "Your system wants malloc to return $mallocptrtype*, it would seem." + ;; + *) mallocsrc=''; + mallocobj=''; + mallocptrtype=void + val="$define" + ;; + esac + set d_mymalloc + eval $setvar + : see if ndbm is available echo " " xxx=`./loc ndbm.h x $usrinclude /usr/local/include $inclwanted` *************** *** 3052,3117 **** $echo $n "$rp $c" . myread intsize="$ans" - - : determine which malloc to compile in - echo " " - case "$d_mymalloc" in - '') - case "$usemymalloc" in - '') - if bsd || v7; then - dflt='y' - else - dflt='n' - fi - ;; - n*) dflt=n;; - *) dflt=y;; - esac - ;; - define) dflt="y" - ;; - *) dflt="n" - ;; - esac - rp="Do you wish to attempt to use the malloc that comes with $package? [$dflt]" - $echo $n "$rp $c" - . myread - case "$ans" in - '') ans=$dflt;; - esac - case "$ans" in - y*) mallocsrc='malloc.c'; mallocobj='malloc.o' - libs=`echo $libs | sed 's/-lmalloc//'` - val="$define" - case "$mallocptrtype" in - '') - cat >usemymalloc.c <<'END' - #ifdef __STDC__ - #include - #else - #include - #endif - void *malloc(); - END - if $cc $ccflags -c usemymalloc.c >/dev/null 2>&1; then - mallocptrtype=void - else - mallocptrtype=char - fi - ;; - esac - echo " " - echo "Your system wants malloc to return $mallocptrtype*, it would seem." - ;; - *) mallocsrc=''; - mallocobj=''; - mallocptrtype=void - val="$define" - ;; - esac - set d_mymalloc - eval $setvar : determine where private executables go case "$privlib" in --- 3114,3119 ---- Index: MANIFEST *** MANIFEST.old Mon Nov 11 16:49:07 1991 --- MANIFEST Mon Nov 11 16:49:07 1991 *************** *** 109,114 **** --- 109,115 ---- hints/hp9000_800.sh hints/hpux.sh hints/i386.sh + hints/isc_3_2_2.sh hints/mips.sh hints/mpc.sh hints/ncr_tower.sh *************** *** 287,292 **** --- 288,294 ---- t/op/range.t See if .. works t/op/re_tests Input file for op.regexp t/op/read.t See if read() works + t/op/readdir.t See if readdir() works t/op/regexp.t See if regular expressions work t/op/repeat.t See if x operator works t/op/s.t See if substitutions work Index: hints/aix_rs.sh *** hints/aix_rs.sh.old Mon Nov 11 16:49:25 1991 --- hints/aix_rs.sh Mon Nov 11 16:49:25 1991 *************** *** 1,5 **** ! eval_cflags='optimize="-g"' ! toke_cflags='optimize="-g"' ! teval_cflags='optimize="-g"' ! ttoke_cflags='optimize="-g"'; ccflags="$ccflags -D_NO_PROTO" --- 1,7 ---- ! eval_cflags='optimize=""' ! toke_cflags='optimize=""' ! teval_cflags='optimize=""' ! ttoke_cflags='optimize=""' ccflags="$ccflags -D_NO_PROTO" + cppstdin='/lib/cpp -D_AIX -D_IBMR2' + cppminus='' Index: cmd.c *** cmd.c.old Mon Nov 11 16:49:10 1991 --- cmd.c Mon Nov 11 16:49:10 1991 *************** *** 1,4 **** ! /* $RCSfile: cmd.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 16:07:43 $ * * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! /* $RCSfile: cmd.c,v $$Revision: 4.0.1.4 $$Date: 91/11/11 16:29:33 $ * * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * License or the Artistic License, as specified in the README file. * * $Log: cmd.c,v $ + * Revision 4.0.1.4 91/11/11 16:29:33 lwall + * patch19: do {$foo ne "bar";} returned wrong value + * patch19: some earlier patches weren't propagated to alternate 286 code + * * Revision 4.0.1.3 91/11/05 16:07:43 lwall * patch11: random cleanup * patch11: "foo\0" eq "foo" was sometimes optimized to true *************** *** 367,379 **** if (cmd->c_spat) lastspat = cmd->c_spat; match = !(cmdflags & CF_FIRSTNEG); ! retstr = &str_yes; goto flipmaybe; } } else if (cmdflags & CF_NESURE) { match = cmdflags & CF_FIRSTNEG; ! retstr = &str_no; goto flipmaybe; } #else --- 371,383 ---- if (cmd->c_spat) lastspat = cmd->c_spat; match = !(cmdflags & CF_FIRSTNEG); ! retstr = match ? &str_yes : &str_no; goto flipmaybe; } } else if (cmdflags & CF_NESURE) { match = cmdflags & CF_FIRSTNEG; ! retstr = match ? &str_yes : &str_no; goto flipmaybe; } #else *************** *** 380,385 **** --- 384,390 ---- { char *zap1, *zap2, zap1c, zap2c; int zaplen; + int lenok; zap1 = cmd->c_short->str_ptr; zap2 = str_get(retstr); *************** *** 386,392 **** zap1c = *zap1; zap2c = *zap2; zaplen = cmd->c_slen; ! if ((zap1c == zap2c) && (bcmp(zap1, zap2, zaplen) == 0)) { if (cmdflags & CF_EQSURE) { if (sawampersand && (cmdflags & CF_OPTIMIZE) != CFT_STROP) { --- 391,401 ---- zap1c = *zap1; zap2c = *zap2; zaplen = cmd->c_slen; ! if (match) ! lenok = (retstr->str_cur == cmd->c_slen - 1); ! else ! lenok = (retstr->str_cur >= cmd->c_slen); ! if ((zap1c == zap2c) && lenok && (bcmp(zap1, zap2, zaplen) == 0)) { if (cmdflags & CF_EQSURE) { if (sawampersand && (cmdflags & CF_OPTIMIZE) != CFT_STROP) { *************** *** 403,415 **** if (cmd->c_spat) lastspat = cmd->c_spat; match = !(cmdflags & CF_FIRSTNEG); ! retstr = &str_yes; goto flipmaybe; } } else if (cmdflags & CF_NESURE) { match = cmdflags & CF_FIRSTNEG; ! retstr = &str_no; goto flipmaybe; } } --- 412,424 ---- if (cmd->c_spat) lastspat = cmd->c_spat; match = !(cmdflags & CF_FIRSTNEG); ! retstr = match ? &str_yes : &str_no; goto flipmaybe; } } else if (cmdflags & CF_NESURE) { match = cmdflags & CF_FIRSTNEG; ! retstr = match ? &str_yes : &str_no; goto flipmaybe; } } *************** *** 451,457 **** } lastspat = cmd->c_spat; match = !(cmdflags & CF_FIRSTNEG); ! retstr = &str_yes; goto flipmaybe; } else --- 460,466 ---- } lastspat = cmd->c_spat; match = !(cmdflags & CF_FIRSTNEG); ! retstr = match ? &str_yes : &str_no; goto flipmaybe; } else *************** *** 461,467 **** if (cmdflags & CF_NESURE) { ++cmd->c_short->str_u.str_useful; match = cmdflags & CF_FIRSTNEG; ! retstr = &str_no; goto flipmaybe; } } --- 470,476 ---- if (cmdflags & CF_NESURE) { ++cmd->c_short->str_u.str_useful; match = cmdflags & CF_FIRSTNEG; ! retstr = match ? &str_yes : &str_no; goto flipmaybe; } } Index: doSH *** doSH.old Mon Nov 11 16:49:13 1991 --- doSH Mon Nov 11 16:49:13 1991 *************** *** 4,9 **** --- 4,10 ---- . ./config.sh rm -f x2p/config.sh + cp cppstdin x2p echo " " echo "Doing variable substitutions on .SH files..." Index: doarg.c *** doarg.c.old Mon Nov 11 16:49:16 1991 --- doarg.c Mon Nov 11 16:49:17 1991 *************** *** 1,4 **** ! /* $RCSfile: doarg.c,v $$Revision: 4.0.1.4 $$Date: 91/11/05 16:35:06 $ * * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! /* $RCSfile: doarg.c,v $$Revision: 4.0.1.5 $$Date: 91/11/11 16:31:58 $ * * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,14 ---- * License or the Artistic License, as specified in the README file. * * $Log: doarg.c,v $ + * Revision 4.0.1.5 91/11/11 16:31:58 lwall + * patch19: added little-endian pack/unpack options + * * Revision 4.0.1.4 91/11/05 16:35:06 lwall * patch11: /$foo/o optimizer could access deallocated data * patch11: minimum match length calculation in regexp is now cumulative *************** *** 661,666 **** --- 664,679 ---- str_ncat(str,(char*)&ashort,sizeof(short)); } break; + case 'v': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (short)str_gnum(fromstr); + #ifdef HAS_HTOVS + ashort = htovs(ashort); + #endif + str_ncat(str,(char*)&ashort,sizeof(short)); + } + break; case 'S': case 's': while (len-- > 0) { *************** *** 689,694 **** --- 702,717 ---- aulong = U_L(str_gnum(fromstr)); #ifdef HAS_HTONL aulong = htonl(aulong); + #endif + str_ncat(str,(char*)&aulong,sizeof(unsigned long)); + } + break; + case 'V': + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = U_L(str_gnum(fromstr)); + #ifdef HAS_HTOVL + aulong = htovl(aulong); #endif str_ncat(str,(char*)&aulong,sizeof(unsigned long)); } Index: dolist.c *** dolist.c.old Mon Nov 11 16:49:20 1991 --- dolist.c Mon Nov 11 16:49:21 1991 *************** *** 1,4 **** ! /* $RCSfile: dolist.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 17:07:02 $ * * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! /* $RCSfile: dolist.c,v $$Revision: 4.0.1.4 $$Date: 91/11/11 16:33:19 $ * * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * License or the Artistic License, as specified in the README file. * * $Log: dolist.c,v $ + * Revision 4.0.1.4 91/11/11 16:33:19 lwall + * patch19: added little-endian pack/unpack options + * patch19: sort $subname was busted by changes in 4.018 + * * Revision 4.0.1.3 91/11/05 17:07:02 lwall * patch11: prepared for ctype implementations that don't define isascii() * patch11: /$foo/o optimizer could access deallocated data *************** *** 786,791 **** --- 790,796 ---- } } break; + case 'v': case 'n': case 'S': along = (strend - s) / sizeof(unsigned short); *************** *** 799,804 **** --- 804,813 ---- if (datumtype == 'n') aushort = ntohs(aushort); #endif + #ifdef HAS_VTOHS + if (datumtype == 'v') + aushort = vtohs(aushort); + #endif culong += aushort; } } *************** *** 811,816 **** --- 820,829 ---- if (datumtype == 'n') aushort = ntohs(aushort); #endif + #ifdef HAS_VTOHS + if (datumtype == 'v') + aushort = vtohs(aushort); + #endif str_numset(str,(double)aushort); (void)astore(stack, ++sp, str_2mortal(str)); } *************** *** 888,893 **** --- 901,907 ---- } } break; + case 'V': case 'N': case 'L': along = (strend - s) / sizeof(unsigned long); *************** *** 901,906 **** --- 915,924 ---- if (datumtype == 'N') aulong = ntohl(aulong); #endif + #ifdef HAS_VTOHL + if (datumtype == 'V') + aulong = vtohl(aulong); + #endif if (checksum > 32) cdouble += (double)aulong; else *************** *** 916,921 **** --- 934,943 ---- if (datumtype == 'N') aulong = ntohl(aulong); #endif + #ifdef HAS_VTOHL + if (datumtype == 'V') + aulong = vtohl(aulong); + #endif str_numset(str,(double)aulong); (void)astore(stack, ++sp, str_2mortal(str)); } *************** *** 1480,1485 **** --- 1502,1508 ---- STR *oldsecond; ARRAY *oldstack; HASH *stash; + STR *sortsubvar; static ARRAY *sortstack = Null(ARRAY*); if (gimme != G_ARRAY) { *************** *** 1489,1494 **** --- 1512,1518 ---- return sp; } up = &st[sp]; + sortsubvar = *up; st += sp; /* temporarily make st point to args */ for (i = 1; i <= max; i++) { /*SUPPRESS 560*/ *************** *** 1514,1520 **** if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else ! stab = stabent(str_get(st[sp+1]),TRUE); if (stab) { if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd)) --- 1538,1544 ---- if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else ! stab = stabent(str_get(sortsubvar),TRUE); if (stab) { if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd)) Index: t/op/groups.t *** t/op/groups.t.old Mon Nov 11 16:49:59 1991 --- t/op/groups.t Mon Nov 11 16:49:59 1991 *************** *** 5,12 **** exit 0; } ! print "1..1\n"; for (split(' ', $()) { next if $seen{$_}++; ($group) = getgrgid($_); --- 5,18 ---- exit 0; } ! print "1..2\n"; + $pwgid = $( + 0; + ($pwgnam) = getgrgid($pwgid); + @basegroup{$pwgid,$pwgnam} = (1,1); + + $seen{$pwgid}++; + for (split(' ', $()) { next if $seen{$_}++; ($group) = getgrgid($_); *************** *** 17,24 **** push(@gr, $_); } } ! $gr1 = join(' ',sort @gr); ! $gr2 = join(' ', sort split(' ',`/usr/ucb/groups`)); ! #print "gr1 is <$gr1>\n"; ! #print "gr2 is <$gr2>\n"; ! print +($gr1 eq $gr2) ? "ok 1\n" : "not ok 1\n"; --- 23,47 ---- push(@gr, $_); } } ! ! $gr1 = join(' ', sort @gr); ! ! $gr2 = join(' ', grep(!$basegroup{$_}, sort split(' ',`/usr/ucb/groups`))); ! ! if ($gr1 eq $gr2) { ! print "ok 1\n"; ! } ! else { ! print "#gr1 is <$gr1>\n"; ! print "#gr2 is <$gr2>\n"; ! print "not ok 1\n"; ! } ! ! # multiple 0's indicate GROUPSTYPE is currently long but should be short ! ! if ($pwgid == 0 || $seen{0} < 2) { ! print "ok 2\n"; ! } ! else { ! print "not ok 2 (groupstype should be type short, not long)\n"; ! } Index: hints/hp9000_800.sh *** hints/hp9000_800.sh.old Mon Nov 11 16:49:27 1991 --- hints/hp9000_800.sh Mon Nov 11 16:49:27 1991 *************** *** 1 **** ! libswanted=`echo $libswanted | sed 's/malloc //'` --- 1,2 ---- ! libswanted=`echo $libswanted | sed -e 's/malloc //' -e 's/BSD //` ! optimize='+O1' Index: installperl *** installperl.old Mon Nov 11 16:49:34 1991 --- installperl Mon Nov 11 16:49:35 1991 *************** *** 136,143 **** if ($pdev != $ldev || $pino != $lino) { foreach $file (<*.pl>) { ! &unlink("$installprivlib/$file"); ! &cmd("cp $file $installprivlib"); } } chdir ".." || die "Can't cd back to source directory: $!\n"; --- 136,146 ---- if ($pdev != $ldev || $pino != $lino) { foreach $file (<*.pl>) { ! system "cmp", "-s", $file, "$privlib/$file"; ! if ($?) { ! &unlink("$installprivlib/$file"); ! &cmd("cp $file $installprivlib"); ! } } } chdir ".." || die "Can't cd back to source directory: $!\n"; Index: hints/isc_3_2_2.sh *** hints/isc_3_2_2.sh.old Mon Nov 11 16:49:29 1991 --- hints/isc_3_2_2.sh Mon Nov 11 16:49:29 1991 *************** *** 0 **** --- 1,7 ---- + set `echo $libswanted | sed -e 's/ x / /' -e 's/ PW / /' -e s/ malloc / /` + libswanted="inet malloc $*" + doio_cflags='ccflags="$ccflags -DENOTSOCK=103"' + tdoio_cflags='ccflags="$ccflags -DENOTSOCK=103"' + echo " defines error numbers for network calls, but" + echo "the definitions for ENAMETOOLONG and ENOTEMPTY conflict with" + echo "those in . Instead just define ENOTSOCK here." Index: perl.c *** perl.c.old Mon Nov 11 16:49:38 1991 --- perl.c Mon Nov 11 16:49:39 1991 *************** *** 1,4 **** ! char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.5 $$Date: 91/11/05 18:03:32 $\nPatch level: ###\n"; /* * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.6 $$Date: 91/11/11 16:38:45 $\nPatch level: ###\n"; /* * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * License or the Artistic License, as specified in the README file. * * $Log: perl.c,v $ + * Revision 4.0.1.6 91/11/11 16:38:45 lwall + * patch19: default arg for shift was wrong after first subroutine definition + * patch19: op/regexp.t failed from missing arg to bcmp() + * * Revision 4.0.1.5 91/11/05 18:03:32 lwall * patch11: random cleanup * patch11: $0 was being truncated at times *************** *** 634,639 **** --- 638,644 ---- defstab = stabent("_",TRUE); + subname = str_make("main",4); if (perldb) { debstash = hnew(0); stab_xhash(stabent("_DB",TRUE)) = debstash; *************** *** 641,647 **** dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE)))); tmpstab->str_pok |= SP_MULTI; dbargs->ary_flags = 0; - subname = str_make("main",4); DBstab = stabent("DB",TRUE); DBstab->str_pok |= SP_MULTI; DBline = stabent("dbline",TRUE); --- 646,651 ---- *************** *** 1030,1036 **** retval |= error_count; } else if (last_root && last_elen == bufend - bufptr ! && *bufptr == *last_eval && !bcmp(bufptr,last_eval)){ retval = 0; eval_root = last_root; /* no point in reparsing */ } --- 1034,1040 ---- retval |= error_count; } else if (last_root && last_elen == bufend - bufptr ! && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){ retval = 0; eval_root = last_root; /* no point in reparsing */ } Index: perl.h *** perl.h.old Mon Nov 11 16:49:42 1991 --- perl.h Mon Nov 11 16:49:42 1991 *************** *** 1,4 **** ! /* $RCSfile: perl.h,v $$Revision: 4.0.1.4 $$Date: 91/11/05 18:06:10 $ * * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! /* $RCSfile: perl.h,v $$Revision: 4.0.1.5 $$Date: 91/11/11 16:41:07 $ * * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,16 ---- * License or the Artistic License, as specified in the README file. * * $Log: perl.h,v $ + * Revision 4.0.1.5 91/11/11 16:41:07 lwall + * patch19: uts wrongly defines S_ISDIR() et al + * patch19: too many preprocessors can't expand a macro right in #if + * patch19: added little-endian pack/unpack options + * * Revision 4.0.1.4 91/11/05 18:06:10 lwall * patch11: various portability fixes * patch11: added support for dbz *************** *** 165,170 **** --- 170,189 ---- #endif #include + #ifdef uts + #undef S_ISDIR + #undef S_ISCHR + #undef S_ISBLK + #undef S_ISREG + #undef S_ISFIFO + #undef S_ISLNK + #define S_ISDIR(P) (((P)&S_IFMT)==S_IFDIR) + #define S_ISCHR(P) (((P)&S_IFMT)==S_IFCHR) + #define S_ISBLK(P) (((P)&S_IFMT)==S_IFBLK) + #define S_ISREG(P) (((P)&S_IFMT)==S_IFREG) + #define S_ISFIFO(P) (((P)&S_IFMT)==S_IFIFO) + #define S_ISLNK(P) (((P)&S_IFMT)==S_IFLNK) + #endif #ifdef I_TIME # include *************** *** 344,353 **** # endif #endif - #if S_ISBLK(060000) == 060000 - XXX Your sys/stat.h appears to be buggy. Please fix it. - #endif - #ifndef S_ISREG # define S_ISREG(m) ((m & S_IFMT) == S_IFREG) #endif --- 363,368 ---- *************** *** 426,432 **** # define SLOPPYDIVIDE #endif ! #if defined(cray) || defined(convex) || BYTEORDER > 0xffff # define QUAD #endif --- 441,447 ---- # define SLOPPYDIVIDE #endif ! #if defined(cray) || defined(convex) || defined (uts) || BYTEORDER > 0xffff # define QUAD #endif *************** *** 434,440 **** # ifdef cray # define quad int # else ! # ifdef convex # define quad long long # else # define quad long --- 449,455 ---- # ifdef cray # define quad int # else ! # if defined(convex) || defined (uts) # define quad long long # else # define quad long *************** *** 583,588 **** --- 598,624 ---- #undef HAS_NTOHS #undef HAS_NTOHL #endif + #endif + + /* + * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. + * -DWS + */ + #if BYTEORDER != 0x1234 + # define HAS_VTOHL + # define HAS_VTOHS + # define HAS_HTOVL + # define HAS_HTOVS + # if BYTEORDER == 0x4321 + # define vtohl(x) ((((x)&0xFF)<<24) \ + +(((x)>>24)&0xFF) \ + +(((x)&0x0000FF00)<<8) \ + +(((x)&0x00FF0000)>>8) ) + # define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF)) + # define htovl(x) vtohl(x) + # define htovs(x) vtohs(x) + # endif + /* otherwise default to functions in util.c */ #endif #ifdef CASTNEGFLOAT Index: perl.man *** perl.man.old Mon Nov 11 16:49:50 1991 --- perl.man Mon Nov 11 16:49:53 1991 *************** *** 1,7 **** .rn '' }` ! ''' $RCSfile: perl.man,v $$Revision: 4.0.1.4 $$Date: 91/11/05 18:11:05 $ ''' ''' $Log: perl.man,v $ ''' Revision 4.0.1.4 91/11/05 18:11:05 lwall ''' patch11: added sort {} LIST ''' patch11: added eval {} --- 1,10 ---- .rn '' }` ! ''' $RCSfile: perl.man,v $$Revision: 4.0.1.5 $$Date: 91/11/11 16:42:00 $ ''' ''' $Log: perl.man,v $ + ''' Revision 4.0.1.5 91/11/11 16:42:00 lwall + ''' patch19: added little-endian pack/unpack options + ''' ''' Revision 4.0.1.4 91/11/05 18:11:05 lwall ''' patch11: added sort {} LIST ''' patch11: added eval {} *************** *** 2014,2020 **** if (defined &$var) { &$var($parm); undef &$var; } .fi ! :Ip "do EXPR" 8 3 Uses the value of EXPR as a filename and executes the contents of the file as a .I perl --- 2017,2023 ---- if (defined &$var) { &$var($parm); undef &$var; } .fi ! .Ip "do EXPR" 8 3 Uses the value of EXPR as a filename and executes the contents of the file as a .I perl *************** *** 3071,3076 **** --- 3074,3081 ---- f A single-precision float in the native format. d A double-precision float in the native format. p A pointer to a string. + v A short in \*(L"VAX\*(R" (little-endian) order. + V A long in \*(L"VAX\*(R" (little-endian) order. x A null byte. X Back up a byte. @ Null fill to absolute position. *************** *** 5893,5899 **** The default top-of-form format for FILEHANDLE is now FILEHANDLE_TOP rather than top. .PP ! The eval {} and sort {} constructs were added in version 4.011. .SH BUGS .PP .I Perl --- 5898,5907 ---- The default top-of-form format for FILEHANDLE is now FILEHANDLE_TOP rather than top. .PP ! The eval {} and sort {} constructs were added in version 4.018. ! .PP ! The v and V (little-endian) template options for pack and unpack were ! added in 4.019. .SH BUGS .PP .I Perl Index: t/op/readdir.t *** t/op/readdir.t.old Mon Nov 11 16:50:00 1991 --- t/op/readdir.t Mon Nov 11 16:50:01 1991 *************** *** 0 **** --- 1,20 ---- + #!./perl + + eval 'opendir(NOSUCH, "no/such/directory");'; + if ($@) { print "1..0\n"; exit; } + + print "1..3\n"; + + if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } + @D = grep(/^[^\.]/, readdir(OP)); + closedir(OP); + + if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; } + + @R = sort @D; + @G = ; + while (@R && @G && "op/".$R[0] eq $G[0]) { + shift(@R); + shift(@G); + } + if (@R == 0 && @G == 0) { print "ok 3\n"; } else { print "not ok 3\n"; } Index: hints/sco_3.sh *** hints/sco_3.sh.old Mon Nov 11 16:49:31 1991 --- hints/sco_3.sh Mon Nov 11 16:49:31 1991 *************** *** 1,4 **** yacc='/usr/bin/yacc -Sm11000' libswanted=`echo $libswanted | sed 's/ x / /'` - i_varargs=undef ccflags="$ccflags -U M_XENIX" --- 1,7 ---- yacc='/usr/bin/yacc -Sm11000' libswanted=`echo $libswanted | sed 's/ x / /'` ccflags="$ccflags -U M_XENIX" + cppstdin='/lib/cpp -Di386 -DM_I386 -Dunix -DM_UNIX -DM_INTERNAT -DLAI_TCP' + cppminus='' + i_varargs=undef + d_rename='undef' Index: t/op/sort.t *** t/op/sort.t.old Mon Nov 11 16:50:02 1991 --- t/op/sort.t Mon Nov 11 16:50:03 1991 *************** *** 1,8 **** #!./perl ! # $RCSfile: sort.t,v $$Revision: 4.0.1.1 $$Date: 91/11/05 18:43:47 $ ! print "1..9\n"; sub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; } --- 1,8 ---- #!./perl ! # $RCSfile: sort.t,v $$Revision: 4.0.1.2 $$Date: 91/11/11 16:43:47 $ ! print "1..10\n"; sub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; } *************** *** 41,43 **** --- 41,48 ---- @a = (10,2,3,4); @b = sort {$a <=> $b;} @a; print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); + + $sub = 'reverse'; + $x = join('', sort $sub @harry); + print ($x eq 'xdogcatCainAbel' ? "ok 10\n" : "not ok 10\n"); + Index: t/op/stat.t *** t/op/stat.t.old Mon Nov 11 16:50:04 1991 --- t/op/stat.t Mon Nov 11 16:50:05 1991 *************** *** 1,6 **** #!./perl ! # $RCSfile: stat.t,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:44:44 $ print "1..56\n"; --- 1,6 ---- #!./perl ! # $RCSfile: stat.t,v $$Revision: 4.0.1.3 $$Date: 91/11/11 16:44:49 $ print "1..56\n"; *************** *** 11,16 **** --- 11,18 ---- unlink "Op.stat.tmp"; open(FOO, ">Op.stat.tmp"); + $junk = `ls Op.stat.tmp`; # hack to make Apollo update link count + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat(FOO); if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";} *************** *** 35,41 **** } print "#4 :$mtime: != :$ctime:\n"; ! `cp /dev/null Op.stat.tmp`; if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";} if (! -s 'Op.stat.tmp') {print "ok 6\n";} else {print "not ok 6\n";} --- 37,44 ---- } print "#4 :$mtime: != :$ctime:\n"; ! `rm -f Op.stat.tmp`; ! `touch Op.stat.tmp`; if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";} if (! -s 'Op.stat.tmp') {print "ok 6\n";} else {print "not ok 6\n";} Index: toke.c *** toke.c.old Mon Nov 11 16:50:08 1991 --- toke.c Mon Nov 11 16:50:10 1991 *************** *** 1,4 **** ! /* $RCSfile: toke.c,v $$Revision: 4.0.1.4 $$Date: 91/11/05 19:02:48 $ * * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! /* $RCSfile: toke.c,v $$Revision: 4.0.1.5 $$Date: 91/11/11 16:45:51 $ * * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,14 ---- * License or the Artistic License, as specified in the README file. * * $Log: toke.c,v $ + * Revision 4.0.1.5 91/11/11 16:45:51 lwall + * patch19: default arg for shift was wrong after first subroutine definition + * * Revision 4.0.1.4 91/11/05 19:02:48 lwall * patch11: \x and \c were subject to double interpretation in regexps * patch11: prepared for ctype implementations that don't define isascii() *************** *** 1198,1207 **** FUN2x(O_SUBSTR); if (strEQ(d,"sub")) { yylval.ival = savestack->ary_fill; /* restore stuff on reduce */ ! if (perldb) { ! savelong(&subline); ! saveitem(subname); ! } subline = curcmd->c_line; d = bufend; --- 1201,1208 ---- FUN2x(O_SUBSTR); if (strEQ(d,"sub")) { yylval.ival = savestack->ary_fill; /* restore stuff on reduce */ ! savelong(&subline); ! saveitem(subname); subline = curcmd->c_line; d = bufend; *************** *** 1208,1226 **** while (s < d && isSPACE(*s)) s++; if (isALPHA(*s) || *s == '_' || *s == '\'') { ! if (perldb) { ! str_sset(subname,curstname); ! str_ncat(subname,"'",1); ! for (d = s+1; isALNUM(*d) || *d == '\''; d++) ! /*SUPPRESS 530*/ ! ; ! if (d[-1] == '\'') ! d--; ! str_ncat(subname,s,d-s); ! } *(--s) = '\\'; /* force next ident to WORD */ } ! else if (perldb) str_set(subname,"?"); OPERATOR(SUB); } --- 1209,1225 ---- while (s < d && isSPACE(*s)) s++; if (isALPHA(*s) || *s == '_' || *s == '\'') { ! str_sset(subname,curstname); ! str_ncat(subname,"'",1); ! for (d = s+1; isALNUM(*d) || *d == '\''; d++) ! /*SUPPRESS 530*/ ! ; ! if (d[-1] == '\'') ! d--; ! str_ncat(subname,s,d-s); *(--s) = '\\'; /* force next ident to WORD */ } ! else str_set(subname,"?"); OPERATOR(SUB); } Index: usersub.c Prereq: 4.0 *** usersub.c.old Mon Nov 11 16:50:12 1991 --- usersub.c Mon Nov 11 16:50:13 1991 *************** *** 1,4 **** ! /* $Header: usersub.c,v 4.0 91/03/20 01:55:56 lwall Locked $ * * This file contains stubs for routines that the user may define to * set up glue routines for C libraries or to decrypt encrypted scripts --- 1,4 ---- ! /* $RCSfile: usersub.c,v $$Revision: 4.0.1.1 $$Date: 91/11/11 16:47:17 $ * * This file contains stubs for routines that the user may define to * set up glue routines for C libraries or to decrypt encrypted scripts *************** *** 5,10 **** --- 5,13 ---- * for execution. * * $Log: usersub.c,v $ + * Revision 4.0.1.1 91/11/11 16:47:17 lwall + * patch19: deleted some unused functions from usersub.c + * * Revision 4.0 91/03/20 01:55:56 lwall * 4.0 baseline. * *************** *** 19,25 **** } /* ! * The following is supplied by John MacDonald as a means of decrypting * and executing (presumably proprietary) scripts that have been encrypted * by a (presumably secret) method. The idea is that you supply your own * routine in place of cryptfilter (which is purposefully a very weak --- 22,28 ---- } /* ! * The following is supplied by John Macdonald as a means of decrypting * and executing (presumably proprietary) scripts that have been encrypted * by a (presumably secret) method. The idea is that you supply your own * routine in place of cryptfilter (which is purposefully a very weak *************** *** 34,39 **** --- 37,48 ---- #include #endif + #ifdef CRYPTLOCAL + + #include "cryptlocal.h" + + #else /* ndef CRYPTLOCAL */ + #define CRYPT_MAGIC_1 0xfb #define CRYPT_MAGIC_2 0xf1 *************** *** 47,52 **** --- 56,63 ---- } } + #endif /* CRYPTLOCAL */ + #ifndef MSDOS static FILE *lastpipefile; static int pipepid; *************** *** 95,100 **** --- 106,112 ---- _exit(0); } close(p[1]); + close(fileno(fil)); fclose(fil); str = afetch(fdpid,p[0],TRUE); str->str_u.str_useful = pipepid; *************** *** 112,117 **** --- 124,130 ---- ch = getc(rsfp); if (ch == CRYPT_MAGIC_1) { if (getc(rsfp) == CRYPT_MAGIC_2) { + if( perldb ) fatal("can't debug an encrypted script"); rsfp = mypfiopen( rsfp, cryptfilter ); preprocess = 1; /* force call to pclose when done */ } *************** *** 120,182 **** } else ungetc(ch,rsfp); - } - - FILE * - cryptopen(cmd) /* open a (possibly encrypted) program for input */ - char *cmd; - { - FILE *fil = fopen( cmd, "r" ); - - lastpipefile = Nullfp; - pipepid = 0; - - if( fil ) { - int ch = getc( fil ); - int lines = 0; - int chars = 0; - - /* Search for the magic cookie that starts the encrypted script, - ** while still allowing a few lines of unencrypted text to let - ** '#!' and the nih hack both continue to work. (These lines - ** will end up being ignored.) - */ - while( ch != CRYPT_MAGIC_1 && ch != EOF && lines < 5 && chars < 300 ) { - if( ch == '\n' ) - ++lines; - ch = getc( fil ); - ++chars; - } - - if( ch == CRYPT_MAGIC_1 ) { - if( (ch = getc( fil ) ) == CRYPT_MAGIC_2 ) { - if( perldb ) fatal("can't debug an encrypted script"); - /* we found it, decrypt the rest of the file */ - fil = mypfiopen( fil, cryptfilter ); - return( lastpipefile = fil ); - } else - /* if its got MAGIC 1 without MAGIC 2, too bad */ - fatal( "bad encryption format" ); - } - - /* this file is not encrypted - rewind and process it normally */ - rewind( fil ); - } - - return( fil ); - } - - VOID - cryptclose(fil) - FILE *fil; - { - if( fil == Nullfp ) - return; - - if( fil == lastpipefile ) - mypclose( fil ); - else - fclose( fil ); } #endif /* !MSDOS */ --- 133,138 ---- Index: util.c *** util.c.old Mon Nov 11 16:50:15 1991 --- util.c Mon Nov 11 16:50:16 1991 *************** *** 1,4 **** ! /* $RCSfile: util.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 19:18:26 $ * * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! /* $RCSfile: util.c,v $$Revision: 4.0.1.4 $$Date: 91/11/11 16:48:54 $ * * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * License or the Artistic License, as specified in the README file. * * $Log: util.c,v $ + * Revision 4.0.1.4 91/11/11 16:48:54 lwall + * patch19: study was busted by 4.018 + * patch19: added little-endian pack/unpack options + * * Revision 4.0.1.3 91/11/05 19:18:26 lwall * patch11: safe malloc code now integrated into Perl's malloc when possible * patch11: index("little", "longer string") could visit faraway places *************** *** 685,696 **** #ifdef POINTERRIGOR if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */ do { ! #ifndef lint ! while (big[pos-previous] != first && big[pos-previous] != fold[first] ! && (pos += screamnext[pos]) ) ! /*SUPPRESS 530*/ ! ; ! #endif for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; --- 689,696 ---- #ifdef POINTERRIGOR if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */ do { ! if (big[pos-previous] != first && big[pos-previous] != fold[first]) ! continue; for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; *************** *** 715,725 **** } else { do { ! #ifndef lint ! while (big[pos-previous] != first && (pos += screamnext[pos])) ! /*SUPPRESS 530*/ ! ; ! #endif for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; --- 715,722 ---- } else { do { ! if (big[pos-previous] != first) ! continue; for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; *************** *** 746,757 **** big -= previous; if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */ do { ! #ifndef lint ! while (big[pos] != first && big[pos] != fold[first] ! && (pos += screamnext[pos]) ) ! /*SUPPRESS 530*/ ! ; ! #endif for (x=big+pos+1,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; --- 743,750 ---- big -= previous; if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */ do { ! if (big[pos] != first && big[pos] != fold[first]) ! continue; for (x=big+pos+1,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; *************** *** 776,786 **** } else { do { ! #ifndef lint ! while (big[pos] != first && (pos += screamnext[pos])) ! /*SUPPRESS 530*/ ! ; ! #endif for (x=big+pos+1,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; --- 769,776 ---- } else { do { ! if (big[pos] != first) ! continue; for (x=big+pos+1,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; *************** *** 1236,1241 **** --- 1226,1239 ---- #endif /* HAS_VPRINTF */ #endif /* I_VARARGS */ + /* + * I think my_swap(), htonl() and ntohl() have never been used. + * perl.h contains last-chance references to my_swap(), my_htonl() + * and my_ntohl(). I presume these are the intended functions; + * but htonl() and ntohl() have the wrong names. There are no + * functions my_htonl() and my_ntohl() defined anywhere. + * -DWS + */ #ifdef MYSWAP #if BYTEORDER != 0x4321 short *************** *** 1315,1321 **** } #endif /* BYTEORDER != 0x4321 */ ! #endif /* HAS_HTONS */ #ifndef MSDOS FILE * --- 1313,1376 ---- } #endif /* BYTEORDER != 0x4321 */ ! #endif /* MYSWAP */ ! ! /* ! * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. ! * If these functions are defined, ! * the BYTEORDER is neither 0x1234 nor 0x4321. ! * However, this is not assumed. ! * -DWS ! */ ! ! #define HTOV(name,type) \ ! type \ ! name (n) \ ! register type n; \ ! { \ ! union { \ ! type value; \ ! char c[sizeof(type)]; \ ! } u; \ ! register int i; \ ! register int s; \ ! for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ ! u.c[i] = (n >> s) & 0xFF; \ ! } \ ! return u.value; \ ! } ! ! #define VTOH(name,type) \ ! type \ ! name (n) \ ! register type n; \ ! { \ ! union { \ ! type value; \ ! char c[sizeof(type)]; \ ! } u; \ ! register int i; \ ! register int s; \ ! u.value = n; \ ! n = 0; \ ! for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ ! n += (u.c[i] & 0xFF) << s; \ ! } \ ! return n; \ ! } ! ! #if defined(HAS_HTOVS) && !defined(htovs) ! HTOV(htovs,short) ! #endif ! #if defined(HAS_HTOVL) && !defined(htovl) ! HTOV(htovl,long) ! #endif ! #if defined(HAS_VTOHS) && !defined(vtohs) ! VTOH(vtohs,short) ! #endif ! #if defined(HAS_VTOHL) && !defined(vtohl) ! VTOH(vtohl,long) ! #endif #ifndef MSDOS FILE * Index: hints/uts.sh *** hints/uts.sh.old Mon Nov 11 16:49:33 1991 --- hints/uts.sh Mon Nov 11 16:49:33 1991 *************** *** 1,2 **** ! ccflags="$ccflags -DCRIPPLED_CC -g" ! d_lstat=$undef --- 1,2 ---- ! ccflags="$ccflags -DCRIPPLED_CC" ! d_lstat=$define exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.