#ifndef lint
static char *RCSid() { return RCSid("$Id: vms.c,v 1.4 2004/04/13 17:24:03 broeker Exp $"); }
#endif
/* GNUPLOT - vms.c */
/*[
* Copyright 1986 - 1993, 1998, 2004 Thomas Williams, Colin Kelley
*
* Permission to use, copy, and distribute this software and its
* documentation for any purpose with or without fee is hereby granted,
* provided that the above copyright notice appear in all copies and
* that both that copyright notice and this permission notice appear
* in supporting documentation.
*
* Permission to modify the software is granted, but not the right to
* distribute the complete modified source code. Modifications are to
* be distributed as patches to the released version. Permission to
* distribute binaries produced by compiling modified sources is granted,
* provided you
* 1. distribute the corresponding source modifications from the
* released version in the form of a patch file along with the binaries,
* 2. add special version identification to distinguish your version
* in addition to the base release version number,
* 3. provide your name and address as the primary contact for the
* support of your modified version, and
* 4. retain our contact information in regard to use of the base
* software.
* Permission to distribute the released version of the source code along
* with corresponding source modifications in the form of a patch file is
* granted with same provisions 2 through 4 for binary distributions.
*
* This software is provided "as is" without express or implied warranty
* to the extent permitted by applicable law.
]*/
/* drop in popen() / pclose() for VMS
* (originally written by drd for port of perl to vms)
*/
#include "syscfg.h" /* for the prototypes */
#include "stdfn.h"
static int something_in_this_file;
#ifdef PIPES
/* (to aid porting) - how are errors dealt with */
#define ERROR(msg) { fprintf(stderr, "%s\nFile %s line %d\n", msg, __FILE__, __LINE__); }
#define FATAL(msg) { fprintf(stderr, "%s\nFile %s line %d\n", msg, __FILE__, __LINE__); exit(EXIT_FAILURE); }
#include <dvidef.h>
#include <syidef.h>
#include <jpidef.h>
#include <ssdef.h>
#include <descrip.h>
#ifdef __DECC /* DECC does not automatically search */
#include <lib$routines.h>
#include <starlet.h> /* for the sys$... routines */
#endif /* __DECC */
#ifndef EXIT_FAILURE /* not in older VAXC <stdlib.h> */
#define EXIT_FAILURE 0x10000002 /* (STS$K_ERROR | STS$M_INHIB_MSG */
#endif
#define _cksts(call) \
if (!(sts=(call))&1) FATAL("Internal error") else {}
static void
create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
static unsigned long int mbxbufsiz;
long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
unsigned long sts; /* for _cksts */
if (!mbxbufsiz) {
/*
* Get the SYSGEN parameter MAXBUF, and the smaller of it and the
* preprocessor consant BUFSIZ from stdio.h as the size of the
* 'pipe' mailbox.
*/
_cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
}
_cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
_cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
} /* end of create_mbx() */
struct pipe_details
{
struct pipe_details *next;
FILE *fp;
int pid;
unsigned long int completion;
};
static struct pipe_details *open_pipes = NULL;
static $DESCRIPTOR(nl_desc, "NL:");
static int waitpid_asleep = 0;
static void
popen_completion_ast(unsigned long int unused)
{
if (waitpid_asleep) {
waitpid_asleep = 0;
sys$wake(0,0);
}
}
FILE *
popen(char *cmd, char *mode)
{
static char mbxname[64];
unsigned short int chan;
unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
struct pipe_details *info;
struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
DSC$K_CLASS_S, mbxname},
cmddsc = {0, DSC$K_DTYPE_T,
DSC$K_CLASS_S, 0};
unsigned long sts;
if (!(info=malloc(sizeof(struct pipe_details))))
{
ERROR("Cannot malloc space");
return NULL;
}
info->completion=0; /* I assume this will remain 0 until terminates */
/* create mailbox */
create_mbx(&chan,&namdsc);
/* open a FILE* onto it */
info->fp=fopen(mbxname, mode);
/* give up other channel onto it */
_cksts(sys$dassgn(chan));
if (!info->fp)
return NULL;
cmddsc.dsc$w_length=strlen(cmd);
cmddsc.dsc$a_pointer=cmd;
if (strcmp(mode,"r")==0) {
_cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
0 /* name */, &info->pid, &info->completion,
0, popen_completion_ast,0,0,0,0));
}
else {
_cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
0 /* name */, &info->pid, &info->completion));
}
info->next=open_pipes; /* prepend to list */
open_pipes=info;
return info->fp;
}
int pclose(FILE *fp)
{
struct pipe_details *info, *last = NULL;
unsigned long int abort = SS$_TIMEOUT, retsts;
unsigned long sts;
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
if (info == NULL)
/* get here => no such pipe open */
FATAL("pclose() - no such pipe open ???");
if (!info->completion) { /* Tap them gently on the shoulder . . .*/
_cksts(sys$forcex(&info->pid,0,&abort));
sleep(1);
}
if (!info->completion) /* We tried to be nice . . . */
_cksts(sys$delprc(&info->pid));
fclose(info->fp);
/* remove from list of open pipes */
if (last) last->next = info->next;
else open_pipes = info->next;
retsts = info->completion;
free(info);
return retsts;
} /* end of pclose() */
/* sort-of waitpid; use only with popen() */
/*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
unsigned long int
waitpid(unsigned long int pid, int *statusp, int flags)
{
struct pipe_details *info;
unsigned long int abort = SS$_TIMEOUT;
unsigned long sts;
for (info = open_pipes; info != NULL; info = info->next)
if (info->pid == pid) break;
if (info != NULL) { /* we know about this child */
while (!info->completion) {
waitpid_asleep = 1;
sys$hiber();
}
*statusp = info->completion;
return pid;
}
else { /* we haven't heard of this child */
$DESCRIPTOR(intdsc,"0 00:00:01");
unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
unsigned long int interval[2];
_cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
_cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
if (ownerpid != mypid)
FATAL("pid not a child");
_cksts(sys$bintim(&intdsc,interval));
while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
_cksts(sys$schdwk(0,0,interval,0));
_cksts(sys$hiber());
}
_cksts(sts);
/* There's no easy way to find the termination status a child we're
* not aware of beforehand. If we're really interested in the future,
* we can go looking for a termination mailbox, or chase after the
* accounting record for the process.
*/
*statusp = 0;
return pid;
}
} /* end of waitpid() */
#endif /* PIPES */
/* vax c doesn't come with strftime - watch out for redefn of RCSid */
#ifdef VAXCRTL
# define RCSid RCSid2
# include "strftime.c"
#endif