| 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 | |