perl 5.0 alpha 2perl-5a2

[editor's note: from history.perl.org.  The sparc executables
originally included in the distribution are not in this commit.]

1 files changed, 55 insertions, 0 deletions

diff --git a/do/shmio b/do/shmio
new file mode 100644
index 0000000000..b7107684ac
--- /dev/null
+++ b/do/shmio
@@ -0,0 +1,55 @@
+int
+do_shmio(optype, arglast)
+int optype;
+int *arglast;
+{
+#ifdef HAS_SHM
+    register STR **st = stack->ary_array;
+    register int sp = arglast[0];
+    STR *mstr;
+    char *mbuf, *shm;
+    int id, mpos, msize;
+    struct shmid_ds shmds;
+#ifndef VOIDSHMAT
+    extern char *shmat();
+#endif
+
+    id = (int)str_gnum(st[++sp]);
+    mstr = st[++sp];
+    mpos = (int)str_gnum(st[++sp]);
+    msize = (int)str_gnum(st[++sp]);
+    errno = 0;
+    if (shmctl(id, IPC_STAT, &shmds) == -1)
+	return -1;
+    if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
+	errno = EFAULT;		/* can't do as caller requested */
+	return -1;
+    }
+    shm = (char*)shmat(id, (char*)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
+    if (shm == (char *)-1)	/* I hate System V IPC, I really do */
+	return -1;
+    mbuf = str_get(mstr);
+    if (optype == O_SHMREAD) {
+	if (mstr->str_cur < msize) {
+	    STR_GROW(mstr, msize+1);
+	    mbuf = str_get(mstr);
+	}
+	Copy(shm + mpos, mbuf, msize, char);
+	mstr->str_cur = msize;
+	mstr->str_ptr[msize] = '\0';
+    }
+    else {
+	int n;
+
+	if ((n = mstr->str_cur) > msize)
+	    n = msize;
+	Copy(mbuf, shm + mpos, n, char);
+	if (n < msize)
+	    memzero(shm + mpos + n, msize - n);
+    }
+    return shmdt(shm);
+#else
+    fatal("shm I/O not implemented");
+#endif
+}
+