From: Larry Wall Date: Mon, 15 Oct 1990 23:06:25 +0000 (+0000) Subject: perl 3.0 patch #30 patch #29, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=39c3038ca76b338006c640ae6da52b407dd9e654;p=p5sagit%2Fp5-mst-13.2.git perl 3.0 patch #30 patch #29, continued See patch #29. --- diff --git a/arg.h b/arg.h index dcfa370..df139db 100644 --- a/arg.h +++ b/arg.h @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,18 @@ * 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 @@ -123,7 +135,7 @@ #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 @@ -277,7 +289,28 @@ #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[]; @@ -529,7 +562,28 @@ 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 @@ -629,11 +683,8 @@ union argptr { 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 */ @@ -658,10 +709,11 @@ struct arg { #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 */ @@ -733,7 +785,7 @@ char opargs[MAXO+1] = { 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 */ @@ -818,10 +870,10 @@ char opargs[MAXO+1] = { 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 */ @@ -843,7 +895,7 @@ char opargs[MAXO+1] = { 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 */ @@ -908,9 +960,31 @@ char opargs[MAXO+1] = { 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(); diff --git a/array.c b/array.c index 5a1fcd4..aff66ca 100644 --- a/array.c +++ b/array.c @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,9 @@ * 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 * @@ -38,12 +41,15 @@ int lval; 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]; } diff --git a/cmd.c b/cmd.c index 844af22..cf79eee 100644 --- a/cmd.c +++ b/cmd.c @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,12 @@ * 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 @@ -600,12 +606,24 @@ until_loop: } 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 */ @@ -1130,7 +1148,7 @@ int base; 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); @@ -1162,6 +1180,20 @@ int base; (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"); } diff --git a/cmd.h b/cmd.h index 64fc5f5..1825f50 100644 --- a/cmd.h +++ b/cmd.h @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,10 @@ * 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 * @@ -78,6 +82,8 @@ char *cmdname[] = { #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 @@ -134,19 +140,33 @@ struct cmd { } 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; diff --git a/config.h.SH b/config.h.SH index dce224c..3eee31f 100644 --- a/config.h.SH +++ b/config.h.SH @@ -421,6 +421,11 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$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. @@ -471,6 +476,11 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$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. @@ -511,6 +521,10 @@ sed <config.h -e 's!^#undef!/\*#undef!' * 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. @@ -532,6 +546,7 @@ sed <config.h -e 's!^#undef!/\*#undef!' * contains pw_expire. */ #$i_pwd I_PWD /**/ +#$d_pwcomment PWCOMMENT /**/ #$d_pwquota PWQUOTA /**/ #$d_pwage PWAGE /**/ #$d_pwchange PWCHANGE /**/ diff --git a/cons.c b/cons.c index 17e317e..3938b99 100644 --- a/cons.c +++ b/cons.c @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,12 @@ * 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 @@ -76,7 +82,7 @@ CMD *cmd; } 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 */ @@ -94,13 +100,18 @@ CMD *cmd; 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; @@ -129,7 +140,7 @@ char *filename; } Safefree(stab_sub(stab)); } - sub->filename = filename; + sub->filestab = fstab(filename); sub->usersub = subaddr; sub->userindex = ix; stab_sub(stab) = sub; @@ -445,27 +456,26 @@ CMD *cur; 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); } @@ -491,8 +501,8 @@ ARG *arg; 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; @@ -519,6 +529,8 @@ struct compcmd cblock; cmd->c_line = cmdline; cmdline = NOLINE; } + cmd->c_filestab = curcmd->c_filestab; + cmd->c_stash = curstash; if (perldb) cmd = dodb(cmd); return cmd; @@ -550,6 +562,8 @@ struct compcmd cblock; 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) { @@ -939,7 +953,7 @@ char *s; 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", @@ -949,7 +963,8 @@ char *s; 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 diff --git a/consarg.c b/consarg.c index a7db58b..ac7a8ca 100644 --- a/consarg.c +++ b/consarg.c @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,11 @@ * 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 * @@ -92,6 +97,9 @@ register ARG *pat; 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 || @@ -156,17 +164,17 @@ ARG *arg3; { 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 )))) @@ -181,15 +189,10 @@ ARG *arg3; 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)) || @@ -206,14 +209,9 @@ ARG *arg3; 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; @@ -223,13 +221,9 @@ ARG *arg3; 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; @@ -241,7 +235,7 @@ ARG *arg3; } } 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; @@ -252,6 +246,14 @@ ARG *arg3; 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]); @@ -354,7 +356,7 @@ register ARG *arg; 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 @@ -410,6 +412,15 @@ register ARG *arg; 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 @@ -499,6 +510,9 @@ register ARG *arg; 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); @@ -941,20 +955,6 @@ ARG *arg; } 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; { diff --git a/lib/cacheout.pl b/lib/cacheout.pl new file mode 100644 index 0000000..106014c --- /dev/null +++ b/lib/cacheout.pl @@ -0,0 +1,44 @@ +#!/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 () { + $maxopen = $1 - 4 if /^#define NOFILE\s+(\d+)/; + } + close PARAM; +} +$maxopen = 16 unless $maxopen; + +1; diff --git a/os2/a2p.cs b/os2/a2p.cs new file mode 100644 index 0000000..1141c4f --- /dev/null +++ b/os2/a2p.cs @@ -0,0 +1,8 @@ +(-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 diff --git a/os2/a2p.def b/os2/a2p.def new file mode 100644 index 0000000..d88c283 --- /dev/null +++ b/os2/a2p.def @@ -0,0 +1,2 @@ +NAME AWK2PERL WINDOWCOMPAT NEWFILES +DESCRIPTION 'AWK to PERL translator - for MS-DOS and OS/2' diff --git a/os2/config.h b/os2/config.h index 7152503..e587a5c 100644 --- a/os2/config.h +++ b/os2/config.h @@ -14,7 +14,6 @@ #define GETPPID #define GETPRIORITY #define SETPRIORITY -#define SYSCALL #define KILL #endif /* OS2 */ @@ -435,7 +434,7 @@ * 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 @@ -545,7 +544,7 @@ * 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: diff --git a/os2/dir.h b/os2/dir.h new file mode 100644 index 0000000..92c6923 --- /dev/null +++ b/os2/dir.h @@ -0,0 +1,163 @@ +/* + * @(#) 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 + #include + + 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) +*/ diff --git a/os2/director.c b/os2/director.c new file mode 100644 index 0000000..a360af7 --- /dev/null +++ b/os2/director.c @@ -0,0 +1,200 @@ +/* + * @(#)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 +#include +#include + +#include +#include +#include + +#define INCL_NOPM +#include + + +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; + } +} diff --git a/patchlevel.h b/patchlevel.h index 46afcbb..256548d 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 29 +#define PATCHLEVEL 30 diff --git a/t/cmd.subval b/t/cmd.subval index e2dc47b..8845715 100644 --- a/t/cmd.subval +++ b/t/cmd.subval @@ -1,6 +1,6 @@ #!./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'; @@ -33,7 +33,7 @@ sub foo6 { '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";} @@ -99,3 +99,81 @@ print &ary2 eq 3 ? "ok 25\n" : "not ok 25\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"; + } +} diff --git a/x2p/a2py.c b/x2p/a2py.c index d53fb16..836d176 100644 --- a/x2p/a2py.c +++ b/x2p/a2py.c @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,9 @@ * 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 * @@ -14,14 +17,33 @@ * */ +#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] [-F] [-n] [-] filename\n", myname); + printf("\n -D sets debugging flags." + "\n -F the awk script to translate is always invoked with" + "\n this -F switch." + "\n -n specifies the names of the input fields if input does" + "\n not have to be split into an array." + "\n - 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; @@ -32,6 +54,7 @@ register char **env; 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++) { @@ -65,14 +88,24 @@ register char **env; 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] = ""; @@ -1207,7 +1240,7 @@ int prevargs; } else fatal("panic: unknown argument type %d, arg %d, line %d\n", - type,numargs+1,line); + type,prevargs+1,line); return numargs; }