git.maemo.org Git - gnuplot/blob - src/vms.c

   1 #ifndef lint
   2 static char *RCSid() { return RCSid("$Id: vms.c,v 1.5 2004/07/01 17:10:09 broeker Exp $"); }
   3 #endif
   4
   5 /* GNUPLOT - vms.c */
   6
   7 /*[
   8  * Copyright 1986 - 1993, 1998, 2004   Thomas Williams, Colin Kelley
   9  *
  10  * Permission to use, copy, and distribute this software and its
  11  * documentation for any purpose with or without fee is hereby granted,
  12  * provided that the above copyright notice appear in all copies and
  13  * that both that copyright notice and this permission notice appear
  14  * in supporting documentation.
  15  *
  16  * Permission to modify the software is granted, but not the right to
  17  * distribute the complete modified source code.  Modifications are to
  18  * be distributed as patches to the released version.  Permission to
  19  * distribute binaries produced by compiling modified sources is granted,
  20  * provided you
  21  *   1. distribute the corresponding source modifications from the
  22  *    released version in the form of a patch file along with the binaries,
  23  *   2. add special version identification to distinguish your version
  24  *    in addition to the base release version number,
  25  *   3. provide your name and address as the primary contact for the
  26  *    support of your modified version, and
  27  *   4. retain our contact information in regard to use of the base
  28  *    software.
  29  * Permission to distribute the released version of the source code along
  30  * with corresponding source modifications in the form of a patch file is
  31  * granted with same provisions 2 through 4 for binary distributions.
  32  *
  33  * This software is provided "as is" without express or implied warranty
  34  * to the extent permitted by applicable law.
  35 ]*/
  36
  37 /* drop in popen() / pclose() for VMS
  38  * (originally written by drd for port of perl to vms)
  39  */
  40
  41 #include "syscfg.h"     /* for the prototypes */
  42 #include "stdfn.h"
  43
  44 static int something_in_this_file;
  45
  46 #ifdef PIPES
  47
  48 /* (to aid porting) - how are errors dealt with */
  49
  50 #define ERROR(msg) { fprintf(stderr, "%s\nFile %s line %d\n", msg, __FILE__, __LINE__); }
  51 #define FATAL(msg) { fprintf(stderr, "%s\nFile %s line %d\n", msg, __FILE__, __LINE__); exit(EXIT_FAILURE); }
  52
  53
  54 #include <dvidef.h>
  55 #include <syidef.h>
  56 #include <jpidef.h>
  57 #include <ssdef.h>
  58 #include <descrip.h>
  59
  60 #ifdef __DECC             /* DECC does not automatically search */
  61 #include <lib$routines.h>
  62 #include <starlet.h>      /* for the sys$... routines */
  63 #endif  /* __DECC */
  64
  65 #ifndef EXIT_FAILURE                  /* not in older VAXC <stdlib.h> */
  66 #define EXIT_FAILURE 0x10000002       /* (STS$K_ERROR | STS$M_INHIB_MSG */
  67 #endif
  68
  69 #define _cksts(call) \
  70   if (!(sts=(call))&1) FATAL("Internal error") else {}
  71
  72 static void
  73 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
  74 {
  75         static unsigned long int mbxbufsiz;
  76                 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
  77         unsigned long sts;  /* for _cksts */
  78
  79   if (!mbxbufsiz) {
  80     /*
  81      * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
  82      * preprocessor consant BUFSIZ from stdio.h as the size of the
  83      * 'pipe' mailbox.
  84      */
  85
  86     _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
  87     if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
  88   }
  89   _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
  90
  91   _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
  92   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
  93
  94 }  /* end of create_mbx() */
  95
  96 struct pipe_details
  97 {
  98     struct pipe_details *next;
  99     FILE *fp;
 100     int pid;
 101     unsigned long int completion;
 102 };
 103
 104 static struct pipe_details *open_pipes = NULL;
 105 static $DESCRIPTOR(nl_desc, "NL:");
 106 static int waitpid_asleep = 0;
 107
 108 static void
 109 popen_completion_ast(unsigned long int unused)
 110 {
 111   if (waitpid_asleep) {
 112     waitpid_asleep = 0;
 113     sys$wake(0,0);
 114   }
 115 }
 116
 117 FILE *
 118 popen(char *cmd, char *mode)
 119 {
 120     static char mbxname[64];
 121     unsigned short int chan;
 122     unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
 123     struct pipe_details *info;
 124     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
 125                                       DSC$K_CLASS_S, mbxname},
 126                             cmddsc = {0, DSC$K_DTYPE_T,
 127                                       DSC$K_CLASS_S, 0};
 128         unsigned long sts;
 129
 130     if (!(info=malloc(sizeof(struct pipe_details))))
 131     {
 132         ERROR("Cannot malloc space");
 133         return NULL;
 134     }
 135
 136     info->completion=0;  /* I assume this will remain 0 until terminates */
 137
 138     /* create mailbox */
 139     create_mbx(&chan,&namdsc);
 140
 141     /* open a FILE* onto it */
 142     info->fp=fopen(mbxname, mode);
 143
 144     /* give up other channel onto it */
 145     _cksts(sys$dassgn(chan));
 146
 147     if (!info->fp)
 148         return NULL;
 149
 150     cmddsc.dsc$w_length=strlen(cmd);
 151     cmddsc.dsc$a_pointer=cmd;
 152
 153     if (strcmp(mode,"r")==0) {
 154       _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
 155                      0  /* name */, &info->pid, &info->completion,
 156                      0, popen_completion_ast,0,0,0,0));
 157     }
 158     else {
 159       _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
 160                      0  /* name */, &info->pid, &info->completion));
 161     }
 162
 163     info->next=open_pipes;  /* prepend to list */
 164     open_pipes=info;
 165
 166     return info->fp;
 167 }
 168
 169 int pclose(FILE *fp)
 170 {
 171     struct pipe_details *info, *last = NULL;
 172     unsigned long int abort = SS$_TIMEOUT, retsts;
 173     unsigned long sts;
 174
 175     for (info = open_pipes; info != NULL; last = info, info = info->next)
 176         if (info->fp == fp) break;
 177
 178     if (info == NULL)
 179       /* get here => no such pipe open */
 180       FATAL("pclose() - no such pipe open ???");
 181
 182     if (!info->completion) { /* Tap them gently on the shoulder . . .*/
 183       _cksts(sys$forcex(&info->pid,0,&abort));
 184       sleep(1);
 185     }
 186     if (!info->completion)  /* We tried to be nice . . . */
 187       _cksts(sys$delprc(&info->pid));
 188
 189     fclose(info->fp);
 190     /* remove from list of open pipes */
 191     if (last) last->next = info->next;
 192     else open_pipes = info->next;
 193     retsts = info->completion;
 194     free(info);
 195
 196     return retsts;
 197 }  /* end of pclose() */
 198
 199
 200 /* sort-of waitpid; use only with popen() */
 201 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
 202 unsigned long int
 203 waitpid(unsigned long int pid, int *statusp, int flags)
 204 {
 205     struct pipe_details *info;
 206     unsigned long int abort = SS$_TIMEOUT;
 207     unsigned long sts;
 208
 209     for (info = open_pipes; info != NULL; info = info->next)
 210         if (info->pid == pid) break;
 211
 212     if (info != NULL) {  /* we know about this child */
 213       while (!info->completion) {
 214         waitpid_asleep = 1;
 215         sys$hiber();
 216       }
 217
 218       *statusp = info->completion;
 219       return pid;
 220     }
 221     else {  /* we haven't heard of this child */
 222       $DESCRIPTOR(intdsc,"0 00:00:01");
 223       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
 224       unsigned long int interval[2];
 225
 226       _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
 227       _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
 228       if (ownerpid != mypid)
 229         FATAL("pid not a child");
 230
 231       _cksts(sys$bintim(&intdsc,interval));
 232       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
 233         _cksts(sys$schdwk(0,0,interval,0));
 234         _cksts(sys$hiber());
 235       }
 236       _cksts(sts);
 237
 238       /* There's no easy way to find the termination status a child we're
 239        * not aware of beforehand.  If we're really interested in the future,
 240        * we can go looking for a termination mailbox, or chase after the
 241        * accounting record for the process.
 242        */
 243       *statusp = 0;
 244       return pid;
 245     }
 246
 247 }  /* end of waitpid() */
 248
 249 #endif /* PIPES */
 250
 251
 252 /* vax c doesn't come with strftime - watch out for redefn of RCSid */
 253 #ifdef VAXCRTL
 254 # define RCSid RCSid2
 255 # include "strftime.c"
 256 #endif