mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-17 10:27:41 +00:00
Initial revision
This commit is contained in:
Richard M. Stallman
parent
0f91ee7e01
commit
7942b8aeb7
2 changed files with 1501 additions and 0 deletions
540
src/abbrev.c
Normal file
540
src/abbrev.c
Normal file
|
|
@ -0,0 +1,540 @@
|
|||
/* Primitives for word-abbrev mode.
|
||||
Copyright (C) 1985, 1986 Free Software Foundation, Inc.
|
||||
|
||||
This file is part of GNU Emacs.
|
||||
|
||||
GNU Emacs is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 1, or (at your option)
|
||||
any later version.
|
||||
|
||||
GNU Emacs is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with GNU Emacs; see the file COPYING. If not, write to
|
||||
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
|
||||
|
||||
|
||||
#include "config.h"
|
||||
#include <stdio.h>
|
||||
#undef NULL
|
||||
#include "lisp.h"
|
||||
#include "commands.h"
|
||||
#include "buffer.h"
|
||||
#include "window.h"
|
||||
|
||||
/* An abbrev table is an obarray.
|
||||
Each defined abbrev is represented by a symbol in that obarray
|
||||
whose print name is the abbreviation.
|
||||
The symbol's value is a string which is the expansion.
|
||||
If its function definition is non-nil, it is called
|
||||
after the expansion is done.
|
||||
The plist slot of the abbrev symbol is its usage count. */
|
||||
|
||||
/* List of all abbrev-table name symbols:
|
||||
symbols whose values are abbrev tables. */
|
||||
|
||||
Lisp_Object Vabbrev_table_name_list;
|
||||
|
||||
/* The table of global abbrevs. These are in effect
|
||||
in any buffer in which abbrev mode is turned on. */
|
||||
|
||||
Lisp_Object Vglobal_abbrev_table;
|
||||
|
||||
/* The local abbrev table used by default (in Fundamental Mode buffers) */
|
||||
|
||||
Lisp_Object Vfundamental_mode_abbrev_table;
|
||||
|
||||
/* Set nonzero when an abbrev definition is changed */
|
||||
|
||||
int abbrevs_changed;
|
||||
|
||||
int abbrev_all_caps;
|
||||
|
||||
/* Non-nil => use this location as the start of abbrev to expand
|
||||
(rather than taking the word before point as the abbrev) */
|
||||
|
||||
Lisp_Object Vabbrev_start_location;
|
||||
|
||||
/* Buffer that Vabbrev_start_location applies to */
|
||||
Lisp_Object Vabbrev_start_location_buffer;
|
||||
|
||||
/* The symbol representing the abbrev most recently expanded */
|
||||
|
||||
Lisp_Object Vlast_abbrev;
|
||||
|
||||
/* A string for the actual text of the abbrev most recently expanded.
|
||||
This has more info than Vlast_abbrev since case is significant. */
|
||||
|
||||
Lisp_Object Vlast_abbrev_text;
|
||||
|
||||
/* Character address of start of last abbrev expanded */
|
||||
|
||||
int last_abbrev_point;
|
||||
|
||||
|
||||
DEFUN ("make-abbrev-table", Fmake_abbrev_table, Smake_abbrev_table, 0, 0, 0,
|
||||
"Create a new, empty abbrev table object.")
|
||||
()
|
||||
{
|
||||
return Fmake_vector (make_number (59), make_number (0));
|
||||
}
|
||||
|
||||
DEFUN ("clear-abbrev-table", Fclear_abbrev_table, Sclear_abbrev_table, 1, 1, 0,
|
||||
"Undefine all abbrevs in abbrev table TABLE, leaving it empty.")
|
||||
(table)
|
||||
Lisp_Object table;
|
||||
{
|
||||
int i, size;
|
||||
|
||||
CHECK_VECTOR (table, 0);
|
||||
size = XVECTOR (table)->size;
|
||||
abbrevs_changed = 1;
|
||||
for (i = 0; i < size; i++)
|
||||
XVECTOR (table)->contents[i] = make_number (0);
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
DEFUN ("define-abbrev", Fdefine_abbrev, Sdefine_abbrev, 3, 5, 0,
|
||||
"Define an abbrev in TABLE named NAME, to expand to EXPANSION and call HOOK.\n\
|
||||
NAME and EXPANSION are strings.\n\
|
||||
To undefine an abbrev, define it with EXPANSION = nil.\n\
|
||||
If HOOK is non-nil, it should be a function of no arguments;\n\
|
||||
it is called after EXPANSION is inserted.")
|
||||
(table, name, expansion, hook, count)
|
||||
Lisp_Object table, name, expansion, hook, count;
|
||||
{
|
||||
Lisp_Object sym, oexp, ohook, tem;
|
||||
CHECK_VECTOR (table, 0);
|
||||
CHECK_STRING (name, 1);
|
||||
if (!NULL (expansion))
|
||||
CHECK_STRING (expansion, 2);
|
||||
if (NULL (count))
|
||||
count = make_number (0);
|
||||
else
|
||||
CHECK_NUMBER (count, 0);
|
||||
|
||||
sym = Fintern (name, table);
|
||||
|
||||
oexp = XSYMBOL (sym)->value;
|
||||
ohook = XSYMBOL (sym)->function;
|
||||
if (!((EQ (oexp, expansion)
|
||||
|| (XTYPE (oexp) == Lisp_String && XTYPE (expansion) == Lisp_String
|
||||
&& (tem = Fstring_equal (oexp, expansion), !NULL (tem))))
|
||||
&&
|
||||
(EQ (ohook, hook)
|
||||
|| (tem = Fequal (ohook, hook), !NULL (tem)))))
|
||||
abbrevs_changed = 1;
|
||||
|
||||
Fset (sym, expansion);
|
||||
Ffset (sym, hook);
|
||||
Fsetplist (sym, count);
|
||||
|
||||
return name;
|
||||
}
|
||||
|
||||
DEFUN ("define-global-abbrev", Fdefine_global_abbrev, Sdefine_global_abbrev, 2, 2,
|
||||
"sDefine global abbrev: \nsExpansion for %s: ",
|
||||
"Define ABBREV as a global abbreviation for EXPANSION.")
|
||||
(name, expansion)
|
||||
Lisp_Object name, expansion;
|
||||
{
|
||||
Fdefine_abbrev (Vglobal_abbrev_table, Fdowncase (name),
|
||||
expansion, Qnil, make_number (0));
|
||||
return name;
|
||||
}
|
||||
|
||||
DEFUN ("define-mode-abbrev", Fdefine_mode_abbrev, Sdefine_mode_abbrev, 2, 2,
|
||||
"sDefine mode abbrev: \nsExpansion for %s: ",
|
||||
"Define ABBREV as a mode-specific abbreviation for EXPANSION.")
|
||||
(name, expansion)
|
||||
Lisp_Object name, expansion;
|
||||
{
|
||||
if (NULL (current_buffer->abbrev_table))
|
||||
error ("Major mode has no abbrev table");
|
||||
|
||||
Fdefine_abbrev (current_buffer->abbrev_table, Fdowncase (name),
|
||||
expansion, Qnil, make_number (0));
|
||||
return name;
|
||||
}
|
||||
|
||||
DEFUN ("abbrev-symbol", Fabbrev_symbol, Sabbrev_symbol, 1, 2, 0,
|
||||
"Return the symbol representing abbrev named ABBREV.\n\
|
||||
This symbol's name is ABBREV, but it is not the canonical symbol of that name;\n\
|
||||
it is interned in an abbrev-table rather than the normal obarray.\n\
|
||||
The value is nil if that abbrev is not defined.\n\
|
||||
Optional second arg TABLE is abbrev table to look it up in.\n\
|
||||
The default is to try buffer's mode-specific abbrev table, then global table.")
|
||||
(abbrev, table)
|
||||
Lisp_Object abbrev, table;
|
||||
{
|
||||
Lisp_Object sym;
|
||||
CHECK_STRING (abbrev, 0);
|
||||
if (!NULL (table))
|
||||
sym = Fintern_soft (abbrev, table);
|
||||
else
|
||||
{
|
||||
sym = Qnil;
|
||||
if (!NULL (current_buffer->abbrev_table))
|
||||
sym = Fintern_soft (abbrev, current_buffer->abbrev_table);
|
||||
if (NULL (XSYMBOL (sym)->value))
|
||||
sym = Qnil;
|
||||
if (NULL (sym))
|
||||
sym = Fintern_soft (abbrev, Vglobal_abbrev_table);
|
||||
}
|
||||
if (NULL (XSYMBOL (sym)->value)) return Qnil;
|
||||
return sym;
|
||||
}
|
||||
|
||||
DEFUN ("abbrev-expansion", Fabbrev_expansion, Sabbrev_expansion, 1, 2, 0,
|
||||
"Return the string that ABBREV expands into in the current buffer.\n\
|
||||
Optionally specify an abbrev table as second arg;\n\
|
||||
then ABBREV is looked up in that table only.")
|
||||
(abbrev, table)
|
||||
Lisp_Object abbrev, table;
|
||||
{
|
||||
Lisp_Object sym;
|
||||
sym = Fabbrev_symbol (abbrev, table);
|
||||
if (NULL (sym)) return sym;
|
||||
return Fsymbol_value (sym);
|
||||
}
|
||||
|
||||
/* Expand the word before point, if it is an abbrev.
|
||||
Returns 1 if an expansion is done. */
|
||||
|
||||
DEFUN ("expand-abbrev", Fexpand_abbrev, Sexpand_abbrev, 0, 0, "",
|
||||
"Expand the abbrev before point, if there is an abbrev there.\n\
|
||||
Effective when explicitly called even when `abbrev-mode' is nil.\n\
|
||||
Returns t if expansion took place.")
|
||||
()
|
||||
{
|
||||
register char *buffer, *p;
|
||||
register int wordstart, wordend, idx;
|
||||
int whitecnt;
|
||||
int uccount = 0, lccount = 0;
|
||||
register Lisp_Object sym;
|
||||
Lisp_Object expansion, hook, tem;
|
||||
|
||||
if (XBUFFER (Vabbrev_start_location_buffer) != current_buffer)
|
||||
Vabbrev_start_location = Qnil;
|
||||
if (!NULL (Vabbrev_start_location))
|
||||
{
|
||||
tem = Vabbrev_start_location;
|
||||
CHECK_NUMBER_COERCE_MARKER (tem, 0);
|
||||
wordstart = XINT (tem);
|
||||
Vabbrev_start_location = Qnil;
|
||||
if (FETCH_CHAR (wordstart) == '-')
|
||||
del_range (wordstart, wordstart + 1);
|
||||
}
|
||||
else
|
||||
wordstart = scan_words (point, -1);
|
||||
|
||||
if (!wordstart)
|
||||
return Qnil;
|
||||
|
||||
wordend = scan_words (wordstart, 1);
|
||||
if (!wordend)
|
||||
return Qnil;
|
||||
|
||||
if (wordend > point)
|
||||
wordend = point;
|
||||
whitecnt = point - wordend;
|
||||
if (wordend <= wordstart)
|
||||
return Qnil;
|
||||
|
||||
p = buffer = (char *) alloca (wordend - wordstart);
|
||||
|
||||
for (idx = wordstart; idx < point; idx++)
|
||||
{
|
||||
register int c = FETCH_CHAR (idx);
|
||||
if (UPPERCASEP (c))
|
||||
c = DOWNCASE (c), uccount++;
|
||||
else if (! NOCASEP (c))
|
||||
lccount++;
|
||||
*p++ = c;
|
||||
}
|
||||
|
||||
if (XTYPE (current_buffer->abbrev_table) == Lisp_Vector)
|
||||
sym = oblookup (current_buffer->abbrev_table, buffer, p - buffer);
|
||||
else
|
||||
XFASTINT (sym) = 0;
|
||||
if (XTYPE (sym) == Lisp_Int || NULL (XSYMBOL (sym)->value))
|
||||
sym = oblookup (Vglobal_abbrev_table, buffer, p - buffer);
|
||||
if (XTYPE (sym) == Lisp_Int || NULL (XSYMBOL (sym)->value))
|
||||
return Qnil;
|
||||
|
||||
if (INTERACTIVE && !EQ (minibuf_window, selected_window))
|
||||
{
|
||||
SET_PT (wordend);
|
||||
Fundo_boundary ();
|
||||
}
|
||||
SET_PT (wordstart);
|
||||
Vlast_abbrev_text
|
||||
= Fbuffer_substring (make_number (wordstart), make_number (wordend));
|
||||
del_range (wordstart, wordend);
|
||||
|
||||
/* Now sym is the abbrev symbol. */
|
||||
Vlast_abbrev = sym;
|
||||
last_abbrev_point = wordstart;
|
||||
|
||||
if (XTYPE (XSYMBOL (sym)->plist) == Lisp_Int)
|
||||
XSETINT (XSYMBOL (sym)->plist,
|
||||
XINT (XSYMBOL (sym)->plist) + 1); /* Increment use count */
|
||||
|
||||
expansion = XSYMBOL (sym)->value;
|
||||
insert_from_string (expansion, 0, XSTRING (expansion)->size);
|
||||
SET_PT (point + whitecnt);
|
||||
|
||||
if (uccount && !lccount)
|
||||
{
|
||||
/* Abbrev was all caps */
|
||||
/* If expansion is multiple words, normally capitalize each word */
|
||||
/* This used to be if (!... && ... >= ...) Fcapitalize; else Fupcase
|
||||
but Megatest 68000 compiler can't handle that */
|
||||
if (!abbrev_all_caps)
|
||||
if (scan_words (point, -1) > scan_words (wordstart, 1))
|
||||
{
|
||||
upcase_initials_region (make_number (wordstart),
|
||||
make_number (point));
|
||||
goto caped;
|
||||
}
|
||||
/* If expansion is one word, or if user says so, upcase it all. */
|
||||
Fupcase_region (make_number (wordstart), make_number (point));
|
||||
caped: ;
|
||||
}
|
||||
else if (uccount)
|
||||
{
|
||||
/* Abbrev included some caps. Cap first initial of expansion */
|
||||
idx = point;
|
||||
SET_PT (wordstart);
|
||||
Fcapitalize_word (make_number (1));
|
||||
SET_PT (idx);
|
||||
}
|
||||
|
||||
hook = XSYMBOL (sym)->function;
|
||||
if (!NULL (hook))
|
||||
call0 (hook);
|
||||
|
||||
return Qt;
|
||||
}
|
||||
|
||||
DEFUN ("unexpand-abbrev", Funexpand_abbrev, Sunexpand_abbrev, 0, 0, "",
|
||||
"Undo the expansion of the last abbrev that expanded.\n\
|
||||
This differs from ordinary undo in that other editing done since then\n\
|
||||
is not undone.")
|
||||
()
|
||||
{
|
||||
int opoint = point;
|
||||
int adjust = 0;
|
||||
if (last_abbrev_point < BEGV
|
||||
|| last_abbrev_point > ZV)
|
||||
return Qnil;
|
||||
SET_PT (last_abbrev_point);
|
||||
if (XTYPE (Vlast_abbrev_text) == Lisp_String)
|
||||
{
|
||||
/* This isn't correct if Vlast_abbrev->function was used
|
||||
to do the expansion */
|
||||
Lisp_Object val;
|
||||
XSET (val, Lisp_String, XSYMBOL (Vlast_abbrev)->value);
|
||||
adjust = XSTRING (val)->size;
|
||||
del_range (point, point + adjust);
|
||||
insert_from_string (Vlast_abbrev_text, 0,
|
||||
XSTRING (Vlast_abbrev_text)->size);
|
||||
adjust -= XSTRING (Vlast_abbrev_text)->size;
|
||||
Vlast_abbrev_text = Qnil;
|
||||
}
|
||||
SET_PT (last_abbrev_point < opoint ? opoint - adjust : opoint);
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
static
|
||||
write_abbrev (sym, stream)
|
||||
Lisp_Object sym, stream;
|
||||
{
|
||||
Lisp_Object name;
|
||||
if (NULL (XSYMBOL (sym)->value))
|
||||
return;
|
||||
insert (" (", 5);
|
||||
XSET (name, Lisp_String, XSYMBOL (sym)->name);
|
||||
Fprin1 (name, stream);
|
||||
insert (" ", 1);
|
||||
Fprin1 (XSYMBOL (sym)->value, stream);
|
||||
insert (" ", 1);
|
||||
Fprin1 (XSYMBOL (sym)->function, stream);
|
||||
insert (" ", 1);
|
||||
Fprin1 (XSYMBOL (sym)->plist, stream);
|
||||
insert (")\n", 2);
|
||||
}
|
||||
|
||||
static
|
||||
describe_abbrev (sym, stream)
|
||||
Lisp_Object sym, stream;
|
||||
{
|
||||
Lisp_Object one;
|
||||
|
||||
if (NULL (XSYMBOL (sym)->value))
|
||||
return;
|
||||
one = make_number (1);
|
||||
Fprin1 (Fsymbol_name (sym), stream);
|
||||
Findent_to (make_number (15), one);
|
||||
Fprin1 (XSYMBOL (sym)->plist, stream);
|
||||
Findent_to (make_number (20), one);
|
||||
Fprin1 (XSYMBOL (sym)->value, stream);
|
||||
if (!NULL (XSYMBOL (sym)->function))
|
||||
{
|
||||
Findent_to (make_number (45), one);
|
||||
Fprin1 (XSYMBOL (sym)->function, stream);
|
||||
}
|
||||
Fterpri (stream);
|
||||
}
|
||||
|
||||
DEFUN ("insert-abbrev-table-description",
|
||||
Finsert_abbrev_table_description, Sinsert_abbrev_table_description,
|
||||
1, 2, 0,
|
||||
"Insert before point a full description of abbrev table named NAME.\n\
|
||||
NAME is a symbol whose value is an abbrev table.\n\
|
||||
If optional 2nd arg HUMAN is non-nil, a human-readable description is inserted.\n\
|
||||
Otherwise the description is an expression,\n\
|
||||
a call to `define-abbrev-table', which would\n\
|
||||
define the abbrev table NAME exactly as it is currently defined.")
|
||||
(name, readable)
|
||||
Lisp_Object name, readable;
|
||||
{
|
||||
Lisp_Object table;
|
||||
Lisp_Object stream;
|
||||
|
||||
CHECK_SYMBOL (name, 0);
|
||||
table = Fsymbol_value (name);
|
||||
CHECK_VECTOR (table, 0);
|
||||
|
||||
XSET (stream, Lisp_Buffer, current_buffer);
|
||||
|
||||
if (!NULL (readable))
|
||||
{
|
||||
insert_string ("(");
|
||||
Fprin1 (name, stream);
|
||||
insert_string (")\n\n");
|
||||
map_obarray (table, describe_abbrev, stream);
|
||||
insert_string ("\n\n");
|
||||
}
|
||||
else
|
||||
{
|
||||
insert_string ("(define-abbrev-table '");
|
||||
Fprin1 (name, stream);
|
||||
insert_string (" '(\n");
|
||||
map_obarray (table, write_abbrev, stream);
|
||||
insert_string (" ))\n\n");
|
||||
}
|
||||
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
DEFUN ("define-abbrev-table", Fdefine_abbrev_table, Sdefine_abbrev_table,
|
||||
2, 2, 0,
|
||||
"Define TABNAME (a symbol) as an abbrev table name.\n\
|
||||
Define abbrevs in it according to DEFINITIONS, which is a list of elements\n\
|
||||
of the form (ABBREVNAME EXPANSION HOOK USECOUNT).")
|
||||
(tabname, defns)
|
||||
Lisp_Object tabname, defns;
|
||||
{
|
||||
Lisp_Object name, exp, hook, count;
|
||||
Lisp_Object table, elt;
|
||||
|
||||
CHECK_SYMBOL (tabname, 0);
|
||||
table = Fboundp (tabname);
|
||||
if (NULL (table) || (table = Fsymbol_value (tabname), NULL (table)))
|
||||
{
|
||||
table = Fmake_abbrev_table ();
|
||||
Fset (tabname, table);
|
||||
Vabbrev_table_name_list =
|
||||
Fcons (tabname, Vabbrev_table_name_list);
|
||||
}
|
||||
CHECK_VECTOR (table, 0);
|
||||
|
||||
for (;!NULL (defns); defns = Fcdr (defns))
|
||||
{
|
||||
elt = Fcar (defns);
|
||||
name = Fcar (elt);
|
||||
elt = Fcdr (elt);
|
||||
exp = Fcar (elt);
|
||||
elt = Fcdr (elt);
|
||||
hook = Fcar (elt);
|
||||
elt = Fcdr (elt);
|
||||
count = Fcar (elt);
|
||||
Fdefine_abbrev (table, name, exp, hook, count);
|
||||
}
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
syms_of_abbrev ()
|
||||
{
|
||||
DEFVAR_LISP ("abbrev-table-name-list", &Vabbrev_table_name_list,
|
||||
"List of symbols whose values are abbrev tables.");
|
||||
Vabbrev_table_name_list = Fcons (intern ("fundamental-mode-abbrev-table"),
|
||||
Fcons (intern ("global-abbrev-table"),
|
||||
Qnil));
|
||||
|
||||
DEFVAR_LISP ("global-abbrev-table", &Vglobal_abbrev_table,
|
||||
"The abbrev table whose abbrevs affect all buffers.\n\
|
||||
Each buffer may also have a local abbrev table.\n\
|
||||
If it does, the local table overrides the global one\n\
|
||||
for any particular abbrev defined in both.");
|
||||
Vglobal_abbrev_table = Fmake_abbrev_table ();
|
||||
|
||||
DEFVAR_LISP ("fundamental-mode-abbrev-table", &Vfundamental_mode_abbrev_table,
|
||||
"The abbrev table of mode-specific abbrevs for Fundamental Mode.");
|
||||
Vfundamental_mode_abbrev_table = Fmake_abbrev_table ();
|
||||
current_buffer->abbrev_table = Vfundamental_mode_abbrev_table;
|
||||
|
||||
DEFVAR_LISP ("last-abbrev", &Vlast_abbrev,
|
||||
"The abbrev-symbol of the last abbrev expanded. See `abbrev-symbol'.");
|
||||
|
||||
DEFVAR_LISP ("last-abbrev-text", &Vlast_abbrev_text,
|
||||
"The exact text of the last abbrev expanded.\n\
|
||||
nil if the abbrev has already been unexpanded.");
|
||||
|
||||
DEFVAR_INT ("last-abbrev-location", &last_abbrev_point,
|
||||
"The location of the start of the last abbrev expanded.");
|
||||
|
||||
Vlast_abbrev = Qnil;
|
||||
Vlast_abbrev_text = Qnil;
|
||||
last_abbrev_point = 0;
|
||||
|
||||
DEFVAR_LISP ("abbrev-start-location", &Vabbrev_start_location,
|
||||
"Buffer position for `expand-abbrev' to use as the start of the abbrev.\n\
|
||||
nil means use the word before point as the abbrev.\n\
|
||||
Calling `expand-abbrev' sets this to nil.");
|
||||
Vabbrev_start_location = Qnil;
|
||||
|
||||
DEFVAR_LISP ("abbrev-start-location-buffer", &Vabbrev_start_location_buffer,
|
||||
"Buffer that `abbrev-start-location' has been set for.\n\
|
||||
Trying to expand an abbrev in any other buffer clears `abbrev-start-location'.");
|
||||
Vabbrev_start_location_buffer = Qnil;
|
||||
|
||||
DEFVAR_PER_BUFFER ("local-abbrev-table", ¤t_buffer->abbrev_table,
|
||||
"Local (mode-specific) abbrev table of current buffer.");
|
||||
|
||||
DEFVAR_BOOL ("abbrevs-changed", &abbrevs_changed,
|
||||
"Set non-nil by defining or altering any word abbrevs.\n\
|
||||
This causes `save-some-buffers' to offer to save the abbrevs.");
|
||||
abbrevs_changed = 0;
|
||||
|
||||
DEFVAR_BOOL ("abbrev-all-caps", &abbrev_all_caps,
|
||||
"*Set non-nil means expand multi-word abbrevs all caps if abbrev was so.");
|
||||
abbrev_all_caps = 0;
|
||||
|
||||
defsubr (&Smake_abbrev_table);
|
||||
defsubr (&Sclear_abbrev_table);
|
||||
defsubr (&Sdefine_abbrev);
|
||||
defsubr (&Sdefine_global_abbrev);
|
||||
defsubr (&Sdefine_mode_abbrev);
|
||||
defsubr (&Sabbrev_expansion);
|
||||
defsubr (&Sabbrev_symbol);
|
||||
defsubr (&Sexpand_abbrev);
|
||||
defsubr (&Sunexpand_abbrev);
|
||||
defsubr (&Sinsert_abbrev_table_description);
|
||||
defsubr (&Sdefine_abbrev_table);
|
||||
}
|
||||
961
src/vmsfns.c
Normal file
961
src/vmsfns.c
Normal file
|
|
@ -0,0 +1,961 @@
|
|||
/* VMS subprocess and command interface.
|
||||
Copyright (C) 1987, 1988 Free Software Foundation, Inc.
|
||||
|
||||
This file is part of GNU Emacs.
|
||||
|
||||
GNU Emacs is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 1, or (at your option)
|
||||
any later version.
|
||||
|
||||
GNU Emacs is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with GNU Emacs; see the file COPYING. If not, write to
|
||||
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
|
||||
|
||||
/* Written by Mukesh Prasad. */
|
||||
|
||||
/*
|
||||
* INTERFACE PROVIDED BY EMACS FOR VMS SUBPROCESSES:
|
||||
*
|
||||
* Emacs provides the following functions:
|
||||
*
|
||||
* "spawn-subprocess", which takes as arguments:
|
||||
*
|
||||
* (i) an integer to identify the spawned subprocess in future
|
||||
* operations,
|
||||
* (ii) A function to process input from the subprocess, and
|
||||
* (iii) A function to be called upon subprocess termination.
|
||||
*
|
||||
* First argument is required. If second argument is missing or nil,
|
||||
* the default action is to insert all received messages at the current
|
||||
* location in the current buffer. If third argument is missing or nil,
|
||||
* no action is taken upon subprocess termination.
|
||||
* The input-handler is called as
|
||||
* (input-handler num string)
|
||||
* where num is the identifying integer for the subprocess and string
|
||||
* is a string received from the subprocess. exit-handler is called
|
||||
* with the identifying integer as the argument.
|
||||
*
|
||||
* "send-command-to-subprocess" takes two arguments:
|
||||
*
|
||||
* (i) Subprocess identifying integer.
|
||||
* (ii) String to send as a message to the subprocess.
|
||||
*
|
||||
* "stop-subprocess" takes the subprocess identifying integer as
|
||||
* argument.
|
||||
*
|
||||
* Implementation is done by spawning an asynchronous subprocess, and
|
||||
* communicating to it via mailboxes.
|
||||
*/
|
||||
|
||||
#ifdef VMS
|
||||
|
||||
#include <stdio.h>
|
||||
#include <ctype.h>
|
||||
#undef NULL
|
||||
|
||||
#include "config.h"
|
||||
#include "lisp.h"
|
||||
#include <descrip.h>
|
||||
#include <dvidef.h>
|
||||
#include <prvdef.h>
|
||||
/* #include <clidef.h> */
|
||||
#include <iodef.h>
|
||||
#include <ssdef.h>
|
||||
#include <errno.h>
|
||||
|
||||
#ifdef VMS4_4 /* I am being cautious; perhaps this exists in older versions */
|
||||
#include <jpidef.h>
|
||||
#endif
|
||||
|
||||
/* #include <syidef.h> */
|
||||
|
||||
#define CLI$M_NOWAIT 1 /* clidef.h is missing from C library */
|
||||
#define SYI$_VERSION 4096 /* syidef.h is missing from C library */
|
||||
#define JPI$_CLINAME 522 /* JPI$_CLINAME is missing from jpidef.h */
|
||||
#define JPI$_MASTER_PID 805 /* JPI$_MASTER_PID missing from jpidef.h */
|
||||
#define LIB$_NOSUCHSYM 1409892 /* libclidef.h missing */
|
||||
|
||||
#define MSGSIZE 160 /* Maximum size for mailbox operations */
|
||||
|
||||
#ifndef PRV$V_ACNT
|
||||
|
||||
/* these defines added as hack for VMS 5.1-1. SJones, 8-17-89 */
|
||||
/* this is _really_ nasty and needs to be changed ASAP - should see about
|
||||
using the union defined in SYS$LIBRARY:PRVDEF.H under v5 */
|
||||
|
||||
#define PRV$V_ACNT 0x09
|
||||
#define PRV$V_ALLSPOOL 0x04
|
||||
#define PRV$V_ALTPRI 0x0D
|
||||
#define PRV$V_BUGCHK 0x17
|
||||
#define PRV$V_BYPASS 0x1D
|
||||
#define PRV$V_CMEXEC 0x01
|
||||
#define PRV$V_CMKRNL 0x00
|
||||
#define PRV$V_DETACH 0x05
|
||||
#define PRV$V_DIAGNOSE 0x06
|
||||
#define PRV$V_DOWNGRADE 0x21
|
||||
#define PRV$V_EXQUOTA 0x13
|
||||
#define PRV$V_GROUP 0x08
|
||||
#define PRV$V_GRPNAM 0x03
|
||||
#define PRV$V_GRPPRV 0x22
|
||||
#define PRV$V_LOG_IO 0x07
|
||||
#define PRV$V_MOUNT 0x11
|
||||
#define PRV$V_NETMBX 0x14
|
||||
#define PRV$V_NOACNT 0x09
|
||||
#define PRV$V_OPER 0x12
|
||||
#define PRV$V_PFNMAP 0x1A
|
||||
#define PRV$V_PHY_IO 0x16
|
||||
#define PRV$V_PRMCEB 0x0A
|
||||
#define PRV$V_PRMGBL 0x18
|
||||
#define PRV$V_PRMJNL 0x25
|
||||
#define PRV$V_PRMMBX 0x0B
|
||||
#define PRV$V_PSWAPM 0x0C
|
||||
#define PRV$V_READALL 0x23
|
||||
#define PRV$V_SECURITY 0x26
|
||||
#define PRV$V_SETPRI 0x0D
|
||||
#define PRV$V_SETPRV 0x0E
|
||||
#define PRV$V_SHARE 0x1F
|
||||
#define PRV$V_SHMEM 0x1B
|
||||
#define PRV$V_SYSGBL 0x19
|
||||
#define PRV$V_SYSLCK 0x1E
|
||||
#define PRV$V_SYSNAM 0x02
|
||||
#define PRV$V_SYSPRV 0x1C
|
||||
#define PRV$V_TMPJNL 0x24
|
||||
#define PRV$V_TMPMBX 0x0F
|
||||
#define PRV$V_UPGRADE 0x20
|
||||
#define PRV$V_VOLPRO 0x15
|
||||
#define PRV$V_WORLD 0x10
|
||||
#endif
|
||||
|
||||
/* IO status block for mailbox operations. */
|
||||
struct mbx_iosb
|
||||
{
|
||||
short status;
|
||||
short size;
|
||||
int pid;
|
||||
};
|
||||
|
||||
/* Structure for maintaining linked list of subprocesses. */
|
||||
struct process_list
|
||||
{
|
||||
int name; /* Numeric identifier for subprocess */
|
||||
int process_id; /* VMS process address */
|
||||
int process_active; /* 1 iff process has not exited yet */
|
||||
int mbx_chan; /* Mailbox channel to write to process */
|
||||
struct mbx_iosb iosb; /* IO status block for write operations */
|
||||
Lisp_Object input_handler; /* Input handler for subprocess */
|
||||
Lisp_Object exit_handler; /* Exit handler for subprocess */
|
||||
struct process_list * next; /* Linked list chain */
|
||||
};
|
||||
|
||||
/* Structure for privilege list. */
|
||||
struct privilege_list
|
||||
{
|
||||
char * name;
|
||||
int mask;
|
||||
};
|
||||
|
||||
/* Structure for finding VMS related information. */
|
||||
struct vms_objlist
|
||||
{
|
||||
char * name; /* Name of object */
|
||||
Lisp_Object (* objfn)(); /* Function to retrieve VMS object */
|
||||
};
|
||||
|
||||
static int exit_ast (); /* Called upon subprocess exit */
|
||||
static int create_mbx (); /* Creates mailbox */
|
||||
static void mbx_msg (); /* Writes null terminated string to mbx */
|
||||
static void write_to_mbx (); /* Writes message to string */
|
||||
static void start_mbx_input (); /* Queues I/O request to mailbox */
|
||||
|
||||
static int input_mbx_chan = 0; /* Channel to read subprocess input on */
|
||||
static char input_mbx_name[20];
|
||||
/* Storage for mailbox device name */
|
||||
static struct dsc$descriptor_s input_mbx_dsc;
|
||||
/* Descriptor for mailbox device name */
|
||||
static struct process_list * process_list = 0;
|
||||
/* Linked list of subprocesses */
|
||||
static char mbx_buffer[MSGSIZE];
|
||||
/* Buffer to read from subprocesses */
|
||||
static struct mbx_iosb input_iosb;
|
||||
/* IO status block for mailbox reads */
|
||||
|
||||
int have_process_input, /* Non-zero iff subprocess input pending */
|
||||
process_exited; /* Non-zero iff suprocess exit pending */
|
||||
|
||||
/* List of privilege names and mask offsets */
|
||||
static struct privilege_list priv_list[] = {
|
||||
|
||||
{ "ACNT", PRV$V_ACNT },
|
||||
{ "ALLSPOOL", PRV$V_ALLSPOOL },
|
||||
{ "ALTPRI", PRV$V_ALTPRI },
|
||||
{ "BUGCHK", PRV$V_BUGCHK },
|
||||
{ "BYPASS", PRV$V_BYPASS },
|
||||
{ "CMEXEC", PRV$V_CMEXEC },
|
||||
{ "CMKRNL", PRV$V_CMKRNL },
|
||||
{ "DETACH", PRV$V_DETACH },
|
||||
{ "DIAGNOSE", PRV$V_DIAGNOSE },
|
||||
{ "DOWNGRADE", PRV$V_DOWNGRADE }, /* Isn't VMS as low as you can go? */
|
||||
{ "EXQUOTA", PRV$V_EXQUOTA },
|
||||
{ "GRPPRV", PRV$V_GRPPRV },
|
||||
{ "GROUP", PRV$V_GROUP },
|
||||
{ "GRPNAM", PRV$V_GRPNAM },
|
||||
{ "LOG_IO", PRV$V_LOG_IO },
|
||||
{ "MOUNT", PRV$V_MOUNT },
|
||||
{ "NETMBX", PRV$V_NETMBX },
|
||||
{ "NOACNT", PRV$V_NOACNT },
|
||||
{ "OPER", PRV$V_OPER },
|
||||
{ "PFNMAP", PRV$V_PFNMAP },
|
||||
{ "PHY_IO", PRV$V_PHY_IO },
|
||||
{ "PRMCEB", PRV$V_PRMCEB },
|
||||
{ "PRMGBL", PRV$V_PRMGBL },
|
||||
{ "PRMJNL", PRV$V_PRMJNL },
|
||||
{ "PRMMBX", PRV$V_PRMMBX },
|
||||
{ "PSWAPM", PRV$V_PSWAPM },
|
||||
{ "READALL", PRV$V_READALL },
|
||||
{ "SECURITY", PRV$V_SECURITY },
|
||||
{ "SETPRI", PRV$V_SETPRI },
|
||||
{ "SETPRV", PRV$V_SETPRV },
|
||||
{ "SHARE", PRV$V_SHARE },
|
||||
{ "SHMEM", PRV$V_SHMEM },
|
||||
{ "SYSGBL", PRV$V_SYSGBL },
|
||||
{ "SYSLCK", PRV$V_SYSLCK },
|
||||
{ "SYSNAM", PRV$V_SYSNAM },
|
||||
{ "SYSPRV", PRV$V_SYSPRV },
|
||||
{ "TMPJNL", PRV$V_TMPJNL },
|
||||
{ "TMPMBX", PRV$V_TMPMBX },
|
||||
{ "UPGRADE", PRV$V_UPGRADE },
|
||||
{ "VOLPRO", PRV$V_VOLPRO },
|
||||
{ "WORLD", PRV$V_WORLD },
|
||||
|
||||
};
|
||||
|
||||
static Lisp_Object
|
||||
vms_account(), vms_cliname(), vms_owner(), vms_grp(), vms_image(),
|
||||
vms_parent(), vms_pid(), vms_prcnam(), vms_terminal(), vms_uic_int(),
|
||||
vms_uic_str(), vms_username(), vms_version_fn(), vms_trnlog(),
|
||||
vms_symbol(), vms_proclist();
|
||||
|
||||
/* Table of arguments to Fvms_object, and the handlers that get the data. */
|
||||
|
||||
static struct vms_objlist vms_object [] = {
|
||||
{ "ACCOUNT", vms_account }, /* Returns account name as a string */
|
||||
{ "CLINAME", vms_cliname }, /* Returns CLI name (string) */
|
||||
{ "OWNER", vms_owner }, /* Returns owner process's PID (int) */
|
||||
{ "GRP", vms_grp }, /* Returns group number of UIC (int) */
|
||||
{ "IMAGE", vms_image }, /* Returns executing image (string) */
|
||||
{ "PARENT", vms_parent }, /* Returns parent proc's PID (int) */
|
||||
{ "PID", vms_pid }, /* Returns process's PID (int) */
|
||||
{ "PRCNAM", vms_prcnam }, /* Returns process's name (string) */
|
||||
{ "TERMINAL", vms_terminal }, /* Returns terminal name (string) */
|
||||
{ "UIC", vms_uic_int }, /* Returns UIC as integer */
|
||||
{ "UICGRP", vms_uic_str }, /* Returns UIC as string */
|
||||
{ "USERNAME", vms_username }, /* Returns username (string) */
|
||||
{ "VERSION", vms_version_fn },/* Returns VMS version (string) */
|
||||
{ "LOGICAL", vms_trnlog }, /* Translates VMS logical name */
|
||||
{ "DCL-SYMBOL", vms_symbol }, /* Translates DCL symbol */
|
||||
{ "PROCLIST", vms_proclist }, /* Returns list of all PIDs on system */
|
||||
};
|
||||
|
||||
Lisp_Object Qdefault_subproc_input_handler;
|
||||
|
||||
extern int process_ef; /* Event flag for subprocess operations */
|
||||
|
||||
DEFUN ("default-subprocess-input-handler",
|
||||
Fdefault_subproc_input_handler, Sdefault_subproc_input_handler,
|
||||
2, 2, 0,
|
||||
"Default input handler for input from spawned subprocesses.")
|
||||
(name, input)
|
||||
Lisp_Object name, input;
|
||||
{
|
||||
/* Just insert in current buffer */
|
||||
insert1 (input);
|
||||
insert ("\n", 1);
|
||||
}
|
||||
|
||||
DEFUN ("spawn-subprocess", Fspawn_subprocess, Sspawn_subprocess, 1, 3, 0,
|
||||
"Spawn an asynchronous VMS suprocess for command processing.")
|
||||
(name, input_handler, exit_handler)
|
||||
Lisp_Object name, input_handler, exit_handler;
|
||||
{
|
||||
int status;
|
||||
char output_mbx_name[20];
|
||||
struct dsc$descriptor_s output_mbx_dsc;
|
||||
struct process_list *ptr, *p, *prev;
|
||||
|
||||
CHECK_NUMBER (name, 0);
|
||||
if (! input_mbx_chan)
|
||||
{
|
||||
if (! create_mbx (&input_mbx_dsc, input_mbx_name, &input_mbx_chan, 1))
|
||||
return Qnil;
|
||||
start_mbx_input ();
|
||||
}
|
||||
ptr = 0;
|
||||
prev = 0;
|
||||
while (ptr)
|
||||
{
|
||||
struct process_list *next = ptr->next;
|
||||
if (ptr->name == XFASTINT (name))
|
||||
{
|
||||
if (ptr->process_active)
|
||||
return Qt;
|
||||
|
||||
/* Delete this process and run its exit handler. */
|
||||
if (prev)
|
||||
prev->next = next;
|
||||
else
|
||||
process_list = next;
|
||||
if (! NULL (ptr->exit_handler))
|
||||
Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name),
|
||||
Qnil)));
|
||||
sys$dassgn (ptr->mbx_chan);
|
||||
break;
|
||||
}
|
||||
else
|
||||
prev = ptr;
|
||||
ptr = next;
|
||||
}
|
||||
if (! ptr)
|
||||
ptr = xmalloc (sizeof (struct process_list));
|
||||
if (! create_mbx (&output_mbx_dsc, output_mbx_name, &ptr->mbx_chan, 2))
|
||||
{
|
||||
free (ptr);
|
||||
return Qnil;
|
||||
}
|
||||
if (NULL (input_handler))
|
||||
input_handler = Qdefault_subproc_input_handler;
|
||||
ptr->input_handler = input_handler;
|
||||
ptr->exit_handler = exit_handler;
|
||||
message ("Creating subprocess...");
|
||||
status = lib$spawn (0, &output_mbx_dsc, &input_mbx_dsc, &CLI$M_NOWAIT, 0,
|
||||
&ptr->process_id, 0, 0, exit_ast, &ptr->process_active);
|
||||
if (! (status & 1))
|
||||
{
|
||||
sys$dassgn (ptr->mbx_chan);
|
||||
free (ptr);
|
||||
error ("Unable to spawn subprocess");
|
||||
return Qnil;
|
||||
}
|
||||
ptr->name = XFASTINT (name);
|
||||
ptr->next = process_list;
|
||||
ptr->process_active = 1;
|
||||
process_list = ptr;
|
||||
message ("Creating subprocess...done");
|
||||
return Qt;
|
||||
}
|
||||
|
||||
static void
|
||||
mbx_msg (ptr, msg)
|
||||
struct process_list *ptr;
|
||||
char *msg;
|
||||
{
|
||||
write_to_mbx (ptr, msg, strlen (msg));
|
||||
}
|
||||
|
||||
DEFUN ("send-command-to-subprocess",
|
||||
Fsend_command_to_subprocess, Ssend_command_to_subprocess, 2, 2,
|
||||
"sSend command to subprocess: \nsSend subprocess %s command: ",
|
||||
"Send to VMS subprocess named NAME the string COMMAND.")
|
||||
(name, command)
|
||||
Lisp_Object name, command;
|
||||
{
|
||||
struct process_list * ptr;
|
||||
|
||||
CHECK_NUMBER (name, 0);
|
||||
CHECK_STRING (command, 1);
|
||||
for (ptr = process_list; ptr; ptr = ptr->next)
|
||||
if (XFASTINT (name) == ptr->name)
|
||||
{
|
||||
write_to_mbx (ptr, XSTRING (command)->data,
|
||||
XSTRING (command)->size);
|
||||
return Qt;
|
||||
}
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
DEFUN ("stop-subprocess", Fstop_subprocess, Sstop_subprocess, 1, 1,
|
||||
"sStop subprocess: ", "Stop VMS subprocess named NAME.")
|
||||
(name)
|
||||
Lisp_Object name;
|
||||
{
|
||||
struct process_list * ptr;
|
||||
|
||||
CHECK_NUMBER (name, 0);
|
||||
for (ptr = process_list; ptr; ptr = ptr->next)
|
||||
if (XFASTINT (name) == ptr->name)
|
||||
{
|
||||
ptr->exit_handler = Qnil;
|
||||
if (sys$delprc (&ptr->process_id, 0) & 1)
|
||||
ptr->process_active = 0;
|
||||
return Qt;
|
||||
}
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
static int
|
||||
exit_ast (active)
|
||||
int * active;
|
||||
{
|
||||
process_exited = 1;
|
||||
*active = 0;
|
||||
sys$setef (process_ef);
|
||||
}
|
||||
|
||||
/* Process to handle input on the input mailbox.
|
||||
* Searches through the list of processes until the matching PID is found,
|
||||
* then calls its input handler.
|
||||
*/
|
||||
|
||||
process_command_input ()
|
||||
{
|
||||
struct process_list * ptr;
|
||||
char * msg;
|
||||
int msglen;
|
||||
Lisp_Object expr;
|
||||
|
||||
msg = mbx_buffer;
|
||||
msglen = input_iosb.size;
|
||||
/* Hack around VMS oddity of sending extraneous CR/LF characters for
|
||||
* some of the commands (but not most).
|
||||
*/
|
||||
if (msglen > 0 && *msg == '\r')
|
||||
{
|
||||
msg++;
|
||||
msglen--;
|
||||
}
|
||||
if (msglen > 0 && msg[msglen - 1] == '\n')
|
||||
msglen--;
|
||||
if (msglen > 0 && msg[msglen - 1] == '\r')
|
||||
msglen--;
|
||||
/* Search for the subprocess in the linked list.
|
||||
*/
|
||||
expr = Qnil;
|
||||
for (ptr = process_list; ptr; ptr = ptr->next)
|
||||
if (ptr->process_id == input_iosb.pid)
|
||||
{
|
||||
expr = Fcons (ptr->input_handler,
|
||||
Fcons (make_number (ptr->name),
|
||||
Fcons (make_string (msg, msglen),
|
||||
Qnil)));
|
||||
break;
|
||||
}
|
||||
have_process_input = 0;
|
||||
start_mbx_input ();
|
||||
clear_waiting_for_input (); /* Otherwise Ctl-g will cause crash. JCB */
|
||||
if (! NULL (expr))
|
||||
Feval (expr);
|
||||
}
|
||||
|
||||
/* Searches process list for any processes which have exited. Calls their
|
||||
* exit handlers and removes them from the process list.
|
||||
*/
|
||||
|
||||
process_exit ()
|
||||
{
|
||||
struct process_list * ptr, * prev, * next;
|
||||
|
||||
process_exited = 0;
|
||||
prev = 0;
|
||||
ptr = process_list;
|
||||
while (ptr)
|
||||
{
|
||||
next = ptr->next;
|
||||
if (! ptr->process_active)
|
||||
{
|
||||
if (prev)
|
||||
prev->next = next;
|
||||
else
|
||||
process_list = next;
|
||||
if (! NULL (ptr->exit_handler))
|
||||
Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name),
|
||||
Qnil)));
|
||||
sys$dassgn (ptr->mbx_chan);
|
||||
free (ptr);
|
||||
}
|
||||
else
|
||||
prev = ptr;
|
||||
ptr = next;
|
||||
}
|
||||
}
|
||||
|
||||
/* Called at emacs exit.
|
||||
*/
|
||||
|
||||
kill_vms_processes ()
|
||||
{
|
||||
struct process_list * ptr;
|
||||
|
||||
for (ptr = process_list; ptr; ptr = ptr->next)
|
||||
if (ptr->process_active)
|
||||
{
|
||||
sys$dassgn (ptr->mbx_chan);
|
||||
sys$delprc (&ptr->process_id, 0);
|
||||
}
|
||||
sys$dassgn (input_mbx_chan);
|
||||
process_list = 0;
|
||||
input_mbx_chan = 0;
|
||||
}
|
||||
|
||||
/* Creates a temporary mailbox and retrieves its device name in 'buf'.
|
||||
* Makes the descriptor pointed to by 'dsc' refer to this device.
|
||||
* 'buffer_factor' is used to allow sending messages asynchronously
|
||||
* till some point.
|
||||
*/
|
||||
|
||||
static int
|
||||
create_mbx (dsc, buf, chan, buffer_factor)
|
||||
struct dsc$descriptor_s *dsc;
|
||||
char *buf;
|
||||
int *chan;
|
||||
int buffer_factor;
|
||||
{
|
||||
int strval[2];
|
||||
int status;
|
||||
|
||||
status = sys$crembx (0, chan, MSGSIZE, MSGSIZE * buffer_factor, 0, 0, 0);
|
||||
if (! (status & 1))
|
||||
{
|
||||
message ("Unable to create mailbox. Need TMPMBX privilege.");
|
||||
return 0;
|
||||
}
|
||||
strval[0] = 16;
|
||||
strval[1] = buf;
|
||||
status = lib$getdvi (&DVI$_DEVNAM, chan, 0, 0, strval,
|
||||
&dsc->dsc$w_length);
|
||||
if (! (status & 1))
|
||||
return 0;
|
||||
dsc->dsc$b_dtype = DSC$K_DTYPE_T;
|
||||
dsc->dsc$b_class = DSC$K_CLASS_S;
|
||||
dsc->dsc$a_pointer = buf;
|
||||
return 1;
|
||||
} /* create_mbx */
|
||||
|
||||
/* AST routine to be called upon receiving mailbox input.
|
||||
* Sets flag telling keyboard routines that input is available.
|
||||
*/
|
||||
|
||||
static int
|
||||
mbx_input_ast ()
|
||||
{
|
||||
have_process_input = 1;
|
||||
}
|
||||
|
||||
/* Issue a QIO request on the input mailbox.
|
||||
*/
|
||||
static void
|
||||
start_mbx_input ()
|
||||
{
|
||||
sys$qio (process_ef, input_mbx_chan, IO$_READVBLK, &input_iosb,
|
||||
mbx_input_ast, 0, mbx_buffer, sizeof (mbx_buffer),
|
||||
0, 0, 0, 0);
|
||||
}
|
||||
|
||||
/* Send a message to the subprocess input mailbox, without blocking if
|
||||
* possible.
|
||||
*/
|
||||
static void
|
||||
write_to_mbx (ptr, buf, len)
|
||||
struct process_list *ptr;
|
||||
char *buf;
|
||||
int len;
|
||||
{
|
||||
sys$qiow (0, ptr->mbx_chan, IO$_WRITEVBLK | IO$M_NOW, &ptr->iosb,
|
||||
0, 0, buf, len, 0, 0, 0, 0);
|
||||
}
|
||||
|
||||
DEFUN ("setprv", Fsetprv, Ssetprv, 1, 3, 0,
|
||||
"Set or reset a VMS privilege. First arg is privilege name.\n\
|
||||
Second arg is t or nil, indicating whether the privilege is to be\n\
|
||||
set or reset. Default is nil. Returns t if success, nil if not.\n\
|
||||
If third arg is non-nil, does not change privilege, but returns t\n\
|
||||
or nil depending upon whether the privilege is already enabled.")
|
||||
(priv, value, getprv)
|
||||
Lisp_Object priv, value, getprv;
|
||||
{
|
||||
int prvmask[2], prvlen, newmask[2];
|
||||
char * prvname;
|
||||
int found, i;
|
||||
struct privilege_list * ptr;
|
||||
|
||||
CHECK_STRING (priv, 0);
|
||||
priv = Fupcase (priv);
|
||||
prvname = XSTRING (priv)->data;
|
||||
prvlen = XSTRING (priv)->size;
|
||||
found = 0;
|
||||
prvmask[0] = 0;
|
||||
prvmask[1] = 0;
|
||||
for (i = 0; i < sizeof (priv_list) / sizeof (priv_list[0]); i++)
|
||||
{
|
||||
ptr = &priv_list[i];
|
||||
if (prvlen == strlen (ptr->name) &&
|
||||
bcmp (prvname, ptr->name, prvlen) == 0)
|
||||
{
|
||||
if (ptr->mask >= 32)
|
||||
prvmask[1] = 1 << (ptr->mask % 32);
|
||||
else
|
||||
prvmask[0] = 1 << ptr->mask;
|
||||
found = 1;
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (! found)
|
||||
error ("Unknown privilege name %s", XSTRING (priv)->data);
|
||||
if (NULL (getprv))
|
||||
{
|
||||
if (sys$setprv (NULL (value) ? 0 : 1, prvmask, 0, 0) == SS$_NORMAL)
|
||||
return Qt;
|
||||
return Qnil;
|
||||
}
|
||||
/* Get old priv value */
|
||||
if (sys$setprv (0, 0, 0, newmask) != SS$_NORMAL)
|
||||
return Qnil;
|
||||
if ((newmask[0] & prvmask[0])
|
||||
|| (newmask[1] & prvmask[1]))
|
||||
return Qt;
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
/* Retrieves VMS system information. */
|
||||
|
||||
#ifdef VMS4_4 /* I don't know whether these functions work in old versions */
|
||||
|
||||
DEFUN ("vms-system-info", Fvms_system_info, Svms_system_info, 1, 3, 0,
|
||||
"Retrieve VMS process and system information.\n\
|
||||
The first argument (a string) specifies the type of information desired.\n\
|
||||
The other arguments depend on the type you select.\n\
|
||||
For information about a process, the second argument is a process ID\n\
|
||||
or a process name, with the current process as a default.\n\
|
||||
These are the possibilities for the first arg (upper or lower case ok):\n\
|
||||
account Returns account name\n\
|
||||
cliname Returns CLI name\n\
|
||||
owner Returns owner process's PID\n\
|
||||
grp Returns group number\n\
|
||||
parent Returns parent process's PID\n\
|
||||
pid Returns process's PID\n\
|
||||
prcnam Returns process's name\n\
|
||||
terminal Returns terminal name\n\
|
||||
uic Returns UIC number\n\
|
||||
uicgrp Returns formatted [UIC,GRP]\n\
|
||||
username Returns username\n\
|
||||
version Returns VMS version\n\
|
||||
logical Translates VMS logical name (second argument)\n\
|
||||
dcl-symbol Translates DCL symbol (second argument)\n\
|
||||
proclist Returns list of all PIDs on system (needs WORLD privilege)." )
|
||||
(type, arg1, arg2)
|
||||
Lisp_Object type, arg1, arg2;
|
||||
{
|
||||
int i, typelen;
|
||||
char * typename;
|
||||
struct vms_objlist * ptr;
|
||||
|
||||
CHECK_STRING (type, 0);
|
||||
type = Fupcase (type);
|
||||
typename = XSTRING (type)->data;
|
||||
typelen = XSTRING (type)->size;
|
||||
for (i = 0; i < sizeof (vms_object) / sizeof (vms_object[0]); i++)
|
||||
{
|
||||
ptr = &vms_object[i];
|
||||
if (typelen == strlen (ptr->name)
|
||||
&& bcmp (typename, ptr->name, typelen) == 0)
|
||||
return (* ptr->objfn)(arg1, arg2);
|
||||
}
|
||||
error ("Unknown object type %s", typename);
|
||||
}
|
||||
|
||||
/* Given a reference to a VMS process, returns its process id. */
|
||||
|
||||
static int
|
||||
translate_id (pid, owner)
|
||||
Lisp_Object pid;
|
||||
int owner; /* if pid is null/0, return owner. If this
|
||||
* flag is 0, return self. */
|
||||
{
|
||||
int status, code, id, i, numeric, size;
|
||||
char * p;
|
||||
int prcnam[2];
|
||||
|
||||
if (NULL (pid)
|
||||
|| XTYPE (pid) == Lisp_String && XSTRING (pid)->size == 0
|
||||
|| XTYPE (pid) == Lisp_Int && XFASTINT (pid) == 0)
|
||||
{
|
||||
code = owner ? JPI$_OWNER : JPI$_PID;
|
||||
status = lib$getjpi (&code, 0, 0, &id);
|
||||
if (! (status & 1))
|
||||
error ("Cannot find %s: %s",
|
||||
owner ? "owner process" : "process id",
|
||||
vmserrstr (status));
|
||||
return (id);
|
||||
}
|
||||
if (XTYPE (pid) == Lisp_Int)
|
||||
return (XFASTINT (pid));
|
||||
CHECK_STRING (pid, 0);
|
||||
pid = Fupcase (pid);
|
||||
size = XSTRING (pid)->size;
|
||||
p = XSTRING (pid)->data;
|
||||
numeric = 1;
|
||||
id = 0;
|
||||
for (i = 0; i < size; i++, p++)
|
||||
if (isxdigit (*p))
|
||||
{
|
||||
id *= 16;
|
||||
if (*p >= '0' && *p <= '9')
|
||||
id += *p - '0';
|
||||
else
|
||||
id += *p - 'A' + 10;
|
||||
}
|
||||
else
|
||||
{
|
||||
numeric = 0;
|
||||
break;
|
||||
}
|
||||
if (numeric)
|
||||
return (id);
|
||||
prcnam[0] = XSTRING (pid)->size;
|
||||
prcnam[1] = XSTRING (pid)->data;
|
||||
status = lib$getjpi (&JPI$_PID, 0, prcnam, &id);
|
||||
if (! (status & 1))
|
||||
error ("Cannot find process id: %s",
|
||||
vmserrstr (status));
|
||||
return (id);
|
||||
} /* translate_id */
|
||||
|
||||
/* VMS object retrieval functions. */
|
||||
|
||||
static Lisp_Object
|
||||
getjpi (jpicode, arg, numeric)
|
||||
int jpicode; /* Type of GETJPI information */
|
||||
Lisp_Object arg;
|
||||
int numeric; /* 1 if numeric value expected */
|
||||
{
|
||||
int id, status, numval;
|
||||
char str[128];
|
||||
int strdsc[2] = { sizeof (str), str };
|
||||
short strlen;
|
||||
|
||||
id = translate_id (arg, 0);
|
||||
status = lib$getjpi (&jpicode, &id, 0, &numval, strdsc, &strlen);
|
||||
if (! (status & 1))
|
||||
error ("Unable to retrieve information: %s",
|
||||
vmserrstr (status));
|
||||
if (numeric)
|
||||
return (make_number (numval));
|
||||
return (make_string (str, strlen));
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_account (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_ACCOUNT, arg1, 0);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_cliname (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_CLINAME, arg1, 0);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_grp (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_GRP, arg1, 1);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_image (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_IMAGNAME, arg1, 0);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_owner (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_OWNER, arg1, 1);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_parent (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_MASTER_PID, arg1, 1);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_pid (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_PID, arg1, 1);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_prcnam (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_PRCNAM, arg1, 0);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_terminal (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_TERMINAL, arg1, 0);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_uic_int (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_UIC, arg1, 1);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_uic_str (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_UIC, arg1, 0);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_username (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
return getjpi (JPI$_USERNAME, arg1, 0);
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_version_fn (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
char str[40];
|
||||
int status;
|
||||
int strdsc[2] = { sizeof (str), str };
|
||||
short strlen;
|
||||
|
||||
status = lib$getsyi (&SYI$_VERSION, 0, strdsc, &strlen, 0, 0);
|
||||
if (! (status & 1))
|
||||
error ("Unable to obtain version: %s", vmserrstr (status));
|
||||
return (make_string (str, strlen));
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_trnlog (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
char str[100];
|
||||
int status, symdsc[2];
|
||||
int strdsc[2] = { sizeof (str), str };
|
||||
short length, level;
|
||||
|
||||
CHECK_STRING (arg1, 0);
|
||||
symdsc[0] = XSTRING (arg1)->size;
|
||||
symdsc[1] = XSTRING (arg1)->data;
|
||||
status = lib$sys_trnlog (symdsc, &length, strdsc);
|
||||
if (! (status & 1))
|
||||
error ("Unable to translate logical name: %s", vmserrstr (status));
|
||||
if (status == SS$_NOTRAN)
|
||||
return (Qnil);
|
||||
return (make_string (str, length));
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_symbol (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
char str[100];
|
||||
int status, symdsc[2];
|
||||
int strdsc[2] = { sizeof (str), str };
|
||||
short length, level;
|
||||
|
||||
CHECK_STRING (arg1, 0);
|
||||
symdsc[0] = XSTRING (arg1)->size;
|
||||
symdsc[1] = XSTRING (arg1)->data;
|
||||
status = lib$get_symbol (symdsc, strdsc, &length, &level);
|
||||
if (! (status & 1)) {
|
||||
if (status == LIB$_NOSUCHSYM)
|
||||
return (Qnil);
|
||||
else
|
||||
error ("Unable to translate symbol: %s", vmserrstr (status));
|
||||
}
|
||||
return (make_string (str, length));
|
||||
}
|
||||
|
||||
static Lisp_Object
|
||||
vms_proclist (arg1, arg2)
|
||||
Lisp_Object arg1, arg2;
|
||||
{
|
||||
Lisp_Object retval;
|
||||
int id, status, pid;
|
||||
|
||||
retval = Qnil;
|
||||
pid = -1;
|
||||
for (;;)
|
||||
{
|
||||
status = lib$getjpi (&JPI$_PID, &pid, 0, &id);
|
||||
if (status == SS$_NOMOREPROC)
|
||||
break;
|
||||
if (! (status & 1))
|
||||
error ("Unable to get process ID: %s", vmserrstr (status));
|
||||
retval = Fcons (make_number (id), retval);
|
||||
}
|
||||
return (Fsort (retval, intern ("<")));
|
||||
}
|
||||
|
||||
DEFUN ("shrink-to-icon", Fshrink_to_icon, Sshrink_to_icon, 0, 0, 0,
|
||||
"If emacs is running in a workstation window, shrink to an icon.")
|
||||
()
|
||||
{
|
||||
static char result[128];
|
||||
static $DESCRIPTOR (result_descriptor, result);
|
||||
static $DESCRIPTOR (tt_name, "TT:");
|
||||
static int chan = 0;
|
||||
static int buf = 0x9d + ('2'<<8) + ('2'<<16) + (0x9c<<24);
|
||||
int status;
|
||||
static int temp = JPI$_TERMINAL;
|
||||
|
||||
status = lib$getjpi (&temp, 0, 0, 0, &result_descriptor, 0);
|
||||
if (status != SS$_NORMAL)
|
||||
error ("Unable to determine terminal type.");
|
||||
if (result[0] != 'W' || result[1] != 'T') /* see if workstation */
|
||||
error ("Can't shrink-to-icon on a non workstation terminal");
|
||||
if (!chan) /* assign channel if not assigned */
|
||||
if ((status = sys$assign (&tt_name, &chan, 0, 0)) != SS$_NORMAL)
|
||||
error ("Can't assign terminal, %d", status);
|
||||
status = sys$qiow (0, chan, IO$_WRITEVBLK+IO$M_BREAKTHRU, 0, 0, 0,
|
||||
&buf, 4, 0, 0, 0, 0);
|
||||
if (status != SS$_NORMAL)
|
||||
error ("Can't shrink-to-icon, %d", status);
|
||||
}
|
||||
|
||||
#endif /* VMS4_4 */
|
||||
|
||||
init_vmsfns ()
|
||||
{
|
||||
process_list = 0;
|
||||
input_mbx_chan = 0;
|
||||
}
|
||||
|
||||
syms_of_vmsfns ()
|
||||
{
|
||||
defsubr (&Sdefault_subproc_input_handler);
|
||||
defsubr (&Sspawn_subprocess);
|
||||
defsubr (&Ssend_command_to_subprocess);
|
||||
defsubr (&Sstop_subprocess);
|
||||
defsubr (&Ssetprv);
|
||||
#ifdef VMS4_4
|
||||
defsubr (&Svms_system_info);
|
||||
defsubr (&Sshrink_to_icon);
|
||||
#endif /* VMS4_4 */
|
||||
Qdefault_subproc_input_handler = intern ("default-subprocess-input-handler");
|
||||
staticpro (&Qdefault_subproc_input_handler);
|
||||
}
|
||||
#endif /* VMS */
|
||||
|
||||
Loading…
Reference in a new issue