summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJim Blandy <jimb@redhat.com>1989-10-31 15:59:53 +0000
committerJim Blandy <jimb@redhat.com>1989-10-31 15:59:53 +0000
commitac1c6ea2915c86f32904c13ad6be2db16487003e (patch)
tree2af4fca28f1fddcdcb00479261b7e83bca6a47e8
parent5211c0c990394c4476accaf0f2597d5d7963e7c8 (diff)
downloademacs-ac1c6ea2915c86f32904c13ad6be2db16487003e.tar.gz
Initial revision
-rw-r--r--lisp/=grow-vers.el30
-rw-r--r--lisp/=inc-vers.el43
-rw-r--r--lisp/=mim-syntax.el91
-rw-r--r--lisp/=netunam.el152
-rw-r--r--lisp/=sun-keys.el71
-rw-r--r--lisp/=vmsx.el137
-rw-r--r--lisp/electric.el181
-rw-r--r--lisp/emulation/mlsupport.el405
-rw-r--r--lisp/loadup.el140
-rw-r--r--lisp/mail/rmailmsc.el45
-rw-r--r--lisp/mail/rnews.el979
-rw-r--r--lisp/mail/rnewspost.el390
-rw-r--r--lisp/mail/undigest.el105
-rw-r--r--lisp/misc.el51
-rw-r--r--lisp/sun-curs.el207
-rw-r--r--lisp/sun-fns.el630
-rw-r--r--lisp/term/sun-mouse.el668
-rw-r--r--lisp/term/sup-mouse.el207
-rw-r--r--lisp/vmsproc.el138
-rw-r--r--lisp/x-menu.el145
20 files changed, 4815 insertions, 0 deletions
diff --git a/lisp/=grow-vers.el b/lisp/=grow-vers.el
new file mode 100644
index 00000000000..bf55146c6a6
--- /dev/null
+++ b/lisp/=grow-vers.el
@@ -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)
diff --git a/lisp/=inc-vers.el b/lisp/=inc-vers.el
new file mode 100644
index 00000000000..13a4fb17e80
--- /dev/null
+++ b/lisp/=inc-vers.el
@@ -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)
diff --git a/lisp/=mim-syntax.el b/lisp/=mim-syntax.el
new file mode 100644
index 00000000000..c9a95b50f2f
--- /dev/null
+++ b/lisp/=mim-syntax.el
@@ -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")))))
+
+
+
diff --git a/lisp/=netunam.el b/lisp/=netunam.el
new file mode 100644
index 00000000000..44d828729ef
--- /dev/null
+++ b/lisp/=netunam.el
@@ -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)))
diff --git a/lisp/=sun-keys.el b/lisp/=sun-keys.el
new file mode 100644
index 00000000000..59fba2a5791
--- /dev/null
+++ b/lisp/=sun-keys.el
@@ -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)
diff --git a/lisp/=vmsx.el b/lisp/=vmsx.el
new file mode 100644
index 00000000000..a68c6de3796
--- /dev/null
+++ b/lisp/=vmsx.el
@@ -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)
diff --git a/lisp/electric.el b/lisp/electric.el
new file mode 100644
index 00000000000..be992c60f0d
--- /dev/null
+++ b/lisp/electric.el
@@ -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)))
diff --git a/lisp/emulation/mlsupport.el b/lisp/emulation/mlsupport.el
new file mode 100644
index 00000000000..14e7a3c9557
--- /dev/null
+++ b/lisp/emulation/mlsupport.el
@@ -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))))
diff --git a/lisp/loadup.el b/lisp/loadup.el
new file mode 100644
index 00000000000..9447c74891d
--- /dev/null
+++ b/lisp/loadup.el
@@ -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))
diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el
new file mode 100644
index 00000000000..c57b15c4c3a
--- /dev/null
+++ b/lisp/mail/rmailmsc.el
@@ -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))
diff --git a/lisp/mail/rnews.el b/lisp/mail/rnews.el
new file mode 100644
index 00000000000..64b98ca407b
--- /dev/null
+++ b/lisp/mail/rnews.el
@@ -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))))
diff --git a/lisp/mail/rnewspost.el b/lisp/mail/rnewspost.el
new file mode 100644
index 00000000000..adb65e6f3ab
--- /dev/null
+++ b/lisp/mail/rnewspost.el
@@ -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)))
diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el
new file mode 100644
index 00000000000..583251e990f
--- /dev/null
+++ b/lisp/mail/undigest.el
@@ -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))))))
+
diff --git a/lisp/misc.el b/lisp/misc.el
new file mode 100644
index 00000000000..db7b3f223b5
--- /dev/null
+++ b/lisp/misc.el
@@ -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)))
diff --git a/lisp/sun-curs.el b/lisp/sun-curs.el
new file mode 100644
index 00000000000..f290e1b3a76
--- /dev/null
+++ b/lisp/sun-curs.el
@@ -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)))
+
diff --git a/lisp/sun-fns.el b/lisp/sun-fns.el
new file mode 100644
index 00000000000..b2ca59203f6
--- /dev/null
+++ b/lisp/sun-fns.el
@@ -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)
+
diff --git a/lisp/term/sun-mouse.el b/lisp/term/sun-mouse.el
new file mode 100644
index 00000000000..bed2b416c1f
--- /dev/null
+++ b/lisp/term/sun-mouse.el
@@ -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))
diff --git a/lisp/term/sup-mouse.el b/lisp/term/sup-mouse.el
new file mode 100644
index 00000000000..d03b009136d
--- /dev/null
+++ b/lisp/term/sup-mouse.el
@@ -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))
+ )
+ )
diff --git a/lisp/vmsproc.el b/lisp/vmsproc.el
new file mode 100644
index 00000000000..b4451a40ad0
--- /dev/null
+++ b/lisp/vmsproc.el
@@ -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)
diff --git a/lisp/x-menu.el b/lisp/x-menu.el
new file mode 100644
index 00000000000..878dde0dc5e
--- /dev/null
+++ b/lisp/x-menu.el
@@ -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))