regina/vmscmd.c

   1 /*
   2  *  The Regina Rexx Interpreter
   3  *  Copyright (C) 1992  Anders Christensen <anders@pvv.unit.no>
   4  *
   5  *  This library is free software; you can redistribute it and/or
   6  *  modify it under the terms of the GNU Library General Public
   7  *  License as published by the Free Software Foundation; either
   8  *  version 2 of the License, or (at your option) any later version.
   9  *
  10  *  This library is distributed in the hope that it will be useful,
  11  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  *  Library General Public License for more details.
  14  *
  15  *  You should have received a copy of the GNU Library General Public
  16  *  License along with this library; if not, write to the Free
  17  *  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  */
  19 #include <stdio.h>
  20 #include <string.h>
  21 #include <errno.h>
  22 #include <processes.h>
  23 #include <descrip.h>
  24 #include <dvidef.h>
  25 #include <clidef.h>
  26 #include <climsgdef.h>
  27 #include <ssdef.h>
  28 #include <iodef.h>
  29 #include <jpidef.h>
  30 #include <rmsdef.h>
  31
  32 #include "rexx.h"
  33 #include "strings.h"
  34
  35 struct mbox_status {
  36    unsigned short status ;
  37    unsigned short size ;
  38    int pid ;
  39 } ;
  40
  41 #define BUFSIZE 128
  42 #define NUMBUFS  1
  43
  44 /* #define VMS_DEBUG */
  45
  46 #define MAX(a,b) (((a)>(b))?(a):(b))
  47 #define MIN(a,b) (((a)<(b))?(a):(b))
  48
  49 #define MAX_SYM_LENGTH 256
  50
  51 typedef struct { /* vms_tsd: static variables of this module (thread-safe) */
  52    volatile int       ichan ;
  53    volatile int       ochan ;
  54    volatile int       pid ;
  55    volatile int       oflag ;
  56    volatile int       comp_stat ;
  57    int                dead ;
  58    volatile int       queue ;
  59    char               buffer[BUFSIZE] ;
  60    struct mbox_status ostat ;
  61    struct mbox_status istat ;
  62    streng *           kill ;
  63 } vms_tsd_t; /* thread-specific but only needed by this module. see
  64               * init_vms
  65               */
  66
  67
  68 /* init_vms initializes the module.
  69  * Currently, we set up the thread specific data.
  70  * The function returns 1 on success, 0 if memory is short.
  71  */
  72 int init_vms( tsd_t *TSD )
  73 {
  74    vms_tsd_t *vt;
  75
  76    if (TSD->vms_tsd != NULL)
  77       return(1);
  78
  79    if ((vt = TSD->vms_tsd = MallocTSD(sizeof(vms_tsd_t))) == NULL)
  80       return(0);
  81    memset(vt,0,sizeof(vms_tsd_t));  /* correct for all values */
  82    return(1);
  83 }
  84
  85 #ifdef VMS_DO_COMMAND
  86 /*
  87  *  At least with OpenVMS 7.3-1 on Alpha, the Posix way seems to work.
  88  *  So there is no need to redirect on (now) bogus code.
  89  *  But I keep the code here in case I didn't see something.
  90  */
  91
  92 static void vms_error (const int error_code)
  93 {
  94    LIB$SIGNAL(error_code);
  95    return;
  96 }
  97
  98 static void complain (const tsd_t *TSD, const int rc)
  99 {
 100    vms_tsd_t *vt;
 101
 102    vt = TSD->vms_tsd;
 103 #  ifdef VMS_DEBUG
 104       printf ("About to complain ... rc=%d, pid=%d, ochan=%d, ichan=%d\n",
 105                rc, vt->pid, vt->ochan, vt->ichan) ;
 106 #  endif
 107
 108    if ((rc != SS$_NORMAL) && vt->pid)
 109       sys$delprc( &vt->pid, NULL ), vt->pid=0 ;
 110
 111 /*
 112    if (vt->ochan) sys$dassgn ((short)vt->ochan), vt->ochan=0 ;
 113 */
 114    if (vt->ichan) sys$dassgn ((short)vt->ichan), vt->ichan=0 ;
 115
 116 #  ifdef VMS_DEBUG
 117       printf( "No more complains left ...about to give error\n" ) ;
 118 #  endif
 119
 120    if (rc && (rc != SS$_NORMAL)) vms_error (rc) ;
 121
 122 #  ifdef VMS_DEBUG
 123       printf ("Exiting complain\n") ;
 124 #  endif
 125
 126    return ;
 127 }
 128
 129 static void read_in_ast( const int read )
 130 {
 131    streng *ptr ;
 132    int rc = 0;
 133    tsd_t *TSD;
 134    vms_tsd_t *vt;
 135
 136    TSD = __regina_get_tsd(); /* This seems to be a system callback function.
 137                               * The TSD must be fetched directly.
 138                               */
 139    vt = TSD->vms_tsd;
 140
 141    if (read) {
 142       switch ( vt->ostat.status ) {
 143          case SS$_NORMAL:
 144             if (vt->ostat.size >= BUFSIZE)
 145                complain( TSD, SS$_NORMAL ) ;
 146             ptr = Str_makeTSD( vt->ostat.size ) ;
 147             ptr = Str_ncatstrTSD( ptr, vt->buffer, vt->ostat.size ) ;
 148             tmp_stack( TSD, ptr, 1 ) ;
 149             break ;
 150
 151          case SS$_ENDOFFILE:
 152             rc = sys$dassgn( (short)vt->ochan ) ;
 153             if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 154             vt->ochan = 0 ;
 155             rc = sys$setef( vt->oflag ) ;
 156             if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 157             break ;
 158
 159          default:
 160             fprintf( stderr,
 161                 "sys$qio() return unexpected status value %d\n",
 162                 vt->ostat.status ) ;
 163
 164             complain( TSD, rc ) ;
 165       }
 166    }
 167
 168    if (vt->ochan) {
 169       rc = sys$qio(0, (short)vt->ochan, IO$_READVBLK, &vt->ostat,
 170                     read_in_ast, 1,
 171                     vt->buffer, BUFSIZE, 0, 0, 0, 0 ) ;
 172 #     ifdef VMS_DEBUG
 173          printf( "I" ) ;
 174          fflush( stdout ) ;
 175 #     endif
 176
 177       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 178    }
 179
 180    return;
 181 }
 182
 183 static void write_out_ast()
 184 {
 185    int rc, len ;
 186    tsd_t *TSD;
 187    vms_tsd_t *vt;
 188
 189    TSD = __regina_get_tsd(); /* This seems to be a system callback function.
 190                               * The TSD must be fetched directly.
 191                               */
 192    vt = TSD->vms_tsd;
 193
 194    if (vt->queue++)
 195       return ;
 196
 197    start:
 198
 199    if (vt->kill) {
 200       FreeTSD( vt->kill ) ;
 201       vt->kill = NULL ;
 202    }
 203
 204    if (! stack_empty( TSD )) {
 205       vt->kill = popline( TSD, NULL, NULL, 0 ) ;
 206
 207       if (!vt->ichan) return ;
 208       rc = sys$qio(0, vt->ichan, IO$_WRITEVBLK, &vt->istat,
 209                    write_out_ast, 0, vt->kill->value, Str_len(vt->kill), 0, 0,
 210                    0, 0 ) ;
 211 #     ifdef VMS_DEBUG
 212          printf( "O" ) ;
 213          fflush( stdout ) ;
 214 #     endif
 215
 216       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 217    } else {
 218       if (vt->dead++ >= 5) {
 219          vt->dead = 0 ;
 220          return ;
 221       }
 222       if (!vt->ichan) return ;
 223       rc = sys$qio(0, vt->ichan, IO$_WRITEOF, &vt->istat,
 224                    write_out_ast, 0, 0, 0, 0, 0, 0, 0 ) ;
 225       if (rc == SS$_IVCHAN) return ;
 226       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 227    }
 228
 229    if (--vt->queue) goto start ;
 230
 231    return;
 232 }
 233
 234 #define in (io_flags == REDIR_INPUT)
 235 #define out (io_flags == REDIR_OUTPUT)
 236 #define fout (io_flags == REDIR_OUTFIFO)
 237 int vms_do_command( tsd_t *TSD, const streng *cmd, int io_flags, environment *env, Queue *redir )
 238 {
 239    struct dsc$descriptor_s name, input, output, prc_name ;
 240    int fdin[2], fdout[2], strval[2], strval2[2], lim=0, max=0 ;
 241    int rc, rc1, child, status, fin, eflag, olen, ilen ;
 242    char line[128], obuf[32], buf2[32], ibuf[32], nbuf[32] ;
 243    struct mbox_status stat ;
 244    vms_tsd_t *vt;
 245
 246    vt = TSD->vms_tsd;
 247    name.dsc$w_length = Str_len( cmd ) ;
 248    name.dsc$b_dtype = DSC$K_DTYPE_T ;
 249    name.dsc$b_class = DSC$K_CLASS_S ;
 250    name.dsc$a_pointer = (char *)cmd->value ;
 251
 252    vt->ichan = vt->ochan = 0 ;
 253    if (in) {
 254       vt->dead = vt->queue = 0 ;
 255       rc = sys$crembx(0, &vt->ichan, BUFSIZE, BUFSIZE*NUMBUFS, 0, 0, 0) ;
 256       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 257       strval[0] = sizeof(ibuf) ;
 258       strval[1] = (int) ibuf ;
 259       rc = lib$getdvi( &DVI$_DEVNAM, &vt->ichan, 0, 0, strval, &ilen) ;
 260       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 261
 262       input.dsc$w_length = ilen ;
 263       input.dsc$b_dtype = DSC$K_DTYPE_T ;
 264       input.dsc$b_class = DSC$K_CLASS_S ;
 265       input.dsc$a_pointer = ibuf ;
 266
 267    }
 268
 269    if (out || fout) {
 270       rc = sys$crembx(0,&vt->ochan,BUFSIZE,BUFSIZE*NUMBUFS,0,0,0) ;
 271       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 272
 273 #     ifdef VMS_DEBUG
 274          printf( "sys$crembx() ochan=%d, rc=%d\n", vt->ochan, rc ) ;
 275 #     endif
 276
 277       strval[0] = sizeof(obuf) ;
 278       strval[1] = (int) obuf ;
 279       rc=lib$getdvi( &DVI$_DEVNAM, &vt->ochan, 0, 0, strval, &olen) ;
 280       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 281
 282 #     ifdef VMS_DEBUG
 283          printf( "lib$getdvi() name=(%d) <%s>\n", olen, obuf ) ;
 284 #     endif
 285
 286       output.dsc$w_length = olen ;
 287       output.dsc$b_dtype = DSC$K_DTYPE_T ;
 288       output.dsc$b_class = DSC$K_CLASS_S ;
 289       output.dsc$a_pointer = obuf ;
 290    }
 291
 292    sprintf( nbuf, "REXX-%d", getpid()) ;
 293    prc_name.dsc$w_length = strlen( nbuf ) ;
 294    prc_name.dsc$b_dtype = DSC$K_DTYPE_T ;
 295    prc_name.dsc$b_class = DSC$K_CLASS_S ;
 296    prc_name.dsc$a_pointer = nbuf ;
 297
 298    if (io_flags == REDIR_OUTPUT || io_flags == REDIR_OUTFIFO) {
 299       rc = lib$get_ef( &vt->oflag ) ;
 300       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 301
 302       rc = sys$clref( vt->oflag ) ;
 303 /*      if (rc != SS$_NORMAL) complain( TSD, rc ) ; */
 304    }
 305
 306    rc = lib$get_ef( &eflag ) ;
 307    if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 308
 309    rc = sys$clref( eflag ) ;
 310 /*   if (rc != SS$_NORMAL) complain( TSD, rc ) ; */
 311
 312    vt->comp_stat = 0 ;
 313    rc = lib$spawn( &name,
 314                    ((in) ? &input : NULL),
 315                    ((out || fout) ? &output : NULL),
 316                    &CLI$M_NOWAIT, &prc_name, &vt->pid, &vt->comp_stat,
 317                    &eflag, NULL, NULL, NULL, NULL ) ;
 318
 319    if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 320
 321 #  ifdef VMS_DEBUG
 322       printf( "lib$spawn() rc=%d\n", rc ) ;
 323 #  endif
 324
 325    if (in) write_out_ast() ;
 326
 327    if (out || fout) read_in_ast( 0 ) ;
 328
 329 #  ifdef VMS_DEBUG
 330       printf( "Input and output asts started, synching on process\n" ) ;
 331 #  endif
 332
 333    rc = sys$synch( eflag, NULL ) ;
 334
 335 #  ifdef VMS_DEBUG
 336       printf( "sys$synch() rc=%d, ochan=%d\n", rc, vt->ochan ) ;
 337 #  endif
 338
 339    if (vt->ichan) {
 340       rc = sys$dassgn( (short)vt->ichan ) ;
 341       vt->ichan = 0 ;
 342       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 343    }
 344
 345    if (io_flags == REDIR_OUTPUT || io_flags == REDIR_OUTFIFO) {
 346       rc = sys$synch( vt->oflag, NULL ) ;
 347       if (vt->ochan)
 348          printf( "Warning ... output channel still exists ochan=%d\n",
 349                  vt->ochan);
 350
 351       if (rc != SS$_NORMAL)
 352          complain( TSD, rc ) ;
 353
 354       rc = lib$free_ef( &vt->oflag ) ;
 355       if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 356    }
 357
 358    rc = lib$free_ef( &eflag ) ;
 359    if (rc != SS$_NORMAL) complain( TSD, rc ) ;
 360
 361    /*
 362     * Warning, kludge ahead!!!   When a process under VMS exits, it
 363     * seems like there is a little delay until the PRCCNT (process
 364     * count) is decremented. So ... if we just continues without
 365     * sync'ing up against the PRCCNT, we might get a 'quota exceeded'
 366     * on the next command (if it is started very soon)
 367     */
 368
 369    lib$getjpi( &JPI$_PRCLM, 0, 0, &max, 0, 0 ) ;
 370    for (lim=max; lim>=max; )
 371       lib$getjpi( &JPI$_PRCCNT, 0, 0, &lim, 0, 0 ) ;
 372
 373    complain( TSD, 0 ) ;
 374
 375 #ifdef TODO
 376    if (out || fout)
 377       flush_stack( TSD, io_flags ) ;
 378 #endif
 379
 380 /*
 381  * I have no idea _why_, but bit 28 is sometimes set in the comp_stat.
 382  * Manuals indicate that this is an internal field, but at least it
 383  * kills checking against the predefined symbols, so I strip it away.
 384  * This should most probably have been handled differently, can someone
 385  * educate me on this?   .... please???
 386  */
 387    if ((vt->comp_stat & 0x0fffffff) == CLI$_NORMAL) vt->comp_stat = SS$_NORMAL ;
 388    return (((vt->comp_stat & 0x0fffffff)==SS$_NORMAL) ? 0 : vt->comp_stat) ;
 389 }
 390 #endif
 391
 392 int vms_killproc( tsd_t *TSD )
 393 {
 394    vms_tsd_t *vt;
 395
 396    vt = TSD->vms_tsd;
 397    if (vt->pid)
 398       sys$delprc( &vt->pid, NULL ) ;
 399
 400    vt->pid = 0 ;
 401    return 0;
 402 }
 403
 404 streng *vms_resolv_symbol( tsd_t *TSD, streng *name, streng *new, streng *pool )
 405 {
 406    struct dsc$descriptor_s sym_name, sym_val, new_val ;
 407    char buffer[MAX_SYM_LENGTH] ;
 408    unsigned int length=0 ;
 409    int rc ;
 410    streng *old ;
 411    vms_tsd_t *vt;
 412
 413    vt = TSD->vms_tsd;
 414    sym_name.dsc$w_length = Str_len( name ) ;
 415    sym_name.dsc$b_dtype = DSC$K_DTYPE_T ;
 416    sym_name.dsc$b_class = DSC$K_CLASS_S ;
 417    sym_name.dsc$a_pointer = name->value ;
 418
 419    if (new) {
 420       new_val.dsc$w_length = Str_len( new ) ;
 421       new_val.dsc$b_dtype = DSC$K_DTYPE_T ;
 422       new_val.dsc$b_class = DSC$K_CLASS_S ;
 423       new_val.dsc$a_pointer = new->value ;
 424    }
 425
 426    sym_val.dsc$w_length = MAX_SYM_LENGTH ;
 427    sym_val.dsc$b_dtype = DSC$K_DTYPE_T ;
 428    sym_val.dsc$b_class = DSC$K_CLASS_S ;
 429    sym_val.dsc$a_pointer = buffer ;
 430
 431    if (strncmp( pool->value, "SYMBOL", MAX(6,Str_len(pool))) ||
 432        strncmp( pool->value, "SYSTEM", MAX(6,Str_len(pool))))
 433    {
 434       rc = lib$get_symbol( &sym_name, &sym_val, &length ) ;
 435       if (new)
 436          lib$set_symbol( &sym_name, &new_val ) ;
 437    }
 438    else if (strncmp( pool->value, "LOGICAL", MAX(7, Str_len(pool))))
 439    {
 440 /*    rc = lib$get_logical( ... ) */
 441       if (new)
 442          lib$set_symbol( &sym_name, &new_val ) ;
 443       else
 444          lib$delete_logical( &sym_name ) ;
 445    } else {
 446       return(NULL) ;
 447    }
 448
 449    old = Str_makeTSD( length ) ;
 450    Str_ncatstrTSD( old, buffer, length ) ;
 451    return(old) ;
 452 }