See patch #4.
--- /dev/null
+#!/bin/sh
+
+: if this fails, just run all the .SH files by hand
+. ./config.sh
+
+echo " "
+echo "Doing variable substitutions on .SH files..."
+set x `awk '{print $1}' <MANIFEST | grep '\.SH'`
+shift
+case $# in
+0) set x *.SH; shift;;
+esac
+if test ! -f $1; then
+ shift
+fi
+for file in $*; do
+ set X
+ shift
+ chmod +x $file
+ case "$file" in
+ */*)
+ dir=`expr X$file : 'X\(.*\)/'`
+ file=`expr X$file : 'X.*/\(.*\)'`
+ (cd $dir && . $file)
+ ;;
+ *)
+ . $file
+ ;;
+ esac
+done
+if test -f config.h.SH; then
+ if test ! -f config.h; then
+ : oops, they left it out of MANIFEST, probably, so do it anyway.
+ . config.h.SH
+ fi
+fi
-/* $RCSfile: doarg.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:40:14 $
+/* $RCSfile: doarg.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 10:42:17 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: doarg.c,v $
+ * Revision 4.0.1.2 91/06/07 10:42:17 lwall
+ * patch4: new copyright notice
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * patch4: //o and s///o now optimize themselves fully at runtime
+ * patch4: added global modifier for pattern matches
+ * patch4: undef @array disabled "@array" interpolation
+ * patch4: chop("") was returning "\0" rather than ""
+ * patch4: vector logical operations &, | and ^ sometimes returned null string
+ * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
+ *
* Revision 4.0.1.1 91/04/11 17:40:14 lwall
* patch1: fixed undefined environ problem
* patch1: fixed debugger coredump on subroutines
if (spat->spat_flags & SPAT_KEEP) {
arg_free(spat->spat_runtime); /* it won't change, so */
spat->spat_runtime = Nullarg; /* no point compiling again */
+ scanconst(spat, m, dstr->str_cur);
+ hoistmust(spat);
+ if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
+ curcmd->c_flags &= ~CF_OPTIMIZE;
+ opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
+ }
}
}
#ifdef DEBUGGING
#endif
safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) &&
!sawampersand);
- if (!*spat->spat_regexp->precomp && lastspat)
+ if (!spat->spat_regexp->prelen && lastspat)
spat = lastspat;
orig = m = s;
if (hint) {
spat->spat_short = Nullstr; /* opt is being useless */
}
}
- once = ((rspat->spat_flags & SPAT_ONCE) != 0);
+ once = !(rspat->spat_flags & SPAT_GLOBAL);
if (rspat->spat_flags & SPAT_CONST) { /* known replacement string? */
if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
dstr = rspat->spat_repl[1].arg_ptr.arg_str;
if (type == O_ARRAY || type == O_LARRAY) {
stab = arg[1].arg_ptr.arg_stab;
afree(stab_xarray(stab));
- stab_xarray(stab) = Null(ARRAY*);
+ stab_xarray(stab) = anew(stab); /* so "@array" still works */
}
else if (type == O_HASH || type == O_LHASH) {
stab = arg[1].arg_ptr.arg_stab;
return;
}
tmps = str_get(str);
- if (!tmps)
- return;
- tmps += str->str_cur - (str->str_cur != 0);
- str_nset(astr,tmps,1); /* remember last char */
- *tmps = '\0'; /* wipe it out */
- str->str_cur = tmps - str->str_ptr;
- str->str_nok = 0;
- STABSET(str);
+ if (tmps && str->str_cur) {
+ tmps += str->str_cur - 1;
+ str_nset(astr,tmps,1); /* remember last char */
+ *tmps = '\0'; /* wipe it out */
+ str->str_cur = tmps - str->str_ptr;
+ str->str_nok = 0;
+ STABSET(str);
+ }
+ else
+ str_nset(astr,"",0);
}
do_vop(optype,str,left,right)
(void)bzero(str->str_ptr + str->str_cur, len - str->str_cur);
str->str_cur = len;
}
+ str->str_pok = 1;
+ str->str_nok = 0;
s = str->str_ptr;
if (!s) {
str_nset(str,"",0);
register STR **st = stack->ary_array;
register int sp = arglast[1];
register int items = arglast[2] - sp;
- long arg[8];
+ unsigned long arg[8];
register int i = 0;
int retval = -1;
*/
while (items--) {
if (st[++sp]->str_nok || !i)
- arg[i++] = (long)str_gnum(st[sp]);
+ arg[i++] = (unsigned long)str_gnum(st[sp]);
#ifndef lint
else
- arg[i++] = (long)st[sp]->str_ptr;
+ arg[i++] = (unsigned long)st[sp]->str_ptr;
#endif /* lint */
}
sp = arglast[1];
-/* $RCSfile: doio.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:41:06 $
+/* $RCSfile: doio.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 10:53:39 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: doio.c,v $
+ * Revision 4.0.1.2 91/06/07 10:53:39 lwall
+ * patch4: new copyright notice
+ * patch4: system fd's are now treated specially
+ * patch4: added $^F variable to specify maximum system fd, default 2
+ * patch4: character special files now opened with bidirectional stdio buffers
+ * patch4: taintchecks could improperly modify parent in vfork()
+ * patch4: many, many itty-bitty portability fixes
+ *
* Revision 4.0.1.1 91/04/11 17:41:06 lwall
* patch1: hopefully straightened out some of the Xenix mess
*
int fd;
int writing = 0;
char mode[3]; /* stdio file mode ("r\0" or "r+\0") */
+ FILE *saveifp = Nullfp;
+ FILE *saveofp = Nullfp;
+ char savetype = ' ';
name = myname;
forkprocess = 1; /* assume true if no fork */
stio = stab_io(stab) = stio_new();
else if (stio->ifp) {
fd = fileno(stio->ifp);
- if (stio->type == '|')
- result = mypclose(stio->ifp);
- else if (stio->type == '-')
+ if (stio->type == '-')
result = 0;
+ else if (fd <= maxsysfd) {
+ saveifp = stio->ifp;
+ saveofp = stio->ofp;
+ savetype = stio->type;
+ result = 0;
+ }
+ else if (stio->type == '|')
+ result = mypclose(stio->ifp);
else if (stio->ifp != stio->ofp) {
if (stio->ofp) {
result = fclose(stio->ofp);
}
else
result = fclose(stio->ifp);
- if (result == EOF && fd > 2)
+ if (result == EOF && fd > maxsysfd)
fprintf(stderr,"Warning: unable to close filehandle %s properly.\n",
stab_name(stab));
stio->ofp = stio->ifp = Nullfp;
fd = atoi(name);
else {
stab = stabent(name,FALSE);
- if (!stab || !stab_io(stab))
- return FALSE;
+ if (!stab || !stab_io(stab)) {
+#ifdef EINVAL
+ errno = EINVAL;
+#endif
+ goto say_false;
+ }
if (stab_io(stab) && stab_io(stab)->ifp) {
fd = fileno(stab_io(stab)->ifp);
if (stab_io(stab)->type == 's')
}
Safefree(myname);
if (!fp)
- return FALSE;
+ goto say_false;
if (stio->type &&
stio->type != '|' && stio->type != '-') {
if (fstat(fileno(fp),&statbuf) < 0) {
(void)fclose(fp);
- return FALSE;
+ goto say_false;
}
- if (S_ISSOCK(statbuf.st_mode))
+ if (S_ISSOCK(statbuf.st_mode) || (S_ISCHR(statbuf.st_mode) && writing))
stio->type = 's'; /* in case a socket was passed in to us */
#ifdef S_IFMT
else if (!(statbuf.st_mode & S_IFMT))
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
fd = fileno(fp);
- fcntl(fd,F_SETFD,fd >= 3);
-#endif
+ fcntl(fd,F_SETFD,fd > maxsysfd);
+#endif
+ if (saveifp) { /* must use old fp? */
+ fd = fileno(saveifp);
+ if (saveofp) {
+ fflush(saveofp); /* emulate fclose() */
+ if (saveofp != saveifp) { /* was a socket? */
+ fclose(saveofp);
+ Safefree(saveofp);
+ }
+ }
+ if (fd != fileno(fp)) {
+ dup2(fileno(fp), fd);
+ fclose(fp);
+ }
+ fp = saveifp;
+ }
stio->ifp = fp;
if (writing) {
if (stio->type != 's')
if (!(stio->ofp = fdopen(fileno(fp),"w"))) {
fclose(fp);
stio->ifp = Nullfp;
+ goto say_false;
}
}
return TRUE;
+
+say_false:
+ stio->ifp = saveifp;
+ stio->ofp = saveofp;
+ stio->type = savetype;
+ return FALSE;
}
FILE *
register char *s;
char flags[10];
-#ifdef TAINT
- taintenv();
- taintproper("Insecure dependency in exec");
-#endif
-
/* save an extra exec if possible */
#ifdef CSH
else if (nstio->ifp)
do_close(nstab,FALSE);
- fd = accept(fileno(gstio->ifp),buf,&len);
+ fd = accept(fileno(gstio->ifp),(struct sockaddr *)buf,&len);
if (fd < 0)
goto badexit;
nstio->ifp = fdopen(fd, "r");
#ifndef telldir
long telldir();
#endif
+#ifndef apollo
struct DIRENT *readdir();
+#endif
register struct DIRENT *dp;
if (!stab)
goto nope;
if (!(stio = stab_io(stab)))
stio = stab_io(stab) = stio_new();
- if (!stio->dirp && optype != O_OPENDIR)
+ if (!stio->dirp && optype != O_OPEN_DIR)
goto nope;
st[sp] = &str_yes;
switch (optype) {
- case O_OPENDIR:
+ case O_OPEN_DIR:
if (stio->dirp)
closedir(stio->dirp);
if (!(stio->dirp = opendir(str_get(st[sp+1]))))
if (semctl(id, 0, IPC_STAT, &semds) == -1)
return -1;
getinfo = (cmd == GETALL);
-#ifdef _POSIX_SOURCE
- infosize = semds.sem_nsems * sizeof(ushort_t);
-#else
- infosize = semds.sem_nsems * sizeof(ushort);
-#endif
+ infosize = semds.sem_nsems * sizeof(short);
+ /* "short" is technically wrong but much more portable
+ than guessing about u_?short(_t)? */
}
break;
#endif
return -1;
}
errno = 0;
- return semop(id, opbuf, opsize/sizeof(struct sembuf));
+ return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
#else
fatal("semop not implemented");
#endif
char *mbuf, *shm;
int id, mpos, msize;
struct shmid_ds shmds;
+#ifndef VOIDSHMAT
extern char *shmat();
+#endif
id = (int)str_gnum(st[++sp]);
mstr = st[++sp];
errno = EFAULT; /* can't do as caller requested */
return -1;
}
- shm = shmat(id, (char *)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
+ shm = (char*)shmat(id, (char*)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
if (shm == (char *)-1) /* I hate System V IPC, I really do */
return -1;
mbuf = str_get(mstr);
-/* $Header: dolist.c,v 4.0 91/03/20 01:08:03 lwall Locked $
+/* $RCSfile: dolist.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:58:28 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: dolist.c,v $
+ * Revision 4.0.1.1 91/06/07 10:58:28 lwall
+ * patch4: new copyright notice
+ * patch4: added global modifier for pattern matches
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * patch4: //o and s///o now optimize themselves fully at runtime
+ * patch4: $` was busted inside s///
+ * patch4: caller($arg) didn't work except under debugger
+ *
* Revision 4.0 91/03/20 01:08:03 lwall
* 4.0 baseline.
*
char *strend = s + st[sp]->str_cur;
STR *tmpstr;
char *myhint = hint;
+ int global;
+ int safebase;
hint = Nullch;
if (!spat) {
st[sp] = str;
return sp;
}
+ global = spat->spat_flags & SPAT_GLOBAL;
+ safebase = (gimme == G_ARRAY) || global;
if (!s)
fatal("panic: do_match");
if (spat->spat_flags & SPAT_USED) {
}
spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
spat->spat_flags & SPAT_FOLD);
- if (!*spat->spat_regexp->precomp && lastspat)
+ if (!spat->spat_regexp->prelen && lastspat)
spat = lastspat;
if (spat->spat_flags & SPAT_KEEP) {
if (spat->spat_runtime)
arg_free(spat->spat_runtime); /* it won't change, so */
spat->spat_runtime = Nullarg; /* no point compiling again */
+ scanconst(spat, t, tmpstr->str_cur);
+ hoistmust(spat);
+ if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
+ curcmd->c_flags &= ~CF_OPTIMIZE;
+ opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
+ }
+ }
+ if (global) {
+ if (spat->spat_regexp->startp[0]) {
+ s = spat->spat_regexp->endp[0];
+ }
}
- if (!spat->spat_regexp->nparens)
+ else if (!spat->spat_regexp->nparens)
gimme = G_SCALAR; /* accidental array context? */
if (regexec(spat->spat_regexp, s, strend, s, 0,
srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
- gimme == G_ARRAY)) {
- if (spat->spat_regexp->subbase)
+ safebase)) {
+ if (spat->spat_regexp->subbase || global)
curspat = spat;
lastspat = spat;
goto gotcha;
deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
}
#endif
- if (!*spat->spat_regexp->precomp && lastspat)
+ if (!spat->spat_regexp->prelen && lastspat)
spat = lastspat;
t = s;
+ play_it_again:
+ if (global && spat->spat_regexp->startp[0])
+ s = spat->spat_regexp->endp[0];
if (myhint) {
if (myhint < s || myhint > strend)
fatal("panic: hint in do_match");
spat->spat_short = Nullstr; /* opt is being useless */
}
}
- if (!spat->spat_regexp->nparens)
+ if (!spat->spat_regexp->nparens && !global)
gimme = G_SCALAR; /* accidental array context? */
if (regexec(spat->spat_regexp, s, strend, t, 0,
srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
- gimme == G_ARRAY)) {
- if (spat->spat_regexp->subbase)
+ safebase)) {
+ if (spat->spat_regexp->subbase || global)
curspat = spat;
lastspat = spat;
if (spat->spat_flags & SPAT_ONCE)
int iters, i, len;
iters = spat->spat_regexp->nparens;
- if (sp + iters >= stack->ary_max) {
- astore(stack,sp + iters, Nullstr);
+ if (global && !iters)
+ i = 1;
+ else
+ i = 0;
+ if (sp + iters + i >= stack->ary_max) {
+ astore(stack,sp + iters + i, Nullstr);
st = stack->ary_array; /* possibly realloced */
}
- for (i = 1; i <= iters; i++) {
+ for (i = !i; i <= iters; i++) {
st[++sp] = str_mortal(&str_no);
if (s = spat->spat_regexp->startp[i]) {
len = spat->spat_regexp->endp[i] - s;
str_nset(st[sp],s,len);
}
}
+ if (global)
+ goto play_it_again;
return sp;
}
else {
lastspat = spat;
if (spat->spat_flags & SPAT_ONCE)
spat->spat_flags |= SPAT_USED;
+ if (global) {
+ spat->spat_regexp->startp[0] = s;
+ spat->spat_regexp->endp[0] = s + spat->spat_short->str_cur;
+ curspat = spat;
+ goto gotcha;
+ }
if (sawampersand) {
char *tmps;
if (spat->spat_regexp->subbase)
Safefree(spat->spat_regexp->subbase);
tmps = spat->spat_regexp->subbase = nsavestr(t,strend-t);
+ spat->spat_regexp->subbeg = tmps;
spat->spat_regexp->subend = tmps + (strend-t);
tmps = spat->spat_regexp->startp[0] = tmps + (s - t);
spat->spat_regexp->endp[0] = tmps + spat->spat_short->str_cur;
return sp;
nope:
+ spat->spat_regexp->startp[0] = Nullch;
++spat->spat_short->str_u.str_useful;
if (gimme == G_ARRAY)
return sp;
str_2mortal(str_nmake((double)csv->wantarray)) );
if (csv->hasargs) {
ARRAY *ary = csv->argarray;
+ STAB *tmpstab;
+ if (!dbargs)
+ dbargs = stab_xarray(aadd(stabent("DB'args", TRUE)));
if (dbargs->ary_max < ary->ary_fill)
astore(dbargs,ary->ary_fill,Nullstr);
Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
-/* $Header: dump.c,v 4.0 91/03/20 01:08:25 lwall Locked $
+/* $RCSfile: dump.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:58:44 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: dump.c,v $
+ * Revision 4.0.1.1 91/06/07 10:58:44 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:08:25 lwall
* 4.0 baseline.
*
-/* $RCSfile: eval.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:43:48 $
+/* $RCSfile: eval.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:07:23 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: eval.c,v $
+ * Revision 4.0.1.2 91/06/07 11:07:23 lwall
+ * patch4: new copyright notice
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ * patch4: assignment wasn't correctly de-tainting the assigned variable.
+ * patch4: default top-of-form format is now FILEHANDLE_TOP
+ * patch4: added $^P variable to control calling of perldb routines
+ * patch4: taintchecks could improperly modify parent in vfork()
+ * patch4: many, many itty-bitty portability fixes
+ *
* Revision 4.0.1.1 91/04/11 17:43:48 lwall
* patch1: fixed failed fork to return undef as documented
* patch1: reduced maximum branch distance in eval.c
}
#endif
break;
+ case A_LENSTAB:
+ str_numset(str, (double)STAB_LEN(argptr.arg_stab));
+ st[++sp] = str;
+#ifdef DEBUGGING
+ if (debug & 8) {
+ (void)sprintf(buf,"LENSTAB $%s",stab_name(argptr.arg_stab));
+ tmps = buf;
+ }
+#endif
+ break;
case A_LEXPR:
#ifdef DEBUGGING
if (debug & 8) {
goto array_return;
case O_SASSIGN:
sassign:
+#ifdef TAINT
+ if (tainted && !st[2]->str_tainted)
+ tainted = 0;
+#endif
STR_SSET(str, st[2]);
STABSET(str);
break;
break;
}
format(&outrec,form,sp);
- do_write(&outrec,stab_io(stab),sp);
+ do_write(&outrec,stab,sp);
if (stab_io(stab)->flags & IOF_FLUSH)
(void)fflush(fp);
str_set(str, Yes);
else if (stab_hash(tmpstab)->tbl_dbm)
str_magic(str, tmpstab, 'D', tmps, anum);
#endif
- else if (perldb && tmpstab == DBline)
+ else if (tmpstab == DBline)
str_magic(str, tmpstab, 'L', tmps, anum);
break;
case O_LSLICE:
else if (arglast[2] - arglast[1] != 1)
value = (double)do_aexec(Nullstr,arglast);
else {
+#ifdef TAINT
+ taintenv();
+ tainted |= st[2]->str_tainted;
+ taintproper("Insecure dependency in exec");
+#endif
value = (double)do_exec(str_get(str_mortal(st[2])));
}
goto donumset;
anum = 0;
else
anum = (int)str_gnum(st[1]);
+#ifdef _POSIX_SOURCE
+ if (anum != 0)
+ fatal("POSIX getpgrp can't take an argument");
+ value = (double)getpgrp();
+#else
value = (double)getpgrp(anum);
+#endif
goto donumset;
#else
fatal("The getpgrp() function is unimplemented on this machine");
fatal("Unsupported function getlogin");
#endif
break;
- case O_OPENDIR:
+ case O_OPEN_DIR:
case O_READDIR:
case O_TELLDIR:
case O_SEEKDIR:
-/* $Header: form.c,v 4.0 91/03/20 01:19:23 lwall Locked $
+/* $RCSfile: form.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:07:59 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: form.c,v $
+ * Revision 4.0.1.1 91/06/07 11:07:59 lwall
+ * patch4: new copyright notice
+ * patch4: default top-of-form format is now FILEHANDLE_TOP
+ *
* Revision 4.0 91/03/20 01:19:23 lwall
* 4.0 baseline.
*
return count;
}
-do_write(orec,stio,sp)
+do_write(orec,stab,sp)
struct outrec *orec;
-register STIO *stio;
+STAB *stab;
int sp;
{
+ register STIO *stio = stab_io(stab);
FILE *ofp = stio->ofp;
#ifdef DEBUGGING
if (stio->lines_left < orec->o_lines) {
if (!stio->top_stab) {
STAB *topstab;
+ char tmpbuf[256];
- if (!stio->top_name)
- stio->top_name = savestr("top");
+ if (!stio->top_name) {
+ if (!stio->fmt_name)
+ stio->fmt_name = savestr(stab_name(stab));
+ sprintf(tmpbuf, "%s_TOP", stio->fmt_name);
+ topstab = stabent(tmpbuf,FALSE);
+ if (topstab && stab_form(topstab))
+ stio->top_name = savestr(tmpbuf);
+ else
+ stio->top_name = savestr("top");
+ }
topstab = stabent(stio->top_name,FALSE);
if (!topstab || !stab_form(topstab)) {
stio->lines_left = 100000000;
-/* $Header: form.h,v 4.0 91/03/20 01:19:37 lwall Locked $
+/* $RCSfile: form.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:08:20 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: form.h,v $
+ * Revision 4.0.1.1 91/06/07 11:08:20 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:19:37 lwall
* 4.0 baseline.
*
open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed";
while (<IOCTLS>) {
- if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\(\w+,\s*\w+,\s*([^)]+)/) {
+ if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\('?\w+'?,\s*\w+,\s*([^)]+)/) {
$need{$2}++;
}
}
-/* $Header: handy.h,v 4.0 91/03/20 01:22:15 lwall Locked $
+/* $RCSfile: handy.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:09:56 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: handy.h,v $
+ * Revision 4.0.1.1 91/06/07 11:09:56 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:22:15 lwall
* 4.0 baseline.
*
-/* $Header: hash.c,v 4.0 91/03/20 01:22:26 lwall Locked $
+/* $RCSfile: hash.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:10:11 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: hash.c,v $
+ * Revision 4.0.1.1 91/06/07 11:10:11 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:22:26 lwall
* 4.0 baseline.
*
--- /dev/null
+# Usage:
+# require "find.pl";
+#
+# &find('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+
+sub find {
+ chop($cwd = `pwd`);
+ foreach $topdir (@_) {
+ (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+ || (warn("Can't stat $topdir: $!\n"), next);
+ if (-d _) {
+ if (chdir($topdir)) {
+ ($dir,$_) = ($topdir,'.');
+ $name = $topdir;
+ &wanted;
+ $topdir =~ s,/$,, ;
+ &finddir($topdir,$topnlink);
+ }
+ else {
+ warn "Can't cd to $topdir: $!\n";
+ }
+ }
+ else {
+ unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ ($dir,$_) = ('.', $topdir);
+ }
+ chdir $dir && &wanted;
+ }
+ chdir $cwd;
+ }
+}
+
+sub finddir {
+ local($dir,$nlink) = @_;
+ local($dev,$ino,$mode,$subcount);
+ local($name);
+
+ # Get the list of files in the current directory.
+
+ opendir(DIR,'.') || warn "Can't open $dir: $!\n";
+ local(@filenames) = readdir(DIR);
+ closedir(DIR);
+
+ if ($nlink == 2) { # This dir has no subdirectories.
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $name = "$dir/$_";
+ $nlink = 0;
+ &wanted;
+ }
+ }
+ else { # This dir has subdirectories.
+ $subcount = $nlink - 2;
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $nlink = $prune = 0;
+ $name = "$dir/$_";
+ &wanted;
+ if ($subcount > 0) { # Seen all the subdirs?
+
+ # Get link count and check for directoriness.
+
+ ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+
+ if (-d _) {
+
+ # It really is a directory, so do it recursively.
+
+ if (!$prune && chdir $_) {
+ &finddir($name,$nlink);
+ chdir '..';
+ }
+ --$subcount;
+ }
+ }
+ }
+ }
+}
+1;
--- /dev/null
+# Usage:
+# require "finddepth.pl";
+#
+# &finddepth('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+
+sub finddepth {
+ chop($cwd = `pwd`);
+ foreach $topdir (@_) {
+ (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+ || (warn("Can't stat $topdir: $!\n"), next);
+ if (-d _) {
+ if (chdir($topdir)) {
+ $topdir =~ s,/$,, ;
+ &finddepthdir($topdir,$topnlink);
+ ($dir,$_) = ($topdir,'.');
+ $name = $topdir;
+ &wanted;
+ }
+ else {
+ warn "Can't cd to $topdir: $!\n";
+ }
+ }
+ else {
+ unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ ($dir,$_) = ('.', $topdir);
+ }
+ chdir $dir && &wanted;
+ }
+ chdir $cwd;
+ }
+}
+
+sub finddepthdir {
+ local($dir,$nlink) = @_;
+ local($dev,$ino,$mode,$subcount);
+ local($name);
+
+ # Get the list of files in the current directory.
+
+ opendir(DIR,'.') || warn "Can't open $dir: $!\n";
+ local(@filenames) = readdir(DIR);
+ closedir(DIR);
+
+ if ($nlink == 2) { # This dir has no subdirectories.
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $name = "$dir/$_";
+ $nlink = 0;
+ &wanted;
+ }
+ }
+ else { # This dir has subdirectories.
+ $subcount = $nlink - 2;
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $nlink = $prune = 0;
+ $name = "$dir/$_";
+ if ($subcount > 0) { # Seen all the subdirs?
+
+ # Get link count and check for directoriness.
+
+ ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+
+ if (-d _) {
+
+ # It really is a directory, so do it recursively.
+
+ if (!$prune && chdir $_) {
+ &finddepthdir($name,$nlink);
+ chdir '..';
+ }
+ --$subcount;
+ }
+ }
+ &wanted;
+ }
+ }
+}
+1;
-/* $Header: dir.h,v 4.0 91/03/20 01:34:20 lwall Locked $
+/* $RCSfile: dir.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:10 $
*
* (C) Copyright 1987, 1990 Diomidis Spinellis.
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: dir.h,v $
+ * Revision 4.0.1.1 91/06/07 11:22:10 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:34:20 lwall
* 4.0 baseline.
*
-/* $Header: directory.c,v 4.0 91/03/20 01:34:24 lwall Locked $
+/* $RCSfile: directory.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:24 $
*
* (C) Copyright 1987, 1988, 1990 Diomidis Spinellis.
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: directory.c,v $
+ * Revision 4.0.1.1 91/06/07 11:22:24 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:34:24 lwall
* 4.0 baseline.
*
#define PATHLEN 65
#ifndef lint
-static char rcsid[] = "$Header: directory.c,v 4.0 91/03/20 01:34:24 lwall Locked $";
+static char rcsid[] = "$RCSfile: directory.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:24 $";
#endif
DIR *
-#define PATCHLEVEL 5
+#define PATCHLEVEL 6
for (split(' ', $()) {
next if $seen{$_}++;
- push(@gr, (getgrgid($_))[0]);
+ ($group) = getgrgid($_);
+ if (defined $group) {
+ push(@gr, $group);
+ }
+ else {
+ push(@gr, $_);
+ }
}
$gr1 = join(' ',sort @gr);
-$gr2 = join(' ', sort split(' ',`groups`));
+$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";
elsif ($_ eq 'exec') {
for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
shift;
- for (@cmd) { s/'/\\'/g; }
- $" = "','";
- $out .= &tab . "&exec(0, '@cmd')";
- $" = ' ';
- $initexec++;
+ $_ = "@cmd";
+ if (m#^(/bin/)?rm -f {}$#) {
+ if (!@ARGV) {
+ $out .= &tab . 'unlink($_)';
+ }
+ else {
+ $out .= &tab . '(unlink($_) || 1)';
+ }
+ }
+ elsif (m#^(/bin/)?rm {}$#) {
+ $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
+ }
+ else {
+ for (@cmd) { s/'/\\'/g; }
+ $" = "','";
+ $out .= &tab . "&exec(0, '@cmd')";
+ $" = ' ';
+ $initexec++;
+ }
}
elsif ($_ eq 'ok') {
for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
}
if (@ARGV) {
if ($ARGV[0] eq '-o') {
+ { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
$statdone = 0 if $indent == 1 && $delayedstat;
$saw_or++;
- $out .= "\n" . &tab . "||\n";
shift;
}
else {
print $initfile, "\n" if $initfile;
+$find = $depth ? "finddepth" : "find";
print <<"END";
+require "$find.pl";
+
# Traverse desired filesystems
-&dodirs($roots);
+&$find($roots);
$flushall
exit;
END
-print <<'END';
-sub dodirs {
- chop($cwd = `pwd`);
- foreach $topdir (@_) {
- (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
- || (warn("Can't stat $topdir: $!\n"), next);
- if (-d _) {
- if (chdir($topdir)) {
-END
-if ($depth) {
- print <<'END';
- $topdir = '' if $topdir eq '/';
- &dodir($topdir,$topnlink);
- ($dir,$_) = ($topdir,'.');
- $name = $topdir;
- &wanted;
-END
-}
-else {
- print <<'END';
- ($dir,$_) = ($topdir,'.');
- $name = $topdir;
- &wanted;
- $topdir = '' if $topdir eq '/';
- &dodir($topdir,$topnlink);
-END
-}
-print <<'END';
- }
- else {
- warn "Can't cd to $topdir: $!\n";
- }
- }
- else {
- unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
- ($dir,$_) = ('.', $topdir);
- }
- chdir $dir && &wanted;
- }
- chdir $cwd;
- }
-}
-
-sub dodir {
- local($dir,$nlink) = @_;
- local($dev,$ino,$mode,$subcount);
- local($name);
-
- # Get the list of files in the current directory.
-
- opendir(DIR,'.') || warn "Can't open $dir: $!\n";
- local(@filenames) = readdir(DIR);
- closedir(DIR);
-
- if ($nlink == 2) { # This dir has no subdirectories.
- for (@filenames) {
- next if $_ eq '.';
- next if $_ eq '..';
- $name = "$dir/$_";
- $nlink = 0;
- &wanted;
- }
- }
- else { # This dir has subdirectories.
- $subcount = $nlink - 2;
- for (@filenames) {
- next if $_ eq '.';
- next if $_ eq '..';
- $nlink = $prune = 0;
- $name = "$dir/$_";
-END
-print <<'END' unless $depth;
- &wanted;
-END
-print <<'END';
- if ($subcount > 0) { # Seen all the subdirs?
-
- # Get link count and check for directoriness.
-
- ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
-
- if (-d _) {
-
- # It really is a directory, so do it recursively.
-
- if (!$prune && chdir $_) {
- &dodir($name,$nlink);
- chdir '..';
- }
- --$subcount;
- }
- }
-END
-print <<'END' if $depth;
- &wanted;
-END
-print <<'END';
- }
- }
-}
-
-END
-
if ($initexec) {
print <<'END';
sub exec {
-/* $RCSfile: handy.h,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:29:08 $
+/* $RCSfile: handy.h,v $$Revision: 4.0.1.2 $$Date: 91/06/07 12:15:43 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: handy.h,v $
+ * Revision 4.0.1.2 91/06/07 12:15:43 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0.1.1 91/04/12 09:29:08 lwall
* patch1: random cleanup in cpp namespace
*
projects / p5sagit/p5-mst-13.2.git / commitdiff