src/vmsfns.c

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