![[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 [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / src|
Return to vmsfns.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / 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 distributed in the hope that it will be useful, ! 7: but WITHOUT ANY WARRANTY. No author or distributor ! 8: accepts responsibility to anyone for the consequences of using it ! 9: or for whether it serves any particular purpose or works at all, ! 10: unless he says so in writing. Refer to the GNU Emacs General Public ! 11: License for full details. ! 12: ! 13: Everyone is granted permission to copy, modify and redistribute ! 14: GNU Emacs, but only under the conditions described in the ! 15: GNU Emacs General Public License. A copy of this license is ! 16: supposed to have been given to you along with GNU Emacs so you ! 17: can know your rights and responsibilities. It should be in a ! 18: file named COPYING. Among other things, the copyright notice ! 19: and this notice must be preserved on all copies. */ ! 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 <stdio.h> ! 60: #include <ctype.h> ! 61: #undef NULL ! 62: ! 63: #include "config.h" ! 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: InsCstr (XSTRING (input)->data, XSTRING (input)->size); ! 279: InsCstr ("\n", 1); ! 280: } ! 281: ! 282: DEFUN ("spawn-subprocess", Fspawn_subprocess, Sspawn_subprocess, 1, 3, 0, ! 283: "Spawns 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; ! 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: for (p = process_list; p; p = p->next) ! 301: if (p->name == XFASTINT (name)) ! 302: { ! 303: ptr = p; ! 304: if (p->process_active) ! 305: return Qt; ! 306: else ! 307: sys$dassgn (p->mbx_chan); ! 308: break; ! 309: } ! 310: if (! ptr) ! 311: ptr = xmalloc (sizeof (struct process_list)); ! 312: if (! create_mbx (&output_mbx_dsc, output_mbx_name, &ptr->mbx_chan, 2)) ! 313: { ! 314: free (ptr); ! 315: return Qnil; ! 316: } ! 317: if (NULL (input_handler)) ! 318: input_handler = Qdefault_subproc_input_handler; ! 319: ptr->input_handler = input_handler; ! 320: ptr->exit_handler = exit_handler; ! 321: message ("Creating subprocess..."); ! 322: status = lib$spawn (0, &output_mbx_dsc, &input_mbx_dsc, &CLI$M_NOWAIT, 0, ! 323: &ptr->process_id, 0, 0, exit_ast, &ptr->process_active); ! 324: if (! (status & 1)) ! 325: { ! 326: sys$dassgn (ptr->mbx_chan); ! 327: free (ptr); ! 328: error ("Unable to spawn subprocess"); ! 329: return Qnil; ! 330: } ! 331: ptr->name = XFASTINT (name); ! 332: ptr->next = process_list; ! 333: ptr->process_active = 1; ! 334: process_list = ptr; ! 335: message ("Creating subprocess...done"); ! 336: return Qt; ! 337: } ! 338: ! 339: static void ! 340: mbx_msg (ptr, msg) ! 341: struct process_list *ptr; ! 342: char *msg; ! 343: { ! 344: write_to_mbx (ptr, msg, strlen (msg)); ! 345: } ! 346: ! 347: DEFUN ("send-command-to-subprocess", ! 348: Fsend_command_to_subprocess, Ssend_command_to_subprocess, 2, 2, ! 349: "sSend command to subprocess: \nsSend subprocess %s command: ", ! 350: "Send to VMS subprocess named NAME the string COMMAND.") ! 351: (name, command) ! 352: Lisp_Object name, command; ! 353: { ! 354: struct process_list * ptr; ! 355: ! 356: CHECK_NUMBER (name, 0); ! 357: CHECK_STRING (command, 1); ! 358: for (ptr = process_list; ptr; ptr = ptr->next) ! 359: if (XFASTINT (name) == ptr->name) ! 360: { ! 361: write_to_mbx (ptr, XSTRING (command)->data, ! 362: XSTRING (command)->size); ! 363: return Qt; ! 364: } ! 365: return Qnil; ! 366: } ! 367: ! 368: DEFUN ("stop-subprocess", Fstop_subprocess, Sstop_subprocess, 1, 1, ! 369: "sStop subprocess: ", "Stop VMS subprocess named NAME.") ! 370: (name) ! 371: Lisp_Object name; ! 372: { ! 373: struct process_list * ptr; ! 374: ! 375: CHECK_NUMBER (name, 0); ! 376: for (ptr = process_list; ptr; ptr = ptr->next) ! 377: if (XFASTINT (name) == ptr->name) ! 378: { ! 379: ptr->exit_handler = Qnil; ! 380: if (sys$delprc (&ptr->process_id, 0) & 1) ! 381: ptr->process_active = 0; ! 382: return Qt; ! 383: } ! 384: return Qnil; ! 385: } ! 386: ! 387: static int ! 388: exit_ast (active) ! 389: int * active; ! 390: { ! 391: process_exited = 1; ! 392: *active = 0; ! 393: sys$setef (process_ef); ! 394: } ! 395: ! 396: /* Process to handle input on the input mailbox. ! 397: * Searches through the list of processes until the matching PID is found, ! 398: * then calls its input handler. ! 399: */ ! 400: ! 401: process_command_input () ! 402: { ! 403: struct process_list * ptr; ! 404: char * msg; ! 405: int msglen; ! 406: Lisp_Object expr; ! 407: ! 408: msg = mbx_buffer; ! 409: msglen = input_iosb.size; ! 410: /* Hack around VMS oddity of sending extraneous CR/LF characters for ! 411: * some of the commands (but not most). ! 412: */ ! 413: if (msglen > 0 && *msg == '\r') ! 414: { ! 415: msg++; ! 416: msglen--; ! 417: } ! 418: if (msglen > 0 && msg[msglen - 1] == '\n') ! 419: msglen--; ! 420: if (msglen > 0 && msg[msglen - 1] == '\r') ! 421: msglen--; ! 422: /* Search for the subprocess in the linked list. ! 423: */ ! 424: expr = Qnil; ! 425: for (ptr = process_list; ptr; ptr = ptr->next) ! 426: if (ptr->process_id == input_iosb.pid) ! 427: { ! 428: expr = Fcons (ptr->input_handler, ! 429: Fcons (make_number (ptr->name), ! 430: Fcons (make_string (msg, msglen), ! 431: Qnil))); ! 432: break; ! 433: } ! 434: have_process_input = 0; ! 435: start_mbx_input (); ! 436: if (! NULL (expr)) ! 437: Feval (expr); ! 438: } ! 439: ! 440: /* Searches process list for any processes which have exited. Calls their ! 441: * exit handlers and removes them from the process list. ! 442: */ ! 443: ! 444: process_exit () ! 445: { ! 446: struct process_list * ptr, * prev, * next; ! 447: ! 448: process_exited = 0; ! 449: prev = 0; ! 450: ptr = process_list; ! 451: while (ptr) ! 452: { ! 453: if (! ptr->process_active) ! 454: { ! 455: next = ptr->next; ! 456: if (prev) ! 457: prev->next = next; ! 458: else ! 459: process_list = next; ! 460: if (! NULL (ptr->exit_handler)) ! 461: Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name), ! 462: Qnil))); ! 463: sys$dassgn (ptr->mbx_chan); ! 464: free (ptr); ! 465: } ! 466: prev = ptr; ! 467: ptr = next; ! 468: } ! 469: } ! 470: ! 471: /* Called at emacs exit. ! 472: */ ! 473: ! 474: kill_vms_processes () ! 475: { ! 476: struct process_list * ptr; ! 477: ! 478: for (ptr = process_list; ptr; ptr = ptr->next) ! 479: if (ptr->process_active) ! 480: { ! 481: sys$dassgn (ptr->mbx_chan); ! 482: sys$delprc (&ptr->process_id, 0); ! 483: } ! 484: sys$dassgn (input_mbx_chan); ! 485: process_list = 0; ! 486: input_mbx_chan = 0; ! 487: } ! 488: ! 489: /* Creates a temporary mailbox and retrieves its device name in 'buf'. ! 490: * Makes the descriptor pointed to by 'dsc' refer to this device. ! 491: * 'buffer_factor' is used to allow sending messages asynchronously ! 492: * till some point. ! 493: */ ! 494: ! 495: static int ! 496: create_mbx (dsc, buf, chan, buffer_factor) ! 497: struct dsc$descriptor_s *dsc; ! 498: char *buf; ! 499: int *chan; ! 500: int buffer_factor; ! 501: { ! 502: int strval[2]; ! 503: int status; ! 504: ! 505: status = sys$crembx (0, chan, MSGSIZE, MSGSIZE * buffer_factor, 0, 0, 0); ! 506: if (! (status & 1)) ! 507: { ! 508: message ("Unable to create mailbox. Need TMPMBX privilege."); ! 509: return 0; ! 510: } ! 511: strval[0] = 16; ! 512: strval[1] = buf; ! 513: status = lib$getdvi (&DVI$_DEVNAM, chan, 0, 0, strval, ! 514: &dsc->dsc$w_length); ! 515: if (! (status & 1)) ! 516: return 0; ! 517: dsc->dsc$b_dtype = DSC$K_DTYPE_T; ! 518: dsc->dsc$b_class = DSC$K_CLASS_S; ! 519: dsc->dsc$a_pointer = buf; ! 520: return 1; ! 521: } /* create_mbx */ ! 522: ! 523: /* AST routine to be called upon receiving mailbox input. ! 524: * Sets flag telling keyboard routines that input is available. ! 525: */ ! 526: ! 527: static int ! 528: mbx_input_ast () ! 529: { ! 530: have_process_input = 1; ! 531: } ! 532: ! 533: /* Issue a QIO request on the input mailbox. ! 534: */ ! 535: static void ! 536: start_mbx_input () ! 537: { ! 538: sys$qio (process_ef, input_mbx_chan, IO$_READVBLK, &input_iosb, ! 539: mbx_input_ast, 0, mbx_buffer, sizeof (mbx_buffer), ! 540: 0, 0, 0, 0); ! 541: } ! 542: ! 543: /* Send a message to the subprocess input mailbox, without blocking if ! 544: * possible. ! 545: */ ! 546: static void ! 547: write_to_mbx (ptr, buf, len) ! 548: struct process_list *ptr; ! 549: char *buf; ! 550: int len; ! 551: { ! 552: sys$qiow (0, ptr->mbx_chan, IO$_WRITEVBLK | IO$M_NOW, &ptr->iosb, ! 553: 0, 0, buf, len, 0, 0, 0, 0); ! 554: } ! 555: ! 556: DEFUN ("setprv", Fsetprv, Ssetprv, 1, 3, 0, ! 557: "Set or reset a VMS privilege. First arg is privilege name.\n\ ! 558: Second arg is t or nil, indicating whether the privilege is to be\n\ ! 559: set or reset. Default is nil. Returns t if success, nil if not.\n\ ! 560: If third arg is non-nil, does not change privilege, but returns t\n\ ! 561: or nil depending upon whether the privilege is already enabled.") ! 562: (priv, value, getprv) ! 563: Lisp_Object priv, value, getprv; ! 564: { ! 565: int prvmask[2], prvlen, newmask[2]; ! 566: char * prvname; ! 567: int found, i; ! 568: struct privilege_list * ptr; ! 569: ! 570: CHECK_STRING (priv, 0); ! 571: priv = Fupcase (priv); ! 572: prvname = XSTRING (priv)->data; ! 573: prvlen = XSTRING (priv)->size; ! 574: found = 0; ! 575: prvmask[0] = 0; ! 576: prvmask[1] = 0; ! 577: for (i = 0; i < sizeof (priv_list) / sizeof (priv_list[0]); i++) ! 578: { ! 579: ptr = &priv_list[i]; ! 580: if (prvlen == strlen (ptr->name) && ! 581: bcmp (prvname, ptr->name, prvlen) == 0) ! 582: { ! 583: if (ptr->mask >= 32) ! 584: prvmask[1] = 1 << (ptr->mask % 32); ! 585: else ! 586: prvmask[0] = 1 << ptr->mask; ! 587: found = 1; ! 588: break; ! 589: } ! 590: } ! 591: if (! found) ! 592: error ("Unknown privilege name %s", XSTRING (priv)->data); ! 593: if (NULL (getprv)) ! 594: { ! 595: if (sys$setprv (NULL (value) ? 0 : 1, prvmask, 0, 0) == SS$_NORMAL) ! 596: return Qt; ! 597: return Qnil; ! 598: } ! 599: /* Get old priv value */ ! 600: if (sys$setprv (0, 0, 0, newmask) != SS$_NORMAL) ! 601: return Qnil; ! 602: if ((newmask[0] & prvmask[0]) ! 603: || (newmask[1] & prvmask[1])) ! 604: return Qt; ! 605: return Qnil; ! 606: } ! 607: ! 608: /* Retrieves VMS system information. */ ! 609: ! 610: #ifdef VMS4_4 /* I don't know whether these functions work in old versions */ ! 611: ! 612: DEFUN ("vms-system-info", Fvms_system_info, Svms_system_info, 1, 3, 0, ! 613: "Retrieve VMS process and system information.\n\ ! 614: The first argument (a string) specifies the type of information desired.\n\ ! 615: The other arguments depend on the type you select.\n\ ! 616: For information about a process, the second argument is a process ID\n\ ! 617: or a process name, with the current process as a default.\n\ ! 618: These are the possibilities for the first arg (upper or lower case ok):\n\ ! 619: account Returns account name\n\ ! 620: cliname Returns CLI name\n\ ! 621: owner Returns owner process's PID\n\ ! 622: grp Returns group number\n\ ! 623: parent Returns parent process's PID\n\ ! 624: pid Returns process's PID\n\ ! 625: prcnam Returns process's name\n\ ! 626: terminal Returns terminal name\n\ ! 627: uic Returns UIC number\n\ ! 628: uicgrp Returns formatted [UIC,GRP]\n\ ! 629: username Returns username\n\ ! 630: version Returns VMS version\n\ ! 631: logical Translates VMS logical name (second argument)\n\ ! 632: dcl-symbol Translates DCL symbol (second argument)\n\ ! 633: proclist Returns list of all PIDs on system (needs WORLD privilege)." ) ! 634: (type, arg1, arg2) ! 635: Lisp_Object type, arg1, arg2; ! 636: { ! 637: int i, typelen; ! 638: char * typename; ! 639: struct vms_objlist * ptr; ! 640: ! 641: CHECK_STRING (type, 0); ! 642: type = Fupcase (type); ! 643: typename = XSTRING (type)->data; ! 644: typelen = XSTRING (type)->size; ! 645: for (i = 0; i < sizeof (vms_object) / sizeof (vms_object[0]); i++) ! 646: { ! 647: ptr = &vms_object[i]; ! 648: if (typelen == strlen (ptr->name) ! 649: && bcmp (typename, ptr->name, typelen) == 0) ! 650: return (* ptr->objfn)(arg1, arg2); ! 651: } ! 652: error ("Unknown object type %s", typename); ! 653: } ! 654: ! 655: /* Given a reference to a VMS process, returns its process id. */ ! 656: ! 657: static int ! 658: translate_id (pid, owner) ! 659: Lisp_Object pid; ! 660: int owner; /* if pid is null/0, return owner. If this ! 661: * flag is 0, return self. */ ! 662: { ! 663: int status, code, id, i, numeric, size; ! 664: char * p; ! 665: int prcnam[2]; ! 666: ! 667: if (NULL (pid) ! 668: || XTYPE (pid) == Lisp_String && XSTRING (pid)->size == 0 ! 669: || XTYPE (pid) == Lisp_Int && XFASTINT (pid) == 0) ! 670: { ! 671: code = owner ? JPI$_OWNER : JPI$_PID; ! 672: status = lib$getjpi (&code, 0, 0, &id); ! 673: if (! (status & 1)) ! 674: error ("Cannot find %s: %s", ! 675: owner ? "owner process" : "process id", ! 676: vmserrstr (status)); ! 677: return (id); ! 678: } ! 679: if (XTYPE (pid) == Lisp_Int) ! 680: return (XFASTINT (pid)); ! 681: CHECK_STRING (pid, 0); ! 682: pid = Fupcase (pid); ! 683: size = XSTRING (pid)->size; ! 684: p = XSTRING (pid)->data; ! 685: numeric = 1; ! 686: id = 0; ! 687: for (i = 0; i < size; i++, p++) ! 688: if (isxdigit (*p)) ! 689: { ! 690: id *= 16; ! 691: if (*p >= '0' && *p <= '9') ! 692: id += *p - '0'; ! 693: else ! 694: id += *p - 'A' + 10; ! 695: } ! 696: else ! 697: { ! 698: numeric = 0; ! 699: break; ! 700: } ! 701: if (numeric) ! 702: return (id); ! 703: prcnam[0] = XSTRING (pid)->size; ! 704: prcnam[1] = XSTRING (pid)->data; ! 705: status = lib$getjpi (&JPI$_PID, 0, prcnam, &id); ! 706: if (! (status & 1)) ! 707: error ("Cannot find process id: %s", ! 708: vmserrstr (status)); ! 709: return (id); ! 710: } /* translate_id */ ! 711: ! 712: /* VMS object retrieval functions. */ ! 713: ! 714: static Lisp_Object ! 715: getjpi (jpicode, arg, numeric) ! 716: int jpicode; /* Type of GETJPI information */ ! 717: Lisp_Object arg; ! 718: int numeric; /* 1 if numeric value expected */ ! 719: { ! 720: int id, status, numval; ! 721: char str[128]; ! 722: int strdsc[2] = { sizeof (str), str }; ! 723: short strlen; ! 724: ! 725: id = translate_id (arg, 0); ! 726: status = lib$getjpi (&jpicode, &id, 0, &numval, strdsc, &strlen); ! 727: if (! (status & 1)) ! 728: error ("Unable to retrieve information: %s", ! 729: vmserrstr (status)); ! 730: if (numeric) ! 731: return (make_number (numval)); ! 732: return (make_string (str, strlen)); ! 733: } ! 734: ! 735: static Lisp_Object ! 736: vms_account (arg1, arg2) ! 737: Lisp_Object arg1, arg2; ! 738: { ! 739: return getjpi (JPI$_ACCOUNT, arg1, 0); ! 740: } ! 741: ! 742: static Lisp_Object ! 743: vms_cliname (arg1, arg2) ! 744: Lisp_Object arg1, arg2; ! 745: { ! 746: return getjpi (JPI$_CLINAME, arg1, 0); ! 747: } ! 748: ! 749: static Lisp_Object ! 750: vms_grp (arg1, arg2) ! 751: Lisp_Object arg1, arg2; ! 752: { ! 753: return getjpi (JPI$_GRP, arg1, 1); ! 754: } ! 755: ! 756: static Lisp_Object ! 757: vms_image (arg1, arg2) ! 758: Lisp_Object arg1, arg2; ! 759: { ! 760: return getjpi (JPI$_IMAGNAME, arg1, 0); ! 761: } ! 762: ! 763: static Lisp_Object ! 764: vms_owner (arg1, arg2) ! 765: Lisp_Object arg1, arg2; ! 766: { ! 767: return getjpi (JPI$_OWNER, arg1, 1); ! 768: } ! 769: ! 770: static Lisp_Object ! 771: vms_parent (arg1, arg2) ! 772: Lisp_Object arg1, arg2; ! 773: { ! 774: return getjpi (JPI$_MASTER_PID, arg1, 1); ! 775: } ! 776: ! 777: static Lisp_Object ! 778: vms_pid (arg1, arg2) ! 779: Lisp_Object arg1, arg2; ! 780: { ! 781: return getjpi (JPI$_PID, arg1, 1); ! 782: } ! 783: ! 784: static Lisp_Object ! 785: vms_prcnam (arg1, arg2) ! 786: Lisp_Object arg1, arg2; ! 787: { ! 788: return getjpi (JPI$_PRCNAM, arg1, 0); ! 789: } ! 790: ! 791: static Lisp_Object ! 792: vms_terminal (arg1, arg2) ! 793: Lisp_Object arg1, arg2; ! 794: { ! 795: return getjpi (JPI$_TERMINAL, arg1, 0); ! 796: } ! 797: ! 798: static Lisp_Object ! 799: vms_uic_int (arg1, arg2) ! 800: Lisp_Object arg1, arg2; ! 801: { ! 802: return getjpi (JPI$_UIC, arg1, 1); ! 803: } ! 804: ! 805: static Lisp_Object ! 806: vms_uic_str (arg1, arg2) ! 807: Lisp_Object arg1, arg2; ! 808: { ! 809: return getjpi (JPI$_UIC, arg1, 0); ! 810: } ! 811: ! 812: static Lisp_Object ! 813: vms_username (arg1, arg2) ! 814: Lisp_Object arg1, arg2; ! 815: { ! 816: return getjpi (JPI$_USERNAME, arg1, 0); ! 817: } ! 818: ! 819: static Lisp_Object ! 820: vms_version_fn (arg1, arg2) ! 821: Lisp_Object arg1, arg2; ! 822: { ! 823: char str[40]; ! 824: int status; ! 825: int strdsc[2] = { sizeof (str), str }; ! 826: short strlen; ! 827: ! 828: status = lib$getsyi (&SYI$_VERSION, 0, strdsc, &strlen, 0, 0); ! 829: if (! (status & 1)) ! 830: error ("Unable to obtain version: %s", vmserrstr (status)); ! 831: return (make_string (str, strlen)); ! 832: } ! 833: ! 834: static Lisp_Object ! 835: vms_trnlog (arg1, arg2) ! 836: Lisp_Object arg1, arg2; ! 837: { ! 838: char str[100]; ! 839: int status, symdsc[2]; ! 840: int strdsc[2] = { sizeof (str), str }; ! 841: short length, level; ! 842: ! 843: CHECK_STRING (arg1, 0); ! 844: symdsc[0] = XSTRING (arg1)->size; ! 845: symdsc[1] = XSTRING (arg1)->data; ! 846: status = lib$sys_trnlog (symdsc, &length, strdsc); ! 847: if (! (status & 1)) ! 848: error ("Unable to translate logical name: %s", vmserrstr (status)); ! 849: if (status == SS$_NOTRAN) ! 850: return (Qnil); ! 851: return (make_string (str, length)); ! 852: } ! 853: ! 854: static Lisp_Object ! 855: vms_symbol (arg1, arg2) ! 856: Lisp_Object arg1, arg2; ! 857: { ! 858: char str[100]; ! 859: int status, symdsc[2]; ! 860: int strdsc[2] = { sizeof (str), str }; ! 861: short length, level; ! 862: ! 863: CHECK_STRING (arg1, 0); ! 864: symdsc[0] = XSTRING (arg1)->size; ! 865: symdsc[1] = XSTRING (arg1)->data; ! 866: status = lib$get_symbol (symdsc, strdsc, &length, &level); ! 867: if (! (status & 1)) { ! 868: if (status == LIB$_NOSUCHSYM) ! 869: return (Qnil); ! 870: else ! 871: error ("Unable to translate symbol: %s", vmserrstr (status)); ! 872: } ! 873: return (make_string (str, length)); ! 874: } ! 875: ! 876: static Lisp_Object ! 877: vms_proclist (arg1, arg2) ! 878: Lisp_Object arg1, arg2; ! 879: { ! 880: Lisp_Object retval; ! 881: int id, status, pid; ! 882: ! 883: retval = Qnil; ! 884: pid = -1; ! 885: for (;;) ! 886: { ! 887: status = lib$getjpi (&JPI$_PID, &pid, 0, &id); ! 888: if (status == SS$_NOMOREPROC) ! 889: break; ! 890: if (! (status & 1)) ! 891: error ("Unable to get process ID: %s", vmserrstr (status)); ! 892: retval = Fcons (make_number (id), retval); ! 893: } ! 894: return (Fsort (retval, intern ("<"))); ! 895: } ! 896: ! 897: DEFUN ("shrink-to-icon", Fshrink_to_icon, Sshrink_to_icon, 0, 0, 0, ! 898: "If emacs is running in a workstation window, shrink to an icon.") ! 899: () ! 900: { ! 901: static char result[128]; ! 902: static $DESCRIPTOR (result_descriptor, result); ! 903: static $DESCRIPTOR (tt_name, "TT:"); ! 904: static int chan = 0; ! 905: static int buf = 0x9d + ('2'<<8) + ('2'<<16) + (0x9c<<24); ! 906: int status; ! 907: static int temp = JPI$_TERMINAL; ! 908: ! 909: status = lib$getjpi (&temp, 0, 0, 0, &result_descriptor, 0); ! 910: if (status != SS$_NORMAL) ! 911: error ("Unable to determine terminal type."); ! 912: if (result[0] != 'W' || result[1] != 'T') /* see if workstation */ ! 913: error ("Can't shrink-to-icon on a non workstation terminal"); ! 914: if (!chan) /* assign channel if not assigned */ ! 915: if ((status = sys$assign (&tt_name, &chan, 0, 0)) != SS$_NORMAL) ! 916: error ("Can't assign terminal, %d", status); ! 917: status = sys$qiow (0, chan, IO$_WRITEVBLK+IO$M_BREAKTHRU, 0, 0, 0, ! 918: &buf, 4, 0, 0, 0, 0); ! 919: if (status != SS$_NORMAL) ! 920: error ("Can't shrink-to-icon, %d", status); ! 921: } ! 922: ! 923: #endif /* VMS4_4 */ ! 924: ! 925: init_vmsfns () ! 926: { ! 927: process_list = 0; ! 928: input_mbx_chan = 0; ! 929: } ! 930: ! 931: syms_of_vmsfns () ! 932: { ! 933: defsubr (&Sdefault_subproc_input_handler); ! 934: defsubr (&Sspawn_subprocess); ! 935: defsubr (&Ssend_command_to_subprocess); ! 936: defsubr (&Sstop_subprocess); ! 937: defsubr (&Ssetprv); ! 938: #ifdef VMS4_4 ! 939: defsubr (&Svms_system_info); ! 940: defsubr (&Sshrink_to_icon); ! 941: #endif /* VMS4_4 */ ! 942: Qdefault_subproc_input_handler = intern ("default-subprocess-input-handler"); ! 943: staticpro (&Qdefault_subproc_input_handler); ! 944: } ! 945: #endif /* VMS */ ! 946:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.