X-Git-Url: https://vcs.maemo.org/git/?a=blobdiff_plain;f=src%2Fvms.c;fp=src%2Fvms.c;h=57b44475392e326897c7a8c3def03f04691d7c17;hb=39ec1247a71f61152a4a7f502a30f06a3896c5da;hp=0000000000000000000000000000000000000000;hpb=06be459be4f5f6a7c6ff878e84f355fb2575caa8;p=gnuplot diff --git a/src/vms.c b/src/vms.c new file mode 100644 index 0000000..57b4447 --- /dev/null +++ b/src/vms.c @@ -0,0 +1,256 @@ +#ifndef lint +static char *RCSid() { return RCSid("$Id: vms.c,v 1.5 2004/07/01 17:10:09 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 +#include +#include +#include +#include + +#ifdef __DECC /* DECC does not automatically search */ +#include +#include /* for the sys$... routines */ +#endif /* __DECC */ + +#ifndef EXIT_FAILURE /* not in older VAXC */ +#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