See patch #29.
-/* $Header: arg.h,v 3.0.1.6 90/08/09 02:25:14 lwall Locked $
+/* $Header: arg.h,v 3.0.1.7 90/10/15 14:53:59 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: arg.h,v $
+ * Revision 3.0.1.7 90/10/15 14:53:59 lwall
+ * patch29: added SysV IPC
+ * patch29: added waitpid
+ * patch29: added cmp and <=>
+ * patch29: added caller
+ * patch29: added scalar
+ * patch29: added sysread and syswrite
+ * patch29: added -M, -A and -C
+ * patch29: index and substr now have optional 3rd args
+ * patch29: you can now read into the middle string
+ * patch29: various portability fixes
+ *
* Revision 3.0.1.6 90/08/09 02:25:14 lwall
* patch19: added require operator
* patch19: added truncate operator
#define O_EACH 89
#define O_CHOP 90
#define O_FORK 91
-#define O_EXEC 92
+#define O_EXEC_OP 92
#define O_SYSTEM 93
#define O_OCT 94
#define O_HEX 95
#define O_BINMODE 243
#define O_REQUIRE 244
#define O_TRUNCATE 245
-#define MAXO 246
+#define O_MSGGET 246
+#define O_MSGCTL 247
+#define O_MSGSND 248
+#define O_MSGRCV 249
+#define O_SEMGET 250
+#define O_SEMCTL 251
+#define O_SEMOP 252
+#define O_SHMGET 253
+#define O_SHMCTL 254
+#define O_SHMREAD 255
+#define O_SHMWRITE 256
+#define O_NCMP 257
+#define O_SCMP 258
+#define O_CALLER 259
+#define O_SCALAR 260
+#define O_SYSREAD 261
+#define O_SYSWRITE 262
+#define O_FTMTIME 263
+#define O_FTATIME 264
+#define O_FTCTIME 265
+#define O_WAITPID 266
+#define MAXO 267
#ifndef DOINIT
extern char *opname[];
"BINMODE",
"REQUIRE",
"TRUNCATE",
- "245"
+ "MSGGET",
+ "MSGCTL",
+ "MSGSND",
+ "MSGRCV",
+ "SEMGET",
+ "SEMCTL",
+ "SEMOP",
+ "SHMGET",
+ "SHMCTL",
+ "SHMREAD",
+ "SHMWRITE",
+ "NCMP",
+ "SCMP",
+ "CALLER",
+ "SCALAR",
+ "SYSREAD",
+ "SYSWRITE",
+ "FTMTIME",
+ "FTATIME",
+ "FTCTIME",
+ "WAITPID",
+ "264"
};
#endif
struct arg {
union argptr arg_ptr;
short arg_len;
-#ifdef mips
- short pad;
-#endif
- unsigned char arg_type;
- unsigned char arg_flags;
+ unsigned short arg_type;
+ unsigned short arg_flags;
};
#define AF_ARYOK 1 /* op can handle multiple values here */
#define Nullarg Null(ARG*)
#ifndef DOINIT
-EXT char opargs[MAXO+1];
+EXT unsigned short opargs[MAXO+1];
#else
-#define A(e1,e2,e3) (e1+(e2<<2)+(e3<<4))
-char opargs[MAXO+1] = {
+#define A(e1,e2,e3) (e1+(e2<<2)+(e3<<4))
+#define A5(e1,e2,e3,e4,e5) (e1+(e2<<2)+(e3<<4)+(e4<<6)+(e5<<8))
+unsigned short opargs[MAXO+1] = {
A(0,0,0), /* NULL */
A(1,0,0), /* ITEM */
A(0,0,0), /* ITEM2 */
A(0,0,0), /* NEXT */
A(0,0,0), /* REDO */
A(0,0,0), /* GOTO */
- A(1,1,0), /* INDEX */
+ A(1,1,1), /* INDEX */
A(0,0,0), /* TIME */
A(0,0,0), /* TIMES */
A(1,0,0), /* LOCALTIME */
A(1,1,1), /* IOCTL */
A(1,1,1), /* FCNTL */
A(1,1,0), /* FLOCK */
- A(1,1,0), /* RINDEX */
+ A(1,1,1), /* RINDEX */
A(1,3,0), /* PACK */
A(1,1,0), /* UNPACK */
- A(1,1,1), /* READ */
+ A(1,1,3), /* READ */
A(0,3,0), /* WARN */
A(1,1,1), /* DBMOPEN */
A(1,0,0), /* DBMCLOSE */
A(1,1,0), /* LISTEN */
A(1,1,0), /* ACCEPT */
A(1,1,3), /* SEND */
- A(1,1,1), /* RECV */
+ A(1,1,3), /* RECV */
A(1,1,1), /* SSELECT */
A(1,1,1), /* SOCKPAIR */
A(0,3,0), /* DBSUBR */
A(1,0,0), /* BINMODE */
A(1,0,0), /* REQUIRE */
A(1,1,0), /* TRUNCATE */
+ A(1,1,0), /* MSGGET */
+ A(1,1,1), /* MSGCTL */
+ A(1,1,1), /* MSGSND */
+ A5(1,1,1,1,1), /* MSGRCV */
+ A(1,1,1), /* SEMGET */
+ A5(1,1,1,1,0), /* SEMCTL */
+ A(1,1,1), /* SEMOP */
+ A(1,1,1), /* SHMGET */
+ A(1,1,1), /* SHMCTL */
+ A5(1,1,1,1,0), /* SHMREAD */
+ A5(1,1,1,1,0), /* SHMWRITE */
+ A(1,1,0), /* NCMP */
+ A(1,1,0), /* SCMP */
+ A(1,0,0), /* CALLER */
+ A(1,0,0), /* SCALAR */
+ A(1,1,3), /* SYSREAD */
+ A(1,1,3), /* SYSWRITE */
+ A(1,0,0), /* FTMTIME */
+ A(1,0,0), /* FTATIME */
+ A(1,0,0), /* FTCTIME */
+ A(1,1,0), /* WAITPID */
0
};
#undef A
+#undef A5
#endif
int do_trans();
-/* $Header: array.c,v 3.0.1.2 90/08/13 21:52:20 lwall Locked $
+/* $Header: array.c,v 3.0.1.3 90/10/15 14:56:17 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: array.c,v $
+ * Revision 3.0.1.3 90/10/15 14:56:17 lwall
+ * patch29: non-existent array values no longer cause core dumps
+ *
* Revision 3.0.1.2 90/08/13 21:52:20 lwall
* patch28: defined(@array) and defined(%array) didn't work right
*
return str;
}
else
- return Nullstr;
+ return &str_undef;
}
- if (lval && !ar->ary_array[key]) {
- str = Str_new(6,0);
- (void)astore(ar,key,str);
- return str;
+ if (!ar->ary_array[key]) {
+ if (lval) {
+ str = Str_new(6,0);
+ (void)astore(ar,key,str);
+ return str;
+ }
+ return &str_undef;
}
return ar->ary_array[key];
}
-/* $Header: cmd.c,v 3.0.1.8 90/08/09 02:28:49 lwall Locked $
+/* $Header: cmd.c,v 3.0.1.9 90/10/15 15:32:39 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cmd.c,v $
+ * Revision 3.0.1.9 90/10/15 15:32:39 lwall
+ * patch29: non-existent array values no longer cause core dumps
+ * patch29: scripts now run at almost full speed under the debugger
+ * patch29: @ENV = () now works
+ * patch29: added caller
+ *
* Revision 3.0.1.8 90/08/09 02:28:49 lwall
* patch19: did preliminary work toward debugging packages and evals
* patch19: conditionals now always supply a scalar context to expression
}
else {
match++;
- retstr = stab_val(cmd->c_stab) = ar->ary_array[match];
+ if (!(retstr = ar->ary_array[match]))
+ retstr = afetch(ar,match,TRUE);
+ stab_val(cmd->c_stab) = retstr;
cmd->c_short->str_u.str_useful = match;
match = TRUE;
}
newsp = -2;
goto maybe;
+ case CFT_D1:
+ break;
+ case CFT_D0:
+ if (DBsingle->str_u.str_nval != 0)
+ break;
+ if (DBsignal->str_u.str_nval != 0)
+ break;
+ if (DBtrace->str_u.str_nval != 0)
+ break;
+ goto next_cmd;
}
/* we have tried to make this normal case as abnormal as possible */
break;
case SS_SHASH: /* hash reference */
stab = value->str_u.str_stab;
- (void)hfree(stab_xhash(stab));
+ (void)hfree(stab_xhash(stab), FALSE);
stab_xhash(stab) = (HASH*)value->str_ptr;
value->str_ptr = Nullch;
str_free(value);
(void)stab_clear(stab);
str_free(value);
break;
+ case SS_SCSV: /* callsave structure */
+ {
+ CSV *csv = (CSV*) value->str_ptr;
+
+ curcmd = csv->curcmd;
+ curcsv = csv->curcsv;
+ csv->sub->depth = csv->depth;
+ if (csv->hasargs) { /* put back old @_ */
+ afree(csv->argarray);
+ stab_xarray(defstab) = csv->savearray;
+ }
+ str_free(value);
+ }
+ break;
default:
fatal("panic: restorelist inconsistency");
}
-/* $Header: cmd.h,v 3.0.1.3 90/08/09 02:29:58 lwall Locked $
+/* $Header: cmd.h,v 3.0.1.4 90/10/15 15:34:50 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cmd.h,v $
+ * Revision 3.0.1.4 90/10/15 15:34:50 lwall
+ * patch29: scripts now run at almost full speed under the debugger
+ * patch29: added caller
+ *
* Revision 3.0.1.3 90/08/09 02:29:58 lwall
* patch19: did preliminary work toward debugging packages and evals
*
#define CFT_INDGETS 11 /* c_expr is <$variable> */
#define CFT_NUMOP 12 /* c_expr is a numeric comparison */
#define CFT_CCLASS 13 /* c_expr must start with one of these characters */
+#define CFT_D0 14 /* no special breakpoint at this line */
+#define CFT_D1 15 /* possible special breakpoint at this line */
#ifdef DEBUGGING
#ifndef DOINIT
} ucmd;
short c_slen; /* len of c_short, if not null */
VOLATILE short c_flags; /* optimization flags--see above */
- char *c_pack; /* package line was compiled in */
- char *c_file; /* file the following line # is from */
+ HASH *c_stash; /* package line was compiled in */
+ STAB *c_filestab; /* file the following line # is from */
line_t c_line; /* line # of this command */
char c_type; /* what this command does */
};
#define Nullcmd Null(CMD*)
+#define Nullcsv Null(CSV*)
EXT CMD * VOLATILE main_root INIT(Nullcmd);
EXT CMD * VOLATILE eval_root INIT(Nullcmd);
EXT CMD compiling;
EXT CMD * VOLATILE curcmd INIT(&compiling);
+EXT CSV * VOLATILE curcsv INIT(Nullcsv);
+
+struct callsave {
+ SUBR *sub;
+ STAB *stab;
+ CSV *curcsv;
+ CMD *curcmd;
+ ARRAY *savearray;
+ ARRAY *argarray;
+ long depth;
+ int wantarray;
+ char hasargs;
+};
struct compcmd {
CMD *comp_true;
*/
#$d_syscall SYSCALL /**/
+/* SYSVIPC:
+ * This symbol, if defined, indicates that System V IPC exists.
+ */
+#$d_sysvipc SYSVIPC /**/
+
/* TRUNCATE:
* This symbol, if defined, indicates that the truncate routine is
* available to truncate files.
*/
#$d_wait4 WAIT4 /**/
+/* WAITPID:
+ * This symbol, if defined, indicates that waitpid() exists.
+ */
+#$d_waitpid WAITPID /**/
+
/* GIDTYPE:
* This symbol has a value like gid_t, int, ushort, or whatever type is
* used to declare group ids in the kernel.
* This symbol, if defined, indicates to the C program that it should
* include pwd.h.
*/
+/* PWCOMMENT:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_comment.
+ */
/* PWQUOTA:
* This symbol, if defined, indicates to the C program that struct passwd
* contains pw_quota.
* contains pw_expire.
*/
#$i_pwd I_PWD /**/
+#$d_pwcomment PWCOMMENT /**/
#$d_pwquota PWQUOTA /**/
#$d_pwage PWAGE /**/
#$d_pwchange PWCHANGE /**/
-/* $Header: cons.c,v 3.0.1.7 90/08/09 02:35:52 lwall Locked $
+/* $Header: cons.c,v 3.0.1.8 90/10/15 15:41:09 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cons.c,v $
+ * Revision 3.0.1.8 90/10/15 15:41:09 lwall
+ * patch29: added caller
+ * patch29: scripts now run at almost full speed under the debugger
+ * patch29: the debugger now understands packages and evals
+ * patch29: package behavior is now more consistent
+ *
* Revision 3.0.1.7 90/08/09 02:35:52 lwall
* patch19: did preliminary work toward debugging packages and evals
* patch19: Added support for linked-in C subroutines
}
Safefree(stab_sub(stab));
}
- sub->filename = filename;
+ sub->filestab = curcmd->c_filestab;
saw_return = FALSE;
tosave = anew(Nullstab);
tosave->ary_fill = 0; /* make 1 based */
sub->cmd = cmd;
stab_sub(stab) = sub;
if (perldb) {
- STR *str = str_nmake((double)subline);
+ STR *str;
+ STR *tmpstr = str_static(&str_undef);
+ sprintf(buf,"%s:%ld",stab_val(curcmd->c_filestab)->str_ptr,
+ (long)subline);
+ str = str_make(buf,0);
str_cat(str,"-");
sprintf(buf,"%ld",(long)curcmd->c_line);
str_cat(str,buf);
name = str_get(subname);
- hstore(stab_xhash(DBsub),name,strlen(name),str,0);
+ stab_fullname(tmpstr,stab);
+ hstore(stab_xhash(DBsub), tmpstr->str_ptr, tmpstr->str_cur, str, 0);
str_set(subname,"main");
}
subline = 0;
}
Safefree(stab_sub(stab));
}
- sub->filename = filename;
+ sub->filestab = fstab(filename);
sub->usersub = subaddr;
sub->userindex = ix;
stab_sub(stab) = sub;
head = cur;
if (!head->c_line)
return cur;
- str = afetch(lineary,(int)head->c_line,FALSE);
- if (!str || str->str_nok)
+ str = afetch(stab_xarray(curcmd->c_filestab),(int)head->c_line,FALSE);
+ if (str == &str_undef || str->str_nok)
return cur;
str->str_u.str_nval = (double)head->c_line;
str->str_nok = 1;
Newz(106,cmd,1,CMD);
+ str_magic(str, curcmd->c_filestab, 0, Nullch, 0);
+ str->str_magic->str_u.str_cmd = cmd;
cmd->c_type = C_EXPR;
cmd->ucmd.acmd.ac_stab = Nullstab;
cmd->ucmd.acmd.ac_expr = Nullarg;
- arg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg);
- arg[1].arg_type = A_SINGLE;
- arg[1].arg_ptr.arg_str = str_nmake((double)head->c_line);
- cmd->c_expr = make_op(O_SUBR, 2,
+ cmd->c_expr = make_op(O_SUBR, 1,
stab2arg(A_WORD,DBstab),
- make_list(arg),
+ Nullarg,
Nullarg);
- cmd->c_flags |= CF_COND|CF_DBSUB;
+ cmd->c_flags |= CF_COND|CF_DBSUB|CFT_D0;
cmd->c_line = head->c_line;
cmd->c_label = head->c_label;
- cmd->c_file = filename;
- cmd->c_pack = curpack;
+ cmd->c_filestab = curcmd->c_filestab;
+ cmd->c_stash = curstash;
return append_line(cmd, cur);
}
cmd->c_line = cmdline;
cmdline = NOLINE;
}
- cmd->c_file = filename;
- cmd->c_pack = curpack;
+ cmd->c_filestab = curcmd->c_filestab;
+ cmd->c_stash = curstash;
if (perldb)
cmd = dodb(cmd);
return cmd;
cmd->c_line = cmdline;
cmdline = NOLINE;
}
+ cmd->c_filestab = curcmd->c_filestab;
+ cmd->c_stash = curstash;
if (perldb)
cmd = dodb(cmd);
return cmd;
cmd->c_line = cmdline;
cmdline = NOLINE;
}
+ cmd->c_filestab = curcmd->c_filestab;
+ cmd->c_stash = curstash;
cur = cmd;
alt = cblock.comp_alt;
while (alt && alt->c_type == C_ELSIF) {
else
(void)sprintf(tname,"next char %c",yychar);
(void)sprintf(buf, "%s in file %s at line %d, %s\n",
- s,filename,curcmd->c_line,tname);
+ s,stab_val(curcmd->c_filestab)->str_ptr,curcmd->c_line,tname);
if (curcmd->c_line == multi_end && multi_start < multi_end)
sprintf(buf+strlen(buf),
" (Might be a runaway multi-line %c%c string starting on line %d)\n",
else
fputs(buf,stderr);
if (++error_count >= 10)
- fatal("%s has too many errors.\n", filename);
+ fatal("%s has too many errors.\n",
+ stab_val(curcmd->c_filestab)->str_ptr);
}
void
-/* $Header: consarg.c,v 3.0.1.6 90/08/09 02:38:51 lwall Locked $
+/* $Header: consarg.c,v 3.0.1.7 90/10/15 15:55:28 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: consarg.c,v $
+ * Revision 3.0.1.7 90/10/15 15:55:28 lwall
+ * patch29: defined @foo was behaving inconsistently
+ * patch29: -5 % 5 was wrong
+ * patch29: package behavior is now more consistent
+ *
* Revision 3.0.1.6 90/08/09 02:38:51 lwall
* patch19: fixed problem with % of negative number
*
register SPAT *spat;
register ARG *newarg;
+ if (!pat)
+ return Nullarg;
+
if ((pat->arg_type == O_MATCH ||
pat->arg_type == O_SUBST ||
pat->arg_type == O_TRANS ||
{
register ARG *arg;
register ARG *chld;
- register int doarg;
+ register unsigned doarg;
+ register int i;
extern ARG *arg4; /* should be normal arguments, really */
extern ARG *arg5;
arg = op_new(newlen);
arg->arg_type = type;
- doarg = opargs[type];
if (chld = arg1) {
if (chld->arg_type == O_ITEM &&
- (hoistable[chld[1].arg_type] || chld[1].arg_type == A_LVAL ||
- (chld[1].arg_type == A_LEXPR &&
+ (hoistable[ i = (chld[1].arg_type&A_MASK)] || i == A_LVAL ||
+ (i == A_LEXPR &&
(chld[1].arg_ptr.arg_arg->arg_type == O_LIST ||
chld[1].arg_ptr.arg_arg->arg_type == O_ARRAY ||
chld[1].arg_ptr.arg_arg->arg_type == O_HASH ))))
arg[1].arg_type = A_EXPR;
arg[1].arg_ptr.arg_arg = chld;
}
- if (!(doarg & 1))
- arg[1].arg_type |= A_DONT;
- if (doarg & 2)
- arg[1].arg_flags |= AF_ARYOK;
}
- doarg >>= 2;
if (chld = arg2) {
if (chld->arg_type == O_ITEM &&
- (hoistable[chld[1].arg_type] ||
+ (hoistable[chld[1].arg_type&A_MASK] ||
(type == O_ASSIGN &&
((chld[1].arg_type == A_READ && !(arg[1].arg_type & A_DONT))
||
arg[2].arg_type = A_EXPR;
arg[2].arg_ptr.arg_arg = chld;
}
- if (!(doarg & 1))
- arg[2].arg_type |= A_DONT;
- if (doarg & 2)
- arg[2].arg_flags |= AF_ARYOK;
}
- doarg >>= 2;
if (chld = arg3) {
- if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) {
+ if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
arg[3].arg_type = chld[1].arg_type;
arg[3].arg_ptr = chld[1].arg_ptr;
arg[3].arg_len = chld[1].arg_len;
arg[3].arg_type = A_EXPR;
arg[3].arg_ptr.arg_arg = chld;
}
- if (!(doarg & 1))
- arg[3].arg_type |= A_DONT;
- if (doarg & 2)
- arg[3].arg_flags |= AF_ARYOK;
}
if (newlen >= 4 && (chld = arg4)) {
- if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) {
+ if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
arg[4].arg_type = chld[1].arg_type;
arg[4].arg_ptr = chld[1].arg_ptr;
arg[4].arg_len = chld[1].arg_len;
}
}
if (newlen >= 5 && (chld = arg5)) {
- if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) {
+ if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
arg[5].arg_type = chld[1].arg_type;
arg[5].arg_ptr = chld[1].arg_ptr;
arg[5].arg_len = chld[1].arg_len;
arg[5].arg_ptr.arg_arg = chld;
}
}
+ doarg = opargs[type];
+ for (i = 1; i <= newlen; ++i) {
+ if (!(doarg & 1))
+ arg[i].arg_type |= A_DONT;
+ if (doarg & 2)
+ arg[i].arg_flags |= AF_ARYOK;
+ doarg >>= 2;
+ }
#ifdef DEBUGGING
if (debug & 16) {
fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]);
if (tmp2 >= 0)
str_numset(str,(double)(tmp2 % tmplong));
else
- str_numset(str,(double)(tmplong - ((-tmp2 - 1) % tmplong))) - 1;
+ str_numset(str,(double)((tmplong-((-tmp2 - 1) % tmplong)) - 1));
#else
tmp2 = tmp2;
#endif
value = str_gnum(s1);
str_numset(str,(value != str_gnum(s2)) ? 1.0 : 0.0);
break;
+ case O_NCMP:
+ value = str_gnum(s1);
+ value -= str_gnum(s2);
+ if (value > 0.0)
+ value = 1.0;
+ else if (value < 0.0)
+ value = -1.0;
+ str_numset(str,value);
+ break;
case O_BIT_AND:
value = str_gnum(s1);
#ifndef lint
case O_SNE:
str_numset(str,(double)(!str_eq(s1,s2)));
break;
+ case O_SCMP:
+ str_numset(str,(double)(str_cmp(s1,s2)));
+ break;
case O_CRYPT:
#ifdef CRYPT
tmps = str_get(s1);
}
ARG *
-fixeval(arg)
-ARG *arg;
-{
- Renew(arg, 3, ARG);
- if (arg->arg_len == 0)
- arg[1].arg_type = A_NULL;
- arg->arg_len = 2;
- arg[2].arg_flags = 0;
- arg[2].arg_ptr.arg_hash = curstash;
- arg[2].arg_type = A_NULL;
- return arg;
-}
-
-ARG *
rcatmaybe(arg)
ARG *arg;
{
--- /dev/null
+#!/usr/bin/perl
+
+# Open in their package.
+
+sub cacheout'open {
+ open($_[0], $_[1]);
+}
+
+# But only this sub name is visible to them.
+
+sub cacheout {
+ package cacheout;
+
+ ($file) = @_;
+ ($package) = caller;
+ if (!$isopen{$file}) {
+ if (++$numopen > $maxopen) {
+ sub byseq {$isopen{$a} != $isopen{$b};}
+ local(@lru) = sort byseq keys(%isopen);
+ splice(@lru, $maxopen / 3);
+ $numopen -= @lru;
+ for (@lru) { close $_; delete $isopen{$_}; }
+ }
+ &open($file, ($saw{$file}++ ? '>>' : '>') . $file)
+ || die "Can't create $file: $!\n";
+ }
+ $isopen{$file} = ++$seq;
+}
+
+package cacheout;
+
+$seq = 0;
+$numopen = 0;
+
+if (open(PARAM,'/usr/include/sys/param.h')) {
+ local($.);
+ while (<PARAM>) {
+ $maxopen = $1 - 4 if /^#define NOFILE\s+(\d+)/;
+ }
+ close PARAM;
+}
+$maxopen = 16 unless $maxopen;
+
+1;
--- /dev/null
+(-W1 -Od -Ocgelt a2p.y{a2py.c})
+(-W1 -Od -Ocgelt hash.c str.c util.c walk.c)
+
+setargv.obj
+a2p.def
+a2p.exe
+
+-AL -LB -S0xA000
--- /dev/null
+NAME AWK2PERL WINDOWCOMPAT NEWFILES
+DESCRIPTION 'AWK to PERL translator - for MS-DOS and OS/2'
#define GETPPID
#define GETPRIORITY
#define SETPRIORITY
-#define SYSCALL
#define KILL
#endif /* OS2 */
* This symbol, if defined, indicates to the C program that it should
* include fcntl.h.
*/
-#define I_FCNTL /**/
+/*#define I_FCNTL /**/
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
* execution path, but it should be accessible by the world. The program
* should be prepared to do ^ expansion.
*/
-#define PRIVLIB "/usr/local/lib/perl" /**/
+#define PRIVLIB "c:/bin/perl" /**/
/*
* BUGGY_MSC:
--- /dev/null
+/*
+ * @(#) dir.h 1.4 87/11/06 Public Domain.
+ *
+ * A public domain implementation of BSD directory routines for
+ * MS-DOS. Written by Michael Rendell ({uunet,utai}michael@garfield),
+ * August 1987
+ *
+ * Enhanced and ported to OS/2 by Kai Uwe Rommel; added scandir() prototype
+ * December 1989, February 1990
+ */
+
+
+#define MAXNAMLEN 12
+#define MAXPATHLEN 128
+
+#define A_RONLY 0x01
+#define A_HIDDEN 0x02
+#define A_SYSTEM 0x04
+#define A_LABEL 0x08
+#define A_DIR 0x10
+#define A_ARCHIVE 0x20
+
+
+struct direct
+{
+ ino_t d_ino; /* a bit of a farce */
+ int d_reclen; /* more farce */
+ int d_namlen; /* length of d_name */
+ char d_name[MAXNAMLEN + 1]; /* null terminated */
+ long d_size; /* size in bytes */
+ int d_mode; /* DOS or OS/2 file attributes */
+};
+
+/* The fields d_size and d_mode are extensions by me (Kai Uwe Rommel).
+ * The find_first and find_next calls deliver this data without any extra cost.
+ * If this data is needed, these fields save a lot of extra calls to stat()
+ * (each stat() again performs a find_first call !).
+ */
+
+struct _dircontents
+{
+ char *_d_entry;
+ long _d_size;
+ int _d_mode;
+ struct _dircontents *_d_next;
+};
+
+typedef struct _dirdesc
+{
+ int dd_id; /* uniquely identify each open directory */
+ long dd_loc; /* where we are in directory entry is this */
+ struct _dircontents *dd_contents; /* pointer to contents of dir */
+ struct _dircontents *dd_cp; /* pointer to current position */
+}
+DIR;
+
+
+extern DIR *opendir(char *);
+extern struct direct *readdir(DIR *);
+extern void seekdir(DIR *, long);
+extern long telldir(DIR *);
+extern void closedir(DIR *);
+#define rewinddir(dirp) seekdir(dirp, 0L)
+
+extern int scandir(char *, struct direct ***,
+ int (*)(struct direct *),
+ int (*)(struct direct *, struct direct *));
+
+extern int getfmode(char *);
+extern int setfmode(char *, unsigned);
+
+/*
+NAME
+ opendir, readdir, telldir, seekdir, rewinddir, closedir -
+ directory operations
+
+SYNTAX
+ #include <sys/types.h>
+ #include <sys/dir.h>
+
+ DIR *opendir(filename)
+ char *filename;
+
+ struct direct *readdir(dirp)
+ DIR *dirp;
+
+ long telldir(dirp)
+ DIR *dirp;
+
+ seekdir(dirp, loc)
+ DIR *dirp;
+ long loc;
+
+ rewinddir(dirp)
+ DIR *dirp;
+
+ int closedir(dirp)
+ DIR *dirp;
+
+DESCRIPTION
+ The opendir library routine opens the directory named by
+ filename and associates a directory stream with it. A
+ pointer is returned to identify the directory stream in sub-
+ sequent operations. The pointer NULL is returned if the
+ specified filename can not be accessed, or if insufficient
+ memory is available to open the directory file.
+
+ The readdir routine returns a pointer to the next directory
+ entry. It returns NULL upon reaching the end of the direc-
+ tory or on detecting an invalid seekdir operation. The
+ readdir routine uses the getdirentries system call to read
+ directories. Since the readdir routine returns NULL upon
+ reaching the end of the directory or on detecting an error,
+ an application which wishes to detect the difference must
+ set errno to 0 prior to calling readdir.
+
+ The telldir routine returns the current location associated
+ with the named directory stream. Values returned by telldir
+ are good only for the lifetime of the DIR pointer from which
+ they are derived. If the directory is closed and then reo-
+ pened, the telldir value may be invalidated due to
+ undetected directory compaction.
+
+ The seekdir routine sets the position of the next readdir
+ operation on the directory stream. Only values returned by
+ telldir should be used with seekdir.
+
+ The rewinddir routine resets the position of the named
+ directory stream to the beginning of the directory.
+
+ The closedir routine closes the named directory stream and
+ returns a value of 0 if successful. Otherwise, a value of -1
+ is returned and errno is set to indicate the error. All
+ resources associated with this directory stream are
+ released.
+
+EXAMPLE
+ The following sample code searches a directory for the entry
+ name.
+
+ len = strlen(name);
+
+ dirp = opendir(".");
+
+ for (dp = readdir(dirp); dp != NULL; dp = readdir(dirp))
+
+ if (dp->d_namlen == len && !strcmp(dp->d_name, name)) {
+
+ closedir(dirp);
+
+ return FOUND;
+
+ }
+
+ closedir(dirp);
+
+ return NOT_FOUND;
+
+
+SEE ALSO
+ close(2), getdirentries(2), lseek(2), open(2), read(2),
+ dir(5)
+*/
--- /dev/null
+/*
+ * @(#)dir.c 1.4 87/11/06 Public Domain.
+ *
+ * A public domain implementation of BSD directory routines for
+ * MS-DOS. Written by Michael Rendell ({uunet,utai}michael@garfield),
+ * August 1897
+ * Ported to OS/2 by Kai Uwe Rommel
+ * December 1989
+ */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <sys/dir.h>
+
+#include <stdio.h>
+#include <malloc.h>
+#include <string.h>
+
+#define INCL_NOPM
+#include <os2.h>
+
+
+int attributes = A_DIR | A_HIDDEN;
+
+
+static char *getdirent(char *);
+static void free_dircontents(struct _dircontents *);
+
+static HDIR hdir;
+static USHORT count;
+static FILEFINDBUF find;
+
+
+DIR *opendir(char *name)
+{
+ struct stat statb;
+ DIR *dirp;
+ char c;
+ char *s;
+ struct _dircontents *dp;
+ char nbuf[MAXPATHLEN + 1];
+
+ strcpy(nbuf, name);
+
+ if ( ((c = nbuf[strlen(nbuf) - 1]) == '\\' || c == '/') &&
+ (strlen(nbuf) > 1) )
+ {
+ nbuf[strlen(nbuf) - 1] = 0;
+
+ if ( nbuf[strlen(nbuf) - 1] == ':' )
+ strcat(nbuf, "\\.");
+ }
+ else
+ if ( nbuf[strlen(nbuf) - 1] == ':' )
+ strcat(nbuf, ".");
+
+ if (stat(nbuf, &statb) < 0 || (statb.st_mode & S_IFMT) != S_IFDIR)
+ return NULL;
+
+ if ( (dirp = malloc(sizeof(DIR))) == NULL )
+ return NULL;
+
+ if ( nbuf[strlen(nbuf) - 1] == '.' )
+ strcpy(nbuf + strlen(nbuf) - 1, "*.*");
+ else
+ if ( ((c = nbuf[strlen(nbuf) - 1]) == '\\' || c == '/') &&
+ (strlen(nbuf) == 1) )
+ strcat(nbuf, "*.*");
+ else
+ strcat(nbuf, "\\*.*");
+
+ dirp -> dd_loc = 0;
+ dirp -> dd_contents = dirp -> dd_cp = NULL;
+
+ if ((s = getdirent(nbuf)) == NULL)
+ return dirp;
+
+ do
+ {
+ if (((dp = malloc(sizeof(struct _dircontents))) == NULL) ||
+ ((dp -> _d_entry = malloc(strlen(s) + 1)) == NULL) )
+ {
+ if (dp)
+ free(dp);
+ free_dircontents(dirp -> dd_contents);
+
+ return NULL;
+ }
+
+ if (dirp -> dd_contents)
+ dirp -> dd_cp = dirp -> dd_cp -> _d_next = dp;
+ else
+ dirp -> dd_contents = dirp -> dd_cp = dp;
+
+ strcpy(dp -> _d_entry, s);
+ dp -> _d_next = NULL;
+
+ dp -> _d_size = find.cbFile;
+ dp -> _d_mode = find.attrFile;
+ dp -> _d_time = *(unsigned *) &(find.ftimeLastWrite);
+ dp -> _d_date = *(unsigned *) &(find.fdateLastWrite);
+ }
+ while ((s = getdirent(NULL)) != NULL);
+
+ dirp -> dd_cp = dirp -> dd_contents;
+
+ return dirp;
+}
+
+
+void closedir(DIR * dirp)
+{
+ free_dircontents(dirp -> dd_contents);
+ free(dirp);
+}
+
+
+struct direct *readdir(DIR * dirp)
+{
+ static struct direct dp;
+
+ if (dirp -> dd_cp == NULL)
+ return NULL;
+
+ dp.d_namlen = dp.d_reclen =
+ strlen(strcpy(dp.d_name, dirp -> dd_cp -> _d_entry));
+
+ strlwr(dp.d_name); /* JF */
+ dp.d_ino = 0;
+
+ dp.d_size = dirp -> dd_cp -> _d_size;
+ dp.d_mode = dirp -> dd_cp -> _d_mode;
+ dp.d_time = dirp -> dd_cp -> _d_time;
+ dp.d_date = dirp -> dd_cp -> _d_date;
+
+ dirp -> dd_cp = dirp -> dd_cp -> _d_next;
+ dirp -> dd_loc++;
+
+ return &dp;
+}
+
+
+void seekdir(DIR * dirp, long off)
+{
+ long i = off;
+ struct _dircontents *dp;
+
+ if (off >= 0)
+ {
+ for (dp = dirp -> dd_contents; --i >= 0 && dp; dp = dp -> _d_next);
+
+ dirp -> dd_loc = off - (i + 1);
+ dirp -> dd_cp = dp;
+ }
+}
+
+
+long telldir(DIR * dirp)
+{
+ return dirp -> dd_loc;
+}
+
+
+static void free_dircontents(struct _dircontents * dp)
+{
+ struct _dircontents *odp;
+
+ while (dp)
+ {
+ if (dp -> _d_entry)
+ free(dp -> _d_entry);
+
+ dp = (odp = dp) -> _d_next;
+ free(odp);
+ }
+}
+
+
+static char *getdirent(char *dir)
+{
+ int done;
+
+ if (dir != NULL)
+ { /* get first entry */
+ hdir = HDIR_CREATE;
+ count = 1;
+ done = DosFindFirst(dir, &hdir, attributes,
+ &find, sizeof(find), &count, 0L);
+ }
+ else /* get next entry */
+ done = DosFindNext(hdir, &find, sizeof(find), &count);
+
+ if (done == 0)
+ return find.achName;
+ else
+ {
+ DosFindClose(hdir);
+ return NULL;
+ }
+}
-#define PATCHLEVEL 29
+#define PATCHLEVEL 30
#!./perl
-# $Header: cmd.subval,v 3.0 89/10/18 15:24:52 lwall Locked $
+# $Header: cmd.subval,v 3.0.1.1 90/10/16 10:46:53 lwall Locked $
sub foo1 {
'true1';
'true2' unless $_[0];
}
-print "1..26\n";
+print "1..34\n";
if (do foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
if (do foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";}
$x = join(':',&ary2);
print $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n";
+sub somesub {
+ local($num,$P,$F,$L) = @_;
+ ($p,$f,$l) = caller;
+ print "$p:$f:$l" eq "$P:$F:$L" ? "ok $num\n" : "not ok $num\n";
+}
+
+&somesub(27, 'main', __FILE__, __LINE__);
+
+package foo;
+&main'somesub(28, 'foo', __FILE__, __LINE__);
+
+package main;
+$i = 28;
+open(FOO,">Cmd_subval.tmp");
+print FOO "blah blah\n";
+close FOO;
+
+&file_main(*F);
+close F;
+&info_main;
+
+&file_package(*F);
+close F;
+&info_package;
+
+unlink 'Cmd_subval.tmp';
+
+sub file_main {
+ local(*F) = @_;
+
+ open(F, 'Cmd_subval.tmp') || die "can't open\n";
+ $i++;
+ eof F ? print "not ok $i\n" : print "ok $i\n";
+}
+
+sub info_main {
+ local(*F);
+
+ open(F, 'Cmd_subval.tmp') || die "test: can't open\n";
+ $i++;
+ eof F ? print "not ok $i\n" : print "ok $i\n";
+ &iseof(*F);
+ close F;
+}
+
+sub iseof {
+ local(*UNIQ) = @_;
+
+ $i++;
+ eof UNIQ ? print "(not ok $i)\n" : print "ok $i\n";
+}
+
+{package foo;
+
+ sub main'file_package {
+ local(*F) = @_;
+
+ open(F, 'Cmd_subval.tmp') || die "can't open\n";
+ $main'i++;
+ eof F ? print "not ok $main'i\n" : print "ok $main'i\n";
+ }
+
+ sub main'info_package {
+ local(*F);
+
+ open(F, 'Cmd_subval.tmp') || die "can't open\n";
+ $main'i++;
+ eof F ? print "not ok $main'i\n" : print "ok $main'i\n";
+ &iseof(*F);
+ }
+
+ sub iseof {
+ local(*UNIQ) = @_;
+
+ $main'i++;
+ eof UNIQ ? print "not ok $main'i\n" : print "ok $main'i\n";
+ }
+}
-/* $Header: a2py.c,v 3.0.1.1 90/08/09 05:48:53 lwall Locked $
+/* $Header: a2py.c,v 3.0.1.2 90/10/16 11:30:34 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: a2py.c,v $
+ * Revision 3.0.1.2 90/10/16 11:30:34 lwall
+ * patch29: various portability fixes
+ *
* Revision 3.0.1.1 90/08/09 05:48:53 lwall
* patch19: a2p didn't emit a chop when NF was referenced though split needs it
*
*
*/
+#ifdef MSDOS
+#include "../patchlev.h"
+#endif
#include "util.h"
char *index();
char *filename;
+char *myname;
int checkers = 0;
STR *walk();
+#ifdef MSDOS
+usage()
+{
+ printf("\nThis is the AWK to PERL translator, version 3.0, patchlevel %d\n", PATCHLEVEL);
+ printf("\nUsage: %s [-D<number>] [-F<char>] [-n<fieldlist>] [-<number>] filename\n", myname);
+ printf("\n -D<number> sets debugging flags."
+ "\n -F<character> the awk script to translate is always invoked with"
+ "\n this -F switch."
+ "\n -n<fieldlist> specifies the names of the input fields if input does"
+ "\n not have to be split into an array."
+ "\n -<number> causes a2p to assume that input will always have that"
+ "\n many fields.\n");
+ exit(1);
+}
+#endif
main(argc,argv,env)
register int argc;
register char **argv;
int i;
STR *tmpstr;
+ myname = argv[0];
linestr = str_new(80);
str = str_new(0); /* first used for -I flags */
for (argc--,argv++; argc; argc--,argv++) {
break;
default:
fatal("Unrecognized switch: %s\n",argv[0]);
+#ifdef MSDOS
+ usage();
+#endif
}
}
switch_end:
/* open script */
- if (argv[0] == Nullch)
- argv[0] = "-";
+ if (argv[0] == Nullch) {
+#ifdef MSDOS
+ if ( isatty(fileno(stdin)) )
+ usage();
+#endif
+ argv[0] = "-";
+ }
+ filename = savestr(argv[0]);
+
filename = savestr(argv[0]);
if (strEQ(filename,"-"))
argv[0] = "";
}
else
fatal("panic: unknown argument type %d, arg %d, line %d\n",
- type,numargs+1,line);
+ type,prevargs+1,line);
return numargs;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff