perl 3.0 patch #30 patch #29, continued
authorLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Mon, 15 Oct 1990 23:06:25 +0000 (23:06 +0000)
committerLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Mon, 15 Oct 1990 23:06:25 +0000 (23:06 +0000)
See patch #29.

16 files changed:
arg.h
array.c
cmd.c
cmd.h
config.h.SH
cons.c
consarg.c
lib/cacheout.pl [new file with mode: 0644]
os2/a2p.cs [new file with mode: 0644]
os2/a2p.def [new file with mode: 0644]
os2/config.h
os2/dir.h [new file with mode: 0644]
os2/director.c [new file with mode: 0644]
patchlevel.h
t/cmd.subval
x2p/a2py.c

diff --git a/arg.h b/arg.h
index dcfa370..df139db 100644 (file)
--- 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
  *
  *
  *    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 $
  *    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
  * 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_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_SYSTEM 93
 #define O_OCT 94
 #define O_HEX 95
 #define O_BINMODE 243
 #define O_REQUIRE 244
 #define O_TRUNCATE 245
 #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[];
 
 #ifndef DOINIT
 extern char *opname[];
@@ -529,7 +562,28 @@ char *opname[] = {
     "BINMODE",
     "REQUIRE",
     "TRUNCATE",
     "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
 
 };
 #endif
 
@@ -629,11 +683,8 @@ union argptr {
 struct arg {
     union argptr arg_ptr;
     short      arg_len;
 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 AF_ARYOK 1             /* op can handle multiple values here */
@@ -658,10 +709,11 @@ struct arg {
 #define Nullarg Null(ARG*)
 
 #ifndef DOINIT
 #define Nullarg Null(ARG*)
 
 #ifndef DOINIT
-EXT char opargs[MAXO+1];
+EXT unsigned short opargs[MAXO+1];
 #else
 #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),       /* 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(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(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,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,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(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,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,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,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
        0
 };
 #undef A
+#undef A5
 #endif
 
 int do_trans();
 #endif
 
 int do_trans();
diff --git a/array.c b/array.c
index 5a1fcd4..aff66ca 100644 (file)
--- 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
  *
  *
  *    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 $
  *    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
  * 
  * 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 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];
 }
     }
     return ar->ary_array[key];
 }
diff --git a/cmd.c b/cmd.c
index 844af22..cf79eee 100644 (file)
--- 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
  *
  *
  *    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 $
  *    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
  * 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++;
            }
            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;
                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 */
        }
 
     /* 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;
            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);
            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;
            (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");
        }
        default:
            fatal("panic: restorelist inconsistency");
        }
diff --git a/cmd.h b/cmd.h
index 64fc5f5..1825f50 100644 (file)
--- 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
  *
  *
  *    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 $
  *    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
  * 
  * 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_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
 
 #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 */
     } 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*)
     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 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;
 
 struct compcmd {
     CMD *comp_true;
index dce224c..3eee31f 100644 (file)
@@ -421,6 +421,11 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
  */
 #$d_syscall    SYSCALL         /**/
 
  */
 #$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.
 /* TRUNCATE:
  *     This symbol, if defined, indicates that the truncate routine is
  *     available to truncate files.
@@ -471,6 +476,11 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
  */
 #$d_wait4      WAIT4   /**/
 
  */
 #$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.
 /* 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 <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
  *     This symbol, if defined, indicates to the C program that it should
  *     include pwd.h.
  */
  *     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.
 /* PWQUOTA:
  *     This symbol, if defined, indicates to the C program that struct passwd
  *     contains pw_quota.
@@ -532,6 +546,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
  *     contains pw_expire.
  */
 #$i_pwd        I_PWD           /**/
  *     contains pw_expire.
  */
 #$i_pwd        I_PWD           /**/
+#$d_pwcomment  PWCOMMENT       /**/
 #$d_pwquota    PWQUOTA         /**/
 #$d_pwage      PWAGE           /**/
 #$d_pwchange   PWCHANGE        /**/
 #$d_pwquota    PWQUOTA         /**/
 #$d_pwage      PWAGE           /**/
 #$d_pwchange   PWCHANGE        /**/
diff --git a/cons.c b/cons.c
index 17e317e..3938b99 100644 (file)
--- 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
  *
  *
  *    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 $
  *    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
  * 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));
     }
        }
        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 */
     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) {
     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);
        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;
        str_set(subname,"main");
     }
     subline = 0;
@@ -129,7 +140,7 @@ char *filename;
        }
        Safefree(stab_sub(stab));
     }
        }
        Safefree(stab_sub(stab));
     }
-    sub->filename = filename;
+    sub->filestab = fstab(filename);
     sub->usersub = subaddr;
     sub->userindex = ix;
     stab_sub(stab) = sub;
     sub->usersub = subaddr;
     sub->userindex = ix;
     stab_sub(stab) = sub;
@@ -445,27 +456,26 @@ CMD *cur;
        head = cur;
     if (!head->c_line)
        return 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);
        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;
     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),
        stab2arg(A_WORD,DBstab),
-       make_list(arg),
+       Nullarg,
        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_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);
 }
 
     return append_line(cmd, cur);
 }
 
@@ -491,8 +501,8 @@ ARG *arg;
        cmd->c_line = cmdline;
        cmdline = NOLINE;
     }
        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;
     if (perldb)
        cmd = dodb(cmd);
     return cmd;
@@ -519,6 +529,8 @@ struct compcmd cblock;
        cmd->c_line = cmdline;
        cmdline = NOLINE;
     }
        cmd->c_line = cmdline;
        cmdline = NOLINE;
     }
+    cmd->c_filestab = curcmd->c_filestab;
+    cmd->c_stash = curstash;
     if (perldb)
        cmd = dodb(cmd);
     return cmd;
     if (perldb)
        cmd = dodb(cmd);
     return cmd;
@@ -550,6 +562,8 @@ struct compcmd cblock;
        cmd->c_line = cmdline;
        cmdline = NOLINE;
     }
        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) {
     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",
     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",
     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)
     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
 }
 
 void
index a7db58b..ac7a8ca 100644 (file)
--- 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
  *
  *
  *    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 $
  *    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
  * 
  * 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;
 
     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 ||
     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 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;
     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 &&
     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 ))))
              (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;
        }
            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 && 
     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))
                ||
             (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;
        }
            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 = 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 = 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;
        }
            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 (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;
            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 (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_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;
        }
     }
            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]);
 #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
            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
 #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;
            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_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_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);
        case O_CRYPT:
 #ifdef CRYPT
            tmps = str_get(s1);
@@ -940,20 +954,6 @@ ARG *arg;
     return arg;
 }
 
     return 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;
 ARG *
 rcatmaybe(arg)
 ARG *arg;
diff --git a/lib/cacheout.pl b/lib/cacheout.pl
new file mode 100644 (file)
index 0000000..106014c
--- /dev/null
@@ -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 (<PARAM>) {
+       $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 (file)
index 0000000..1141c4f
--- /dev/null
@@ -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 (file)
index 0000000..d88c283
--- /dev/null
@@ -0,0 +1,2 @@
+NAME AWK2PERL WINDOWCOMPAT NEWFILES
+DESCRIPTION 'AWK to PERL translator - for MS-DOS and OS/2'
index 7152503..e587a5c 100644 (file)
@@ -14,7 +14,6 @@
 #define GETPPID
 #define GETPRIORITY
 #define SETPRIORITY
 #define GETPPID
 #define GETPRIORITY
 #define SETPRIORITY
-#define SYSCALL
 #define KILL
 #endif /* OS2 */
 
 #define KILL
 #endif /* OS2 */
 
  *     This symbol, if defined, indicates to the C program that it should
  *     include fcntl.h.
  */
  *     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
 
 /* 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.
  */
  *     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:
 
 /*
  * BUGGY_MSC:
diff --git a/os2/dir.h b/os2/dir.h
new file mode 100644 (file)
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 <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)
+*/
diff --git a/os2/director.c b/os2/director.c
new file mode 100644 (file)
index 0000000..a360af7
--- /dev/null
@@ -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 <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;
+  }
+}
index 46afcbb..256548d 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 29
+#define PATCHLEVEL 30
index e2dc47b..8845715 100644 (file)
@@ -1,6 +1,6 @@
 #!./perl
 
 #!./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';
 
 sub foo1 {
     'true1';
@@ -33,7 +33,7 @@ sub foo6 {
     'true2' unless $_[0];
 }
 
     '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";}
 
 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";
 
 $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";
+ }
+}
index d53fb16..836d176 100644 (file)
@@ -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
  *
  *
  *    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 $
  *    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
  * 
  * 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;
 #include "util.h"
 char *index();
 
 char *filename;
+char *myname;
 
 int checkers = 0;
 STR *walk();
 
 
 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;
 main(argc,argv,env)
 register int argc;
 register char **argv;
@@ -32,6 +54,7 @@ register char **env;
     int i;
     STR *tmpstr;
 
     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++) {
     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]);
            break;
        default:
            fatal("Unrecognized switch: %s\n",argv[0]);
+#ifdef MSDOS
+            usage();
+#endif
        }
     }
   switch_end:
 
     /* open script */
 
        }
     }
   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] = "";
     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",
     }
     else
        fatal("panic: unknown argument type %d, arg %d, line %d\n",
-         type,numargs+1,line);
+         type,prevargs+1,line);
     return numargs;
 }
 
     return numargs;
 }