Mercurial > emacs
changeset 35:63b375f17a65
Initial revision
| author | Jim Blandy <jimb@redhat.com> |
|---|---|
| date | Tue, 31 Oct 1989 15:59:53 +0000 |
| parents | edf8af31003b |
| children | 9697c13298e5 |
| files | lisp/=grow-vers.el lisp/=inc-vers.el lisp/=mim-syntax.el lisp/=netunam.el lisp/=sun-keys.el lisp/=vmsx.el lisp/electric.el lisp/emulation/mlsupport.el lisp/loadup.el lisp/mail/rmailmsc.el lisp/mail/rnews.el lisp/mail/rnewspost.el lisp/mail/undigest.el lisp/misc.el lisp/sun-curs.el lisp/sun-fns.el lisp/term/sun-mouse.el lisp/term/sup-mouse.el lisp/vmsproc.el lisp/x-menu.el |
| diffstat | 20 files changed, 4815 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=grow-vers.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=inc-vers.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=mim-syntax.el Tue Oct 31 15:59:53 1989 +0000 @@ -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"))))) + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=netunam.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=sun-keys.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=vmsx.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/electric.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulation/mlsupport.el Tue Oct 31 15:59:53 1989 +0000 @@ -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))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/loadup.el Tue Oct 31 15:59:53 1989 +0000 @@ -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))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/rmailmsc.el Tue Oct 31 15:59:53 1989 +0000 @@ -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))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/rnews.el Tue Oct 31 15:59:53 1989 +0000 @@ -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))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/rnewspost.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/undigest.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)))))) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/misc.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/sun-curs.el Tue Oct 31 15:59:53 1989 +0000 @@ -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))) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/sun-fns.el Tue Oct 31 15:59:53 1989 +0000 @@ -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) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/term/sun-mouse.el Tue Oct 31 15:59:53 1989 +0000 @@ -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))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/term/sup-mouse.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)) + ) + )
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vmsproc.el Tue Oct 31 15:59:53 1989 +0000 @@ -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)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-menu.el Tue Oct 31 15:59:53 1989 +0000 @@ -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))