See patch #4.
Perl Kit, Version 4.0
Copyright (c) 1989,1990,1991, Larry Wall
+ All rights reserved.
This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 1, or (at your option)
- any later version.
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this Kit.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this
+ Kit, in the file named "Artistic". If not, I'll be glad to provide one.
- You should have received a copy of the GNU General Public License
+ You should also have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- My interpretation of the GNU General Public License is that no Perl
- script falls under the terms of the License unless you explicitly put
- said script under the terms of the License yourself. Furthermore, any
+ For those of you that choose to use the GNU General Public License,
+ my interpretation of the GNU General Public License is that no Perl
+ script falls under the terms of the GPL unless you explicitly put
+ said script under the terms of the GPL yourself. Furthermore, any
object code linked with uperl.o does not automatically fall under the
- terms of the License, provided such object code only adds definitions
+ terms of the GPL, provided such object code only adds definitions
of subroutines and variables, and does not otherwise impair the
resulting interpreter from executing any standard Perl script. I
consider linking in C subroutines in this manner to be the moral
Public License. (This is merely an alternate way of specifying input
to the program.) You may also sell a binary produced by the dumping of
a running Perl script that belongs to you, provided that you provide or
- offer to provide the Perl source as specified by the License. (The
+ offer to provide the Perl source as specified by the GPL. (The
fact that a Perl interpreter and your code are in the same binary file
is, in this case, a form of mere aggregation.) This is my interpretation
- of the License. If you still have concerns or difficulties understanding
- my intent, feel free to contact me.
+ of the GPL. If you still have concerns or difficulties understanding
+ my intent, feel free to contact me. Of course, the Artistic License
+ spells all this out for your protection, so you may prefer to use that.
--------------------------------------------------------------------------
Perl is a language that combines some of the features of C, sed, awk and shell.
-See the manual page for more hype.
+See the manual page for more hype. There's also a Nutshell Handbook published
+by O'Reilly & Assoc. Their U.S. number is 1-800-338-6887 (dev-nuts) and
+their international number is 1-707-829-0515. E-mail to nuts@ora.com.
Perl will probably not run on machines with a small address space.
AIX/RT may need a -a switch and -DCRIPPLED_CC.
AIX RS/6000 needs to use system malloc and avoid -O on eval.c and toke.c.
AIX RS/6000 needs -D_NO_PROTO.
- SUNOS 4.0.[12] needs #define fputs(str,fp) fprintf(fp,"%s",str) in perl.h
+ SUNOS 4.0.[12] needs -DFPUTS_BOTCH.
SUNOS 3.[45] should use the system malloc.
SGI machines may need -Ddouble="long float" and -O1.
Vax-based systems may need to hand assemble teval.s with a -J switch.
Ultrix on MIPS machines may need -DLANGUAGE_C.
Ultrix 4.0 on MIPS machines may need -Olimit 2900 or so.
Ultrix 3.[01] on MIPS needs to undefine WAITPID--the system call is busted.
+ MIPS machines need /bin before /bsd43/bin in PATH.
MIPS machines may need to undef d_volatile.
MIPS machines may need to turn off -O on cmd.c, perl.c and tperl.c.
Some MIPS machines may need to undefine CASTNEGFLOAT.
If possible, send in patches such that the patch program will apply them.
Context diffs are the best, then normal diffs. Don't send ed scripts--
- I've probably changed my copy since the version you have.
+ I've probably changed my copy since the version you have. It's also
+ helpful if you send the output of "uname -a".
Watch for perl patches in comp.lang.perl. Patches will generally be
in a form usable by the patch program. If you are just now bringing up
-echo ': work around botch in SunOS 4.0.1 and 4.0.2' >>../perl.h
-echo '#ifndef fputs' >>../perl.h
-echo '#define fputs(str,fp) fprintf(fp,"%s",str)' >>../perl.h
-echo '#endif' >>../perl.h
+$ccflags="$ccflags -DFPUTS_BOTCH"
-echo ': work around botch in SunOS 4.0.1 and 4.0.2' >>../perl.h
-echo '#ifndef fputs' >>../perl.h
-echo '#define fputs(str,fp) fprintf(fp,"%s",str)' >>../perl.h
-echo '#endif' >>../perl.h
+$ccflags="$ccflags -DFPUTS_BOTCH"
--- /dev/null
+cc='/bin/cc'
+test -f $cc || cc='/usr/ccs/bin/cc'
+ldflags='-L/usr/ucblib'
+mansrc='/usr/share/man/man1'
+ccflags='-I/usr/include -I/usr/ucbinclude'
+libswanted=`echo $libswanted | sed 's/ ucb/ c ucb/'`
ccflags="$ccflags -DLANGUAGE_C"
-d_waitpid=$undef
+tmp="`(uname -a) 2>/dev/null`"
+case "$tmp" in
+*3.[01]*RISC) d_waitpid=$undef;;
+'') d_waitpid=$undef;;
+esac
+case "$tmp" in
+*RISC)
+ cmd_cflags='optimize="-g"'
+ perl_cflags='optimize="-g"'
+ tcmd_cflags='optimize="-g"'
+ tperl_cflags='optimize="-g"'
+ ;;
+esac
ccflags="$ccflags -DLANGUAGE_C -Olimit 2900"
+tmp=`(uname -a) 2>/dev/null`
+case "$tmp" in
+*RISC*) cat <<EOF
+Note that there is a bug in some versions of NFS on the DECStation that
+may cause utime() to work incorrectly. If so, regression test io/fs
+may fail if run under NFS. Ignore the failure.
+EOF
+;;
+esac
+case "$tmp" in
+*4.1*)
+ eval_cflags='optimize="-g"'
+ teval_cflags='optimize="-g"'
+ toke_cflags='optimize="-g"'
+ ttoke_cflags='optimize="-g"'
+ ;;
+esac
+
--- /dev/null
+teval_cflags='case $cc in *gcc);; *) optimize="-O";; esac'
-#define PATCHLEVEL 8
+#define PATCHLEVEL 9
-/* $Header: stab.h,v 4.0 91/03/20 01:39:49 lwall Locked $
+/* $RCSfile: stab.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:56:35 $
*
- * 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: stab.h,v $
+ * Revision 4.0.1.1 91/06/07 11:56:35 lwall
+ * patch4: new copyright notice
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ *
* Revision 4.0 91/03/20 01:39:49 lwall
* 4.0 baseline.
*
#define Nullstab Null(STAB*)
+STRLEN stab_len();
+
#define STAB_STR(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_str(stab_val(tmpstab)->str_magic) : stab_val(tmpstab))
+#define STAB_LEN(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_len(stab_val(tmpstab)->str_magic) : stab_val(tmpstab)->str_cur)
#define STAB_GET(s) (tmpstab = (s), str_get(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
#define STAB_GNUM(s) (tmpstab = (s), str_gnum(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
-/* $RCSfile: str.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:15:30 $
+/* $RCSfile: str.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:58:13 $
*
- * 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: str.c,v $
+ * Revision 4.0.1.2 91/06/07 11:58:13 lwall
+ * patch4: new copyright notice
+ * patch4: taint check on undefined string could cause core dump
+ *
* Revision 4.0.1.1 91/04/12 09:15:30 lwall
* patch1: fixed undefined environ problem
* patch1: substr($ENV{"PATH"},0,0) = "/foo:" didn't modify environment
STR *dstr;
register STR *sstr;
{
+ if (!sstr)
+ return;
#ifdef TAINT
tainted |= sstr->str_tainted;
#endif
- if (!sstr)
- return;
if (!(sstr->str_pok))
(void)str_2ptr(sstr);
if (sstr)
-/* $RCSfile: str.h,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:16:12 $
+/* $RCSfile: str.h,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:58:33 $
*
- * 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: str.h,v $
+ * Revision 4.0.1.2 91/06/07 11:58:33 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0.1.1 91/04/12 09:16:12 lwall
* patch1: you may now use "die" and "caller" in a signal handler
*
#!./perl
-# $Header: stat.t,v 4.0 91/03/20 01:54:55 lwall Locked $
+# $RCSfile: stat.t,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:02:42 $
print "1..56\n";
chop($cwd = `pwd`);
+$DEV = `ls -l /dev`;
+
unlink "Op.stat.tmp";
open(foo, ">Op.stat.tmp");
`rm -f Op.stat.tmp Op.stat.tmp2`;
if (! -e 'Op.stat.tmp') {print "ok 28\n";} else {print "not ok 28\n";}
-if (-c '/dev/tty') {print "ok 29\n";} else {print "not ok 29\n";}
+if ($DEV !~ /\nc.* (\S+)\n/)
+ {print "ok 29\n";}
+elsif (-c "/dev/$1")
+ {print "ok 29\n";}
+else
+ {print "not ok 29\n";}
if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";}
-if (! -e '/dev/printer' || -c '/dev/printer' || -S '/dev/printer')
+if ($DEV !~ /\ns.* (\S+)\n/)
+ {print "ok 31\n";}
+elsif (-S "/dev/$1")
{print "ok 31\n";}
else
{print "not ok 31\n";}
if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";}
-if (! -e '/dev/mt0' || -b '/dev/mt0')
+if ($DEV !~ /\nb.* (\S+)\n/)
+ {print "ok 33\n";}
+elsif (-b "/dev/$1")
{print "ok 33\n";}
else
{print "not ok 33\n";}
-/* $RCSfile: toke.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:18:18 $
+/* $RCSfile: toke.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 12:05: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: toke.c,v $
+ * Revision 4.0.1.2 91/06/07 12:05:56 lwall
+ * patch4: new copyright notice
+ * patch4: debugger lost track of lines in eval
+ * patch4: //o and s///o now optimize themselves fully at runtime
+ * patch4: added global modifier for pattern matches
+ *
* Revision 4.0.1.1 91/04/12 09:18:18 lwall
* patch1: perl -de "print" wouldn't stop at the first statement
*
#include <sys/file.h>
#endif
+#ifdef f_next
+#undef f_next
+#endif
+
/* which backslash sequences to keep in m// or s// */
static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtf0123456789[{]}";
s++;
if (s < d)
s++;
- if (perldb) {
- STR *str = Str_new(85,0);
-
- str_nset(str,linestr->str_ptr, s - linestr->str_ptr);
- astore(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str);
- str_chop(linestr, s);
- }
if (in_format) {
bufptr = s;
yylval.formval = load_format();
if (strEQ(d,"oct"))
UNI(O_OCT);
if (strEQ(d,"opendir"))
- FOP2(O_OPENDIR);
+ FOP2(O_OPEN_DIR);
break;
case 'p': case 'P':
SNARFWORD;
}
STR *
-scanconst(string,len)
+scanconst(spat,string,len)
+SPAT *spat;
char *string;
int len;
{
register char *t;
register char *d;
register char *e;
+ char *origstring = string;
+ static char *vert = "|";
- if (index(string,'|')) {
+ if (ninstr(string, string+len, vert, vert+1))
return Nullstr;
- }
+ if (*string == '^')
+ string++, len--;
retstr = Str_new(86,len);
str_nset(retstr,string,len);
t = str_get(retstr);
}
*d = '\0';
retstr->str_cur = d - t;
+ if (d == t+len)
+ spat->spat_flags |= SPAT_ALL;
+ if (*origstring != '^')
+ spat->spat_flags |= SPAT_SCANFIRST;
+ spat->spat_short = retstr;
+ spat->spat_slen = d - t;
return retstr;
}
return s;
}
s++;
- while (*s == 'i' || *s == 'o') {
+ while (*s == 'i' || *s == 'o' || *s == 'g') {
if (*s == 'i') {
s++;
sawi = TRUE;
s++;
spat->spat_flags |= SPAT_KEEP;
}
+ if (*s == 'g') {
+ s++;
+ spat->spat_flags |= SPAT_GLOBAL;
+ }
}
len = str->str_cur;
e = str->str_ptr + len;
#else
(void)bcopy((char *)spat, (char *)&savespat, sizeof(SPAT));
#endif
- if (*str->str_ptr == '^') {
- spat->spat_short = scanconst(str->str_ptr+1,len-1);
- if (spat->spat_short) {
- spat->spat_slen = spat->spat_short->str_cur;
- if (spat->spat_slen == len - 1)
- spat->spat_flags |= SPAT_ALL;
- }
- }
- else {
- spat->spat_flags |= SPAT_SCANFIRST;
- spat->spat_short = scanconst(str->str_ptr,len);
- if (spat->spat_short) {
- spat->spat_slen = spat->spat_short->str_cur;
- if (spat->spat_slen == len)
- spat->spat_flags |= SPAT_ALL;
- }
- }
+ scanconst(spat,str->str_ptr,len);
if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) {
fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
goto get_repl; /* skip compiling for now */
}
}
- if (*str->str_ptr == '^') {
- spat->spat_short = scanconst(str->str_ptr+1,len-1);
- if (spat->spat_short)
- spat->spat_slen = spat->spat_short->str_cur;
- }
- else {
- spat->spat_flags |= SPAT_SCANFIRST;
- spat->spat_short = scanconst(str->str_ptr,len);
- if (spat->spat_short)
- spat->spat_slen = spat->spat_short->str_cur;
- }
+ scanconst(spat,str->str_ptr,len);
get_repl:
s = scanstr(s);
if (s >= bufend) {
return s;
}
spat->spat_repl = yylval.arg;
- spat->spat_flags |= SPAT_ONCE;
if ((spat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
spat->spat_flags |= SPAT_CONST;
else if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) {
}
if (*s == 'g') {
s++;
- spat->spat_flags &= ~SPAT_ONCE;
+ spat->spat_flags |= SPAT_GLOBAL;
}
if (*s == 'i') {
s++;
hoistmust(spat)
register SPAT *spat;
{
- if (spat->spat_regexp->regmust) { /* is there a better short-circuit? */
+ if (!spat->spat_short && spat->spat_regexp->regstart &&
+ (!spat->spat_regexp->regmust || spat->spat_regexp->reganch & ROPT_ANCH)
+ ) {
+ spat->spat_short = spat->spat_regexp->regstart;
+ if (!(spat->spat_regexp->reganch & ROPT_ANCH))
+ spat->spat_flags |= SPAT_SCANFIRST;
+ }
+ else if (spat->spat_regexp->regmust) {/* is there a better short-circuit? */
if (spat->spat_short &&
str_eq(spat->spat_short,spat->spat_regexp->regmust))
{
STR *tmpstr;
char *tmps;
+ CLINE;
multi_start = curcmd->c_line;
if (hereis)
multi_open = multi_close = '<';
-/* $RCSfile: util.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:19:25 $
+/* $RCSfile: util.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 12:10:42 $
*
- * 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: util.c,v $
+ * Revision 4.0.1.2 91/06/07 12:10:42 lwall
+ * patch4: new copyright notice
+ * patch4: made some allowances for "semi-standard" C
+ * patch4: index() could blow up searching for null string
+ * patch4: taintchecks could improperly modify parent in vfork()
+ * patch4: exec would close files even if you cleared close-on-exec flag
+ *
* Revision 4.0.1.1 91/04/12 09:19:25 lwall
* patch1: random cleanup in cpp namespace
*
#endif /* MSDOS */
{
char *ptr;
-#ifndef __STDC__
+#ifndef STANDARD_C
char *malloc();
-#endif /* ! __STDC__ */
+#endif /* ! STANDARD_C */
#ifdef MSDOS
if (size > 0xffff) {
#endif /* MSDOS */
{
char *ptr;
-#ifndef __STDC__
+#ifndef STANDARD_C
char *realloc();
-#endif /* ! __STDC__ */
+#endif /* ! STANDARD_C */
#ifdef MSDOS
if (size > 0xffff) {
register unsigned char *oldlittle;
#ifndef lint
- if (!(littlestr->str_pok & SP_FBM))
+ if (!(littlestr->str_pok & SP_FBM)) {
+ if (!littlestr->str_ptr)
+ return (char*)big;
return ninstr((char*)big,(char*)bigend,
littlestr->str_ptr, littlestr->str_ptr + littlestr->str_cur);
+ }
#endif
littlelen = littlestr->str_cur;
{
char *pat;
char *s;
+#ifndef HAS_VPRINTF
#ifdef CHARVSPRINTF
char *vsprintf();
#else
int vsprintf();
#endif
+#endif
s = buf;
#ifdef lint
return Nullfp;
this = (*mode == 'w');
that = !this;
+#ifdef TAINT
+ if (doexec) {
+ taintenv();
+ taintproper("Insecure dependency in exec");
+ }
+#endif
while ((pid = (doexec?vfork():fork())) < 0) {
if (errno != EAGAIN) {
close(p[this]);
close(p[THIS]);
}
if (doexec) {
-#if !defined(I_FCNTL) || !defined(F_SETFD)
+#if !defined(HAS_FCNTL) || !defined(F_SETFD)
int fd;
#ifndef NOFILE
#define NOFILE 20
#endif
- for (fd = 3; fd < NOFILE; fd++)
+ for (fd = maxsysfd + 1; fd < NOFILE; fd++)
close(fd);
#endif
do_exec(cmd); /* may or may not use the shell */
close(newfd);
fcntl(oldfd, F_DUPFD, newfd);
#else
- int fdtmp[20];
+ int fdtmp[256];
int fdx = 0;
int fd;
-/* $Header: util.h,v 4.0 91/03/20 01:56:48 lwall Locked $
+/* $RCSfile: util.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:11:00 $
*
- * 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: util.h,v $
+ * Revision 4.0.1.1 91/06/07 12:11:00 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:56:48 lwall
* 4.0 baseline.
*
esac
echo "Extracting x2p/Makefile (with variable substitutions)"
cat >Makefile <<!GROK!THIS!
-# $Header: Makefile.SH,v 4.0 91/03/20 01:57:03 lwall Locked $
+# $RCSfile: Makefile.SH,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:12:14 $
#
# $Log: Makefile.SH,v $
+# Revision 4.0.1.1 91/06/07 12:12:14 lwall
+# patch4: cflags now emits entire cc command except for the filename
+#
# Revision 4.0 91/03/20 01:57:03 lwall
# 4.0 baseline.
#
lib = $lib
mansrc = $mansrc
manext = $manext
-CFLAGS = $ccflags $optimize
LDFLAGS = $ldflags
SMALL = $small
LARGE = $large $split
cat >>Makefile <<'!NO!SUBS!'
+CCCMD = `sh cflags $@`
+
public = a2p s2p find2perl
private =
SHELL = /bin/sh
.c.o:
- $(CC) -c $(CFLAGS) $(LARGE) $*.c
+ $(CCCMD) $*.c
all: $(public) $(private) $(util)
touch all
a2p: $(obj) a2p.o
- $(CC) $(LARGE) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p
+ $(CC) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p
a2p.c: a2p.y
@ echo Expect 226 shift/reduce conflicts...
mv y.tab.c a2p.c
a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h
- $(CC) -c $(CFLAGS) $(LARGE) a2p.c
+ $(CCCMD) $(LARGE) a2p.c
install: a2p s2p
# won't work with csh
for pub in $(public); do \
chmod +x `basename $$pub`; \
done
-# chmod +x makedir
-# - ./makedir `filexp $(lib)`
-# - \
-#if test `pwd` != `filexp $(lib)`; then \
-#cp $(private) `filexp $(lib)`; \
-#fi
-# cd `filexp $(lib)`; \
-#for priv in $(private); do \
-#chmod +x `basename $$priv`; \
-#done
- if test `pwd` != $(mansrc); then \
for page in $(manpages); do \
cp $$page $(mansrc)/`basename $$page .man`.$(manext); \
rm -f a2p *.o
realclean: clean
- rm -f *.orig */*.orig core $(addedbyconf) a2p.c s2p all
+ rm -f *.orig */*.orig core $(addedbyconf) a2p.c s2p find2perl all cflags
# The following lint has practically everything turned on. Unfortunately,
# you have to wade through a lot of mumbo jumbo that can't be suppressed.
-/* $Header: str.c,v 4.0 91/03/20 01:58:15 lwall Locked $
+/* $RCSfile: str.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20:08 $
*
- * 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: str.c,v $
+ * Revision 4.0.1.1 91/06/07 12:20:08 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:58:15 lwall
* 4.0 baseline.
*
-/* $Header: str.h,v 4.0 91/03/20 01:58:21 lwall Locked $
+/* $RCSfile: str.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20:22 $
*
- * 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: str.h,v $
+ * Revision 4.0.1.1 91/06/07 12:20:22 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:58:21 lwall
* 4.0 baseline.
*
-/* $Header: util.c,v 4.0 91/03/20 01:58:25 lwall Locked $
+/* $RCSfile: util.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20:35 $
*
- * 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: util.c,v $
+ * Revision 4.0.1.1 91/06/07 12:20:35 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:58:25 lwall
* 4.0 baseline.
*
-/* $Header: util.h,v 4.0 91/03/20 01:58:29 lwall Locked $
+/* $RCSfile: util.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20: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: util.h,v $
+ * Revision 4.0.1.1 91/06/07 12:20:43 lwall
+ * patch4: new copyright notice
+ *
* Revision 4.0 91/03/20 01:58:29 lwall
* 4.0 baseline.
*
-/* $Header: walk.c,v 4.0 91/03/20 01:58:36 lwall Locked $
+/* $RCSfile: walk.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:22:04 $
*
- * 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: walk.c,v $
+ * Revision 4.0.1.1 91/06/07 12:22:04 lwall
+ * patch4: new copyright notice
+ * patch4: a2p didn't correctly implement -n switch
+ *
* Revision 4.0 91/03/20 01:58:36 lwall
* 4.0 baseline.
*
bool subretnum = FALSE;
bool saw_FNR = FALSE;
bool saw_argv0 = FALSE;
+bool saw_fh = FALSE;
int maxtmp = 0;
char *lparen;
char *rparen;
type &= 255;
switch (type) {
case OPROG:
+ arymax = 0;
+ if (namelist) {
+ while (isalpha(*namelist)) {
+ for (d = tokenbuf,s=namelist;
+ isalpha(*s) || isdigit(*s) || *s == '_';
+ *d++ = *s++) ;
+ *d = '\0';
+ while (*s && !isalpha(*s)) s++;
+ namelist = s;
+ nameary[++arymax] = savestr(tokenbuf);
+ }
+ }
+ if (maxfld < arymax)
+ maxfld = arymax;
opens = str_new(0);
subs = str_new(0);
str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
str_cat(str,"chop;\t# strip record separator\n");
tab(str,level);
}
- arymax = 0;
- if (namelist) {
- while (isalpha(*namelist)) {
- for (d = tokenbuf,s=namelist;
- isalpha(*s) || isdigit(*s) || *s == '_';
- *d++ = *s++) ;
- *d = '\0';
- while (*s && !isalpha(*s)) s++;
- namelist = s;
- nameary[++arymax] = savestr(tokenbuf);
- }
- }
- if (maxfld < arymax)
- maxfld = arymax;
if (do_split)
emit_split(str,level);
str_scat(str,fstr);
s = savestr(tokenbuf);
for (t = tokenbuf; *t; t++) {
*t &= 127;
+ if (islower(*t))
+ *t = toupper(*t);
if (!isalpha(*t) && !isdigit(*t))
*t = '_';
}
if (!index(tokenbuf,'_'))
- strcpy(t,"_fh");
+ strcpy(t,"_FH");
tmp3str = hfetch(symtab,tokenbuf);
if (!tmp3str) {
do_opens = TRUE;
s = savestr(tokenbuf);
for (t = tokenbuf; *t; t++) {
*t &= 127;
+ if (islower(*t))
+ *t = toupper(*t);
if (!isalpha(*t) && !isdigit(*t))
*t = '_';
}
if (!index(tokenbuf,'_'))
- strcpy(t,"_fh");
+ strcpy(t,"_FH");
str_free(tmpstr);
safefree(s);
str_set(str,"close ");
s = savestr(tokenbuf);
for (t = tokenbuf; *t; t++) {
*t &= 127;
+ if (islower(*t))
+ *t = toupper(*t);
if (!isalpha(*t) && !isdigit(*t))
*t = '_';
}
if (!index(tokenbuf,'_'))
- strcpy(t,"_fh");
+ strcpy(t,"_FH");
tmp3str = hfetch(symtab,tokenbuf);
if (!tmp3str) {
str_cat(opens,"open(");
str_cat(str,"printf");
else
str_cat(str,"print");
+ saw_fh = 0;
if (len == 3 || do_fancy_opens) {
- if (*tokenbuf)
+ if (*tokenbuf) {
str_cat(str," ");
+ saw_fh = 1;
+ }
str_cat(str,tokenbuf);
}
tmpstr = walk(1+(type==OPRINT),level,ops[node+1].ival,&numarg,P_MIN);
}
if (*tmpstr->str_ptr) {
str_cat(str," ");
- str_scat(str,tmpstr);
+ if (!saw_fh && *tmpstr->str_ptr == '(') {
+ str_cat(str,"(");
+ str_scat(str,tmpstr);
+ str_cat(str,")");
+ }
+ else
+ str_scat(str,tmpstr);
}
else {
str_cat(str," $_");
projects / p5sagit/p5-mst-13.2.git / commitdiff