mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-01-17 17:58:46 +00:00
Initial revision
This commit is contained in:
Jim Blandy
parent
89758ab855
commit
0d20f9a04e
181
lisp/electric.el
Normal file
181
lisp/electric.el
Normal file
@ -0,0 +1,181 @@
|
||||
;; electric -- Window maker and Command loop for `electric' modes.
|
||||
;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
|
||||
;; Principal author K. Shane Hartman
|
||||
|
||||
;; 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.
|
||||
|
||||
|
||||
(provide 'electric) ; zaaaaaaap
|
||||
|
||||
;; perhaps this should be in subr.el...
|
||||
(defun shrink-window-if-larger-than-buffer (window)
|
||||
(save-excursion
|
||||
(set-buffer (window-buffer window))
|
||||
(let ((w (selected-window)) ;save-window-excursion can't win
|
||||
(buffer-file-name buffer-file-name)
|
||||
(p (point))
|
||||
(n 0)
|
||||
(window-min-height 0)
|
||||
(buffer-read-only nil)
|
||||
(modified (buffer-modified-p))
|
||||
(buffer (current-buffer)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(select-window window)
|
||||
(goto-char (point-min))
|
||||
(while (pos-visible-in-window-p (point-max))
|
||||
;; defeat file locking... don't try this at home, kids!
|
||||
(setq buffer-file-name nil)
|
||||
(insert ?\n) (setq n (1+ n)))
|
||||
(if (> n 0) (shrink-window (1- n))))
|
||||
(delete-region (point-min) (point))
|
||||
(set-buffer-modified-p modified)
|
||||
(goto-char p)
|
||||
(select-window w)
|
||||
;; Make sure we unbind buffer-read-only
|
||||
;; with the proper current buffer.
|
||||
(set-buffer buffer)))))
|
||||
|
||||
;; This loop is the guts for non-standard modes which retain control
|
||||
;; until some event occurs. It is a `do-forever', the only way out is to
|
||||
;; throw. It assumes that you have set up the keymap, window, and
|
||||
;; everything else: all it does is read commands and execute them -
|
||||
;; providing error messages should one occur (if there is no loop
|
||||
;; function - which see). The required argument is a tag which should
|
||||
;; expect a value of nil if the user decides to punt. The
|
||||
;; second argument is a prompt string (defaults to "->"). Given third
|
||||
;; argument non-nil, it INHIBITS quitting unless the user types C-g at
|
||||
;; toplevel. This is so user can do things like C-u C-g and not get
|
||||
;; thrown out. Fourth argument, if non-nil, should be a function of two
|
||||
;; arguments which is called after every command is executed. The fifth
|
||||
;; argument, if provided, is the state variable for the function. If the
|
||||
;; loop-function gets an error, the loop will abort WITHOUT throwing
|
||||
;; (moral: use unwind-protect around call to this function for any
|
||||
;; critical stuff). The second argument for the loop function is the
|
||||
;; conditions for any error that occurred or nil if none.
|
||||
|
||||
(defun Electric-command-loop (return-tag
|
||||
&optional prompt inhibit-quit
|
||||
loop-function loop-state)
|
||||
(if (not prompt) (setq prompt "->"))
|
||||
(let (cmd (err nil))
|
||||
(while t
|
||||
(setq cmd (read-key-sequence (if (stringp prompt)
|
||||
prompt (funcall prompt))))
|
||||
(setq last-command-char (aref cmd (1- (length cmd)))
|
||||
this-command (key-binding cmd)
|
||||
cmd this-command)
|
||||
(if (or (prog1 quit-flag (setq quit-flag nil))
|
||||
(= last-input-char ?\C-g))
|
||||
(progn (setq unread-command-char -1
|
||||
prefix-arg nil)
|
||||
;; If it wasn't cancelling a prefix character, then quit.
|
||||
(if (or (= (length (this-command-keys)) 1)
|
||||
(not inhibit-quit)) ; safety
|
||||
(progn (ding)
|
||||
(message "Quit")
|
||||
(throw return-tag nil))
|
||||
(setq cmd nil))))
|
||||
(setq current-prefix-arg prefix-arg)
|
||||
(if cmd
|
||||
(condition-case conditions
|
||||
(progn (command-execute cmd)
|
||||
(if (or (prog1 quit-flag (setq quit-flag nil))
|
||||
(= last-input-char ?\C-g))
|
||||
(progn (setq unread-command-char -1)
|
||||
(if (not inhibit-quit)
|
||||
(progn (ding)
|
||||
(message "Quit")
|
||||
(throw return-tag nil))
|
||||
(ding)))))
|
||||
(buffer-read-only (if loop-function
|
||||
(setq err conditions)
|
||||
(ding)
|
||||
(message "Buffer is read-only")
|
||||
(sit-for 2)))
|
||||
(beginning-of-buffer (if loop-function
|
||||
(setq err conditions)
|
||||
(ding)
|
||||
(message "Beginning of Buffer")
|
||||
(sit-for 2)))
|
||||
(end-of-buffer (if loop-function
|
||||
(setq err conditions)
|
||||
(ding)
|
||||
(message "End of Buffer")
|
||||
(sit-for 2)))
|
||||
(error (if loop-function
|
||||
(setq err conditions)
|
||||
(ding)
|
||||
(message "Error: %s"
|
||||
(if (eq (car conditions) 'error)
|
||||
(car (cdr conditions))
|
||||
(prin1-to-string conditions)))
|
||||
(sit-for 2))))
|
||||
(ding))
|
||||
(if loop-function (funcall loop-function loop-state err))))
|
||||
(ding)
|
||||
(throw return-tag nil))
|
||||
|
||||
;; This function is like pop-to-buffer, sort of.
|
||||
;; The algorithm is
|
||||
;; If there is a window displaying buffer
|
||||
;; Select it
|
||||
;; Else if there is only one window
|
||||
;; Split it, selecting the window on the bottom with height being
|
||||
;; the lesser of max-height (if non-nil) and the number of lines in
|
||||
;; the buffer to be displayed subject to window-min-height constraint.
|
||||
;; Else
|
||||
;; Switch to buffer in the current window.
|
||||
;;
|
||||
;; Then if max-height is nil, and not all of the lines in the buffer
|
||||
;; are displayed, grab the whole screen.
|
||||
;;
|
||||
;; Returns selected window on buffer positioned at point-min.
|
||||
|
||||
(defun Electric-pop-up-window (buffer &optional max-height)
|
||||
(let* ((win (or (get-buffer-window buffer) (selected-window)))
|
||||
(buf (get-buffer buffer))
|
||||
(one-window (one-window-p t))
|
||||
(pop-up-windows t)
|
||||
(target-height)
|
||||
(lines))
|
||||
(if (not buf)
|
||||
(error "Buffer %s does not exist" buffer)
|
||||
(save-excursion
|
||||
(set-buffer buf)
|
||||
(setq lines (count-lines (point-min) (point-max)))
|
||||
(setq target-height
|
||||
(min (max (if max-height (min max-height (1+ lines)) (1+ lines))
|
||||
window-min-height)
|
||||
(save-window-excursion
|
||||
(delete-other-windows)
|
||||
(1- (window-height (selected-window)))))))
|
||||
(cond ((and (eq (window-buffer win) buf))
|
||||
(select-window win))
|
||||
(one-window
|
||||
(goto-char (window-start win))
|
||||
(pop-to-buffer buffer)
|
||||
(setq win (selected-window))
|
||||
(enlarge-window (- target-height (window-height win))))
|
||||
(t
|
||||
(switch-to-buffer buf)))
|
||||
(if (and (not max-height)
|
||||
(> target-height (window-height (selected-window))))
|
||||
(progn (goto-char (window-start win))
|
||||
(enlarge-window (- target-height (window-height win)))))
|
||||
(goto-char (point-min))
|
||||
win)))
|
||||
405
lisp/emulation/mlsupport.el
Normal file
405
lisp/emulation/mlsupport.el
Normal file
@ -0,0 +1,405 @@
|
||||
;; Run-time support for mocklisp code.
|
||||
;; Copyright (C) 1985 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.
|
||||
|
||||
|
||||
(provide 'mlsupport)
|
||||
|
||||
(defmacro ml-defun (&rest defs)
|
||||
(list 'ml-defun-1 (list 'quote defs)))
|
||||
|
||||
(defun ml-defun-1 (args)
|
||||
(while args
|
||||
(fset (car (car args)) (cons 'mocklisp (cdr (car args))))
|
||||
(setq args (cdr args))))
|
||||
|
||||
(defmacro declare-buffer-specific (&rest vars)
|
||||
(cons 'progn (mapcar (function (lambda (var) (list 'make-variable-buffer-local (list 'quote var)))) vars)))
|
||||
|
||||
(defun ml-set-default (varname value)
|
||||
(set-default (intern varname) value))
|
||||
|
||||
; Lossage: must make various things default missing args to the prefix arg
|
||||
; Alternatively, must make provide-prefix-argument do something hairy.
|
||||
|
||||
(defun >> (val count) (lsh val (- count)))
|
||||
(defun novalue () nil)
|
||||
|
||||
(defun ml-not (arg) (if (zerop arg) 1 0))
|
||||
|
||||
(defun provide-prefix-arg (arg form)
|
||||
(funcall (car form) arg))
|
||||
|
||||
(defun define-keymap (name)
|
||||
(fset (intern name) (make-keymap)))
|
||||
|
||||
(defun ml-use-local-map (name)
|
||||
(use-local-map (intern (concat name "-map"))))
|
||||
|
||||
(defun ml-use-global-map (name)
|
||||
(use-global-map (intern (concat name "-map"))))
|
||||
|
||||
(defun local-bind-to-key (name key)
|
||||
(or (current-local-map)
|
||||
(use-local-map (make-keymap)))
|
||||
(define-key (current-local-map)
|
||||
(if (integerp key)
|
||||
(if (>= key 128)
|
||||
(concat (char-to-string meta-prefix-char)
|
||||
(char-to-string (- key 128)))
|
||||
(char-to-string key))
|
||||
key)
|
||||
(intern name)))
|
||||
|
||||
(defun bind-to-key (name key)
|
||||
(define-key global-map (if (integerp key) (char-to-string key) key)
|
||||
(intern name)))
|
||||
|
||||
(defun ml-autoload (name file)
|
||||
(autoload (intern name) file))
|
||||
|
||||
(defun ml-define-string-macro (name defn)
|
||||
(fset (intern name) defn))
|
||||
|
||||
(defun push-back-character (char)
|
||||
(setq unread-command-char char))
|
||||
|
||||
(defun to-col (column)
|
||||
(indent-to column 0))
|
||||
|
||||
(defmacro is-bound (&rest syms)
|
||||
(cons 'and (mapcar (function (lambda (sym) (list 'boundp (list 'quote sym)))) syms)))
|
||||
|
||||
(defmacro declare-global (&rest syms)
|
||||
(cons 'progn (mapcar (function (lambda (sym) (list 'defvar sym nil))) syms)))
|
||||
|
||||
(defmacro error-occurred (&rest body)
|
||||
(list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
|
||||
|
||||
(defun return-prefix-argument (value)
|
||||
(setq prefix-arg value))
|
||||
|
||||
(defun ml-prefix-argument ()
|
||||
(if (null current-prefix-arg) 1
|
||||
(if (listp current-prefix-arg) (car current-prefix-arg)
|
||||
(if (eq current-prefix-arg '-) -1
|
||||
current-prefix-arg))))
|
||||
|
||||
(defun ml-print (varname)
|
||||
(interactive "vPrint variable: ")
|
||||
(if (boundp varname)
|
||||
(message "%s => %s" (symbol-name varname) (symbol-value varname))
|
||||
(message "%s has no value" (symbol-name varname))))
|
||||
|
||||
(defun ml-set (str val) (set (intern str) val))
|
||||
|
||||
(defun ml-message (&rest args) (message "%s" (apply 'concat args)))
|
||||
|
||||
(defun kill-to-end-of-line ()
|
||||
(ml-prefix-argument-loop
|
||||
(if (eolp)
|
||||
(kill-region (point) (1+ (point)))
|
||||
(kill-region (point) (if (search-forward ?\n nil t)
|
||||
(1- (point)) (point-max))))))
|
||||
|
||||
(defun set-auto-fill-hook (arg)
|
||||
(setq auto-fill-function (intern arg)))
|
||||
|
||||
(defun auto-execute (function pattern)
|
||||
(if (/= (aref pattern 0) ?*)
|
||||
(error "Only patterns starting with * supported in auto-execute"))
|
||||
(setq auto-mode-alist (cons (cons (concat "\\." (substring pattern 1)
|
||||
"$")
|
||||
function)
|
||||
auto-mode-alist)))
|
||||
|
||||
(defun move-to-comment-column ()
|
||||
(indent-to comment-column))
|
||||
|
||||
(defun erase-region ()
|
||||
(delete-region (point) (mark)))
|
||||
|
||||
(defun delete-region-to-buffer (bufname)
|
||||
(copy-to-buffer bufname (point) (mark))
|
||||
(delete-region (point) (mark)))
|
||||
|
||||
(defun copy-region-to-buffer (bufname)
|
||||
(copy-to-buffer bufname (point) (mark)))
|
||||
|
||||
(defun append-region-to-buffer (bufname)
|
||||
(append-to-buffer bufname (point) (mark)))
|
||||
|
||||
(defun prepend-region-to-buffer (bufname)
|
||||
(prepend-to-buffer bufname (point) (mark)))
|
||||
|
||||
(defun delete-next-character ()
|
||||
(delete-char (ml-prefix-argument)))
|
||||
|
||||
(defun delete-next-word ()
|
||||
(delete-region (point) (progn (forward-word (ml-prefix-argument)) (point))))
|
||||
|
||||
(defun delete-previous-word ()
|
||||
(delete-region (point) (progn (backward-word (ml-prefix-argument)) (point))))
|
||||
|
||||
(defun delete-previous-character ()
|
||||
(delete-backward-char (ml-prefix-argument)))
|
||||
|
||||
(defun forward-character ()
|
||||
(forward-char (ml-prefix-argument)))
|
||||
|
||||
(defun backward-character ()
|
||||
(backward-char (ml-prefix-argument)))
|
||||
|
||||
(defun ml-newline ()
|
||||
(newline (ml-prefix-argument)))
|
||||
|
||||
(defun ml-next-line ()
|
||||
(next-line (ml-prefix-argument)))
|
||||
|
||||
(defun ml-previous-line ()
|
||||
(previous-line (ml-prefix-argument)))
|
||||
|
||||
(defun delete-to-kill-buffer ()
|
||||
(kill-region (point) (mark)))
|
||||
|
||||
(defun narrow-region ()
|
||||
(narrow-to-region (point) (mark)))
|
||||
|
||||
(defun ml-newline-and-indent ()
|
||||
(let ((column (current-indentation)))
|
||||
(newline (ml-prefix-argument))
|
||||
(indent-to column)))
|
||||
|
||||
(defun newline-and-backup ()
|
||||
(open-line (ml-prefix-argument)))
|
||||
|
||||
(defun quote-char ()
|
||||
(quoted-insert (ml-prefix-argument)))
|
||||
|
||||
(defun ml-current-column ()
|
||||
(1+ (current-column)))
|
||||
|
||||
(defun ml-current-indent ()
|
||||
(1+ (current-indentation)))
|
||||
|
||||
(defun region-around-match (&optional n)
|
||||
(set-mark (match-beginning n))
|
||||
(goto-char (match-end n)))
|
||||
|
||||
(defun region-to-string ()
|
||||
(buffer-substring (min (point) (mark)) (max (point) (mark))))
|
||||
|
||||
(defun use-abbrev-table (name)
|
||||
(let ((symbol (intern (concat name "-abbrev-table"))))
|
||||
(or (boundp symbol)
|
||||
(define-abbrev-table symbol nil))
|
||||
(symbol-value symbol)))
|
||||
|
||||
(defun define-hooked-local-abbrev (name exp hook)
|
||||
(define-local-abbrev name exp (intern hook)))
|
||||
|
||||
(defun define-hooked-global-abbrev (name exp hook)
|
||||
(define-global-abbrev name exp (intern hook)))
|
||||
|
||||
(defun case-word-lower ()
|
||||
(ml-casify-word 'downcase-region))
|
||||
|
||||
(defun case-word-upper ()
|
||||
(ml-casify-word 'upcase-region))
|
||||
|
||||
(defun case-word-capitalize ()
|
||||
(ml-casify-word 'capitalize-region))
|
||||
|
||||
(defun ml-casify-word (fun)
|
||||
(save-excursion
|
||||
(forward-char 1)
|
||||
(forward-word -1)
|
||||
(funcall fun (point)
|
||||
(progn (forward-word (ml-prefix-argument))
|
||||
(point)))))
|
||||
|
||||
(defun case-region-lower ()
|
||||
(downcase-region (point) (mark)))
|
||||
|
||||
(defun case-region-upper ()
|
||||
(upcase-region (point) (mark)))
|
||||
|
||||
(defun case-region-capitalize ()
|
||||
(capitalize-region (point) (mark)))
|
||||
|
||||
(defvar saved-command-line-args nil)
|
||||
|
||||
(defun argc ()
|
||||
(or saved-command-line-args
|
||||
(setq saved-command-line-args command-line-args
|
||||
command-line-args ()))
|
||||
(length command-line-args))
|
||||
|
||||
(defun argv (i)
|
||||
(or saved-command-line-args
|
||||
(setq saved-command-line-args command-line-args
|
||||
command-line-args ()))
|
||||
(nth i saved-command-line-args))
|
||||
|
||||
(defun invisible-argc ()
|
||||
(length (or saved-command-line-args
|
||||
command-line-args)))
|
||||
|
||||
(defun invisible-argv (i)
|
||||
(nth i (or saved-command-line-args
|
||||
command-line-args)))
|
||||
|
||||
(defun exit-emacs ()
|
||||
(interactive)
|
||||
(condition-case ()
|
||||
(exit-recursive-edit)
|
||||
(error (kill-emacs))))
|
||||
|
||||
;; Lisp function buffer-size returns total including invisible;
|
||||
;; mocklisp wants just visible.
|
||||
(defun ml-buffer-size ()
|
||||
(- (point-max) (point-min)))
|
||||
|
||||
(defun previous-command ()
|
||||
last-command)
|
||||
|
||||
(defun beginning-of-window ()
|
||||
(goto-char (window-start)))
|
||||
|
||||
(defun end-of-window ()
|
||||
(goto-char (window-start))
|
||||
(vertical-motion (- (window-height) 2)))
|
||||
|
||||
(defun ml-search-forward (string)
|
||||
(search-forward string nil nil (ml-prefix-argument)))
|
||||
|
||||
(defun ml-re-search-forward (string)
|
||||
(re-search-forward string nil nil (ml-prefix-argument)))
|
||||
|
||||
(defun ml-search-backward (string)
|
||||
(search-backward string nil nil (ml-prefix-argument)))
|
||||
|
||||
(defun ml-re-search-backward (string)
|
||||
(re-search-backward string nil nil (ml-prefix-argument)))
|
||||
|
||||
(defvar use-users-shell 1
|
||||
"Mocklisp compatibility variable; 1 means use shell from SHELL env var.
|
||||
0 means use /bin/sh.")
|
||||
|
||||
(defvar use-csh-option-f 1
|
||||
"Mocklisp compatibility variable; 1 means pass -f when calling csh.")
|
||||
|
||||
(defun filter-region (command)
|
||||
(let ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh"))
|
||||
(csh (equal (file-name-nondirectory shell) "csh")))
|
||||
(call-process-region (point) (mark) shell t t nil
|
||||
(if (and csh use-csh-option-f) "-cf" "-c")
|
||||
(concat "exec " command))))
|
||||
|
||||
(defun execute-monitor-command (command)
|
||||
(let ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh"))
|
||||
(csh (equal (file-name-nondirectory shell) "csh")))
|
||||
(call-process shell nil t t
|
||||
(if (and csh use-csh-option-f) "-cf" "-c")
|
||||
(concat "exec " command))))
|
||||
|
||||
(defun use-syntax-table (name)
|
||||
(set-syntax-table (symbol-value (intern (concat name "-syntax-table")))))
|
||||
|
||||
(defun line-to-top-of-window ()
|
||||
(recenter (1- (ml-prefix-argument))))
|
||||
|
||||
(defun ml-previous-page (&optional arg)
|
||||
(let ((count (or arg (ml-prefix-argument))))
|
||||
(while (> count 0)
|
||||
(scroll-down nil)
|
||||
(setq count (1- count)))
|
||||
(while (< count 0)
|
||||
(scroll-up nil)
|
||||
(setq count (1+ count)))))
|
||||
|
||||
(defun ml-next-page ()
|
||||
(previous-page (- (ml-prefix-argument))))
|
||||
|
||||
(defun page-next-window (&optional arg)
|
||||
(let ((count (or arg (ml-prefix-argument))))
|
||||
(while (> count 0)
|
||||
(scroll-other-window nil)
|
||||
(setq count (1- count)))
|
||||
(while (< count 0)
|
||||
(scroll-other-window '-)
|
||||
(setq count (1+ count)))))
|
||||
|
||||
(defun ml-next-window ()
|
||||
(select-window (next-window)))
|
||||
|
||||
(defun ml-previous-window ()
|
||||
(select-window (previous-window)))
|
||||
|
||||
(defun scroll-one-line-up ()
|
||||
(scroll-up (ml-prefix-argument)))
|
||||
|
||||
(defun scroll-one-line-down ()
|
||||
(scroll-down (ml-prefix-argument)))
|
||||
|
||||
(defun split-current-window ()
|
||||
(split-window (selected-window)))
|
||||
|
||||
(defun last-key-struck () last-command-char)
|
||||
|
||||
(defun execute-mlisp-line (string)
|
||||
(eval (read string)))
|
||||
|
||||
(defun move-dot-to-x-y (x y)
|
||||
(goto-char (window-start (selected-window)))
|
||||
(vertical-motion (1- y))
|
||||
(move-to-column (1- x)))
|
||||
|
||||
(defun ml-modify-syntax-entry (string)
|
||||
(let ((i 5)
|
||||
(len (length string))
|
||||
(datastring (substring string 0 2)))
|
||||
(if (= (aref string 0) ?\-)
|
||||
(aset datastring 0 ?\ ))
|
||||
(if (= (aref string 2) ?\{)
|
||||
(if (= (aref string 4) ?\ )
|
||||
(aset datastring 0 ?\<)
|
||||
(error "Two-char comment delimiter: use modify-syntax-entry directly")))
|
||||
(if (= (aref string 3) ?\})
|
||||
(if (= (aref string 4) ?\ )
|
||||
(aset datastring 0 ?\>)
|
||||
(error "Two-char comment delimiter: use modify-syntax-entry directly")))
|
||||
(while (< i len)
|
||||
(modify-syntax-entry (aref string i) datastring)
|
||||
(setq i (1+ i))
|
||||
(if (and (< i len)
|
||||
(= (aref string i) ?\-))
|
||||
(let ((c (aref string (1- i)))
|
||||
(lim (aref string (1+ i))))
|
||||
(while (<= c lim)
|
||||
(modify-syntax-entry c datastring)
|
||||
(setq c (1+ c)))
|
||||
(setq i (+ 2 i)))))))
|
||||
|
||||
|
||||
|
||||
(defun ml-substr (string from to)
|
||||
(let ((length (length string)))
|
||||
(if (< from 0) (setq from (+ from length)))
|
||||
(if (< to 0) (setq to (+ to length)))
|
||||
(substring string from (+ from to))))
|
||||
30
lisp/grow-vers.el
Normal file
30
lisp/grow-vers.el
Normal file
@ -0,0 +1,30 @@
|
||||
;; Load this file to add a new level (starting at zero)
|
||||
;; to the Emacs version number recorded in version.el.
|
||||
;; Copyright (C) 1985 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.
|
||||
|
||||
|
||||
(insert-file-contents "lisp/version.el")
|
||||
|
||||
(re-search-forward "emacs-version \"[0-9.]*")
|
||||
(insert ".0")
|
||||
|
||||
;; Delete the share-link with the current version
|
||||
;; so that we do not alter the current version.
|
||||
(delete-file "lisp/version.el")
|
||||
(write-region (point-min) (point-max) "lisp/version.el" nil 'nomsg)
|
||||
43
lisp/inc-vers.el
Normal file
43
lisp/inc-vers.el
Normal file
@ -0,0 +1,43 @@
|
||||
;; Load this file to increment the recorded Emacs version number.
|
||||
;; 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.
|
||||
|
||||
|
||||
(insert-file-contents "../lisp/version.el")
|
||||
|
||||
(re-search-forward "emacs-version \"[^\"]*[0-9]+\"")
|
||||
(forward-char -1)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region (point)
|
||||
(progn (skip-chars-backward "0-9") (point)))
|
||||
(goto-char (point-min))
|
||||
(let ((version (read (current-buffer))))
|
||||
(delete-region (point-min) (point-max))
|
||||
(prin1 (1+ version) (current-buffer)))))
|
||||
(skip-chars-backward "^\"")
|
||||
(message "New Emacs version will be %s"
|
||||
(buffer-substring (point)
|
||||
(progn (skip-chars-forward "^\"") (point))))
|
||||
|
||||
|
||||
(write-region (point-min) (point-max) "../lisp/version.el" nil 'nomsg)
|
||||
(erase-buffer)
|
||||
(set-buffer-modified-p nil)
|
||||
|
||||
(kill-emacs)
|
||||
140
lisp/loadup.el
Normal file
140
lisp/loadup.el
Normal file
@ -0,0 +1,140 @@
|
||||
;;Load up standardly loaded Lisp files for Emacs.
|
||||
;; This is loaded into a bare Emacs to make a dumpable one.
|
||||
;; 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.
|
||||
|
||||
|
||||
(load "subr")
|
||||
(garbage-collect)
|
||||
(load "loaddefs.el") ;Don't get confused if someone compiled loaddefs by mistake.
|
||||
(garbage-collect)
|
||||
(load "simple")
|
||||
(garbage-collect)
|
||||
(load "help")
|
||||
(garbage-collect)
|
||||
(load "files")
|
||||
(garbage-collect)
|
||||
(load "indent")
|
||||
(load "window")
|
||||
(load "paths.el") ;Don't get confused if someone compiled paths by mistake.
|
||||
(garbage-collect)
|
||||
(load "startup")
|
||||
(load "lisp")
|
||||
(garbage-collect)
|
||||
(load "page")
|
||||
(load "register")
|
||||
(garbage-collect)
|
||||
(load "paragraphs")
|
||||
(load "lisp-mode")
|
||||
(garbage-collect)
|
||||
(load "text-mode")
|
||||
(load "fill")
|
||||
(garbage-collect)
|
||||
(load "c-mode")
|
||||
(garbage-collect)
|
||||
(load "isearch")
|
||||
(garbage-collect)
|
||||
(load "replace")
|
||||
(if (eq system-type 'vax-vms)
|
||||
(progn
|
||||
(garbage-collect)
|
||||
(load "vmsproc")))
|
||||
(garbage-collect)
|
||||
(load "abbrev")
|
||||
(garbage-collect)
|
||||
(load "buff-menu")
|
||||
(if (eq system-type 'vax-vms)
|
||||
(progn
|
||||
(garbage-collect)
|
||||
(load "vms-patch")))
|
||||
(if (fboundp 'atan) ; preload some constants and
|
||||
(progn ; floating pt. functions if
|
||||
(garbage-collect) ; we have float support.
|
||||
(load "float-sup")))
|
||||
|
||||
;If you want additional libraries to be preloaded and their
|
||||
;doc strings kept in the DOC file rather than in core,
|
||||
;you may load them with a "site-load.el" file.
|
||||
;But you must also cause them to be scanned when the DOC file
|
||||
;is generated. For VMS, you must edit ../etc/makedoc.com.
|
||||
;For other systems, you must edit ../src/ymakefile.
|
||||
(if (load "site-load" t)
|
||||
(garbage-collect))
|
||||
|
||||
(load "version.el") ;Don't get confused if someone compiled version.el by mistake.
|
||||
|
||||
;; Note: all compiled Lisp files loaded above this point
|
||||
;; must be among the ones parsed by make-docfile
|
||||
;; to construct DOC. Any that are not processed
|
||||
;; for DOC will not have doc strings in the dumped Emacs.
|
||||
|
||||
(message "Finding pointers to doc strings...")
|
||||
(if (fboundp 'dump-emacs)
|
||||
(let ((name emacs-version))
|
||||
(while (string-match "[^-+_.a-zA-Z0-9]+" name)
|
||||
(setq name (concat (downcase (substring name 0 (match-beginning 0)))
|
||||
"-"
|
||||
(substring name (match-end 0)))))
|
||||
(copy-file (expand-file-name "../etc/DOC")
|
||||
(concat (expand-file-name "../etc/DOC-") name)
|
||||
t)
|
||||
(Snarf-documentation (concat "DOC-" name)))
|
||||
(Snarf-documentation "DOC"))
|
||||
(message "Finding pointers to doc strings...done")
|
||||
|
||||
;Note: You can cause additional libraries to be preloaded
|
||||
;by writing a site-init.el that loads them.
|
||||
;See also "site-load" above.
|
||||
(load "site-init" t)
|
||||
(garbage-collect)
|
||||
|
||||
(if (or (equal (nth 3 command-line-args) "dump")
|
||||
(equal (nth 4 command-line-args) "dump"))
|
||||
(if (eq system-type 'vax-vms)
|
||||
(progn
|
||||
(message "Dumping data as file temacs.dump")
|
||||
(dump-emacs "temacs.dump" "temacs")
|
||||
(kill-emacs))
|
||||
(let ((name (concat "emacs-" emacs-version)))
|
||||
(while (string-match "[^-+_.a-zA-Z0-9]+" name)
|
||||
(setq name (concat (downcase (substring name 0 (match-beginning 0)))
|
||||
"-"
|
||||
(substring name (match-end 0)))))
|
||||
(message "Dumping under names xemacs and %s" name))
|
||||
(condition-case ()
|
||||
(delete-file "xemacs")
|
||||
(file-error nil))
|
||||
(dump-emacs "xemacs" "temacs")
|
||||
;; Recompute NAME now, so that it isn't set when we dump.
|
||||
(let ((name (concat "emacs-" emacs-version)))
|
||||
(while (string-match "[^-+_.a-zA-Z0-9]+" name)
|
||||
(setq name (concat (downcase (substring name 0 (match-beginning 0)))
|
||||
"-"
|
||||
(substring name (match-end 0)))))
|
||||
(add-name-to-file "xemacs" name t))
|
||||
(kill-emacs)))
|
||||
|
||||
;; Avoid error if user loads some more libraries now.
|
||||
(setq purify-flag nil)
|
||||
|
||||
;; For machines with CANNOT_DUMP defined in config.h,
|
||||
;; this file must be loaded each time Emacs is run.
|
||||
;; So run the startup code now.
|
||||
|
||||
(or (fboundp 'dump-emacs)
|
||||
(eval top-level))
|
||||
45
lisp/mail/rmailmsc.el
Normal file
45
lisp/mail/rmailmsc.el
Normal file
@ -0,0 +1,45 @@
|
||||
;; Copyright (C) 1985 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.
|
||||
|
||||
|
||||
(defun set-rmail-inbox-list (file-name)
|
||||
"Set the inbox list of the current RMAIL file to FILE-NAME.
|
||||
This may be a list of file names separated by commas.
|
||||
If FILE-NAME is empty, remove any inbox list."
|
||||
(interactive "sSet mailbox list to (comma-separated list of filenames): ")
|
||||
(save-excursion
|
||||
(let ((names (rmail-parse-file-inboxes))
|
||||
(standard-output nil))
|
||||
(if (or (not names)
|
||||
(y-or-n-p (concat "Replace "
|
||||
(mapconcat 'identity names ", ")
|
||||
"? ")))
|
||||
(let ((buffer-read-only nil))
|
||||
(widen)
|
||||
(goto-char (point-min))
|
||||
(search-forward "\n\^_")
|
||||
(re-search-backward "^Mail" nil t)
|
||||
(forward-line 0)
|
||||
(if (looking-at "Mail:")
|
||||
(delete-region (point)
|
||||
(progn (forward-line 1)
|
||||
(point))))
|
||||
(if (not (string= file-name ""))
|
||||
(insert "Mail: " file-name "\n"))))))
|
||||
(setq rmail-inbox-list (rmail-parse-file-inboxes))
|
||||
(rmail-show-message rmail-current-message))
|
||||
979
lisp/mail/rnews.el
Normal file
979
lisp/mail/rnews.el
Normal file
@ -0,0 +1,979 @@
|
||||
;;; USENET news reader for gnu emacs
|
||||
;; Copyright (C) 1985, 1986, 1987 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.
|
||||
|
||||
;; Created Sun Mar 10,1985 at 21:35:01 ads and sundar@hernes.ai.mit.edu
|
||||
;; Should do the point pdl stuff sometime
|
||||
;; finito except pdl.... Sat Mar 16,1985 at 06:43:44
|
||||
;; lets keep the summary stuff out until we get it working ..
|
||||
;; sundar@hermes.ai.mit.edu Wed Apr 10,1985 at 16:32:06
|
||||
;; hack slash maim. mly@prep.ai.mit.edu Thu 18 Apr, 1985 06:11:14
|
||||
;; modified to correct reentrance bug, to not bother with groups that
|
||||
;; received no new traffic since last read completely, to find out
|
||||
;; what traffic a group has available much more quickly when
|
||||
;; possible, to do some completing reads for group names - should
|
||||
;; be much faster...
|
||||
;; KING@KESTREL.arpa, Thu Mar 13 09:03:28 1986
|
||||
;; made news-{next,previous}-group skip groups with no new messages; and
|
||||
;; added checking for unsubscribed groups to news-add-news-group
|
||||
;; tower@prep.ai.mit.edu Jul 18 1986
|
||||
;; bound rmail-output to C-o; and changed header-field commands binding to
|
||||
;; agree with the new C-c C-f usage in sendmail
|
||||
;; tower@prep Sep 3 1986
|
||||
;; added news-rotate-buffer-body
|
||||
;; tower@prep Oct 17 1986
|
||||
;; made messages more user friendly, cleanuped news-inews
|
||||
;; move posting and mail code to new file rnewpost.el
|
||||
;; tower@prep Oct 29 1986
|
||||
;; added caesar-region, rename news-caesar-buffer-body, hacked accordingly
|
||||
;; tower@prep Nov 21 1986
|
||||
;; added (provide 'rnews) tower@prep 22 Apr 87
|
||||
(provide 'rnews)
|
||||
(require 'mail-utils)
|
||||
|
||||
(autoload 'rmail-output "rmailout"
|
||||
"Append this message to Unix mail file named FILE-NAME."
|
||||
t)
|
||||
|
||||
(autoload 'news-reply "rnewspost"
|
||||
"Compose and post a reply to the current article on USENET.
|
||||
While composing the reply, use \\[mail-yank-original] to yank the original
|
||||
message into it."
|
||||
t)
|
||||
|
||||
(autoload 'news-mail-other-window "rnewspost"
|
||||
"Send mail in another window.
|
||||
While composing the message, use \\[mail-yank-original] to yank the
|
||||
original message into it."
|
||||
t)
|
||||
|
||||
(autoload 'news-post-news "rnewspost"
|
||||
"Begin editing a new USENET news article to be posted."
|
||||
t)
|
||||
|
||||
(autoload 'news-mail-reply "rnewspost"
|
||||
"Mail a reply to the author of the current article.
|
||||
While composing the reply, use \\[mail-yank-original] to yank the original
|
||||
message into it."
|
||||
t)
|
||||
|
||||
(defvar news-group-hook-alist nil
|
||||
"Alist of (GROUP-REGEXP . HOOK) pairs.
|
||||
Just before displaying a message, each HOOK is called
|
||||
if its GROUP-REGEXP matches the current newsgroup name.")
|
||||
|
||||
(defvar rmail-last-file (expand-file-name "~/mbox.news"))
|
||||
|
||||
;Now in paths.el.
|
||||
;(defvar news-path "/usr/spool/news/"
|
||||
; "The root directory below which all news files are stored.")
|
||||
|
||||
(defvar news-startup-file "$HOME/.newsrc" "Contains ~/.newsrc")
|
||||
(defvar news-certification-file "$HOME/.news-dates" "Contains ~/.news-dates")
|
||||
|
||||
;; random headers that we decide to ignore.
|
||||
(defvar news-ignored-headers
|
||||
"^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:"
|
||||
"All random fields within the header of a message.")
|
||||
|
||||
(defvar news-mode-map nil)
|
||||
(defvar news-read-first-time-p t)
|
||||
;; Contains the (dotified) news groups of which you are a member.
|
||||
(defvar news-user-group-list nil)
|
||||
|
||||
(defvar news-current-news-group nil)
|
||||
(defvar news-current-group-begin nil)
|
||||
(defvar news-current-group-end nil)
|
||||
(defvar news-current-certifications nil
|
||||
"An assoc list of a group name and the time at which it is
|
||||
known that the group had no new traffic")
|
||||
(defvar news-current-certifiable nil
|
||||
"The time when the directory we are now working on was written")
|
||||
|
||||
(defvar news-message-filter nil
|
||||
"User specifiable filter function that will be called during
|
||||
formatting of the news file")
|
||||
|
||||
;(defvar news-mode-group-string "Starting-Up"
|
||||
; "Mode line group name info is held in this variable")
|
||||
(defvar news-list-of-files nil
|
||||
"Global variable in which we store the list of files
|
||||
associated with the current newsgroup")
|
||||
(defvar news-list-of-files-possibly-bogus nil
|
||||
"variable indicating we only are guessing at which files are available.
|
||||
Not currently used.")
|
||||
|
||||
;; association list in which we store lists of the form
|
||||
;; (pointified-group-name (first last old-last))
|
||||
(defvar news-group-article-assoc nil)
|
||||
|
||||
(defvar news-current-message-number 0 "Displayed Article Number")
|
||||
(defvar news-total-current-group 0 "Total no of messages in group")
|
||||
|
||||
(defvar news-unsubscribe-groups ())
|
||||
(defvar news-point-pdl () "List of visited news messages.")
|
||||
(defvar news-no-jumps-p t)
|
||||
(defvar news-buffer () "Buffer into which news files are read.")
|
||||
|
||||
(defmacro news-push (item ref)
|
||||
(list 'setq ref (list 'cons item ref)))
|
||||
|
||||
(defmacro news-cadr (x) (list 'car (list 'cdr x)))
|
||||
(defmacro news-cdar (x) (list 'cdr (list 'car x)))
|
||||
(defmacro news-caddr (x) (list 'car (list 'cdr (list 'cdr x))))
|
||||
(defmacro news-cadar (x) (list 'car (list 'cdr (list 'car x))))
|
||||
(defmacro news-caadr (x) (list 'car (list 'car (list 'cdr x))))
|
||||
(defmacro news-cdadr (x) (list 'cdr (list 'car (list 'cdr x))))
|
||||
|
||||
(defmacro news-wins (pfx index)
|
||||
(` (file-exists-p (concat (, pfx) "/" (int-to-string (, index))))))
|
||||
|
||||
(defvar news-max-plausible-gap 2
|
||||
"* In an rnews directory, the maximum possible gap size.
|
||||
A gap is a sequence of missing messages between two messages that exist.
|
||||
An empty file does not contribute to a gap -- it ends one.")
|
||||
|
||||
(defun news-find-first-and-last (prefix base)
|
||||
(and (news-wins prefix base)
|
||||
(cons (news-find-first-or-last prefix base -1)
|
||||
(news-find-first-or-last prefix base 1))))
|
||||
|
||||
(defmacro news-/ (a1 a2)
|
||||
;; a form of / that guarantees that (/ -1 2) = 0
|
||||
(if (zerop (/ -1 2))
|
||||
(` (/ (, a1) (, a2)))
|
||||
(` (if (< (, a1) 0)
|
||||
(- (/ (- (, a1)) (, a2)))
|
||||
(/ (, a1) (, a2))))))
|
||||
|
||||
(defun news-find-first-or-last (pfx base dirn)
|
||||
;; first use powers of two to find a plausible ceiling
|
||||
(let ((original-dir dirn))
|
||||
(while (news-wins pfx (+ base dirn))
|
||||
(setq dirn (* dirn 2)))
|
||||
(setq dirn (news-/ dirn 2))
|
||||
;; Then use a binary search to find the high water mark
|
||||
(let ((offset (news-/ dirn 2)))
|
||||
(while (/= offset 0)
|
||||
(if (news-wins pfx (+ base dirn offset))
|
||||
(setq dirn (+ dirn offset)))
|
||||
(setq offset (news-/ offset 2))))
|
||||
;; If this high-water mark is bogus, recurse.
|
||||
(let ((offset (* news-max-plausible-gap original-dir)))
|
||||
(while (and (/= offset 0) (not (news-wins pfx (+ base dirn offset))))
|
||||
(setq offset (- offset original-dir)))
|
||||
(if (= offset 0)
|
||||
(+ base dirn)
|
||||
(news-find-first-or-last pfx (+ base dirn offset) original-dir)))))
|
||||
|
||||
(defun rnews ()
|
||||
"Read USENET news for groups for which you are a member and add or
|
||||
delete groups.
|
||||
You can reply to articles posted and send articles to any group.
|
||||
|
||||
Type \\[describe-mode] once reading news to get a list of rnews commands."
|
||||
(interactive)
|
||||
(let ((last-buffer (buffer-name)))
|
||||
(make-local-variable 'rmail-last-file)
|
||||
(switch-to-buffer (setq news-buffer (get-buffer-create "*news*")))
|
||||
(news-mode)
|
||||
(setq news-buffer-save last-buffer)
|
||||
(setq buffer-read-only nil)
|
||||
(erase-buffer)
|
||||
(setq buffer-read-only t)
|
||||
(set-buffer-modified-p t)
|
||||
(sit-for 0)
|
||||
(message "Getting new USENET news...")
|
||||
(news-set-mode-line)
|
||||
(news-get-certifications)
|
||||
(news-get-new-news)))
|
||||
|
||||
(defun news-group-certification (group)
|
||||
(cdr-safe (assoc group news-current-certifications)))
|
||||
|
||||
|
||||
(defun news-set-current-certifiable ()
|
||||
;; Record the date that corresponds to the directory you are about to check
|
||||
(let ((file (concat news-path
|
||||
(string-subst-char ?/ ?. news-current-news-group))))
|
||||
(setq news-current-certifiable
|
||||
(nth 5 (file-attributes
|
||||
(or (file-symlink-p file) file))))))
|
||||
|
||||
(defun news-get-certifications ()
|
||||
;; Read the certified-read file from last session
|
||||
(save-excursion
|
||||
(save-window-excursion
|
||||
(setq news-current-certifications
|
||||
(car-safe
|
||||
(condition-case var
|
||||
(let*
|
||||
((file (substitute-in-file-name news-certification-file))
|
||||
(buf (find-file-noselect file)))
|
||||
(and (file-exists-p file)
|
||||
(progn
|
||||
(switch-to-buffer buf 'norecord)
|
||||
(unwind-protect
|
||||
(read-from-string (buffer-string))
|
||||
(kill-buffer buf)))))
|
||||
(error nil)))))))
|
||||
|
||||
(defun news-write-certifications ()
|
||||
;; Write a certification file.
|
||||
;; This is an assoc list of group names with doubletons that represent
|
||||
;; mod times of the directory when group is read completely.
|
||||
(save-excursion
|
||||
(save-window-excursion
|
||||
(with-output-to-temp-buffer
|
||||
"*CeRtIfIcAtIoNs*"
|
||||
(print news-current-certifications))
|
||||
(let ((buf (get-buffer "*CeRtIfIcAtIoNs*")))
|
||||
(switch-to-buffer buf)
|
||||
(write-file (substitute-in-file-name news-certification-file))
|
||||
(kill-buffer buf)))))
|
||||
|
||||
(defun news-set-current-group-certification ()
|
||||
(let ((cgc (assoc news-current-news-group news-current-certifications)))
|
||||
(if cgc (setcdr cgc news-current-certifiable)
|
||||
(news-push (cons news-current-news-group news-current-certifiable)
|
||||
news-current-certifications))))
|
||||
|
||||
(defun news-set-minor-modes ()
|
||||
"Creates a minor mode list that has group name, total articles,
|
||||
and attribute for current article."
|
||||
(setq news-minor-modes (list (cons 'foo
|
||||
(concat news-current-message-number
|
||||
"/"
|
||||
news-total-current-group
|
||||
(news-get-attribute-string)))))
|
||||
;; Detect Emacs versions 18.16 and up, which display
|
||||
;; directly from news-minor-modes by using a list for mode-name.
|
||||
(or (boundp 'minor-mode-alist)
|
||||
(setq minor-modes news-minor-modes)))
|
||||
|
||||
(defun news-set-message-counters ()
|
||||
"Scan through current news-groups filelist to figure out how many messages
|
||||
are there. Set counters for use with minor mode display."
|
||||
(if (null news-list-of-files)
|
||||
(setq news-current-message-number 0)))
|
||||
|
||||
(if news-mode-map
|
||||
nil
|
||||
(setq news-mode-map (make-keymap))
|
||||
(suppress-keymap news-mode-map)
|
||||
(define-key news-mode-map "." 'beginning-of-buffer)
|
||||
(define-key news-mode-map " " 'scroll-up)
|
||||
(define-key news-mode-map "\177" 'scroll-down)
|
||||
(define-key news-mode-map "n" 'news-next-message)
|
||||
(define-key news-mode-map "c" 'news-make-link-to-message)
|
||||
(define-key news-mode-map "p" 'news-previous-message)
|
||||
(define-key news-mode-map "j" 'news-goto-message)
|
||||
(define-key news-mode-map "q" 'news-exit)
|
||||
(define-key news-mode-map "e" 'news-exit)
|
||||
(define-key news-mode-map "\ej" 'news-goto-news-group)
|
||||
(define-key news-mode-map "\en" 'news-next-group)
|
||||
(define-key news-mode-map "\ep" 'news-previous-group)
|
||||
(define-key news-mode-map "l" 'news-list-news-groups)
|
||||
(define-key news-mode-map "?" 'describe-mode)
|
||||
(define-key news-mode-map "g" 'news-get-new-news)
|
||||
(define-key news-mode-map "f" 'news-reply)
|
||||
(define-key news-mode-map "m" 'news-mail-other-window)
|
||||
(define-key news-mode-map "a" 'news-post-news)
|
||||
(define-key news-mode-map "r" 'news-mail-reply)
|
||||
(define-key news-mode-map "o" 'news-save-item-in-file)
|
||||
(define-key news-mode-map "\C-o" 'rmail-output)
|
||||
(define-key news-mode-map "t" 'news-show-all-headers)
|
||||
(define-key news-mode-map "x" 'news-force-update)
|
||||
(define-key news-mode-map "A" 'news-add-news-group)
|
||||
(define-key news-mode-map "u" 'news-unsubscribe-current-group)
|
||||
(define-key news-mode-map "U" 'news-unsubscribe-group)
|
||||
(define-key news-mode-map "\C-c\C-r" 'news-caesar-buffer-body))
|
||||
|
||||
(defun news-mode ()
|
||||
"News Mode is used by M-x rnews for reading USENET Newsgroups articles.
|
||||
New readers can find additional help in newsgroup: news.announce.newusers .
|
||||
All normal editing commands are turned off.
|
||||
Instead, these commands are available:
|
||||
|
||||
. move point to front of this news article (same as Meta-<).
|
||||
Space scroll to next screen of this news article.
|
||||
Delete scroll down previous page of this news article.
|
||||
n move to next news article, possibly next group.
|
||||
p move to previous news article, possibly previous group.
|
||||
j jump to news article specified by numeric position.
|
||||
M-j jump to news group.
|
||||
M-n goto next news group.
|
||||
M-p goto previous news group.
|
||||
l list all the news groups with current status.
|
||||
? print this help message.
|
||||
C-c C-r caesar rotate all letters by 13 places in the article's body (rot13).
|
||||
g get new USENET news.
|
||||
f post a reply article to USENET.
|
||||
a post an original news article.
|
||||
A add a newsgroup.
|
||||
o save the current article in the named file (append if file exists).
|
||||
C-o output this message to a Unix-format mail file (append it).
|
||||
c \"copy\" (actually link) current or prefix-arg msg to file.
|
||||
warning: target directory and message file must be on same device
|
||||
(UNIX magic)
|
||||
t show all the headers this news article originally had.
|
||||
q quit reading news after updating .newsrc file.
|
||||
e exit updating .newsrc file.
|
||||
m mail a news article. Same as C-x 4 m.
|
||||
x update last message seen to be the current message.
|
||||
r mail a reply to this news article. Like m but initializes some fields.
|
||||
u unsubscribe from current newsgroup.
|
||||
U unsubscribe from specified newsgroup."
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(make-local-variable 'news-read-first-time-p)
|
||||
(setq news-read-first-time-p t)
|
||||
(make-local-variable 'news-current-news-group)
|
||||
; (setq news-current-news-group "??")
|
||||
(make-local-variable 'news-current-group-begin)
|
||||
(setq news-current-group-begin 0)
|
||||
(make-local-variable 'news-current-message-number)
|
||||
(setq news-current-message-number 0)
|
||||
(make-local-variable 'news-total-current-group)
|
||||
(make-local-variable 'news-buffer-save)
|
||||
(make-local-variable 'version-control)
|
||||
(setq version-control 'never)
|
||||
(make-local-variable 'news-point-pdl)
|
||||
; This breaks it. I don't have time to figure out why. -- RMS
|
||||
; (make-local-variable 'news-group-article-assoc)
|
||||
(setq major-mode 'news-mode)
|
||||
(if (boundp 'minor-mode-alist)
|
||||
;; Emacs versions 18.16 and up.
|
||||
(setq mode-name '("NEWS" news-minor-modes))
|
||||
;; Earlier versions display minor-modes via a special mechanism.
|
||||
(setq mode-name "NEWS"))
|
||||
(news-set-mode-line)
|
||||
(set-syntax-table text-mode-syntax-table)
|
||||
(use-local-map news-mode-map)
|
||||
(setq local-abbrev-table text-mode-abbrev-table)
|
||||
(run-hooks 'news-mode-hook))
|
||||
|
||||
(defun string-subst-char (new old string)
|
||||
(let (index)
|
||||
(setq old (regexp-quote (char-to-string old))
|
||||
string (substring string 0))
|
||||
(while (setq index (string-match old string))
|
||||
(aset string index new)))
|
||||
string)
|
||||
|
||||
;; update read message number
|
||||
(defmacro news-update-message-read (ngroup nno)
|
||||
(list 'setcar
|
||||
(list 'news-cdadr
|
||||
(list 'assoc ngroup 'news-group-article-assoc))
|
||||
nno))
|
||||
|
||||
(defun news-parse-range (number-string)
|
||||
"Parse string representing range of numbers of he form <a>-<b>
|
||||
to a list (a . b)"
|
||||
(let ((n (string-match "-" number-string)))
|
||||
(if n
|
||||
(cons (string-to-int (substring number-string 0 n))
|
||||
(string-to-int (substring number-string (1+ n))))
|
||||
(setq n (string-to-int number-string))
|
||||
(cons n n))))
|
||||
|
||||
;(defun is-in (elt lis)
|
||||
; (catch 'foo
|
||||
; (while lis
|
||||
; (if (equal (car lis) elt)
|
||||
; (throw 'foo t)
|
||||
; (setq lis (cdr lis))))))
|
||||
|
||||
(defun news-get-new-news ()
|
||||
"Get new USENET news, if there is any for the current user."
|
||||
(interactive)
|
||||
(if (not (null news-user-group-list))
|
||||
(news-update-newsrc-file))
|
||||
(setq news-group-article-assoc ())
|
||||
(setq news-user-group-list ())
|
||||
(message "Looking up %s file..." news-startup-file)
|
||||
(let ((file (substitute-in-file-name news-startup-file))
|
||||
(temp-user-groups ()))
|
||||
(save-excursion
|
||||
(let ((newsrcbuf (find-file-noselect file))
|
||||
start end endofline tem)
|
||||
(set-buffer newsrcbuf)
|
||||
(goto-char 0)
|
||||
(while (search-forward ": " nil t)
|
||||
(setq end (point))
|
||||
(beginning-of-line)
|
||||
(setq start (point))
|
||||
(end-of-line)
|
||||
(setq endofline (point))
|
||||
(setq tem (buffer-substring start (- end 2)))
|
||||
(let ((range (news-parse-range
|
||||
(buffer-substring end endofline))))
|
||||
(if (assoc tem news-group-article-assoc)
|
||||
(message "You are subscribed twice to %s; I ignore second"
|
||||
tem)
|
||||
(setq temp-user-groups (cons tem temp-user-groups)
|
||||
news-group-article-assoc
|
||||
(cons (list tem (list (car range)
|
||||
(cdr range)
|
||||
(cdr range)))
|
||||
news-group-article-assoc)))))
|
||||
(kill-buffer newsrcbuf)))
|
||||
(setq temp-user-groups (nreverse temp-user-groups))
|
||||
(message "Prefrobnicating...")
|
||||
(switch-to-buffer news-buffer)
|
||||
(setq news-user-group-list temp-user-groups)
|
||||
(while (and temp-user-groups
|
||||
(not (news-read-files-into-buffer
|
||||
(car temp-user-groups) nil)))
|
||||
(setq temp-user-groups (cdr temp-user-groups)))
|
||||
(if (null temp-user-groups)
|
||||
(message "No news is good news.")
|
||||
(message ""))))
|
||||
|
||||
(defun news-list-news-groups ()
|
||||
"Display all the news groups to which you belong."
|
||||
(interactive)
|
||||
(with-output-to-temp-buffer "*Newsgroups*"
|
||||
(save-excursion
|
||||
(set-buffer standard-output)
|
||||
(insert
|
||||
"News Group Msg No. News Group Msg No.\n")
|
||||
(insert
|
||||
"------------------------- -------------------------\n")
|
||||
(let ((temp news-user-group-list)
|
||||
(flag nil))
|
||||
(while temp
|
||||
(let ((item (assoc (car temp) news-group-article-assoc)))
|
||||
(insert (car item))
|
||||
(indent-to (if flag 52 20))
|
||||
(insert (int-to-string (news-cadr (news-cadr item))))
|
||||
(if flag
|
||||
(insert "\n")
|
||||
(indent-to 33))
|
||||
(setq temp (cdr temp) flag (not flag))))))))
|
||||
|
||||
;; Mode line hack
|
||||
(defun news-set-mode-line ()
|
||||
"Set mode line string to something useful."
|
||||
(setq mode-line-process
|
||||
(concat " "
|
||||
(if (integerp news-current-message-number)
|
||||
(int-to-string news-current-message-number)
|
||||
"??")
|
||||
"/"
|
||||
(if (integerp news-current-group-end)
|
||||
(int-to-string news-current-group-end)
|
||||
news-current-group-end)))
|
||||
(setq mode-line-buffer-identification
|
||||
(concat "NEWS: "
|
||||
news-current-news-group
|
||||
;; Enough spaces to pad group name to 17 positions.
|
||||
(substring " "
|
||||
0 (max 0 (- 17 (length news-current-news-group))))))
|
||||
(set-buffer-modified-p t)
|
||||
(sit-for 0))
|
||||
|
||||
(defun news-goto-news-group (gp)
|
||||
"Takes a string and goes to that news group."
|
||||
(interactive (list (completing-read "NewsGroup: "
|
||||
news-group-article-assoc)))
|
||||
(message "Jumping to news group %s..." gp)
|
||||
(news-select-news-group gp)
|
||||
(message "Jumping to news group %s... done." gp))
|
||||
|
||||
(defun news-select-news-group (gp)
|
||||
(let ((grp (assoc gp news-group-article-assoc)))
|
||||
(if (null grp)
|
||||
(error "Group %s not subscribed to" gp)
|
||||
(progn
|
||||
(news-update-message-read news-current-news-group
|
||||
(news-cdar news-point-pdl))
|
||||
(news-read-files-into-buffer (car grp) nil)
|
||||
(news-set-mode-line)))))
|
||||
|
||||
(defun news-goto-message (arg)
|
||||
"Goes to the article ARG in current newsgroup."
|
||||
(interactive "p")
|
||||
(if (null current-prefix-arg)
|
||||
(setq arg (read-no-blanks-input "Go to article: " "")))
|
||||
(news-select-message arg))
|
||||
|
||||
(defun news-select-message (arg)
|
||||
(if (stringp arg) (setq arg (string-to-int arg)))
|
||||
(let ((file (concat news-path
|
||||
(string-subst-char ?/ ?. news-current-news-group)
|
||||
"/" arg)))
|
||||
(if (file-exists-p file)
|
||||
(let ((buffer-read-only ()))
|
||||
(if (= arg
|
||||
(or (news-cadr (memq (news-cdar news-point-pdl) news-list-of-files))
|
||||
0))
|
||||
(setcdr (car news-point-pdl) arg))
|
||||
(setq news-current-message-number arg)
|
||||
(news-read-in-file file)
|
||||
(news-set-mode-line))
|
||||
(error "Article %d nonexistent" arg))))
|
||||
|
||||
(defun news-force-update ()
|
||||
"updates the position of last article read in the current news group"
|
||||
(interactive)
|
||||
(setcdr (car news-point-pdl) news-current-message-number)
|
||||
(message "Updated to %d" news-current-message-number))
|
||||
|
||||
(defun news-next-message (arg)
|
||||
"Move ARG messages forward within one newsgroup.
|
||||
Negative ARG moves backward.
|
||||
If ARG is 1 or -1, moves to next or previous newsgroup if at end."
|
||||
(interactive "p")
|
||||
(let ((no (+ arg news-current-message-number)))
|
||||
(if (or (< no news-current-group-begin)
|
||||
(> no news-current-group-end))
|
||||
(cond ((= arg 1)
|
||||
(news-set-current-group-certification)
|
||||
(news-next-group))
|
||||
((= arg -1)
|
||||
(news-previous-group))
|
||||
(t (error "Article out of range")))
|
||||
(let ((plist (news-get-motion-lists
|
||||
news-current-message-number
|
||||
news-list-of-files)))
|
||||
(if (< arg 0)
|
||||
(news-select-message (nth (1- (- arg)) (car (cdr plist))))
|
||||
(news-select-message (nth (1- arg) (car plist))))))))
|
||||
|
||||
(defun news-previous-message (arg)
|
||||
"Move ARG messages backward in current newsgroup.
|
||||
With no arg or arg of 1, move one message
|
||||
and move to previous newsgroup if at beginning.
|
||||
A negative ARG means move forward."
|
||||
(interactive "p")
|
||||
(news-next-message (- arg)))
|
||||
|
||||
(defun news-move-to-group (arg)
|
||||
"Given arg move forward or backward to a new newsgroup."
|
||||
(let ((cg news-current-news-group))
|
||||
(let ((plist (news-get-motion-lists cg news-user-group-list))
|
||||
ngrp)
|
||||
(if (< arg 0)
|
||||
(or (setq ngrp (nth (1- (- arg)) (news-cadr plist)))
|
||||
(error "No previous news groups"))
|
||||
(or (setq ngrp (nth arg (car plist)))
|
||||
(error "No more news groups")))
|
||||
(news-select-news-group ngrp))))
|
||||
|
||||
(defun news-next-group ()
|
||||
"Moves to the next user group."
|
||||
(interactive)
|
||||
; (message "Moving to next group...")
|
||||
(news-move-to-group 0)
|
||||
(while (null news-list-of-files)
|
||||
(news-move-to-group 0)))
|
||||
; (message "Moving to next group... done.")
|
||||
|
||||
(defun news-previous-group ()
|
||||
"Moves to the previous user group."
|
||||
(interactive)
|
||||
; (message "Moving to previous group...")
|
||||
(news-move-to-group -1)
|
||||
(while (null news-list-of-files)
|
||||
(news-move-to-group -1)))
|
||||
; (message "Moving to previous group... done.")
|
||||
|
||||
(defun news-get-motion-lists (arg listy)
|
||||
"Given a msgnumber/group this will return a list of two lists;
|
||||
one for moving forward and one for moving backward."
|
||||
(let ((temp listy)
|
||||
(result ()))
|
||||
(catch 'out
|
||||
(while temp
|
||||
(if (equal (car temp) arg)
|
||||
(throw 'out (cons (cdr temp) (list result)))
|
||||
(setq result (nconc (list (car temp)) result))
|
||||
(setq temp (cdr temp)))))))
|
||||
|
||||
;; miscellaneous io routines
|
||||
(defun news-read-in-file (filename)
|
||||
(erase-buffer)
|
||||
(let ((start (point)))
|
||||
(insert-file-contents filename)
|
||||
(news-convert-format)
|
||||
;; Run each hook that applies to the current newsgroup.
|
||||
(let ((hooks news-group-hook-alist))
|
||||
(while hooks
|
||||
(goto-char start)
|
||||
(if (string-match (car (car hooks)) news-group-name)
|
||||
(funcall (cdr (car hooks))))
|
||||
(setq hooks (cdr hooks))))
|
||||
(goto-char start)
|
||||
(forward-line 1)
|
||||
(if (eobp)
|
||||
(message "(Empty file?)")
|
||||
(goto-char start))))
|
||||
|
||||
(defun news-convert-format ()
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(let* ((start (point))
|
||||
(end (condition-case ()
|
||||
(progn (search-forward "\n\n") (point))
|
||||
(error nil)))
|
||||
has-from has-date)
|
||||
(cond (end
|
||||
(narrow-to-region start end)
|
||||
(goto-char start)
|
||||
(setq has-from (search-forward "\nFrom:" nil t))
|
||||
(cond ((and (not has-from) has-date)
|
||||
(goto-char start)
|
||||
(search-forward "\nDate:")
|
||||
(beginning-of-line)
|
||||
(kill-line) (kill-line)))
|
||||
(news-delete-headers start)
|
||||
(goto-char start)))))))
|
||||
|
||||
(defun news-show-all-headers ()
|
||||
"Redisplay current news item with all original headers"
|
||||
(interactive)
|
||||
(let (news-ignored-headers
|
||||
(buffer-read-only ()))
|
||||
(erase-buffer)
|
||||
(news-set-mode-line)
|
||||
(news-read-in-file
|
||||
(concat news-path
|
||||
(string-subst-char ?/ ?. news-current-news-group)
|
||||
"/" (int-to-string news-current-message-number)))))
|
||||
|
||||
(defun news-delete-headers (pos)
|
||||
(goto-char pos)
|
||||
(and (stringp news-ignored-headers)
|
||||
(while (re-search-forward news-ignored-headers nil t)
|
||||
(beginning-of-line)
|
||||
(delete-region (point)
|
||||
(progn (re-search-forward "\n[^ \t]")
|
||||
(forward-char -1)
|
||||
(point))))))
|
||||
|
||||
(defun news-exit ()
|
||||
"Quit news reading session and update the .newsrc file."
|
||||
(interactive)
|
||||
(if (y-or-n-p "Do you really wanna quit reading news ? ")
|
||||
(progn (message "Updating %s..." news-startup-file)
|
||||
(news-update-newsrc-file)
|
||||
(news-write-certifications)
|
||||
(message "Updating %s... done" news-startup-file)
|
||||
(message "Now do some real work")
|
||||
(and (fboundp 'bury-buffer) (bury-buffer (current-buffer)))
|
||||
(switch-to-buffer news-buffer-save)
|
||||
(setq news-user-group-list ()))
|
||||
(message "")))
|
||||
|
||||
(defun news-update-newsrc-file ()
|
||||
"Updates the .newsrc file in the users home dir."
|
||||
(let ((newsrcbuf (find-file-noselect
|
||||
(substitute-in-file-name news-startup-file)))
|
||||
(tem news-user-group-list)
|
||||
group)
|
||||
(save-excursion
|
||||
(if (not (null news-current-news-group))
|
||||
(news-update-message-read news-current-news-group
|
||||
(news-cdar news-point-pdl)))
|
||||
(set-buffer newsrcbuf)
|
||||
(while tem
|
||||
(setq group (assoc (car tem) news-group-article-assoc))
|
||||
(if (= (news-cadr (news-cadr group)) (news-caddr (news-cadr group)))
|
||||
nil
|
||||
(goto-char 0)
|
||||
(if (search-forward (concat (car group) ": ") nil t)
|
||||
(kill-line nil)
|
||||
(insert (car group) ": \n") (backward-char 1))
|
||||
(insert (int-to-string (car (news-cadr group))) "-"
|
||||
(int-to-string (news-cadr (news-cadr group)))))
|
||||
(setq tem (cdr tem)))
|
||||
(while news-unsubscribe-groups
|
||||
(setq group (assoc (car news-unsubscribe-groups)
|
||||
news-group-article-assoc))
|
||||
(goto-char 0)
|
||||
(if (search-forward (concat (car group) ": ") nil t)
|
||||
(progn
|
||||
(backward-char 2)
|
||||
(kill-line nil)
|
||||
(insert "! " (int-to-string (car (news-cadr group)))
|
||||
"-" (int-to-string (news-cadr (news-cadr group))))))
|
||||
(setq news-unsubscribe-groups (cdr news-unsubscribe-groups)))
|
||||
(save-buffer)
|
||||
(kill-buffer (current-buffer)))))
|
||||
|
||||
|
||||
(defun news-unsubscribe-group (group)
|
||||
"Removes you from newgroup GROUP."
|
||||
(interactive (list (completing-read "Unsubscribe from group: "
|
||||
news-group-article-assoc)))
|
||||
(news-unsubscribe-internal group))
|
||||
|
||||
(defun news-unsubscribe-current-group ()
|
||||
"Removes you from the newsgroup you are now reading."
|
||||
(interactive)
|
||||
(if (y-or-n-p "Do you really want to unsubscribe from this group ? ")
|
||||
(news-unsubscribe-internal news-current-news-group)))
|
||||
|
||||
(defun news-unsubscribe-internal (group)
|
||||
(let ((tem (assoc group news-group-article-assoc)))
|
||||
(if tem
|
||||
(progn
|
||||
(setq news-unsubscribe-groups (cons group news-unsubscribe-groups))
|
||||
(news-update-message-read group (news-cdar news-point-pdl))
|
||||
(if (equal group news-current-news-group)
|
||||
(news-next-group))
|
||||
(message ""))
|
||||
(error "Not subscribed to group: %s" group))))
|
||||
|
||||
(defun news-save-item-in-file (file)
|
||||
"Save the current article that is being read by appending to a file."
|
||||
(interactive "FSave item in file: ")
|
||||
(append-to-file (point-min) (point-max) file))
|
||||
|
||||
(defun news-get-pruned-list-of-files (gp-list end-file-no)
|
||||
"Given a news group it finds all files in the news group.
|
||||
The arg must be in slashified format.
|
||||
Using ls was found to be too slow in a previous version."
|
||||
(let
|
||||
((answer
|
||||
(and
|
||||
(not (and end-file-no
|
||||
(equal (news-set-current-certifiable)
|
||||
(news-group-certification gp-list))
|
||||
(setq news-list-of-files nil
|
||||
news-list-of-files-possibly-bogus t)))
|
||||
(let* ((file-directory (concat news-path
|
||||
(string-subst-char ?/ ?. gp-list)))
|
||||
tem
|
||||
(last-winner
|
||||
(and end-file-no
|
||||
(news-wins file-directory end-file-no)
|
||||
(news-find-first-or-last file-directory end-file-no 1))))
|
||||
(setq news-list-of-files-possibly-bogus t news-list-of-files nil)
|
||||
(if last-winner
|
||||
(progn
|
||||
(setq news-list-of-files-possibly-bogus t
|
||||
news-current-group-end last-winner)
|
||||
(while (> last-winner end-file-no)
|
||||
(news-push last-winner news-list-of-files)
|
||||
(setq last-winner (1- last-winner)))
|
||||
news-list-of-files)
|
||||
(if (or (not (file-directory-p file-directory))
|
||||
(not (file-readable-p file-directory)))
|
||||
nil
|
||||
(setq news-list-of-files
|
||||
(condition-case error
|
||||
(directory-files file-directory)
|
||||
(file-error
|
||||
(if (string= (nth 2 error) "permission denied")
|
||||
(message "Newsgroup %s is read-protected"
|
||||
gp-list)
|
||||
(signal 'file-error (cdr error)))
|
||||
nil)))
|
||||
(setq tem news-list-of-files)
|
||||
(while tem
|
||||
(if (or (not (string-match "^[0-9]*$" (car tem)))
|
||||
;; dont get confused by directories that look like numbers
|
||||
(file-directory-p
|
||||
(concat file-directory "/" (car tem)))
|
||||
(<= (string-to-int (car tem)) end-file-no))
|
||||
(setq news-list-of-files
|
||||
(delq (car tem) news-list-of-files)))
|
||||
(setq tem (cdr tem)))
|
||||
(if (null news-list-of-files)
|
||||
(progn (setq news-current-group-end 0)
|
||||
nil)
|
||||
(setq news-list-of-files
|
||||
(mapcar 'string-to-int news-list-of-files))
|
||||
(setq news-list-of-files (sort news-list-of-files '<))
|
||||
(setq news-current-group-end
|
||||
(elt news-list-of-files
|
||||
(1- (length news-list-of-files))))
|
||||
news-list-of-files)))))))
|
||||
(or answer (progn (news-set-current-group-certification) nil))))
|
||||
|
||||
(defun news-read-files-into-buffer (group reversep)
|
||||
(let* ((files-start-end (news-cadr (assoc group news-group-article-assoc)))
|
||||
(start-file-no (car files-start-end))
|
||||
(end-file-no (news-cadr files-start-end))
|
||||
(buffer-read-only nil))
|
||||
(setq news-current-news-group group)
|
||||
(setq news-current-message-number nil)
|
||||
(setq news-current-group-end nil)
|
||||
(news-set-mode-line)
|
||||
(news-get-pruned-list-of-files group end-file-no)
|
||||
(news-set-mode-line)
|
||||
;; @@ should be a lot smarter than this if we have to move
|
||||
;; @@ around correctly.
|
||||
(setq news-point-pdl (list (cons (car files-start-end)
|
||||
(news-cadr files-start-end))))
|
||||
(if (null news-list-of-files)
|
||||
(progn (erase-buffer)
|
||||
(setq news-current-group-end end-file-no)
|
||||
(setq news-current-group-begin end-file-no)
|
||||
(setq news-current-message-number end-file-no)
|
||||
(news-set-mode-line)
|
||||
; (message "No new articles in " group " group.")
|
||||
nil)
|
||||
(setq news-current-group-begin (car news-list-of-files))
|
||||
(if reversep
|
||||
(setq news-current-message-number news-current-group-end)
|
||||
(if (> (car news-list-of-files) end-file-no)
|
||||
(setcdr (car news-point-pdl) (car news-list-of-files)))
|
||||
(setq news-current-message-number news-current-group-begin))
|
||||
(news-set-message-counters)
|
||||
(news-set-mode-line)
|
||||
(news-read-in-file (concat news-path
|
||||
(string-subst-char ?/ ?. group)
|
||||
"/"
|
||||
(int-to-string
|
||||
news-current-message-number)))
|
||||
(news-set-message-counters)
|
||||
(news-set-mode-line)
|
||||
t)))
|
||||
|
||||
(defun news-add-news-group (gp)
|
||||
"Resubscribe to or add a USENET news group named GROUP (a string)."
|
||||
; @@ (completing-read ...)
|
||||
; @@ could be based on news library file ../active (slightly facist)
|
||||
; @@ or (expensive to compute) all directories under the news spool directory
|
||||
(interactive "sAdd news group: ")
|
||||
(let ((file-dir (concat news-path (string-subst-char ?/ ?. gp))))
|
||||
(save-excursion
|
||||
(if (null (assoc gp news-group-article-assoc))
|
||||
(let ((newsrcbuf (find-file-noselect
|
||||
(substitute-in-file-name news-startup-file))))
|
||||
(if (file-directory-p file-dir)
|
||||
(progn
|
||||
(switch-to-buffer newsrcbuf)
|
||||
(goto-char 0)
|
||||
(if (search-forward (concat gp "! ") nil t)
|
||||
(progn
|
||||
(message "Re-subscribing to group %s." gp)
|
||||
;;@@ news-unsubscribe-groups isn't being used
|
||||
;;(setq news-unsubscribe-groups
|
||||
;; (delq gp news-unsubscribe-groups))
|
||||
(backward-char 2)
|
||||
(delete-char 1)
|
||||
(insert ":"))
|
||||
(progn
|
||||
(message
|
||||
"Added %s to your list of newsgroups." gp)
|
||||
(end-of-buffer)
|
||||
(insert gp ": 1-1\n")))
|
||||
(search-backward gp nil t)
|
||||
(let (start end endofline tem)
|
||||
(search-forward ": " nil t)
|
||||
(setq end (point))
|
||||
(beginning-of-line)
|
||||
(setq start (point))
|
||||
(end-of-line)
|
||||
(setq endofline (point))
|
||||
(setq tem (buffer-substring start (- end 2)))
|
||||
(let ((range (news-parse-range
|
||||
(buffer-substring end endofline))))
|
||||
(setq news-group-article-assoc
|
||||
(cons (list tem (list (car range)
|
||||
(cdr range)
|
||||
(cdr range)))
|
||||
news-group-article-assoc))))
|
||||
(save-buffer)
|
||||
(kill-buffer (current-buffer)))
|
||||
(message "Newsgroup %s doesn't exist." gp)))
|
||||
(message "Already subscribed to group %s." gp)))))
|
||||
|
||||
(defun news-make-link-to-message (number newname)
|
||||
"Forges a link to an rnews message numbered number (current if no arg)
|
||||
Good for hanging on to a message that might or might not be
|
||||
automatically deleted."
|
||||
(interactive "P
|
||||
FName to link to message: ")
|
||||
(add-name-to-file
|
||||
(concat news-path
|
||||
(string-subst-char ?/ ?. news-current-news-group)
|
||||
"/" (if number
|
||||
(prefix-numeric-value number)
|
||||
news-current-message-number))
|
||||
newname))
|
||||
|
||||
;;; caesar-region written by phr@prep.ai.mit.edu Nov 86
|
||||
;;; modified by tower@prep Nov 86
|
||||
(defun caesar-region (&optional n)
|
||||
"Caesar rotation of region by N, default 13, for decrypting netnews."
|
||||
(interactive (if current-prefix-arg ; Was there a prefix arg?
|
||||
(list (prefix-numeric-value current-prefix-arg))
|
||||
(list nil)))
|
||||
(cond ((not (numberp n)) (setq n 13))
|
||||
((< n 0) (setq n (- 26 (% (- n) 26))))
|
||||
(t (setq n (% n 26)))) ;canonicalize N
|
||||
(if (not (zerop n)) ; no action needed for a rot of 0
|
||||
(progn
|
||||
(if (or (not (boundp 'caesar-translate-table))
|
||||
(/= (aref caesar-translate-table ?a) (+ ?a n)))
|
||||
(let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper)
|
||||
(message "Building caesar-translate-table...")
|
||||
(setq caesar-translate-table (make-vector 256 0))
|
||||
(while (< i 256)
|
||||
(aset caesar-translate-table i i)
|
||||
(setq i (1+ i)))
|
||||
(setq lower (concat lower lower) upper (upcase lower) i 0)
|
||||
(while (< i 26)
|
||||
(aset caesar-translate-table (+ ?a i) (aref lower (+ i n)))
|
||||
(aset caesar-translate-table (+ ?A i) (aref upper (+ i n)))
|
||||
(setq i (1+ i)))
|
||||
(message "Building caesar-translate-table... done")))
|
||||
(let ((from (region-beginning))
|
||||
(to (region-end))
|
||||
(i 0) str len)
|
||||
(setq str (buffer-substring from to))
|
||||
(setq len (length str))
|
||||
(while (< i len)
|
||||
(aset str i (aref caesar-translate-table (aref str i)))
|
||||
(setq i (1+ i)))
|
||||
(goto-char from)
|
||||
(kill-region from to)
|
||||
(insert str)))))
|
||||
|
||||
;;; news-caesar-buffer-body written by paul@media-lab.mit.edu Wed Oct 1, 1986
|
||||
;;; hacked further by tower@prep.ai.mit.edu
|
||||
(defun news-caesar-buffer-body (&optional rotnum)
|
||||
"Caesar rotates all letters in the current buffer by 13 places.
|
||||
Used to encode/decode possibly offensive messages (commonly in net.jokes).
|
||||
With prefix arg, specifies the number of places to rotate each letter forward.
|
||||
Mail and USENET news headers are not rotated."
|
||||
(interactive (if current-prefix-arg ; Was there a prefix arg?
|
||||
(list (prefix-numeric-value current-prefix-arg))
|
||||
(list nil)))
|
||||
(save-excursion
|
||||
(let ((buffer-status buffer-read-only))
|
||||
(setq buffer-read-only nil)
|
||||
;; setup the region
|
||||
(set-mark (if (progn (goto-char (point-min))
|
||||
(search-forward
|
||||
(concat "\n"
|
||||
(if (equal major-mode 'news-mode)
|
||||
""
|
||||
mail-header-separator)
|
||||
"\n") nil t))
|
||||
(point)
|
||||
(point-min)))
|
||||
(goto-char (point-max))
|
||||
(caesar-region rotnum)
|
||||
(setq buffer-read-only buffer-status))))
|
||||
390
lisp/mail/rnewspost.el
Normal file
390
lisp/mail/rnewspost.el
Normal file
@ -0,0 +1,390 @@
|
||||
;;; USENET news poster/mailer for GNU Emacs
|
||||
;; Copyright (C) 1985, 1986, 1987 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.
|
||||
|
||||
;; moved posting and mail code from rnews.el
|
||||
;; tower@prep.ai.mit.edu Wed Oct 29 1986
|
||||
;; brought posting code almost up to the revision of RFC 850 for News 2.11
|
||||
;; - couldn't see handling the special meaning of the Keyword: poster
|
||||
;; - not worth the code space to support the old A news Title: (which
|
||||
;; Subject: replaced) and Article-I.D.: (which Message-ID: replaced)
|
||||
;; tower@prep Nov 86
|
||||
;; changed C-c C-r key-binding due to rename of news-caesar-buffer-body
|
||||
;; tower@prep 21 Nov 86
|
||||
;; added (require 'rnews) tower@prep 22 Apr 87
|
||||
;; restricted call of news-show-all-headers in news-post-news & news-reply
|
||||
;; tower@prep 28 Apr 87
|
||||
;; commented out Posting-Front-End to save USENET bytes tower@prep Jul 31 87
|
||||
;; commented out -n and -t args in news-inews tower@prep 15 Oct 87
|
||||
(require 'sendmail)
|
||||
(require 'rnews)
|
||||
|
||||
;Now in paths.el.
|
||||
;(defvar news-inews-program "inews"
|
||||
; "Function to post news.")
|
||||
|
||||
;; Replying and posting news items are done by these functions.
|
||||
;; imported from rmail and modified to work with rnews ...
|
||||
;; Mon Mar 25,1985 at 03:07:04 ads@mit-hermes.
|
||||
;; this is done so that rnews can operate independently from rmail.el and
|
||||
;; sendmail and dosen't have to autoload these functions.
|
||||
;;
|
||||
;;; >> Nuked by Mly to autoload those functions again, as the duplication of
|
||||
;;; >> code was making maintenance too difficult.
|
||||
|
||||
(defvar news-reply-mode-map () "Mode map used by news-reply.")
|
||||
|
||||
(or news-reply-mode-map
|
||||
(progn
|
||||
(setq news-reply-mode-map (make-keymap))
|
||||
(define-key news-reply-mode-map "\C-c?" 'describe-mode)
|
||||
(define-key news-reply-mode-map "\C-c\C-f\C-d" 'news-reply-distribution)
|
||||
(define-key news-reply-mode-map "\C-c\C-f\C-k" 'news-reply-keywords)
|
||||
(define-key news-reply-mode-map "\C-c\C-f\C-n" 'news-reply-newsgroups)
|
||||
(define-key news-reply-mode-map "\C-c\C-f\C-f" 'news-reply-followup-to)
|
||||
(define-key news-reply-mode-map "\C-c\C-f\C-s" 'mail-subject)
|
||||
(define-key news-reply-mode-map "\C-c\C-f\C-a" 'news-reply-summary)
|
||||
(define-key news-reply-mode-map "\C-c\C-r" 'news-caesar-buffer-body)
|
||||
(define-key news-reply-mode-map "\C-c\C-w" 'news-reply-signature)
|
||||
(define-key news-reply-mode-map "\C-c\C-y" 'news-reply-yank-original)
|
||||
(define-key news-reply-mode-map "\C-c\C-q" 'mail-fill-yanked-message)
|
||||
(define-key news-reply-mode-map "\C-c\C-c" 'news-inews)
|
||||
(define-key news-reply-mode-map "\C-c\C-s" 'news-inews)))
|
||||
|
||||
(defun news-reply-mode ()
|
||||
"Major mode for editing news to be posted on USENET.
|
||||
First-time posters are asked to please read the articles in newsgroup:
|
||||
news.announce.newusers .
|
||||
Like Text Mode but with these additional commands:
|
||||
|
||||
C-c C-s news-inews (post the message) C-c C-c news-inews
|
||||
C-c C-f move to a header field (and create it if there isn't):
|
||||
C-c C-f C-n move to Newsgroups: C-c C-f C-s move to Subj:
|
||||
C-c C-f C-f move to Followup-To: C-c C-f C-k move to Keywords:
|
||||
C-c C-f C-d move to Distribution: C-c C-f C-a move to Summary:
|
||||
C-c C-y news-reply-yank-original (insert current message, in NEWS).
|
||||
C-c C-q mail-fill-yanked-message (fill what was yanked).
|
||||
C-c C-r caesar rotate all letters by 13 places in the article's body (rot13)."
|
||||
(interactive)
|
||||
;; require...
|
||||
(or (fboundp 'mail-setup) (load "sendmail"))
|
||||
(kill-all-local-variables)
|
||||
(make-local-variable 'mail-reply-buffer)
|
||||
(setq mail-reply-buffer nil)
|
||||
(set-syntax-table text-mode-syntax-table)
|
||||
(use-local-map news-reply-mode-map)
|
||||
(setq local-abbrev-table text-mode-abbrev-table)
|
||||
(setq major-mode 'news-reply-mode)
|
||||
(setq mode-name "News")
|
||||
(make-local-variable 'paragraph-separate)
|
||||
(make-local-variable 'paragraph-start)
|
||||
(setq paragraph-start (concat "^" mail-header-separator "$\\|"
|
||||
paragraph-start))
|
||||
(setq paragraph-separate (concat "^" mail-header-separator "$\\|"
|
||||
paragraph-separate))
|
||||
(run-hooks 'text-mode-hook 'news-reply-mode-hook))
|
||||
|
||||
(defvar news-reply-yank-from
|
||||
"Save From: field for news-reply-yank-original."
|
||||
"")
|
||||
|
||||
(defvar news-reply-yank-message-id
|
||||
"Save Message-Id: field for news-reply-yank-original."
|
||||
"")
|
||||
|
||||
(defun news-reply-yank-original (arg)
|
||||
"Insert the message being replied to, if any (in rmail).
|
||||
Puts point before the text and mark after.
|
||||
Indents each nonblank line ARG spaces (default 3).
|
||||
Just \\[universal-argument] as argument means don't indent
|
||||
and don't delete any header fields."
|
||||
(interactive "P")
|
||||
(mail-yank-original arg)
|
||||
(exchange-point-and-mark)
|
||||
(run-hooks 'news-reply-header-hook))
|
||||
|
||||
(defvar news-reply-header-hook
|
||||
'(lambda ()
|
||||
(insert "In article " news-reply-yank-message-id
|
||||
" " news-reply-yank-from " writes:\n\n"))
|
||||
"Hook for inserting a header at the top of a yanked message.")
|
||||
|
||||
(defun news-reply-newsgroups ()
|
||||
"Move point to end of Newsgroups: field.
|
||||
RFC 850 constrains the Newsgroups: field to be a comma separated list of valid
|
||||
newsgroups names at your site:
|
||||
Newsgroups: news.misc,comp.misc,rec.misc"
|
||||
(interactive)
|
||||
(expand-abbrev)
|
||||
(goto-char (point-min))
|
||||
(mail-position-on-field "Newsgroups"))
|
||||
|
||||
(defun news-reply-followup-to ()
|
||||
"Move point to end of Followup-To: field. Create the field if none.
|
||||
One usually requests followups to only one newsgroup.
|
||||
RFC 850 constrains the Followup-To: field to be a comma separated list of valid
|
||||
newsgroups names at your site, that are also in the Newsgroups: field:
|
||||
Newsgroups: news.misc,comp.misc,rec.misc,misc.misc,soc.misc
|
||||
Followup-To: news.misc,comp.misc,rec.misc"
|
||||
(interactive)
|
||||
(expand-abbrev)
|
||||
(or (mail-position-on-field "Followup-To" t)
|
||||
(progn (mail-position-on-field "newsgroups")
|
||||
(insert "\nFollowup-To: ")))
|
||||
;; @@ could do a completing read based on the Newsgroups: field to
|
||||
;; @@ fill in the Followup-To: field
|
||||
)
|
||||
|
||||
(defun news-reply-distribution ()
|
||||
"Move point to end of Distribution: optional field.
|
||||
Create the field if none. Without this field the posting goes to all of
|
||||
USENET. The field is used to restrict the posting to parts of USENET."
|
||||
(interactive)
|
||||
(expand-abbrev)
|
||||
(mail-position-on-field "Distribution")
|
||||
;; @@could do a completing read based on the news library file:
|
||||
;; @@ ../distributions to fill in the field.
|
||||
)
|
||||
|
||||
(defun news-reply-keywords ()
|
||||
"Move point to end of Keywords: optional field. Create the field if none.
|
||||
Used as an aid to the news reader, it can contain a few, well selected keywords
|
||||
identifying the message."
|
||||
(interactive)
|
||||
(expand-abbrev)
|
||||
(mail-position-on-field "Keywords"))
|
||||
|
||||
(defun news-reply-summary ()
|
||||
"Move point to end of Summary: optional field. Create the field if none.
|
||||
Used as an aid to the news reader, it can contain a succinct
|
||||
summary (abstract) of the message."
|
||||
(interactive)
|
||||
(expand-abbrev)
|
||||
(mail-position-on-field "Summary"))
|
||||
|
||||
(defun news-reply-signature ()
|
||||
"The inews program appends ~/.signature automatically."
|
||||
(interactive)
|
||||
(message "~/.signature will be appended automatically."))
|
||||
|
||||
(defun news-setup (to subject in-reply-to newsgroups replybuffer)
|
||||
"Setup the news reply or posting buffer with the proper headers and in
|
||||
news-reply-mode."
|
||||
(setq mail-reply-buffer replybuffer)
|
||||
(let ((mail-setup-hook nil))
|
||||
(if (null to)
|
||||
;; this hack is needed so that inews wont be confused by
|
||||
;; the fcc: and bcc: fields
|
||||
(let ((mail-self-blind nil)
|
||||
(mail-archive-file-name nil))
|
||||
(mail-setup to subject in-reply-to nil replybuffer nil)
|
||||
(beginning-of-line)
|
||||
(kill-line 1)
|
||||
(goto-char (point-max)))
|
||||
(mail-setup to subject in-reply-to nil replybuffer nil))
|
||||
;;;(mail-position-on-field "Posting-Front-End")
|
||||
;;;(insert (emacs-version))
|
||||
(goto-char (point-max))
|
||||
(if (let ((case-fold-search t))
|
||||
(re-search-backward "^Subject:" (point-min) t))
|
||||
(progn (beginning-of-line)
|
||||
(insert "Newsgroups: " (or newsgroups "") "\n")
|
||||
(if (not newsgroups)
|
||||
(backward-char 1)
|
||||
(goto-char (point-max)))))
|
||||
(run-hooks 'news-setup-hook)))
|
||||
|
||||
(defun news-inews ()
|
||||
"Send a news message using inews."
|
||||
(interactive)
|
||||
(let* (newsgroups subject
|
||||
(case-fold-search nil))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(goto-char (point-min))
|
||||
(search-forward (concat "\n" mail-header-separator "\n"))
|
||||
(narrow-to-region (point-min) (point))
|
||||
(setq newsgroups (mail-fetch-field "newsgroups")
|
||||
subject (mail-fetch-field "subject")))
|
||||
(widen)
|
||||
(goto-char (point-min))
|
||||
(run-hooks 'news-inews-hook)
|
||||
(goto-char (point-min))
|
||||
(search-forward (concat "\n" mail-header-separator "\n"))
|
||||
(replace-match "\n\n")
|
||||
(goto-char (point-max))
|
||||
;; require a newline at the end for inews to append .signature to
|
||||
(or (= (preceding-char) ?\n)
|
||||
(insert ?\n))
|
||||
(message "Posting to USENET...")
|
||||
(call-process-region (point-min) (point-max)
|
||||
news-inews-program nil 0 nil
|
||||
"-h") ; take all header lines!
|
||||
;@@ setting of subject and newsgroups still needed?
|
||||
;"-t" subject
|
||||
;"-n" newsgroups
|
||||
(message "Posting to USENET... done")
|
||||
(goto-char (point-min)) ;restore internal header separator
|
||||
(search-forward "\n\n")
|
||||
(replace-match (concat "\n" mail-header-separator "\n"))
|
||||
(set-buffer-modified-p nil))
|
||||
(and (fboundp 'bury-buffer) (bury-buffer))))
|
||||
|
||||
;@@ shares some code with news-reply and news-post-news
|
||||
(defun news-mail-reply ()
|
||||
"Mail a reply to the author of the current article.
|
||||
While composing the reply, use \\[news-reply-yank-original] to yank the
|
||||
original message into it."
|
||||
(interactive)
|
||||
(let (from cc subject date to reply-to
|
||||
(buffer (current-buffer)))
|
||||
(save-restriction
|
||||
(narrow-to-region (point-min) (progn (goto-line (point-min))
|
||||
(search-forward "\n\n")
|
||||
(- (point) 1)))
|
||||
(setq from (mail-fetch-field "from")
|
||||
subject (mail-fetch-field "subject")
|
||||
reply-to (mail-fetch-field "reply-to")
|
||||
date (mail-fetch-field "date"))
|
||||
(setq to from)
|
||||
(pop-to-buffer "*mail*")
|
||||
(mail nil
|
||||
(if reply-to reply-to to)
|
||||
subject
|
||||
(let ((stop-pos (string-match " *at \\| *@ \\| *(\\| *<" from)))
|
||||
(concat (if stop-pos (substring from 0 stop-pos) from)
|
||||
"'s message of "
|
||||
date))
|
||||
nil
|
||||
buffer))))
|
||||
|
||||
;@@ the guts of news-reply and news-post-news should be combined. -tower
|
||||
(defun news-reply ()
|
||||
"Compose and post a reply (aka a followup) to the current article on USENET.
|
||||
While composing the followup, use \\[news-reply-yank-original] to yank the
|
||||
original message into it."
|
||||
(interactive)
|
||||
(if (y-or-n-p "Are you sure you want to followup to all of USENET? ")
|
||||
(let (from cc subject date to followup-to newsgroups message-of
|
||||
references distribution message-id
|
||||
(buffer (current-buffer)))
|
||||
(save-restriction
|
||||
(and (not (= 0 (buffer-size))) ;@@real problem is non-existence of
|
||||
;@@ of article file
|
||||
(equal major-mode 'news-mode) ;@@ if rmail-mode,
|
||||
;@@ should show full headers
|
||||
(progn
|
||||
(news-show-all-headers) ;@@ should save/restore header state,
|
||||
;@@ but rnews.el lacks support
|
||||
(narrow-to-region (point-min) (progn (goto-char (point-min))
|
||||
(search-forward "\n\n")
|
||||
(- (point) 1)))))
|
||||
(setq from (mail-fetch-field "from")
|
||||
news-reply-yank-from from
|
||||
;; @@ not handling old Title: field
|
||||
subject (mail-fetch-field "subject")
|
||||
date (mail-fetch-field "date")
|
||||
followup-to (mail-fetch-field "followup-to")
|
||||
newsgroups (or followup-to
|
||||
(mail-fetch-field "newsgroups"))
|
||||
references (mail-fetch-field "references")
|
||||
;; @@ not handling old Article-I.D.: field
|
||||
distribution (mail-fetch-field "distribution")
|
||||
message-id (mail-fetch-field "message-id")
|
||||
news-reply-yank-message-id message-id)
|
||||
(pop-to-buffer "*post-news*")
|
||||
(news-reply-mode)
|
||||
(if (and (buffer-modified-p)
|
||||
(not
|
||||
(y-or-n-p "Unsent article being composed; erase it? ")))
|
||||
()
|
||||
(progn
|
||||
(erase-buffer)
|
||||
(and subject
|
||||
(progn (if (string-match "\\`Re: " subject)
|
||||
(while (string-match "\\`Re: " subject)
|
||||
(setq subject (substring subject 4))))
|
||||
(setq subject (concat "Re: " subject))))
|
||||
(and from
|
||||
(progn
|
||||
(let ((stop-pos
|
||||
(string-match " *at \\| *@ \\| *(\\| *<" from)))
|
||||
(setq message-of
|
||||
(concat
|
||||
(if stop-pos (substring from 0 stop-pos) from)
|
||||
"'s message of "
|
||||
date)))))
|
||||
(news-setup
|
||||
nil
|
||||
subject
|
||||
message-of
|
||||
newsgroups
|
||||
buffer)
|
||||
(if followup-to
|
||||
(progn (news-reply-followup-to)
|
||||
(insert followup-to)))
|
||||
(if distribution
|
||||
(progn
|
||||
(mail-position-on-field "Distribution")
|
||||
(insert distribution)))
|
||||
(mail-position-on-field "References")
|
||||
(if references
|
||||
(insert references))
|
||||
(if (and references message-id)
|
||||
(insert " "))
|
||||
(if message-id
|
||||
(insert message-id))
|
||||
(goto-char (point-max))))))
|
||||
(message "")))
|
||||
|
||||
;@@ the guts of news-reply and news-post-news should be combined. -tower
|
||||
(defun news-post-news ()
|
||||
"Begin editing a new USENET news article to be posted.
|
||||
Type \\[describe-mode] once editing the article to get a list of commands."
|
||||
(interactive)
|
||||
(if (y-or-n-p "Are you sure you want to post to all of USENET? ")
|
||||
(let ((buffer (current-buffer)))
|
||||
(save-restriction
|
||||
(and (not (= 0 (buffer-size))) ;@@real problem is non-existence of
|
||||
;@@ of article file
|
||||
(equal major-mode 'news-mode) ;@@ if rmail-mode,
|
||||
;@@ should show full headers
|
||||
(progn
|
||||
(news-show-all-headers) ;@@ should save/restore header state,
|
||||
;@@ but rnews.el lacks support
|
||||
(narrow-to-region (point-min) (progn (goto-char (point-min))
|
||||
(search-forward "\n\n")
|
||||
(- (point) 1)))))
|
||||
(setq news-reply-yank-from (mail-fetch-field "from")
|
||||
;; @@ not handling old Article-I.D.: field
|
||||
news-reply-yank-message-id (mail-fetch-field "message-id")))
|
||||
(pop-to-buffer "*post-news*")
|
||||
(news-reply-mode)
|
||||
(if (and (buffer-modified-p)
|
||||
(not (y-or-n-p "Unsent article being composed; erase it? ")))
|
||||
() ;@@ not saving point from last time
|
||||
(progn (erase-buffer)
|
||||
(news-setup () () () () buffer))))
|
||||
(message "")))
|
||||
|
||||
(defun news-mail-other-window ()
|
||||
"Send mail in another window.
|
||||
While composing the message, use \\[news-reply-yank-original] to yank the
|
||||
original message into it."
|
||||
(interactive)
|
||||
(mail-other-window nil nil nil nil nil (current-buffer)))
|
||||
105
lisp/mail/undigest.el
Normal file
105
lisp/mail/undigest.el
Normal file
@ -0,0 +1,105 @@
|
||||
;; "RMAIL" mail reader for Emacs.
|
||||
;; 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.
|
||||
|
||||
;; note Interent RFP934
|
||||
|
||||
(defun undigestify-rmail-message ()
|
||||
"Break up a digest message into its constituent messages.
|
||||
Leaves original message, deleted, before the undigestified messages."
|
||||
(interactive)
|
||||
(widen)
|
||||
(let ((buffer-read-only nil)
|
||||
(msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
|
||||
(rmail-msgend rmail-current-message))))
|
||||
(goto-char (rmail-msgend rmail-current-message))
|
||||
(narrow-to-region (point) (point))
|
||||
(insert msg-string)
|
||||
(narrow-to-region (point-min) (1- (point-max))))
|
||||
(let ((error t)
|
||||
(buffer-read-only nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(save-restriction
|
||||
(goto-char (point-min))
|
||||
(delete-region (point-min)
|
||||
(progn (search-forward "\n*** EOOH ***\n")
|
||||
(point)))
|
||||
(insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
|
||||
(narrow-to-region (point)
|
||||
(point-max))
|
||||
(let* ((fill-prefix "")
|
||||
(case-fold-search t)
|
||||
(digest-name
|
||||
(mail-strip-quoted-names
|
||||
(or (save-restriction
|
||||
(search-forward "\n\n")
|
||||
(narrow-to-region (point-min) (point))
|
||||
(goto-char (point-max))
|
||||
(or (mail-fetch-field "Reply-To")
|
||||
(mail-fetch-field "To")
|
||||
(mail-fetch-field "Apparently-To")
|
||||
(mail-fetch-field "From")))
|
||||
(error "Message is not a digest")))))
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(skip-chars-backward " \t\n")
|
||||
(let ((count 10) found)
|
||||
;; compensate for broken un*x digestifiers. Sigh Sigh.
|
||||
(while (and (> count 0) (not found))
|
||||
(forward-line -1)
|
||||
(setq count (1- count))
|
||||
(if (looking-at (concat "End of.*Digest.*\n"
|
||||
(regexp-quote "*********") "*"
|
||||
"\\(\n------*\\)*"))
|
||||
(setq found t)))
|
||||
(if (not found) (error "Message is not a digest"))))
|
||||
(re-search-forward (concat "^" (make-string 55 ?-) "-*\n*"))
|
||||
(replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
|
||||
(save-restriction
|
||||
(narrow-to-region (point)
|
||||
(progn (search-forward "\n\n")
|
||||
(point)))
|
||||
(if (mail-fetch-field "To") nil
|
||||
(goto-char (point-min))
|
||||
(insert "To: " digest-name "\n")))
|
||||
(while (re-search-forward
|
||||
(concat "\n\n" (make-string 27 ?-) "-*\n*")
|
||||
nil t)
|
||||
(replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
|
||||
(save-restriction
|
||||
(if (looking-at "End ")
|
||||
(insert "To: " digest-name "\n\n")
|
||||
(narrow-to-region (point)
|
||||
(progn (search-forward "\n\n"
|
||||
nil 'move)
|
||||
(point))))
|
||||
(if (mail-fetch-field "To") nil
|
||||
(goto-char (point-min))
|
||||
(insert "To: " digest-name "\n"))))))
|
||||
(setq error nil)
|
||||
(message "Message successfully undigestified")
|
||||
(let ((n rmail-current-message))
|
||||
(rmail-forget-messages)
|
||||
(rmail-show-message n)
|
||||
(rmail-delete-forward)))
|
||||
(cond (error
|
||||
(narrow-to-region (point-min) (1+ (point-max)))
|
||||
(delete-region (point-min) (point-max))
|
||||
(rmail-show-message rmail-current-message))))))
|
||||
|
||||
91
lisp/mim-syntax.el
Normal file
91
lisp/mim-syntax.el
Normal file
@ -0,0 +1,91 @@
|
||||
;; Syntax checker for Mim (MDL).
|
||||
;; Copyright (C) 1985 Free Software Foundation, Inc.
|
||||
;; Principal author K. Shane Hartman
|
||||
|
||||
;; 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.
|
||||
|
||||
|
||||
(require 'mim-mode)
|
||||
|
||||
(defun slow-syntax-check-mim ()
|
||||
"Check Mim syntax slowly.
|
||||
Points out the context of the error, if the syntax is incorrect."
|
||||
(interactive)
|
||||
(message "checking syntax...")
|
||||
(let ((stop (point-max)) point-stack current last-bracket whoops last-point)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(while (and (not whoops)
|
||||
(re-search-forward "\\s(\\|\\s)\\|\"\\|[\\]" stop t))
|
||||
(setq current (preceding-char))
|
||||
(cond ((= current ?\")
|
||||
(condition-case nil
|
||||
(progn (re-search-forward "[^\\]\"")
|
||||
(setq current nil))
|
||||
(error (setq whoops (point)))))
|
||||
((= current ?\\)
|
||||
(condition-case nil (forward-char 1) (error nil)))
|
||||
((= (char-syntax current) ?\))
|
||||
(if (or (not last-bracket)
|
||||
(not (= (logand (lsh (aref (syntax-table) last-bracket) -8)
|
||||
?\177)
|
||||
current)))
|
||||
(setq whoops (point))
|
||||
(setq last-point (car point-stack))
|
||||
(setq last-bracket (if last-point (char-after (1- last-point))))
|
||||
(setq point-stack (cdr point-stack))))
|
||||
(t
|
||||
(if last-point (setq point-stack (cons last-point point-stack)))
|
||||
(setq last-point (point))
|
||||
(setq last-bracket current)))))
|
||||
(cond ((not (or whoops last-point))
|
||||
(message "Syntax correct"))
|
||||
(whoops
|
||||
(goto-char whoops)
|
||||
(cond ((equal current ?\")
|
||||
(error "Unterminated string"))
|
||||
((not last-point)
|
||||
(error "Extraneous %s" (char-to-string current)))
|
||||
(t
|
||||
(error "Mismatched %s with %s"
|
||||
(save-excursion
|
||||
(setq whoops (1- (point)))
|
||||
(goto-char (1- last-point))
|
||||
(buffer-substring (point)
|
||||
(min (progn (end-of-line) (point))
|
||||
whoops)))
|
||||
(char-to-string current)))))
|
||||
(t
|
||||
(goto-char last-point)
|
||||
(error "Unmatched %s" (char-to-string last-bracket))))))
|
||||
|
||||
(defun fast-syntax-check-mim ()
|
||||
"Checks Mim syntax quickly.
|
||||
Answers correct or incorrect, cannot point out the error context."
|
||||
(interactive)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(let (state)
|
||||
(while (and (not (eobp))
|
||||
(equal (car (setq state (parse-partial-sexp (point) (point-max) 0)))
|
||||
0)))
|
||||
(if (equal (car state) 0)
|
||||
(message "Syntax correct")
|
||||
(error "Syntax incorrect")))))
|
||||
|
||||
|
||||
|
||||
51
lisp/misc.el
Normal file
51
lisp/misc.el
Normal file
@ -0,0 +1,51 @@
|
||||
;; Basic editing commands for Emacs
|
||||
;; Copyright (C) 1989 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.
|
||||
|
||||
|
||||
(defun copy-from-above-command (&optional arg)
|
||||
"Copy characters from previous nonblank line, starting just above point.
|
||||
Copy ARG characters, but not past the end of that line.
|
||||
If no argument given, copy the entire rest of the line.
|
||||
The characters copied are inserted in the buffer before point."
|
||||
(interactive "P")
|
||||
(let ((cc (current-column))
|
||||
n
|
||||
(string ""))
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(backward-char 1)
|
||||
(skip-chars-backward "\ \t\n")
|
||||
(move-to-column cc)
|
||||
;; Default is enough to copy the whole rest of the line.
|
||||
(setq n (if arg (prefix-numeric-value arg) (point-max)))
|
||||
;; If current column winds up in middle of a tab,
|
||||
;; copy appropriate number of "virtual" space chars.
|
||||
(if (< cc (current-column))
|
||||
(if (= (preceding-char) ?\t)
|
||||
(progn
|
||||
(setq string (make-string (min n (- (current-column) cc)) ?\ ))
|
||||
(setq n (- n (min n (- (current-column) cc)))))
|
||||
;; In middle of ctl char => copy that whole char.
|
||||
(backward-char 1)))
|
||||
(setq string (concat string
|
||||
(buffer-substring
|
||||
(point)
|
||||
(min (save-excursion (end-of-line) (point))
|
||||
(+ n (point)))))))
|
||||
(insert string)))
|
||||
152
lisp/netunam.el
Normal file
152
lisp/netunam.el
Normal file
@ -0,0 +1,152 @@
|
||||
;; HP-UX RFA Commands
|
||||
;; Copyright (C) 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.
|
||||
|
||||
;;; Author: cph@zurich.ai.mit.edu
|
||||
|
||||
;;; $Header: netunam.el,v 1.3 88/12/21 16:32:23 GMT cph Exp $
|
||||
|
||||
(defconst rfa-node-directory "/net/"
|
||||
"Directory in which RFA network special files are stored.
|
||||
By HP convention, this is \"/net/\".")
|
||||
|
||||
(defvar rfa-default-node nil
|
||||
"If not nil, this is the name of the default RFA network special file.")
|
||||
|
||||
(defvar rfa-password-memoize-p t
|
||||
"If non-nil, remember login user's passwords after they have been entered.")
|
||||
|
||||
(defvar rfa-password-alist '()
|
||||
"An association from node-name strings to password strings.
|
||||
Used if `rfa-password-memoize-p' is non-nil.")
|
||||
|
||||
(defvar rfa-password-per-node-p t
|
||||
"If nil, login user uses same password on all machines.
|
||||
Has no effect if `rfa-password-memoize-p' is nil.")
|
||||
|
||||
(defun rfa-set-password (password &optional node user)
|
||||
"Add PASSWORD to the RFA password database.
|
||||
Optional second arg NODE is a string specifying a particular nodename;
|
||||
if supplied and not nil, PASSWORD applies to only that node.
|
||||
Optional third arg USER is a string specifying the (remote) user whose
|
||||
password this is; if not supplied this defaults to (user-login-name)."
|
||||
(if (not user) (setq user (user-login-name)))
|
||||
(let ((node-entry (assoc node rfa-password-alist)))
|
||||
(if node-entry
|
||||
(let ((user-entry (assoc user (cdr node-entry))))
|
||||
(if user-entry
|
||||
(rplacd user-entry password)
|
||||
(rplacd node-entry
|
||||
(nconc (cdr node-entry)
|
||||
(list (cons user password))))))
|
||||
(setq rfa-password-alist
|
||||
(nconc rfa-password-alist
|
||||
(list (list node (cons user password))))))))
|
||||
|
||||
(defun rfa-open (node &optional user password)
|
||||
"Open a network connection to a server using remote file access.
|
||||
First argument NODE is the network node for the remote machine.
|
||||
Second optional argument USER is the user name to use on that machine.
|
||||
If called interactively, the user name is prompted for.
|
||||
Third optional argument PASSWORD is the password string for that user.
|
||||
If not given, this is filled in from the value of
|
||||
`rfa-password-alist', or prompted for. A prefix argument of - will
|
||||
cause the password to be prompted for even if previously memoized."
|
||||
(interactive
|
||||
(list (read-file-name "rfa-open: " rfa-node-directory rfa-default-node t)
|
||||
(read-string "user-name: " (user-login-name))))
|
||||
(let ((node
|
||||
(and (or rfa-password-per-node-p
|
||||
(not (equal user (user-login-name))))
|
||||
node)))
|
||||
(if (not password)
|
||||
(setq password
|
||||
(let ((password
|
||||
(cdr (assoc user (cdr (assoc node rfa-password-alist))))))
|
||||
(or (and (not current-prefix-arg) password)
|
||||
(rfa-password-read
|
||||
(format "password for user %s%s: "
|
||||
user
|
||||
(if node (format " on node \"%s\"" node) ""))
|
||||
password))))))
|
||||
(let ((result
|
||||
(sysnetunam (expand-file-name node rfa-node-directory)
|
||||
(concat user ":" password))))
|
||||
(if (interactive-p)
|
||||
(if result
|
||||
(message "Opened network connection to %s as %s" node user)
|
||||
(error "Unable to open network connection")))
|
||||
(if (and rfa-password-memoize-p result)
|
||||
(rfa-set-password password node user))
|
||||
result))
|
||||
|
||||
(defun rfa-close (node)
|
||||
"Close a network connection to a server using remote file access.
|
||||
NODE is the network node for the remote machine."
|
||||
(interactive
|
||||
(list (read-file-name "rfa-close: " rfa-node-directory rfa-default-node t)))
|
||||
(let ((result (sysnetunam (expand-file-name node rfa-node-directory) "")))
|
||||
(cond ((not (interactive-p)) result)
|
||||
((not result) (error "Unable to close network connection"))
|
||||
(t (message "Closed network connection to %s" node)))))
|
||||
|
||||
(defun rfa-password-read (prompt default)
|
||||
(let ((rfa-password-accumulator (or default "")))
|
||||
(read-from-minibuffer prompt
|
||||
(and default
|
||||
(let ((copy (concat default))
|
||||
(index 0)
|
||||
(length (length default)))
|
||||
(while (< index length)
|
||||
(aset copy index ?.)
|
||||
(setq index (1+ index)))
|
||||
copy))
|
||||
rfa-password-map)
|
||||
rfa-password-accumulator))
|
||||
|
||||
(defvar rfa-password-map nil)
|
||||
(if (not rfa-password-map)
|
||||
(let ((char ? ))
|
||||
(setq rfa-password-map (make-keymap))
|
||||
(while (< char 127)
|
||||
(define-key rfa-password-map (char-to-string char)
|
||||
'rfa-password-self-insert)
|
||||
(setq char (1+ char)))
|
||||
(define-key rfa-password-map "\C-g"
|
||||
'abort-recursive-edit)
|
||||
(define-key rfa-password-map "\177"
|
||||
'rfa-password-rubout)
|
||||
(define-key rfa-password-map "\n"
|
||||
'exit-minibuffer)
|
||||
(define-key rfa-password-map "\r"
|
||||
'exit-minibuffer)))
|
||||
|
||||
(defvar rfa-password-accumulator nil)
|
||||
|
||||
(defun rfa-password-self-insert ()
|
||||
(interactive)
|
||||
(setq rfa-password-accumulator
|
||||
(concat rfa-password-accumulator
|
||||
(char-to-string last-command-char)))
|
||||
(insert ?.))
|
||||
|
||||
(defun rfa-password-rubout ()
|
||||
(interactive)
|
||||
(delete-char -1)
|
||||
(setq rfa-password-accumulator
|
||||
(substring rfa-password-accumulator 0 -1)))
|
||||
207
lisp/sun-curs.el
Normal file
207
lisp/sun-curs.el
Normal file
@ -0,0 +1,207 @@
|
||||
;; Cursor definitions for Sun windows
|
||||
;; Copyright (C) 1987 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.
|
||||
|
||||
;;;
|
||||
;;; Added some more cursors and moved the hot spots
|
||||
;;; Cursor defined by 16 pairs of 16-bit numbers
|
||||
;;;
|
||||
;;; 9-dec-86 Jeff Peck, Sun Microsystems Inc. <peck@sun.com>
|
||||
|
||||
(provide 'sm-cursors)
|
||||
|
||||
(defvar sc::cursors nil "List of known cursors")
|
||||
|
||||
(defmacro defcursor (name x y string)
|
||||
(if (not (memq name sc::cursors))
|
||||
(setq sc::cursors (cons name sc::cursors)))
|
||||
(list 'defconst name (list 'vector x y string)))
|
||||
|
||||
;;; push should be defined in common lisp, but if not use this:
|
||||
;(defmacro push (v l)
|
||||
; "The ITEM is evaluated and consed onto LIST, a list-valued atom"
|
||||
; (list 'setq l (list 'cons v l)))
|
||||
|
||||
;;;
|
||||
;;; The standard default cursor
|
||||
;;;
|
||||
(defcursor sc:right-arrow 15 0
|
||||
(concat '(0 1 0 3 0 7 0 15 0 31 0 63 0 127 0 15
|
||||
0 27 0 25 0 48 0 48 0 96 0 96 0 192 0 192)))
|
||||
|
||||
;;(sc:set-cursor sc:right-arrow)
|
||||
|
||||
(defcursor sc:fat-left-arrow 0 8
|
||||
(concat '(1 0 3 0 7 0 15 0 31 0 63 255 127 255 255 255
|
||||
255 255 127 255 63 255 31 0 15 0 7 0 3 0 1 0)))
|
||||
|
||||
(defcursor sc:box 8 8
|
||||
(concat '(15 252 8 4 8 4 8 4 8 4 8 4 8 4 8 4
|
||||
8 132 8 4 8 4 8 4 8 4 8 4 8 4 15 252)))
|
||||
|
||||
(defcursor sc:hourglass 8 8
|
||||
(concat "\177\376\100\002\040\014\032\070"
|
||||
"\017\360\007\340\003\300\001\200"
|
||||
"\001\200\002\100\005\040\010\020"
|
||||
"\021\210\043\304\107\342\177\376"))
|
||||
|
||||
(defun sc:set-cursor (icon)
|
||||
"Change the Sun mouse cursor to ICON.
|
||||
If ICON is nil, switch to the system default cursor,
|
||||
Otherwise, ICON should be a vector or the name of a vector of [x y 32-chars]"
|
||||
(interactive "XIcon Name: ")
|
||||
(if (symbolp icon) (setq icon (symbol-value icon)))
|
||||
(sun-change-cursor-icon icon))
|
||||
|
||||
(make-local-variable '*edit-icon*)
|
||||
(make-variable-buffer-local 'icon-edit)
|
||||
(setq-default icon-edit nil)
|
||||
(or (assq 'icon-edit minor-mode-alist)
|
||||
(push '(icon-edit " IconEdit") minor-mode-alist))
|
||||
|
||||
(defun sc:edit-cursor (icon)
|
||||
"convert icon to rectangle, edit, and repack"
|
||||
(interactive "XIcon Name: ")
|
||||
(if (not icon) (setq icon (sc::menu-choose-cursor (selected-window) 1 1)))
|
||||
(if (symbolp icon) (setq icon (symbol-value icon)))
|
||||
(if (get-buffer "icon-edit") (kill-buffer "icon-edit"))
|
||||
(switch-to-buffer "icon-edit")
|
||||
(local-set-mouse '(text right) 'sc::menu-function)
|
||||
(local-set-mouse '(text left) '(sc::pic-ins-at-mouse 32))
|
||||
(local-set-mouse '(text middle) '(sc::pic-ins-at-mouse 64))
|
||||
(local-set-mouse '(text left middle) 'sc::hotspot)
|
||||
(sc::display-icon icon)
|
||||
(picture-mode)
|
||||
(setq icon-edit t) ; for mode line display
|
||||
)
|
||||
|
||||
(defun sc::pic-ins-at-mouse (char)
|
||||
"Picture insert char at mouse location"
|
||||
(mouse-move-point *mouse-window* (min 15 *mouse-x*) (min 15 *mouse-y*))
|
||||
(move-to-column-force (1+ (min 15 (current-column))))
|
||||
(delete-char -1)
|
||||
(insert char)
|
||||
(sc::goto-hotspot))
|
||||
|
||||
(defun sc::menu-function (window x y)
|
||||
(sun-menu-evaluate window (1+ x) y sc::menu))
|
||||
|
||||
(defmenu sc::menu
|
||||
("Cursor Menu")
|
||||
("Pack & Use" sc::pack-buffer-to-cursor)
|
||||
("Pack to Icon" sc::pack-buffer-to-icon
|
||||
(sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*))
|
||||
("New Icon" call-interactively 'sc::make-cursor)
|
||||
("Edit Icon" sc:edit-cursor
|
||||
(sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*))
|
||||
("Set Cursor" sc:set-cursor
|
||||
(sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*))
|
||||
("Reset Cursor" sc:set-cursor nil)
|
||||
("Help". sc::edit-icon-help-menu)
|
||||
("Quit" sc::quit-edit)
|
||||
)
|
||||
|
||||
(defun sc::quit-edit ()
|
||||
(interactive)
|
||||
(bury-buffer (current-buffer))
|
||||
(switch-to-buffer (other-buffer) 'no-record))
|
||||
|
||||
(defun sc::make-cursor (symbol)
|
||||
(interactive "SIcon Name: ")
|
||||
(eval (list 'defcursor symbol 0 0 ""))
|
||||
(sc::pack-buffer-to-icon (symbol-value symbol)))
|
||||
|
||||
(defmenu sc::edit-icon-help-menu
|
||||
("Simple Icon Editor")
|
||||
("Left => CLEAR")
|
||||
("Middle => SET")
|
||||
("L & M => HOTSPOT")
|
||||
("Right => MENU"))
|
||||
|
||||
(defun sc::edit-icon-help ()
|
||||
(message "Left=> CLEAR Middle=> SET Left+Middle=> HOTSPOT Right=> MENU"))
|
||||
|
||||
(defun sc::pack-buffer-to-cursor ()
|
||||
(sc::pack-buffer-to-icon *edit-icon*)
|
||||
(sc:set-cursor *edit-icon*))
|
||||
|
||||
(defun sc::menu-choose-cursor (window x y)
|
||||
"Presents a menu of cursor names, and returns one or nil"
|
||||
(let ((curs sc::cursors)
|
||||
(items))
|
||||
(while curs
|
||||
(push (sc::menu-item-for-cursor (car curs)) items)
|
||||
(setq curs (cdr curs)))
|
||||
(push (list "Choose Cursor") items)
|
||||
(setq menu (menu-create items))
|
||||
(sun-menu-evaluate window x y menu)))
|
||||
|
||||
(defun sc::menu-item-for-cursor (cursor)
|
||||
"apply function to selected cursor"
|
||||
(list (symbol-name cursor) 'quote cursor))
|
||||
|
||||
(defun sc::hotspot (window x y)
|
||||
(aset *edit-icon* 0 x)
|
||||
(aset *edit-icon* 1 y)
|
||||
(sc::goto-hotspot))
|
||||
|
||||
(defun sc::goto-hotspot ()
|
||||
(goto-line (1+ (aref *edit-icon* 1)))
|
||||
(move-to-column (aref *edit-icon* 0)))
|
||||
|
||||
(defun sc::display-icon (icon)
|
||||
(setq *edit-icon* (copy-sequence icon))
|
||||
(let ((string (aref *edit-icon* 2))
|
||||
(index 0))
|
||||
(while (< index 32)
|
||||
(let ((char (aref string index))
|
||||
(bit 128))
|
||||
(while (> bit 0)
|
||||
(insert (sc::char-at-bit char bit))
|
||||
(setq bit (lsh bit -1))))
|
||||
(if (eq 1 (% index 2)) (newline))
|
||||
(setq index (1+ index))))
|
||||
(sc::goto-hotspot))
|
||||
|
||||
(defun sc::char-at-bit (char bit)
|
||||
(if (> (logand char bit) 0) "@" " "))
|
||||
|
||||
(defun sc::pack-buffer-to-icon (icon)
|
||||
"Pack 16 x 16 field into icon string"
|
||||
(goto-char (point-min))
|
||||
(aset icon 0 (aref *edit-icon* 0))
|
||||
(aset icon 1 (aref *edit-icon* 1))
|
||||
(aset icon 2 (mapconcat 'sc::pack-one-line "1234567890123456" ""))
|
||||
(sc::goto-hotspot)
|
||||
)
|
||||
|
||||
(defun sc::pack-one-line (dummy)
|
||||
(let* (char chr1 chr2)
|
||||
(setq char 0 chr1 (mapconcat 'sc::pack-one-char "12345678" "") chr1 char)
|
||||
(setq char 0 chr2 (mapconcat 'sc::pack-one-char "12345678" "") chr2 char)
|
||||
(forward-line 1)
|
||||
(concat (char-to-string chr1) (char-to-string chr2))
|
||||
))
|
||||
|
||||
(defun sc::pack-one-char (dummy)
|
||||
"pack following char into char, unless eolp"
|
||||
(if (or (eolp) (char-equal (following-char) 32))
|
||||
(setq char (lsh char 1))
|
||||
(setq char (1+ (lsh char 1))))
|
||||
(if (not (eolp))(forward-char)))
|
||||
|
||||
630
lisp/sun-fns.el
Normal file
630
lisp/sun-fns.el
Normal file
@ -0,0 +1,630 @@
|
||||
;; Subroutines of Mouse handling for Sun windows
|
||||
;; Copyright (C) 1987 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.
|
||||
|
||||
;;; Submitted Mar. 1987, Jeff Peck
|
||||
;;; Sun Microsystems Inc. <peck@sun.com>
|
||||
;;; Conceived Nov. 1986, Stan Jefferson,
|
||||
;;; Computer Science Lab, SRI International.
|
||||
;;; GoodIdeas Feb. 1987, Steve Greenbaum
|
||||
;;; & UpClicks Reasoning Systems, Inc.
|
||||
;;;
|
||||
(provide 'sun-fns)
|
||||
(require 'sun-mouse)
|
||||
;;;
|
||||
;;; Functions for manipulating via the mouse and mouse-map definitions
|
||||
;;; for accessing them. Also definitons of mouse menus.
|
||||
;;; This file you should freely modify to reflect you personal tastes.
|
||||
;;;
|
||||
;;; First half of file defines functions to implement mouse commands,
|
||||
;;; Don't delete any of those, just add what ever else you need.
|
||||
;;; Second half of file defines mouse bindings, do whatever you want there.
|
||||
|
||||
;;;
|
||||
;;; Mouse Functions.
|
||||
;;;
|
||||
;;; These functions follow the sun-mouse-handler convention of being called
|
||||
;;; with three arguements: (window x-pos y-pos)
|
||||
;;; This makes it easy for a mouse executed command to know where the mouse is.
|
||||
;;; Use the macro "eval-in-window" to execute a function
|
||||
;;; in a temporarily selected window.
|
||||
;;;
|
||||
;;; If you have a function that must be called with other arguments
|
||||
;;; bind the mouse button to an s-exp that contains the necessary parameters.
|
||||
;;; See "minibuffer" bindings for examples.
|
||||
;;;
|
||||
(defconst cursor-pause-milliseconds 300
|
||||
"*Number of milliseconds to display alternate cursor (usually the mark)")
|
||||
|
||||
(defun indicate-region (&optional pause)
|
||||
"Bounce cursor to mark for cursor-pause-milliseconds and back again"
|
||||
(or pause (setq pause cursor-pause-milliseconds))
|
||||
(let ((point (point)))
|
||||
(goto-char (mark))
|
||||
(sit-for-millisecs pause)
|
||||
;(update-display)
|
||||
;(sleep-for-millisecs pause)
|
||||
(goto-char point)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Text buffer operations
|
||||
;;;
|
||||
(defun mouse-move-point (window x y)
|
||||
"Move point to mouse cursor."
|
||||
(select-window window)
|
||||
(move-to-loc x y)
|
||||
(if (memq last-command ; support the mouse-copy/delete/yank
|
||||
'(mouse-copy mouse-delete mouse-yank-move))
|
||||
(setq this-command 'mouse-yank-move))
|
||||
)
|
||||
|
||||
(defun mouse-set-mark (window x y)
|
||||
"Set mark at mouse cursor."
|
||||
(eval-in-window window ;; use this to get the unwind protect
|
||||
(let ((point (point)))
|
||||
(move-to-loc x y)
|
||||
(set-mark (point))
|
||||
(goto-char point)
|
||||
(indicate-region)))
|
||||
)
|
||||
|
||||
(defun mouse-set-mark-and-select (window x y)
|
||||
"Set mark at mouse cursor, and select that window."
|
||||
(select-window window)
|
||||
(mouse-set-mark window x y)
|
||||
)
|
||||
|
||||
(defun mouse-set-mark-and-stuff (w x y)
|
||||
"Set mark at mouse cursor, and put region in stuff buffer."
|
||||
(mouse-set-mark-and-select w x y)
|
||||
(sun-select-region (region-beginning) (region-end)))
|
||||
|
||||
;;;
|
||||
;;; Simple mouse dragging stuff: marking with button up
|
||||
;;;
|
||||
|
||||
(defvar *mouse-drag-window* nil)
|
||||
(defvar *mouse-drag-x* -1)
|
||||
(defvar *mouse-drag-y* -1)
|
||||
|
||||
(defun mouse-drag-move-point (window x y)
|
||||
"Move point to mouse cursor, and allow dragging."
|
||||
(mouse-move-point window x y)
|
||||
(setq *mouse-drag-window* window
|
||||
*mouse-drag-x* x
|
||||
*mouse-drag-y* y))
|
||||
|
||||
(defun mouse-drag-set-mark-stuff (window x y)
|
||||
"The up click handler that goes with mouse-drag-move-point.
|
||||
If mouse is in same WINDOW but at different X or Y than when
|
||||
mouse-drag-move-point was last executed, set the mark at mouse
|
||||
and put the region in the stuff buffer."
|
||||
(if (and (eq *mouse-drag-window* window)
|
||||
(not (and (equal *mouse-drag-x* x)
|
||||
(equal *mouse-drag-y* y))))
|
||||
(mouse-set-mark-and-stuff window x y)
|
||||
(setq this-command last-command)) ; this was just an upclick no-op.
|
||||
)
|
||||
|
||||
(defun mouse-select-or-drag-move-point (window x y)
|
||||
"Select window if not selected, otherwise do mouse-drag-move-point."
|
||||
(if (eq (selected-window) window)
|
||||
(mouse-drag-move-point window x y)
|
||||
(mouse-select-window window x y)))
|
||||
|
||||
;;;
|
||||
;;; esoteria:
|
||||
;;;
|
||||
(defun mouse-exch-pt-and-mark (window x y)
|
||||
"Exchange point and mark."
|
||||
(select-window window)
|
||||
(exchange-point-and-mark)
|
||||
)
|
||||
|
||||
(defun mouse-call-kbd-macro (window x y)
|
||||
"Invokes last keyboard macro at mouse cursor."
|
||||
(mouse-move-point window x y)
|
||||
(call-last-kbd-macro)
|
||||
)
|
||||
|
||||
(defun mouse-mark-thing (window x y)
|
||||
"Set point and mark to text object using syntax table.
|
||||
The resulting region is put in the sun-window stuff buffer.
|
||||
Left or right Paren syntax marks an s-expression.
|
||||
Clicking at the end of a line marks the line including a trailing newline.
|
||||
If it doesn't recognize one of these it marks the character at point."
|
||||
(mouse-move-point window x y)
|
||||
(if (eobp) (open-line 1))
|
||||
(let* ((char (char-after (point)))
|
||||
(syntax (char-syntax char)))
|
||||
(cond
|
||||
((eq syntax ?w) ; word.
|
||||
(forward-word 1)
|
||||
(set-mark (point))
|
||||
(forward-word -1))
|
||||
;; try to include a single following whitespace (is this a good idea?)
|
||||
;; No, not a good idea since inconsistent.
|
||||
;;(if (eq (char-syntax (char-after (mark))) ?\ )
|
||||
;; (set-mark (1+ (mark))))
|
||||
((eq syntax ?\( ) ; open paren.
|
||||
(mark-sexp 1))
|
||||
((eq syntax ?\) ) ; close paren.
|
||||
(forward-char 1)
|
||||
(mark-sexp -1)
|
||||
(exchange-point-and-mark))
|
||||
((eolp) ; mark line if at end.
|
||||
(set-mark (1+ (point)))
|
||||
(beginning-of-line 1))
|
||||
(t ; mark character
|
||||
(set-mark (1+ (point)))))
|
||||
(indicate-region)) ; display region boundary.
|
||||
(sun-select-region (region-beginning) (region-end))
|
||||
)
|
||||
|
||||
(defun mouse-kill-thing (window x y)
|
||||
"Kill thing at mouse, and put point there."
|
||||
(mouse-mark-thing window x y)
|
||||
(kill-region-and-unmark (region-beginning) (region-end))
|
||||
)
|
||||
|
||||
(defun mouse-kill-thing-there (window x y)
|
||||
"Kill thing at mouse, leave point where it was.
|
||||
See mouse-mark-thing for a description of the objects recognized."
|
||||
(eval-in-window window
|
||||
(save-excursion
|
||||
(mouse-mark-thing window x y)
|
||||
(kill-region (region-beginning) (region-end))))
|
||||
)
|
||||
|
||||
(defun mouse-save-thing (window x y &optional quiet)
|
||||
"Put thing at mouse in kill ring.
|
||||
See mouse-mark-thing for a description of the objects recognized."
|
||||
(mouse-mark-thing window x y)
|
||||
(copy-region-as-kill (region-beginning) (region-end))
|
||||
(if (not quiet) (message "Thing saved"))
|
||||
)
|
||||
|
||||
(defun mouse-save-thing-there (window x y &optional quiet)
|
||||
"Put thing at mouse in kill ring, leave point as is.
|
||||
See mouse-mark-thing for a description of the objects recognized."
|
||||
(eval-in-window window
|
||||
(save-excursion
|
||||
(mouse-save-thing window x y quiet))))
|
||||
|
||||
;;;
|
||||
;;; Mouse yanking...
|
||||
;;;
|
||||
(defun mouse-copy-thing (window x y)
|
||||
"Put thing at mouse in kill ring, yank to point.
|
||||
See mouse-mark-thing for a description of the objects recognized."
|
||||
(setq last-command 'not-kill) ;Avoids appending to previous kills.
|
||||
(mouse-save-thing-there window x y t)
|
||||
(yank)
|
||||
(setq this-command 'yank))
|
||||
|
||||
(defun mouse-move-thing (window x y)
|
||||
"Kill thing at mouse, yank it to point.
|
||||
See mouse-mark-thing for a description of the objects recognized."
|
||||
(setq last-command 'not-kill) ;Avoids appending to previous kills.
|
||||
(mouse-kill-thing-there window x y)
|
||||
(yank)
|
||||
(setq this-command 'yank))
|
||||
|
||||
(defun mouse-yank-at-point (&optional window x y)
|
||||
"Yank from kill-ring at point; then cycle thru kill ring."
|
||||
(if (eq last-command 'yank)
|
||||
(let ((before (< (point) (mark))))
|
||||
(delete-region (point) (mark))
|
||||
(rotate-yank-pointer 1)
|
||||
(insert (car kill-ring-yank-pointer))
|
||||
(if before (exchange-point-and-mark)))
|
||||
(yank))
|
||||
(setq this-command 'yank))
|
||||
|
||||
(defun mouse-yank-at-mouse (window x y)
|
||||
"Yank from kill-ring at mouse; then cycle thru kill ring."
|
||||
(mouse-move-point window x y)
|
||||
(mouse-yank-at-point window x y))
|
||||
|
||||
(defun mouse-save/delete/yank (&optional window x y)
|
||||
"Context sensitive save/delete/yank.
|
||||
Consecutive clicks perform as follows:
|
||||
* first click saves region to kill ring,
|
||||
* second click kills region,
|
||||
* third click yanks from kill ring,
|
||||
* subsequent clicks cycle thru kill ring.
|
||||
If mouse-move-point is performed after the first or second click,
|
||||
the next click will do a yank, etc. Except for a possible mouse-move-point,
|
||||
this command is insensitive to mouse location."
|
||||
(cond
|
||||
((memq last-command '(mouse-delete yank mouse-yank-move)) ; third+ click
|
||||
(mouse-yank-at-point))
|
||||
((eq last-command 'mouse-copy) ; second click
|
||||
(kill-region (region-beginning) (region-end))
|
||||
(setq this-command 'mouse-delete))
|
||||
(t ; first click
|
||||
(copy-region-as-kill (region-beginning) (region-end))
|
||||
(message "Region saved")
|
||||
(setq this-command 'mouse-copy))
|
||||
))
|
||||
|
||||
|
||||
(defun mouse-split-horizontally (window x y)
|
||||
"Splits the window horizontally at mouse cursor."
|
||||
(eval-in-window window (split-window-horizontally (1+ x))))
|
||||
|
||||
(defun mouse-split-vertically (window x y)
|
||||
"Split the window vertically at the mouse cursor."
|
||||
(eval-in-window window (split-window-vertically (1+ y))))
|
||||
|
||||
(defun mouse-select-window (window x y)
|
||||
"Selects the window, restoring point."
|
||||
(select-window window))
|
||||
|
||||
(defun mouse-delete-other-windows (window x y)
|
||||
"Deletes all windows except the one mouse is in."
|
||||
(delete-other-windows window))
|
||||
|
||||
(defun mouse-delete-window (window x y)
|
||||
"Deletes the window mouse is in."
|
||||
(delete-window window))
|
||||
|
||||
(defun mouse-undo (window x y)
|
||||
"Invokes undo in the window mouse is in."
|
||||
(eval-in-window window (undo)))
|
||||
|
||||
;;;
|
||||
;;; Scroll operations
|
||||
;;;
|
||||
|
||||
;;; The move-to-window-line is used below because otherwise
|
||||
;;; scrolling a non-selected process window with the mouse, after
|
||||
;;; the process has written text past the bottom of the window,
|
||||
;;; gives an "End of buffer" error, and then scrolls. The
|
||||
;;; move-to-window-line seems to force recomputing where things are.
|
||||
(defun mouse-scroll-up (window x y)
|
||||
"Scrolls the window upward."
|
||||
(eval-in-window window (move-to-window-line 1) (scroll-up nil)))
|
||||
|
||||
(defun mouse-scroll-down (window x y)
|
||||
"Scrolls the window downward."
|
||||
(eval-in-window window (scroll-down nil)))
|
||||
|
||||
(defun mouse-scroll-proportional (window x y)
|
||||
"Scrolls the window proportionally corresponding to window
|
||||
relative X divided by window width."
|
||||
(eval-in-window window
|
||||
(if (>= x (1- (window-width)))
|
||||
;; When x is maximun (equal to or 1 less than window width),
|
||||
;; goto end of buffer. We check for this special case
|
||||
;; becuase the calculated goto-char often goes short of the
|
||||
;; end due to roundoff error, and we often really want to go
|
||||
;; to the end.
|
||||
(goto-char (point-max))
|
||||
(progn
|
||||
(goto-char (+ (point-min) ; For narrowed regions.
|
||||
(* x (/ (- (point-max) (point-min))
|
||||
(1- (window-width))))))
|
||||
(beginning-of-line))
|
||||
)
|
||||
(what-cursor-position) ; Report position.
|
||||
))
|
||||
|
||||
(defun mouse-line-to-top (window x y)
|
||||
"Scrolls the line at the mouse cursor up to the top."
|
||||
(eval-in-window window (scroll-up y)))
|
||||
|
||||
(defun mouse-top-to-line (window x y)
|
||||
"Scrolls the top line down to the mouse cursor."
|
||||
(eval-in-window window (scroll-down y)))
|
||||
|
||||
(defun mouse-line-to-bottom (window x y)
|
||||
"Scrolls the line at the mouse cursor to the bottom."
|
||||
(eval-in-window window (scroll-up (+ y (- 2 (window-height))))))
|
||||
|
||||
(defun mouse-bottom-to-line (window x y)
|
||||
"Scrolls the bottom line up to the mouse cursor."
|
||||
(eval-in-window window (scroll-down (+ y (- 2 (window-height))))))
|
||||
|
||||
(defun mouse-line-to-middle (window x y)
|
||||
"Scrolls the line at the mouse cursor to the middle."
|
||||
(eval-in-window window (scroll-up (- y -1 (/ (window-height) 2)))))
|
||||
|
||||
(defun mouse-middle-to-line (window x y)
|
||||
"Scrolls the line at the middle to the mouse cursor."
|
||||
(eval-in-window window (scroll-up (- (/ (window-height) 2) y 1))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; main emacs menu.
|
||||
;;;
|
||||
(defmenu expand-menu
|
||||
("Vertically" mouse-expand-vertically *menu-window*)
|
||||
("Horizontally" mouse-expand-horizontally *menu-window*))
|
||||
|
||||
(defmenu delete-window-menu
|
||||
("This One" delete-window *menu-window*)
|
||||
("All Others" delete-other-windows *menu-window*))
|
||||
|
||||
(defmenu mouse-help-menu
|
||||
("Text Region"
|
||||
mouse-help-region *menu-window* *menu-x* *menu-y* 'text)
|
||||
("Scrollbar"
|
||||
mouse-help-region *menu-window* *menu-x* *menu-y* 'scrollbar)
|
||||
("Modeline"
|
||||
mouse-help-region *menu-window* *menu-x* *menu-y* 'modeline)
|
||||
("Minibuffer"
|
||||
mouse-help-region *menu-window* *menu-x* *menu-y* 'minibuffer)
|
||||
)
|
||||
|
||||
(defmenu emacs-quit-menu
|
||||
("Suspend" suspend-emacstool)
|
||||
("Quit" save-buffers-kill-emacs))
|
||||
|
||||
(defmenu emacs-menu
|
||||
("Emacs Menu")
|
||||
("Stuff Selection" sun-yank-selection)
|
||||
("Expand" . expand-menu)
|
||||
("Delete Window" . delete-window-menu)
|
||||
("Previous Buffer" mouse-select-previous-buffer *menu-window*)
|
||||
("Save Buffers" save-some-buffers)
|
||||
("List Directory" list-directory nil)
|
||||
("Dired" dired nil)
|
||||
("Mouse Help" . mouse-help-menu)
|
||||
("Quit" . emacs-quit-menu))
|
||||
|
||||
(defun emacs-menu-eval (window x y)
|
||||
"Pop-up menu of editor commands."
|
||||
(sun-menu-evaluate window (1+ x) (1- y) 'emacs-menu))
|
||||
|
||||
(defun mouse-expand-horizontally (window)
|
||||
(eval-in-window window
|
||||
(enlarge-window 4 t)
|
||||
(update-display) ; Try to redisplay, since can get confused.
|
||||
))
|
||||
|
||||
(defun mouse-expand-vertically (window)
|
||||
(eval-in-window window (enlarge-window 4)))
|
||||
|
||||
(defun mouse-select-previous-buffer (window)
|
||||
"Switch buffer in mouse window to most recently selected buffer."
|
||||
(eval-in-window window (switch-to-buffer (other-buffer))))
|
||||
|
||||
;;;
|
||||
;;; minibuffer menu
|
||||
;;;
|
||||
(defmenu minibuffer-menu
|
||||
("Minibuffer" message "Just some miscellanous minibuffer commands")
|
||||
("Stuff" sun-yank-selection)
|
||||
("Do-It" exit-minibuffer)
|
||||
("Abort" abort-recursive-edit)
|
||||
("Suspend" suspend-emacs))
|
||||
|
||||
(defun minibuffer-menu-eval (window x y)
|
||||
"Pop-up menu of commands."
|
||||
(sun-menu-evaluate window x (1- y) 'minibuffer-menu))
|
||||
|
||||
(defun mini-move-point (window x y)
|
||||
;; -6 is good for most common cases
|
||||
(mouse-move-point window (- x 6) 0))
|
||||
|
||||
(defun mini-set-mark-and-stuff (window x y)
|
||||
;; -6 is good for most common cases
|
||||
(mouse-set-mark-and-stuff window (- x 6) 0))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Buffer-mode Mouse commands
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun Buffer-at-mouse (w x y)
|
||||
"Calls Buffer-menu-buffer from mouse click."
|
||||
(save-window-excursion
|
||||
(mouse-move-point w x y)
|
||||
(beginning-of-line)
|
||||
(Buffer-menu-buffer t)))
|
||||
|
||||
(defun mouse-buffer-bury (w x y)
|
||||
"Bury the indicated buffer."
|
||||
(bury-buffer (Buffer-at-mouse w x y))
|
||||
)
|
||||
|
||||
(defun mouse-buffer-select (w x y)
|
||||
"Put the indicated buffer in selected window."
|
||||
(switch-to-buffer (Buffer-at-mouse w x y))
|
||||
(list-buffers)
|
||||
)
|
||||
|
||||
(defun mouse-buffer-delete (w x y)
|
||||
"mark indicated buffer for delete"
|
||||
(save-window-excursion
|
||||
(mouse-move-point w x y)
|
||||
(Buffer-menu-delete)
|
||||
))
|
||||
|
||||
(defun mouse-buffer-execute (w x y)
|
||||
"execute buffer-menu selections"
|
||||
(save-window-excursion
|
||||
(mouse-move-point w x y)
|
||||
(Buffer-menu-execute)
|
||||
))
|
||||
|
||||
(defun enable-mouse-in-buffer-list ()
|
||||
"Call this to enable mouse selections in *Buffer List*
|
||||
LEFT puts the indicated buffer in the selected window.
|
||||
MIDDLE buries the indicated buffer.
|
||||
RIGHT marks the indicated buffer for deletion.
|
||||
MIDDLE-RIGHT deletes the marked buffers.
|
||||
To unmark a buffer marked for deletion, select it with LEFT."
|
||||
(save-window-excursion
|
||||
(list-buffers) ; Initialize *Buffer List*
|
||||
(set-buffer "*Buffer List*")
|
||||
(local-set-mouse '(text middle) 'mouse-buffer-bury)
|
||||
(local-set-mouse '(text left) 'mouse-buffer-select)
|
||||
(local-set-mouse '(text right) 'mouse-buffer-delete)
|
||||
(local-set-mouse '(text middle right) 'mouse-buffer-execute)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
;;;*******************************************************************
|
||||
;;;
|
||||
;;; Global Mouse Bindings.
|
||||
;;;
|
||||
;;; There is some sense to this mouse binding madness:
|
||||
;;; LEFT and RIGHT scrolls are inverses.
|
||||
;;; SHIFT makes an opposite meaning in the scroll bar.
|
||||
;;; SHIFT is an alternative to DOUBLE (but double chords do not exist).
|
||||
;;; META makes the scrollbar functions work in the text region.
|
||||
;;; MIDDLE operates the mark
|
||||
;;; LEFT operates at point
|
||||
|
||||
;;; META commands are generally non-destructive,
|
||||
;;; SHIFT is a little more dangerous.
|
||||
;;; CONTROL is for the really complicated ones.
|
||||
|
||||
;;; CONTROL-META-SHIFT-RIGHT gives help on that region.
|
||||
|
||||
;;;
|
||||
;;; Text Region mousemap
|
||||
;;;
|
||||
;; The basics: Point, Mark, Menu, Sun-Select:
|
||||
(global-set-mouse '(text left) 'mouse-drag-move-point)
|
||||
(global-set-mouse '(text up left) 'mouse-drag-set-mark-stuff)
|
||||
(global-set-mouse '(text shift left) 'mouse-exch-pt-and-mark)
|
||||
(global-set-mouse '(text double left) 'mouse-exch-pt-and-mark)
|
||||
|
||||
(global-set-mouse '(text middle) 'mouse-set-mark-and-stuff)
|
||||
|
||||
(global-set-mouse '(text right) 'emacs-menu-eval)
|
||||
(global-set-mouse '(text shift right) '(sun-yank-selection))
|
||||
(global-set-mouse '(text double right) '(sun-yank-selection))
|
||||
|
||||
;; The Slymoblics multi-command for Save, Kill, Copy, Move:
|
||||
(global-set-mouse '(text shift middle) 'mouse-save/delete/yank)
|
||||
(global-set-mouse '(text double middle) 'mouse-save/delete/yank)
|
||||
|
||||
;; Save, Kill, Copy, Move Things:
|
||||
;; control-left composes with control middle/right to produce copy/move
|
||||
(global-set-mouse '(text control middle ) 'mouse-save-thing-there)
|
||||
(global-set-mouse '(text control right ) 'mouse-kill-thing-there)
|
||||
(global-set-mouse '(text control left) 'mouse-yank-at-point)
|
||||
(global-set-mouse '(text control middle left) 'mouse-copy-thing)
|
||||
(global-set-mouse '(text control right left) 'mouse-move-thing)
|
||||
(global-set-mouse '(text control right middle) 'mouse-mark-thing)
|
||||
|
||||
;; The Universal mouse help command (press all buttons):
|
||||
(global-set-mouse '(text shift control meta right) 'mouse-help-region)
|
||||
(global-set-mouse '(text double control meta right) 'mouse-help-region)
|
||||
|
||||
;;; Meta in Text Region is like meta version in scrollbar:
|
||||
(global-set-mouse '(text meta left) 'mouse-line-to-top)
|
||||
(global-set-mouse '(text meta shift left) 'mouse-line-to-bottom)
|
||||
(global-set-mouse '(text meta double left) 'mouse-line-to-bottom)
|
||||
(global-set-mouse '(text meta middle) 'mouse-line-to-middle)
|
||||
(global-set-mouse '(text meta shift middle) 'mouse-middle-to-line)
|
||||
(global-set-mouse '(text meta double middle) 'mouse-middle-to-line)
|
||||
(global-set-mouse '(text meta control middle) 'mouse-split-vertically)
|
||||
(global-set-mouse '(text meta right) 'mouse-top-to-line)
|
||||
(global-set-mouse '(text meta shift right) 'mouse-bottom-to-line)
|
||||
(global-set-mouse '(text meta double right) 'mouse-bottom-to-line)
|
||||
|
||||
;; Miscellaneous:
|
||||
(global-set-mouse '(text meta control left) 'mouse-call-kbd-macro)
|
||||
(global-set-mouse '(text meta control right) 'mouse-undo)
|
||||
|
||||
;;;
|
||||
;;; Scrollbar mousemap.
|
||||
;;; Are available in the Scrollbar Region, or with Meta Text (or Meta Scrollbar)
|
||||
;;;
|
||||
(global-set-mouse '(scrollbar left) 'mouse-line-to-top)
|
||||
(global-set-mouse '(scrollbar shift left) 'mouse-line-to-bottom)
|
||||
(global-set-mouse '(scrollbar double left) 'mouse-line-to-bottom)
|
||||
|
||||
(global-set-mouse '(scrollbar middle) 'mouse-line-to-middle)
|
||||
(global-set-mouse '(scrollbar shift middle) 'mouse-middle-to-line)
|
||||
(global-set-mouse '(scrollbar double middle) 'mouse-middle-to-line)
|
||||
(global-set-mouse '(scrollbar control middle) 'mouse-split-vertically)
|
||||
|
||||
(global-set-mouse '(scrollbar right) 'mouse-top-to-line)
|
||||
(global-set-mouse '(scrollbar shift right) 'mouse-bottom-to-line)
|
||||
(global-set-mouse '(scrollbar double right) 'mouse-bottom-to-line)
|
||||
|
||||
(global-set-mouse '(scrollbar meta left) 'mouse-line-to-top)
|
||||
(global-set-mouse '(scrollbar meta shift left) 'mouse-line-to-bottom)
|
||||
(global-set-mouse '(scrollbar meta double left) 'mouse-line-to-bottom)
|
||||
(global-set-mouse '(scrollbar meta middle) 'mouse-line-to-middle)
|
||||
(global-set-mouse '(scrollbar meta shift middle) 'mouse-middle-to-line)
|
||||
(global-set-mouse '(scrollbar meta double middle) 'mouse-middle-to-line)
|
||||
(global-set-mouse '(scrollbar meta control middle) 'mouse-split-vertically)
|
||||
(global-set-mouse '(scrollbar meta right) 'mouse-top-to-line)
|
||||
(global-set-mouse '(scrollbar meta shift right) 'mouse-bottom-to-line)
|
||||
(global-set-mouse '(scrollbar meta double right) 'mouse-bottom-to-line)
|
||||
|
||||
;; And the help menu:
|
||||
(global-set-mouse '(scrollbar shift control meta right) 'mouse-help-region)
|
||||
(global-set-mouse '(scrollbar double control meta right) 'mouse-help-region)
|
||||
|
||||
;;;
|
||||
;;; Modeline mousemap.
|
||||
;;;
|
||||
;;; Note: meta of any single button selects window.
|
||||
|
||||
(global-set-mouse '(modeline left) 'mouse-scroll-up)
|
||||
(global-set-mouse '(modeline meta left) 'mouse-select-window)
|
||||
|
||||
(global-set-mouse '(modeline middle) 'mouse-scroll-proportional)
|
||||
(global-set-mouse '(modeline meta middle) 'mouse-select-window)
|
||||
(global-set-mouse '(modeline control middle) 'mouse-split-horizontally)
|
||||
|
||||
(global-set-mouse '(modeline right) 'mouse-scroll-down)
|
||||
(global-set-mouse '(modeline meta right) 'mouse-select-window)
|
||||
|
||||
;;; control-left selects this window, control-right deletes it.
|
||||
(global-set-mouse '(modeline control left) 'mouse-delete-other-windows)
|
||||
(global-set-mouse '(modeline control right) 'mouse-delete-window)
|
||||
|
||||
;; in case of confusion, just select it:
|
||||
(global-set-mouse '(modeline control left right)'mouse-select-window)
|
||||
|
||||
;; even without confusion (and without the keyboard) select it:
|
||||
(global-set-mouse '(modeline left right) 'mouse-select-window)
|
||||
|
||||
;; And the help menu:
|
||||
(global-set-mouse '(modeline shift control meta right) 'mouse-help-region)
|
||||
(global-set-mouse '(modeline double control meta right) 'mouse-help-region)
|
||||
|
||||
;;;
|
||||
;;; Minibuffer Mousemap
|
||||
;;; Demonstrating some variety:
|
||||
;;;
|
||||
(global-set-mouse '(minibuffer left) 'mini-move-point)
|
||||
|
||||
(global-set-mouse '(minibuffer middle) 'mini-set-mark-and-stuff)
|
||||
|
||||
(global-set-mouse '(minibuffer shift middle) '(select-previous-complex-command))
|
||||
(global-set-mouse '(minibuffer double middle) '(select-previous-complex-command))
|
||||
(global-set-mouse '(minibuffer control middle) '(next-complex-command 1))
|
||||
(global-set-mouse '(minibuffer meta middle) '(previous-complex-command 1))
|
||||
|
||||
(global-set-mouse '(minibuffer right) 'minibuffer-menu-eval)
|
||||
|
||||
(global-set-mouse '(minibuffer shift control meta right) 'mouse-help-region)
|
||||
(global-set-mouse '(minibuffer double control meta right) 'mouse-help-region)
|
||||
|
||||
71
lisp/sun-keys.el
Normal file
71
lisp/sun-keys.el
Normal file
@ -0,0 +1,71 @@
|
||||
;;;
|
||||
;;; Support (cleanly) for Sun function keys. Provides help facilities,
|
||||
;;; better diagnostics, etc.
|
||||
;;;
|
||||
;;; To use: make sure your .ttyswrc binds 'F1' to <ESC> * F1 <CR> and so on.
|
||||
;;; load this lot from your start_up
|
||||
;;;
|
||||
;;;
|
||||
;;; Copyright (C) 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.
|
||||
;;;
|
||||
;;; Batten@uk.ac.bham.multics (Ian G. Batten)
|
||||
;;;
|
||||
|
||||
(defun sun-function-keys-dispatch (arg)
|
||||
"Dispatcher for function keys."
|
||||
(interactive "p")
|
||||
(let* ((key-stroke (read t))
|
||||
(command (assq key-stroke sun-function-keys-command-list)))
|
||||
(cond (command (funcall (cdr command) arg))
|
||||
(t (error "Unbound function key %s" key-stroke)))))
|
||||
|
||||
(defvar sun-function-keys-command-list
|
||||
'((F1 . sun-function-keys-describe-bindings)
|
||||
(R8 . previous-line) ; arrow keys
|
||||
(R10 . backward-char)
|
||||
(R12 . forward-char)
|
||||
(R14 . next-line)))
|
||||
|
||||
(defun sun-function-keys-bind-key (arg1 arg2)
|
||||
"Bind a specified key."
|
||||
(interactive "xFunction Key Cap Label:
|
||||
CCommand To Use:")
|
||||
(setq sun-function-keys-command-list
|
||||
(cons (cons arg1 arg2) sun-function-keys-command-list)))
|
||||
|
||||
(defun sun-function-keys-describe-bindings (arg)
|
||||
"Describe the function key bindings we're running"
|
||||
(interactive)
|
||||
(with-output-to-temp-buffer "*Help*"
|
||||
(sun-function-keys-write-bindings
|
||||
(sort (copy-sequence sun-function-keys-command-list)
|
||||
'(lambda (x y) (string-lessp (car x) (car y)))))))
|
||||
|
||||
(defun sun-function-keys-write-bindings (list)
|
||||
(cond ((null list)
|
||||
t)
|
||||
(t
|
||||
(princ (format "%s: %s\n"
|
||||
(car (car list))
|
||||
(cdr (car list))))
|
||||
(sun-function-keys-write-bindings (cdr list)))))
|
||||
|
||||
(global-set-key "\e*" 'sun-function-keys-dispatch)
|
||||
|
||||
(make-variable-buffer-local 'sun-function-keys-command-list)
|
||||
668
lisp/term/sun-mouse.el
Normal file
668
lisp/term/sun-mouse.el
Normal file
@ -0,0 +1,668 @@
|
||||
;; Mouse handling for Sun windows
|
||||
;; Copyright (C) 1987 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.
|
||||
|
||||
;;; Jeff Peck, Sun Microsystems, Jan 1987.
|
||||
;;; Original idea by Stan Jefferson
|
||||
|
||||
(provide 'sun-mouse)
|
||||
|
||||
;;;
|
||||
;;; Modelled after the GNUEMACS keymap interface.
|
||||
;;;
|
||||
;;; User Functions:
|
||||
;;; make-mousemap, copy-mousemap,
|
||||
;;; define-mouse, global-set-mouse, local-set-mouse,
|
||||
;;; use-global-mousemap, use-local-mousemap,
|
||||
;;; mouse-lookup, describe-mouse-bindings
|
||||
;;;
|
||||
;;; Options:
|
||||
;;; extra-click-wait, scrollbar-width
|
||||
;;;
|
||||
|
||||
(defvar extra-click-wait 150
|
||||
"*Number of milliseconds to wait for an extra click.
|
||||
Set this to zero if you don't want chords or double clicks.")
|
||||
|
||||
(defvar scrollbar-width 5
|
||||
"*The character width of the scrollbar.
|
||||
The cursor is deemed to be in the right edge scrollbar if it is this near the
|
||||
right edge, and more than two chars past the end of the indicated line.
|
||||
Setting to nil limits the scrollbar to the edge or vertical dividing bar.")
|
||||
|
||||
;;;
|
||||
;;; Mousemaps
|
||||
;;;
|
||||
(defun make-mousemap ()
|
||||
"Returns a new mousemap."
|
||||
(cons 'mousemap nil))
|
||||
|
||||
(defun copy-mousemap (mousemap)
|
||||
"Return a copy of mousemap."
|
||||
(copy-alist mousemap))
|
||||
|
||||
(defun define-mouse (mousemap mouse-list def)
|
||||
"Args MOUSEMAP, MOUSE-LIST, DEF. Define MOUSE-LIST in MOUSEMAP as DEF.
|
||||
MOUSE-LIST is a list of atoms specifing a mouse hit according to these rules:
|
||||
* One of these atoms specifies the active region of the definition.
|
||||
text, scrollbar, modeline, minibuffer
|
||||
* One or two or these atoms specify the button or button combination.
|
||||
left, middle, right, double
|
||||
* Any combination of these atoms specify the active shift keys.
|
||||
control, shift, meta
|
||||
* With a single unshifted button, you can add
|
||||
up
|
||||
to indicate an up-click.
|
||||
The atom `double' is used with a button designator to denote a double click.
|
||||
Two button chords are denoted by listing the two buttons.
|
||||
See sun-mouse-handler for the treatment of the form DEF."
|
||||
(mousemap-set (mouse-list-to-mouse-code mouse-list) mousemap def))
|
||||
|
||||
(defun global-set-mouse (mouse-list def)
|
||||
"Give MOUSE-EVENT-LIST a local definition of DEF.
|
||||
See define-mouse for a description of MOUSE-EVENT-LIST and DEF.
|
||||
Note that if MOUSE-EVENT-LIST has a local definition in the current buffer,
|
||||
that local definition will continue to shadow any global definition."
|
||||
(interactive "xMouse event: \nxDefinition: ")
|
||||
(define-mouse current-global-mousemap mouse-list def))
|
||||
|
||||
(defun local-set-mouse (mouse-list def)
|
||||
"Give MOUSE-EVENT-LIST a local definition of DEF.
|
||||
See define-mouse for a description of the arguments.
|
||||
The definition goes in the current buffer's local mousemap.
|
||||
Normally buffers in the same major mode share a local mousemap."
|
||||
(interactive "xMouse event: \nxDefinition: ")
|
||||
(if (null current-local-mousemap)
|
||||
(setq current-local-mousemap (make-mousemap)))
|
||||
(define-mouse current-local-mousemap mouse-list def))
|
||||
|
||||
(defun use-global-mousemap (mousemap)
|
||||
"Selects MOUSEMAP as the global mousemap."
|
||||
(setq current-global-mousemap mousemap))
|
||||
|
||||
(defun use-local-mousemap (mousemap)
|
||||
"Selects MOUSEMAP as the local mousemap.
|
||||
nil for MOUSEMAP means no local mousemap."
|
||||
(setq current-local-mousemap mousemap))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Interface to the Mouse encoding defined in Emacstool.c
|
||||
;;;
|
||||
;;; Called when mouse-prefix is sent to emacs, additional
|
||||
;;; information is read in as a list (button x y time-delta)
|
||||
;;;
|
||||
;;; First, some generally useful functions:
|
||||
;;;
|
||||
|
||||
(defun logtest (x y)
|
||||
"True if any bits set in X are also set in Y.
|
||||
Just like the Common Lisp function of the same name."
|
||||
(not (zerop (logand x y))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Hit accessors.
|
||||
;;;
|
||||
|
||||
(defconst sm::ButtonBits 7) ; Lowest 3 bits.
|
||||
(defconst sm::ShiftmaskBits 56) ; Second lowest 3 bits (56 = 63 - 7).
|
||||
(defconst sm::DoubleBits 64) ; Bit 7.
|
||||
(defconst sm::UpBits 128) ; Bit 8.
|
||||
|
||||
;;; All the useful code bits
|
||||
(defmacro sm::hit-code (hit)
|
||||
(` (nth 0 (, hit))))
|
||||
;;; The button, or buttons if a chord.
|
||||
(defmacro sm::hit-button (hit)
|
||||
(` (logand sm::ButtonBits (nth 0 (, hit)))))
|
||||
;;; The shift, control, and meta flags.
|
||||
(defmacro sm::hit-shiftmask (hit)
|
||||
(` (logand sm::ShiftmaskBits (nth 0 (, hit)))))
|
||||
;;; Set if a double click (but not a chord).
|
||||
(defmacro sm::hit-double (hit)
|
||||
(` (logand sm::DoubleBits (nth 0 (, hit)))))
|
||||
;;; Set on button release (as opposed to button press).
|
||||
(defmacro sm::hit-up (hit)
|
||||
(` (logand sm::UpBits (nth 0 (, hit)))))
|
||||
;;; Screen x position.
|
||||
(defmacro sm::hit-x (hit) (list 'nth 1 hit))
|
||||
;;; Screen y position.
|
||||
(defmacro sm::hit-y (hit) (list 'nth 2 hit))
|
||||
;;; Millisconds since last hit.
|
||||
(defmacro sm::hit-delta (hit) (list 'nth 3 hit))
|
||||
|
||||
(defmacro sm::hit-up-p (hit) ; A predicate.
|
||||
(` (not (zerop (sm::hit-up (, hit))))))
|
||||
|
||||
;;;
|
||||
;;; Loc accessors. for sm::window-xy
|
||||
;;;
|
||||
(defmacro sm::loc-w (loc) (list 'nth 0 loc))
|
||||
(defmacro sm::loc-x (loc) (list 'nth 1 loc))
|
||||
(defmacro sm::loc-y (loc) (list 'nth 2 loc))
|
||||
|
||||
(defmacro eval-in-buffer (buffer &rest forms)
|
||||
"Macro to switches to BUFFER, evaluates FORMS, returns to original buffer."
|
||||
;; When you don't need the complete window context of eval-in-window
|
||||
(` (let ((StartBuffer (current-buffer)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(set-buffer (, buffer))
|
||||
(,@ forms))
|
||||
(set-buffer StartBuffer)))))
|
||||
|
||||
(put 'eval-in-buffer 'lisp-indent-function 1)
|
||||
|
||||
;;; this is used extensively by sun-fns.el
|
||||
;;;
|
||||
(defmacro eval-in-window (window &rest forms)
|
||||
"Switch to WINDOW, evaluate FORMS, return to original window."
|
||||
(` (let ((OriginallySelectedWindow (selected-window)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(select-window (, window))
|
||||
(,@ forms))
|
||||
(select-window OriginallySelectedWindow)))))
|
||||
(put 'eval-in-window 'lisp-indent-function 1)
|
||||
|
||||
;;;
|
||||
;;; handy utility, generalizes window_loop
|
||||
;;;
|
||||
|
||||
;;; It's a macro (and does not evaluate its arguments).
|
||||
(defmacro eval-in-windows (form &optional yesmini)
|
||||
"Switches to each window and evaluates FORM. Optional argument
|
||||
YESMINI says to include the minibuffer as a window.
|
||||
This is a macro, and does not evaluate its arguments."
|
||||
(` (let ((OriginallySelectedWindow (selected-window)))
|
||||
(unwind-protect
|
||||
(while (progn
|
||||
(, form)
|
||||
(not (eq OriginallySelectedWindow
|
||||
(select-window
|
||||
(next-window nil (, yesmini)))))))
|
||||
(select-window OriginallySelectedWindow)))))
|
||||
(put 'eval-in-window 'lisp-indent-function 0)
|
||||
|
||||
(defun move-to-loc (x y)
|
||||
"Move cursor to window location X, Y.
|
||||
Handles wrapped and horizontally scrolled lines correctly."
|
||||
(move-to-window-line y)
|
||||
;; window-line-end expects this to return the window column it moved to.
|
||||
(let ((cc (current-column))
|
||||
(nc (move-to-column
|
||||
(if (zerop (window-hscroll))
|
||||
(+ (current-column)
|
||||
(min (- (window-width) 2) ; To stay on the line.
|
||||
x))
|
||||
(+ (window-hscroll) -1
|
||||
(min (1- (window-width)) ; To stay on the line.
|
||||
x))))))
|
||||
(- nc cc)))
|
||||
|
||||
|
||||
(defun minibuffer-window-p (window)
|
||||
"True iff this WINDOW is minibuffer."
|
||||
(= (screen-height)
|
||||
(nth 3 (window-edges window)) ; The bottom edge.
|
||||
))
|
||||
|
||||
|
||||
(defun sun-mouse-handler (&optional hit)
|
||||
"Evaluates the function or list associated with a mouse hit.
|
||||
Expecting to read a hit, which is a list: (button x y delta).
|
||||
A form bound to button by define-mouse is found by mouse-lookup.
|
||||
The variables: *mouse-window*, *mouse-x*, *mouse-y* are bound.
|
||||
If the form is a symbol (symbolp), it is funcall'ed with *mouse-window*,
|
||||
*mouse-x*, and *mouse-y* as arguments; if the form is a list (listp),
|
||||
the form is eval'ed; if the form is neither of these, it is an error.
|
||||
Returns nil."
|
||||
(interactive)
|
||||
(if (null hit) (setq hit (sm::combined-hits)))
|
||||
(let ((loc (sm::window-xy (sm::hit-x hit) (sm::hit-y hit))))
|
||||
(let ((*mouse-window* (sm::loc-w loc))
|
||||
(*mouse-x* (sm::loc-x loc))
|
||||
(*mouse-y* (sm::loc-y loc))
|
||||
(mouse-code (mouse-event-code hit loc)))
|
||||
(let ((form (eval-in-buffer (window-buffer *mouse-window*)
|
||||
(mouse-lookup mouse-code))))
|
||||
(cond ((null form)
|
||||
(if (not (sm::hit-up-p hit)) ; undefined up hits are ok.
|
||||
(error "Undefined mouse event: %s"
|
||||
(prin1-to-string
|
||||
(mouse-code-to-mouse-list mouse-code)))))
|
||||
((symbolp form)
|
||||
(setq this-command form)
|
||||
(funcall form *mouse-window* *mouse-x* *mouse-y*))
|
||||
((listp form)
|
||||
(setq this-command (car form))
|
||||
(eval form))
|
||||
(t
|
||||
(error "Mouse action must be symbol or list, but was: %s"
|
||||
form))))))
|
||||
;; Don't let 'sun-mouse-handler get on last-command,
|
||||
;; since this function should be transparent.
|
||||
(if (eq this-command 'sun-mouse-handler)
|
||||
(setq this-command last-command))
|
||||
;; (message (prin1-to-string this-command)) ; to see what your buttons did
|
||||
nil)
|
||||
|
||||
(defun sm::combined-hits ()
|
||||
"Read and return next mouse-hit, include possible double click"
|
||||
(let ((hit1 (mouse-hit-read)))
|
||||
(if (not (sm::hit-up-p hit1)) ; Up hits dont start doubles or chords.
|
||||
(let ((hit2 (mouse-second-hit extra-click-wait)))
|
||||
(if hit2 ; we cons'd it, we can smash it.
|
||||
; (setf (sm::hit-code hit1) (logior (sm::hit-code hit1) ...))
|
||||
(setcar hit1 (logior (sm::hit-code hit1)
|
||||
(sm::hit-code hit2)
|
||||
(if (= (sm::hit-button hit1)
|
||||
(sm::hit-button hit2))
|
||||
sm::DoubleBits 0))))))
|
||||
hit1))
|
||||
|
||||
(defun mouse-hit-read ()
|
||||
"Read mouse-hit list from keyboard. Like (read 'read-char),
|
||||
but that uses minibuffer, and mucks up last-command."
|
||||
(let ((char-list nil) (char nil))
|
||||
(while (not (equal 13 ; Carriage return.
|
||||
(prog1 (setq char (read-char))
|
||||
(setq char-list (cons char char-list))))))
|
||||
(read (mapconcat 'char-to-string (nreverse char-list) ""))
|
||||
))
|
||||
|
||||
;;; Second Click Hackery....
|
||||
;;; if prefix is not mouse-prefix, need a way to unread the char...
|
||||
;;; or else have mouse flush input queue, or else need a peek at next char.
|
||||
|
||||
;;; There is no peek, but since one character can be unread, we only
|
||||
;;; have to flush the queue when the command after a mouse click
|
||||
;;; starts with mouse-prefix1 (see below).
|
||||
;;; Something to do later: We could buffer the read commands and
|
||||
;;; execute them ourselves after doing the mouse command (using
|
||||
;;; lookup-key ??).
|
||||
|
||||
(defvar mouse-prefix1 24 ; C-x
|
||||
"First char of mouse-prefix. Used to detect double clicks and chords.")
|
||||
|
||||
(defvar mouse-prefix2 0 ; C-@
|
||||
"Second char of mouse-prefix. Used to detect double clicks and chords.")
|
||||
|
||||
|
||||
(defun mouse-second-hit (hit-wait)
|
||||
"Returns the next mouse hit occurring within HIT-WAIT milliseconds."
|
||||
(if (sit-for-millisecs hit-wait) nil ; No input within hit-wait millisecs.
|
||||
(let ((pc1 (read-char)))
|
||||
(if (or (not (equal pc1 mouse-prefix1))
|
||||
(sit-for-millisecs 3)) ; a mouse prefix will have second char
|
||||
(progn (setq unread-command-char pc1) ; Can get away with one unread.
|
||||
nil) ; Next input not mouse event.
|
||||
(let ((pc2 (read-char)))
|
||||
(if (not (equal pc2 mouse-prefix2))
|
||||
(progn (setq unread-command-char pc1) ; put back the ^X
|
||||
;;; Too bad can't do two: (setq unread-command-char (list pc1 pc2))
|
||||
(ding) ; user will have to retype that pc2.
|
||||
nil) ; This input is not a mouse event.
|
||||
;; Next input has mouse prefix and is within time limit.
|
||||
(let ((new-hit (mouse-hit-read))) ; Read the new hit.
|
||||
(if (sm::hit-up-p new-hit) ; Ignore up events when timing.
|
||||
(mouse-second-hit (- hit-wait (sm::hit-delta new-hit)))
|
||||
new-hit ; New down hit within limit, return it.
|
||||
))))))))
|
||||
|
||||
(defun sm::window-xy (x y)
|
||||
"Find window containing screen coordinates X and Y.
|
||||
Returns list (window x y) where x and y are relative to window."
|
||||
(or
|
||||
(catch 'found
|
||||
(eval-in-windows
|
||||
(let ((we (window-edges (selected-window))))
|
||||
(let ((le (nth 0 we))
|
||||
(te (nth 1 we))
|
||||
(re (nth 2 we))
|
||||
(be (nth 3 we)))
|
||||
(if (= re (screen-width))
|
||||
;; include the continuation column with this window
|
||||
(setq re (1+ re)))
|
||||
(if (= be (screen-height))
|
||||
;; include partial line at bottom of screen with this window
|
||||
;; id est, if window is not multple of char size.
|
||||
(setq be (1+ be)))
|
||||
|
||||
(if (and (>= x le) (< x re)
|
||||
(>= y te) (< y be))
|
||||
(throw 'found
|
||||
(list (selected-window) (- x le) (- y te))))))
|
||||
t)) ; include minibuffer in eval-in-windows
|
||||
;;If x,y from a real mouse click, we shouldn't get here.
|
||||
(list nil x y)
|
||||
))
|
||||
|
||||
(defun sm::window-region (loc)
|
||||
"Parse LOC into a region symbol.
|
||||
Returns one of (text scrollbar modeline minibuffer)"
|
||||
(let ((w (sm::loc-w loc))
|
||||
(x (sm::loc-x loc))
|
||||
(y (sm::loc-y loc)))
|
||||
(let ((right (1- (window-width w)))
|
||||
(bottom (1- (window-height w))))
|
||||
(cond ((minibuffer-window-p w) 'minibuffer)
|
||||
((>= y bottom) 'modeline)
|
||||
((>= x right) 'scrollbar)
|
||||
;; far right column (window seperator) is always a scrollbar
|
||||
((and scrollbar-width
|
||||
;; mouse within scrollbar-width of edge.
|
||||
(>= x (- right scrollbar-width))
|
||||
;; mouse a few chars past the end of line.
|
||||
(>= x (+ 2 (window-line-end w x y))))
|
||||
'scrollbar)
|
||||
(t 'text)))))
|
||||
|
||||
(defun window-line-end (w x y)
|
||||
"Return WINDOW column (ignore X) containing end of line Y"
|
||||
(eval-in-window w (save-excursion (move-to-loc (screen-width) y))))
|
||||
|
||||
;;;
|
||||
;;; The encoding of mouse events into a mousemap.
|
||||
;;; These values must agree with coding in emacstool:
|
||||
;;;
|
||||
(defconst sm::keyword-alist
|
||||
'((left . 1) (middle . 2) (right . 4)
|
||||
(shift . 8) (control . 16) (meta . 32) (double . 64) (up . 128)
|
||||
(text . 256) (scrollbar . 512) (modeline . 1024) (minibuffer . 2048)
|
||||
))
|
||||
|
||||
(defun mouse-event-code (hit loc)
|
||||
"Maps MOUSE-HIT and LOC into a mouse-code."
|
||||
;;;Region is a code for one of text, modeline, scrollbar, or minibuffer.
|
||||
(logior (sm::hit-code hit)
|
||||
(mouse-region-to-code (sm::window-region loc))))
|
||||
|
||||
(defun mouse-region-to-code (region)
|
||||
"Returns partial mouse-code for specified REGION."
|
||||
(cdr (assq region sm::keyword-alist)))
|
||||
|
||||
(defun mouse-list-to-mouse-code (mouse-list)
|
||||
"Map a MOUSE-LIST to a mouse-code."
|
||||
(apply 'logior
|
||||
(mapcar (function (lambda (x)
|
||||
(cdr (assq x sm::keyword-alist))))
|
||||
mouse-list)))
|
||||
|
||||
(defun mouse-code-to-mouse-list (mouse-code)
|
||||
"Map a MOUSE-CODE to a mouse-list."
|
||||
(apply 'nconc (mapcar
|
||||
(function (lambda (x)
|
||||
(if (logtest mouse-code (cdr x))
|
||||
(list (car x)))))
|
||||
sm::keyword-alist)))
|
||||
|
||||
(defun mousemap-set (code mousemap value)
|
||||
(let* ((alist (cdr mousemap))
|
||||
(assq-result (assq code alist)))
|
||||
(if assq-result
|
||||
(setcdr assq-result value)
|
||||
(setcdr mousemap (cons (cons code value) alist)))))
|
||||
|
||||
(defun mousemap-get (code mousemap)
|
||||
(cdr (assq code (cdr mousemap))))
|
||||
|
||||
(defun mouse-lookup (mouse-code)
|
||||
"Look up MOUSE-EVENT and return the definition. nil means undefined."
|
||||
(or (mousemap-get mouse-code current-local-mousemap)
|
||||
(mousemap-get mouse-code current-global-mousemap)))
|
||||
|
||||
;;;
|
||||
;;; I (jpeck) don't understand the utility of the next four functions
|
||||
;;; ask Steven Greenbaum <froud@kestrel>
|
||||
;;;
|
||||
(defun mouse-mask-lookup (mask list)
|
||||
"Args MASK (a bit mask) and LIST (a list of (code . form) pairs).
|
||||
Returns a list of elements of LIST whose code or'ed with MASK is non-zero."
|
||||
(let ((result nil))
|
||||
(while list
|
||||
(if (logtest mask (car (car list)))
|
||||
(setq result (cons (car list) result)))
|
||||
(setq list (cdr list)))
|
||||
result))
|
||||
|
||||
(defun mouse-union (l l-unique)
|
||||
"Return the union of list of mouse (code . form) pairs L and L-UNIQUE,
|
||||
where L-UNIQUE is considered to be union'ized already."
|
||||
(let ((result l-unique))
|
||||
(while l
|
||||
(let ((code-form-pair (car l)))
|
||||
(if (not (assq (car code-form-pair) result))
|
||||
(setq result (cons code-form-pair result))))
|
||||
(setq l (cdr l)))
|
||||
result))
|
||||
|
||||
(defun mouse-union-first-prefered (l1 l2)
|
||||
"Return the union of lists of mouse (code . form) pairs L1 and L2,
|
||||
based on the code's, with preference going to elements in L1."
|
||||
(mouse-union l2 (mouse-union l1 nil)))
|
||||
|
||||
(defun mouse-code-function-pairs-of-region (region)
|
||||
"Return a list of (code . function) pairs, where each code is
|
||||
currently set in the REGION."
|
||||
(let ((mask (mouse-region-to-code region)))
|
||||
(mouse-union-first-prefered
|
||||
(mouse-mask-lookup mask (cdr current-local-mousemap))
|
||||
(mouse-mask-lookup mask (cdr current-global-mousemap))
|
||||
)))
|
||||
|
||||
;;;
|
||||
;;; Functions for DESCRIBE-MOUSE-BINDINGS
|
||||
;;; And other mouse documentation functions
|
||||
;;; Still need a good procedure to print out a help sheet in readable format.
|
||||
;;;
|
||||
|
||||
(defun one-line-doc-string (function)
|
||||
"Returns first line of documentation string for FUNCTION.
|
||||
If there is no documentation string, then the string
|
||||
\"No documentation\" is returned."
|
||||
(while (consp function) (setq function (car function)))
|
||||
(let ((doc (documentation function)))
|
||||
(if (null doc)
|
||||
"No documentation."
|
||||
(string-match "^.*$" doc)
|
||||
(substring doc 0 (match-end 0)))))
|
||||
|
||||
(defun print-mouse-format (binding)
|
||||
(princ (car binding))
|
||||
(princ ": ")
|
||||
(mapcar (function
|
||||
(lambda (mouse-list)
|
||||
(princ mouse-list)
|
||||
(princ " ")))
|
||||
(cdr binding))
|
||||
(terpri)
|
||||
(princ " ")
|
||||
(princ (one-line-doc-string (car binding)))
|
||||
(terpri)
|
||||
)
|
||||
|
||||
(defun print-mouse-bindings (region)
|
||||
"Prints mouse-event bindings for REGION."
|
||||
(mapcar 'print-mouse-format (sm::event-bindings region)))
|
||||
|
||||
(defun sm::event-bindings (region)
|
||||
"Returns an alist of (function . (mouse-list1 ... mouse-listN)) for REGION,
|
||||
where each mouse-list is bound to the function in REGION."
|
||||
(let ((mouse-bindings (mouse-code-function-pairs-of-region region))
|
||||
(result nil))
|
||||
(while mouse-bindings
|
||||
(let* ((code-function-pair (car mouse-bindings))
|
||||
(current-entry (assoc (cdr code-function-pair) result)))
|
||||
(if current-entry
|
||||
(setcdr current-entry
|
||||
(cons (mouse-code-to-mouse-list (car code-function-pair))
|
||||
(cdr current-entry)))
|
||||
(setq result (cons (cons (cdr code-function-pair)
|
||||
(list (mouse-code-to-mouse-list
|
||||
(car code-function-pair))))
|
||||
result))))
|
||||
(setq mouse-bindings (cdr mouse-bindings))
|
||||
)
|
||||
result))
|
||||
|
||||
(defun describe-mouse-bindings ()
|
||||
"Lists all current mouse-event bindings."
|
||||
(interactive)
|
||||
(with-output-to-temp-buffer "*Help*"
|
||||
(princ "Text Region") (terpri)
|
||||
(princ "---- ------") (terpri)
|
||||
(print-mouse-bindings 'text) (terpri)
|
||||
(princ "Modeline Region") (terpri)
|
||||
(princ "-------- ------") (terpri)
|
||||
(print-mouse-bindings 'modeline) (terpri)
|
||||
(princ "Scrollbar Region") (terpri)
|
||||
(princ "--------- ------") (terpri)
|
||||
(print-mouse-bindings 'scrollbar)))
|
||||
|
||||
(defun describe-mouse-briefly (mouse-list)
|
||||
"Print a short description of the function bound to MOUSE-LIST."
|
||||
(interactive "xDescibe mouse list briefly: ")
|
||||
(let ((function (mouse-lookup (mouse-list-to-mouse-code mouse-list))))
|
||||
(if function
|
||||
(message "%s runs the command %s" mouse-list function)
|
||||
(message "%s is undefined" mouse-list))))
|
||||
|
||||
(defun mouse-help-menu (function-and-binding)
|
||||
(cons (prin1-to-string (car function-and-binding))
|
||||
(menu-create ; Two sub-menu items of form ("String" . nil)
|
||||
(list (list (one-line-doc-string (car function-and-binding)))
|
||||
(list (prin1-to-string (cdr function-and-binding)))))))
|
||||
|
||||
(defun mouse-help-region (w x y &optional region)
|
||||
"Displays a menu of mouse functions callable in this region."
|
||||
(let* ((region (or region (sm::window-region (list w x y))))
|
||||
(mlist (mapcar (function mouse-help-menu)
|
||||
(sm::event-bindings region)))
|
||||
(menu (menu-create (cons (list (symbol-name region)) mlist)))
|
||||
(item (sun-menu-evaluate w 0 y menu))
|
||||
)))
|
||||
|
||||
;;;
|
||||
;;; Menu interface functions
|
||||
;;;
|
||||
;;; use defmenu, because this interface is subject to change
|
||||
;;; really need a menu-p, but we use vectorp and the context...
|
||||
;;;
|
||||
(defun menu-create (items)
|
||||
"Functional form for defmenu, given a list of ITEMS returns a menu.
|
||||
Each ITEM is a (STRING . VALUE) pair."
|
||||
(apply 'vector items)
|
||||
)
|
||||
|
||||
(defmacro defmenu (menu &rest itemlist)
|
||||
"Defines MENU to be a menu, the ITEMS are (STRING . VALUE) pairs.
|
||||
See sun-menu-evaluate for interpretation of ITEMS."
|
||||
(list 'defconst menu (funcall 'menu-create itemlist))
|
||||
)
|
||||
|
||||
(defun sun-menu-evaluate (*menu-window* *menu-x* *menu-y* menu)
|
||||
"Display a pop-up menu in WINDOW at X Y and evaluate selected item
|
||||
of MENU. MENU (or its symbol-value) should be a menu defined by defmenu.
|
||||
A menu ITEM is a (STRING . FORM) pair;
|
||||
the FORM associated with the selected STRING is evaluated,
|
||||
and the resulting value is returned. Generally these FORMs are
|
||||
evaluated for their side-effects rather than their values.
|
||||
If the selected form is a menu or a symbol whose value is a menu,
|
||||
then it is displayed and evaluated as a pullright menu item.
|
||||
If the the FORM of the first ITEM is nil, the STRING of the item
|
||||
is used as a label for the menu, i.e. it's inverted and not selectible."
|
||||
|
||||
(if (symbolp menu) (setq menu (symbol-value menu)))
|
||||
(eval (sun-menu-internal *menu-window* *menu-x* *menu-y* 4 menu)))
|
||||
|
||||
(defun sun-get-frame-data (code)
|
||||
"Sends the tty-sub-window escape sequence CODE to terminal,
|
||||
and returns a cons of the two numbers in returned escape sequence.
|
||||
That is it returns (cons <car> <cdr>) from \"\\E[n;<car>;<cdr>t\".
|
||||
CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars."
|
||||
(send-string-to-terminal (concat "\033[" (int-to-string code) "t"))
|
||||
(let (char str x y)
|
||||
(while (not (equal 116 (setq char (read-char)))) ; #\t = 116
|
||||
(setq str (cons char str)))
|
||||
(setq str (mapconcat 'char-to-string (nreverse str) ""))
|
||||
(string-match ";[0-9]*" str)
|
||||
(setq y (substring str (1+ (match-beginning 0)) (match-end 0)))
|
||||
(setq str (substring str (match-end 0)))
|
||||
(string-match ";[0-9]*" str)
|
||||
(setq x (substring str (1+ (match-beginning 0)) (match-end 0)))
|
||||
(cons (string-to-int y) (string-to-int x))))
|
||||
|
||||
(defun sm::font-size ()
|
||||
"Returns font size in pixels: (cons Ysize Xsize)"
|
||||
(let ((pix (sun-get-frame-data 14)) ; returns size in pixels
|
||||
(chr (sun-get-frame-data 18))) ; returns size in chars
|
||||
(cons (/ (car pix) (car chr)) (/ (cdr pix) (cdr chr)))))
|
||||
|
||||
(defvar sm::menu-kludge-x nil
|
||||
"Cached frame-to-window X-Offset for sm::menu-kludge")
|
||||
(defvar sm::menu-kludge-y nil
|
||||
"Cached frame-to-window Y-Offset for sm::menu-kludge")
|
||||
|
||||
(defun sm::menu-kludge ()
|
||||
"If sunfns.c uses <Menu_Base_Kludge> this function must be here!"
|
||||
(or sm::menu-kludge-y
|
||||
(let ((fs (sm::font-size)))
|
||||
(setq sm::menu-kludge-y (+ 8 (car fs)) ; a title line and borders
|
||||
sm::menu-kludge-x 4))) ; best values depend on .defaults/Menu
|
||||
(let ((wl (sun-get-frame-data 13))) ; returns frame location
|
||||
(cons (+ (car wl) sm::menu-kludge-y)
|
||||
(+ (cdr wl) sm::menu-kludge-x))))
|
||||
|
||||
;;;
|
||||
;;; Function interface to selection/region
|
||||
;;; primative functions are defined in sunfns.c
|
||||
;;;
|
||||
(defun sun-yank-selection ()
|
||||
"Set mark and yank the contents of the current sunwindows selection
|
||||
into the current buffer at point."
|
||||
(interactive "*")
|
||||
(set-mark-command nil)
|
||||
(insert-string (sun-get-selection)))
|
||||
|
||||
(defun sun-select-region (beg end)
|
||||
"Set the sunwindows selection to the region in the current buffer."
|
||||
(interactive "r")
|
||||
(sun-set-selection (buffer-substring beg end)))
|
||||
|
||||
;;;
|
||||
;;; Support for emacstool
|
||||
;;; This closes the window instead of stopping emacs.
|
||||
;;;
|
||||
(defun suspend-emacstool (&optional stuffstring)
|
||||
"If running under as a detached process emacstool,
|
||||
you don't want to suspend (there is no way to resume),
|
||||
just close the window, and wait for reopening."
|
||||
(interactive)
|
||||
(run-hooks 'suspend-hook)
|
||||
(if stuffstring (send-string-to-terminal stuffstring))
|
||||
(send-string-to-terminal "\033[2t") ; To close EmacsTool window.
|
||||
(run-hooks 'suspend-resume-hook))
|
||||
;;;
|
||||
;;; initialize mouse maps
|
||||
;;;
|
||||
|
||||
(make-variable-buffer-local 'current-local-mousemap)
|
||||
(setq-default current-local-mousemap nil)
|
||||
(defvar current-global-mousemap (make-mousemap))
|
||||
207
lisp/term/sup-mouse.el
Normal file
207
lisp/term/sup-mouse.el
Normal file
@ -0,0 +1,207 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ;;
|
||||
;; File: sup-mouse.el ;;
|
||||
;; Author: Wolfgang Rupprecht ;;
|
||||
;; Created: Fri Nov 21 19:22:22 1986 ;;
|
||||
;; Contents: supdup mouse support for lisp machines ;;
|
||||
;; ;;
|
||||
;; (from code originally written by John Robinson@bbn for the bitgraph) ;;
|
||||
;; ;;
|
||||
;; $Log$ ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; GNU Emacs code for lambda/supdup mouse
|
||||
;; Copyright (C) Free Software Foundation 1985, 1986
|
||||
|
||||
;; 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.
|
||||
|
||||
;;; User customization option:
|
||||
|
||||
(defvar sup-mouse-fast-select-window nil
|
||||
"*Non-nil for mouse hits to select new window, then execute; else just select.")
|
||||
|
||||
(defconst mouse-left 0)
|
||||
(defconst mouse-center 1)
|
||||
(defconst mouse-right 2)
|
||||
|
||||
(defconst mouse-2left 4)
|
||||
(defconst mouse-2center 5)
|
||||
(defconst mouse-2right 6)
|
||||
|
||||
(defconst mouse-3left 8)
|
||||
(defconst mouse-3center 9)
|
||||
(defconst mouse-3right 10)
|
||||
|
||||
;;; Defuns:
|
||||
|
||||
(defun sup-mouse-report ()
|
||||
"This function is called directly by the mouse, it parses and
|
||||
executes the mouse commands.
|
||||
|
||||
L move point * |---- These apply for mouse click in a window.
|
||||
2L delete word |
|
||||
3L copy word | If sup-mouse-fast-select-window is nil,
|
||||
C move point and yank * | just selects that window.
|
||||
2C yank pop |
|
||||
R set mark * |
|
||||
2R delete region |
|
||||
3R copy region |
|
||||
|
||||
on modeline on \"scroll bar\" in minibuffer
|
||||
L scroll-up line to top execute-extended-command
|
||||
C proportional goto-char line to middle mouse-help
|
||||
R scroll-down line to bottom eval-expression"
|
||||
|
||||
(interactive)
|
||||
(let*
|
||||
;; expect a string of <esc>:<buttons>;<x-pos>;<y-pos>c
|
||||
((buttons (sup-get-tty-num ?\;))
|
||||
(x (sup-get-tty-num ?\;))
|
||||
(y (sup-get-tty-num ?c))
|
||||
(window (sup-pos-to-window x y))
|
||||
(edges (window-edges window))
|
||||
(old-window (selected-window))
|
||||
(in-minibuf-p (eq y (1- (screen-height))))
|
||||
(same-window-p (and (not in-minibuf-p) (eq window old-window)))
|
||||
(in-modeline-p (eq y (1- (nth 3 edges))))
|
||||
(in-scrollbar-p (>= x (1- (nth 2 edges)))))
|
||||
(setq x (- x (nth 0 edges)))
|
||||
(setq y (- y (nth 1 edges)))
|
||||
|
||||
; (error "mouse-hit %d %d %d" buttons x y) ;;;; debug
|
||||
|
||||
(cond (in-modeline-p
|
||||
(select-window window)
|
||||
(cond ((= buttons mouse-left)
|
||||
(scroll-up))
|
||||
((= buttons mouse-right)
|
||||
(scroll-down))
|
||||
((= buttons mouse-center)
|
||||
(goto-char (/ (* x
|
||||
(- (point-max) (point-min)))
|
||||
(1- (window-width))))
|
||||
(beginning-of-line)
|
||||
(what-cursor-position)))
|
||||
(select-window old-window))
|
||||
(in-scrollbar-p
|
||||
(select-window window)
|
||||
(scroll-up
|
||||
(cond ((= buttons mouse-left)
|
||||
y)
|
||||
((= buttons mouse-right)
|
||||
(+ y (- 2 (window-height))))
|
||||
((= buttons mouse-center)
|
||||
(/ (+ 2 y y (- (window-height))) 2))
|
||||
(t
|
||||
0)))
|
||||
(select-window old-window))
|
||||
(same-window-p
|
||||
(cond ((= buttons mouse-left)
|
||||
(sup-move-point-to-x-y x y))
|
||||
((= buttons mouse-2left)
|
||||
(sup-move-point-to-x-y x y)
|
||||
(kill-word 1))
|
||||
((= buttons mouse-3left)
|
||||
(sup-move-point-to-x-y x y)
|
||||
(save-excursion
|
||||
(copy-region-as-kill
|
||||
(point) (progn (forward-word 1) (point))))
|
||||
(setq this-command 'yank)
|
||||
)
|
||||
((= buttons mouse-right)
|
||||
(push-mark)
|
||||
(sup-move-point-to-x-y x y)
|
||||
(exchange-point-and-mark))
|
||||
((= buttons mouse-2right)
|
||||
(push-mark)
|
||||
(sup-move-point-to-x-y x y)
|
||||
(kill-region (mark) (point)))
|
||||
((= buttons mouse-3right)
|
||||
(push-mark)
|
||||
(sup-move-point-to-x-y x y)
|
||||
(copy-region-as-kill (mark) (point))
|
||||
(setq this-command 'yank))
|
||||
((= buttons mouse-center)
|
||||
(sup-move-point-to-x-y x y)
|
||||
(setq this-command 'yank)
|
||||
(yank))
|
||||
((= buttons mouse-2center)
|
||||
(yank-pop 1))
|
||||
)
|
||||
)
|
||||
(in-minibuf-p
|
||||
(cond ((= buttons mouse-right)
|
||||
(call-interactively 'eval-expression))
|
||||
((= buttons mouse-left)
|
||||
(call-interactively 'execute-extended-command))
|
||||
((= buttons mouse-center)
|
||||
(describe-function 'sup-mouse-report)); silly self help
|
||||
))
|
||||
(t ;in another window
|
||||
(select-window window)
|
||||
(cond ((not sup-mouse-fast-select-window))
|
||||
((= buttons mouse-left)
|
||||
(sup-move-point-to-x-y x y))
|
||||
((= buttons mouse-right)
|
||||
(push-mark)
|
||||
(sup-move-point-to-x-y x y)
|
||||
(exchange-point-and-mark))
|
||||
((= buttons mouse-center)
|
||||
(sup-move-point-to-x-y x y)
|
||||
(setq this-command 'yank)
|
||||
(yank))
|
||||
))
|
||||
)))
|
||||
|
||||
|
||||
(defun sup-get-tty-num (term-char)
|
||||
"Read from terminal until TERM-CHAR is read, and return intervening number.
|
||||
Upon non-numeric not matching TERM-CHAR signal an error."
|
||||
(let
|
||||
((num 0)
|
||||
(char (read-char)))
|
||||
(while (and (>= char ?0)
|
||||
(<= char ?9))
|
||||
(setq num (+ (* num 10) (- char ?0)))
|
||||
(setq char (read-char)))
|
||||
(or (eq term-char char)
|
||||
(error "Invalid data format in mouse command"))
|
||||
num))
|
||||
|
||||
(defun sup-move-point-to-x-y (x y)
|
||||
"Position cursor in window coordinates.
|
||||
X and Y are 0-based character positions in the window."
|
||||
(move-to-window-line y)
|
||||
(move-to-column x)
|
||||
)
|
||||
|
||||
(defun sup-pos-to-window (x y)
|
||||
"Find window corresponding to screen coordinates.
|
||||
X and Y are 0-based character positions on the screen."
|
||||
(let ((edges (window-edges))
|
||||
(window nil))
|
||||
(while (and (not (eq window (selected-window)))
|
||||
(or (< y (nth 1 edges))
|
||||
(>= y (nth 3 edges))
|
||||
(< x (nth 0 edges))
|
||||
(>= x (nth 2 edges))))
|
||||
(setq window (next-window window))
|
||||
(setq edges (window-edges window))
|
||||
)
|
||||
(or window (selected-window))
|
||||
)
|
||||
)
|
||||
138
lisp/vmsproc.el
Normal file
138
lisp/vmsproc.el
Normal file
@ -0,0 +1,138 @@
|
||||
;; Run asynchronous VMS subprocesses under Emacs
|
||||
;; Copyright (C) 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.
|
||||
|
||||
;; Written by Mukesh Prasad.
|
||||
|
||||
(defvar display-subprocess-window nil
|
||||
"If non-nil, the suprocess window is displayed whenever input is received.")
|
||||
|
||||
(defvar command-prefix-string "$ "
|
||||
"String to insert to distinguish commands entered by user.")
|
||||
|
||||
(defvar subprocess-running nil)
|
||||
(defvar command-mode-map nil)
|
||||
|
||||
(if command-mode-map
|
||||
nil
|
||||
(setq command-mode-map (make-sparse-keymap))
|
||||
(define-key command-mode-map "\C-m" 'command-send-input)
|
||||
(define-key command-mode-map "\C-u" 'command-kill-line))
|
||||
|
||||
(defun subprocess-input (name str)
|
||||
"Handles input from a subprocess. Called by Emacs."
|
||||
(if display-subprocess-window
|
||||
(display-buffer subprocess-buf))
|
||||
(let ((old-buffer (current-buffer)))
|
||||
(set-buffer subprocess-buf)
|
||||
(goto-char (point-max))
|
||||
(insert str)
|
||||
(insert ?\n)
|
||||
(set-buffer old-buffer)))
|
||||
|
||||
(defun subprocess-exit (name)
|
||||
"Called by Emacs upon subprocess exit."
|
||||
(setq subprocess-running nil))
|
||||
|
||||
(defun start-subprocess ()
|
||||
"Spawns an asynchronous subprocess with output redirected to
|
||||
the buffer *COMMAND*. Within this buffer, use C-m to send
|
||||
the last line to the subprocess or to bring another line to
|
||||
the end."
|
||||
(if subprocess-running
|
||||
(return t))
|
||||
(setq subprocess-buf (get-buffer-create "*COMMAND*"))
|
||||
(save-excursion
|
||||
(set-buffer subprocess-buf)
|
||||
(use-local-map command-mode-map))
|
||||
(setq subprocess-running (spawn-subprocess 1 'subprocess-input
|
||||
'subprocess-exit))
|
||||
;; Initialize subprocess so it doesn't panic and die upon
|
||||
;; encountering the first error.
|
||||
(and subprocess-running
|
||||
(send-command-to-subprocess 1 "ON SEVERE_ERROR THEN CONTINUE")))
|
||||
|
||||
(defun subprocess-command-to-buffer (command buffer)
|
||||
"Execute COMMAND and redirect output into BUFFER."
|
||||
(let (cmd args)
|
||||
(setq cmd (substring command 0 (string-match " " command)))
|
||||
(setq args (substring command (string-match " " command)))
|
||||
(call-process cmd nil buffer nil "*dcl*" args)))
|
||||
;BUGS: only the output up to the end of the first image activation is trapped.
|
||||
; (if (not subprocess-running)
|
||||
; (start-subprocess))
|
||||
; (save-excursion
|
||||
; (set-buffer buffer)
|
||||
; (let ((output-filename (concat "SYS$SCRATCH:OUTPUT-FOR-"
|
||||
; (getenv "USER") ".LISTING")))
|
||||
; (while (file-exists-p output-filename)
|
||||
; (delete-file output-filename))
|
||||
; (define-logical-name "SYS$OUTPUT" (concat output-filename "-NEW"))
|
||||
; (send-command-to-subprocess 1 command)
|
||||
; (send-command-to-subprocess 1 (concat
|
||||
; "RENAME " output-filename
|
||||
; "-NEW " output-filename))
|
||||
; (while (not (file-exists-p output-filename))
|
||||
; (sleep-for 1))
|
||||
; (define-logical-name "SYS$OUTPUT" nil)
|
||||
; (insert-file output-filename)
|
||||
; (delete-file output-filename))))
|
||||
|
||||
(defun subprocess-command ()
|
||||
"Starts asynchronous subprocess if not running and switches to its window."
|
||||
(interactive)
|
||||
(if (not subprocess-running)
|
||||
(start-subprocess))
|
||||
(and subprocess-running
|
||||
(progn (pop-to-buffer subprocess-buf) (goto-char (point-max)))))
|
||||
|
||||
(defun command-send-input ()
|
||||
"If at last line of buffer, sends the current line to
|
||||
the spawned subprocess. Otherwise brings back current
|
||||
line to the last line for resubmission."
|
||||
(interactive)
|
||||
(beginning-of-line)
|
||||
(let ((current-line (buffer-substring (point)
|
||||
(progn (end-of-line) (point)))))
|
||||
(if (eobp)
|
||||
(progn
|
||||
(if (not subprocess-running)
|
||||
(start-subprocess))
|
||||
(if subprocess-running
|
||||
(progn
|
||||
(beginning-of-line)
|
||||
(send-command-to-subprocess 1 current-line)
|
||||
(if command-prefix-string
|
||||
(progn (beginning-of-line) (insert command-prefix-string)))
|
||||
(next-line 1))))
|
||||
;; else -- if not at last line in buffer
|
||||
(end-of-buffer)
|
||||
(backward-char)
|
||||
(next-line 1)
|
||||
(if (string-equal command-prefix-string
|
||||
(substring current-line 0 (length command-prefix-string)))
|
||||
(insert (substring current-line (length command-prefix-string)))
|
||||
(insert current-line)))))
|
||||
|
||||
(defun command-kill-line()
|
||||
"Kills the current line. Used in command mode."
|
||||
(interactive)
|
||||
(beginning-of-line)
|
||||
(kill-line))
|
||||
|
||||
(define-key esc-map "$" 'subprocess-command)
|
||||
137
lisp/vmsx.el
Normal file
137
lisp/vmsx.el
Normal file
@ -0,0 +1,137 @@
|
||||
;; Run asynchronous VMS subprocesses under Emacs
|
||||
;; Copyright (C) 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.
|
||||
|
||||
;; Written by Mukesh Prasad.
|
||||
|
||||
(defvar display-subprocess-window nil
|
||||
"If non-nil, the suprocess window is displayed whenever input is received.")
|
||||
|
||||
(defvar command-prefix-string "$ "
|
||||
"String to insert to distinguish commands entered by user.")
|
||||
|
||||
(defvar subprocess-running nil)
|
||||
(defvar command-mode-map nil)
|
||||
|
||||
(if command-mode-map
|
||||
nil
|
||||
(setq command-mode-map (make-sparse-keymap))
|
||||
(define-key command-mode-map "\C-m" 'command-send-input)
|
||||
(define-key command-mode-map "\C-u" 'command-kill-line))
|
||||
|
||||
(defun subprocess-input (name str)
|
||||
"Handles input from a subprocess. Called by Emacs."
|
||||
(if display-subprocess-window
|
||||
(display-buffer subprocess-buf))
|
||||
(let ((old-buffer (current-buffer)))
|
||||
(set-buffer subprocess-buf)
|
||||
(goto-char (point-max))
|
||||
(insert str)
|
||||
(insert ?\n)
|
||||
(set-buffer old-buffer)))
|
||||
|
||||
(defun subprocess-exit (name)
|
||||
"Called by Emacs upon subprocess exit."
|
||||
(setq subprocess-running nil))
|
||||
|
||||
(defun start-subprocess ()
|
||||
"Spawns an asynchronous subprocess with output redirected to
|
||||
the buffer *COMMAND*. Within this buffer, use C-m to send
|
||||
the last line to the subprocess or to bring another line to
|
||||
the end."
|
||||
(if subprocess-running
|
||||
(return t))
|
||||
(setq subprocess-buf (get-buffer-create "*COMMAND*"))
|
||||
(save-excursion
|
||||
(set-buffer subprocess-buf)
|
||||
(use-local-map command-mode-map))
|
||||
(setq subprocess-running (spawn-subprocess 1 'subprocess-input
|
||||
'subprocess-exit))
|
||||
;; Initialize subprocess so it doesn't panic and die upon
|
||||
;; encountering the first error.
|
||||
(and subprocess-running
|
||||
(send-command-to-subprocess 1 "ON SEVERE_ERROR THEN CONTINUE")))
|
||||
|
||||
(defvar subprocess-command-to-buffer-tmpdir "SYS$SCRATCH:"
|
||||
"*Put temporary files from subprocess-command-to-buffer here.")
|
||||
|
||||
(defun subprocess-command-to-buffer (command buffer)
|
||||
"Execute command and redirect output into buffer.
|
||||
|
||||
BUGS: only the output up to the end of the first image activation is trapped."
|
||||
(if (not subprocess-running)
|
||||
(start-subprocess))
|
||||
(save-excursion
|
||||
(set-buffer buffer)
|
||||
(let ((output-filename
|
||||
(concat subprocess-command-to-buffer-tmpdir
|
||||
"OUTPUT-FOR-" (getenv "USER") ".LISTING")))
|
||||
(while (file-attributes output-filename)
|
||||
(delete-file output-filename))
|
||||
(send-command-to-subprocess 1 (concat "DEFINE/USER SYS$OUTPUT "
|
||||
output-filename "-NEW"))
|
||||
(send-command-to-subprocess 1 command)
|
||||
(send-command-to-subprocess 1 (concat "RENAME " output-filename
|
||||
"-NEW " output-filename))
|
||||
(while (not (file-attributes output-filename))
|
||||
(sleep-for 2))
|
||||
(insert-file output-filename))))
|
||||
|
||||
(defun subprocess-command ()
|
||||
"Starts asynchronous subprocess if not running and switches to its window."
|
||||
(interactive)
|
||||
(if (not subprocess-running)
|
||||
(start-subprocess))
|
||||
(and subprocess-running
|
||||
(progn (pop-to-buffer subprocess-buf) (goto-char (point-max)))))
|
||||
|
||||
(defun command-send-input ()
|
||||
"If at last line of buffer, sends the current line to
|
||||
the spawned subprocess. Otherwise brings back current
|
||||
line to the last line for resubmission."
|
||||
(interactive)
|
||||
(beginning-of-line)
|
||||
(let ((current-line (buffer-substring (point)
|
||||
(progn (end-of-line) (point)))))
|
||||
(if (eobp)
|
||||
(progn
|
||||
(if (not subprocess-running)
|
||||
(start-subprocess))
|
||||
(if subprocess-running
|
||||
(progn
|
||||
(beginning-of-line)
|
||||
(send-command-to-subprocess 1 current-line)
|
||||
(if command-prefix-string
|
||||
(progn (beginning-of-line) (insert command-prefix-string)))
|
||||
(next-line 1))))
|
||||
;; else -- if not at last line in buffer
|
||||
(end-of-buffer)
|
||||
(backward-char)
|
||||
(next-line 1)
|
||||
(if (string-equal command-prefix-string
|
||||
(substring current-line 0 (length command-prefix-string)))
|
||||
(insert (substring current-line (length command-prefix-string)))
|
||||
(insert current-line)))))
|
||||
|
||||
(defun command-kill-line()
|
||||
"Kills the current line. Used in command mode."
|
||||
(interactive)
|
||||
(beginning-of-line)
|
||||
(kill-line))
|
||||
|
||||
(define-key esc-map "$" 'subprocess-command)
|
||||
145
lisp/x-menu.el
Normal file
145
lisp/x-menu.el
Normal file
@ -0,0 +1,145 @@
|
||||
;; Copyright (C) 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.
|
||||
|
||||
|
||||
(defmacro caar (conscell)
|
||||
(list 'car (list 'car conscell)))
|
||||
|
||||
(defmacro cdar (conscell)
|
||||
(list 'cdr (list 'car conscell)))
|
||||
|
||||
(defun x-menu-mode ()
|
||||
"Major mode for creating permanent menus for use with X.
|
||||
These menus are implemented entirely in Lisp; popup menus, implemented
|
||||
with x-popup-menu, are implemented using XMenu primitives."
|
||||
(make-local-variable 'x-menu-items-per-line)
|
||||
(make-local-variable 'x-menu-item-width)
|
||||
(make-local-variable 'x-menu-items-alist)
|
||||
(make-local-variable 'x-process-mouse-hook)
|
||||
(make-local-variable 'x-menu-assoc-buffer)
|
||||
(setq buffer-read-only t)
|
||||
(setq truncate-lines t)
|
||||
(setq x-process-mouse-hook 'x-menu-pick-entry)
|
||||
(setq mode-line-buffer-identification '("MENU: %32b")))
|
||||
|
||||
(defvar x-menu-max-width 0)
|
||||
(defvar x-menu-items-per-line 0)
|
||||
(defvar x-menu-item-width 0)
|
||||
(defvar x-menu-items-alist nil)
|
||||
(defvar x-menu-assoc-buffer nil)
|
||||
|
||||
(defvar x-menu-item-spacing 1
|
||||
"*Minimum horizontal spacing between objects in a permanent X menu.")
|
||||
|
||||
(defun x-menu-create-menu (name)
|
||||
"Create a permanent X menu. Returns an item which should be used as a
|
||||
menu object whenever referring to the menu."
|
||||
(let ((old (current-buffer))
|
||||
(buf (get-buffer-create name)))
|
||||
(set-buffer buf)
|
||||
(x-menu-mode)
|
||||
(setq x-menu-assoc-buffer old)
|
||||
(set-buffer old)
|
||||
buf))
|
||||
|
||||
(defun x-menu-change-associated-buffer (menu buffer)
|
||||
"Change associated buffer of MENU to BUFFER. BUFFER should be a buffer
|
||||
object."
|
||||
(let ((old (current-buffer)))
|
||||
(set-buffer menu)
|
||||
(setq x-menu-assoc-buffer buffer)
|
||||
(set-buffer old)))
|
||||
|
||||
(defun x-menu-add-item (menu item binding)
|
||||
"Adds to MENU an item with name ITEM, associated with BINDING.
|
||||
Following a sequence of calls to x-menu-add-item, a call to x-menu-compute
|
||||
should be performed before the menu will be made available to the user.
|
||||
|
||||
BINDING should be a function of one argument, which is the numerical
|
||||
button/key code as defined in x-menu.el."
|
||||
(let ((old (current-buffer))
|
||||
elt)
|
||||
(set-buffer menu)
|
||||
(if (setq elt (assoc item x-menu-items-alist))
|
||||
(rplacd elt binding)
|
||||
(setq x-menu-items-alist (append x-menu-items-alist
|
||||
(list (cons item binding)))))
|
||||
(set-buffer old)
|
||||
item))
|
||||
|
||||
(defun x-menu-delete-item (menu item)
|
||||
"Deletes from MENU the item named ITEM. x-menu-compute should be called
|
||||
before the menu is made available to the user."
|
||||
(let ((old (current-buffer))
|
||||
elt)
|
||||
(set-buffer menu)
|
||||
(if (setq elt (assoc item x-menu-items-alist))
|
||||
(rplaca elt nil))
|
||||
(set-buffer old)
|
||||
item))
|
||||
|
||||
(defun x-menu-activate (menu)
|
||||
"Computes all necessary parameters for MENU. This must be called whenever
|
||||
a menu is modified before it is made available to the user.
|
||||
|
||||
This also creates the menu itself."
|
||||
(let ((buf (current-buffer)))
|
||||
(pop-to-buffer menu)
|
||||
(let (buffer-read-only)
|
||||
(setq x-menu-max-width (1- (screen-width)))
|
||||
(setq x-menu-item-width 0)
|
||||
(let (items-head
|
||||
(items-tail x-menu-items-alist))
|
||||
(while items-tail
|
||||
(if (caar items-tail)
|
||||
(progn (setq items-head (cons (car items-tail) items-head))
|
||||
(setq x-menu-item-width
|
||||
(max x-menu-item-width
|
||||
(length (caar items-tail))))))
|
||||
(setq items-tail (cdr items-tail)))
|
||||
(setq x-menu-items-alist (reverse items-head)))
|
||||
(setq x-menu-item-width (+ x-menu-item-spacing x-menu-item-width))
|
||||
(setq x-menu-items-per-line
|
||||
(max 1 (/ x-menu-max-width x-menu-item-width)))
|
||||
(erase-buffer)
|
||||
(let ((items-head x-menu-items-alist))
|
||||
(while items-head
|
||||
(let ((items 0))
|
||||
(while (and items-head
|
||||
(<= (setq items (1+ items)) x-menu-items-per-line))
|
||||
(insert (format (concat "%"
|
||||
(int-to-string x-menu-item-width) "s")
|
||||
(caar items-head)))
|
||||
(setq items-head (cdr items-head))))
|
||||
(insert ?\n)))
|
||||
(shrink-window (max 0
|
||||
(- (window-height)
|
||||
(1+ (count-lines (point-min) (point-max))))))
|
||||
(goto-char (point-min)))
|
||||
(pop-to-buffer buf)))
|
||||
|
||||
(defun x-menu-pick-entry (position event)
|
||||
"Internal function for dispatching on mouse/menu events"
|
||||
(let* ((x (min (1- x-menu-items-per-line)
|
||||
(/ (current-column) x-menu-item-width)))
|
||||
(y (- (count-lines (point-min) (point))
|
||||
(if (zerop (current-column)) 0 1)))
|
||||
(item (+ x (* y x-menu-items-per-line)))
|
||||
(litem (cdr (nth item x-menu-items-alist))))
|
||||
(and litem (funcall litem event)))
|
||||
(pop-to-buffer x-menu-assoc-buffer))
|
||||
Loading…
Reference in New Issue
Block a user