src/vmsfns.c

   1 /* VMS subprocess and command interface.
   2    Copyright (C) 1987, 1988 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 1, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20 /* Written by Mukesh Prasad.  */
  21
  22 /*
  23  * INTERFACE PROVIDED BY EMACS FOR VMS SUBPROCESSES:
  24  *
  25  *      Emacs provides the following functions:
  26  *
  27  *      "spawn-subprocess", which takes as arguments:
  28  *
  29  *        (i)   an integer to identify the spawned subprocess in future
  30  *              operations,
  31  *        (ii)  A function to process input from the subprocess, and
  32  *        (iii) A function to be called upon subprocess termination.
  33  *
  34  *      First argument is required.  If second argument is missing or nil,
  35  *      the default action is to insert all received messages at the current
  36  *      location in the current buffer.  If third argument is missing or nil,
  37  *      no action is taken upon subprocess termination.
  38  *      The input-handler is called as
  39  *              (input-handler num string)
  40  *      where num is the identifying integer for the subprocess and string
  41  *      is a string received from the subprocess.  exit-handler is called
  42  *      with the identifying integer as the argument.
  43  *
  44  *      "send-command-to-subprocess" takes two arguments:
  45  *
  46  *        (i)   Subprocess identifying integer.
  47  *        (ii)  String to send as a message to the subprocess.
  48  *
  49  *      "stop-subprocess" takes the subprocess identifying integer as
  50  *      argument.
  51  *
  52  *  Implementation is done by spawning an asynchronous subprocess, and
  53  *  communicating to it via mailboxes.
  54  */
  55
  56 #ifdef VMS
  57
  58 #include <stdio.h>
  59 #include <ctype.h>
  60 #undef NULL
  61
  62 #include "config.h"
  63 #include "lisp.h"
  64 #include <descrip.h>
  65 #include <dvidef.h>
  66 #include <prvdef.h>
  67 /* #include <clidef.h> */
  68 #include <iodef.h>
  69 #include <ssdef.h>
  70 #include <errno.h>
  71
  72 #ifdef VMS4_4   /* I am being cautious; perhaps this exists in older versions */
  73 #include <jpidef.h>
  74 #endif
  75
  76 /* #include <syidef.h> */
  77
  78 #define CLI$M_NOWAIT    1       /* clidef.h is missing from C library */
  79 #define SYI$_VERSION    4096    /* syidef.h is missing from C library */
  80 #define JPI$_CLINAME    522     /* JPI$_CLINAME is missing from jpidef.h */
  81 #define JPI$_MASTER_PID 805     /* JPI$_MASTER_PID missing from jpidef.h */
  82 #define LIB$_NOSUCHSYM  1409892 /* libclidef.h missing */
  83
  84 #define MSGSIZE 160             /* Maximum size for mailbox operations */
  85
  86 #ifndef PRV$V_ACNT
  87
  88 /* these defines added as hack for VMS 5.1-1.   SJones, 8-17-89 */
  89 /* this is _really_ nasty and needs to be changed ASAP - should see about
  90    using the union defined in SYS$LIBRARY:PRVDEF.H under v5 */
  91
  92 #define PRV$V_ACNT      0x09
  93 #define PRV$V_ALLSPOOL  0x04
  94 #define PRV$V_ALTPRI    0x0D
  95 #define PRV$V_BUGCHK    0x17
  96 #define PRV$V_BYPASS    0x1D
  97 #define PRV$V_CMEXEC    0x01
  98 #define PRV$V_CMKRNL    0x00
  99 #define PRV$V_DETACH    0x05
 100 #define PRV$V_DIAGNOSE  0x06
 101 #define PRV$V_DOWNGRADE 0x21
 102 #define PRV$V_EXQUOTA   0x13
 103 #define PRV$V_GROUP     0x08
 104 #define PRV$V_GRPNAM    0x03
 105 #define PRV$V_GRPPRV    0x22
 106 #define PRV$V_LOG_IO    0x07
 107 #define PRV$V_MOUNT     0x11
 108 #define PRV$V_NETMBX    0x14
 109 #define PRV$V_NOACNT    0x09
 110 #define PRV$V_OPER      0x12
 111 #define PRV$V_PFNMAP    0x1A
 112 #define PRV$V_PHY_IO    0x16
 113 #define PRV$V_PRMCEB    0x0A
 114 #define PRV$V_PRMGBL    0x18
 115 #define PRV$V_PRMJNL    0x25
 116 #define PRV$V_PRMMBX    0x0B
 117 #define PRV$V_PSWAPM    0x0C
 118 #define PRV$V_READALL   0x23
 119 #define PRV$V_SECURITY  0x26
 120 #define PRV$V_SETPRI    0x0D
 121 #define PRV$V_SETPRV    0x0E
 122 #define PRV$V_SHARE     0x1F
 123 #define PRV$V_SHMEM     0x1B
 124 #define PRV$V_SYSGBL    0x19
 125 #define PRV$V_SYSLCK    0x1E
 126 #define PRV$V_SYSNAM    0x02
 127 #define PRV$V_SYSPRV    0x1C
 128 #define PRV$V_TMPJNL    0x24
 129 #define PRV$V_TMPMBX    0x0F
 130 #define PRV$V_UPGRADE   0x20
 131 #define PRV$V_VOLPRO    0x15
 132 #define PRV$V_WORLD     0x10
 133 #endif
 134
 135 /* IO status block for mailbox operations.  */
 136 struct mbx_iosb
 137 {
 138   short status;
 139   short size;
 140   int   pid;
 141 };
 142
 143 /* Structure for maintaining linked list of subprocesses.  */
 144 struct process_list
 145 {
 146   int name;                     /* Numeric identifier for subprocess */
 147   int process_id;               /* VMS process address */
 148   int process_active;           /* 1 iff process has not exited yet */
 149   int mbx_chan;                 /* Mailbox channel to write to process */
 150   struct mbx_iosb iosb;         /* IO status block for write operations */
 151   Lisp_Object input_handler;    /* Input handler for subprocess */
 152   Lisp_Object exit_handler;     /* Exit handler for subprocess */
 153   struct process_list * next;   /* Linked list chain */
 154 };
 155
 156 /* Structure for privilege list.  */
 157 struct privilege_list
 158 {
 159   char * name;
 160   int  mask;
 161 };
 162
 163 /* Structure for finding VMS related information.  */
 164 struct vms_objlist
 165 {
 166   char * name;                  /* Name of object */
 167   Lisp_Object (* objfn)();      /* Function to retrieve VMS object */
 168 };
 169
 170 static int exit_ast ();         /* Called upon subprocess exit */
 171 static int create_mbx ();       /* Creates mailbox */
 172 static void mbx_msg ();         /* Writes null terminated string to mbx */
 173 static void write_to_mbx ();    /* Writes message to string */
 174 static void start_mbx_input (); /* Queues I/O request to mailbox */
 175
 176 static int input_mbx_chan = 0;  /* Channel to read subprocess input on */
 177 static char input_mbx_name[20];
 178                                 /* Storage for mailbox device name */
 179 static struct dsc$descriptor_s input_mbx_dsc;
 180                                 /* Descriptor for mailbox device name */
 181 static struct process_list * process_list = 0;
 182                                 /* Linked list of subprocesses */
 183 static char mbx_buffer[MSGSIZE];
 184                                 /* Buffer to read from subprocesses */
 185 static struct mbx_iosb input_iosb;
 186                                 /* IO status block for mailbox reads */
 187
 188 int have_process_input,         /* Non-zero iff subprocess input pending */
 189     process_exited;             /* Non-zero iff suprocess exit pending */
 190
 191 /* List of privilege names and mask offsets */
 192 static struct privilege_list priv_list[] = {
 193
 194     { "ACNT",           PRV$V_ACNT },
 195     { "ALLSPOOL",       PRV$V_ALLSPOOL },
 196     { "ALTPRI",         PRV$V_ALTPRI },
 197     { "BUGCHK",         PRV$V_BUGCHK },
 198     { "BYPASS",         PRV$V_BYPASS },
 199     { "CMEXEC",         PRV$V_CMEXEC },
 200     { "CMKRNL",         PRV$V_CMKRNL },
 201     { "DETACH",         PRV$V_DETACH },
 202     { "DIAGNOSE",       PRV$V_DIAGNOSE },
 203     { "DOWNGRADE",      PRV$V_DOWNGRADE }, /* Isn't VMS as low as you can go?  */
 204     { "EXQUOTA",        PRV$V_EXQUOTA },
 205     { "GRPPRV",         PRV$V_GRPPRV },
 206     { "GROUP",          PRV$V_GROUP },
 207     { "GRPNAM",         PRV$V_GRPNAM },
 208     { "LOG_IO",         PRV$V_LOG_IO },
 209     { "MOUNT",          PRV$V_MOUNT },
 210     { "NETMBX",         PRV$V_NETMBX },
 211     { "NOACNT",         PRV$V_NOACNT },
 212     { "OPER",           PRV$V_OPER },
 213     { "PFNMAP",         PRV$V_PFNMAP },
 214     { "PHY_IO",         PRV$V_PHY_IO },
 215     { "PRMCEB",         PRV$V_PRMCEB },
 216     { "PRMGBL",         PRV$V_PRMGBL },
 217     { "PRMJNL",         PRV$V_PRMJNL },
 218     { "PRMMBX",         PRV$V_PRMMBX },
 219     { "PSWAPM",         PRV$V_PSWAPM },
 220     { "READALL",        PRV$V_READALL },
 221     { "SECURITY",       PRV$V_SECURITY },
 222     { "SETPRI",         PRV$V_SETPRI },
 223     { "SETPRV",         PRV$V_SETPRV },
 224     { "SHARE",          PRV$V_SHARE },
 225     { "SHMEM",          PRV$V_SHMEM },
 226     { "SYSGBL",         PRV$V_SYSGBL },
 227     { "SYSLCK",         PRV$V_SYSLCK },
 228     { "SYSNAM",         PRV$V_SYSNAM },
 229     { "SYSPRV",         PRV$V_SYSPRV },
 230     { "TMPJNL",         PRV$V_TMPJNL },
 231     { "TMPMBX",         PRV$V_TMPMBX },
 232     { "UPGRADE",        PRV$V_UPGRADE },
 233     { "VOLPRO",         PRV$V_VOLPRO },
 234     { "WORLD",          PRV$V_WORLD },
 235
 236     };
 237
 238 static Lisp_Object
 239           vms_account(), vms_cliname(), vms_owner(), vms_grp(), vms_image(),
 240           vms_parent(), vms_pid(), vms_prcnam(), vms_terminal(), vms_uic_int(),
 241           vms_uic_str(), vms_username(), vms_version_fn(), vms_trnlog(),
 242           vms_symbol(), vms_proclist();
 243
 244 /* Table of arguments to Fvms_object, and the handlers that get the data.  */
 245
 246 static struct vms_objlist vms_object [] = {
 247     { "ACCOUNT",        vms_account },  /* Returns account name as a string */
 248     { "CLINAME",        vms_cliname },  /* Returns CLI name (string) */
 249     { "OWNER",          vms_owner },    /* Returns owner process's PID (int) */
 250     { "GRP",            vms_grp },      /* Returns group number of UIC (int) */
 251     { "IMAGE",          vms_image },    /* Returns executing image (string) */
 252     { "PARENT",         vms_parent },   /* Returns parent proc's PID (int) */
 253     { "PID",            vms_pid },      /* Returns process's PID (int) */
 254     { "PRCNAM",         vms_prcnam },   /* Returns process's name (string) */
 255     { "TERMINAL",       vms_terminal }, /* Returns terminal name (string) */
 256     { "UIC",            vms_uic_int },  /* Returns UIC as integer */
 257     { "UICGRP",         vms_uic_str },  /* Returns UIC as string */
 258     { "USERNAME",       vms_username }, /* Returns username (string) */
 259     { "VERSION",        vms_version_fn },/* Returns VMS version (string) */
 260     { "LOGICAL",        vms_trnlog },   /* Translates VMS logical name */
 261     { "DCL-SYMBOL",     vms_symbol },   /* Translates DCL symbol */
 262     { "PROCLIST",       vms_proclist }, /* Returns list of all PIDs on system */
 263     };
 264
 265 Lisp_Object Qdefault_subproc_input_handler;
 266
 267 extern int process_ef;          /* Event flag for subprocess operations */
 268
 269 DEFUN ("default-subprocess-input-handler",
 270   Fdefault_subproc_input_handler, Sdefault_subproc_input_handler,
 271   2, 2, 0,
 272   "Default input handler for input from spawned subprocesses.")
 273   (name, input)
 274      Lisp_Object name, input;
 275 {
 276   /* Just insert in current buffer */
 277   insert1 (input);
 278   insert ("\n", 1);
 279 }
 280
 281 DEFUN ("spawn-subprocess", Fspawn_subprocess, Sspawn_subprocess, 1, 3, 0,
 282   "Spawn an asynchronous VMS suprocess for command processing.")
 283   (name, input_handler, exit_handler)
 284      Lisp_Object name, input_handler, exit_handler;
 285 {
 286   int status;
 287   char output_mbx_name[20];
 288   struct dsc$descriptor_s output_mbx_dsc;
 289   struct process_list *ptr, *p, *prev;
 290
 291   CHECK_NUMBER (name, 0);
 292   if (! input_mbx_chan)
 293     {
 294       if (! create_mbx (&input_mbx_dsc, input_mbx_name, &input_mbx_chan, 1))
 295         return Qnil;
 296       start_mbx_input ();
 297     }
 298   ptr = 0;
 299   prev = 0;
 300   while (ptr)
 301     {
 302       struct process_list *next = ptr->next;
 303       if (ptr->name == XFASTINT (name))
 304         {
 305           if (ptr->process_active)
 306             return Qt;
 307
 308           /* Delete this process and run its exit handler.  */
 309           if (prev)
 310             prev->next = next;
 311           else
 312             process_list = next;
 313           if (! NILP (ptr->exit_handler))
 314             Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name),
 315                                                     Qnil)));
 316           sys$dassgn (ptr->mbx_chan);
 317           break;
 318         }
 319       else
 320         prev = ptr;
 321       ptr = next;
 322     }
 323   if (! ptr)
 324     ptr = xmalloc (sizeof (struct process_list));
 325   if (! create_mbx (&output_mbx_dsc, output_mbx_name, &ptr->mbx_chan, 2))
 326     {
 327       free (ptr);
 328       return Qnil;
 329     }
 330   if (NILP (input_handler))
 331     input_handler = Qdefault_subproc_input_handler;
 332   ptr->input_handler = input_handler;
 333   ptr->exit_handler = exit_handler;
 334   message ("Creating subprocess...");
 335   status = lib$spawn (0, &output_mbx_dsc, &input_mbx_dsc, &CLI$M_NOWAIT, 0,
 336                       &ptr->process_id, 0, 0, exit_ast, &ptr->process_active);
 337   if (! (status & 1))
 338     {
 339       sys$dassgn (ptr->mbx_chan);
 340       free (ptr);
 341       error ("Unable to spawn subprocess");
 342       return Qnil;
 343     }
 344   ptr->name = XFASTINT (name);
 345   ptr->next = process_list;
 346   ptr->process_active = 1;
 347   process_list = ptr;
 348   message ("Creating subprocess...done");
 349   return Qt;
 350 }
 351
 352 static void
 353 mbx_msg (ptr, msg)
 354      struct process_list *ptr;
 355      char *msg;
 356 {
 357   write_to_mbx (ptr, msg, strlen (msg));
 358 }
 359
 360 DEFUN ("send-command-to-subprocess",
 361   Fsend_command_to_subprocess, Ssend_command_to_subprocess, 2, 2,
 362   "sSend command to subprocess: \nsSend subprocess %s command: ",
 363   "Send to VMS subprocess named NAME the string COMMAND.")
 364   (name, command)
 365      Lisp_Object name, command;
 366 {
 367   struct process_list * ptr;
 368
 369   CHECK_NUMBER (name, 0);
 370   CHECK_STRING (command, 1);
 371   for (ptr = process_list; ptr; ptr = ptr->next)
 372     if (XFASTINT (name) == ptr->name)
 373       {
 374         write_to_mbx (ptr, XSTRING (command)->data,
 375                       XSTRING (command)->size);
 376         return Qt;
 377       }
 378   return Qnil;
 379 }
 380
 381 DEFUN ("stop-subprocess", Fstop_subprocess, Sstop_subprocess, 1, 1,
 382   "sStop subprocess: ", "Stop VMS subprocess named NAME.")
 383   (name)
 384      Lisp_Object name;
 385 {
 386   struct process_list * ptr;
 387
 388   CHECK_NUMBER (name, 0);
 389   for (ptr = process_list; ptr; ptr = ptr->next)
 390     if (XFASTINT (name) == ptr->name)
 391       {
 392         ptr->exit_handler = Qnil;
 393         if (sys$delprc (&ptr->process_id, 0) & 1)
 394           ptr->process_active = 0;
 395         return Qt;
 396       }
 397   return Qnil;
 398 }
 399
 400 static int
 401 exit_ast (active)
 402      int * active;
 403 {
 404   process_exited = 1;
 405   *active = 0;
 406   sys$setef (process_ef);
 407 }
 408
 409 /* Process to handle input on the input mailbox.
 410  * Searches through the list of processes until the matching PID is found,
 411  * then calls its input handler.
 412  */
 413
 414 process_command_input ()
 415 {
 416   struct process_list * ptr;
 417   char * msg;
 418   int msglen;
 419   Lisp_Object expr;
 420
 421   msg = mbx_buffer;
 422   msglen = input_iosb.size;
 423   /* Hack around VMS oddity of sending extraneous CR/LF characters for
 424    * some of the commands (but not most).
 425    */
 426   if (msglen > 0 && *msg == '\r')
 427     {
 428       msg++;
 429       msglen--;
 430     }
 431   if (msglen > 0 && msg[msglen - 1] == '\n')
 432     msglen--;
 433   if (msglen > 0 && msg[msglen - 1] == '\r')
 434     msglen--;
 435   /* Search for the subprocess in the linked list.
 436    */
 437   expr = Qnil;
 438   for (ptr = process_list; ptr; ptr = ptr->next)
 439     if (ptr->process_id == input_iosb.pid)
 440       {
 441         expr = Fcons (ptr->input_handler,
 442                       Fcons (make_number (ptr->name),
 443                              Fcons (make_string (msg, msglen),
 444                                     Qnil)));
 445         break;
 446       }
 447   have_process_input = 0;
 448   start_mbx_input ();
 449   clear_waiting_for_input ();    /* Otherwise Ctl-g will cause crash. JCB */
 450   if (! NILP (expr))
 451     Feval (expr);
 452 }
 453
 454 /* Searches process list for any processes which have exited.  Calls their
 455  * exit handlers and removes them from the process list.
 456  */
 457
 458 process_exit ()
 459 {
 460   struct process_list * ptr, * prev, * next;
 461
 462   process_exited = 0;
 463   prev = 0;
 464   ptr = process_list;
 465   while (ptr)
 466     {
 467       next = ptr->next;
 468       if (! ptr->process_active)
 469         {
 470           if (prev)
 471             prev->next = next;
 472           else
 473             process_list = next;
 474           if (! NILP (ptr->exit_handler))
 475             Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name),
 476                                                     Qnil)));
 477           sys$dassgn (ptr->mbx_chan);
 478           free (ptr);
 479         }
 480       else
 481         prev = ptr;
 482       ptr = next;
 483     }
 484 }
 485
 486 /* Called at emacs exit.
 487  */
 488
 489 kill_vms_processes ()
 490 {
 491   struct process_list * ptr;
 492
 493   for (ptr = process_list; ptr; ptr = ptr->next)
 494     if (ptr->process_active)
 495       {
 496         sys$dassgn (ptr->mbx_chan);
 497         sys$delprc (&ptr->process_id, 0);
 498       }
 499   sys$dassgn (input_mbx_chan);
 500   process_list = 0;
 501   input_mbx_chan = 0;
 502 }
 503
 504 /* Creates a temporary mailbox and retrieves its device name in 'buf'.
 505  * Makes the descriptor pointed to by 'dsc' refer to this device.
 506  * 'buffer_factor' is used to allow sending messages asynchronously
 507  * till some point.
 508  */
 509
 510 static int
 511 create_mbx (dsc, buf, chan, buffer_factor)
 512      struct dsc$descriptor_s *dsc;
 513      char *buf;
 514      int *chan;
 515      int buffer_factor;
 516 {
 517   int strval[2];
 518   int status;
 519
 520   status = sys$crembx (0, chan, MSGSIZE, MSGSIZE * buffer_factor, 0, 0, 0);
 521   if (! (status & 1))
 522     {
 523       message ("Unable to create mailbox.  Need TMPMBX privilege.");
 524       return 0;
 525     }
 526   strval[0] = 16;
 527   strval[1] = buf;
 528   status = lib$getdvi (&DVI$_DEVNAM, chan, 0, 0, strval,
 529                        &dsc->dsc$w_length);
 530   if (! (status & 1))
 531     return 0;
 532   dsc->dsc$b_dtype = DSC$K_DTYPE_T;
 533   dsc->dsc$b_class = DSC$K_CLASS_S;
 534   dsc->dsc$a_pointer = buf;
 535   return 1;
 536 }                               /* create_mbx */
 537
 538 /* AST routine to be called upon receiving mailbox input.
 539  * Sets flag telling keyboard routines that input is available.
 540  */
 541
 542 static int
 543 mbx_input_ast ()
 544 {
 545   have_process_input = 1;
 546 }
 547
 548 /* Issue a QIO request on the input mailbox.
 549  */
 550 static void
 551 start_mbx_input ()
 552 {
 553   sys$qio (process_ef, input_mbx_chan, IO$_READVBLK, &input_iosb,
 554            mbx_input_ast, 0, mbx_buffer, sizeof (mbx_buffer),
 555            0, 0, 0, 0);
 556 }
 557
 558 /* Send a message to the subprocess input mailbox, without blocking if
 559  * possible.
 560  */
 561 static void
 562 write_to_mbx (ptr, buf, len)
 563      struct process_list *ptr;
 564      char *buf;
 565      int len;
 566 {
 567   sys$qiow (0, ptr->mbx_chan, IO$_WRITEVBLK | IO$M_NOW, &ptr->iosb,
 568             0, 0, buf, len, 0, 0, 0, 0);
 569 }
 570
 571 DEFUN ("setprv", Fsetprv, Ssetprv, 1, 3, 0,
 572   "Set or reset a VMS privilege.  First arg is privilege name.\n\
 573 Second arg is t or nil, indicating whether the privilege is to be\n\
 574 set or reset.  Default is nil.  Returns t if success, nil if not.\n\
 575 If third arg is non-nil, does not change privilege, but returns t\n\
 576 or nil depending upon whether the privilege is already enabled.")
 577   (priv, value, getprv)
 578      Lisp_Object priv, value, getprv;
 579 {
 580   int prvmask[2], prvlen, newmask[2];
 581   char * prvname;
 582   int found, i;
 583   struct privilege_list * ptr;
 584
 585   CHECK_STRING (priv, 0);
 586   priv = Fupcase (priv);
 587   prvname = XSTRING (priv)->data;
 588   prvlen = XSTRING (priv)->size;
 589   found = 0;
 590   prvmask[0] = 0;
 591   prvmask[1] = 0;
 592   for (i = 0; i < sizeof (priv_list) / sizeof (priv_list[0]); i++)
 593     {
 594       ptr = &priv_list[i];
 595       if (prvlen == strlen (ptr->name) &&
 596           bcmp (prvname, ptr->name, prvlen) == 0)
 597         {
 598           if (ptr->mask >= 32)
 599             prvmask[1] = 1 << (ptr->mask % 32);
 600           else
 601             prvmask[0] = 1 << ptr->mask;
 602           found = 1;
 603           break;
 604         }
 605     }
 606   if (! found)
 607     error ("Unknown privilege name %s", XSTRING (priv)->data);
 608   if (NILP (getprv))
 609     {
 610       if (sys$setprv (NILP (value) ? 0 : 1, prvmask, 0, 0) == SS$_NORMAL)
 611         return Qt;
 612       return Qnil;
 613     }
 614   /* Get old priv value */
 615   if (sys$setprv (0, 0, 0, newmask) != SS$_NORMAL)
 616     return Qnil;
 617   if ((newmask[0] & prvmask[0])
 618       || (newmask[1] & prvmask[1]))
 619     return Qt;
 620   return Qnil;
 621 }
 622 \f
 623 /* Retrieves VMS system information.  */
 624
 625 #ifdef VMS4_4  /* I don't know whether these functions work in old versions */
 626
 627 DEFUN ("vms-system-info", Fvms_system_info, Svms_system_info, 1, 3, 0,
 628   "Retrieve VMS process and system information.\n\
 629 The first argument (a string) specifies the type of information desired.\n\
 630 The other arguments depend on the type you select.\n\
 631 For information about a process, the second argument is a process ID\n\
 632 or a process name, with the current process as a default.\n\
 633 These are the possibilities for the first arg (upper or lower case ok):\n\
 634     account     Returns account name\n\
 635     cliname     Returns CLI name\n\
 636     owner       Returns owner process's PID\n\
 637     grp         Returns group number\n\
 638     parent      Returns parent process's PID\n\
 639     pid         Returns process's PID\n\
 640     prcnam      Returns process's name\n\
 641     terminal    Returns terminal name\n\
 642     uic         Returns UIC number\n\
 643     uicgrp      Returns formatted [UIC,GRP]\n\
 644     username    Returns username\n\
 645     version     Returns VMS version\n\
 646     logical     Translates VMS logical name (second argument)\n\
 647     dcl-symbol  Translates DCL symbol (second argument)\n\
 648     proclist    Returns list of all PIDs on system (needs WORLD privilege)." )
 649   (type, arg1, arg2)
 650      Lisp_Object type, arg1, arg2;
 651 {
 652   int i, typelen;
 653   char * typename;
 654   struct vms_objlist * ptr;
 655
 656   CHECK_STRING (type, 0);
 657   type = Fupcase (type);
 658   typename = XSTRING (type)->data;
 659   typelen = XSTRING (type)->size;
 660   for (i = 0; i < sizeof (vms_object) / sizeof (vms_object[0]); i++)
 661     {
 662       ptr = &vms_object[i];
 663       if (typelen == strlen (ptr->name)
 664           && bcmp (typename, ptr->name, typelen) == 0)
 665         return (* ptr->objfn)(arg1, arg2);
 666     }
 667   error ("Unknown object type %s", typename);
 668 }
 669 \f
 670 /* Given a reference to a VMS process, returns its process id.  */
 671
 672 static int
 673 translate_id (pid, owner)
 674      Lisp_Object pid;
 675      int owner;         /* if pid is null/0, return owner.  If this
 676                          * flag is 0, return self. */
 677 {
 678   int status, code, id, i, numeric, size;
 679   char * p;
 680   int prcnam[2];
 681
 682   if (NILP (pid)
 683       || XTYPE (pid) == Lisp_String && XSTRING (pid)->size == 0
 684       || XTYPE (pid) == Lisp_Int && XFASTINT (pid) == 0)
 685     {
 686       code = owner ? JPI$_OWNER : JPI$_PID;
 687       status = lib$getjpi (&code, 0, 0, &id);
 688       if (! (status & 1))
 689         error ("Cannot find %s: %s",
 690                owner ? "owner process" : "process id",
 691                vmserrstr (status));
 692       return (id);
 693     }
 694   if (XTYPE (pid) == Lisp_Int)
 695     return (XFASTINT (pid));
 696   CHECK_STRING (pid, 0);
 697   pid = Fupcase (pid);
 698   size = XSTRING (pid)->size;
 699   p = XSTRING (pid)->data;
 700   numeric = 1;
 701   id = 0;
 702   for (i = 0; i < size; i++, p++)
 703     if (isxdigit (*p))
 704       {
 705         id *= 16;
 706         if (*p >= '0' && *p <= '9')
 707           id += *p - '0';
 708         else
 709           id += *p - 'A' + 10;
 710       }
 711     else
 712       {
 713         numeric = 0;
 714         break;
 715       }
 716   if (numeric)
 717     return (id);
 718   prcnam[0] = XSTRING (pid)->size;
 719   prcnam[1] = XSTRING (pid)->data;
 720   status = lib$getjpi (&JPI$_PID, 0, prcnam, &id);
 721   if (! (status & 1))
 722     error ("Cannot find process id: %s",
 723            vmserrstr (status));
 724   return (id);
 725 }                               /* translate_id */
 726 \f
 727 /* VMS object retrieval functions.  */
 728
 729 static Lisp_Object
 730 getjpi (jpicode, arg, numeric)
 731      int jpicode;               /* Type of GETJPI information */
 732      Lisp_Object arg;
 733      int numeric;               /* 1 if numeric value expected */
 734 {
 735   int id, status, numval;
 736   char str[128];
 737   int strdsc[2] = { sizeof (str), str };
 738   short strlen;
 739
 740   id = translate_id (arg, 0);
 741   status = lib$getjpi (&jpicode, &id, 0, &numval, strdsc, &strlen);
 742   if (! (status & 1))
 743     error ("Unable to retrieve information: %s",
 744            vmserrstr (status));
 745   if (numeric)
 746     return (make_number (numval));
 747   return (make_string (str, strlen));
 748 }
 749
 750 static Lisp_Object
 751 vms_account (arg1, arg2)
 752      Lisp_Object arg1, arg2;
 753 {
 754   return getjpi (JPI$_ACCOUNT, arg1, 0);
 755 }
 756
 757 static Lisp_Object
 758 vms_cliname (arg1, arg2)
 759      Lisp_Object arg1, arg2;
 760 {
 761   return getjpi (JPI$_CLINAME, arg1, 0);
 762 }
 763
 764 static Lisp_Object
 765 vms_grp (arg1, arg2)
 766      Lisp_Object arg1, arg2;
 767 {
 768   return getjpi (JPI$_GRP, arg1, 1);
 769 }
 770
 771 static Lisp_Object
 772 vms_image (arg1, arg2)
 773      Lisp_Object arg1, arg2;
 774 {
 775   return getjpi (JPI$_IMAGNAME, arg1, 0);
 776 }
 777
 778 static Lisp_Object
 779 vms_owner (arg1, arg2)
 780      Lisp_Object arg1, arg2;
 781 {
 782   return getjpi (JPI$_OWNER, arg1, 1);
 783 }
 784
 785 static Lisp_Object
 786 vms_parent (arg1, arg2)
 787      Lisp_Object arg1, arg2;
 788 {
 789   return getjpi (JPI$_MASTER_PID, arg1, 1);
 790 }
 791
 792 static Lisp_Object
 793 vms_pid (arg1, arg2)
 794      Lisp_Object arg1, arg2;
 795 {
 796   return getjpi (JPI$_PID, arg1, 1);
 797 }
 798
 799 static Lisp_Object
 800 vms_prcnam (arg1, arg2)
 801      Lisp_Object arg1, arg2;
 802 {
 803   return getjpi (JPI$_PRCNAM, arg1, 0);
 804 }
 805
 806 static Lisp_Object
 807 vms_terminal (arg1, arg2)
 808      Lisp_Object arg1, arg2;
 809 {
 810   return getjpi (JPI$_TERMINAL, arg1, 0);
 811 }
 812
 813 static Lisp_Object
 814 vms_uic_int (arg1, arg2)
 815      Lisp_Object arg1, arg2;
 816 {
 817   return getjpi (JPI$_UIC, arg1, 1);
 818 }
 819
 820 static Lisp_Object
 821 vms_uic_str (arg1, arg2)
 822      Lisp_Object arg1, arg2;
 823 {
 824   return getjpi (JPI$_UIC, arg1, 0);
 825 }
 826
 827 static Lisp_Object
 828 vms_username (arg1, arg2)
 829      Lisp_Object arg1, arg2;
 830 {
 831   return getjpi (JPI$_USERNAME, arg1, 0);
 832 }
 833
 834 static Lisp_Object
 835 vms_version_fn (arg1, arg2)
 836      Lisp_Object arg1, arg2;
 837 {
 838   char str[40];
 839   int status;
 840   int strdsc[2] = { sizeof (str), str };
 841   short strlen;
 842
 843   status = lib$getsyi (&SYI$_VERSION, 0, strdsc, &strlen, 0, 0);
 844   if (! (status & 1))
 845     error ("Unable to obtain version: %s", vmserrstr (status));
 846   return (make_string (str, strlen));
 847 }
 848
 849 static Lisp_Object
 850 vms_trnlog (arg1, arg2)
 851      Lisp_Object arg1, arg2;
 852 {
 853   char str[256];                /* Max logical translation is 255 bytes.  */
 854   int status, symdsc[2];
 855   int strdsc[2] = { sizeof (str), str };
 856   short length, level;
 857
 858   CHECK_STRING (arg1, 0);
 859   symdsc[0] = XSTRING (arg1)->size;
 860   symdsc[1] = XSTRING (arg1)->data;
 861   status = lib$sys_trnlog (symdsc, &length, strdsc);
 862   if (! (status & 1))
 863     error ("Unable to translate logical name: %s", vmserrstr (status));
 864   if (status == SS$_NOTRAN)
 865     return (Qnil);
 866   return (make_string (str, length));
 867 }
 868
 869 static Lisp_Object
 870 vms_symbol (arg1, arg2)
 871      Lisp_Object arg1, arg2;
 872 {
 873   char str[1025];               /* Max symbol translation is 1024 bytes.  */
 874   int status, symdsc[2];
 875   int strdsc[2] = { sizeof (str), str };
 876   short length, level;
 877
 878   CHECK_STRING (arg1, 0);
 879   symdsc[0] = XSTRING (arg1)->size;
 880   symdsc[1] = XSTRING (arg1)->data;
 881   status = lib$get_symbol (symdsc, strdsc, &length, &level);
 882   if (! (status & 1)) {
 883     if (status == LIB$_NOSUCHSYM)
 884       return (Qnil);
 885     else
 886       error ("Unable to translate symbol: %s", vmserrstr (status));
 887   }
 888   return (make_string (str, length));
 889 }
 890
 891 static Lisp_Object
 892 vms_proclist (arg1, arg2)
 893      Lisp_Object arg1, arg2;
 894 {
 895   Lisp_Object retval;
 896   int id, status, pid;
 897
 898   retval = Qnil;
 899   pid = -1;
 900   for (;;)
 901     {
 902       status = lib$getjpi (&JPI$_PID, &pid, 0, &id);
 903       if (status == SS$_NOMOREPROC)
 904         break;
 905       if (! (status & 1))
 906         error ("Unable to get process ID: %s", vmserrstr (status));
 907       retval = Fcons (make_number (id), retval);
 908     }
 909   return (Fsort (retval, intern ("<")));
 910 }
 911 \f
 912 DEFUN ("shrink-to-icon", Fshrink_to_icon, Sshrink_to_icon, 0, 0, 0,
 913       "If emacs is running in a workstation window, shrink to an icon.")
 914      ()
 915 {
 916   static char result[128];
 917   static $DESCRIPTOR (result_descriptor, result);
 918   static $DESCRIPTOR (tt_name, "TT:");
 919   static int chan = 0;
 920   static int buf = 0x9d + ('2'<<8) + ('2'<<16) + (0x9c<<24);
 921   int status;
 922   static int temp = JPI$_TERMINAL;
 923
 924   status = lib$getjpi (&temp, 0, 0, 0, &result_descriptor, 0);
 925   if (status != SS$_NORMAL)
 926     error ("Unable to determine terminal type.");
 927   if (result[0] != 'W' || result[1] != 'T') /* see if workstation */
 928     error ("Can't shrink-to-icon on a non workstation terminal");
 929   if (!chan)                            /* assign channel if not assigned */
 930     if ((status = sys$assign (&tt_name, &chan, 0, 0)) != SS$_NORMAL)
 931       error ("Can't assign terminal, %d", status);
 932   status = sys$qiow (0, chan, IO$_WRITEVBLK+IO$M_BREAKTHRU, 0, 0, 0,
 933                      &buf, 4, 0, 0, 0, 0);
 934   if (status != SS$_NORMAL)
 935     error ("Can't shrink-to-icon, %d", status);
 936 }
 937
 938 #endif /* VMS4_4 */
 939 \f
 940 init_vmsfns ()
 941 {
 942   process_list = 0;
 943   input_mbx_chan = 0;
 944 }
 945
 946 syms_of_vmsfns ()
 947 {
 948   defsubr (&Sdefault_subproc_input_handler);
 949   defsubr (&Sspawn_subprocess);
 950   defsubr (&Ssend_command_to_subprocess);
 951   defsubr (&Sstop_subprocess);
 952   defsubr (&Ssetprv);
 953 #ifdef VMS4_4
 954   defsubr (&Svms_system_info);
 955   defsubr (&Sshrink_to_icon);
 956 #endif /* VMS4_4 */
 957   Qdefault_subproc_input_handler = intern ("default-subprocess-input-handler");
 958   staticpro (&Qdefault_subproc_input_handler);
 959 }
 960 #endif /* VMS */
 961