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