From: Eshel Yaron Date: Sat, 22 Jun 2024 20:35:25 +0000 (+0200) Subject: Remove some long obsolete libraries X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=ed02e9849fb6d39baa74e5bf647aee7fce261f0c;p=emacs.git Remove some long obsolete libraries --- diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 0b0a9bbfc1d..1305dc3e2df 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1185,40 +1185,6 @@ SPEC is a predicate specifier that contains stuff like `or', `and', (ido-completing-read prompt collection nil require-match initial-input history def)) - -(declare-function iswitchb-read-buffer "iswitchb" - (prompt &optional default require-match - _predicate start matches-set)) -(declare-function iswitchb-minibuffer-setup "iswitchb") -(defvar iswitchb-temp-buflist) -(defvar iswitchb-mode) -(defvar iswitchb-make-buflist-hook) - -(defun gnus-iswitchb-completing-read (prompt collection &optional require-match - initial-input history def) - "`iswitchb' based completing-read function." - (declare (obsolete nil "29.1")) - ;; Make sure iswitchb is loaded before we let-bind its variables. - ;; If it is loaded inside the let, variables can become unbound afterwards. - (require 'iswitchb) - (let ((iswitchb-make-buflist-hook - (lambda () - (setq iswitchb-temp-buflist - (let ((choices (append - (when initial-input (list initial-input)) - (symbol-value history) collection)) - filtered-choices) - (dolist (x choices) - (setq filtered-choices (cl-adjoin x filtered-choices))) - (nreverse filtered-choices)))))) - (unwind-protect - (progn - (or iswitchb-mode - (add-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup)) - (iswitchb-read-buffer prompt def require-match)) - (or iswitchb-mode - (remove-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup))))) - (defmacro gnus-parse-without-error (&rest body) "Allow continuing onto the next line even if an error occurs." (declare (indent 0) (debug t)) diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 4506aa9e35e..ddb9841a2a9 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -1055,19 +1055,6 @@ matches exist." ;; is cached. (if last (setcdr last base-size)))))))) -;;;_* Iswitchb compatibility - -;; We moved Iswitchb to `obsolete' in 24.4, but autoloads in files in -;; `obsolete' aren't obeyed (since that would encourage people to keep using -;; those packages, oblivious to their obsolescence). Given the fact that -;; Iswitchb was very popular, we decided to keep its autoload for a bit longer, -;; so we moved it here. - -;;;###autoload(when (locate-library "obsolete/iswitchb") -;;;###autoload (autoload 'iswitchb-mode "iswitchb" "Toggle Iswitchb mode." t) -;;;###autoload (make-obsolete 'iswitchb-mode -;;;###autoload "use `icomplete-mode' or `ido-mode' instead." "24.4")) - (provide 'icomplete) ;;;_* Local emacs vars. diff --git a/lisp/isearchb.el b/lisp/isearchb.el deleted file mode 100644 index 8cde93ed846..00000000000 --- a/lisp/isearchb.el +++ /dev/null @@ -1,227 +0,0 @@ -;;; isearchb.el --- a marriage between iswitchb and isearch -*- lexical-binding: t -*- - -;; Copyright (C) 2004-2024 Free Software Foundation, Inc. - -;; Author: John Wiegley -;; Maintainer: emacs-devel@gnu.org -;; Created: 16 Apr 2004 -;; Version: 1.5 -;; Keywords: lisp - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; This module allows you to switch to buffers even faster than with -;; iswitchb! It is not intended to replace it, however, as it works -;; well only with buffers whose names don't typically overlap. You'll -;; have to try it first, and see how your mileage varies. -;; -;; The first way to use isearchb is by holding down a modifier key, in -;; which case every letter you type while holding it searches for any -;; buffer matching what you're typing (using the same ordering scheme -;; employed by iswitchb). To use it this way, add to your .emacs: -;; -;; (isearchb-set-keybindings 'super) ; s-x s-y s-z now finds "xyz" -;; -;; The other way is by using a command that puts you into "search" -;; mode, just like with isearch. I use C-z for this. The binding in -;; my .emacs looks like: -;; -;; (define-key global-map [(control ?z)] 'isearchb-activate) -;; -;; Now, after pressing C-z (for example), each self-inserting -;; character thereafter will search for a buffer containing those -;; characters. For instance, typing "C-z xyz" will switch to the -;; first buffer containing "xyz". Once you press a non-self-inserting -;; character (such as any control key sequence), the search will end. -;; -;; C-z after C-z toggles between the previously selected buffer and -;; the current one. -;; -;; C-g aborts the search and returns you to your original buffer. -;; -;; TAB, after typing in a few characters (after C-z), will jump into -;; iswitchb, using the prefix you've typed so far. This is handy when -;; you realize that isearchb is not powerful enough to find the buffer -;; you're looking for. -;; -;; C-s and C-r move forward and backward in the buffer list. If -;; `isearchb-show-completions' is non-nil (the default), the list of -;; possible completions is shown in the minibuffer. -;; -;; If `isearchb-idle-timeout' is set to a number, isearchb will quit -;; after that many seconds of idle time. I recommend trying it set to -;; one or two seconds. Then, if you switch to a buffer and wait for -;; that amount of time, you can start typing without manually exiting -;; isearchb. - -;; TODO: -;; C-z C-z is broken -;; killing iswitchb.el and then trying to switch back is broken -;; make sure TAB isn't broken - -;;; Code: - -;; FIXME: Don't rely on iswitchb! See bug#36260. -(with-suppressed-warnings ((obsolete iswitchb)) - (require 'iswitchb)) - -(defgroup isearchb nil - "Switch between buffers using a mechanism like isearch." - :group 'iswitchb) - -(defcustom isearchb-idle-timeout nil - "Number of idle seconds before isearchb turns itself off. -If nil, don't use a timeout." - :type '(choice (integer :tag "Seconds") - (const :tag "Disable" nil))) - -(defcustom isearchb-show-completions t - "If non-nil, show possible completions in the minibuffer." - :type 'boolean) - -(defvar isearchb-start-buffer nil) -(defvar isearchb-last-buffer nil) -(defvar isearchb-idle-timer nil) - -(defun isearchb-stop (&optional return-to-buffer ignore-command) - "Called by isearchb to terminate a search in progress." - (remove-hook 'pre-command-hook 'isearchb-follow-char) - (if return-to-buffer - (switch-to-buffer isearchb-start-buffer) - (setq isearchb-last-buffer isearchb-start-buffer)) - (when isearchb-idle-timer - (cancel-timer isearchb-idle-timer) - (setq isearchb-idle-timer nil)) - (if ignore-command - (setq this-command 'ignore - last-command 'ignore)) - (message nil)) - -(defun isearchb-iswitchb () - "isearchb's custom version of the `iswitchb' command. -Its purpose is to pass different call arguments to -`iswitchb-read-buffer'." - (interactive) - (let* ((prompt "iswitch ") - (iswitchb-method 'samewindow) - (buf (iswitchb-read-buffer prompt nil nil nil iswitchb-text t))) - (if (eq iswitchb-exit 'findfile) - (call-interactively 'find-file) - (when buf - (if (get-buffer buf) - ;; buffer exists, so view it and then exit - (iswitchb-visit-buffer buf) - ;; else buffer doesn't exist - (iswitchb-possible-new-buffer buf)))))) - -(defun isearchb () - "Switch to buffer matching a substring, based on chars typed." - (interactive) - (unless (eq last-command 'isearchb) - (setq iswitchb-text nil)) - (unless iswitchb-text - (setq iswitchb-text "") - (iswitchb-make-buflist nil)) - (if last-command-event - (setq iswitchb-rescan t - iswitchb-text (concat iswitchb-text - (char-to-string - (event-basic-type last-command-event))))) - (iswitchb-set-matches) - (let* ((match (car iswitchb-matches)) - (buf (and match (get-buffer match)))) - (if (null buf) - (progn - (isearchb-stop t) - (isearchb-iswitchb)) - (switch-to-buffer buf) - (if isearchb-show-completions - (message "isearchb: %s%s" iswitchb-text - (iswitchb-completions iswitchb-text)) - (if (= 1 (length iswitchb-matches)) - (message "isearchb: %s (only match)" iswitchb-text) - (message "isearchb: %s" iswitchb-text)))))) - -(defun isearchb-set-keybindings (modifier) - "Setup isearchb on the given MODIFIER." - (dotimes (i 128) - (if (eq 'self-insert-command - (lookup-key global-map (vector i))) - (define-key global-map (vector (list modifier i)) 'isearchb)))) - -(defun isearchb-follow-char () - "Function added to `post-command-hook' to handle the isearchb \"mode\"." - (let (keys) - (if (not (and (memq last-command '(isearchb isearchb-activate)) - (setq keys (this-command-keys)) - (= 1 (length keys)))) - (isearchb-stop) - (cond - ((or (equal keys "\C-h") (equal keys "\C-?") - (equal keys [backspace]) (equal keys [delete])) - (setq iswitchb-text - (substring iswitchb-text 0 (1- (length iswitchb-text)))) - (if (= 0 (length iswitchb-text)) - (isearchb-stop t t) - (setq last-command-event nil) - (setq this-command 'isearchb))) - ((or (equal keys "\C-i") (equal keys [tab])) - (setq this-command 'isearchb-iswitchb)) - ((equal keys "\C-s") - (iswitchb-next-match) - (setq last-command-event nil) - (setq this-command 'isearchb)) - ((equal keys "\C-r") - (iswitchb-prev-match) - (setq last-command-event nil) - (setq this-command 'isearchb)) - ((equal keys "\C-g") - (ding) - (isearchb-stop t t)) - ((eq (lookup-key global-map keys) 'self-insert-command) - (setq this-command 'isearchb))) - (if (and isearchb-idle-timeout - (null isearchb-idle-timer)) - (setq isearchb-idle-timer - (run-with-idle-timer isearchb-idle-timeout nil - 'isearchb-stop)))))) - -;;;###autoload -(defun isearchb-activate () - "Active isearchb mode for subsequent alphanumeric keystrokes. -Executing this command again will terminate the search; or, if -the search has not yet begun, will toggle to the last buffer -accessed via isearchb." - (interactive) - (cond - ((eq last-command 'isearchb) - (isearchb-stop nil t)) - ((eq last-command 'isearchb-activate) - (if isearchb-last-buffer - (switch-to-buffer isearchb-last-buffer) - (error "isearchb: There is no previous buffer to toggle to")) - (isearchb-stop nil t)) - (t - (message "isearchb: ") - (setq iswitchb-text nil - isearchb-start-buffer (current-buffer)) - (add-hook 'pre-command-hook 'isearchb-follow-char)))) - -(provide 'isearchb) - -;;; isearchb.el ends here diff --git a/lisp/obsolete/bruce.el b/lisp/obsolete/bruce.el deleted file mode 100644 index 2a44946c7b6..00000000000 --- a/lisp/obsolete/bruce.el +++ /dev/null @@ -1,148 +0,0 @@ -;;; bruce.el --- bruce phrase utility for overloading the Communications -*- lexical-binding: t; -*- -;;; Decency Act snoops, if any. - -;; Copyright (C) 1988, 1993, 1997, 2001-2024 Free Software Foundation, -;; Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: games -;; Created: Jan 1997 -;; Obsolete-since: 24.3 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; This program was written to protest the miss-named "Communications -;; Decency Act of 1996. This Act bans "indecent speech", whatever that is, -;; from the Internet. For more on the CDA, see Richard Stallman's essay on -;; censorship, included in the etc directory of emacs distributions 19.34 -;; and up. See also https://www.eff.org/blueribbon.html. - -;; For many years, emacs has included a program called Spook. This program -;; adds a series of "keywords" to email just before it goes out. On the -;; theory that the NSA monitors people's email, the keywords would be -;; picked up by the NSA's snoop computers, causing them to waste time -;; reading your meeting schedule notices or other email boring to everyone -;; but you and (you hope) the recipient. See below (I left in the original -;; writeup when I made this conversion), or the emacs documentation at -;; https://www.gnu.org/software/emacs/manual/. - -;; Bruce is a direct copy of spook, with the word "spook" replaced with -;; the word "bruce". Thanks to "esr", whoever he, she or it may be, this -;; conversion was an extremely easy piece of editing, suitable for a first -;; essay at elisp programming. - -;; You may think of the name as having been derived from a certain Monty -;; Python routine. Or from Lenny Bruce, who opposed censorship in his own -;; inimitable way. Bruce does exactly what Spook does: it throws keywords -;; into your email messages or other documents. - -;; However, in order to comply with the CDA as interpreted by Richard -;; Stallman (see the essay on censorship), bruce is distributed without a -;; data file from which to select words at random. Sorry about that. I -;; believe the average user will be able to come up with a few words on -;; his or her own. If that is a problem, feel free to ask any American -;; teenager, preferably one who attends a government school. Failing -;; that, you might write to Mr. Clinton or Ms Reno or their successors and -;; ask them for suggestions. Think of it as a public spirited act: the -;; time they spend answering you is time not spent persecuting someone -;; else. However, do ask them to respond by snail mail, where their -;; suggestions would be legal. - -;; To build the data file, just start a file called bruce.lines in the etc -;; directory of your emacs distribution. Note that each phrase or word has -;; to be followed by an ascii 0, control-@. See the file spook.lines in -;; the etc directory for an example. In emacs, use c-q c-@ to insert the -;; ascii 0s. - -;; Once you have edited up a data file, you have to tell emacs how to find -;; the program bruce. Add the following two lines to your .emacs file. Be -;; sure to uncomment the second line. - -;; for bruce mode -;; (autoload 'bruce "bruce" "Use the Bruce program to protest the CDA" t) - -;; Shut down emacs and fire it up again. Then "M-x bruce" should put some -;; shocking words in the current buffer. - - -;; Please note that I am not suggesting that you actually use this program -;; to add "illegal" words to your email, or any other purpose. First, you -;; don't really need a program to do it, and second, it would be illegal -;; for me to suggest or advise that you actually break the law. This -;; program was written as a demonstration only, and as an act of political -;; protest and free expression protected by the First Amendment, or -;; whatever is left of it. - - -;; We now return to the original writeup for spook: - -;; Steve Strassmann didn't write the -;; program spook, from which this was adapted, and even if he did, he -;; really didn't mean for you to use it in an anarchistic way. -;; -;; To use this: -;; Just before sending mail, do M-x spook. -;; A number of phrases will be inserted into your buffer, to help -;; give your message that extra bit of attractiveness for automated -;; keyword scanners. Help defeat the NSA trunk trawler! - -;;; Code: - -(require 'cookie1) - -; Variables -(defgroup bruce nil - "Insert phrases selected at random from a file into a buffer." - :prefix "bruce-" - :group 'games) - -(defcustom bruce-phrases-file "~/bruce.lines" - "Keep your favorite phrases here." - :type 'file) - -(defcustom bruce-phrase-default-count 15 - "Default number of phrases to insert." - :type 'integer) - -;;;###autoload -(defun bruce () - "Adds that special touch of class to your outgoing mail." - (interactive) - (or (file-exists-p bruce-phrases-file) - (error "You need to create %s" bruce-phrases-file)) - (cookie-insert bruce-phrases-file - bruce-phrase-default-count - "Checking authorization..." - "Checking authorization...Approved")) - -;;;###autoload -(defun snarf-bruces () - "Return a vector containing the lines from `bruce-phrases-file'." - (or (file-exists-p bruce-phrases-file) - (error "You need to create %s" bruce-phrases-file)) - (cookie-snarf bruce-phrases-file - "Checking authorization..." - "Checking authorization...Approved")) - -;; Note: the implementation that used to take up most of this file has been -;; cleaned up, generalized, gratuitously broken by esr, and now resides in -;; cookie1.el. - -(provide 'bruce) - -;;; bruce.el ends here diff --git a/lisp/obsolete/crisp.el b/lisp/obsolete/crisp.el deleted file mode 100644 index 3a3a44f850f..00000000000 --- a/lisp/obsolete/crisp.el +++ /dev/null @@ -1,359 +0,0 @@ -;;; crisp.el --- CRiSP/Brief Emacs emulator -*- lexical-binding: t; -*- - -;; Copyright (C) 1997-1999, 2001-2024 Free Software Foundation, Inc. - -;; Author: Gary D. Foster -;; Keywords: emulations brief crisp -;; Obsolete-since: 24.5 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; *Note: This package has now moved to elpa.gnu.org.* - -;; Keybindings and minor functions to duplicate the functionality and -;; finger-feel of the CRiSP/Brief editor. This package is designed to -;; facilitate transitioning from Brief to (XE|E)macs with a minimum -;; amount of hassles. - -;; Enable this package by putting (require 'crisp) in your .emacs and -;; use M-x crisp-mode to toggle it on or off. - -;; This package will automatically load the scroll-all.el package if -;; you put (setq crisp-load-scroll-all t) in your .emacs before -;; loading this package. If this feature is enabled, it will bind -;; meta-f1 to the scroll-all mode toggle. The scroll-all package -;; duplicates the scroll-all feature in CRiSP. - -;; Also, the default keybindings for brief/CRiSP override the M-x -;; key to exit the editor. If you don't like this functionality, you -;; can prevent this behavior (or redefine it dynamically) by setting -;; the value of `crisp-override-meta-x' either in your .emacs or -;; interactively. The default setting is t, which means that M-x will -;; by default run `save-buffers-kill-emacs' instead of the command -;; `execute-extended-command'. - -;; Finally, if you want to change the string displayed in the mode -;; line when this mode is in effect, override the definition of -;; `crisp-mode-mode-line-string' in your .emacs. The default value is -;; " *Crisp*" which may be a bit lengthy if you have a lot of things -;; being displayed there. - -;; All these overrides should go *before* the (require 'crisp) statement. - -;;; Code: - -;; local variables - -(defgroup crisp nil - "Emulator for CRiSP and Brief key bindings." - :prefix "crisp-" - :group 'emulations) - -(defvar crisp-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(f1)] #'other-window) - - (define-key map [(f2) (down)] #'enlarge-window) - (define-key map [(f2) (left)] #'shrink-window-horizontally) - (define-key map [(f2) (right)] #'enlarge-window-horizontally) - (define-key map [(f2) (up)] #'shrink-window) - (define-key map [(f3) (down)] #'split-window-below) - (define-key map [(f3) (right)] #'split-window-right) - - (define-key map [(f4)] #'delete-window) - (define-key map [(control f4)] #'delete-other-windows) - - (define-key map [(f5)] #'search-forward-regexp) - (define-key map [(f19)] #'search-forward-regexp) - (define-key map [(meta f5)] #'search-backward-regexp) - - (define-key map [(f6)] #'query-replace) - - (define-key map [(f7)] #'start-kbd-macro) - (define-key map [(meta f7)] #'end-kbd-macro) - - (define-key map [(f8)] #'call-last-kbd-macro) - ;;(define-key map [(meta f8)] #'save-kbd-macro) ;FIXME:Unknown command? - - (define-key map [(f9)] #'find-file) - (define-key map [(meta f9)] #'load-library) - - (define-key map [(f10)] #'execute-extended-command) - (define-key map [(meta f10)] #'compile) - - (define-key map [(SunF37)] #'kill-buffer) - (define-key map [(kp-add)] #'crisp-copy-line) - (define-key map [(kp-subtract)] #'crisp-kill-line) - ;; just to cover all the bases (GNU Emacs, for instance) - (define-key map [(f24)] #'crisp-kill-line) - (define-key map [(insert)] #'crisp-yank-clipboard) - (define-key map [(f16)] #'crisp-set-clipboard) ; copy on Sun5 kbd - (define-key map [(f20)] #'crisp-kill-region) ; cut on Sun5 kbd - (define-key map [(f18)] #'crisp-yank-clipboard) ; paste on Sun5 kbd - - ;; (define-key map [(control f)] #'fill-paragraph-or-region) - (define-key map [(meta d)] (lambda () - (interactive) - (beginning-of-line) (kill-line))) - (define-key map [(meta e)] #'find-file) - (define-key map [(meta g)] #'goto-line) - (define-key map [(meta h)] #'help) - (define-key map [(meta i)] #'overwrite-mode) - (define-key map [(meta j)] #'bookmark-jump) - (define-key map [(meta l)] #'crisp-mark-line) - (define-key map [(meta m)] #'set-mark-command) - (define-key map [(meta n)] #'bury-buffer) - (define-key map [(meta p)] #'crisp-unbury-buffer) - (define-key map [(meta u)] #'undo) - (define-key map [(f14)] #'undo) - (define-key map [(meta w)] #'save-buffer) - (define-key map [(meta x)] #'crisp-meta-x-wrapper) - (define-key map [(meta ?0)] (lambda () - (interactive) - (bookmark-set "0"))) - (define-key map [(meta ?1)] (lambda () - (interactive) - (bookmark-set "1"))) - (define-key map [(meta ?2)] (lambda () - (interactive) - (bookmark-set "2"))) - (define-key map [(meta ?3)] (lambda () - (interactive) - (bookmark-set "3"))) - (define-key map [(meta ?4)] (lambda () - (interactive) - (bookmark-set "4"))) - (define-key map [(meta ?5)] (lambda () - (interactive) - (bookmark-set "5"))) - (define-key map [(meta ?6)] (lambda () - (interactive) - (bookmark-set "6"))) - (define-key map [(meta ?7)] (lambda () - (interactive) - (bookmark-set "7"))) - (define-key map [(meta ?8)] (lambda () - (interactive) - (bookmark-set "8"))) - (define-key map [(meta ?9)] (lambda () - (interactive) - (bookmark-set "9"))) - - (define-key map [(shift delete)] #'kill-word) - (define-key map [(shift backspace)] #'backward-kill-word) - (define-key map [(control left)] #'backward-word) - (define-key map [(control right)] #'forward-word) - - (define-key map [(home)] #'crisp-home) - (define-key map [(control home)] (lambda () - (interactive) - (move-to-window-line 0))) - (define-key map [(meta home)] #'beginning-of-line) - (define-key map [(end)] #'crisp-end) - (define-key map [(control end)] (lambda () - (interactive) - (move-to-window-line -1))) - (define-key map [(meta end)] #'end-of-line) - map) - "Local keymap for CRiSP emulation mode. -All the bindings are done here instead of globally to try and be -nice to the world.") - -(defcustom crisp-mode-mode-line-string " *CRiSP*" - "String to display in the mode line when CRiSP emulation mode is enabled." - :type 'string) - -;;;###autoload -(defcustom crisp-mode nil - "Track status of CRiSP emulation mode. -A value of nil means CRiSP mode is not enabled. A value of t -indicates CRiSP mode is enabled. - -Setting this variable directly does not take effect; -use either M-x customize or the function `crisp-mode'." - :set (lambda (_symbol value) (crisp-mode (if value 1 0))) - :initialize #'custom-initialize-default - :require 'crisp - :version "20.4" - :type 'boolean) - -(defcustom crisp-override-meta-x t - "Controls overriding the normal Emacs M-x key binding in the CRiSP emulator. -Normally the CRiSP emulator rebinds M-x to `save-buffers-exit-emacs', and -provides the usual M-x functionality on the F10 key. If this variable -is non-nil, M-x will exit Emacs." - :type 'boolean) - -(defcustom crisp-load-scroll-all nil - "Controls loading of the Scroll Lock in the CRiSP emulator. -Its default behavior is to load and enable the Scroll Lock minor mode -package when enabling the CRiSP emulator. - -If this variable is nil when you start the CRiSP emulator, it -does not load the scroll-all package." - :type 'boolean) - -(defcustom crisp-load-hook nil - "Hooks to run after loading the CRiSP emulator package." - :type 'hook) - -(defcustom crisp-mode-hook nil - "Hook run by the function `crisp-mode'." - :type 'hook) - -(defconst crisp-version "1.34" - "The version of the CRiSP emulator.") - -(defconst crisp-mode-help-address "gfoster@suzieq.ml.org" - "The email address of the CRiSP mode author/maintainer.") - -;; Silence the byte-compiler. -(defvar crisp-last-last-command nil - "The previous value of `last-command'.") - -;; The cut and paste routines are different between XEmacs and Emacs -;; so we need to set up aliases for the functions. -(defalias 'crisp-set-clipboard 'clipboard-kill-ring-save) -(defalias 'crisp-kill-region 'clipboard-kill-region) -(defalias 'crisp-yank-clipboard 'clipboard-yank) - -(defun crisp-region-active () - "Compatibility function to test for an active region." - mark-active) - -(defun crisp-version (&optional arg) - "Version number of the CRiSP emulator package. -If ARG, insert results at point." - (interactive "P") - (let ((foo (concat "CRiSP version " crisp-version))) - (if arg - (insert (message foo)) - (message foo)))) - -(defun crisp-mark-line (arg) - "Set mark at the end of the line. -Arg works as in `end-of-line'." - (interactive "p") - (let (newmark) - (save-excursion - (end-of-line arg) - (setq newmark (point))) - (push-mark newmark nil t))) - -(defun crisp-kill-line (arg) - "Mark and kill line(s). -Marks from point to end of the current line (honoring prefix arguments), -copies the region to the kill ring and clipboard, and then deletes it." - (interactive "*p") - (if (crisp-region-active) - (call-interactively 'crisp-kill-region) - (crisp-mark-line arg) - (call-interactively 'crisp-kill-region))) - -(defun crisp-copy-line (arg) - "Mark and copy line(s). -Marks from point to end of the current line (honoring prefix arguments), -copies the region to the kill ring and clipboard, and then deactivates -the region." - (interactive "*p") - (if (crisp-region-active) - (call-interactively 'crisp-set-clipboard) - (crisp-mark-line arg) - (call-interactively 'crisp-set-clipboard)) - ;; clear the region after the operation is complete - ;; XEmacs does this automagically, Emacs doesn't. - (if (boundp 'mark-active) - (setq mark-active nil))) - -(defun crisp-home () - "\"Home\" the point, the way CRiSP would do it. -The first use moves point to beginning of the line. Second -consecutive use moves point to beginning of the screen. Third -consecutive use moves point to the beginning of the buffer." - (interactive nil) - (cond - ((and (eq last-command 'crisp-home) - (eq crisp-last-last-command 'crisp-home)) - (goto-char (point-min))) - ((eq last-command 'crisp-home) - (move-to-window-line 0)) - (t - (beginning-of-line))) - (setq crisp-last-last-command last-command)) - -(defun crisp-end () - "\"End\" the point, the way CRiSP would do it. -The first use moves point to end of the line. Second -consecutive use moves point to the end of the screen. Third -consecutive use moves point to the end of the buffer." - (interactive nil) - (cond - ((and (eq last-command 'crisp-end) - (eq crisp-last-last-command 'crisp-end)) - (goto-char (point-max))) - ((eq last-command 'crisp-end) - (move-to-window-line -1) - (end-of-line)) - (t - (end-of-line))) - (setq crisp-last-last-command last-command)) - -(defun crisp-unbury-buffer () - "Go back one buffer." - (interactive) - (switch-to-buffer (car (last (buffer-list))))) - -(defun crisp-meta-x-wrapper () - "Wrapper function to conditionally override the normal M-x bindings. -When `crisp-override-meta-x' is non-nil, M-x will exit Emacs (the -normal CRiSP binding) and when it is nil M-x will run -`execute-extended-command' (the normal Emacs binding)." - (interactive) - (if crisp-override-meta-x - (save-buffers-kill-emacs) - (call-interactively 'execute-extended-command))) - -;;;###autoload -(define-minor-mode crisp-mode - "Toggle CRiSP/Brief emulation (CRiSP mode)." - :keymap crisp-mode-map - :lighter crisp-mode-mode-line-string - (when crisp-mode - ;; Make menu entries show M-u or f14 in preference to C-x u. - (put 'undo :advertised-binding - `([?\M-u] [f14] ,@(get 'undo :advertised-binding))) - ;; Force transient-mark-mode, so that the marking routines work as - ;; expected. If the user turns off transient mark mode, most - ;; things will still work fine except the crisp-(copy|kill) - ;; functions won't work quite as nicely when regions are marked - ;; differently and could really confuse people. Caveat emptor. - (if (fboundp 'transient-mark-mode) - (transient-mark-mode t)) - (if crisp-load-scroll-all - (require 'scroll-all)) - (if (featurep 'scroll-all) - (define-key crisp-mode-map [(meta f1)] #'scroll-all-mode)))) - -;; People might use Apropos on `brief'. -;;;###autoload -(defalias 'brief-mode #'crisp-mode) - -(run-hooks 'crisp-load-hook) -(provide 'crisp) - -;;; crisp.el ends here diff --git a/lisp/obsolete/gulp.el b/lisp/obsolete/gulp.el deleted file mode 100644 index 03c005f498b..00000000000 --- a/lisp/obsolete/gulp.el +++ /dev/null @@ -1,174 +0,0 @@ -;;; gulp.el --- ask for updates for Lisp packages -*- lexical-binding: t; -*- - -;; Copyright (C) 1996, 2001-2024 Free Software Foundation, Inc. - -;; Author: Sam Shteingold -;; Maintainer: emacs-devel@gnu.org -;; Keywords: maint -;; Obsolete-since: 25.1 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; Search the emacs/{version}/lisp directory for *.el files, extract the -;; name of the author or maintainer and send him e-mail requesting -;; update. - -;;; Code: -(defgroup gulp nil - "Ask for updates for Lisp packages." - :prefix "-" - :group 'maint) - -(defcustom gulp-discard "^;+ *Maintainer: *\\(FSF\\|emacs-devel@gnu\\.org\\) *$" - "The regexp matching the packages not requiring the request for updates." - :version "24.4" ; added emacs-devel - :type 'regexp) - -(defcustom gulp-tmp-buffer "*gulp*" - "The name of the temporary buffer." - :type 'string) - -(defcustom gulp-max-len 2000 - "Distance into a Lisp source file to scan for keywords." - :type 'integer) - -(defcustom gulp-request-header - (concat - "This message was created automatically. -I'm going to start pretesting a new version of GNU Emacs soon, so I'd -like to ask if you have any updates for the Emacs packages you work on. -You're listed as the maintainer of the following package(s):\n\n") - "The starting text of a gulp message." - :type 'string) - -(defcustom gulp-request-end - (concat - "\nIf you have any changes since the version in the previous release (" - (format "%d.%d" emacs-major-version emacs-minor-version) - "), -please send them to me ASAP. - -Please don't send the whole file. Instead, please send a patch made with -`diff -c' that shows precisely the changes you would like me to install. -Also please include itemized change log entries for your changes; -please use lisp/ChangeLog* as a guide for the style and for what kinds -of information to include. - -Thanks.") - "The closing text in a gulp message." - :type 'string) - -(declare-function mail-subject "sendmail" ()) -(declare-function mail-send "sendmail" ()) - -(defun gulp-send-requests (dir &optional time) - "Send requests for updates to the authors of Lisp packages in directory DIR. -For each maintainer, the message consists of `gulp-request-header', -followed by the list of packages (with modification times if the optional -prefix argument TIME is non-nil), concluded with `gulp-request-end'. - -You can't edit the messages, but you can confirm whether to send each one. - -The list of addresses for which you decided not to send mail -is left in the `*gulp*' buffer at the end." - (interactive "DRequest updates for Lisp directory: \nP") - (with-current-buffer (get-buffer-create gulp-tmp-buffer) - (let ((m-p-alist (gulp-create-m-p-alist - (directory-files dir nil "\\`[^=].*\\.el\\'" t) - dir)) - ;; Temporarily inhibit undo in the *gulp* buffer. - (buffer-undo-list t) - mail-setup-hook msg node) - (setq m-p-alist - (sort m-p-alist - (function (lambda (a b) - (string< (car a) (car b)))))) - (while (setq node (car m-p-alist)) - (setq msg (gulp-create-message (cdr node) time)) - (setq mail-setup-hook - (lambda () - (mail-subject) - (insert "It's time for Emacs updates again") - (goto-char (point-max)) - (insert msg))) - (mail nil (car node)) - (goto-char (point-min)) - (if (y-or-n-p "Send? ") (mail-send) - (kill-this-buffer) - (set-buffer gulp-tmp-buffer) - (insert (format "%s\n\n" node))) - (setq m-p-alist (cdr m-p-alist)))) - (set-buffer gulp-tmp-buffer) - (setq buffer-undo-list nil))) - - -(defun gulp-create-message (rec time) - "Return the message string for REC, which is a list like (FILE TIME)." - (let (node (str gulp-request-header)) - (while (setq node (car rec)) - (setq str (concat str "\t" (car node) - (if time (concat "\tLast modified:\t" (cdr node))) - "\n")) - (setq rec (cdr rec))) - (concat str gulp-request-end))) - - -(defun gulp-create-m-p-alist (flist dir) - "Create the maintainer/package alist for files in FLIST in DIR. -That is a list of elements, each of the form (MAINTAINER PACKAGES...)." - (save-excursion - (let (mplist filen node mnt tm fl-tm) - (get-buffer-create gulp-tmp-buffer) - (set-buffer gulp-tmp-buffer) - (setq buffer-undo-list t) - (while flist - (setq fl-tm (gulp-maintainer (setq filen (car flist)) dir)) - (if (setq tm (cdr fl-tm) mnt (car fl-tm));; there is a definite maintainer - (if (setq node (assoc mnt mplist));; this is not a new maintainer - (setq mplist (cons (cons mnt (cons (cons filen tm) (cdr node))) - (delete node mplist))) - (setq mplist (cons (list mnt (cons filen (cdr fl-tm))) mplist)))) - (setq flist (cdr flist))) - (erase-buffer) - mplist))) - -(defun gulp-maintainer (filenm dir) - "Return a list (MAINTAINER TIMESTAMP) for the package FILENM in directory DIR." - (save-excursion - (let* ((fl (expand-file-name filenm dir)) mnt - (timest (format-time-string "%Y-%m-%d %a %T %Z" - (elt (file-attributes fl) 5)))) - (set-buffer gulp-tmp-buffer) - (erase-buffer) - (insert-file-contents fl nil 0 gulp-max-len) - (goto-char 1) - (if (re-search-forward gulp-discard nil t) - (setq mnt nil) ;; do nothing, return nil - (goto-char 1) - (if (and (re-search-forward "^;+ *Maintainer: \\(.*\\)$" nil t) - (> (length (setq mnt (match-string 1))) 0)) - () ;; found! - (goto-char 1) - (if (re-search-forward "^;+ *Author: \\(.*\\)$" nil t) - (setq mnt (match-string 1)))) - (if (= (length mnt) 0) (setq mnt nil))) ;; "^;; Author: $" --> nil - (cons mnt timest)))) - -(provide 'gulp) - -;;; gulp.el ends here diff --git a/lisp/obsolete/info-edit.el b/lisp/obsolete/info-edit.el deleted file mode 100644 index fb6de736590..00000000000 --- a/lisp/obsolete/info-edit.el +++ /dev/null @@ -1,89 +0,0 @@ -;;; info-edit.el --- Editing info files -*- lexical-binding:t -*- - -;; Copyright (C) 1985-1986, 1992-2024 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: help -;; Obsolete-since: 24.4 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;;; Code: - -(require 'info) - -(defvar Info-edit-mode-hook nil - "Hook run when `Info-edit-mode' is activated.") - -(make-obsolete-variable 'Info-edit-mode-hook - "editing Info nodes by hand is not recommended." "24.4") - -(defvar Info-edit-mode-map (let ((map (make-sparse-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\C-c\C-c" #'Info-cease-edit) - map) - "Local keymap used within `e' command of Info.") - -(make-obsolete-variable 'Info-edit-mode-map - "editing Info nodes by hand is not recommended." - "24.4") - -;; Info-edit mode is suitable only for specially formatted data. -(put 'Info-edit-mode 'mode-class 'special) - -(define-derived-mode Info-edit-mode text-mode "Info Edit" - "Major mode for editing the contents of an Info node. -Like text mode with the addition of `Info-cease-edit' -which returns to Info mode for browsing." - (setq buffer-read-only nil) - (force-mode-line-update) - (buffer-enable-undo (current-buffer))) - -(defun Info-edit () - "Edit the contents of this Info node." - (interactive) - (Info-edit-mode) - (message "%s" (substitute-command-keys - "Editing: Type \\\\[Info-cease-edit] to return to info"))) - -(put 'Info-edit 'disabled "Editing Info nodes by hand is not recommended. -This feature will be removed in future.") - -(defun Info-cease-edit () - "Finish editing Info node; switch back to Info proper." - (interactive) - ;; Do this first, so nothing has changed if user C-g's at query. - (and (buffer-modified-p) - (y-or-n-p "Save the file? ") - (save-buffer)) - (Info-mode) - (force-mode-line-update) - (and (marker-position Info-tag-table-marker) - (buffer-modified-p) - (message "Tags may have changed. Use Info-tagify if necessary"))) - -(with-eval-after-load 'ibuffer - (defvar ibuffer-help-buffer-modes) - ;; Moved here from definition of ibuffer-help-buffer-modes to make - ;; that variable customizable even though this code is obsolete. See - ;; also Bug#30990. - (add-to-list 'ibuffer-help-buffer-modes 'Info-edit-mode)) - -(provide 'info-edit) - -;;; info-edit.el ends here diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el deleted file mode 100644 index e1ea9141f0d..00000000000 --- a/lisp/obsolete/iswitchb.el +++ /dev/null @@ -1,1331 +0,0 @@ -;;; iswitchb.el --- switch between buffers using substrings -*- lexical-binding: t; -*- - -;; Copyright (C) 1996-1997, 2000-2024 Free Software Foundation, Inc. - -;; Author: Stephen Eglen -;; Keywords: completion convenience -;; Obsolete-since: 24.4 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; This file is obsolete - use icomplete-mode or ido-mode instead. - -;; Installation: -;; To get the functions in this package bound to keys, use -;; M-x iswitchb-mode or customize the option `iswitchb-mode'. -;; Alternatively, add the following line to your .emacs: -;; (iswitchb-mode 1) - -;; As you type in a substring, the list of buffers currently matching -;; the substring is displayed as you type. The list is ordered so -;; that the most recent buffers visited come at the start of the list. -;; The buffer at the start of the list will be the one visited when -;; you press return. By typing more of the substring, the list is -;; narrowed down so that gradually the buffer you want will be at the -;; top of the list. Alternatively, you can use C-s and C-r to rotate -;; buffer names in the list until the one you want is at the top of -;; the list. Completion is also available so that you can see what is -;; common to all of the matching buffers as you type. - -;; This code is similar to a couple of other packages. Michael R Cook -;; wrote a similar buffer switching package, but -;; does exact matching rather than substring matching on buffer names. -;; I also modified a couple of functions from icomplete.el to provide -;; the completion feedback in the minibuffer. - -;;; Example - -;; If I have two buffers called "123456" and "123", with "123456" the -;; most recent, when I use iswitchb, I first of all get presented with -;; the list of all the buffers -;; -;; iswitch {123456,123} -;; -;; If I then press 2: -;; iswitch 2[3]{123456,123} -;; -;; The list in {} are the matching buffers, most recent first (buffers -;; visible in the current frame are put at the end of the list by -;; default). At any time I can select the item at the head of the -;; list by pressing RET. I can also put the first element at the end -;; of the list by pressing C-s, or put the last element at the head of -;; the list by pressing C-r. The item in [] indicates what can be -;; added to my input by pressing TAB. In this case, I will get "3" -;; added to my input. So, press TAB: -;; iswitch 23{123456,123} -;; -;; At this point, I still have two matching buffers. -;; If I want the first buffer in the list, I simply press RET. If I -;; wanted the second in the list, I could press C-s to move it to the -;; top of the list and then RET to select it. -;; -;; However, if I type 4, I only have one match left: -;; iswitch 234[123456] [Matched] -;; -;; Since there is only one matching buffer left, it is given in [] and we -;; see the text [Matched] afterwards. I can now press TAB or RET to go -;; to that buffer. -;; -;; If however, I now type "a": -;; iswitch 234a [No match] -;; There are no matching buffers. If I press RET or TAB, I can be -;; prompted to create a new buffer called "234a". -;; -;; Of course, where this function comes in really useful is when you -;; can specify the buffer using only a few keystrokes. In the above -;; example, the quickest way to get to the "123456" buffer would be -;; just to type 4 and then RET (assuming there isn't any newer buffer -;; with 4 in its name). - -;; To see a full list of all matching buffers in a separate buffer, -;; hit ? or press TAB when there are no further completions to the -;; substring. Repeated TAB presses will scroll you through this -;; separate buffer. - -;; The buffer at the head of the list can be killed by pressing C-k. -;; If the buffer needs saving, you will be queried before the buffer -;; is killed. - -;; If you find that the file you are after is not in a buffer, you can -;; press C-x C-f to immediately drop into find-file. - -;; See the doc string of iswitchb for full keybindings and features. -;; (describe-function 'iswitchb) - -;; Case matching: The case of strings when matching can be ignored or -;; used depending on the value of iswitchb-case (default is the same -;; as case-fold-search, normally t). Imagine you have the following -;; buffers: -;; -;; INBOX *info* *scratch* -;; -;; Then these will be the matching buffers, depending on how you type -;; the two letters `in' and the value of iswitchb-case: -;; -;; iswitchb-case user input | matching buffers -;; ---------------------------------------------- -;; nil in | *info* -;; t in | INBOX, *info* -;; t IN | INBOX -;; t In | [No match] - -;;; Customization - -;; See the User Variables section below for easy ways to change the -;; functionality of the program. These are accessible using the -;; custom package. -;; To modify the keybindings, use something like: -;; -;;(add-hook 'iswitchb-mode-hook 'iswitchb-my-keys) -;;(defun iswitchb-my-keys () -;; "Add my keybindings for iswitchb." -;; (define-key iswitchb-mode-map " " 'iswitchb-next-match)) -;; -;; Seeing all the matching buffers -;; -;; If you have many matching buffers, they may not all fit onto one -;; line of the minibuffer. In Emacs 21, the variable -;; `resize-mini-windows' controls how many lines of the minibuffer can -;; be seen. For older versions of emacs, you can use -;; `resize-minibuffer-mode'. You can also limit iswitchb so that it -;; only shows a certain number of lines -- see the documentation for -;; `iswitchb-minibuffer-setup-hook'. - -;; Changing the list of buffers - -;; By default, the list of current buffers is most recent first, -;; oldest last, with the exception that the buffers visible in the -;; current frame are put at the end of the list. A hook exists to -;; allow other functions to order the list. For example, if you add: -;; -;; (add-hook 'iswitchb-make-buflist-hook 'iswitchb-summaries-to-end) -;; -;; then all buffers matching "Summary" are moved to the end of the -;; list. (I find this handy for keeping the INBOX Summary and so on -;; out of the way.) It also moves buffers matching "output\*$" to the -;; end of the list (these are created by AUCTeX when compiling.) -;; Other functions could be made available which alter the list of -;; matching buffers (either deleting or rearranging elements.) - -;; Font-Lock - -;; font-lock is used to highlight the first matching buffer. To -;; switch this off, set (setq iswitchb-use-faces nil). Coloring of -;; the matching buffer name was suggested by Carsten Dominik -;; (dominik@strw.leidenuniv.nl) - -;; Replacement for read-buffer - -;; iswitchb-read-buffer has been written to be a drop in replacement -;; for the normal buffer selection routine `read-buffer'. To use -;; iswitch for all buffer selections in Emacs, add: -;; (setq read-buffer-function #'iswitchb-read-buffer) -;; (This variable was introduced in Emacs 20.3.) - -;; Using iswitchb for other completion tasks. - -;; Kin Cho (kin@neoscale.com) sent the following suggestion to use -;; iswitchb for other completion tasks. -;; -;; (defun my-icompleting-read (prompt choices) -;; "Use iswitch as a completing-read replacement to choose from -;; choices. PROMPT is a string to prompt with. CHOICES is a list of -;; strings to choose from." -;; (let ((iswitchb-make-buflist-hook -;; (lambda () -;; (setq iswitchb-temp-buflist choices)))) -;; (iswitchb-read-buffer prompt))) -;; -;; example: -;; (my-icompleting-read "Which fruit? " ' -;; ("apple" "pineapple" "pear" "bananas" "oranges") ) - -;; Kin Cho also suggested the following defun. Once you have a subset of -;; matching buffers matching your current prompt, you can then press -;; e.g. C-o to restrict matching to those buffers and clearing the prompt: -;; (defun iswitchb-exclude-nonmatching() -;; "Make iswitchb work on only the currently matching names." -;; (interactive) -;; (setq iswitchb-buflist iswitchb-matches) -;; (setq iswitchb-rescan t) -;; (delete-minibuffer-contents)) -;; -;; (add-hook 'iswitchb-define-mode-map-hook -;; (lambda () (define-key -;; iswitchb-mode-map "\C-o" -;; 'iswitchb-exclude-nonmatching))) - -;; Other lisp packages extend iswitchb behavior to other tasks. See -;; ido.el (by Kim Storm) and mcomplete.el (Yuji Minejima). - -;; Window managers: Switching frames/focus follows mouse; Sawfish. - -;; If you switch to a buffer that is visible in another frame, -;; iswitchb can switch focus to that frame. If your window manager -;; uses "click to focus" policy for window selection, you should also -;; set focus-follows-mouse to nil. - -;; iswitch functionality has also been implemented for switching -;; between windows in the Sawfish window manager. - -;; Regexp matching - -;; There is provision for regexp matching within iswitchb, enabled -;; through `iswitchb-regexp'. This allows you to type `c$' for -;; example and see all buffer names ending in `c'. No completion -;; mechanism is currently offered when regexp searching. - -;;; TODO - -;;; Acknowledgments - -;; Thanks to Jari Aalto for help with the -;; first version of this package, iswitch-buffer. Thanks also to many -;; others for testing earlier versions. - -;;; Code: - -(require 'font-lock) - -;;; User Variables -;; -;; These are some things you might want to change. - -(defgroup iswitchb nil - "Switch between buffers using substrings." - :group 'convenience - :group 'completion - :link '(emacs-commentary-link :tag "Commentary" "iswitchb.el") - :link '(url-link "https://www.anc.ed.ac.uk/~stephen/emacs/") - :link '(emacs-library-link :tag "Lisp File" "iswitchb.el")) - -(defcustom iswitchb-case case-fold-search - "Non-nil if searching of buffer names should ignore case. -If this is non-nil but the user input has any upper case letters, matching -is temporarily case sensitive." - :type 'boolean) - -(defcustom iswitchb-buffer-ignore - '("^ ") - "List of regexps or functions matching buffer names to ignore. -For example, traditional behavior is not to list buffers whose names begin -with a space, for which the regexp is `^ '. See the source file for -example functions that filter buffer names." - :type '(repeat (choice regexp function))) -(put 'iswitchb-buffer-ignore 'risky-local-variable t) - -(defcustom iswitchb-max-to-show nil - "If non-nil, limit the number of names shown in the minibuffer. -If this value is N, and N is greater than the number of matching -buffers, the first N/2 and the last N/2 matching buffers are -shown. This can greatly speed up iswitchb if you have a -multitude of buffers open." - :type '(choice (const :tag "Show all" nil) integer)) - -(defcustom iswitchb-use-virtual-buffers nil - "If non-nil, refer to past buffers when none match. -This feature relies upon the `recentf' package, which will be -enabled if this variable is configured to a non-nil value." - :type 'boolean - :require 'recentf - :set (function - (lambda (sym value) - (if value (recentf-mode 1)) - (set sym value)))) - -(defvar iswitchb-virtual-buffers nil) - -(defcustom iswitchb-cannot-complete-hook 'iswitchb-completion-help - "Hook run when `iswitchb-complete' can't complete any more. -The most useful values are `iswitchb-completion-help', which pops up a -window with completion alternatives, or `iswitchb-next-match' or -`iswitchb-prev-match', which cycle the buffer list." - :type 'hook) - -;; Examples for setting the value of iswitchb-buffer-ignore -;;(defun iswitchb-ignore-c-mode (name) -;; "Ignore all c mode buffers -- example function for iswitchb." -;; (with-current-buffer name -;; (derived-mode-p 'c-mode))) - -;;(setq iswitchb-buffer-ignore '("^ " iswitchb-ignore-c-mode)) -;;(setq iswitchb-buffer-ignore '("^ " "\\.c\\'" "\\.h\\'")) - -(defcustom iswitchb-default-method 'always-frame - "How to switch to new buffer when using `iswitchb-buffer'. -Possible values: -`samewindow' Show new buffer in same window -`otherwindow' Show new buffer in another window (same frame) -`display' Display buffer in another window without switching to it -`otherframe' Show new buffer in another frame -`maybe-frame' If a buffer is visible in another frame, prompt to ask if - you want to see the buffer in the same window of the current - frame or in the other frame. -`always-frame' If a buffer is visible in another frame, raise that - frame. Otherwise, visit the buffer in the same window." - :type '(choice (const samewindow) - (const otherwindow) - (const display) - (const otherframe) - (const maybe-frame) - (const always-frame))) - -(defcustom iswitchb-regexp nil - "Non-nil means that `iswitchb' will do regexp matching. -Value can be toggled within `iswitchb' using `iswitchb-toggle-regexp'." - :type 'boolean) - -(defcustom iswitchb-newbuffer t - "Non-nil means create new buffer if no buffer matches substring. -See also `iswitchb-prompt-newbuffer'." - :type 'boolean) - -(defcustom iswitchb-prompt-newbuffer t - "Non-nil means prompt user to confirm before creating new buffer. -See also `iswitchb-newbuffer'." - :type 'boolean) - -(defcustom iswitchb-use-faces t - "Non-nil means use font-lock faces for showing first match." - :type 'boolean) - -(defcustom iswitchb-use-frame-buffer-list nil - "Non-nil means use the currently selected frame's buffer list." - :type 'boolean) - -(defcustom iswitchb-make-buflist-hook nil - "Hook to run when list of matching buffers is created." - :type 'hook) - -(defcustom iswitchb-delim "," - "Delimiter to put between buffer names when displaying results." - :type 'string) - -(defcustom iswitchb-all-frames 'visible - "Argument to pass to `walk-windows' when iswitchb is finding buffers. -See documentation of `walk-windows' for useful values." - :type '(choice (const :tag "Selected frame only" nil) - (const :tag "All existing frames" t) - (const :tag "All visible frames" visible) - (const :tag "All frames on this terminal" 0))) - -(defcustom iswitchb-minibuffer-setup-hook nil - "Iswitchb-specific customization of minibuffer setup. - -This hook is run during minibuffer setup if `iswitchb' is active. -For instance: -\(add-hook \\='iswitchb-minibuffer-setup-hook - \\='\(lambda () (setq-local max-mini-window-height 3))) -will constrain the minibuffer to a maximum height of 3 lines when -iswitchb is running." - :type 'hook) - -(defface iswitchb-single-match - '((t - (:inherit font-lock-comment-face))) - "Iswitchb face for single matching buffer name." - :version "22.1") - -(defface iswitchb-current-match - '((t - (:inherit font-lock-function-name-face))) - "Iswitchb face for current matching buffer name." - :version "22.1") - -(defface iswitchb-virtual-matches - '((t - (:inherit font-lock-builtin-face))) - "Iswitchb face for matching virtual buffer names. -See also `iswitchb-use-virtual-buffers'." - :version "22.1") - -(defface iswitchb-invalid-regexp - '((t - (:inherit font-lock-warning-face))) - "Iswitchb face for indicating invalid regexp. " - :version "22.1") - -;; Do we need the variable iswitchb-use-mycompletion? - -;;; Internal Variables - -(defvar iswitchb-method nil - "Stores the method for viewing the selected buffer. -Its value is one of `samewindow', `otherwindow', `display', `otherframe', -`maybe-frame' or `always-frame'. See `iswitchb-default-method' for -details of values.") - -(defvar iswitchb-eoinput 1 - "Point where minibuffer input ends and completion info begins. -Copied from `icomplete-eoinput'.") -(make-variable-buffer-local 'iswitchb-eoinput) - -(defvar iswitchb-buflist nil - "Stores the current list of buffers that will be searched through. -The list is ordered, so that the most recent buffers come first, -although by default, the buffers visible in the current frame are put -at the end of the list. Created by `iswitchb-make-buflist'.") - -;; todo -- is this necessary? - -(defvar iswitchb-use-mycompletion nil - "Non-nil means use `iswitchb-buffer' completion feedback. -Should only be set to t by iswitchb functions, so that it doesn't -interfere with other minibuffer usage.") - -(defvar iswitchb-change-word-sub nil - "Private variable used by `iswitchb-word-matching-substring'.") - -(defvar iswitchb-common-match-string nil - "Stores the string that is common to all matching buffers.") - -(defvar iswitchb-rescan nil - "Non-nil means we need to regenerate the list of matching buffers.") - -(defvar iswitchb-text nil - "Stores the users string as it is typed in.") - -(defvar iswitchb-matches nil - "List of buffers currently matching `iswitchb-text'.") - -(defvar iswitchb-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "?" #'iswitchb-completion-help) - (define-key map "\C-s" #'iswitchb-next-match) - (define-key map "\C-r" #'iswitchb-prev-match) - (define-key map [?\C-.] #'iswitchb-next-match) - (define-key map [?\C-,] #'iswitchb-prev-match) - (define-key map "\t" #'iswitchb-complete) - (define-key map "\C-j" #'iswitchb-select-buffer-text) - (define-key map "\C-t" #'iswitchb-toggle-regexp) - (define-key map "\C-x\C-f" #'iswitchb-find-file) - (define-key map "\C-c" #'iswitchb-toggle-case) - (define-key map "\C-k" #'iswitchb-kill-buffer) - (define-key map "\C-m" #'iswitchb-exit-minibuffer) - map) - "Minibuffer keymap for `iswitchb-buffer'.") - -(defvar iswitchb-global-map - (let ((map (make-sparse-keymap))) - (dolist (b '((switch-to-buffer . iswitchb-buffer) - (switch-to-buffer-other-window . iswitchb-buffer-other-window) - (switch-to-buffer-other-frame . iswitchb-buffer-other-frame) - (display-buffer . iswitchb-display-buffer))) - (define-key map (vector 'remap (car b)) (cdr b))) - map) - "Global keymap for `iswitchb-mode'.") - -(defvar iswitchb-history nil - "History of buffers selected using `iswitchb-buffer'.") - -(defvar iswitchb-exit nil - "Flag to monitor how `iswitchb-buffer' exits. -If equal to `takeprompt', we use the prompt as the buffer name to be -selected.") - -(defvar iswitchb-buffer-ignore-orig nil - "Stores original value of `iswitchb-buffer-ignore'.") - -(defvar iswitchb-default nil - "Default buffer for iswitchb.") - -;; The following variables are needed to keep the byte compiler quiet. -(defvar iswitchb-require-match nil - "Non-nil if matching buffer must be selected.") - -(defvar iswitchb-temp-buflist nil - "Stores a temporary version of the buffer list being created.") - -(defvar iswitchb-bufs-in-frame nil - "List of the buffers visible in the current frame.") - -(defvar iswitchb-minibuf-depth nil - "Value we expect to be returned by `minibuffer-depth' in the minibuffer.") - -(defvar iswitchb-common-match-inserted nil - "Non-nil if we have just inserted a common match in the minibuffer.") - -(defvar iswitchb-invalid-regexp) - -;;; FUNCTIONS - -;;; MAIN FUNCTION -(defun iswitchb () - "Switch to buffer matching a substring. -As you type in a string, all of the buffers matching the string are -displayed. When you have found the buffer you want, it can then be -selected. As you type, most keys have their normal keybindings, -except for the following: -\\ - -RET Select the buffer at the front of the list of matches. If the -list is empty, possibly prompt to create new buffer. - -\\[iswitchb-select-buffer-text] Select the current prompt as the buffer. -If no buffer is found, prompt for a new one. - -\\[iswitchb-next-match] Put the first element at the end of the list. -\\[iswitchb-prev-match] Put the last element at the start of the list. -\\[iswitchb-complete] Complete a common suffix to the current string that -matches all buffers. If there is only one match, select that buffer. -If there is no common suffix, show a list of all matching buffers -in a separate window. -\\[iswitchb-toggle-regexp] Toggle regexp searching. -\\[iswitchb-toggle-case] Toggle case-sensitive searching of buffer names. -\\[iswitchb-completion-help] Show list of matching buffers in separate window. -\\[iswitchb-find-file] Exit iswitchb and drop into `find-file'. -\\[iswitchb-kill-buffer] Kill buffer at head of buffer list." - ;;\\[iswitchb-toggle-ignore] Toggle ignoring certain buffers (see \ - ;;`iswitchb-buffer-ignore') - - (let* ((prompt "iswitch ") - iswitchb-invalid-regexp - (buf (iswitchb-read-buffer prompt))) - - ;;(message "chosen text %s" iswitchb-final-text) - ;; Choose the buffer name: either the text typed in, or the head - ;; of the list of matches - - (cond ( (eq iswitchb-exit 'findfile) - (call-interactively 'find-file)) - (iswitchb-invalid-regexp - (message "Won't make invalid regexp named buffer")) - (t - ;; View the buffer - ;;(message "go to buf %s" buf) - ;; Check buf is non-nil. - (if buf - (if (get-buffer buf) - ;; buffer exists, so view it and then exit - (iswitchb-visit-buffer buf) - ;; else buffer doesn't exist - (iswitchb-possible-new-buffer buf))) - )))) - -(defun iswitchb-read-buffer (prompt &optional default require-match - _predicate start matches-set) - "Replacement for the built-in `read-buffer'. -Return the name of a buffer selected. -PROMPT is the prompt to give to the user. -DEFAULT if given is the default buffer to be selected, which will -go to the front of the list. -If REQUIRE-MATCH is non-nil, an existing buffer must be selected. -If START is a string, the selection process is started with that -string. -If MATCHES-SET is non-nil, the buflist is not updated before -the selection process begins. Used by isearchb.el." - ;; The map is generated every time so that it can inherit new - ;; functions. - (let ((map (copy-keymap minibuffer-local-map)) - buf-sel iswitchb-final-text - icomplete-mode) ; prevent icomplete starting up - (define-key map "?" #'iswitchb-completion-help) - (define-key map "\C-s" #'iswitchb-next-match) - (define-key map "\C-r" #'iswitchb-prev-match) - (define-key map "\t" #'iswitchb-complete) - (define-key map "\C-j" #'iswitchb-select-buffer-text) - (define-key map "\C-t" #'iswitchb-toggle-regexp) - (define-key map "\C-x\C-f" #'iswitchb-find-file) - (define-key map "\C-n" #'iswitchb-toggle-ignore) - (define-key map "\C-c" #'iswitchb-toggle-case) - (define-key map "\C-k" #'iswitchb-kill-buffer) - (define-key map "\C-m" #'iswitchb-exit-minibuffer) - (setq iswitchb-mode-map map) - (run-hooks 'iswitchb-define-mode-map-hook) - - (setq iswitchb-exit nil) - (setq iswitchb-default - (if (bufferp default) - (buffer-name default) - default)) - (setq iswitchb-text (or start "")) - (unless matches-set - (setq iswitchb-rescan t) - (iswitchb-make-buflist iswitchb-default) - (iswitchb-set-matches)) - (let - ((minibuffer-local-completion-map iswitchb-mode-map) - ;; Record the minibuffer depth that we expect to find once - ;; the minibuffer is set up and iswitchb-entryfn-p is called. - (iswitchb-minibuf-depth (1+ (minibuffer-depth))) - (iswitchb-require-match require-match)) - ;; prompt the user for the buffer name - (setq iswitchb-final-text (completing-read - prompt ;the prompt - '(("dummy" . 1)) ;table - nil ;predicate - nil ;require-match [handled elsewhere] - start ;initial-contents - 'iswitchb-history))) - (if (and (not (eq iswitchb-exit 'usefirst)) - (get-buffer iswitchb-final-text)) - ;; This happens for example if the buffer was chosen with the mouse. - (setq iswitchb-matches (list iswitchb-final-text) - iswitchb-virtual-buffers nil)) - - ;; If no buffer matched, but a virtual buffer was selected, visit - ;; that file now and act as though that buffer had been selected. - (if (and iswitchb-virtual-buffers - (not (iswitchb-existing-buffer-p))) - (let ((virt (car iswitchb-virtual-buffers)) - (new-buf)) - ;; Keep the name of the buffer returned by find-file-noselect, as - ;; the buffer 'virt' could be a symlink to a file of a different name. - (setq new-buf (buffer-name (find-file-noselect (cdr virt)))) - (setq iswitchb-matches (list new-buf) - iswitchb-virtual-buffers nil))) - - ;; Handling the require-match must be done in a better way. - (if (and require-match - (not (iswitchb-existing-buffer-p))) - (error "Must specify valid buffer")) - - (if (or (eq iswitchb-exit 'takeprompt) - (null iswitchb-matches)) - (setq buf-sel iswitchb-final-text) - ;; else take head of list - (setq buf-sel (car iswitchb-matches))) - - ;; Or possibly choose the default buffer - (if (equal iswitchb-final-text "") - (setq buf-sel (car iswitchb-matches))) - - buf-sel)) - -(defun iswitchb-existing-buffer-p () - "Return non-nil if there is a matching buffer." - (not (null iswitchb-matches))) - -;;; COMPLETION CODE - -(defun iswitchb-set-common-completion () - "Find common completion of `iswitchb-text' in `iswitchb-matches'. -The result is stored in `iswitchb-common-match-string'." - - (let (val) - (setq iswitchb-common-match-string nil) - (if (and iswitchb-matches - (not iswitchb-regexp) ;; testing - (stringp iswitchb-text) - (> (length iswitchb-text) 0)) - (if (setq val (iswitchb-find-common-substring - iswitchb-matches iswitchb-text)) - (setq iswitchb-common-match-string val))) - val)) - -(defun iswitchb-complete () - "Try and complete the current pattern amongst the buffer names." - (interactive) - (let (res) - (cond ((not iswitchb-matches) - (run-hooks 'iswitchb-cannot-complete-hook)) - (iswitchb-invalid-regexp - ;; Do nothing - ) - ((= 1 (length iswitchb-matches)) - ;; only one choice, so select it. - (exit-minibuffer)) - - (t - ;; else there could be some completions - (setq res iswitchb-common-match-string) - (if (and (not (memq res '(t nil))) - (not (equal res iswitchb-text))) - ;; found something to complete, so put it in the minibuffer. - (progn - (setq iswitchb-rescan nil - iswitchb-common-match-inserted t) - (delete-region (minibuffer-prompt-end) (point)) - (insert res)) - ;; else nothing to complete - (run-hooks 'iswitchb-cannot-complete-hook) - ))))) - -;;; TOGGLE FUNCTIONS - -(defun iswitchb-toggle-case () - "Toggle the value of variable `iswitchb-case'." - (interactive) - (setq iswitchb-case (not iswitchb-case)) - ;; ask for list to be regenerated. - (setq iswitchb-rescan t)) - -(defun iswitchb-toggle-regexp () - "Toggle the value of `iswitchb-regexp'." - (interactive) - (setq iswitchb-regexp (not iswitchb-regexp)) - ;; ask for list to be regenerated. - (setq iswitchb-rescan t)) - -(defun iswitchb-toggle-ignore () - "Toggle ignoring buffers specified with `iswitchb-buffer-ignore'." - (interactive) - (if iswitchb-buffer-ignore - (progn - (setq iswitchb-buffer-ignore-orig iswitchb-buffer-ignore) - (setq iswitchb-buffer-ignore nil)) - ;; else - (setq iswitchb-buffer-ignore iswitchb-buffer-ignore-orig)) - (iswitchb-make-buflist iswitchb-default) - ;; ask for list to be regenerated. - (setq iswitchb-rescan t)) - -(defun iswitchb-exit-minibuffer () - "Exit minibuffer, but make sure we have a match if one is needed." - (interactive) - (if (or (not iswitchb-require-match) - (iswitchb-existing-buffer-p)) - (progn - (setq iswitchb-exit 'usefirst) - (throw 'exit nil)))) - -(defun iswitchb-select-buffer-text () - "Select the buffer named by the prompt. -If no buffer exactly matching the prompt exists, maybe create a new one." - (interactive) - (setq iswitchb-exit 'takeprompt) - (exit-minibuffer)) - -(defun iswitchb-find-file () - "Drop into `find-file' from buffer switching." - (interactive) - (setq iswitchb-exit 'findfile) - (exit-minibuffer)) - -(defvar recentf-list) - -(defun iswitchb-next-match () - "Put first element of `iswitchb-matches' at the end of the list." - (interactive) - (let ((next (cadr iswitchb-matches))) - (if (and (null next) iswitchb-virtual-buffers) - (setq recentf-list - (iswitchb-chop recentf-list - (cdr (cadr iswitchb-virtual-buffers)))) - (setq iswitchb-buflist (iswitchb-chop iswitchb-buflist next))) - (setq iswitchb-rescan t))) - -(defun iswitchb-prev-match () - "Put last element of `iswitchb-matches' at the front of the list." - (interactive) - (let ((prev (car (last iswitchb-matches)))) - (if (and (null prev) iswitchb-virtual-buffers) - (setq recentf-list - (iswitchb-chop recentf-list - (cdr (car (last iswitchb-virtual-buffers))))) - (setq iswitchb-buflist (iswitchb-chop iswitchb-buflist prev))) - (setq iswitchb-rescan t))) - -(defun iswitchb-chop (list elem) - "Remove all elements before ELEM and put them at the end of LIST." - (let ((ret nil) - (next nil) - (sofar nil)) - (while (not ret) - (setq next (car list)) - (if (equal next elem) - (setq ret (append list (nreverse sofar))) - ;; else - (progn - (setq list (cdr list)) - (setq sofar (cons next sofar))))) - ret)) - -;;; CREATE LIST OF ALL CURRENT BUFFERS - -(defun iswitchb-make-buflist (default) - "Set `iswitchb-buflist' to the current list of buffers. -Currently visible buffers are put at the end of the list. -The hook `iswitchb-make-buflist-hook' is run after the list has been -created to allow the user to further modify the order of the buffer names -in this list. If DEFAULT is non-nil, and corresponds to an existing buffer, -it is put to the start of the list." - (setq iswitchb-buflist - (let* ((iswitchb-current-buffers (iswitchb-get-buffers-in-frames)) - (iswitchb-temp-buflist - (delq nil - (mapcar - (lambda (x) - (let ((b-name (buffer-name x))) - (if (not - (or - (iswitchb-ignore-buffername-p b-name) - (memq b-name iswitchb-current-buffers))) - b-name))) - (buffer-list (and iswitchb-use-frame-buffer-list - (selected-frame))))))) - (setq iswitchb-temp-buflist - (nconc iswitchb-temp-buflist iswitchb-current-buffers)) - (run-hooks 'iswitchb-make-buflist-hook) - ;; Should this be after the hooks, or should the hooks be the - ;; final thing to be run? - (if default - (progn - (setq iswitchb-temp-buflist - (delete default iswitchb-temp-buflist)) - (setq iswitchb-temp-buflist - (cons default iswitchb-temp-buflist)))) - iswitchb-temp-buflist))) - -(defun iswitchb-to-end (lst) - "Move the elements from LST to the end of `iswitchb-temp-buflist'." - (dolist (elem lst) - (setq iswitchb-temp-buflist (delq elem iswitchb-temp-buflist))) - (setq iswitchb-temp-buflist (nconc iswitchb-temp-buflist lst))) - -(defun iswitchb-get-buffers-in-frames (&optional current) - "Return the list of buffers that are visible in the current frame. -If optional argument CURRENT is given, restrict searching to the -current frame, rather than all frames, regardless of value of -`iswitchb-all-frames'." - (let ((iswitchb-bufs-in-frame nil)) - (walk-windows 'iswitchb-get-bufname nil - (if current - nil - iswitchb-all-frames)) - iswitchb-bufs-in-frame)) - -(defun iswitchb-get-bufname (win) - "Used by `iswitchb-get-buffers-in-frames' to walk through all windows." - (let ((buf (buffer-name (window-buffer win)))) - (if (not (member buf iswitchb-bufs-in-frame)) - ;; Only add buf if it is not already in list. - ;; This prevents same buf in two different windows being - ;; put into the list twice. - (setq iswitchb-bufs-in-frame - (cons buf iswitchb-bufs-in-frame))))) - -;;; FIND MATCHING BUFFERS - -(defun iswitchb-set-matches () - "Set `iswitchb-matches' to the list of buffers matching prompt." - (if iswitchb-rescan - (setq iswitchb-matches - (let ((buflist iswitchb-buflist)) - (iswitchb-get-matched-buffers iswitchb-text iswitchb-regexp - buflist)) - iswitchb-virtual-buffers nil))) - -(defun iswitchb-get-matched-buffers (regexp - &optional string-format buffer-list) - "Return buffers matching REGEXP. -If STRING-FORMAT is nil, consider REGEXP as just a string. -BUFFER-LIST can be list of buffers or list of strings." - (let ((case-fold-search (iswitchb-case)) - name ret) - (if (null string-format) (setq regexp (regexp-quote regexp))) - (setq iswitchb-invalid-regexp nil) - (condition-case error - (dolist (x buffer-list (nreverse ret)) - (setq name (if (stringp x) x (buffer-name x))) - (when (and (string-match regexp name) - (not (iswitchb-ignore-buffername-p name))) - (push name ret))) - (invalid-regexp - (setq iswitchb-invalid-regexp t) - (cdr error))))) - -(defun iswitchb-ignore-buffername-p (bufname) - "Return t if the buffer BUFNAME should be ignored." - (let ((data (match-data)) - (re-list iswitchb-buffer-ignore) - ignorep - nextstr) - (while re-list - (setq nextstr (car re-list)) - (cond - ((stringp nextstr) - (if (string-match nextstr bufname) - (progn - (setq ignorep t) - (setq re-list nil)))) - ((functionp nextstr) - (if (funcall nextstr bufname) - (progn - (setq ignorep t) - (setq re-list nil))))) - (setq re-list (cdr re-list))) - (set-match-data data) - - ;; return the result - ignorep)) - -(defun iswitchb-word-matching-substring (word) - "Return part of WORD before 1st match to `iswitchb-change-word-sub'. -If `iswitchb-change-word-sub' cannot be found in WORD, return nil." - (let ((case-fold-search (iswitchb-case))) - (let ((m (string-match iswitchb-change-word-sub word))) - (if m - (substring word m) - ;; else no match - nil)))) - -(defun iswitchb-find-common-substring (lis subs) - "Return common string following SUBS in each element of LIS." - (let (res - alist - iswitchb-change-word-sub) - (setq iswitchb-change-word-sub - (if iswitchb-regexp - subs - (regexp-quote subs))) - (setq res (mapcar #'iswitchb-word-matching-substring lis)) - (setq res (delq nil res)) ;; remove any nil elements (shouldn't happen) - (setq alist (mapcar #'iswitchb-makealist res)) ;; could use an OBARRAY - - ;; try-completion returns t if there is an exact match. - (let ((completion-ignore-case (iswitchb-case))) - - (try-completion subs alist)))) - -(defun iswitchb-makealist (res) - "Return dotted pair (RES . 1)." - (cons res 1)) - -;; from Wayne Mesard -(defun iswitchb-rotate-list (lis) - "Destructively remove the last element from LIS. -Return the modified list with the last element prepended to it." - (if (<= (length lis) 1) - lis - (let ((las lis) - (prev lis)) - (while (consp (cdr las)) - (setq prev las - las (cdr las))) - (setcdr prev nil) - (cons (car las) lis)))) - -(defun iswitchb-completion-help () - "Show possible completions in a *Completions* buffer." - ;; we could allow this buffer to be used to select match, but I think - ;; choose-completion-string will need redefining, so it just inserts - ;; choice with out any previous input. - (interactive) - (setq iswitchb-rescan nil) - (let ((buf (current-buffer)) - (temp-buf "*Completions*") - (win)) - - (if (and (eq last-command this-command) - (not iswitchb-common-match-inserted)) - ;; scroll buffer - (progn - (set-buffer temp-buf) - (setq win (get-buffer-window temp-buf)) - (if (pos-visible-in-window-p (point-max) win) - (set-window-start win (point-min)) - (scroll-other-window)) - (set-buffer buf)) - - (with-output-to-temp-buffer temp-buf - (display-completion-list (or iswitchb-matches iswitchb-buflist))) - (setq iswitchb-common-match-inserted nil)))) - -;;; KILL CURRENT BUFFER - -(defun iswitchb-kill-buffer () - "Kill the buffer at the head of `iswitchb-matches'." - (interactive) - (let ((enable-recursive-minibuffers t) - buf) - - (setq buf (car iswitchb-matches)) - ;; check to see if buf is non-nil. - (if buf - (let ((bufobjs (mapcar (lambda (name) - (or (get-buffer name) name)) - iswitchb-buflist))) - (kill-buffer buf) - - ;; Check if buffer exists. XEmacs gnuserv.el makes alias - ;; for kill-buffer which does not return t if buffer is - ;; killed, so we can't rely on kill-buffer return value. - (if (get-buffer buf) - ;; buffer couldn't be killed. - (setq iswitchb-rescan t) - ;; Else `kill-buffer' succeeds so re-make the buffer list - ;; taking into account packages like uniquify may rename - ;; buffers, and try to preserve the ordering of buffers. - (setq iswitchb-buflist - (delq nil (mapcar (lambda (b) - (if (bufferp b) - (buffer-name b) - b)) - bufobjs)))))))) - -;;; VISIT CHOSEN BUFFER -(defun iswitchb-visit-buffer (buffer) - "Visit buffer named BUFFER according to `iswitchb-method'." - (let (win newframe) - (cond - ((eq iswitchb-method 'samewindow) - (switch-to-buffer buffer)) - - ((memq iswitchb-method '(always-frame maybe-frame)) - (cond - ((and (setq win (iswitchb-window-buffer-p buffer)) - (or (eq iswitchb-method 'always-frame) - (y-or-n-p "Jump to frame? "))) - (setq newframe (window-frame win)) - (if (fboundp 'select-frame-set-input-focus) - (select-frame-set-input-focus newframe) - (raise-frame newframe) - (select-frame newframe) - ) - (select-window win)) - (t - ;; No buffer in other frames... - (switch-to-buffer buffer) - ))) - - ((eq iswitchb-method 'otherwindow) - (switch-to-buffer-other-window buffer)) - - ((eq iswitchb-method 'display) - (display-buffer buffer)) - - ((eq iswitchb-method 'otherframe) - (progn - (switch-to-buffer-other-frame buffer) - (if (fboundp 'select-frame-set-input-focus) - (select-frame-set-input-focus (selected-frame))) - ))))) - -(defun iswitchb-possible-new-buffer (buf) - "Possibly create and visit a new buffer called BUF." - - (let ((newbufcreated)) - (if (and iswitchb-newbuffer - (or - (not iswitchb-prompt-newbuffer) - - (and iswitchb-prompt-newbuffer - (y-or-n-p - (format-message - "No buffer matching `%s', create one? " - buf))))) - ;; then create a new buffer - (progn - (setq newbufcreated (get-buffer-create buf)) - (set-buffer-major-mode newbufcreated) - (iswitchb-visit-buffer newbufcreated)) - ;; else won't create new buffer - (message "no buffer matching `%s'" buf)))) - -(defun iswitchb-window-buffer-p (buffer) - "Return window pointer if BUFFER is visible in another frame. -If BUFFER is visible in the current frame, return nil." - (interactive) - (let ((blist (iswitchb-get-buffers-in-frames 'current))) - ;; If the buffer is visible in current frame, return nil - (unless (member buffer blist) - ;; maybe in other frame or icon - (get-buffer-window buffer 0) ; better than 'visible - ))) - -(defun iswitchb-buffer () - "Switch to another buffer. - -The buffer name is selected interactively by typing a substring. The -buffer is displayed according to `iswitchb-default-method' -- the -default is to show it in the same window, unless it is already visible -in another frame. -For details of keybindings, do `\\[describe-function] iswitchb'." - (interactive) - (setq iswitchb-method iswitchb-default-method) - (iswitchb)) - -(defun iswitchb-buffer-other-window () - "Switch to another buffer and show it in another window. -The buffer name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] iswitchb'." - (interactive) - (setq iswitchb-method 'otherwindow) - (iswitchb)) - -(defun iswitchb-display-buffer () - "Display a buffer in another window but don't select it. -The buffer name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] iswitchb'." - (interactive) - (setq iswitchb-method 'display) - (iswitchb)) - -(defun iswitchb-buffer-other-frame () - "Switch to another buffer and show it in another frame. -The buffer name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] iswitchb'." - (interactive) - (setq iswitchb-method 'otherframe) - (iswitchb)) - -;;; ICOMPLETE TYPE CODE - -(defun iswitchb-exhibit () - "Find matching buffers and display a list in the minibuffer. -Copied from `icomplete-exhibit' with two changes: -1. It prints a default buffer name when there is no text yet entered. -2. It calls my completion routine rather than the standard completion." - (if iswitchb-use-mycompletion - (let ((contents (buffer-substring (minibuffer-prompt-end) (point-max))) - (buffer-undo-list t)) - (save-excursion - (goto-char (point-max)) - ; Register the end of input, so we - ; know where the extra stuff - ; (match-status info) begins: - (if (not (boundp 'iswitchb-eoinput)) - ;; In case it got wiped out by major mode business: - (make-local-variable 'iswitchb-eoinput)) - (setq iswitchb-eoinput (point)) - ;; Update the list of matches - (setq iswitchb-text contents) - (iswitchb-set-matches) - (setq iswitchb-rescan t) - (iswitchb-set-common-completion) - - ;; Insert the match-status information: - (insert (iswitchb-completions - contents)))))) - -(defun iswitchb-completions (name) - "Return the string that is displayed after the user's text. -Modified from `icomplete-completions'." - - (let ((comps iswitchb-matches) - ; "-determined" - only one candidate - (open-bracket-determined "[") - (close-bracket-determined "]") - ;"-prospects" - more than one candidate - (open-bracket-prospects "{") - (close-bracket-prospects "}") - first) - - (if (and iswitchb-use-faces comps) - (progn - (setq first (copy-sequence (car comps))) - (setq first (format "%s" first)) - (put-text-property 0 (length first) 'face - (if (= (length comps) 1) - (if iswitchb-invalid-regexp - 'iswitchb-invalid-regexp - 'iswitchb-single-match) - 'iswitchb-current-match) - first) - (setq comps (cons first (cdr comps))))) - - ;; If no buffers matched, and virtual buffers are being used, then - ;; consult the list of past visited files, to see if we can find - ;; the file which the user might thought was still open. - (when (and iswitchb-use-virtual-buffers (null comps) - recentf-list) - (setq iswitchb-virtual-buffers nil) - (let ((head recentf-list) name) - (while head - (if (and (setq name (file-name-nondirectory (car head))) - (string-match (if iswitchb-regexp - iswitchb-text - (regexp-quote iswitchb-text)) name) - (null (get-file-buffer (car head))) - (not (assoc name iswitchb-virtual-buffers)) - (not (iswitchb-ignore-buffername-p name)) - (file-exists-p (car head))) - (setq iswitchb-virtual-buffers - (cons (cons name (car head)) - iswitchb-virtual-buffers))) - (setq head (cdr head))) - (setq iswitchb-virtual-buffers (nreverse iswitchb-virtual-buffers) - comps (mapcar #'car iswitchb-virtual-buffers)) - (let ((comp comps)) - (while comp - (put-text-property 0 (length (car comp)) - 'face 'iswitchb-virtual-matches - (car comp)) - (setq comp (cdr comp)))))) - - (cond ((null comps) (format " %sNo match%s" - open-bracket-determined - close-bracket-determined)) - - (iswitchb-invalid-regexp - (concat " " (car comps))) - ((null (cdr comps)) ;one match - (concat - (if (if (not iswitchb-regexp) - (= (length name) - (length (car comps))) - (string-match name (car comps)) - (string-equal (match-string 0 (car comps)) - (car comps))) - "" - (concat open-bracket-determined - ;; when there is one match, show the - ;; matching buffer name in full - (car comps) - close-bracket-determined)) - (if (not iswitchb-use-faces) " [Matched]"))) - (t ;multiple matches - (if (and iswitchb-max-to-show - (> (length comps) iswitchb-max-to-show)) - (setq comps - (append - (let ((res nil) - (comp comps) - (end (/ iswitchb-max-to-show 2))) - (while (>= (setq end (1- end)) 0) - (setq res (cons (car comp) res) - comp (cdr comp))) - (nreverse res)) - (list "...") - (nthcdr (- (length comps) - (/ iswitchb-max-to-show 2)) - comps)))) - (let* ( - (alternatives - (mapconcat #'identity comps iswitchb-delim))) - - (concat - - ;; put in common completion item -- what you get by - ;; pressing tab - (if (and (stringp iswitchb-common-match-string) - (> (length iswitchb-common-match-string) (length name))) - (concat open-bracket-determined - (substring iswitchb-common-match-string - (length name)) - close-bracket-determined)) - ;; end of partial matches... - - ;; list all alternatives - open-bracket-prospects - alternatives - close-bracket-prospects)))))) - -(defun iswitchb-minibuffer-setup () - "Set up minibuffer for `iswitchb-buffer'. -Copied from `icomplete-minibuffer-setup-hook'." - (when (iswitchb-entryfn-p) - (setq-local iswitchb-use-mycompletion t) - (add-hook 'pre-command-hook #'iswitchb-pre-command nil t) - (add-hook 'post-command-hook #'iswitchb-post-command nil t) - (run-hooks 'iswitchb-minibuffer-setup-hook))) - -(defun iswitchb-pre-command () - "Run before command in `iswitchb-buffer'." - (iswitchb-tidy)) - -(defun iswitchb-post-command () - "Run after command in `iswitchb-buffer'." - (iswitchb-exhibit)) - -(defun iswitchb-tidy () - "Remove completions display, if any, prior to new user input. -Copied from `icomplete-tidy'." - - (if (and (boundp 'iswitchb-eoinput) - iswitchb-eoinput) - - (if (> iswitchb-eoinput (point-max)) - ;; Oops, got rug pulled out from under us - reinit: - (setq iswitchb-eoinput (point-max)) - (let ((buffer-undo-list buffer-undo-list )) ; prevent entry - (delete-region iswitchb-eoinput (point-max)))) - - ;; Reestablish the local variable 'cause minibuffer-setup is weird: - (make-local-variable 'iswitchb-eoinput) - (setq iswitchb-eoinput 1))) - -(defun iswitchb-entryfn-p () - "Return non-nil if we are using `iswitchb-buffer'." - (eq iswitchb-minibuf-depth (minibuffer-depth))) - -(defun iswitchb-summaries-to-end () - "Move the summaries to the end of the list. -This is an example function which can be hooked on to -`iswitchb-make-buflist-hook'. Any buffer matching the regexps -`Summary' or `output\\*$'are put to the end of the list." - (let ((summaries (delq nil - (mapcar - (lambda (x) - (if (string-match "Summary\\|output\\*$" x) - x)) - iswitchb-temp-buflist)))) - (iswitchb-to-end summaries))) - -(defun iswitchb-case () - "Return non-nil if we should ignore case when matching. -See the variable `iswitchb-case' for details." - (if iswitchb-case - (isearch-no-upper-case-p iswitchb-text t))) - -;;;###autoload -(define-minor-mode iswitchb-mode - "Toggle Iswitchb mode. - -Iswitchb mode is a global minor mode that enables switching -between buffers using substrings. See `iswitchb' for details." - :keymap iswitchb-global-map :global t - (if iswitchb-mode - (add-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup) - (remove-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup))) - -(provide 'iswitchb) - -;;; iswitchb.el ends here diff --git a/lisp/obsolete/meese.el b/lisp/obsolete/meese.el deleted file mode 100644 index 7443bacc8b2..00000000000 --- a/lisp/obsolete/meese.el +++ /dev/null @@ -1,38 +0,0 @@ -;;; meese.el --- protect the impressionable young minds of America -*- lexical-binding: t; -*- - -;; This is in the public domain on account of being distributed since -;; 1985 or 1986 without a copyright notice. - -;; This file is part of GNU Emacs. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: games -;; Obsolete-since: 24.4 - -;;; Commentary: - -;; Adds a hook to protect the impressionable young minds of America -;; from reading certain files in the Emacs distribution using Emacs. - -;; This file is named after Ed Meese, the US Attorney General -;; under President Reagan, because of his support for censorship. - -;;; Code: - -(defun protect-innocence-hook () - (let ((dir (file-name-directory buffer-file-name))) - (if (and (equal buffer-file-name (expand-file-name "sex.6" dir)) - (file-exists-p buffer-file-name) - (not (y-or-n-p "Are you over 18? "))) - (progn - (clear-visited-file-modtime) - (setq buffer-file-name (expand-file-name "celibacy.1" dir)) - (let ((inhibit-read-only t)) ; otherwise (erase-buffer) may bomb. - (erase-buffer) - (insert-file-contents buffer-file-name t)) - (rename-buffer (file-name-nondirectory buffer-file-name)))))) - -;;;(add-hook 'find-file-hook 'protect-innocence-hook) -(provide 'meese) - -;;; meese.el ends here diff --git a/lisp/obsolete/messcompat.el b/lisp/obsolete/messcompat.el deleted file mode 100644 index b30794c0eae..00000000000 --- a/lisp/obsolete/messcompat.el +++ /dev/null @@ -1,55 +0,0 @@ -;;; messcompat.el --- making message mode compatible with mail mode -*- lexical-binding: t; -*- - -;; Copyright (C) 1996-2024 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; Keywords: mail, news -;; Obsolete-since: 26.1 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; This file tries to provide backward compatibility with sendmail.el -;; for Message mode. It should be used by simply adding -;; -;; (require 'messcompat) -;; -;; to the .emacs file. Loading it after Message mode has been -;; loaded will have no effect. - -;;; Code: - -(require 'sendmail) - -;(setq message-from-style mail-from-style) -;(setq message-interactive mail-interactive) -(setq message-setup-hook mail-setup-hook) -(setq message-mode-hook mail-mode-hook) -;(setq message-indentation-spaces mail-indentation-spaces) -;(setq message-signature mail-signature) -;(setq message-signature-file mail-signature-file) -(setq message-default-headers mail-default-headers) -(setq message-send-hook mail-send-hook) -(setq message-send-mail-function send-mail-function) - -(provide 'messcompat) - -;;; messcompat.el ends here - -;; Local Variables: -;; no-byte-compile: t -;; End: diff --git a/lisp/obsolete/rcompile.el b/lisp/obsolete/rcompile.el deleted file mode 100644 index 258b2b519d9..00000000000 --- a/lisp/obsolete/rcompile.el +++ /dev/null @@ -1,180 +0,0 @@ -;;; rcompile.el --- run a compilation on a remote machine -*- lexical-binding: t; -*- - -;; Copyright (C) 1993-1994, 2001-2024 Free Software Foundation, Inc. - -;; Author: Alon Albert -;; Maintainer: emacs-devel@gnu.org -;; Created: 1993 Oct 6 -;; Keywords: tools, processes -;; Obsolete-since: 24.4 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; This package is for running a remote compilation and using emacs to parse -;; the error messages. It works by rsh'ing the compilation to a remote host -;; and parsing the output. If the file visited at the time remote-compile was -;; called was loaded remotely (ange-ftp), the host and user name are obtained -;; by the calling ange-ftp-ftp-name on the current directory. In this case the -;; next-error command will also ange-ftp the files over. This is achieved -;; automatically because the compilation-parse-errors function uses -;; default-directory to build its file names. If however the file visited was -;; loaded locally, remote-compile prompts for a host and user and assumes the -;; files mounted locally (otherwise, how was the visited file loaded). - -;; See the user defined variables section for more info. - -;; I was contemplating redefining "compile" to "remote-compile" automatically -;; if the file visited was ange-ftp'ed but decided against it for now. If you -;; feel this is a good idea, let me know and I'll consider it again. - -;; Installation: - -;; To use rcompile, you also need to give yourself permission to connect to -;; the remote host. You do this by putting lines like: - -;; monopoly alon -;; vme33 -;; -;; in a file named .rhosts in the home directory (of the remote machine). -;; Be careful what you put in this file. A line like: -;; -;; + -;; -;; Will allow anyone access to your account without a password. I suggest you -;; read the rhosts(5) manual page before you edit this file (if you are not -;; familiar with it already) - -;;; Code: - -(provide 'rcompile) -(require 'compile) -;;; The following should not be needed. -;;; (eval-when-compile (require 'ange-ftp)) - -;;;; user defined variables - -(defgroup remote-compile nil - "Run a compilation on a remote machine." - :group 'processes - :group 'tools) - - -(defcustom remote-compile-host nil - "Host for remote compilations." - :type '(choice string (const nil))) - -(defcustom remote-compile-user nil - "User for remote compilations. -nil means use the value returned by \\[user-login-name]." - :type '(choice string (const nil))) - -(defcustom remote-compile-run-before nil - "Command to run before compilation. -This can be used for setting up environment variables, -since rsh does not invoke the shell as a login shell and files like .login -\(tcsh) and .bash_profile \(bash) are not run. -nil means run no commands." - :type '(choice string (const nil))) - -(defcustom remote-compile-prompt-for-host nil - "Non-nil means prompt for host if not available from filename." - :type 'boolean) - -(defcustom remote-compile-prompt-for-user nil - "Non-nil means prompt for user if not available from filename." - :type 'boolean) - -;;;; internal variables - -;; History of remote compile hosts and users -(defvar remote-compile-host-history nil) -(defvar remote-compile-user-history nil) - - -;;;; entry point - -;; We use the Tramp internal function `tramp-make-tramp-file-name'. -;; It has changed its signature in Emacs 27.1, supporting still the -;; old calling convention. Let's assume rcompile.el has been removed -;; once Tramp does not support it any longer. -;; Better would be, if there are functions to provide user, host and -;; localname of a remote filename, independent of Tramp's implementation. -;; The function calls are wrapped by `funcall' in order to pacify the byte -;; compiler. ange-ftp check removed, because it is handled also by Tramp. -;;;###autoload -(defun remote-compile (host user command) - "Compile the current buffer's directory on HOST. Log in as USER. -See \\[compile]." - (interactive - (let (host user command prompt) ;; l l-host l-user - (setq prompt (if (stringp remote-compile-host) - (format "Compile on host (default %s): " - remote-compile-host) - "Compile on host: ") - host (if (or remote-compile-prompt-for-host - (null remote-compile-host)) - (read-from-minibuffer prompt - "" nil nil - 'remote-compile-host-history) - remote-compile-host) - user (if remote-compile-prompt-for-user - (read-from-minibuffer (format - "Compile by user (default %s): " - (or remote-compile-user - (user-login-name))) - "" nil nil - 'remote-compile-user-history) - remote-compile-user)) - (setq command (read-from-minibuffer "Compile command: " - compile-command nil nil - '(compile-history . 1))) - (list (if (string= host "") remote-compile-host host) - (if (string= user "") remote-compile-user user) - command))) - (setq compile-command command) - (cond (user - (setq remote-compile-user user)) - ((null remote-compile-user) - (setq remote-compile-user (user-login-name)))) - (let* (;; localname ;; Pacify byte-compiler. - (compile-command - (format "%s %s -l %s \"(%scd %s; %s)\"" - remote-shell-program - host - remote-compile-user - (if remote-compile-run-before - (concat remote-compile-run-before "; ") - "") - "" - compile-command))) - (setq remote-compile-host host) - (save-some-buffers nil nil) - (compilation-start compile-command) - ;; Set comint-file-name-prefix in the compilation buffer so - ;; compilation-parse-errors will find referenced files by Tramp. - (with-current-buffer next-error-last-buffer - (when (fboundp 'tramp-make-tramp-file-name) - (setq-local comint-file-name-prefix - (funcall - #'tramp-make-tramp-file-name - nil ;; method. - remote-compile-user - remote-compile-host - "")))))) - -;;; rcompile.el ends here diff --git a/lisp/obsolete/sup-mouse.el b/lisp/obsolete/sup-mouse.el deleted file mode 100644 index e7bb58950a0..00000000000 --- a/lisp/obsolete/sup-mouse.el +++ /dev/null @@ -1,203 +0,0 @@ -;;; sup-mouse.el --- supdup mouse support for lisp machines -*- lexical-binding: t; -*- - -;; Copyright (C) 1985-1986, 2001-2024 Free Software Foundation, Inc. - -;; Author: Wolfgang Rupprecht -;; Maintainer: emacs-devel@gnu.org -;; Created: 21 Nov 1986 -;; Keywords: hardware -;; Obsolete-since: 24.4 - -;; (from code originally written by John Robinson@bbn for the bitgraph) - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;;; Code: - -;;; User customization option: - -(defcustom sup-mouse-fast-select-window nil - "Non-nil means mouse hits select new window, then execute. -Otherwise just select." - :type 'boolean - :group 'mouse) - -(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 mode line 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 :;;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- (frame-height)))) - (same-window-p (and (not in-minibuf-p) (eq window old-window))) - (in-mode-line-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-mode-line-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 frame coordinates. -X and Y are 0-based character positions on the frame." - (get-window-with-predicate (lambda (w) - (coordinates-in-window-p (cons x y) w)))) - -(provide 'sup-mouse) - -;;; sup-mouse.el ends here diff --git a/lisp/obsolete/tpu-edt.el b/lisp/obsolete/tpu-edt.el deleted file mode 100644 index 50b8cf328b0..00000000000 --- a/lisp/obsolete/tpu-edt.el +++ /dev/null @@ -1,2445 +0,0 @@ -;;; tpu-edt.el --- Emacs emulating TPU emulating EDT -*- lexical-binding: t; -*- - -;; Copyright (C) 1993-1995, 2000-2024 Free Software Foundation, Inc. - -;; Author: Rob Riepel -;; Version: 4.5 -;; Keywords: emulations -;; Obsolete-since: 24.5 - -;; 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 3 of the License, 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. If not, see . - -;; TPU-edt is based on tpu.el by Jeff Kowalski and Bob Covey. - -;;; Commentary: - -;; %% TPU-edt -- Emacs emulating TPU emulating EDT - -;; %% Contents - -;; % Introduction -;; % Differences Between TPU-edt and DEC TPU/edt -;; % Starting TPU-edt -;; % Customizing TPU-edt using the Emacs Initialization File -;; % Regular Expressions in TPU-edt - - -;; %% Introduction - -;; TPU-edt emulates the popular DEC VMS editor EDT (actually, it emulates -;; DEC TPU's EDT emulation, hence the name TPU-edt). TPU-edt features the -;; following TPU/edt functionality: - -;; . EDT keypad -;; . On-line help -;; . Repeat counts -;; . Scroll margins -;; . Learn sequences -;; . Free cursor mode -;; . Rectangular cut and paste -;; . Multiple windows and buffers -;; . TPU line-mode REPLACE command -;; . Wild card search and substitution -;; . Configurable through an initialization file -;; . History recall of search strings, file names, and commands - -;; Please note that TPU-edt does NOT emulate TPU. It emulates TPU's EDT -;; emulation. Very few TPU line-mode commands are supported. - -;; TPU-edt, like its VMS cousin, works on VT-series terminals with DEC -;; style keyboards. VT terminal emulators, including xterm with the -;; appropriate key translations, work just fine too. - -;; TPU-edt works with X-windows. This is accomplished through a TPU-edt -;; X key map. The tpu-mapper command creates this map and stores it in a -;; file. See the tpu-mapper command help for more information, or just -;; run it and follow the directions. - - -;; %% Differences Between TPU-edt and DEC TPU/edt - -;; In some cases, Emacs doesn't support text highlighting, so selected -;; regions are not shown in inverse video. Emacs uses the concept of "the -;; mark". The mark is set at one end of a selected region; the cursor is -;; at the other. In cases where the selected region cannot be shown in -;; inverse video an at sign (@) appears in the mode line when mark is set. -;; The native Emacs command ^X^X (Control-X twice) exchanges the cursor -;; with the mark; this provides a handy way to find the location of the -;; mark. - -;; In TPU the cursor can be either bound or free. Bound means the cursor -;; cannot wander outside the text of the file being edited. Free means -;; the arrow keys can move the cursor past the ends of lines. Free is the -;; default mode in TPU; bound is the only mode in EDT. Bound is the only -;; mode in the base version of TPU-edt; optional extensions add an -;; approximation of free mode, see the commentary in tpu-extras.el for -;; details. - -;; Like TPU, Emacs uses multiple buffers. Some buffers are used to hold -;; files you are editing; other "internal" buffers are used for Emacs's own -;; purposes (like showing you help). Here are some commands for dealing -;; with buffers. - -;; Gold-B moves to next buffer, including internal buffers -;; Gold-N moves to next buffer containing a file -;; Gold-M brings up a buffer menu (like TPU "show buffers") - -;; Emacs is very fond of throwing up new windows. Dealing with all these -;; windows can be a little confusing at first, so here are a few commands -;; to that may help: - -;; Gold-Next_Scr moves to the next window on the screen -;; Gold-Prev_Scr moves to the previous window on the screen -;; Gold-TAB also moves to the next window on the screen - -;; Control-x 1 deletes all but the current window -;; Control-x 0 deletes the current window - -;; Note that the buffers associated with deleted windows still exist! - -;; Like TPU, TPU-edt has a "command" function, invoked with Gold-KP7 or -;; Do. Most of the commands available are Emacs commands. Some TPU -;; commands are available, they are: replace, exit, quit, include, and -;; Get (unfortunately, "get" is an internal Emacs function, so we are -;; stuck with "Get" - to make life easier, Get is available as Gold-g). - -;; TPU-edt supports the recall of commands, file names, and search -;; strings. The history of strings recalled differs slightly from -;; TPU/edt, but it is still very convenient. - -;; Help is available! The traditional help keys (Help and PF2) display -;; a small help file showing the default keypad layout, control key -;; functions, and Gold key functions. Pressing any key inside of help -;; splits the screen and prints a description of the function of the -;; pressed key. Gold-PF2 invokes the native Emacs help, with its -;; zillions of options. - -;; Thanks to Emacs, TPU-edt has some extensions that may make your life -;; easier, or at least more interesting. For example, Gold-r toggles -;; TPU-edt rectangular mode. In rectangular mode, Remove and Insert work -;; on rectangles. Likewise, Gold-* toggles TPU-edt regular expression -;; mode. In regular expression mode Find, Find Next, and the line-mode -;; replace command work with regular expressions. [A regular expression -;; is a pattern that denotes a set of strings; like VMS wildcards.] - -;; Emacs also gives TPU-edt the undo and occur functions. Undo does -;; what it says; it undoes the last change. Multiple undos in a row -;; undo multiple changes. For your convenience, undo is available on -;; Gold-u. Occur shows all the lines containing a specific string in -;; another window. Moving to that window, and typing ^C^C (Control-C -;; twice) on a particular line moves you back to the original window -;; at that line. Occur is on Gold-o. - -;; Finally, as you edit, remember that all the power of Emacs is at -;; your disposal. It really is a fantastic tool. You may even want to -;; take some time and read the Emacs tutorial; perhaps not to learn the -;; native Emacs key bindings, but to get a feel for all the things -;; Emacs can do for you. The Emacs tutorial is available from the -;; Emacs help function: "Gold-PF2 t" - - -;; %% Starting TPU-edt - -;; All you have to do to start TPU-edt, is turn it on. This can be -;; done from the command line when running Emacs. - -;; prompt> emacs -f tpu-edt - -;; If you've already started Emacs, turn on TPU-edt using the tpu-edt -;; command. First press `M-x' (that's usually `ESC' followed by `x') -;; and type `tpu-edt' followed by a carriage return. - -;; If you like TPU-edt and want to use it all the time, you can start -;; TPU-edt using the Emacs initialization file, .emacs. Simply add -;; the following line to your init file: - -;; (tpu-edt) - -;; That's all you need to do to start TPU-edt. - - -;; %% Customizing TPU-edt using the Emacs Initialization File - -;; The following is a sample Emacs initialization file. It shows how to -;; invoke TPU-edt, and how to customize it. - -;; ; .emacs - a sample Emacs initialization file - -;; ; Turn on TPU-edt -;; (tpu-edt) - -;; ; Set scroll margins 10% (top) and 15% (bottom). -;; (tpu-set-scroll-margins "10%" "15%") - -;; ; Load the vtxxx terminal control functions. -;; (load "vt-control" t) - -;; ; TPU-edt treats words like EDT; here's how to add word separators. -;; ; Note that backslash (\) and double quote (") are quoted with '\'. -;; (tpu-add-word-separators "]\\[-_,.\"=+()'/*#:!&;$") - -;; ; Emacs is happy to save files without a final newline; other Unix -;; ; programs hate that! Here we make sure that files end with newlines. -;; (setq require-final-newline t) - -;; ; Emacs uses Control-s and Control-q. Problems can occur when using -;; ; Emacs on terminals that use these codes for flow control (Xon/Xoff -;; ; flow control). These lines disable Emacs's use of these characters. -;; (global-unset-key "\C-s") -;; (global-unset-key "\C-q") - -;; ; The Emacs universal-argument function is very useful. -;; ; This line maps universal-argument to Gold-PF1. -;; (define-key tpu-gold-map [kp_f1] 'universal-argument) ; Gold-PF1 - -;; ; Make KP7 move by paragraphs, instead of pages. -;; (define-key tpu-global-map [kf_7] 'tpu-paragraph) ; KP7 - -;; ; Repeat the preceding mappings for X-windows. -;; (cond -;; (window-system -;; (define-key tpu-global-map [kp_7] 'tpu-paragraph) ; KP7 -;; (define-key tpu-gold-map [kp_f1] 'universal-argument))) ; GOLD-PF1 - -;; ; Display the TPU-edt version. -;; (tpu-version) - - -;; %% Regular Expressions in TPU-edt - -;; Gold-* toggles TPU-edt regular expression mode. In regular expression -;; mode, find, find next, replace, and substitute accept Emacs regular -;; expressions. A complete list of Emacs regular expressions can be found -;; using the Emacs "info" command (it's somewhat like the VMS help -;; command). Try the following sequence of commands: - -;; DO info -;; m emacs - -;; Type "q" to quit out of info mode. - -;; There is a problem in regular expression mode when searching for empty -;; strings, like beginning-of-line (^) and end-of-line ($). When searching -;; for these strings, find-next may find the current string, instead of the -;; next one. This can cause global replace and substitute commands to loop -;; forever in the same location. For this reason, commands like - -;; replace "^" "> " " to beginning of line> -;; replace "$" "00711" - -;; may not work properly. - -;; Commands like those above are very useful for adding text to the -;; beginning or end of lines. They might work on a line-by-line basis, but -;; go into an infinite loop if the "all" response is specified. If the -;; goal is to add a string to the beginning or end of a particular set of -;; lines TPU-edt provides functions to do this. - -;; Gold-^ Add a string at BOL in region or buffer -;; Gold-$ Add a string at EOL in region or buffer - -;; There is also a TPU-edt interface to the native Emacs string replacement -;; commands. Gold-/ invokes this command. It accepts regular expressions -;; if TPU-edt is in regular expression mode. Given a repeat count, it will -;; perform the replacement without prompting for confirmation. - -;; This command replaces empty strings correctly, however, it has its -;; drawbacks. As a native Emacs command, it has a different interface -;; than the emulated TPU commands. Also, it works only in the forward -;; direction, regardless of the current TPU-edt direction. - -;;; Todo/Bugs: - -;; We shouldn't use vt100 ESC sequences since it is uselessly fighting -;; against function-key-map. Better use real key names. - -;;; Code: - -;; we use picture-mode functions -(require 'picture) - -(defgroup tpu nil - "Emacs emulating TPU emulating EDT." - :prefix "tpu-" - :group 'emulations) - - -;;; -;;; Version Information -;;; -(defconst tpu-version "4.5" "TPU-edt version number.") - - -;;; -;;; User Configurable Variables -;;; -(defcustom tpu-kill-buffers-silently nil - "If non-nil, TPU-edt kills modified buffers without asking." - :type 'boolean) - -(defcustom tpu-percent-scroll 75 - "Percentage of the screen to scroll for next/previous screen commands." - :type 'integer) - -(defcustom tpu-pan-columns 16 - "Number of columns the tpu-pan functions scroll left or right." - :type 'integer) - - -;;; -;;; Global Keymaps -;;; - -(defvar tpu-gold-map - (let ((map (make-keymap))) - ;; Previously we used escape sequences here. We now instead presume - ;; that term/*.el does its job to map the escape sequence to the right - ;; key-symbol. - - (define-key map [up] #'tpu-move-to-beginning) ; up-arrow - (define-key map [down] #'tpu-move-to-end) ; down-arrow - (define-key map [right] #'end-of-line) ; right-arrow - (define-key map [left] #'beginning-of-line) ; left-arrow - - ;; (define-key map [find] nil) ; Find - ;; (define-key map [insert] nil) ; Insert Here - (define-key map [delete] #'tpu-store-text) ; Remove - (define-key map [select] #'tpu-unselect) ; Select - (define-key map [prior] #'tpu-previous-window) ; Prev Screen - (define-key map [next] #'tpu-next-window) ; Next Screen - - ;; (define-key map [f1] nil) ; F1 - ;; (define-key map [f2] nil) ; F2 - ;; (define-key map [f3] nil) ; F3 - ;; (define-key map [f4] nil) ; F4 - ;; (define-key map [f5] nil) ; F5 - ;; (define-key map [f6] nil) ; F6 - ;; (define-key map [f7] nil) ; F7 - ;; (define-key map [f8] nil) ; F8 - ;; (define-key map [f9] nil) ; F9 - ;; (define-key map [f10] nil) ; F10 - ;; (define-key map [f11] nil) ; F11 - ;; (define-key map [f12] nil) ; F12 - ;; (define-key map [f13] nil) ; F13 - ;; (define-key map [f14] nil) ; F14 - (define-key map [help] #'describe-bindings) ; HELP - ;; (define-key map [menu] nil) ; DO - (define-key map [f17] #'tpu-drop-breadcrumb) ; F17 - ;; (define-key map [f18] nil) ; F18 - ;; (define-key map [f19] nil) ; F19 - ;; (define-key map [f20] nil) ; F20 - - (define-key map [kp-f1] #'keyboard-quit) ; PF1 - (define-key map [kp-f3] #'tpu-search) ; PF3 - (define-key map [kp-f4] #'tpu-undelete-lines) ; PF4 - (define-key map [kp-0] #'open-line) ; KP0 - (define-key map [kp-1] #'tpu-change-case) ; KP1 - (define-key map [kp-2] #'tpu-delete-to-eol) ; KP2 - (define-key map [kp-3] #'tpu-special-insert) ; KP3 - (define-key map [kp-4] #'tpu-move-to-end) ; KP4 - (define-key map [kp-5] #'tpu-move-to-beginning) ; KP5 - (define-key map [kp-6] #'tpu-paste) ; KP6 - (define-key map [kp-7] #'execute-extended-command) ; KP7 - (define-key map [kp-8] #'tpu-fill) ; KP8 - (define-key map [kp-9] #'tpu-replace) ; KP9 - (define-key map [kp-subtract] #'tpu-undelete-words) ; KP- - (define-key map [kp-separator] #'tpu-undelete-char) ; KP, - (define-key map [kp-decimal] #'tpu-unselect) ; KP. - (define-key map [kp-enter] #'tpu-substitute) ; KPenter - - ;; - (define-key map "\C-A" #'tpu-toggle-overwrite-mode) ; ^A - ;; (define-key map "\C-B" nil) ; ^B - ;; (define-key map "\C-C" nil) ; ^C - ;; (define-key map "\C-D" nil) ; ^D - ;; (define-key map "\C-E" nil) ; ^E - (define-key map "\C-F" #'set-visited-file-name) ; ^F - (define-key map "\C-g" #'keyboard-quit) ; safety first - (define-key map "\C-h" #'delete-other-windows) ; BS - (define-key map "\C-i" #'other-window) ; TAB - ;; (define-key map "\C-J" nil) ; ^J - (define-key map "\C-K" #'tpu-define-macro-key) ; ^K - (define-key map "\C-l" #'downcase-region) ; ^L - ;; (define-key map "\C-M" nil) ; ^M - ;; (define-key map "\C-N" nil) ; ^N - ;; (define-key map "\C-O" nil) ; ^O - ;; (define-key map "\C-P" nil) ; ^P - ;; (define-key map "\C-Q" nil) ; ^Q - ;; (define-key map "\C-R" nil) ; ^R - ;; (define-key map "\C-S" nil) ; ^S - (define-key map "\C-T" #'tpu-toggle-control-keys) ; ^T - (define-key map "\C-u" #'upcase-region) ; ^U - ;; (define-key map "\C-V" nil) ; ^V - (define-key map "\C-w" #'tpu-write-current-buffers) ; ^W - ;; (define-key map "\C-X" nil) ; ^X - ;; (define-key map "\C-Y" nil) ; ^Y - ;; (define-key map "\C-Z" nil) ; ^Z - (define-key map " " #'undo) ; SPC - ;; (define-key map "!" nil) ; ! - ;; (define-key map "#" nil) ; # - (define-key map "$" #'tpu-add-at-eol) ; $ - (define-key map "%" #'tpu-goto-percent) ; % - ;; (define-key map "&" nil) ; & - ;; (define-key map "(" nil) ; ( - ;; (define-key map ")" nil) ; ) - (define-key map "*" #'tpu-toggle-regexp) ; * - ;; (define-key map "+" nil) ; + - (define-key map "," #'tpu-goto-breadcrumb) ; , - (define-key map "-" #'negative-argument) ; - - (define-key map "." #'tpu-drop-breadcrumb) ; . - (define-key map "/" #'tpu-emacs-replace) ; / - (define-key map "0" #'digit-argument) ; 0 - (define-key map "1" #'digit-argument) ; 1 - (define-key map "2" #'digit-argument) ; 2 - (define-key map "3" #'digit-argument) ; 3 - (define-key map "4" #'digit-argument) ; 4 - (define-key map "5" #'digit-argument) ; 5 - (define-key map "6" #'digit-argument) ; 6 - (define-key map "7" #'digit-argument) ; 7 - (define-key map "8" #'digit-argument) ; 8 - (define-key map "9" #'digit-argument) ; 9 - ;; (define-key map ":" nil) ; : - (define-key map ";" #'tpu-trim-line-ends) ; ; - ;; (define-key map "<" nil) ; < - ;; (define-key map "=" nil) ; = - ;; (define-key map ">" nil) ; > - (define-key map "?" #'tpu-spell-check) ; ? - ;; (define-key map "A" #'tpu-toggle-newline-and-indent) ; A - ;; (define-key map "B" #'tpu-next-buffer) ; B - ;; (define-key map "C" #'repeat-complex-command) ; C - ;; (define-key map "D" #'shell-command) ; D - ;; (define-key map "E" #'tpu-exit) ; E - ;; (define-key map "F" #'tpu-cursor-free-mode) ; F - ;; (define-key map "G" #'tpu-get) ; G - ;; (define-key map "H" nil) ; H - ;; (define-key map "I" #'tpu-include) ; I - ;; (define-key map "K" #'tpu-kill-buffer) ; K - (define-key map "L" #'tpu-what-line) ; L - ;; (define-key map "M" #'buffer-menu) ; M - ;; (define-key map "N" #'tpu-next-file-buffer) ; N - ;; (define-key map "O" #'occur) ; O - (define-key map "P" #'lpr-buffer) ; P - ;; (define-key map "Q" #'tpu-quit) ; Q - ;; (define-key map "R" #'tpu-toggle-rectangle) ; R - ;; (define-key map "S" #'replace) ; S - ;; (define-key map "T" #'tpu-line-to-top-of-window) ; T - ;; (define-key map "U" #'undo) ; U - ;; (define-key map "V" #'tpu-version) ; V - ;; (define-key map "W" #'save-buffer) ; W - ;; (define-key map "X" #'tpu-save-all-buffers-kill-emacs) ; X - ;; (define-key map "Y" #'copy-region-as-kill) ; Y - ;; (define-key map "Z" #'suspend-emacs) ; Z - (define-key map "[" #'blink-matching-open) ; [ - ;; (define-key map "\\" nil) ; \ - (define-key map "]" #'blink-matching-open) ; ] - (define-key map "^" #'tpu-add-at-bol) ; ^ - (define-key map "_" #'split-window-below) ; - - (define-key map "`" #'what-line) ; ` - (define-key map "a" #'tpu-toggle-newline-and-indent) ; a - (define-key map "b" #'tpu-next-buffer) ; b - (define-key map "c" #'repeat-complex-command) ; c - (define-key map "d" #'shell-command) ; d - (define-key map "e" #'tpu-exit) ; e - (define-key map "f" #'tpu-cursor-free-mode) ; f - (define-key map "g" #'tpu-get) ; g - ;; (define-key map "h" nil) ; h - (define-key map "i" #'tpu-include) ; i - (define-key map "k" #'tpu-kill-buffer) ; k - (define-key map "l" #'goto-line) ; l - (define-key map "m" #'buffer-menu) ; m - (define-key map "n" #'tpu-next-file-buffer) ; n - (define-key map "o" #'occur) ; o - (define-key map "p" #'lpr-region) ; p - (define-key map "q" #'tpu-quit) ; q - (define-key map "r" #'tpu-toggle-rectangle) ; r - (define-key map "s" #'replace) ; s - (define-key map "t" #'tpu-line-to-top-of-window) ; t - (define-key map "u" #'undo) ; u - (define-key map "v" #'tpu-version) ; v - (define-key map "w" #'save-buffer) ; w - (define-key map "x" #'tpu-save-all-buffers-kill-emacs) ; x - (define-key map "y" #'copy-region-as-kill) ; y - (define-key map "z" #'suspend-emacs) ; z - ;; (define-key map "{" nil) ; { - (define-key map "|" #'split-window-right) ; | - ;; (define-key map "}" nil) ; } - (define-key map "~" #'exchange-point-and-mark) ; ~ - (define-key map "\177" #'delete-window) ; OP.") - -(defvar tpu-global-map - (let ((map (make-sparse-keymap))) - - ;; Previously defined in CSI-map. We now presume that term/*.el does - ;; its job to map the escape sequence to the right key-symbol. - (define-key map [find] #'tpu-search) ; Find - (define-key map [insert] #'tpu-paste) ; Insert Here - (define-key map [delete] #'tpu-cut) ; Remove - (define-key map [select] #'tpu-select) ; Select - (define-key map [prior] #'tpu-scroll-window-down) ; Prev Screen - (define-key map [next] #'tpu-scroll-window-up) ; Next Screen - - ;; (define-key map [f1] nil) ; F1 - ;; (define-key map [f2] nil) ; F2 - ;; (define-key map [f3] nil) ; F3 - ;; (define-key map [f4] nil) ; F4 - ;; (define-key map [f5] nil) ; F5 - ;; (define-key map [f6] nil) ; F6 - ;; (define-key map [f7] nil) ; F7 - ;; (define-key map [f8] nil) ; F8 - ;; (define-key map [f9] nil) ; F9 - (define-key map [f10] #'tpu-exit) ; F10 - (define-key map [f11] #'tpu-insert-escape) ; F11 (ESC) - (define-key map [f12] #'tpu-next-beginning-of-line) ; F12 (BS) - (define-key map [f13] #'tpu-delete-previous-word) ; F13 (LF) - (define-key map [f14] #'tpu-toggle-overwrite-mode) ; F14 - (define-key map [help] #'tpu-help) ; HELP - (define-key map [menu] #'execute-extended-command) ; DO - (define-key map [f17] #'tpu-goto-breadcrumb) ; F17 - ;; (define-key map [f18] nil) ; F18 - ;; (define-key map [f19] nil) ; F19 - ;; (define-key map [f20] nil) ; F20 - - - ;; Previously defined in SS3-map. We now presume that term/*.el does - ;; its job to map the escape sequence to the right key-symbol. - (define-key map [kp-f1] tpu-gold-map) ; GOLD map - ;; - (define-key map [up] #'tpu-previous-line) ; up - (define-key map [down] #'tpu-next-line) ; down - (define-key map [right] #'tpu-forward-char) ; right - (define-key map [left] #'tpu-backward-char) ; left - - (define-key map [kp-f2] #'tpu-help) ; PF2 - (define-key map [kp-f3] #'tpu-search-again) ; PF3 - (define-key map [kp-f4] #'tpu-delete-current-line) ; PF4 - (define-key map [kp-0] #'tpu-line) ; KP0 - (define-key map [kp-1] #'tpu-word) ; KP1 - (define-key map [kp-2] #'tpu-end-of-line) ; KP2 - (define-key map [kp-3] #'tpu-char) ; KP3 - (define-key map [kp-4] #'tpu-advance-direction) ; KP4 - (define-key map [kp-5] #'tpu-backup-direction) ; KP5 - (define-key map [kp-6] #'tpu-cut) ; KP6 - (define-key map [kp-7] #'tpu-page) ; KP7 - (define-key map [kp-8] #'tpu-scroll-window) ; KP8 - (define-key map [kp-9] #'tpu-append-region) ; KP9 - (define-key map [kp-subtract] #'tpu-delete-current-word) ; KP- - (define-key map [kp-separator] #'tpu-delete-current-char) ; KP, - (define-key map [kp-decimal] #'tpu-select) ; KP. - (define-key map [kp-enter] #'newline) ; KPenter - - map) - "TPU-edt global keymap.") - - -;;; -;;; Global Variables -;;; -(defvar tpu-last-replaced-text "" - "Last text deleted by a TPU-edt replace command.") -(defvar tpu-last-deleted-region "" - "Last text deleted by a TPU-edt remove command.") -(defvar tpu-last-deleted-lines "" - "Last text deleted by a TPU-edt line-delete command.") -(defvar tpu-last-deleted-words "" - "Last text deleted by a TPU-edt word-delete command.") -(defvar tpu-last-deleted-char "" - "Last character deleted by a TPU-edt character-delete command.") - -(defvar tpu-searching-forward t - "If non-nil, TPU-edt is searching in the forward direction.") -(defvar tpu-search-last-string "" - "Last text searched for by the TPU-edt search commands.") -(defvar tpu-search-overlay (make-overlay 1 1) - "Search highlight overlay.") -(overlay-put tpu-search-overlay 'face 'bold) - -(defvar tpu-replace-overlay (make-overlay 1 1) - "Replace highlight overlay.") -(overlay-put tpu-replace-overlay 'face 'highlight) - -(defvar tpu-regexp-p nil - "If non-nil, TPU-edt uses regexp search and replace routines.") -(defvar tpu-rectangular-p nil - "If non-nil, TPU-edt removes and inserts rectangles.") -(defvar tpu-advance t - "True when TPU-edt is operating in the forward direction.") -(defvar tpu-reverse nil - "True when TPU-edt is operating in the backward direction.") -(defvar tpu-control-keys nil - "If non-nil, control keys are set to perform TPU functions.") -(defvar tpu-xkeys-file nil - "File containing TPU-edt X key map.") - -(defvar tpu-rectangle-string nil - "Mode line string to identify rectangular mode.") -(defvar tpu-direction-string nil - "Mode line string to identify current direction.") - -(defvar tpu-add-at-bol-hist nil - "History variable for tpu-edt-add-at-bol function.") -(defvar tpu-add-at-eol-hist nil - "History variable for tpu-edt-add-at-eol function.") -(defvar tpu-regexp-prompt-hist nil - "History variable for search and replace functions.") - - -;;; -;;; Buffer Local Variables -;;; -(defvar tpu-newline-and-indent-p nil - "If non-nil, Return produces a newline and indents.") -(make-variable-buffer-local 'tpu-newline-and-indent-p) - -(defvar tpu-newline-and-indent-string nil - "Mode line string to identify AutoIndent mode.") -(make-variable-buffer-local 'tpu-newline-and-indent-string) - -(defvar tpu-saved-delete-func nil - "Saved value of the delete key.") -(make-variable-buffer-local 'tpu-saved-delete-func) - -(defvar tpu-buffer-local-map nil - "TPU-edt buffer local key map.") -(make-variable-buffer-local 'tpu-buffer-local-map) - - -;;; -;;; Mode Line - Modify the mode line to show the following -;;; -;;; o Mark state. -;;; o Direction of motion. -;;; o Active rectangle mode. -;;; o Active auto indent mode. -;;; -(defvar tpu-original-mm-alist minor-mode-alist) - -(defvar tpu-mark-flag "") -(make-variable-buffer-local 'tpu-mark-flag) - -(defun tpu-set-mode-line (for-tpu) - "Set `minor-mode-alist' for TPU-edt, or reset it to default Emacs." - (let ((entries '((tpu-newline-and-indent-p tpu-newline-and-indent-string) - (tpu-rectangular-p tpu-rectangle-string) - (tpu-direction-string tpu-direction-string) - (tpu-mark-flag tpu-mark-flag)))) - (dolist (entry entries) - (if for-tpu - (add-to-list 'minor-mode-alist entry) - (setq minor-mode-alist (remove entry minor-mode-alist)))))) - -(defun tpu-update-mode-line nil - "Make sure mode-line in the current buffer reflects all changes." - (setq tpu-mark-flag (if transient-mark-mode "" (if (tpu-mark) " @" " "))) - (force-mode-line-update)) - -(add-hook 'activate-mark-hook 'tpu-update-mode-line) -(add-hook 'deactivate-mark-hook 'tpu-update-mode-line) - - -;;; -;;; Match Markers - -;;; -;;; Set in: Search -;;; -;;; Used in: Replace, Substitute, Store-Text, Cut/Remove, -;;; Append, and Change-Case -;;; -(defvar tpu-match-beginning-mark (make-marker)) -(defvar tpu-match-end-mark (make-marker)) - -(defun tpu-set-match nil - "Set markers at match beginning and end." - ;; Add one to beginning mark so it stays with the first character of - ;; the string even if characters are added just before the string. - (setq tpu-match-beginning-mark (copy-marker (match-beginning 0) t)) - (setq tpu-match-end-mark (copy-marker (match-end 0)))) - -(defun tpu-unset-match nil - "Unset match beginning and end markers." - (set-marker tpu-match-beginning-mark nil) - (set-marker tpu-match-end-mark nil)) - -(defun tpu-match-beginning nil - "Return the location of the last match beginning." - (marker-position tpu-match-beginning-mark)) - -(defun tpu-match-end nil - "Return the location of the last match end." - (marker-position tpu-match-end-mark)) - -(defun tpu-check-match nil - "Return t if point is between tpu-match markers. -Otherwise sets the tpu-match markers to nil and returns nil." - ;; make sure 1- marker is in this buffer - ;; 2- point is at or after beginning marker - ;; 3- point is before ending marker, or in the case of - ;; zero length regions (like bol, or eol) that the - ;; beginning, end, and point are equal. - (cond ((and - (equal (marker-buffer tpu-match-beginning-mark) (current-buffer)) - (>= (point) (marker-position tpu-match-beginning-mark)) - (or - (< (point) (marker-position tpu-match-end-mark)) - (and (= (marker-position tpu-match-beginning-mark) - (marker-position tpu-match-end-mark)) - (= (marker-position tpu-match-end-mark) (point))))) t) - (t - (tpu-unset-match) nil))) - -(defun tpu-show-match-markers nil - "Show the values of the match markers." - (interactive) - (if (markerp tpu-match-beginning-mark) - (message "(%s, %s) in %s -- current %s in %s" - (marker-position tpu-match-beginning-mark) - (marker-position tpu-match-end-mark) - (marker-buffer tpu-match-end-mark) - (point) (current-buffer)))) - - -;;; -;;; Utilities -;;; - -(defun tpu-mark nil - "TPU-edt version of the mark function. -Return the appropriate value of the mark for the current -version of Emacs." - (and mark-active (mark (not transient-mark-mode)))) - -(defun tpu-set-mark (pos) - "TPU-edt version of the `set-mark' function. -Sets the mark at POS and activates the region according to the -current version of Emacs." - (set-mark pos)) - -(defun tpu-string-prompt (prompt history-symbol) - "Read a string with PROMPT." - (read-from-minibuffer prompt nil nil nil history-symbol)) - -(defvar tpu-last-answer nil "Most recent response to tpu-y-or-n-p.") - -(defun tpu-y-or-n-p (prompt &optional not-yes) - "Prompt for a y or n answer with positive default. -Optional second argument NOT-YES changes default to negative. -Like Emacs `y-or-n-p', but also accepts space as y and DEL as n." - (message "%s[%s]" prompt (if not-yes "n" "y")) - (let ((doit t)) - (while doit - (setq doit nil) - (let ((ans (read-char))) - (cond ((or (= ans ?y) (= ans ?Y) (= ans ?\ )) - (setq tpu-last-answer t)) - ((or (= ans ?n) (= ans ?N) (= ans ?\C-?)) - (setq tpu-last-answer nil)) - ((= ans ?\r) (setq tpu-last-answer (not not-yes))) - (t - (setq doit t) (beep) - (message "Please answer y or n. %s[%s]" - prompt (if not-yes "n" "y"))))))) - tpu-last-answer) - -(defun tpu-local-set-key (key func) - "Replace a key in the TPU-edt local key map. -Create the key map if necessary." - (cond ((not (keymapp tpu-buffer-local-map)) - (setq tpu-buffer-local-map (if (current-local-map) - (copy-keymap (current-local-map)) - (make-sparse-keymap))) - (use-local-map tpu-buffer-local-map))) - (local-set-key key func)) - -(defun tpu-current-line () - "Return the vertical position of point in the selected window. -Top line is 0. Counts each text line only once, even if it wraps." - (or - (cdr (nth 6 (posn-at-point))) - (if (eq (window-start) (point)) 0 - (1- (count-screen-lines (window-start) (point) 'count-final-newline))))) - - -;;; -;;; Breadcrumbs -;;; -(defvar tpu-breadcrumb-plist nil - "The set of user-defined markers (breadcrumbs), as a plist.") - -(defun tpu-drop-breadcrumb (num) - "Drops a breadcrumb that can be returned to later with goto-breadcrumb." - (interactive "p") - (put tpu-breadcrumb-plist num (list (current-buffer) (point))) - (message "Mark %d set." num)) - -(defun tpu-goto-breadcrumb (num) - "Return to a breadcrumb set with drop-breadcrumb." - (interactive "p") - (cond ((get tpu-breadcrumb-plist num) - (switch-to-buffer (car (get tpu-breadcrumb-plist num))) - (goto-char (cadr (get tpu-breadcrumb-plist num))) - (message "mark %d found." num)) - (t - (message "mark %d not found." num)))) - - -;;; -;;; Miscellaneous -;;; -(defun tpu-change-case (num) - "Change the case of the character under the cursor or region. -Accepts a prefix argument of the number of characters to invert." - (interactive "p") - (cond ((tpu-mark) - (let ((beg (region-beginning)) (end (region-end))) - (while (> end beg) - (funcall (if (= (downcase (char-after beg)) (char-after beg)) - 'upcase-region 'downcase-region) - beg (1+ beg)) - (setq beg (1+ beg))) - (tpu-unselect t))) - ((tpu-check-match) - (let ((beg (tpu-match-beginning)) (end (tpu-match-end))) - (while (> end beg) - (funcall (if (= (downcase (char-after beg)) (char-after beg)) - 'upcase-region 'downcase-region) - beg (1+ beg)) - (setq beg (1+ beg))) - (tpu-unset-match))) - (t - (while (> num 0) - (funcall (if (= (downcase (following-char)) (following-char)) - 'upcase-region 'downcase-region) - (point) (1+ (point))) - (forward-char (if tpu-reverse -1 1)) - (setq num (1- num)))))) - -(defun tpu-fill (num) - "Fill paragraph or marked region. -With argument, fill and justify." - (interactive "P") - (cond ((tpu-mark) - (fill-region (point) (tpu-mark) num) - (tpu-unselect t)) - (t - (fill-paragraph num)))) - -(defun tpu-version nil - "Print the TPU-edt version number." - (interactive) - (message - "TPU-edt version %s by Rob Riepel (riepel@networking.stanford.edu)" - tpu-version)) - -(defun tpu-reset-screen-size (height width) - "Set the screen size." - (interactive "nnew screen height: \nnnew screen width: ") - (set-frame-height (selected-frame) height) - (set-frame-width (selected-frame) width)) - -(defun tpu-toggle-newline-and-indent nil - "Toggle between `newline-and-indent' and simple `newline'." - (interactive) - (cond (tpu-newline-and-indent-p - (setq tpu-newline-and-indent-string "") - (setq tpu-newline-and-indent-p nil) - (tpu-local-set-key "\C-m" 'newline)) - (t - (setq tpu-newline-and-indent-string " AutoIndent") - (setq tpu-newline-and-indent-p t) - (tpu-local-set-key "\C-m" 'newline-and-indent))) - (tpu-update-mode-line) - (and (called-interactively-p 'interactive) - (message "Carriage return inserts a newline%s" - (if tpu-newline-and-indent-p " and indents." ".")))) - -(defun tpu-spell-check nil - "Check the spelling of the region, or of the entire buffer, -if no region is selected." - (interactive) - (let ((m (tpu-mark))) - (apply #'ispell-region - (if m - (if (> m (point)) (list (point) m) - (list m (point))) - (list (point-min) (point-max)))) - (if m (tpu-unselect t)))) - -(defun tpu-toggle-overwrite-mode nil - "Switch in and out of overwrite mode." - (interactive) - (cond (overwrite-mode - (tpu-local-set-key "\177" tpu-saved-delete-func) - (overwrite-mode 0)) - (t - (setq tpu-saved-delete-func (local-key-binding "\177")) - (tpu-local-set-key "\177" 'picture-backward-clear-column) - (overwrite-mode 1)))) - -(defun tpu-special-insert (num) - "Insert a character or control code according to its ASCII decimal value." - (interactive "P") - (if overwrite-mode (delete-char 1)) - (insert (or num 0))) - -(defun tpu-quoted-insert (num) - "Read next input character and insert it. -This is useful for inserting control characters." - (interactive "*p") - (let ((char (read-char)) ) - (if overwrite-mode (delete-char num)) - (insert-char char num))) - - -;;; -;;; TPU line-mode commands -;;; -(defun tpu-include (file) - "TPU-like include file." - (interactive "fInclude file: ") - (insert-file-contents file) - (message "")) - -(defun tpu-get (file) - "TPU-like get file." - (interactive "FFile to get: ") - (find-file file find-file-wildcards)) - -(defun tpu-what-line nil - "Tell what line the point is on, -and the total number of lines in the buffer." - (interactive) - (if (eobp) - (message "You are at the End of Buffer. The last line is %d." - (count-lines 1 (point-max))) - (let* ((cur (count-lines 1 (1+ (point)))) - (max (count-lines 1 (point-max))) - (pct (/ (* 100 (+ cur (/ max 200))) max))) - (message "You are on line %d out of %d (%d%%)." cur max pct)))) - -(defun tpu-exit nil - "Exit the way TPU does, save current buffer and ask about others." - (interactive) - (if (not (eq (recursion-depth) 0)) - (exit-recursive-edit) - (progn (save-buffer) (save-buffers-kill-emacs)))) - -(defun tpu-quit nil - "Quit the way TPU does, ask to make sure changes should be abandoned." - (interactive) - (let ((list (buffer-list)) - (working t)) - (while (and list working) - (let ((buffer (car list))) - (if (and (buffer-file-name buffer) (buffer-modified-p buffer)) - (if (tpu-y-or-n-p - "Modifications will not be saved, continue quitting? ") - (kill-emacs t) (setq working nil))) - (setq list (cdr list)))) - (if working (kill-emacs t)))) - - -;;; -;;; Command and Function Aliases -;;; -;;;###autoload -(define-minor-mode tpu-edt-mode - "Toggle TPU/edt emulation on or off." - :global t - (if tpu-edt-mode (tpu-edt-on) (tpu-edt-off))) - -(defalias 'TPU-EDT-MODE #'tpu-edt-mode) - -;;;###autoload -(defalias 'tpu-edt #'tpu-edt-on) -(defalias 'TPU-EDT #'tpu-edt-on) - -;; Note: The following functions have no `tpu-' prefix. This is unavoidable. -;; The real TPU/edt editor has interactive commands with these names, -;; so tpu-edt.el users expect things like M-x exit RET and M-x help RET -;; to work. Therefore it really is necessary to define these functions, -;; even in cases where they redefine existing Emacs functions. - -(defalias 'exit #'tpu-exit) -(defalias 'EXIT #'tpu-exit) - -(defalias 'Get #'tpu-get) -(defalias 'GET #'tpu-get) - -(defalias 'include #'tpu-include) -(defalias 'INCLUDE #'tpu-include) - -(defalias 'quit #'tpu-quit) -(defalias 'QUIT #'tpu-quit) - -(defalias 'spell #'tpu-spell-check) -(defalias 'SPELL #'tpu-spell-check) - -(defalias 'what\ line #'tpu-what-line) -(defalias 'WHAT\ LINE #'tpu-what-line) - -(defalias 'replace #'tpu-lm-replace) -(defalias 'REPLACE #'tpu-lm-replace) - -(defalias 'help #'tpu-help) -(defalias 'HELP #'tpu-help) - -(defalias 'set\ cursor\ free #'tpu-set-cursor-free) -(defalias 'SET\ CURSOR\ FREE #'tpu-set-cursor-free) - -(defalias 'set\ cursor\ bound #'tpu-set-cursor-bound) -(defalias 'SET\ CURSOR\ BOUND #'tpu-set-cursor-bound) - -(defalias 'set\ scroll\ margins #'tpu-set-scroll-margins) -(defalias 'SET\ SCROLL\ MARGINS #'tpu-set-scroll-margins) - -;; Real TPU error messages end in periods. -;; Define this to avoid openly flouting Emacs coding standards. -(defalias 'tpu-error #'error) - - -;;; -;;; Help -;;; -(defvar tpu-help-keypad-map "\f - _______________________ _______________________________ - | HELP | Do | | | | | | - |KeyDefs| | | | | | | - |_______|_______________| |_______|_______|_______|_______| - _______________________ _______________________________ - | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | - | | |Sto Tex| | key |E-Help | Find |Undel L| - |_______|_______|_______| |_______|_______|_______|_______| - |Select |Pre Scr|Nex Scr| | Page | Sect |Append | Del W | - | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| - |_______|_______|_______| |_______|_______|_______|_______| - |Move up| |Forward|Reverse|Remove | Del C | - | Top | |Bottom | Top |Insert |Undel C| - _______|_______|_______ |_______|_______|_______|_______| - |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | - |StaOfLi|Bottom |EndOfLi| |ChngCas|Del EOL|SpecIns| Enter | - |_______|_______|_______| |_______|_______|_______| | - | Line |Select | Subs | - | Open Line | Reset | | - |_______________|_______|_______| -") - -(defvar tpu-help-text " -\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f - - Control Characters - - ^A toggle insert and overwrite - ^B recall - ^E end of line - - ^G Cancel current operation - ^H beginning of line - ^J delete previous word - - ^K learn - ^L insert page break - ^R remember (during learn), re-center - - ^U delete to beginning of line - ^V quote - ^W refresh - - ^Z exit - ^X^X exchange point and mark - useful for checking region boundaries - -\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f - Gold- Functions - - B Next Buffer - display the next buffer (all buffers) - C Recall - edit and possibly repeat previous commands - E Exit - save current buffer and ask about others - G Get - load a file into a new edit buffer - - I Include - include a file in this buffer - K Kill Buffer - abandon edits and delete buffer - M Buffer Menu - display a list of all buffers - N Next File Buffer - display next buffer containing a file - - O Occur - show following lines containing REGEXP - Q Quit - exit without saving anything - R Toggle rectangular mode for remove and insert - S Search and substitute - line mode REPLACE command - - ^T Toggle control key bindings between TPU and Emacs - U Undo - undo the last edit - W Write - save current buffer - X Exit - save all modified buffers and exit - -\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f - - More extensive documentation on TPU-edt can be found in the `Commentary' - section of tpu-edt.el. This section can be accessed through the standard - Emacs help facility using the `p' option. Once you exit TPU-edt Help, one - of the following key sequences is sure to get you there. - - ^h p if you're not yet using TPU-edt - Gold-PF2 p if you're using TPU-edt - - Alternatively, fire up Emacs help from the command prompt, with - - M-x help-for-help p - - Where `M-x' might be any of `Gold-KP7', `Do', or `ESC-x'. - - When you successfully invoke this part of the Emacs help facility, you - will see a buffer named `*Finder*' listing a number of topics. Look for - tpu-edt under `emulations'. - -\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f - - *** No more help, use P to view previous screen") - -(defvar tpu-help-enter (format "%s" "\eOM")) ; tpu-help enter key symbol -(defvar tpu-help-return (format "%s" "\r")) ; tpu-help enter key symbol -(defvar tpu-help-N "N") ; tpu-help "N" symbol -(defvar tpu-help-n "n") ; tpu-help "n" symbol -(defvar tpu-help-P "P") ; tpu-help "P" symbol -(defvar tpu-help-p "p") ; tpu-help "p" symbol - -(defun tpu-help nil - "Display TPU-edt help." - (interactive) - ;; Save current window configuration - (save-window-excursion - ;; Create and fill help buffer if necessary - (if (not (get-buffer "*TPU-edt Help*")) - (progn (generate-new-buffer "*TPU-edt Help*") - (switch-to-buffer "*TPU-edt Help*") - (insert tpu-help-keypad-map) - (insert tpu-help-text) - (setq buffer-read-only t))) - - ;; Display the help buffer - (switch-to-buffer "*TPU-edt Help*") - (delete-other-windows) - (tpu-move-to-beginning) - (forward-line 1) - (tpu-line-to-top-of-window) - - ;; Prompt for keys to describe, based on screen state (split/not split) - (let ((key nil) (fkey nil) (split nil)) - (while (not (equal tpu-help-return fkey)) - (if split - (setq key - (read-key-sequence - "Press the key you want help on (RET=exit, ENTER=redisplay, N=next, P=prev): ")) - (setq key - (read-key-sequence - "Press the key you want help on (RET to exit, N next screen, P prev screen): "))) - - ;; Process the read key - ;; - ;; ENTER - Display just the help window - ;; N or n - Next help or describe-key screen - ;; P or p - Previous help or describe-key screen - ;; RETURN - Exit from TPU-help - ;; default - describe the key - ;; - (setq fkey (format "%s" key)) - (cond ((equal tpu-help-enter fkey) - (setq split nil) - (delete-other-windows)) - ((or (equal tpu-help-N fkey) (equal tpu-help-n fkey)) - (cond (split - (condition-case nil - (scroll-other-window 8) - (error nil))) - (t - (forward-page) - (forward-line 1) - (tpu-line-to-top-of-window)))) - ((or (equal tpu-help-P fkey) (equal tpu-help-p fkey)) - (cond (split - (condition-case nil - (scroll-other-window -8) - (error nil))) - (t - (forward-line -1) - (backward-page) - (forward-line 1) - (tpu-line-to-top-of-window)))) - ((not (equal tpu-help-return fkey)) - (setq split t) - (describe-key key) - ;; If the key is undefined, leave the - ;; message in the mini-buffer for 3 seconds - (if (not (key-binding key)) (sit-for 3)))))))) - - -;;; -;;; Auto-insert -;;; -(defun tpu-insert-escape nil - "Insert an escape character, and so becomes the escape-key alias." - (interactive) - (insert "\e")) - -(defun tpu-insert-formfeed nil - "Insert a formfeed character." - (interactive) - (insert "\C-L")) - - -;;; -;;; Define key -;;; -(defvar tpu-saved-control-r nil "Saved value of Control-r.") - -(defun tpu-end-define-macro-key (key) - "End the current macro definition." - (interactive "kPress the key you want to use to do what was just learned: ") - (end-kbd-macro nil) - (global-set-key key last-kbd-macro) - (global-set-key "\C-r" tpu-saved-control-r)) - -(defun tpu-define-macro-key nil - "Bind a set of keystrokes to a single key, or key combination." - (interactive) - (setq tpu-saved-control-r (global-key-binding "\C-r")) - (global-set-key "\C-r" #'tpu-end-define-macro-key) - (start-kbd-macro nil)) - - -;;; -;;; Buffers and Windows -;;; -(defun tpu-kill-buffer nil - "Kill the current buffer. -If `tpu-kill-buffers-silently' is non-nil, -kill modified buffers without asking." - (interactive) - (if tpu-kill-buffers-silently (set-buffer-modified-p nil)) - (kill-buffer (current-buffer))) - -(defun tpu-save-all-buffers-kill-emacs nil - "Save all buffers and exit Emacs." - (interactive) - (let ((delete-old-versions t)) - (save-buffers-kill-emacs t))) - -(defun tpu-write-current-buffers nil - "Save all modified buffers without exiting." - (interactive) - (save-some-buffers t)) - -(defun tpu-next-buffer nil - "Go to next buffer in ring." - (interactive) - (switch-to-buffer (car (reverse (buffer-list))))) - -(defun tpu-next-file-buffer nil - "Go to next buffer in ring that is visiting a file or directory." - (interactive) - (let ((list (tpu-make-file-buffer-list (buffer-list)))) - (setq list (delq (current-buffer) list)) - (if (not list) (tpu-error "No other buffers.")) - (switch-to-buffer (car (reverse list))))) - -(defun tpu-make-file-buffer-list (buffer-list) - "Return names from BUFFER-LIST excluding those beginning with a space or star." - (delq nil (mapcar (lambda (b) - (if (or (= (aref (buffer-name b) 0) ?\s) - (= (aref (buffer-name b) 0) ?*)) nil b)) - buffer-list))) - -(defun tpu-next-window nil - "Move to the next window." - (interactive) - (if (one-window-p) (message "There is only one window on screen.") - (other-window 1))) - -(defun tpu-previous-window nil - "Move to the previous window." - (interactive) - (if (one-window-p) (message "There is only one window on screen.") - (select-window (previous-window)))) - - -;;; -;;; Search -;;; -(defun tpu-toggle-regexp nil - "Switch in and out of regular expression search and replace mode." - (interactive) - (setq tpu-regexp-p (not tpu-regexp-p)) - (tpu-set-search) - (and (called-interactively-p 'interactive) - (message "Regular expression search and substitute %sabled." - (if tpu-regexp-p "en" "dis")))) - -(defun tpu-regexp-prompt (prompt) - "Read a string, adding `RE ' to the prompt if tpu-regexp-p is set." - (let ((re-prompt (concat (if tpu-regexp-p "RE ") prompt))) - (read-from-minibuffer re-prompt nil nil nil 'tpu-regexp-prompt-hist))) - -(defun tpu-search-highlight nil - (if (tpu-check-match) - (move-overlay tpu-search-overlay - (tpu-match-beginning) (tpu-match-end) (current-buffer)) - (unless (equal (overlay-start tpu-search-overlay) - (overlay-end tpu-search-overlay)) - (move-overlay tpu-search-overlay 1 1 (current-buffer))))) - -(defun tpu-search nil - "Search for a string or regular expression. -The search is performed in the current direction." - (interactive) - (tpu-set-search) - (tpu-search-internal "")) - -(defun tpu-search-forward nil - "Search for a string or regular expression. -The search is begins in the forward direction." - (interactive) - (setq tpu-searching-forward t) - (tpu-set-search t) - (tpu-search-internal "")) - -(defun tpu-search-reverse nil - "Search for a string or regular expression. -The search is begins in the reverse direction." - (interactive) - (setq tpu-searching-forward nil) - (tpu-set-search t) - (tpu-search-internal "")) - -(defun tpu-search-again nil - "Search for the same string or regular expression as last time. -The search is performed in the current direction." - (interactive) - (tpu-search-internal tpu-search-last-string)) - -;; tpu-set-search defines the search functions used by the TPU-edt internal -;; search function. It should be called whenever the direction changes, or -;; the regular expression mode is turned on or off. It can also be called -;; to ensure that the next search will be in the current direction. It is -;; called from: - -;; tpu-advance tpu-backup -;; tpu-toggle-regexp tpu-toggle-search-direction (t) -;; tpu-search tpu-lm-replace -;; tpu-search-forward (t) tpu-search-reverse (t) -;; tpu-search-forward-exit (t) tpu-search-backward-exit (t) - -(declare-function tpu-emacs-search "tpu-edt") -(declare-function tpu-emacs-rev-search "tpu-edt") - -(defun tpu-set-search (&optional arg) - "Set the search functions and set the search direction to the current direction. -If an argument is specified, don't set the search direction." - (if (not arg) (setq tpu-searching-forward tpu-advance)) - (cond (tpu-searching-forward - (cond (tpu-regexp-p - (fset 'tpu-emacs-search #'re-search-forward) - (fset 'tpu-emacs-rev-search #'re-search-backward)) - (t - (fset 'tpu-emacs-search #'search-forward) - (fset 'tpu-emacs-rev-search #'search-backward)))) - (t - (cond (tpu-regexp-p - (fset 'tpu-emacs-search #'re-search-backward) - (fset 'tpu-emacs-rev-search #'re-search-forward)) - (t - (fset 'tpu-emacs-search #'search-backward) - (fset 'tpu-emacs-rev-search #'search-forward)))))) - -(defun tpu-search-internal (pat &optional quiet) - "Search for a string or regular expression." - (setq tpu-search-last-string - (if (not (string= "" pat)) pat (tpu-regexp-prompt "Search: "))) - - (tpu-unset-match) - (tpu-adjust-search) - - (let ((case-fold-search - (and case-fold-search (tpu-check-search-case tpu-search-last-string)))) - - (cond ((tpu-emacs-search tpu-search-last-string nil t) - (tpu-set-match) (goto-char (tpu-match-beginning))) - - (t - (tpu-adjust-search t) - (let ((found nil) (pos nil)) - (save-excursion - (let ((tpu-searching-forward (not tpu-searching-forward))) - (tpu-adjust-search) - (setq found (tpu-emacs-rev-search tpu-search-last-string nil t)) - (setq pos (match-beginning 0)))) - - (cond - (found - (cond ((tpu-y-or-n-p - (format "Found in %s direction. Go there? " - (if tpu-searching-forward "reverse" "forward"))) - (goto-char pos) (tpu-set-match) - (tpu-toggle-search-direction)))) - - (t - (if (not quiet) - (message - "%sSearch failed: \"%s\"" - (if tpu-regexp-p "RE " "") tpu-search-last-string))))))))) - -(defalias 'tpu-search-internal-core (symbol-function 'tpu-search-internal)) - -(defun tpu-check-search-case (string) - "Return t if string contains upper case." - ;; if using regexp, eliminate upper case forms (\B \W \S.) - (if tpu-regexp-p - (let ((pat (copy-sequence string)) (case-fold-search nil) (pos 0)) - (while (setq pos (string-search "\\\\" pat)) (aset pat (+ 1 pos) ?.)) - (while (setq pos (string-search "\\B" pat)) (aset pat (+ 1 pos) ?.)) - (while (setq pos (string-search "\\W" pat)) (aset pat (+ 1 pos) ?.)) - (while (setq pos (string-match "\\\\S." pat)) - (aset pat (+ 1 pos) ?.) (aset pat (+ 2 pos) ?.)) - (string-equal pat (downcase pat))) - (string-equal string (downcase string)))) - -(defun tpu-adjust-search (&optional arg) - "For forward searches, move forward a character before searching, -and backward a character after a failed search. Arg means end of search." - (if tpu-searching-forward - (cond (arg (if (not (bobp)) (forward-char -1))) - (t (if (not (eobp)) (forward-char 1)))))) - -(defun tpu-toggle-search-direction nil - "Toggle the TPU-edt search direction. -Used for reversing a search in progress." - (interactive) - (setq tpu-searching-forward (not tpu-searching-forward)) - (tpu-set-search t) - (and (called-interactively-p 'interactive) - (message "Searching %sward." - (if tpu-searching-forward "for" "back")))) - -(defun tpu-search-forward-exit nil - "Set search direction forward and exit minibuffer." - (interactive) - (setq tpu-searching-forward t) - (tpu-set-search t) - (exit-minibuffer)) - -(defun tpu-search-backward-exit nil - "Set search direction backward and exit minibuffer." - (interactive) - (setq tpu-searching-forward nil) - (tpu-set-search t) - (exit-minibuffer)) - - -;;; -;;; Select / Unselect -;;; -(defun tpu-select (&optional quiet) - "Set the mark to define one end of a region." - (interactive "P") - (cond ((tpu-mark) - (tpu-unselect quiet)) - (t - (tpu-set-mark (point)) - (tpu-update-mode-line) - (if (not quiet) (message "Move the text cursor to select text."))))) - -(defun tpu-unselect (&optional quiet) - "Remove the mark to unselect the current region." - (interactive "P") - (deactivate-mark) - (setq mark-ring nil) - (tpu-set-mark nil) - (tpu-update-mode-line) - (if (not quiet) (message "Selection canceled."))) - - -;;; -;;; Delete / Cut -;;; -(defun tpu-toggle-rectangle nil - "Toggle rectangular mode for remove and insert." - (interactive) - (setq tpu-rectangular-p (not tpu-rectangular-p)) - (setq tpu-rectangle-string (if tpu-rectangular-p " Rect" "")) - (tpu-update-mode-line) - (and (called-interactively-p 'interactive) - (message "Rectangular cut and paste %sabled." - (if tpu-rectangular-p "en" "dis")))) - -(defun tpu-arrange-rectangle nil - "Adjust point and mark to upper left and lower right corners of a rectangle." - (let ((mc (current-column)) - (pc (progn (exchange-point-and-mark) (current-column)))) - - (cond ((> (point) (tpu-mark)) ; point on lower line - (cond ((> pc mc) ; point @ lower-right - (exchange-point-and-mark)) ; point -> upper-left - - (t ; point @ lower-left - (move-to-column mc t) ; point -> lower-right - (exchange-point-and-mark) ; point -> upper-right - (move-to-column pc t)))) ; point -> upper-left - - (t ; point on upper line - (cond ((> pc mc) ; point @ upper-right - (move-to-column mc t) ; point -> upper-left - (exchange-point-and-mark) ; point -> lower-left - (move-to-column pc t) ; point -> lower-right - (exchange-point-and-mark))))))) ; point -> upper-left - -(defun tpu-cut-text nil - "Delete the selected region. -The text is saved for the tpu-paste command." - (interactive) - (cond ((tpu-mark) - (cond (tpu-rectangular-p - (tpu-arrange-rectangle) - (picture-clear-rectangle (point) (tpu-mark) (not overwrite-mode)) - (tpu-unselect t)) - (t - (setq tpu-last-deleted-region - (buffer-substring (tpu-mark) (point))) - (delete-region (tpu-mark) (point)) - (tpu-unselect t)))) - ((tpu-check-match) - (let ((beg (tpu-match-beginning)) (end (tpu-match-end))) - (setq tpu-last-deleted-region (buffer-substring beg end)) - (delete-region beg end) - (tpu-unset-match))) - (t - (tpu-error "No selection active.")))) - -(defun tpu-store-text nil - "Copy the selected region to the cut buffer without deleting it. -The text is saved for the tpu-paste command." - (interactive) - (cond ((tpu-mark) - (cond (tpu-rectangular-p - (save-excursion - (tpu-arrange-rectangle) - (setq picture-killed-rectangle - (extract-rectangle (point) (tpu-mark)))) - (tpu-unselect t)) - (t - (setq tpu-last-deleted-region - (buffer-substring (tpu-mark) (point))) - (tpu-unselect t)))) - ((tpu-check-match) - (setq tpu-last-deleted-region - (buffer-substring (tpu-match-beginning) (tpu-match-end))) - (tpu-unset-match)) - (t - (tpu-error "No selection active.")))) - -(defun tpu-cut (arg) - "Copy selected region to the cut buffer. -In the absence of an argument, delete the selected region too." - (interactive "P") - (if arg (tpu-store-text) (tpu-cut-text))) - -(defun tpu-append-region (arg) - "Append selected region to the tpu-cut buffer. -In the absence of an argument, delete the selected region too." - (interactive "P") - (cond ((tpu-mark) - (let ((beg (region-beginning)) (end (region-end))) - (setq tpu-last-deleted-region - (concat tpu-last-deleted-region - (buffer-substring beg end))) - (if (not arg) (delete-region beg end)) - (tpu-unselect t))) - ((tpu-check-match) - (let ((beg (tpu-match-beginning)) (end (tpu-match-end))) - (setq tpu-last-deleted-region - (concat tpu-last-deleted-region - (buffer-substring beg end))) - (if (not arg) (delete-region beg end)) - (tpu-unset-match))) - (t - (tpu-error "No selection active.")))) - -(defun tpu-delete-current-line (num) - "Delete one or specified number of lines after point. -This includes the newline character at the end of each line. -They are saved for the TPU-edt undelete-lines command." - (interactive "p") - (let ((beg (point))) - (forward-line num) - (if (not (eq (preceding-char) ?\n)) - (insert "\n")) - (setq tpu-last-deleted-lines - (buffer-substring beg (point))) - (delete-region beg (point)))) - -(defun tpu-delete-to-eol (num) - "Delete text up to end of line. -With argument, delete up to the Nth line-end past point. -They are saved for the TPU-edt undelete-lines command." - (interactive "p") - (let ((beg (point))) - (forward-char 1) - (end-of-line num) - (setq tpu-last-deleted-lines - (buffer-substring beg (point))) - (delete-region beg (point)))) - -(defun tpu-delete-to-bol (num) - "Delete text back to beginning of line. -With argument, delete up to the Nth line-end past point. -They are saved for the TPU-edt undelete-lines command." - (interactive "p") - (let ((beg (point))) - (tpu-next-beginning-of-line num) - (setq tpu-last-deleted-lines - (buffer-substring (point) beg)) - (delete-region (point) beg))) - -(defun tpu-delete-current-word (num) - "Delete one or specified number of words after point. -They are saved for the TPU-edt undelete-words command." - (interactive "p") - (let ((beg (point))) - (tpu-forward-to-word num) - (setq tpu-last-deleted-words - (buffer-substring beg (point))) - (delete-region beg (point)))) - -(defun tpu-delete-previous-word (num) - "Delete one or specified number of words before point. -They are saved for the TPU-edt undelete-words command." - (interactive "p") - (let ((beg (point))) - (tpu-backward-to-word num) - (setq tpu-last-deleted-words - (buffer-substring (point) beg)) - (delete-region beg (point)))) - -(defun tpu-delete-current-char (num) - "Delete one or specified number of characters after point. -The last character deleted is saved for the TPU-edt undelete-char command." - (interactive "p") - (while (and (> num 0) (not (eobp))) - (setq tpu-last-deleted-char (char-after (point))) - (cond (overwrite-mode - (picture-clear-column 1) - (forward-char 1)) - (t - (delete-char 1))) - (setq num (1- num)))) - - -;;; -;;; Undelete / Paste -;;; -(defun tpu-paste (num) - "Insert the last region or rectangle of killed text. -With argument reinserts the text that many times." - (interactive "p") - (while (> num 0) - (cond (tpu-rectangular-p - (let ((beg (point))) - (save-excursion - (picture-yank-rectangle (not overwrite-mode)) - (message "")) - (goto-char beg))) - (t - (insert tpu-last-deleted-region))) - (setq num (1- num)))) - -(defun tpu-undelete-lines (num) - "Insert lines deleted by last TPU-edt line-deletion command. -With argument reinserts lines that many times." - (interactive "p") - (let ((beg (point))) - (while (> num 0) - (insert tpu-last-deleted-lines) - (setq num (1- num))) - (goto-char beg))) - -(defun tpu-undelete-words (num) - "Insert words deleted by last TPU-edt word-deletion command. -With argument reinserts words that many times." - (interactive "p") - (let ((beg (point))) - (while (> num 0) - (insert tpu-last-deleted-words) - (setq num (1- num))) - (goto-char beg))) - -(defun tpu-undelete-char (num) - "Insert character deleted by last TPU-edt character-deletion command. -With argument reinserts the character that many times." - (interactive "p") - (while (> num 0) - (if overwrite-mode (prog1 (forward-char -1) (delete-char 1))) - (insert tpu-last-deleted-char) - (forward-char -1) - (setq num (1- num)))) - - -;;; -;;; Replace and Substitute -;;; -(defun tpu-replace nil - "Replace the selected region with the contents of the cut buffer." - (interactive) - (cond ((tpu-mark) - (let ((beg (region-beginning)) (end (region-end))) - (setq tpu-last-replaced-text (buffer-substring beg end)) - (delete-region beg end) - (insert tpu-last-deleted-region) - (tpu-unselect t))) - ((tpu-check-match) - (let ((beg (tpu-match-beginning)) (end (tpu-match-end))) - (setq tpu-last-replaced-text (buffer-substring beg end)) - (replace-match tpu-last-deleted-region - (not case-replace) (not tpu-regexp-p)) - (tpu-unset-match))) - (t - (tpu-error "No selection active.")))) - -(defun tpu-substitute (num) - "Replace the selected region with the contents of the cut buffer, -and repeat most recent search. A numeric argument serves as a repeat count. -A negative argument means replace all occurrences of the search string." - (interactive "p") - (cond ((or (tpu-mark) (tpu-check-match)) - (while (and (not (= num 0)) (or (tpu-mark) (tpu-check-match))) - (let ((beg (point))) - (tpu-replace) - (if tpu-searching-forward (forward-char -1) (goto-char beg)) - (if (= num 1) (tpu-search-internal tpu-search-last-string) - (tpu-search-internal-core tpu-search-last-string))) - (setq num (1- num)))) - (t - (tpu-error "No selection active.")))) - -(defun tpu-lm-replace (from to) - "Interactively search for OLD-string and substitute NEW-string." - (interactive (list (tpu-regexp-prompt "Old String: ") - (tpu-regexp-prompt "New String: "))) - - (let ((doit t) (strings 0)) - - ;; Can't replace null strings - (if (string= "" from) (tpu-error "No string to replace.")) - - ;; Find the first occurrence - (tpu-set-search) - (tpu-search-internal from t) - - ;; Loop on replace question - yes, no, all, last, or quit. - (while doit - (if (not (tpu-check-match)) (setq doit nil) - (progn - (move-overlay tpu-replace-overlay - (tpu-match-beginning) (tpu-match-end) (current-buffer)) - (message "Replace? Type Yes, No, All, Last, or Quit: ") - (let ((ans (read-char))) - - (cond ((or (= ans ?y) (= ans ?Y) (= ans ?\r) (= ans ?\ )) - (let ((beg (point))) - (replace-match to (not case-replace) (not tpu-regexp-p)) - (setq strings (1+ strings)) - (if tpu-searching-forward (forward-char -1) (goto-char beg))) - (tpu-search-internal from t)) - - ((or (= ans ?n) (= ans ?N) (= ans ?\C-?)) - (tpu-search-internal from t)) - - ((or (= ans ?a) (= ans ?A)) - (save-excursion - (let ((beg (point))) - (replace-match to (not case-replace) (not tpu-regexp-p)) - (setq strings (1+ strings)) - (if tpu-searching-forward (forward-char -1) (goto-char beg))) - (tpu-search-internal-core from t) - (while (tpu-check-match) - (let ((beg (point))) - (replace-match to (not case-replace) (not tpu-regexp-p)) - (setq strings (1+ strings)) - (if tpu-searching-forward (forward-char -1) (goto-char beg))) - (tpu-search-internal-core from t))) - (setq doit nil)) - - ((or (= ans ?l) (= ans ?L)) - (let ((beg (point))) - (replace-match to (not case-replace) (not tpu-regexp-p)) - (setq strings (1+ strings)) - (if tpu-searching-forward (forward-char -1) (goto-char beg))) - (setq doit nil)) - - ((or (= ans ?q) (= ans ?Q)) - (tpu-unset-match) - (setq doit nil))))))) - - (move-overlay tpu-replace-overlay 1 1 (current-buffer)) - (message "Replaced %s occurrence%s." strings (if (not (= 1 strings)) "s" "")))) - -(defun tpu-emacs-replace (&optional dont-ask) - "A TPU-edt interface to the Emacs replace functions. -If TPU-edt is currently in regular expression mode, the Emacs regular -expression replace functions are used. If an argument is supplied, -replacements are performed without asking. Only works in forward direction." - (interactive "P") - (cond (dont-ask - (setq current-prefix-arg nil) - (call-interactively - (if tpu-regexp-p 'replace-regexp 'replace-string))) - (t - (call-interactively - (if tpu-regexp-p 'query-replace-regexp 'query-replace))))) - -(defun tpu-add-at-bol (text) - "Add text to the beginning of each line in a region, -or each line in the entire buffer if no region is selected." - (interactive - (list (tpu-string-prompt "String to add: " 'tpu-add-at-bol-hist))) - (if (string= "" text) (tpu-error "No string specified.")) - (cond ((tpu-mark) - (save-excursion - (if (> (point) (tpu-mark)) (exchange-point-and-mark)) - (while (and (< (point) (tpu-mark)) (re-search-forward "^" (tpu-mark) t)) - (if (< (point) (tpu-mark)) (replace-match text)))) - (tpu-unselect t)) - (t - (save-excursion - (goto-char (point-min)) - (while (and (re-search-forward "^" nil t) (not (eobp))) - (replace-match text)))))) - -(defun tpu-add-at-eol (text) - "Add text to the end of each line in a region, -or each line of the entire buffer if no region is selected." - (interactive - (list (tpu-string-prompt "String to add: " 'tpu-add-at-eol-hist))) - (if (string= "" text) (tpu-error "No string specified.")) - (cond ((tpu-mark) - (save-excursion - (if (> (point) (tpu-mark)) (exchange-point-and-mark)) - (while (< (point) (tpu-mark)) - (end-of-line) - (if (<= (point) (tpu-mark)) (insert text)) - (forward-line))) - (tpu-unselect t)) - (t - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) (insert text) (forward-line)))))) - -(defun tpu-trim-line-ends nil - "Remove trailing whitespace from every line in the buffer." - (interactive) - (save-match-data - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "[ \t][ \t]*$" nil t) - (delete-region (match-beginning 0) (match-end 0)))))) - - -;;; -;;; Movement by character -;;; -(defun tpu-char (num) - "Move to the next character in the current direction. -A repeat count means move that many characters." - (interactive "p") - (if tpu-advance (tpu-forward-char num) (tpu-backward-char num))) - -(defun tpu-forward-char (num) - "Move right ARG characters (left if ARG is negative)." - (interactive "p") - (forward-char num)) - -(defun tpu-backward-char (num) - "Move left ARG characters (right if ARG is negative)." - (interactive "p") - (backward-char num)) - - -;;; -;;; Movement by word -;;; -(defvar tpu-word-separator-list '() - "List of additional word separators.") -(defvar tpu-skip-chars "^ \t" - "Characters to skip when moving by word. -Additional word separators are added to this string.") - -(defun tpu-word (num) - "Move to the beginning of the next word in the current direction. -A repeat count means move that many words." - (interactive "p") - (if tpu-advance (tpu-forward-to-word num) (tpu-backward-to-word num))) - -(defun tpu-forward-to-word (num) - "Move forward until encountering the beginning of a word. -With argument, do this that many times." - (interactive "p") - (while (and (> num 0) (not (eobp))) - (let* ((beg (point)) - (end (prog2 (end-of-line) (point) (goto-char beg)))) - (cond ((eolp) - (forward-char 1)) - ((memq (char-after (point)) tpu-word-separator-list) - (forward-char 1) - (skip-chars-forward " \t" end)) - (t - (skip-chars-forward tpu-skip-chars end) - (skip-chars-forward " \t" end)))) - (setq num (1- num)))) - -(defun tpu-backward-to-word (num) - "Move backward until encountering the beginning of a word. -With argument, do this that many times." - (interactive "p") - (while (and (> num 0) (not (bobp))) - (let* ((beg (point)) - (end (prog2 (beginning-of-line) (point) (goto-char beg)))) - (cond ((bolp) - ( forward-char -1)) - ((memq (char-after (1- (point))) tpu-word-separator-list) - (forward-char -1)) - (t - (skip-chars-backward " \t" end) - (skip-chars-backward tpu-skip-chars end) - (if (and (not (bolp)) (= ? (char-syntax (char-after (point))))) - (forward-char -1))))) - (setq num (1- num)))) - -(defun tpu-add-word-separators (separators) - "Add new word separators for TPU-edt word commands." - (interactive "sSeparators: ") - (let* ((n 0) (length (length separators))) - (while (< n length) - (let ((char (aref separators n)) - (ss (substring separators n (1+ n)))) - (cond ((not (memq char tpu-word-separator-list)) - (setq tpu-word-separator-list - (append ss tpu-word-separator-list)) - (cond ((= char ?-) - (setq tpu-skip-chars (concat tpu-skip-chars "\\-"))) - ((= char ?\\) - (setq tpu-skip-chars (concat tpu-skip-chars "\\\\"))) - ((= char ?^) - (setq tpu-skip-chars (concat tpu-skip-chars "\\^"))) - (t - (setq tpu-skip-chars (concat tpu-skip-chars ss)))))) - (setq n (1+ n)))))) - -(defun tpu-reset-word-separators nil - "Reset word separators to default value." - (interactive) - (setq tpu-word-separator-list nil) - (setq tpu-skip-chars "^ \t")) - -(defun tpu-set-word-separators (separators) - "Set new word separators for TPU-edt word commands." - (interactive "sSeparators: ") - (tpu-reset-word-separators) - (tpu-add-word-separators separators)) - - -;;; -;;; Movement by line -;;; -(defun tpu-next-line (num) - "Move to next line. -Prefix argument serves as a repeat count." - (interactive "p") - (line-move num) - (setq this-command 'next-line)) - -(defun tpu-previous-line (num) - "Move to previous line. -Prefix argument serves as a repeat count." - (interactive "p") - (line-move (- num)) - (setq this-command 'previous-line)) - -(defun tpu-next-beginning-of-line (num) - "Move to beginning of line; if at beginning, move to beginning of next line. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (backward-char 1) - (forward-visible-line (- 1 num))) - -(defun tpu-end-of-line (num) - "Move to the next end of line in the current direction. -A repeat count means move that many lines." - (interactive "p") - (if tpu-advance (tpu-next-end-of-line num) (tpu-previous-end-of-line num))) - -(defun tpu-next-end-of-line (num) - "Move to end of line; if at end, move to end of next line. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (forward-char 1) - (end-of-line num)) - -(defun tpu-previous-end-of-line (num) - "Move EOL upward. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (end-of-line (- 1 num))) - -(defun tpu-current-end-of-line nil - "Move point to end of current line." - (interactive) - (let ((beg (point))) - (end-of-line) - (if (= beg (point)) (message "You are already at the end of a line.")))) - -(defun tpu-line (num) - "Move to the beginning of the next line in the current direction. -A repeat count means move that many lines." - (interactive "p") - (if tpu-advance (tpu-forward-line num) (tpu-backward-line num))) - -(defun tpu-forward-line (num) - "Move to beginning of next line. -Prefix argument serves as a repeat count." - (interactive "p") - (forward-line num)) - -(defun tpu-backward-line (num) - "Move to beginning of previous line. -Prefix argument serves as repeat count." - (interactive "p") - (or (bolp) (>= 0 num) (setq num (- num 1))) - (forward-line (- num))) - - -;;; -;;; Movement by paragraph -;;; -(defun tpu-paragraph (num) - "Move to the next paragraph in the current direction. -A repeat count means move that many paragraphs." - (interactive "p") - (if tpu-advance - (tpu-next-paragraph num) (tpu-previous-paragraph num))) - -(defun tpu-next-paragraph (num) - "Move to beginning of the next paragraph. -Accepts a prefix argument for the number of paragraphs." - (interactive "p") - (beginning-of-line) - (while (and (not (eobp)) (> num 0)) - (if (re-search-forward "^[ \t]*$" nil t) - (if (re-search-forward "[^ \t\n]" nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max)))) - (setq num (1- num))) - (beginning-of-line)) - - -(defun tpu-previous-paragraph (num) - "Move to beginning of previous paragraph. -Accepts a prefix argument for the number of paragraphs." - (interactive "p") - (end-of-line) - (while (and (not (bobp)) (> num 0)) - (if (not (and (re-search-backward "^[ \t]*$" nil t) - (re-search-backward "[^ \t\n]" nil t) - (re-search-backward "^[ \t]*$" nil t) - (progn (re-search-forward "[^ \t\n]" nil t) - (goto-char (match-beginning 0))))) - (goto-char (point-min))) - (setq num (1- num))) - (beginning-of-line)) - - -;;; -;;; Movement by page -;;; -(defun tpu-page (num) - "Move to the next page in the current direction. -A repeat count means move that many pages." - (interactive "p") - (if tpu-advance (forward-page num) (backward-page num)) - (if (eobp) (recenter -1))) - - -;;; -;;; Scrolling and movement within the buffer -;;; -(defun tpu-scroll-window (num) - "Scroll the display to the next section in the current direction. -A repeat count means scroll that many sections." - (interactive "p") - (if tpu-advance (tpu-scroll-window-up num) (tpu-scroll-window-down num))) - -(defun tpu-scroll-window-down (num) - "Scroll the display down to the next section. -A repeat count means scroll that many sections." - (interactive "p") - (let* ((beg (tpu-current-line)) - (height (1- (window-height))) - (lines (* num (/ (* height tpu-percent-scroll) 100)))) - (line-move (- lines)) - (if (> lines beg) (recenter 0)))) - -(defun tpu-scroll-window-up (num) - "Scroll the display up to the next section. -A repeat count means scroll that many sections." - (interactive "p") - (let* ((beg (tpu-current-line)) - (height (1- (window-height))) - (lines (* num (/ (* height tpu-percent-scroll) 100)))) - (line-move lines) - (if (>= (+ lines beg) height) (recenter -1)))) - -(defun tpu-pan-right (num) - "Pan right tpu-pan-columns (16 by default). -Accepts a prefix argument for the number of tpu-pan-columns to scroll." - (interactive "p") - (scroll-left (* tpu-pan-columns num))) - -(defun tpu-pan-left (num) - "Pan left tpu-pan-columns (16 by default). -Accepts a prefix argument for the number of tpu-pan-columns to scroll." - (interactive "p") - (scroll-right (* tpu-pan-columns num))) - -(defun tpu-move-to-beginning nil - "Move cursor to the beginning of buffer, but don't set the mark." - (interactive) - (goto-char (point-min))) - -(defun tpu-move-to-end nil - "Move cursor to the end of buffer, but don't set the mark." - (interactive) - (goto-char (point-max)) - (recenter -1)) - -(defun tpu-goto-percent (perc) - "Move point to ARG percentage of the buffer." - (interactive "NGoto-percentage: ") - (if (or (> perc 100) (< perc 0)) - (tpu-error "Percentage %d out of range 0 < percent < 100." perc) - (goto-char (/ (* (point-max) perc) 100)))) - -(defun tpu-beginning-of-window nil - "Move cursor to top of window." - (interactive) - (move-to-window-line 0)) - -(defun tpu-end-of-window nil - "Move cursor to bottom of window." - (interactive) - (move-to-window-line -1)) - -(defun tpu-line-to-bottom-of-window nil - "Move the current line to the bottom of the window." - (interactive) - (recenter -1)) - -(defun tpu-line-to-top-of-window nil - "Move the current line to the top of the window." - (interactive) - (recenter 0)) - - -;;; -;;; Direction -;;; -(defun tpu-advance-direction nil - "Set TPU Advance mode so keypad commands move forward." - (interactive) - (setq tpu-direction-string " Advance") - (setq tpu-advance t) - (setq tpu-reverse nil) - (tpu-set-search) - (tpu-update-mode-line)) - -(defun tpu-backup-direction nil - "Set TPU Backup mode so keypad commands move backward." - (interactive) - (setq tpu-direction-string " Reverse") - (setq tpu-advance nil) - (setq tpu-reverse t) - (tpu-set-search) - (tpu-update-mode-line)) - -(defun tpu-toggle-direction nil - "Change the current TPU direction." - (interactive) - (if tpu-advance (tpu-backup-direction) (tpu-advance-direction))) - - -;;; -;;; Minibuffer map additions to make KP_enter = RET -;;; -;; Standard Emacs settings under xterm in function-key-map map -;; "\eOM" to [kp-enter] and [kp-enter] to RET, but since the output of the map -;; is not fed back into the map, the key stays as kp-enter :-(. -(define-key minibuffer-local-map [kp-enter] #'exit-minibuffer) -;; These are not necessary because they are inherited. -;; (define-key minibuffer-local-ns-map [kp-enter] 'exit-minibuffer) -;; (define-key minibuffer-local-completion-map [kp-enter] 'exit-minibuffer) -(define-key minibuffer-local-must-match-map [kp-enter] #'minibuffer-complete-and-exit) - - -;;; -;;; Minibuffer map additions to set search direction -;;; -(define-key minibuffer-local-map [kp-4] #'tpu-search-forward-exit) ;KP4 -(define-key minibuffer-local-map [kp-5] #'tpu-search-backward-exit) ;KP5 - - -;;; -;;; Functions to set, reset, and toggle the control key bindings -;;; - -(defvar tpu-control-keys-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-\\" #'quoted-insert) ; ^\ - (define-key map "\C-a" #'tpu-toggle-overwrite-mode) ; ^A - (define-key map "\C-b" #'repeat-complex-command) ; ^B - (define-key map "\C-e" #'tpu-current-end-of-line) ; ^E - (define-key map "\C-h" #'tpu-next-beginning-of-line) ; ^H (BS) - (define-key map "\C-j" #'tpu-delete-previous-word) ; ^J (LF) - (define-key map "\C-k" #'tpu-define-macro-key) ; ^K - (define-key map "\C-l" #'tpu-insert-formfeed) ; ^L (FF) - (define-key map "\C-r" #'recenter) ; ^R - (define-key map "\C-u" #'tpu-delete-to-bol) ; ^U - (define-key map "\C-v" #'tpu-quoted-insert) ; ^V - (define-key map "\C-w" #'redraw-display) ; ^W - (define-key map "\C-z" #'tpu-exit) ; ^Z - map)) - -(defun tpu-set-control-keys () - "Set control keys to TPU style functions." - (tpu-reset-control-keys 'tpu)) - -(defun tpu-reset-control-keys (tpu-style) - "Set control keys to TPU or Emacs style functions." - (let ((parent (keymap-parent tpu-global-map))) - (if tpu-style - (if (eq parent tpu-control-keys-map) - nil ;All done already. - ;; Insert tpu-control-keys-map in the global map. - (set-keymap-parent tpu-control-keys-map parent) - (set-keymap-parent tpu-global-map tpu-control-keys-map)) - (if (not (eq parent tpu-control-keys-map)) - nil ;All done already. - ;; Remove tpu-control-keys-map from the global map. - (set-keymap-parent tpu-global-map (keymap-parent parent)) - (set-keymap-parent tpu-control-keys-map nil))) - (setq tpu-control-keys tpu-style))) - -(defun tpu-toggle-control-keys nil - "Toggle control key bindings between TPU-edt and Emacs." - (interactive) - (tpu-reset-control-keys (not tpu-control-keys)) - (and (called-interactively-p 'interactive) - (message "Control keys function with %s bindings." - (if tpu-control-keys "TPU-edt" "Emacs")))) - - -;;; -;;; Emacs version 19 minibuffer history support -;;; -(defun tpu-next-history-element (n) - "Insert the next element of the minibuffer history into the minibuffer." - (interactive "p") - (next-history-element n) - (goto-char (point-max))) - -(defun tpu-previous-history-element (n) - "Insert the previous element of the minibuffer history into the minibuffer." - (interactive "p") - (previous-history-element n) - (goto-char (point-max))) - -(defun tpu-arrow-history nil - "Modify minibuffer maps to use arrows for history recall." - (interactive) - (dolist (cur (where-is-internal #'tpu-previous-line)) - (define-key read-expression-map cur #'tpu-previous-history-element) - (define-key minibuffer-local-map cur #'tpu-previous-history-element) - ;; These are inherited anyway. --Stef - ;; (define-key minibuffer-local-ns-map cur 'tpu-previous-history-element) - ;; (define-key minibuffer-local-completion-map cur 'tpu-previous-history-element) - ;; (define-key minibuffer-local-must-match-map cur 'tpu-previous-history-element) - ) - - (dolist (cur (where-is-internal #'tpu-next-line)) - (define-key read-expression-map cur #'tpu-next-history-element) - (define-key minibuffer-local-map cur #'tpu-next-history-element) - ;; These are inherited anyway. --Stef - ;; (define-key minibuffer-local-ns-map cur 'tpu-next-history-element) - ;; (define-key minibuffer-local-completion-map cur 'tpu-next-history-element) - ;; (define-key minibuffer-local-must-match-map cur 'tpu-next-history-element) - )) - - -;;; -;;; Emacs version 19 X-windows key definition support -;;; -(defun tpu-load-xkeys (file) - "Load the TPU-edt X-windows key definitions FILE. -If FILE is nil, try to load a default file. The default file name is -`~/.tpu-keys'." - (interactive "fX key definition file: ") - (cond (file - (setq file (expand-file-name file))) - (tpu-xkeys-file - (setq file (expand-file-name tpu-xkeys-file))) - (t - (setq file (convert-standard-filename - (expand-file-name "~/.tpu-keys"))) - (and (not (file-exists-p file)) - (file-exists-p - (convert-standard-filename - (expand-file-name "~/.tpu-gnu-keys"))) - (tpu-copy-keyfile - (convert-standard-filename - (expand-file-name "~/.tpu-gnu-keys")) file)))) - (cond ((file-readable-p file) - (load-file file)) - (t - ;; This used to force the user to build `file'. With the - ;; new code, such a file may not be necessary. In case it - ;; is, issue a message giving a hint as to how to build it. - (message "%s not found: use M-x tpu-mapper to create it" - (abbreviate-file-name file))))) - -(defun tpu-copy-keyfile (oldname newname) - "Copy the TPU-edt X key definitions file to the new default name." - (interactive "fOld name: \nFNew name: ") - (if (not (get-buffer "*TPU-Notice*")) (generate-new-buffer "*TPU-Notice*")) - (set-buffer "*TPU-Notice*") - (erase-buffer) - (insert " - NOTICE -- - - The default name of the TPU-edt key definition file has changed - from `~/.tpu-gnu-keys' to `~/.tpu-keys'. With your permission, - your key definitions will be copied to the new file. If you'll - never use older versions of Emacs, you can remove the old file. - If the copy fails, you'll be asked if you want to create a new - key definitions file. Do you want to copy your key definition - file now? - ") - (save-window-excursion - (switch-to-buffer-other-window "*TPU-Notice*") - (shrink-window-if-larger-than-buffer) - (goto-char (point-min)) - (beep) - (and (tpu-y-or-n-p "Copy key definitions to the new file now? ") - (with-demoted-errors "Sorry, couldn't copy - %s." - (copy-file oldname newname))) - (kill-buffer "*TPU-Notice*"))) - -(defvar tpu-edt-old-global-values nil) - -;;; -;;; Start and Stop TPU-edt -;;; -;;;###autoload -(defun tpu-edt-on () - "Turn on TPU/edt emulation." - (interactive) - ;; To clean things up (and avoid cycles in the global map). - (tpu-edt-off) - ;; First, activate tpu-global-map, while protecting the original keymap. - (set-keymap-parent tpu-global-map global-map) - (setq global-map tpu-global-map) - (use-global-map global-map) - ;; Then do the normal TPU setup. - (transient-mark-mode t) - (add-hook 'post-command-hook #'tpu-search-highlight) - (tpu-set-mode-line t) - (tpu-advance-direction) - ;; set page delimiter, display line truncation, and scrolling like TPU - (dolist (varval '((page-delimiter . "\f") - (truncate-lines . t) - (scroll-step . 1))) - (push (cons (car varval) (default-value (car varval))) - tpu-edt-old-global-values) - (set-default (car varval) (cdr varval))) - (tpu-set-control-keys) - (and window-system (tpu-load-xkeys nil)) - (tpu-arrow-history) - ;; Then protect tpu-global-map from user modifications. - (let ((map (make-sparse-keymap))) - (set-keymap-parent map global-map) - (setq global-map map) - (use-global-map map)) - (setq tpu-edt-mode t)) - -(defun tpu-edt-off () - "Turn off TPU/edt emulation. Note that the keypad is left on." - (interactive) - (tpu-reset-control-keys nil) - (remove-hook 'post-command-hook #'tpu-search-highlight) - (tpu-set-mode-line nil) - (while tpu-edt-old-global-values - (let ((varval (pop tpu-edt-old-global-values))) - (set-default (car varval) (cdr varval)))) - ;; Remove tpu-global-map from the global map. - (let ((map global-map)) - (while map - (let ((parent (keymap-parent map))) - (if (eq tpu-global-map parent) - (set-keymap-parent map (keymap-parent parent)) - (setq map parent))))) - ;; Only has an effect if the advice in tpu-extras has been activated. - (condition-case nil - (with-no-warnings (ad-disable-regexp "\\`tpu-")) - (error nil)) - (setq tpu-edt-mode nil)) - - -;;;### (autoloads nil "tpu-extras" "tpu-extras.el" "cbbb448cff48fab904ac19805aa6f36a") -;;; Generated autoloads from tpu-extras.el - -(autoload 'tpu-cursor-free-mode "tpu-extras" "\ -Minor mode to allow the cursor to move freely about the screen. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. - -\(fn &optional ARG)" t nil) - -(autoload 'tpu-set-scroll-margins "tpu-extras" "\ -Set scroll margins. - -\(fn TOP BOTTOM)" t nil) - -(autoload 'tpu-set-cursor-free "tpu-extras" "\ -Allow the cursor to move freely about the screen. - -\(fn)" t nil) - -(autoload 'tpu-set-cursor-bound "tpu-extras" "\ -Constrain the cursor to the flow of the text. - -\(fn)" t nil) - -;;;*** - -(provide 'tpu-edt) - -;;; tpu-edt.el ends here diff --git a/lisp/obsolete/tpu-extras.el b/lisp/obsolete/tpu-extras.el deleted file mode 100644 index 801a20d3550..00000000000 --- a/lisp/obsolete/tpu-extras.el +++ /dev/null @@ -1,429 +0,0 @@ -;;; tpu-extras.el --- scroll margins and free cursor mode for TPU-edt -*- lexical-binding: t; -*- - -;; Copyright (C) 1993-1995, 2000-2024 Free Software Foundation, Inc. - -;; Author: Rob Riepel -;; Keywords: emulations -;; Package: tpu-edt -;; Obsolete-since: 24.5 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; Use the functions defined here to customize TPU-edt to your tastes by -;; setting scroll margins and/or turning on free cursor mode. Here's an -;; example for your init file. - -;; (tpu-set-cursor-free) ; Set cursor free. -;; (tpu-set-scroll-margins "10%" "15%") ; Set scroll margins. - -;; Scroll margins and cursor binding can be changed from within emacs using -;; the following commands: - -;; tpu-set-scroll-margins or set scroll margins -;; tpu-set-cursor-bound or set cursor bound -;; tpu-set-cursor-free or set cursor free - -;; Additionally, Gold-F toggles between bound and free cursor modes. - -;; Note that switching out of free cursor mode or exiting TPU-edt while in -;; free cursor mode strips trailing whitespace from every line in the file. - - -;;; Details: - -;; The functions contained in this file implement scroll margins and free -;; cursor mode. The following keys and commands are affected. - -;; key/command function scroll cursor - -;; Up-Arrow previous line x x -;; Down-Arrow next line x x -;; Right-Arrow next character x -;; Left-Arrow previous character x -;; KP0 next or previous line x -;; KP7 next or previous page x -;; KP8 next or previous screen x -;; KP2 next or previous end-of-line x x -;; Control-e current end-of-line x -;; Control-h previous beginning-of-line x -;; Next Scr next screen x -;; Prev Scr previous screen x -;; Search find a string x -;; Replace find and replace a string x -;; Newline insert a newline x -;; Paragraph next or previous paragraph x -;; Auto-Fill break lines on spaces x - -;; These functions are not part of the base TPU-edt for the following -;; reasons: - -;; Free cursor mode is implemented with the emacs picture-mode functions. -;; These functions support moving the cursor all over the screen, however, -;; when the cursor is moved past the end of a line, spaces or tabs are -;; appended to the line - even if no text is entered in that area. In -;; order for a free cursor mode to work exactly like TPU/edt, this trailing -;; whitespace needs to be dealt with in every function that might encounter -;; it. Such global changes are impractical, however, free cursor mode is -;; too valuable to abandon completely, so it has been implemented in those -;; functions where it serves best. - -;; The implementation of scroll margins adds overhead to previously -;; simple and often used commands. These commands are now responsible -;; for their normal operation and part of the display function. There -;; is a possibility that this display overhead could adversely affect the -;; performance of TPU-edt on slower computers. In order to support the -;; widest range of computers, scroll margin support is optional. - -;; It's actually not known whether the overhead associated with scroll -;; margin support is significant. If you find that it is, please send -;; a note describing the extent of the performance degradation. Be sure -;; to include a description of the platform where you're running TPU-edt. -;; Send your note to the address provided by Gold-V. - -;; Even with these differences and limitations, these functions implement -;; important aspects of the real TPU/edt. Those who miss free cursor mode -;; and/or scroll margins will appreciate these implementations. - -;;; Code: - - -;;; Gotta have tpu-edt - -(require 'tpu-edt) - - -;;; Customization variables - -(defcustom tpu-top-scroll-margin 0 - "Scroll margin at the top of the screen. -Interpreted as a percent of the current window size." - :type 'integer - :group 'tpu) -(defcustom tpu-bottom-scroll-margin 0 - "Scroll margin at the bottom of the screen. -Interpreted as a percent of the current window size." - :type 'integer - :group 'tpu) - -(defcustom tpu-backward-char-like-tpu t - "If non-nil, in free cursor mode backward-char (left-arrow) works -just like TPU/edt. Otherwise, backward-char will move to the end of -the previous line when starting from a line beginning." - :type 'boolean - :group 'tpu) - - -;;; Global variables - -;;;###autoload -(define-minor-mode tpu-cursor-free-mode - "Minor mode to allow the cursor to move freely about the screen." - :init-value nil - (if (not tpu-cursor-free-mode) - (tpu-trim-line-ends)) - (if (not tpu-cursor-free-mode) - (message "The cursor is now bound to the flow of your text.") - (message "The cursor will now move freely about the screen."))) - - -;;; Hooks -- Set cursor free in picture mode. -;;; Clean up when writing a file from cursor free mode. - -(add-hook 'picture-mode-hook #'tpu-set-cursor-free) - -(defun tpu-trim-line-ends-if-needed () - "Eliminate whitespace at ends of lines, if the cursor is free." - (if (and (buffer-modified-p) tpu-cursor-free-mode) (tpu-trim-line-ends))) -(add-hook 'before-save-hook #'tpu-trim-line-ends-if-needed) - - -;;; Utility routines for implementing scroll margins - -(defun tpu-top-check (beg lines) - "Enforce scroll margin at the top of screen." - (let ((margin (/ (* (window-height) tpu-top-scroll-margin) 100))) - (cond ((< beg margin) (recenter beg)) - ((< (- beg lines) margin) (recenter margin))))) - -(defun tpu-bottom-check (beg lines) - "Enforce scroll margin at the bottom of screen." - (let* ((height (window-height)) - (margin (+ 1 (/ (* height tpu-bottom-scroll-margin) 100))) - ;; subtract 1 from height because it includes mode line - (difference (- height margin 1))) - (cond ((> beg difference) (recenter beg)) - ((> (+ beg lines) difference) (recenter (- margin)))))) - - -;;; Movement by character - -(defun tpu-forward-char (num) - "Move right ARG characters (left if ARG is negative)." - (interactive "p") - (if tpu-cursor-free-mode (picture-forward-column num) (forward-char num))) - -(defun tpu-backward-char (num) - "Move left ARG characters (right if ARG is negative)." - (interactive "p") - (cond ((not tpu-cursor-free-mode) - (backward-char num)) - (tpu-backward-char-like-tpu - (picture-backward-column num)) - ((bolp) - (backward-char 1) - (picture-end-of-line) - (picture-backward-column (1- num))) - (t - (picture-backward-column num)))) - - -;;; Movement by line - -(defun tpu-next-line (num) - "Move to next line. -Prefix argument serves as a repeat count." - (interactive "p") - (let ((beg (tpu-current-line))) - (if tpu-cursor-free-mode (or (eobp) (picture-move-down num)) - (line-move num)) - (tpu-bottom-check beg num) - (setq this-command 'next-line))) - -(defun tpu-previous-line (num) - "Move to previous line. -Prefix argument serves as a repeat count." - (interactive "p") - (let ((beg (tpu-current-line))) - (if tpu-cursor-free-mode (picture-move-up num) (line-move (- num))) - (tpu-top-check beg num) - (setq this-command 'previous-line))) - -(defun tpu-next-beginning-of-line (num) - "Move to beginning of line; if at beginning, move to beginning of next line. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (let ((beg (tpu-current-line))) - (backward-char 1) - (forward-visible-line (- 1 num)) - (tpu-top-check beg num))) - -(defun tpu-next-end-of-line (num) - "Move to end of line; if at end, move to end of next line. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (let ((beg (tpu-current-line))) - (cond (tpu-cursor-free-mode - (let ((beg (point))) - (if (< 1 num) (forward-line num)) - (picture-end-of-line) - (if (<= (point) beg) (progn (forward-line) (picture-end-of-line))))) - (t - (forward-char) - (end-of-line num))) - (tpu-bottom-check beg num))) - -(defun tpu-previous-end-of-line (num) - "Move EOL upward. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (let ((beg (tpu-current-line))) - (cond (tpu-cursor-free-mode - (picture-end-of-line (- 1 num))) - (t - (end-of-line (- 1 num)))) - (tpu-top-check beg num))) - -(defun tpu-current-end-of-line () - "Move point to end of current line." - (interactive) - (let ((beg (point))) - (if tpu-cursor-free-mode (picture-end-of-line) (end-of-line)) - (if (= beg (point)) (message "You are already at the end of a line.")))) - -(defun tpu-forward-line (num) - "Move to beginning of next line. -Prefix argument serves as a repeat count." - (interactive "p") - (let ((beg (tpu-current-line))) - (forward-line num) - (tpu-bottom-check beg num))) - -(defun tpu-backward-line (num) - "Move to beginning of previous line. -Prefix argument serves as repeat count." - (interactive "p") - (let ((beg (tpu-current-line))) - (or (bolp) (>= 0 num) (setq num (- num 1))) - (forward-line (- num)) - (tpu-top-check beg num))) - - -;;; Movement by paragraph - -;; Cf edt-with-position. -(defmacro tpu-with-position (&rest body) - "Execute BODY with some position-related variables bound." - `(let* ((left nil) - (beg (tpu-current-line)) - (height (window-height)) - (top-percent - (if (zerop tpu-top-scroll-margin) 10 tpu-top-scroll-margin)) - (bottom-percent - (if (zerop tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin)) - (top-margin (/ (* height top-percent) 100)) - (bottom-up-margin (1+ (/ (* height bottom-percent) 100))) - (bottom-margin (max beg (- height bottom-up-margin 1))) - (top (save-excursion (move-to-window-line top-margin) (point))) - (bottom (save-excursion (move-to-window-line bottom-margin) (point))) - (far (save-excursion - (goto-char bottom) - (line-beginning-position (1- height))))) - ,@body)) - -(defun tpu-paragraph (num) - "Move to the next paragraph in the current direction. -A repeat count means move that many paragraphs." - (interactive "p") - (tpu-with-position - (if tpu-advance - (progn - (tpu-next-paragraph num) - (if (> (point) far) - (if (zerop (setq left (save-excursion (forward-line height)))) - (recenter top-margin) - (recenter (- left bottom-up-margin))) - (and (> (point) bottom) (recenter bottom-margin)))) - (tpu-previous-paragraph num) - (and (< (point) top) (recenter (min beg top-margin)))))) - -;;; Movement by page - -(defun tpu-page (num) - "Move to the next page in the current direction. -A repeat count means move that many pages." - (interactive "p") - (tpu-with-position - (if tpu-advance - (progn - (forward-page num) - (if (> (point) far) - (if (zerop (setq left (save-excursion (forward-line height)))) - (recenter top-margin) - (recenter (- left bottom-up-margin))) - (and (> (point) bottom) (recenter bottom-margin)))) - (backward-page num) - (and (< (point) top) (recenter (min beg top-margin)))))) - -;;; Scrolling - -(defun tpu-scroll-window-down (num) - "Scroll the display down to the next section. -A repeat count means scroll that many sections." - (interactive "p") - (let* ((beg (tpu-current-line)) - (height (1- (window-height))) - (lines (* num (/ (* height tpu-percent-scroll) 100)))) - (line-move (- lines)) - (tpu-top-check beg lines))) - -(defun tpu-scroll-window-up (num) - "Scroll the display up to the next section. -A repeat count means scroll that many sections." - (interactive "p") - (let* ((beg (tpu-current-line)) - (height (1- (window-height))) - (lines (* num (/ (* height tpu-percent-scroll) 100)))) - (line-move lines) - (tpu-bottom-check beg lines))) - - -;;; Replace the TPU-edt internal search function - -(defun tpu-search-internal (pat &optional quiet) - "Search for a string or regular expression." - (tpu-with-position - (tpu-search-internal-core pat quiet) - (if tpu-searching-forward - (progn - (if (> (point) far) - (if (zerop (setq left (save-excursion (forward-line height)))) - (recenter top-margin) - (recenter (- left bottom-up-margin))) - (and (> (point) bottom) (recenter bottom-margin)))) - (and (< (point) top) (recenter (min beg top-margin)))))) - -;; Advise the newline, newline-and-indent, and do-auto-fill functions. -(defun tpu--respect-bottom-scroll-margin (orig-fun &optional &rest args) - "Respect `tpu-bottom-scroll-margin'." - (let ((beg (tpu-current-line)) - (num (prefix-numeric-value (car args)))) - (apply orig-fun args) - (tpu-bottom-check beg num))) - -;;; Function to set scroll margins - -;;;###autoload -(defun tpu-set-scroll-margins (top bottom &optional emit-msg) - "Set scroll margins." - (interactive - "sEnter top scroll margin (N lines or N%% or RETURN for current value): \ -\nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): \ -\np") - ;; set top scroll margin - (or (string= top "") - (setq tpu-top-scroll-margin - (if (string= "%" (substring top -1)) - (string-to-number top) - (/ (1- (+ (* (string-to-number top) 100) (window-height))) - (window-height))))) - ;; set bottom scroll margin - (or (string= bottom "") - (setq tpu-bottom-scroll-margin - (if (string= "%" (substring bottom -1)) - (string-to-number bottom) - (/ (1- (+ (* (string-to-number bottom) 100) (window-height))) - (window-height))))) - (dolist (f '(newline newline-and-indent do-auto-fill)) - (advice-add f :around #'tpu--respect-bottom-scroll-margin)) - ;; report scroll margin settings if running interactively - (and emit-msg - (message "Scroll margins set. Top = %s%%, Bottom = %s%%" - tpu-top-scroll-margin tpu-bottom-scroll-margin))) - - -;;; Functions to set cursor bound or free - -;;;###autoload -(defun tpu-set-cursor-free () - "Allow the cursor to move freely about the screen." - (interactive) - (tpu-cursor-free-mode 1)) - -;;;###autoload -(defun tpu-set-cursor-bound () - "Constrain the cursor to the flow of the text." - (interactive) - (tpu-cursor-free-mode -1)) - -(provide 'tpu-extras) - -;; Local Variables: -;; generated-autoload-file: "tpu-edt.el" -;; End: - -;;; tpu-extras.el ends here diff --git a/lisp/obsolete/tpu-mapper.el b/lisp/obsolete/tpu-mapper.el deleted file mode 100644 index 3a494267d5d..00000000000 --- a/lisp/obsolete/tpu-mapper.el +++ /dev/null @@ -1,325 +0,0 @@ -;;; tpu-mapper.el --- create a TPU-edt X-windows keymap file -*- lexical-binding: t; -*- - -;; Copyright (C) 1993-1995, 2001-2024 Free Software Foundation, Inc. - -;; Author: Rob Riepel -;; Keywords: emulations -;; Package: tpu-edt -;; Obsolete-since: 24.5 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; This Emacs Lisp program can be used to create an Emacs Lisp file that -;; defines the TPU-edt keypad for Emacs running on X-Windows. - -;;; Code: - -;;; -;;; Key variables -;;; -(defvar tpu-kp4 nil) -(defvar tpu-kp5 nil) -(defvar tpu-key nil) -(defvar tpu-enter nil) -(defvar tpu-return nil) -(defvar tpu-key-seq nil) -(defvar tpu-enter-seq nil) -(defvar tpu-return-seq nil) - -;;; -;;; Key mapping function -;;; -(defun tpu-map-key (ident descrip func gold-func) - (interactive) - (message "Press %s%s: " ident descrip) - (setq tpu-key-seq (read-event) - tpu-key (format "[%s]" tpu-key-seq)) - (unless (equal tpu-key tpu-return) - (set-buffer "Keys") - (insert (format"(define-key tpu-global-map %s %s)\n" tpu-key func)) - (set-buffer "Gold-Keys") - (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func))) - (set-buffer "Directions") - tpu-key) - -;;;###autoload -(defun tpu-mapper () - "Create an Emacs Lisp file defining the TPU-edt keypad for X-windows. - -This command displays an instruction screen showing the TPU-edt keypad -and asks you to press the TPU-edt editing keys. It uses the keys you -press to create an Emacs Lisp file that will define a TPU-edt keypad -for your X server. You can even re-arrange the standard EDT keypad to -suit your tastes (or to cope with those silly Sun and PC keypads). - -Finally, you will be prompted for the name of the file to store the key -definitions. If you chose the default, TPU-edt will find it and load it -automatically. If you specify a different file name, you will need to -set the variable `tpu-xkeys-file' before starting TPU-edt. Here's how -you might go about doing that in your init file. - - (setq tpu-xkeys-file (expand-file-name \"~/.my-emacs-x-keys\")) - (tpu-edt) - -Known Problems: - -Sometimes, tpu-mapper will ignore a key you press, and just continue to -prompt for the same key. This can happen when your window manager sucks -up the key and doesn't pass it on to Emacs, or it could be an Emacs bug. -Either way, there's nothing that tpu-mapper can do about it. You must -press RETURN, to skip the current key and continue. Later, you and/or -your local X guru can try to figure out why the key is being ignored." - (interactive) - - ;; Make sure we're running X-windows - - (if (not window-system) - (error "tpu-mapper requires running Emacs with an X display")) - - ;; Make sure the window is big enough to display the instructions - - (set-frame-size (selected-frame) 80 36) - - ;; Create buffers - Directions, Keys, Gold-Keys - - (if (not (get-buffer "Directions")) (generate-new-buffer "Directions")) - (if (not (get-buffer "Keys")) (generate-new-buffer "Keys")) - (if (not (get-buffer "Gold-Keys")) (generate-new-buffer "Gold-Keys")) - - ;; Put headers in the Keys buffer - - (set-buffer "Keys") - (insert "\ -;; Key definitions for TPU-edt -;; -") - - ;; Display directions - - (switch-to-buffer "Directions") - (insert " - This program prompts you to press keys to create a custom keymap file - for use with the x-windows version of Emacs and TPU-edt. - - Start by pressing the RETURN key, and continue by pressing the keys - specified in the mini-buffer. You can re-arrange the TPU-edt keypad - by pressing any key you want at any prompt. If you want to entirely - omit a key, just press RETURN at the prompt. - - Here's a picture of the standard TPU/edt keypad for reference: - - _______________________ _______________________________ - | HELP | Do | | | | | | - |KeyDefs| | | | | | | - |_______|_______________| |_______|_______|_______|_______| - _______________________ _______________________________ - | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | - | | |Sto Tex| | key |E-Help | Find |Undel L| - |_______|_______|_______| |_______|_______|_______|_______| - |Select |Pre Scr|Nex Scr| | Page | Sect |Append | Del W | - | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| - |_______|_______|_______| |_______|_______|_______|_______| - |Move up| |Forward|Reverse|Remove | Del C | - | Top | |Bottom | Top |Insert |Undel C| - _______|_______|_______ |_______|_______|_______|_______| - |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | - |StaOfLi|Bottom |EndOfLi| |ChngCas|Del EOL|SpecIns| Enter | - |_______|_______|_______| |_______|_______|_______| | - | Line |Select | Subs | - | Open Line | Reset | | - |_______________|_______|_______| - - -") - (delete-other-windows) - (goto-char (point-min)) - - ;; Save for future reference - - (message "Hit carriage-return to continue ") - (setq tpu-return-seq (read-event)) - (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]")) - - ;; Build the keymap file - - (set-buffer "Keys") - (insert " -;; Arrows -;; -") - (set-buffer "Gold-Keys") - (insert " -;; GOLD Arrows -;; -") - (set-buffer "Directions") - - (tpu-map-key "Up-Arrow" "" "'tpu-previous-line" "'tpu-move-to-beginning") - (tpu-map-key "Down-arrow" "" "'tpu-next-line" "'tpu-move-to-end") - (tpu-map-key "Right-arrow" "" "'tpu-forward-char" "'end-of-line") - (tpu-map-key "Left-arrow" "" "'tpu-backward-char" "'beginning-of-line") - - (set-buffer "Keys") - (insert " -;; PF keys -;; -") - (set-buffer "Gold-Keys") - (insert " -;; GOLD PF keys -;; -") - (set-buffer "Directions") - - (tpu-map-key "PF1" " - The GOLD key" "tpu-gold-map" "'keyboard-quit") - (tpu-map-key "PF3" " - The Find/Find-Next key" "'tpu-search-again" "'tpu-search") - (tpu-map-key "PF4" " - The Del/Undelete Line key" "'tpu-delete-current-line" "'tpu-undelete-lines") - - (set-buffer "Keys") - (insert " -;; KP0-9 KP- KP, KP. and KPenter -;; -") - (set-buffer "Gold-Keys") - (insert " -;; GOLD KP0-9 KP- KP, and KPenter -;; -") - (set-buffer "Directions") - - (tpu-map-key "KP-0" " - The Line/Open-Line key" "'tpu-line" "'open-line") - (tpu-map-key "KP-1" " - The Word/Change-Case key" "'tpu-word" "'tpu-change-case") - (tpu-map-key "KP-2" " - The EOL/Delete-EOL key" "'tpu-end-of-line" "'tpu-delete-to-eol") - (tpu-map-key "KP-3" " - The Character/Special-Insert key" "'tpu-char" "'tpu-special-insert") - (setq tpu-kp4 (tpu-map-key "KP-4" " - The Forward/Bottom key" "'tpu-advance-direction" "'tpu-move-to-end")) - (setq tpu-kp5 (tpu-map-key "KP-5" " - The Reverse/Top key" "'tpu-backup-direction" "'tpu-move-to-beginning")) - (tpu-map-key "KP-6" " - The Remove/Insert key" "'tpu-cut" "'tpu-paste") - (tpu-map-key "KP-7" " - The Page/Do key" "'tpu-page" "'execute-extended-command") - (tpu-map-key "KP-8" " - The Section/Fill key" "'tpu-scroll-window" "'tpu-fill") - (tpu-map-key "KP-9" " - The Append/Replace key" "'tpu-append-region" "'tpu-replace") - (tpu-map-key "KP--" " - The Delete/Undelete Word key" "'tpu-delete-current-word" "'tpu-undelete-words") - (tpu-map-key "KP-," " - The Delete/Undelete Character key" "'tpu-delete-current-char" "'tpu-undelete-char") - (tpu-map-key "KP-." " - The Select/Reset key" "'tpu-select" "'tpu-unselect") - (tpu-map-key "KP-Enter" " - The Enter key on the numeric keypad" "'newline" "'tpu-substitute") - ;; Save the enter key - (setq tpu-enter tpu-key) - (setq tpu-enter-seq tpu-key-seq) - - (set-buffer "Keys") - (insert " -;; Editing keypad (find, insert, remove) -;; (select, prev, next) -;; -") - (set-buffer "Gold-Keys") - (insert " -;; GOLD Editing keypad (find, insert, remove) -;; (select, prev, next) -;; -") - (set-buffer "Directions") - - (tpu-map-key "Find" " - The Find key on the editing keypad" "'tpu-search" "'nil") - (tpu-map-key "Insert" " - The Insert key on the editing keypad" "'tpu-paste" "'nil") - (tpu-map-key "Remove" " - The Remove key on the editing keypad" "'tpu-cut" "'tpu-store-text") - (tpu-map-key "Select" " - The Select key on the editing keypad" "'tpu-select" "'tpu-unselect") - (tpu-map-key "Prev Scr" " - The Prev Scr key on the editing keypad" "'tpu-scroll-window-down" "'tpu-previous-window") - (tpu-map-key "Next Scr" " - The Next Scr key on the editing keypad" "'tpu-scroll-window-up" "'tpu-next-window") - - (set-buffer "Keys") - (insert " -;; F10-14 Help Do F17 -;; -") - (set-buffer "Gold-Keys") - (insert " -;; GOLD F10-14 Help Do F17 -;; -") - (set-buffer "Directions") - - (tpu-map-key "F10" " - Invokes the Exit function on VT200+ terminals" "'tpu-exit" "'nil") - (tpu-map-key "F11" " - Inserts an Escape character into the text" "'tpu-insert-escape" "'nil") - (tpu-map-key "Backspace" " - Not Delete nor ^H! Sometimes on the F12 key" "'tpu-next-beginning-of-line" "'nil") - (tpu-map-key "F13" " - Invokes the delete previous word function" "'tpu-delete-previous-word" "'nil") - (tpu-map-key "F14" " - Toggles insert/overstrike modes" "'tpu-toggle-overwrite-mode" "'nil") - (tpu-map-key "Help" " - Brings up the help screen, same as PF2" "'tpu-help" "'describe-bindings") - (tpu-map-key "Do" " - Invokes the COMMAND function" "'execute-extended-command" "'nil") - (tpu-map-key "F17" "" "'tpu-goto-breadcrumb" "'tpu-drop-breadcrumb") - - (set-buffer "Gold-Keys") - (cond - ((not (equal tpu-enter tpu-return)) - (insert " -;; Minibuffer map additions to make KP_enter = RET -;; -") - - (insert (format "(define-key minibuffer-local-map %s 'exit-minibuffer)\n" tpu-enter)) - ;; These are not necessary because they are inherited. - ;; (insert (format "(define-key minibuffer-local-ns-map %s 'exit-minibuffer)\n" tpu-enter)) - ;; (insert (format "(define-key minibuffer-local-completion-map %s 'exit-minibuffer)\n" tpu-enter)) - (insert (format "(define-key minibuffer-local-must-match-map %s 'minibuffer-complete-and-exit)\n" tpu-enter)))) - - (cond - ((not (or (equal tpu-kp4 tpu-return) (equal tpu-kp5 tpu-return))) - (insert " -;; Minibuffer map additions to allow KP-4/5 termination of search strings. -;; -") - - (insert (format "(define-key minibuffer-local-map %s 'tpu-search-forward-exit)\n" tpu-kp4)) - (insert (format "(define-key minibuffer-local-map %s 'tpu-search-backward-exit)\n" tpu-kp5)))) - - (insert " -;; Define the tpu-help-enter/return symbols -;; -") - - (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter)) - - (append-to-buffer "Keys" 1 (point)) - (set-buffer "Keys") - - ;; Save the key mapping program - - (let ((file (convert-standard-filename "~/.tpu-keys"))) - (set-visited-file-name - (read-file-name (format "Save key mapping to file (default %s): " file) "" file))) - (save-buffer) - - ;; Load the newly defined keys and clean up - - (require 'tpu-edt) - (eval-buffer) - (kill-buffer (current-buffer)) - (kill-buffer "*scratch*") - (kill-buffer "Gold-Keys") - - ;; Let them know it worked. - - (switch-to-buffer "Directions") - (erase-buffer) - (insert " - A custom TPU-edt keymap file has been created. - - Press GOLD-k to remove this buffer and continue editing. -") - (goto-char (point-min))) - -;;; tpu-mapper.el ends here diff --git a/lisp/obsolete/uce.el b/lisp/obsolete/uce.el deleted file mode 100644 index 85e25cb7558..00000000000 --- a/lisp/obsolete/uce.el +++ /dev/null @@ -1,401 +0,0 @@ -;;; uce.el --- facilitate reply to unsolicited commercial email -*- lexical-binding: t; -*- - -;; Copyright (C) 1996, 1998, 2000-2024 Free Software Foundation, Inc. - -;; Author: stanislav shalunov -;; Created: 10 Dec 1996 -;; Keywords: mail, uce, unsolicited commercial email -;; Obsolete-since: 29.1 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; The code in this file provides a semi-automatic means of replying -;; to unsolicited commercial email (UCE) you might get. Currently, it -;; only works with Rmail and Gnus. If you would like to make it work -;; with other mail readers, see the mail-client dependent section of -;; uce-reply-to-uce. Please let me know about your changes so I can -;; incorporate them. I'd appreciate it. - -;; NOTE: We don't recommend using this feature; see the message in -;; 'uce-reply-to-uce' for the reasons. - -;; The command uce-reply-to-uce, if called when the current message -;; buffer is a UCE, will setup a reply *mail* buffer as follows. It -;; scans the full headers of the message for: 1) the normal return -;; address of the sender (From, Reply-To lines), and puts these -;; addresses into the To: header, along with abuse@offenders.host; 2) -;; the mailhub that first saw this message, and adds the address of -;; its postmaster into the To: header; and 3), finally, it looks at -;; the Message-Id and adds the postmaster of that host to the list of -;; addresses. - -;; Then, we add an "Errors-To: nobody@localhost" header, so that if -;; some of these addresses are not actually correct, we will never see -;; bounced mail. Also, mail-self-blind and mail-archive-file-name -;; take no effect: the ideology is that we don't want to save junk or -;; replies to junk. - -;; Then we insert a template into the buffer (a customizable message -;; that explains what has happened), customizable signature, and the -;; original message with full headers and envelope for postmasters. -;; Then the buffer is left for editing. - -;; The reason that the function uce-reply-to-uce is mail-client -;; dependent is that we want the full headers of the original message, -;; nothing stripped. If we use the normal means of inserting the -;; original message into the *mail* buffer, headers like Received: -;; (not really headers, but envelope lines) will be stripped, while -;; they bear valuable information for us and postmasters. I do wish -;; that there would be some portable way to write this function, but I -;; am not aware of any. - -;; Usage: - -;; Place uce.el in your load-path (and optionally byte-compile it). -;; Add the following line to your init file: -;; (autoload 'uce-reply-to-uce "uce" "Reply to UCEs" t nil) -;; If you want to use it with Gnus rather than Rmail: -;; (setq uce-mail-reader 'gnus) - -;; Options: - -;; uce-message-text is a template that will be inserted into buffer. -;; It has a reasonable default. If you want to write some scarier -;; one, please do so and send it to me. Please keep it polite. - -;; uce-signature behaves just like mail-signature. If nil, nothing is -;; inserted, if t, file ~/.signature is used, if a string, its -;; contents are inserted into buffer. - -;; uce-uce-separator is a line that separates your message from the -;; UCE that you enclose. - -;; uce-subject-line will be used as the subject of the outgoing message. - - -;;; Change Log: - -;; Dec 10, 1996 -- posted draft version to gnu.sources.emacs - -;; Dec 11, 1996 -- fixed some typos, and Francesco Potortì -;; pointed out that my use of defvar was -;; weird, suggested fix, and added let form. - -;; Dec 17, 1996 -- made scanning for host names little bit more clever -;; (obviously bogus stuff like localhost is now ignored). - -;; Nov 11, 1997 -- incorporated changes from Mikael Djurfeldt -;; to make uce.el work with Gnus. Changed the text -;; of message that is sent. - -;; Dec 3, 1997 -- changes from Gareth Jones -;; handling Received headers following some line like `From:'. - -;; Aug 16, 2000 -- changes from Detlev Zundel -;; to make uce.el work with the -;; latest Gnus. Lars told him it should work for all versions of Gnus -;; younger than three years. - - -;;; Code: - -(defvar gnus-original-article-buffer) -(defvar mail-reply-buffer) - -(require 'sendmail) -;; Those sections of code which are dependent upon -;; RMAIL are only evaluated if we have received a message with RMAIL... -;;(require 'rmail) - -(defgroup uce nil - "Facilitate reply to unsolicited commercial email." - :prefix "uce-" - :group 'mail) - -(defcustom uce-mail-reader 'rmail - "A symbol indicating which mail reader you are using. -Choose from: `gnus', `rmail'." - :type '(choice (const gnus) (const rmail)) - :version "20.3") - -(defcustom uce-setup-hook nil - "Hook to run after UCE rant message is composed. -This hook is run after `mail-setup-hook', which is run as well." - :type 'hook) - -(defcustom uce-message-text - "Recently, I have received an Unsolicited Commercial E-mail from you. -I do not like UCE's and I would like to inform you that sending -unsolicited messages to someone while he or she may have to pay for -reading your message may be illegal. Anyway, it is highly annoying -and not welcome by anyone. It is rude, after all. - -If you think that this is a good way to advertise your products or -services you are mistaken. Spamming will only make people hate you, not -buy from you. - -If you have any list of people you send unsolicited commercial emails to, -REMOVE me from such list immediately. I suggest that you make this list -just empty. - - ---------------------------------------------------- - -If you are not an administrator of any site and still have received -this message then your email address is being abused by some spammer. -They fake your address in From: or Reply-To: header. In this case, -you might want to show this message to your system administrator, and -ask him/her to investigate this matter. - -Note to the postmaster(s): I append the text of UCE in question to -this message; I would like to hear from you about action(s) taken. -This message has been sent to postmasters at the host that is -mentioned as original sender's host (I do realize that it may be -faked, but I think that if your domain name is being abused this way -you might want to learn about it, and take actions) and to the -postmaster whose host was used as mail relay for this message. If -message was sent not by your user, could you please compare time when -this message was sent (use time in Received: field of the envelope -rather than Date: field) with your sendmail logs and see what host was -using your sendmail at this moment of time. - -Thank you." - - "This is the text that `uce-reply-to-uce' command will put in reply buffer. -Some of spamming programs in use will be set up to read all incoming -to spam address email, and will remove people who put the word `remove' -on beginning of some line from the spamming list. So, when you set it -up, it might be a good idea to actually use this feature. - -Value nil means insert no text by default, lets you type it in." - :type '(choice (const nil) string)) - -(defcustom uce-uce-separator - "----- original unsolicited commercial email follows -----" - "Line that will begin quoting of the UCE. -Value nil means use no separator." - :type '(choice (const nil) string)) - -(defcustom uce-signature mail-signature -"Text to put as your signature after the note to UCE sender. -Value nil means none, t means insert `~/.signature' file (if it happens -to exist), if this variable is a string this string will be inserted -as your signature." - :type '(choice (const nil) (const t) string)) - -(defcustom uce-default-headers - "Errors-To: nobody@localhost\nPrecedence: bulk\n" - "Additional headers to use when responding to a UCE with \\[uce-reply-to-uce]. -These are mostly meant for headers that prevent delivery errors reporting." - :type '(choice (const nil) string)) - -(defcustom uce-subject-line - "Spam alert: unsolicited commercial e-mail" - "Subject of the message that will be sent in response to a UCE." - :type 'string) - -;; End of user options. - - -(defvar rmail-buffer) -(declare-function rmail-msg-is-pruned "rmail" ()) -(declare-function mail-strip-quoted-names "mail-utils" (address)) -(declare-function rmail-maybe-set-message-counters "rmail" ()) -(declare-function rmail-toggle-header "rmail" (&optional arg)) - -(defvar uce--usage-warning-displayed nil) - -;;;###autoload -(defun uce-reply-to-uce (&optional _ignored) - "Compose a reply to unsolicited commercial email (UCE). -Sets up a reply buffer addressed to: the sender, his postmaster, -his abuse@ address, and the postmaster of the mail relay used. -You might need to set `uce-mail-reader' before using this." - (interactive) - ;; Start of mail-client dependent section. - (let ((message-buffer - (cond ((eq uce-mail-reader 'gnus) gnus-original-article-buffer) - ((eq uce-mail-reader 'rmail) (bound-and-true-p rmail-buffer)) - (t (error - "Variable uce-mail-reader set to unrecognized value")))) - pruned) - (or (and message-buffer (get-buffer message-buffer)) - (error "No mail buffer, cannot find UCE")) - (switch-to-buffer message-buffer) - ;; We need the message with headers pruned. - ;; Why? All we do is get the from and reply-to headers. ? - (and (eq uce-mail-reader 'rmail) - (not (setq pruned (rmail-msg-is-pruned))) - (rmail-toggle-header 1)) - (let ((to (mail-strip-quoted-names (mail-fetch-field "from" t))) - (reply-to (mail-fetch-field "reply-to")) - temp) - ;; Initial setting of the list of recipients of our message; that's - ;; what they are pretending to be. - (setq to (if to - (format "%s" (mail-strip-quoted-names to)) - "")) - (if reply-to - (setq to (format "%s, %s" to (mail-strip-quoted-names reply-to)))) - (let (first-at-sign end-of-hostname sender-host) - (setq first-at-sign (string-search "@" to) - end-of-hostname (string-match "[ ,>]" to first-at-sign) - sender-host (substring to first-at-sign end-of-hostname)) - (if (string-search "." sender-host) - (setq to (format "%s, postmaster%s, abuse%s" - to sender-host sender-host)))) - (setq mail-send-actions nil) - (setq mail-reply-buffer nil) - (when (eq uce-mail-reader 'rmail) - (rmail-toggle-header 0) - (rmail-maybe-set-message-counters)) ; why? - (copy-region-as-kill (point-min) (point-max)) - ;; Restore the initial header state we found. - (and pruned (rmail-toggle-header 1)) - (switch-to-buffer "*mail*") - (erase-buffer) - (yank) - (goto-char (point-min)) - ;; Delete any internal Rmail headers. - (when (eq uce-mail-reader 'rmail) - (search-forward "\n\n") - (while (re-search-backward "^X-RMAIL" nil t) - (delete-region (point) (line-beginning-position 2))) - (goto-char (point-min))) - ;; Now find the mail hub that first accepted this message. - ;; This should try to find the last Received: header. - ;; Sometimes there may be other headers in between Received: headers. - (cond ((eq uce-mail-reader 'gnus) - ;; Does Gnus always have Lines: in the end? - (re-search-forward "^Lines:") - (beginning-of-line)) - ((eq uce-mail-reader 'rmail) - (search-forward "\n\n"))) - (re-search-backward "^Received:") - ;; Is this always good? It's the only thing I saw when I checked - ;; a few messages. - ;;(if (not (re-search-forward ": \\(from\\|by\\) " eol t)) - (unless (re-search-forward "\\(from\\|by\\) " (line-end-position) 'move) - (if (looking-at "[ \t\n]+\\(from\\|by\\) ") - (goto-char (match-end 0)) - (error "Failed to extract hub address"))) - (setq temp (point)) - (search-forward " ") - (forward-char -1) - ;; And add its postmaster to the list of addresses. - (if (string-search "." (buffer-substring temp (point))) - (setq to (format "%s, postmaster@%s" - to (buffer-substring temp (point))))) - ;; Also look at the message-id, it helps *very* often. - (and (search-forward "\nMessage-Id: " nil t) - ;; Not all Message-Id:'s have an `@' sign. - (search-forward "@" (line-end-position) t) - (progn - (setq temp (point)) - (search-forward ">") - (forward-char -1) - (if (string-search "." (buffer-substring temp (point))) - (setq to (format "%s, postmaster@%s" - to (buffer-substring temp (point))))))) - (when (eq uce-mail-reader 'gnus) - ;; Does Gnus always have Lines: in the end? - (re-search-forward "^Lines:") - (beginning-of-line) - (setq temp (point)) - (search-forward "\n\n" nil t) - (forward-line -1) - (delete-region temp (point))) - ;; End of mail-client dependent section. - (auto-save-mode auto-save-default) - (mail-mode) - (goto-char (point-min)) - (insert "To: ") - (save-excursion - (if to - (let ((fill-prefix "\t") - (address-start (point))) - (insert to "\n") - (fill-region-as-paragraph address-start (point))) - (newline)) - (insert "Subject: " uce-subject-line "\n") - (if uce-default-headers - (insert uce-default-headers)) - (if mail-default-headers - (insert mail-default-headers)) - (if mail-default-reply-to - (insert "Reply-To: " mail-default-reply-to "\n")) - (insert mail-header-separator "\n") - ;; Insert all our text. Then go back to the place where we started. - (if to (setq to (point))) - ;; Text of ranting. - (if uce-message-text - (insert uce-message-text)) - ;; Signature. - (cond ((eq uce-signature t) - (if (file-exists-p "~/.signature") - (progn - (insert "\n\n-- \n") - (forward-char (cadr (insert-file-contents "~/.signature")))))) - (uce-signature - (insert "\n\n-- \n" uce-signature))) - ;; And text of the original message. - (if uce-uce-separator - (insert "\n\n" uce-uce-separator "\n")) - ;; If message doesn't end with a newline, insert it. - (goto-char (point-max)) - (or (bolp) (newline))) - ;; And go back to the beginning of text. - (if to (goto-char to)) - (or to (set-buffer-modified-p nil)) - ;; Run hooks before we leave buffer for editing. Reasonable usage - ;; might be to set up special key bindings, replace standard - ;; functions in mail-mode, etc. - (run-hooks 'mail-setup-hook 'uce-setup-hook))) - (unless uce--usage-warning-displayed - (setq uce--usage-warning-displayed t) - (pop-to-buffer (get-buffer-create "uce-reply-to-uce warning")) - (insert "\ --- !!! NOTE !!! --------------------------------------------- - -Replying to spam is at best pointless, but most likely actively -harmful. - -- You will confirm that your email address is valid, thus ensuring - you get more spam. - -- You will leak information and open yourself up for further - attack. For example, they could use your \"geolocation\" to find - your home address and phone number. - -- The sender address is likely fake. - -- You help them refine their methods of spamming. - -Therefore, we strongly recommend that you do not use this package. -Use a spam filter instead, or just delete the spam. - -------------------------------------------------------------- -"))) - -(defun uce-insert-ranting (&optional _ignored) - "Insert text of the usual reply to UCE into current buffer." - (interactive "P") - (insert uce-message-text)) - -(provide 'uce) - -;;; uce.el ends here diff --git a/lisp/obsolete/vi.el b/lisp/obsolete/vi.el deleted file mode 100644 index afc6284b348..00000000000 --- a/lisp/obsolete/vi.el +++ /dev/null @@ -1,1495 +0,0 @@ -;;; vi.el --- major mode for emulating "vi" editor under GNU Emacs -*- lexical-binding: t; -*- - -;; This file is in the public domain because the authors distributed it -;; without a copyright notice before the US signed the Bern Convention. - -;; This file is part of GNU Emacs. - -;; Author: Neal Ziring -;; Felix S. T. Wu -;; Keywords: emulations -;; Obsolete-since: 24.5 - -;;; Commentary: - -;; This file is obsolete. Consider using viper instead. - -;; Originally written by : seismo!wucs!nz@rsch.wisc.edu (Neal Ziring) -;; Extensively redesigned and rewritten by wu@crys.wisc.edu (Felix S.T. Wu) -;; Last revision: 01/07/87 Wed (for GNU Emacs 18.33) - -;; INSTALLATION PROCEDURE: -;; 1) Add a global key binding for command "vi-mode" (I use ESC ESC instead of -;; the single ESC used in real "vi", so I can access other ESC prefixed emacs -;; commands while I'm in "vi"), say, by putting the following line in your -;; ".emacs" file: -;; (define-key global-map "\e\e" 'vi-mode) ;quick switch into vi-mode -;; 2) If you wish you can define "find-file-hook" to enter "vi" automatically -;; after a file is loaded into the buffer. For example, I defined it as: -;; (setq find-file-hook (list -;; (function (lambda () -;; (if (not (or (eq major-mode 'Info-mode) -;; (eq major-mode 'vi-mode))) -;; (vi-mode)))))) -;; 3) In your init file you can define the command "vi-mode" to be "autoload" -;; or you can execute the "load" command to load "vi" directly. -;; 4) Read the comments for command "vi-mode" before you start using it. - -;; COULD DO -;; 1). A general 'define-operator' function to replace current hack -;; 2). In operator handling, should allow other point moving Emacs commands -;; (such as ESC <, ESC >) to be used as arguments. - -;;; Code: - -(defvar vi-mode-old-major-mode) -(defvar vi-mode-old-mode-name) -(defvar vi-mode-old-local-map) -(defvar vi-mode-old-case-fold) - -(if (null (where-is-internal 'vi-switch-mode (current-local-map))) - (define-key ctl-x-map "~" #'vi-switch-mode)) - -(defvar vi-tilde-map nil - "Keymap used for \\[vi-switch-mode] prefix key. Link to various major modes.") - -(if vi-tilde-map - nil - (setq vi-tilde-map (make-keymap)) - (define-key vi-tilde-map "a" #'abbrev-mode) - (define-key vi-tilde-map "c" #'c-mode) - (define-key vi-tilde-map "d" #'vi-debugging) - (define-key vi-tilde-map "e" #'emacs-lisp-mode) - (define-key vi-tilde-map "f" #'auto-fill-mode) - (define-key vi-tilde-map "g" #'prolog-mode) - (define-key vi-tilde-map "h" #'hanoi) - ;; (define-key vi-tilde-map "i" #'info-mode) - (define-key vi-tilde-map "l" #'lisp-mode) - (define-key vi-tilde-map "n" #'nroff-mode) - (define-key vi-tilde-map "o" #'overwrite-mode) - (define-key vi-tilde-map "O" #'outline-mode) - (define-key vi-tilde-map "P" #'picture-mode) - (define-key vi-tilde-map "r" #'vi-readonly-mode) - (define-key vi-tilde-map "t" #'text-mode) - (define-key vi-tilde-map "v" #'vi-mode) - (define-key vi-tilde-map "x" #'tex-mode) - (define-key vi-tilde-map "~" #'vi-back-to-old-mode)) - -(defun vi-switch-mode (arg mode-char) - "Switch the major mode of current buffer as specified by the following char \\{vi-tilde-map}" - (interactive "P\nc") - (let ((mode-cmd (lookup-key vi-tilde-map (char-to-string mode-char)))) - (if (null mode-cmd) - (with-output-to-temp-buffer "*Help*" - (princ (substitute-command-keys "Possible major modes to switch to: \\{vi-tilde-map}")) - (with-current-buffer standard-output - (help-mode))) - (setq prefix-arg arg) ; prefix arg will be passed down - (command-execute mode-cmd nil) ; may need to save mode-line-format etc - (force-mode-line-update)))) ; just in case - - -(defun vi-debugging (arg) - "Toggle debug-on-error flag. If prefix arg is given, set t." - (interactive "P") - (if arg - (setq debug-on-error t) - (setq debug-on-error (not debug-on-error))) - (if debug-on-error - (message "Debug-on-error ...") - (message "NO more debug-on-error"))) - -(defun vi-back-to-old-mode () - "Go back to the previous mode without setting up for insertion." - (interactive) - (if vi-mode-old-major-mode - (progn - (setq mode-name vi-mode-old-mode-name) - (use-local-map vi-mode-old-local-map) - (setq major-mode vi-mode-old-major-mode) - (setq case-fold-search vi-mode-old-case-fold) - (force-mode-line-update)))) - -(defun vi-readonly-mode () - "Toggle current buffer's readonly flag." - (interactive) - (setq buffer-read-only (not buffer-read-only))) - -(defvar vi-com-map nil - "Keymap used in Evi's command state -Command state includes most of the vi editing commands, with some Emacs -command extensions.") - -(put 'vi-undefined 'suppress-keymap t) -(if vi-com-map nil - (setq vi-com-map (make-keymap)) -;;(fillarray vi-com-map #'vi-undefined) - (define-key vi-com-map "\C-@" #'vi-mark-region) ; extension - (define-key vi-com-map "\C-a" #'vi-ask-for-info) ; extension - (define-key vi-com-map "\C-b" #'vi-backward-windowful) - (define-key vi-com-map "\C-c" #'vi-do-old-mode-C-c-command) ; extension - (define-key vi-com-map "\C-d" #'vi-scroll-down-window) - (define-key vi-com-map "\C-e" #'vi-expose-line-below) - (define-key vi-com-map "\C-f" #'vi-forward-windowful) - (define-key vi-com-map "\C-g" #'keyboard-quit) - (define-key vi-com-map "\C-i" #'indent-relative-first-indent-point) ; TAB - (define-key vi-com-map "\C-j" #'vi-next-line) ; LFD - (define-key vi-com-map "\C-k" #'vi-kill-line) ; extension - (define-key vi-com-map "\C-l" #'recenter) - (define-key vi-com-map "\C-m" #'vi-next-line-first-nonwhite) ; RET - (define-key vi-com-map "\C-n" #'vi-next-line) - (define-key vi-com-map "\C-o" #'vi-split-open-line) - (define-key vi-com-map "\C-p" #'previous-line) - (define-key vi-com-map "\C-q" #'vi-query-replace) ; extension - (define-key vi-com-map "\C-r" #'vi-isearch-backward) ; modification - (define-key vi-com-map "\C-s" #'vi-isearch-forward) ; extension - (define-key vi-com-map "\C-t" #'vi-transpose-objects) ; extension - (define-key vi-com-map "\C-u" #'vi-scroll-up-window) - (define-key vi-com-map "\C-v" #'scroll-up-command) ; extension - (define-key vi-com-map "\C-w" #'vi-kill-region) ; extension - (define-key vi-com-map "\C-x" 'Control-X-prefix) ; extension - (define-key vi-com-map "\C-y" #'vi-expose-line-above) - (define-key vi-com-map "\C-z" #'suspend-emacs) - - (define-key vi-com-map "\e" 'ESC-prefix); C-[ (ESC) - (define-key vi-com-map "\C-\\" #'vi-unimplemented) - (define-key vi-com-map "\C-]" #'xref-find-definitions) - (define-key vi-com-map "\C-^" #'vi-locate-def) ; extension - (define-key vi-com-map "\C-_" #'vi-undefined) - - (define-key vi-com-map " " #'forward-char) - (define-key vi-com-map "!" #'vi-operator) - (define-key vi-com-map "\"" #'vi-char-argument) - (define-key vi-com-map "#" #'universal-argument) ; extension - (define-key vi-com-map "$" #'end-of-line) - (define-key vi-com-map "%" #'vi-find-matching-paren) - (define-key vi-com-map "&" #'vi-unimplemented) - (define-key vi-com-map "'" #'vi-goto-line-mark) - (define-key vi-com-map "(" #'backward-sexp) - (define-key vi-com-map ")" #'forward-sexp) - (define-key vi-com-map "*" #'vi-name-last-change-or-macro) ; extension - (define-key vi-com-map "+" #'vi-next-line-first-nonwhite) - (define-key vi-com-map "," #'vi-reverse-last-find-char) - (define-key vi-com-map "-" #'vi-previous-line-first-nonwhite) - (define-key vi-com-map "." #'vi-redo-last-change-command) - (define-key vi-com-map "/" #'vi-search-forward) - (define-key vi-com-map "0" #'beginning-of-line) - - (define-key vi-com-map "1" #'vi-digit-argument) - (define-key vi-com-map "2" #'vi-digit-argument) - (define-key vi-com-map "3" #'vi-digit-argument) - (define-key vi-com-map "4" #'vi-digit-argument) - (define-key vi-com-map "5" #'vi-digit-argument) - (define-key vi-com-map "6" #'vi-digit-argument) - (define-key vi-com-map "7" #'vi-digit-argument) - (define-key vi-com-map "8" #'vi-digit-argument) - (define-key vi-com-map "9" #'vi-digit-argument) - - (define-key vi-com-map ":" #'vi-ex-cmd) - (define-key vi-com-map ";" #'vi-repeat-last-find-char) - (define-key vi-com-map "<" #'vi-operator) - (define-key vi-com-map "=" #'vi-operator) - (define-key vi-com-map ">" #'vi-operator) - (define-key vi-com-map "?" #'vi-search-backward) - (define-key vi-com-map "@" #'vi-call-named-change-or-macro) ; extension - - (define-key vi-com-map "A" #'vi-append-at-end-of-line) - (define-key vi-com-map "B" #'vi-backward-blank-delimited-word) - (define-key vi-com-map "C" #'vi-change-rest-of-line) - (define-key vi-com-map "D" #'vi-kill-line) - (define-key vi-com-map "E" #'vi-end-of-blank-delimited-word) - (define-key vi-com-map "F" #'vi-backward-find-char) - (define-key vi-com-map "G" #'vi-goto-line) - (define-key vi-com-map "H" #'vi-home-window-line) - (define-key vi-com-map "I" #'vi-insert-before-first-nonwhite) - (define-key vi-com-map "J" #'vi-join-lines) - (define-key vi-com-map "K" #'vi-undefined) - (define-key vi-com-map "L" #'vi-last-window-line) - (define-key vi-com-map "M" #'vi-middle-window-line) - (define-key vi-com-map "N" #'vi-reverse-last-search) - (define-key vi-com-map "O" #'vi-open-above) - (define-key vi-com-map "P" #'vi-put-before) - (define-key vi-com-map "Q" #'vi-quote-words) ; extension - (define-key vi-com-map "R" #'vi-replace-chars) - (define-key vi-com-map "S" #'vi-substitute-lines) - (define-key vi-com-map "T" #'vi-backward-upto-char) - (define-key vi-com-map "U" #'vi-unimplemented) - (define-key vi-com-map "V" #'vi-undefined) - (define-key vi-com-map "W" #'vi-forward-blank-delimited-word) - (define-key vi-com-map "X" #'call-last-kbd-macro) ; modification/extension - (define-key vi-com-map "Y" #'vi-yank-line) - (define-key vi-com-map "Z" (make-sparse-keymap)) ;allow below prefix command - (define-key vi-com-map "ZZ" #'vi-save-all-and-exit) - - (define-key vi-com-map "[" #'vi-unimplemented) - (define-key vi-com-map "\\" #'vi-operator) ; extension for vi-narrow-op - (define-key vi-com-map "]" #'vi-unimplemented) - (define-key vi-com-map "^" #'back-to-indentation) - (define-key vi-com-map "_" #'vi-undefined) - (define-key vi-com-map "`" #'vi-goto-char-mark) - - (define-key vi-com-map "a" #'vi-insert-after) - (define-key vi-com-map "b" #'backward-word) - (define-key vi-com-map "c" #'vi-operator) - (define-key vi-com-map "d" #'vi-operator) - (define-key vi-com-map "e" #'vi-end-of-word) - (define-key vi-com-map "f" #'vi-forward-find-char) - (define-key vi-com-map "g" #'vi-beginning-of-buffer) ; extension - (define-key vi-com-map "h" #'backward-char) - (define-key vi-com-map "i" #'vi-insert-before) - (define-key vi-com-map "j" #'vi-next-line) - (define-key vi-com-map "k" #'previous-line) - (define-key vi-com-map "l" #'forward-char) - (define-key vi-com-map "m" #'vi-set-mark) - (define-key vi-com-map "n" #'vi-repeat-last-search) - (define-key vi-com-map "o" #'vi-open-below) - (define-key vi-com-map "p" #'vi-put-after) - (define-key vi-com-map "q" #'vi-replace) - (define-key vi-com-map "r" #'vi-replace-1-char) - (define-key vi-com-map "s" #'vi-substitute-chars) - (define-key vi-com-map "t" #'vi-forward-upto-char) - (define-key vi-com-map "u" #'undo) - (define-key vi-com-map "v" #'vi-verify-spelling) - (define-key vi-com-map "w" #'vi-forward-word) - (define-key vi-com-map "x" #'vi-kill-char) - (define-key vi-com-map "y" #'vi-operator) - (define-key vi-com-map "z" #'vi-adjust-window) - - (define-key vi-com-map "{" #'backward-paragraph) - (define-key vi-com-map "|" #'vi-goto-column) - (define-key vi-com-map "}" #'forward-paragraph) - (define-key vi-com-map "~" #'vi-change-case) - (define-key vi-com-map "\177" #'delete-backward-char)) - -(put 'backward-char 'point-moving-unit 'char) -(put 'vi-next-line 'point-moving-unit 'line) -(put 'next-line 'point-moving-unit 'line) -(put 'forward-line 'point-moving-unit 'line) -(put 'previous-line 'point-moving-unit 'line) -(put 'vi-isearch-backward 'point-moving-unit 'search) -(put 'vi-search-backward 'point-moving-unit 'search) -(put 'vi-isearch-forward 'point-moving-unit 'search) -(put 'vi-search-forward 'point-moving-unit 'search) -(put 'forward-char 'point-moving-unit 'char) -(put 'end-of-line 'point-moving-unit 'char) -(put 'vi-find-matching-paren 'point-moving-unit 'match) -(put 'vi-goto-line-mark 'point-moving-unit 'line) -(put 'backward-sexp 'point-moving-unit 'sexp) -(put 'forward-sexp 'point-moving-unit 'sexp) -(put 'vi-next-line-first-nonwhite 'point-moving-unit 'line) -(put 'vi-previous-line-first-nonwhite 'point-moving-unit 'line) -(put 'vi-reverse-last-find-char 'point-moving-unit 'rev-find) -(put 'vi-re-search-forward 'point-moving-unit 'search) -(put 'beginning-of-line 'point-moving-unit 'char) -(put 'vi-beginning-of-buffer 'point-moving-unit 'char) -(put 'vi-repeat-last-find-char 'point-moving-unit 'find) -(put 'vi-re-search-backward 'point-moving-unit 'search) -(put 'vi-backward-blank-delimited-word 'point-moving-unit 'WORD) -(put 'vi-end-of-blank-delimited-word 'point-moving-unit 'match) -(put 'vi-backward-find-char 'point-moving-unit 'find) -(put 'vi-goto-line 'point-moving-unit 'line) -(put 'vi-home-window-line 'point-moving-unit 'line) -(put 'vi-last-window-line 'point-moving-unit 'line) -(put 'vi-middle-window-line 'point-moving-unit 'line) -(put 'vi-reverse-last-search 'point-moving-unit 'rev-search) -(put 'vi-backward-upto-char 'point-moving-unit 'find) -(put 'vi-forward-blank-delimited-word 'point-moving-unit 'WORD) -(put 'back-to-indentation 'point-moving-unit 'char) -(put 'vi-goto-char-mark 'point-moving-unit 'char) -(put 'backward-word 'point-moving-unit 'word) -(put 'vi-end-of-word 'point-moving-unit 'match) -(put 'vi-forward-find-char 'point-moving-unit 'find) -(put 'backward-char 'point-moving-unit 'char) -(put 'vi-forward-char 'point-moving-unit 'char) -(put 'vi-repeat-last-search 'point-moving-unit 'search) -(put 'vi-forward-upto-char 'point-moving-unit 'find) -(put 'vi-forward-word 'point-moving-unit 'word) -(put 'vi-goto-column 'point-moving-unit 'match) -(put 'forward-paragraph 'point-moving-unit 'paragraph) -(put 'backward-paragraph 'point-moving-unit 'paragraph) - -;;; region mark commands -(put 'mark-page 'point-moving-unit 'region) -(put 'mark-paragraph 'point-moving-unit 'region) -(put 'mark-word 'point-moving-unit 'region) -(put 'mark-sexp 'point-moving-unit 'region) -(put 'mark-defun 'point-moving-unit 'region) -(put 'mark-whole-buffer 'point-moving-unit 'region) -(put 'mark-end-of-sentence 'point-moving-unit 'region) -(put 'c-mark-function 'point-moving-unit 'region) -;;; - -(defvar vi-mark-alist nil - "Alist of (NAME . MARK), marks are local to each buffer.") - -(defvar vi-scroll-amount (/ (window-height) 2) - "Default amount of lines for scrolling (used by \"^D\"/\"^U\").") - -(defvar vi-shift-width 4 - "Shift amount for \"<\"/\">\" operators.") - -(defvar vi-ins-point nil ; integer - "Last insertion point. Should use `mark' instead.") - -(defvar vi-ins-length nil ; integer - "Length of last insertion.") - -(defvar vi-ins-repetition nil ; integer - "The repetition required for last insertion.") - -(defvar vi-ins-overwrt-p nil ; boolean - "T if last insertion was a replace actually.") - -(defvar vi-ins-prefix-code nil ; ready-to-eval sexp - "Code to be eval'ed before (redo-)insertion begins.") - -(defvar vi-last-find-char nil ; cons cell - "Save last direction, char and upto-flag used for char finding.") - -(defvar vi-last-change-command nil ; cons cell - "Save commands for redoing last changes. Each command is in (FUNC . ARGS) -form that is ready to be `apply'ed.") - -(defvar vi-last-shell-command nil ; last shell op command line - "Save last shell command given for \"!\" operator.") - -(defvar vi-insert-state nil ; boolean - "Non-nil if it is in insert state.") - -; in "loaddefs.el" -;(defvar search-last-string "" -; "Last string search for by a search command.") - -(defvar vi-search-last-command nil ; (re-)search-forward(backward) - "Save last search command for possible redo.") - -(defvar vi-mode-old-local-map nil - "Save the local-map used before entering vi-mode.") - -(defvar vi-mode-old-mode-name nil - "Save the mode-name before entering vi-mode.") - -(defvar vi-mode-old-major-mode nil - "Save the major-mode before entering vi-mode.") - -(defvar vi-mode-old-case-fold nil) - -;(defconst vi-add-to-mode-line-1 -; '(overwrite-mode nil " Insert")) - -;; Value is same as vi-add-to-mode-line-1 when in vi mode, -;; but nil in other buffers. -;(defvar vi-add-to-mode-line nil) - -(defun vi-mode-setup () - "Setup a buffer for vi-mode by creating necessary buffer-local variables." -; (make-local-variable 'vi-add-to-mode-line) -; (setq vi-add-to-mode-line vi-add-to-mode-line-1) -; (or (memq vi-add-to-mode-line minor-mode-alist) -; (setq minor-mode-alist (cons vi-add-to-mode-line minor-mode-alist))) - (make-local-variable 'vi-scroll-amount) - (setq vi-scroll-amount (/ (window-height) 2)) - (make-local-variable 'vi-shift-width) - (setq vi-shift-width 4) - (make-local-variable 'vi-ins-point) - (make-local-variable 'vi-ins-length) - (make-local-variable 'vi-ins-repetition) - (make-local-variable 'vi-ins-overwrt-p) - (make-local-variable 'vi-ins-prefix-code) - (make-local-variable 'vi-last-change-command) - (make-local-variable 'vi-last-shell-command) - (make-local-variable 'vi-last-find-char) - (make-local-variable 'vi-mark-alist) - (make-local-variable 'vi-insert-state) - (make-local-variable 'vi-mode-old-local-map) - (make-local-variable 'vi-mode-old-mode-name) - (make-local-variable 'vi-mode-old-major-mode) - (make-local-variable 'vi-mode-old-case-fold) - (run-mode-hooks 'vi-mode-hook)) - -;;;###autoload -(defun vi-mode () - "Major mode that acts like the `vi' editor. -The purpose of this mode is to provide you the combined power of vi (namely, -the \"cross product\" effect of commands and repeat last changes) and Emacs. - -This command redefines nearly all keys to look like vi commands. -It records the previous major mode, and any vi command for input -\(`i', `a', `s', etc.) switches back to that mode. -Thus, ordinary Emacs (in whatever major mode you had been using) -is \"input\" mode as far as vi is concerned. - -To get back into vi from \"input\" mode, you must issue this command again. -Therefore, it is recommended that you assign it to a key. - -Major differences between this mode and real vi : - -* Limitations and unsupported features - - Search patterns with line offset (e.g. /pat/+3 or /pat/z.) are - not supported. - - Ex commands are not implemented; try ':' to get some hints. - - No line undo (i.e. the `U' command), but multi-undo is a standard feature. - -* Modifications - - The stopping positions for some point motion commands (word boundary, - pattern search) are slightly different from standard `vi'. - Also, no automatic wrap around at end of buffer for pattern searching. - - Since changes are done in two steps (deletion then insertion), you need - to undo twice to completely undo a change command. But this is not needed - for undoing a repeated change command. - - No need to set/unset `magic', to search for a string with regular expr - in it just put a prefix arg for the search commands. Replace cmds too. - - ^R is bound to incremental backward search, so use ^L to redraw screen. - -* Extensions - - Some standard (or modified) Emacs commands were integrated, such as - incremental search, query replace, transpose objects, and keyboard macros. - - In command state, ^X links to the `ctl-x-map', and ESC can be linked to - esc-map or set undefined. These can give you the full power of Emacs. - - See vi-com-map for those keys that are extensions to standard vi, e.g. - `vi-name-last-change-or-macro', `vi-verify-spelling', `vi-locate-def', - `vi-mark-region', and `vi-quote-words'. Some of them are quite handy. - - Use \\[vi-switch-mode] to switch among different modes quickly. - -Syntax table and abbrevs while in vi mode remain as they were in Emacs." - (interactive) - (if (null vi-mode-old-major-mode) ; very first call for current buffer - (vi-mode-setup)) - - (if (eq major-mode 'vi-mode) - (progn (ding) (message "Already in vi-mode.")) - (setq vi-mode-old-local-map (current-local-map)) - (setq vi-mode-old-mode-name mode-name) - (setq vi-mode-old-major-mode major-mode) - (setq vi-mode-old-case-fold case-fold-search) ; this is needed !! - (setq case-fold-search nil) ; exact case match in searching - (use-local-map vi-com-map) - (setq major-mode 'vi-mode) - (setq mode-name "VI") - (force-mode-line-update) ; force mode line update - (if vi-insert-state ; this is a return from insertion - (vi-end-of-insert-state)))) - -(defun vi-ding() - "Ding !" - (interactive) - (ding)) - -(defun vi-save-all-and-exit () - "Save all modified buffers without asking, then exits emacs." - (interactive) - (save-some-buffers t) - (kill-emacs)) - -;; to be used by "ex" commands -(defvar vi-replaced-string nil) -(defvar vi-replacing-string nil) - -(defun vi-ex-cmd () - "Ex commands are not implemented in Evi mode. For some commonly used ex -commands, you can use the following alternatives for similar effect : -w C-x C-s (save-buffer) -wq C-x C-c (save-buffers-kill-emacs) -w fname C-x C-w (write-file) -e fname C-x C-f (find-file) -r fname C-x i (insert-file) -s/old/new use q (vi-replace) to do unconditional replace - use C-q (vi-query-replace) to do query replace -set sw=n M-x set-variable vi-shift-width n " - (interactive) -;; (let ((cmd (read-string ":")) (lines 1)) -;; (cond ((string-match "s")))) - (with-output-to-temp-buffer "*Help*" - (princ (documentation 'vi-ex-cmd)) - (with-current-buffer standard-output - (help-mode)))) - -(defun vi-undefined () - (interactive) - (message "Command key \"%s\" is undefined in Evi." - (single-key-description last-command-event)) - (ding)) - -(defun vi-unimplemented () - (interactive) - (message "Command key \"%s\" is not implemented in Evi." - (single-key-description last-command-event)) - (ding)) - -;;;;; -(defun vi-goto-insert-state (repetition &optional prefix-code do-it-now-p) - "Go into insert state, the text entered will be repeated if REPETITION > 1. -If PREFIX-CODE is given, do it before insertion begins if DO-IT-NOW-P is T. -In any case, the prefix-code will be done before each `redo-insert'. -This function expects `overwrite-mode' being set properly beforehand." - (if do-it-now-p (apply (car prefix-code) (cdr prefix-code))) - (setq vi-ins-point (point)) - (setq vi-ins-repetition repetition) - (setq vi-ins-prefix-code prefix-code) - (setq mode-name vi-mode-old-mode-name) - (setq case-fold-search vi-mode-old-case-fold) - (use-local-map vi-mode-old-local-map) - (setq major-mode vi-mode-old-major-mode) - (force-mode-line-update) - (setq vi-insert-state t)) - -(defun vi-end-of-insert-state () - "Terminate insertion and set up last change command." - (if (or (< (point) vi-ins-point) ;Check if there is any effective change - (and (= (point) vi-ins-point) (null vi-ins-prefix-code)) - (<= vi-ins-repetition 0)) - (vi-goto-command-state t) - (if (> vi-ins-repetition 1) - (progn - (let ((str (buffer-substring vi-ins-point (point)))) - (while (> vi-ins-repetition 1) - (insert str) - (setq vi-ins-repetition (1- vi-ins-repetition)))))) - (vi-set-last-change-command 'vi-first-redo-insertion vi-ins-point (point) - overwrite-mode vi-ins-prefix-code) - (vi-goto-command-state t))) - -(defun vi-first-redo-insertion (begin end &optional overwrite-p prefix-code) - "Redo last insertion the first time. Extract the string and save it for -future redoes. Do prefix-code if it's given, use overwrite mode if asked." - (let ((str (buffer-substring begin end))) - (if prefix-code (apply (car prefix-code) (cdr prefix-code))) - (if overwrite-p (delete-region (point) (+ (point) (length str)))) - (insert str) - (vi-set-last-change-command 'vi-more-redo-insertion str overwrite-p prefix-code))) - -(defun vi-more-redo-insertion (str &optional overwrite-p prefix-code) - "Redo more insertion : copy string from STR to point, use overwrite mode -if overwrite-p is T; apply prefix-code first if it's non-nil." - (if prefix-code (apply (car prefix-code) (cdr prefix-code))) - (if overwrite-p (delete-region (point) (+ (point) (length str)))) - (insert str)) - -(defun vi-goto-command-state (&optional from-insert-state-p) - "Go to vi-mode command state. If optional arg exists, means return from -insert state." - (use-local-map vi-com-map) - (setq vi-insert-state nil) - (if from-insert-state-p - (if overwrite-mode - (overwrite-mode 0) -; (set-minor-mode 'ins "Insert" nil) - ))) - -(defun vi-kill-line (arg) - "kill specified number of lines (=d$), text saved in the kill ring." - (interactive "*P") - (kill-line arg) - (vi-set-last-change-command 'kill-line arg)) - -(defun vi-kill-region (start end) - (interactive "*r") - (kill-region start end) - (vi-set-last-change-command 'kill-region)) - -(defun vi-append-at-end-of-line (arg) - "go to end of line and then go into vi insert state." - (interactive "*p") - (vi-goto-insert-state arg '(end-of-line) t)) - -(defun vi-change-rest-of-line (arg) - "Change the rest of (ARG) lines (= c$ in vi)." - (interactive "*P") - (vi-goto-insert-state 1 (list 'kill-line arg) t)) - -(defun vi-insert-before-first-nonwhite (arg) - "(= ^i in vi)" - (interactive "*p") - (vi-goto-insert-state arg '(back-to-indentation) t)) - -(defun vi-open-above (arg) - "open new line(s) above current line and enter insert state." - (interactive "*p") - (vi-goto-insert-state 1 - (list (function (lambda (x) - (or (beginning-of-line) - (open-line x)))) arg) - t)) - -(defun vi-open-below (arg) - "open new line(s) and go into insert mode on the last line." - (interactive "*p") - (vi-goto-insert-state 1 - (list (function (lambda (x) - (or (end-of-line) - (open-line x) - (forward-line x)))) arg) - t)) - -(defun vi-insert-after (arg) - "start vi insert state after cursor." - (interactive "*p") - (vi-goto-insert-state arg - (list (function (lambda () - (if (not (eolp)) (forward-char))))) - t)) - -(defun vi-insert-before (arg) - "enter insert state before the cursor." - (interactive "*p") - (vi-goto-insert-state arg)) - -(defun vi-goto-line (arg) - "Go to ARGth line." - (interactive "P") - (if (null (vi-raw-numeric-prefix arg)) - (with-no-warnings - (end-of-buffer)) - (with-no-warnings (goto-line (vi-prefix-numeric-value arg))))) - -(defun vi-beginning-of-buffer () - "Move point to the beginning of current buffer." - (interactive) - (goto-char (point-min))) - -;;;;; not used now -;;(defvar regexp-search t ; string -;; "*T if search string can contain regular expressions. (= set magic in vi)") -;;;;; - -(defun vi-isearch-forward (arg) - "Incremental search forward. Use regexp version if ARG is non-nil." - (interactive "P") - (let ((scmd (if arg 'isearch-forward-regexp 'isearch-forward)) - (opoint (point))) - (call-interactively scmd) - (if (= opoint (point)) - nil - (setq vi-search-last-command (if arg 're-search-forward 'search-forward))))) - -(defun vi-isearch-backward (arg) - "Incremental search backward. Use regexp version if ARG is non-nil." - (interactive "P") - (let ((scmd (if arg 'isearch-backward-regexp 'isearch-backward)) - (opoint (point))) - (call-interactively scmd) - (if (= opoint (point)) - nil - (setq vi-search-last-command (if arg 're-search-backward 'search-backward))))) - -(defun vi-search-forward (arg string) - "Nonincremental search forward. Use regexp version if ARG is non-nil." - (interactive (if current-prefix-arg - (list t (read-string "regexp/" nil)) - (list nil (read-string "/" nil)))) - (setq vi-search-last-command (if arg 're-search-forward 'search-forward)) - (if (> (length string) 0) - (isearch-update-ring string arg)) - (funcall vi-search-last-command string nil nil 1)) - -(defun vi-search-backward (arg string) - "Nonincremental search backward. Use regexp version if ARG is non-nil." - (interactive (if current-prefix-arg - (list t (read-string "regexp?" nil)) - (list nil (read-string "?" nil)))) - (setq vi-search-last-command (if arg 're-search-backward 'search-backward)) - (if (> (length string) 0) - (isearch-update-ring string arg)) - (funcall vi-search-last-command string nil nil 1)) - -(defun vi-repeat-last-search (arg &optional search-command search-string) - "Repeat last search command. -If optional search-command/string are given, -use those instead of the ones saved." - (interactive "p") - (if (null search-command) (setq search-command vi-search-last-command)) - (if (null search-string) - (setq search-string - (car (if (memq search-command - '(re-search-forward re-search-backward)) - regexp-search-ring - search-ring)))) - (if (null search-command) - (progn (ding) (message "No last search command to repeat.")) - (funcall search-command search-string nil nil arg))) - -(defun vi-reverse-last-search (arg &optional search-command search-string) - "Redo last search command in reverse direction. -If the optional search args are given, use those instead of the ones saved." - (interactive "p") - (if (null search-command) (setq search-command vi-search-last-command)) - (if (null search-string) - (setq search-string - (car (if (memq search-command - '(re-search-forward re-search-backward)) - regexp-search-ring - search-ring)))) - (if (null search-command) - (progn (ding) (message "No last search command to repeat.")) - (funcall (cond ((eq search-command 're-search-forward) 're-search-backward) - ((eq search-command 're-search-backward) 're-search-forward) - ((eq search-command 'search-forward) 'search-backward) - ((eq search-command 'search-backward) 'search-forward)) - search-string nil nil arg))) - -(defun vi-join-lines (arg) - "join ARG lines from current line (default 2), cleaning up white space." - (interactive "P") - (if (null (vi-raw-numeric-prefix arg)) - (delete-indentation t) - (let ((count (vi-prefix-numeric-value arg))) - (while (>= count 2) - (delete-indentation t) - (setq count (1- count))))) - (vi-set-last-change-command 'vi-join-lines arg)) - -(defun vi-backward-kill-line () - "kill the current line. Only works in insert state." - (interactive) - (if (not vi-insert-state) - nil - (beginning-of-line 1) - (kill-line nil))) - -(defun vi-abort-ins () - "abort insert state, kill inserted text and go back to command state." - (interactive) - (if (not vi-insert-state) - nil - (if (> (point) vi-ins-point) - (kill-region vi-ins-point (point))) - (vi-goto-command-state t))) - -(defun vi-backward-windowful (count) - "Backward COUNT windowfuls. Default is one." - (interactive "p") -; (set-mark-command nil) - (while (> count 0) - (scroll-down nil) - (setq count (1- count)))) - -(defun vi-scroll-down-window (count) - "Scrolls down window COUNT lines. -If COUNT is nil (actually, non-integer), scrolls default amount. -The given COUNT is remembered for future scrollings." - (interactive "P") - (if (integerp count) - (setq vi-scroll-amount count)) - (scroll-up vi-scroll-amount)) - -(defun vi-expose-line-below (count) - "Expose COUNT more lines below the current window. Default COUNT is 1." - (interactive "p") - (scroll-up count)) - -(defun vi-forward-windowful (count) - "Forward COUNT windowfuls. Default is one." - (interactive "p") -; (set-mark-command nil) - (while (> count 0) - (scroll-up nil) - (setq count (1- count)))) - -(defun vi-next-line (count) - "Go down count lines, try to keep at the same column." - (interactive "p") - (setq this-command 'next-line) ; this is a needed trick - (if (= (point) (progn (line-move count) (point))) - (ding) ; no moving, already at end of buffer - (setq last-command 'next-line))) - -(defun vi-next-line-first-nonwhite (count) - "Go down COUNT lines. Stop at first non-white." - (interactive "p") - (if (= (point) (progn (forward-line count) (back-to-indentation) (point))) - (ding))) ; no moving, already at end of buffer - -(defun vi-previous-line-first-nonwhite (count) - "Go up COUNT lines. Stop at first non-white." - (interactive "p") - (forward-line (- count)) - (back-to-indentation)) - -(defun vi-scroll-up-window (count) - "Scrolls up window COUNT lines. -If COUNT is nil (actually, non-integer), scrolls default amount. -The given COUNT is remembered for future scrollings." - (interactive "P") - (if (integerp count) - (setq vi-scroll-amount count)) - (scroll-down vi-scroll-amount)) - -(defun vi-expose-line-above (count) - "Expose COUNT more lines above the current window. Default COUNT is 1." - (interactive "p") - (scroll-down count)) - -(defun vi-char-argument (arg) - "Get following character (could be any CHAR) as part of the prefix argument. -Possible prefix-arg cases are nil, INTEGER, (nil . CHAR) or (INTEGER . CHAR)." - (interactive "P") - (let ((char (read-char))) - (cond ((null arg) (setq prefix-arg (cons nil char))) - ((integerp arg) (setq prefix-arg (cons arg char))) - ; This can happen only if the user changed his/her mind for CHAR, - ; Or there are some leading "universal-argument"s - (t (setq prefix-arg (cons (car arg) char)))))) - -(defun vi-goto-mark (mark-char &optional line-flag) - "Go to marked position or line (if line-flag is given). -Goto mark `@' means jump into and pop the top mark on the mark ring." - (cond ((char-equal mark-char last-command-event) ; `` or '' - (exchange-point-and-mark) (if line-flag (back-to-indentation))) - ((char-equal mark-char ?@) ; jump and pop mark - (set-mark-command t) (if line-flag (back-to-indentation))) - (t - (let ((mark (vi-get-mark mark-char))) - (if (null mark) - (progn (vi-ding) (message "Mark register undefined.")) - (set-mark-command nil) - (goto-char mark) - (if line-flag (back-to-indentation))))))) - -(defun vi-goto-line-mark (char) - "Go to the line (at first non-white) marked by next char." - (interactive "c") - (vi-goto-mark char t)) - -(defun vi-goto-char-mark (char) - "Go to the char position marked by next mark-char." - (interactive "c") - (vi-goto-mark char)) - -(defun vi-digit-argument (arg) - "Set numeric prefix argument." - (interactive "P") - (cond ((null arg) (digit-argument arg)) - ((integerp arg) (digit-argument nil) - (setq prefix-arg (* prefix-arg arg))) - (t (digit-argument nil) ; in (NIL . CHAR) or (NUM . CHAR) form - (setq prefix-arg (cons (* prefix-arg - (if (null (car arg)) 1 (car arg))) - (cdr arg)))))) - -(defun vi-raw-numeric-prefix (arg) - "Return the raw value of numeric part prefix argument." - (if (consp arg) (car arg) arg)) - -(defun vi-prefix-numeric-value (arg) - "Return numeric meaning of the raw prefix argument. This is a modification -to the standard one provided in `callint.c' to handle (_ . CHAR) cases." - (cond ((null arg) 1) - ((integerp arg) arg) - ((consp arg) (if (car arg) (car arg) 1)))) - -(defun vi-reverse-last-find-char (count &optional find-arg) - "Reverse last f F t T operation COUNT times. If the optional FIND-ARG -is given, it is used instead of the saved one." - (interactive "p") - (if (null find-arg) (setq find-arg vi-last-find-char)) - (if (null find-arg) - (progn (ding) (message "No last find char to repeat.")) - (vi-find-char (cons (* (car find-arg) -1) (cdr find-arg)) count))) ;6/13/86 - -(defun vi-find-char (arg count) - "Find in DIRECTION (1/-1) for CHAR of COUNT'th times on current line. -If UPTO-FLAG is T, stop before the char. ARG = (DIRECTION.CHAR.UPTO-FLAG." - (let* ((direction (car arg)) (char (car (cdr arg))) - (upto-flag (cdr (cdr arg))) (pos (+ (point) direction))) - (if (catch 'exit-find-char - (while t - (cond ((null (char-after pos)) (throw 'exit-find-char nil)) - ((char-equal (char-after pos) ?\n) (throw 'exit-find-char nil)) - ((char-equal char (char-after pos)) (setq count (1- count)) - (if (= count 0) - (throw 'exit-find-char - (if upto-flag - (setq pos (- pos direction)) - pos))))) - (setq pos (+ pos direction)))) - (goto-char pos) - (ding)))) - -(defun vi-repeat-last-find-char (count &optional find-arg) - "Repeat last f F t T operation COUNT times. If optional FIND-ARG is given, -it is used instead of the saved one." - (interactive "p") - (if (null find-arg) (setq find-arg vi-last-find-char)) - (if (null find-arg) - (progn (ding) (message "No last find char to repeat.")) - (vi-find-char find-arg count))) - -(defun vi-backward-find-char (count char) - "Find the COUNT'th CHAR backward on current line." - (interactive "p\nc") - (setq vi-last-find-char (cons -1 (cons char nil))) - (vi-repeat-last-find-char count)) - -(defun vi-forward-find-char (count char) - "Find the COUNT'th CHAR forward on current line." - (interactive "p\nc") - (setq vi-last-find-char (cons 1 (cons char nil))) - (vi-repeat-last-find-char count)) - -(defun vi-backward-upto-char (count char) - "Find up to the COUNT'th CHAR backward on current line." - (interactive "p\nc") - (setq vi-last-find-char (cons -1 (cons char t))) - (vi-repeat-last-find-char count)) - -(defun vi-forward-upto-char (count char) - "Find up to the COUNT'th CHAR forward on current line." - (interactive "p\nc") - (setq vi-last-find-char (cons 1 (cons char t))) - (vi-repeat-last-find-char count)) - -(defun vi-end-of-word (count) - "Move forward until encountering the end of a word. -With argument, do this that many times." - (interactive "p") - (if (not (eobp)) (forward-char)) - (if (re-search-forward "\\W*\\w+\\>" nil t count) - (backward-char))) - -(defun vi-replace-1-char (count char) - "Replace char after point by CHAR. Repeat COUNT times." - (interactive "p\nc") - (delete-char count nil) ; don't save in kill ring - (setq last-command-event char) - (self-insert-command count) - (vi-set-last-change-command 'vi-replace-1-char count char)) - -(defun vi-replace-chars (arg) - "Replace chars over old ones." - (interactive "*p") - (overwrite-mode 1) - (vi-goto-insert-state arg)) - -(defun vi-substitute-chars (count) - "Substitute COUNT chars by the input chars, enter insert state." - (interactive "*p") - (vi-goto-insert-state 1 (list (function (lambda (c) ; this is a bit tricky - (delete-region (point) - (+ (point) c)))) - count) t)) - -(defun vi-substitute-lines (count) - "Substitute COUNT lines by the input chars. (=cc in vi)" - (interactive "*p") - (vi-goto-insert-state 1 (list 'vi-delete-op 'next-line (1- count)) t)) - -(defun vi-prefix-char-value (arg) - "Get the char part of the current prefix argument." - (cond ((null arg) nil) - ((integerp arg) nil) - ((consp arg) (cdr arg)) - (t nil))) - -(defun vi-operator (arg) - "Handling vi operators (d/c//!/=/y). Current implementation requires -the key bindings of the operators being fixed." - (interactive "P") - (catch 'vi-exit-op - (let ((this-op-char last-command-event)) - (setq last-command-event (read-char)) - (setq this-command (lookup-key vi-com-map (char-to-string last-command-event))) - (if (not (eq this-command 'vi-digit-argument)) - (setq prefix-arg arg) - (vi-digit-argument arg) - (setq last-command-event (read-char)) - (setq this-command (lookup-key vi-com-map (char-to-string last-command-event)))) - (cond ((char-equal this-op-char last-command-event) ; line op - (vi-execute-op this-op-char 'next-line - (cons (1- (vi-prefix-numeric-value prefix-arg)) - (vi-prefix-char-value prefix-arg)))) - ;; We assume any command that has no property 'point-moving-unit' - ;; as having that property with the value 'CHAR'. 3/12/86 - (t ;; (get this-command 'point-moving-unit) - (vi-execute-op this-op-char this-command prefix-arg)))))) - ;; (t (throw 'vi-exit-op (ding))))))) - -(defun vi-execute-op (op-char motion-command arg) - "Execute vi edit operator as specified by OP-CHAR, the operand is the region -determined by the MOTION-COMMAND with ARG." - (cond ((= op-char ?d) - (if (vi-delete-op motion-command arg) - (vi-set-last-change-command 'vi-delete-op (vi-repeat-command-of motion-command) arg))) - ((= op-char ?c) - (if (vi-delete-op motion-command arg) - (vi-goto-insert-state 1 (list 'vi-delete-op - (vi-repeat-command-of motion-command) arg) nil))) - ((= op-char ?y) - (if (vi-yank-op motion-command arg) - (vi-set-last-change-command 'vi-yank-op (vi-repeat-command-of motion-command) arg))) - ((= op-char ?!) - (if (vi-shell-op motion-command arg) - (vi-set-last-change-command 'vi-shell-op (vi-repeat-command-of motion-command) arg vi-last-shell-command))) - ((= op-char ?<) - (if (vi-shift-op motion-command arg (- vi-shift-width)) - (vi-set-last-change-command 'vi-shift-op (vi-repeat-command-of motion-command) arg (- vi-shift-width)))) - ((= op-char ?>) - (if (vi-shift-op motion-command arg vi-shift-width) - (vi-set-last-change-command 'vi-shift-op (vi-repeat-command-of motion-command) arg vi-shift-width))) - ((= op-char ?=) - (if (vi-indent-op motion-command arg) - (vi-set-last-change-command 'vi-indent-op (vi-repeat-command-of motion-command) arg))) - ((= op-char ?\\) - (vi-narrow-op motion-command arg)))) - -(defun vi-repeat-command-of (command) - "Return the command for redo the given command." - (let ((cmd-type (get command 'point-moving-unit))) - (cond ((eq cmd-type 'search) 'vi-repeat-last-search) - ((eq cmd-type 'find) 'vi-repeat-last-find-char) - (t command)))) - -(defun vi-effective-range (motion-command arg) - "Return (begin . end) of the range spanned by executing the given -MOTION-COMMAND with ARG. - MOTION-COMMAND in ready-to-eval list form is not yet supported." - (save-excursion - (let ((begin (point)) end opoint - (moving-unit (get motion-command 'point-moving-unit))) - (setq prefix-arg arg) - (setq opoint (point)) - (command-execute motion-command nil) -;; Check if there is any effective motion. Note that for single line operation -;; the motion-command causes no effective point movement (since it moves up or -;; down zero lines), but it should be counted as effectively moved. - (if (and (= (point) opoint) (not (eq moving-unit 'line))) - (cons opoint opoint) ; no effective motion - (if (eq moving-unit 'region) - (setq begin (or (mark) (point)))) - (if (<= begin (point)) - (setq end (point)) - (setq end begin) - (setq begin (point))) - (cond ((or (eq moving-unit 'match) (eq moving-unit 'find)) - (setq end (1+ end))) - ((eq moving-unit 'line) - (goto-char begin) (beginning-of-line) (setq begin (point)) - (goto-char end) (forward-line 1) (beginning-of-line) (setq end (point)))) - (if (> end (point-max)) (setq end (point-max))) ; force in buffer region - (cons begin end))))) - -(defun vi-delete-op (motion-command arg) - "Delete range specified by MOTION-COMMAND with ARG." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range)) reg) - (if (= begin end) - nil ; point not moved, abort op - (setq reg (vi-prefix-char-value arg)) - (if (null reg) - (kill-region begin end) ; kill ring as unnamed registers - (if (and (>= reg ?A) (<= reg ?Z)) - (append-to-register (downcase reg) begin end t) - (copy-to-register reg begin end t))) - t))) - -(defun vi-yank-op (motion-command arg) - "Yank (in vi sense) range specified by MOTION-COMMAND with ARG." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range)) reg) - (if (= begin end) - nil ; point not moved, abort op - (setq reg (vi-prefix-char-value arg)) - (if (null reg) - (copy-region-as-kill begin end); kill ring as unnamed registers - (if (and (>= reg ?A) (<= reg ?Z)) - (append-to-register (downcase reg) begin end nil) - (copy-to-register reg begin end nil))) - t))) - -(defun vi-yank-line (arg) - "Yank (in vi sense) lines (= `yy' command)." - (interactive "*P") - (setq arg (cons (1- (vi-prefix-numeric-value arg)) (vi-prefix-char-value arg))) - (if (vi-yank-op 'next-line arg) - (vi-set-last-change-command 'vi-yank-op 'next-line arg))) - -(defun vi-string-end-with-nl-p (string) - "See if STRING ends with a newline char. -Used in checking whether the yanked text should be put back as lines or not." - (= (aref string (1- (length string))) ?\n)) - -(defun vi-put-before (arg &optional after-p) - "Put yanked (in vi sense) text back before/above cursor. -If a numeric prefix value (currently it should be >1) is given, put back -text as lines. If the optional after-p is given, put after/below the cursor." - (interactive "P") - (let ((reg (vi-prefix-char-value arg)) put-text) - (if (and reg (or (< reg ?1) (> reg ?9)) (null (get-register reg))) - (error "Nothing in register %c" reg) - (if (null reg) (setq reg ?1)) ; the default is the last text killed - (setq put-text - (cond - ((and (>= reg ?1) (<= reg ?9)) - (setq this-command 'yank) ; So we may yank-pop !! - (current-kill (- reg ?0 1) 'do-not-rotate)) - ((stringp (get-register reg)) (get-register reg)) - (t (error "Register %c is not containing text string" reg)))) - (if (vi-string-end-with-nl-p put-text) ; put back text as lines - (if after-p - (progn (forward-line 1) (beginning-of-line)) - (beginning-of-line)) - (if after-p (forward-char 1))) - (push-mark) - (insert put-text) - (exchange-point-and-mark) -;; (back-to-indentation) ; this is not allowed if we allow yank-pop - (vi-set-last-change-command 'vi-put-before arg after-p)))) - -(defun vi-put-after (arg) - "Put yanked (in vi sense) text back after/below cursor." - (interactive "P") - (vi-put-before arg t)) - -(defun vi-shell-op (motion-command arg &optional shell-command) - "Perform shell command (as filter). -Performs command on range specified by MOTION-COMMAND -with ARG. If SHELL-COMMAND is not given, ask for one from minibuffer. -If char argument is given, it directs the output to a *temp* buffer." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range))) - (if (= begin end) - nil ; point not moved, abort op - (cond ((null shell-command) - (setq shell-command (read-string "!" nil)) - (setq vi-last-shell-command shell-command))) - (shell-command-on-region begin end shell-command (not (vi-prefix-char-value arg)) - (not (vi-prefix-char-value arg))) - t))) - -(defun vi-shift-op (motion-command arg amount) - "Perform shift command on range specified by MOTION-COMMAND with ARG for -AMOUNT on each line. Negative amount means shift left. -SPECIAL FEATURE: char argument can be used to specify shift amount(1-9)." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range))) - (if (= begin end) - nil ; point not moved, abort op - (if (vi-prefix-char-value arg) - (setq amount (if (> amount 0) - (- (vi-prefix-char-value arg) ?0) - (- ?0 (vi-prefix-char-value arg))))) - (indent-rigidly begin end amount) - t))) - -(defun vi-indent-op (motion-command arg) - "Perform indent command on range specified by MOTION-COMMAND with ARG." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range))) - (if (= begin end) - nil ; point not moved, abort op - (indent-region begin end nil) ; insert TAB as indent command - t))) - -(defun vi-narrow-op (motion-command arg) - "Narrow to region specified by MOTION-COMMAND with ARG." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range))) - (if (= begin end) - nil ; point not moved, abort op - (narrow-to-region begin end)))) - -(defun vi-get-mark (char) - "Return contents of vi mark register named CHAR, or nil if undefined." - (cdr (assq char vi-mark-alist))) - -(defun vi-set-mark (char) - "Set contents of vi mark register named CHAR to current point. -'@' is the special anonymous mark register." - (interactive "c") - (if (char-equal char ?@) - (set-mark-command nil) - (let ((aelt (assq char vi-mark-alist))) - (if aelt - (move-marker (cdr aelt) (point)) ; fixed 6/12/86 - (setq aelt (cons char (point-marker))) - (setq vi-mark-alist (cons aelt vi-mark-alist)))))) - -(defun vi-find-matching-paren () - "Locate the matching paren. It's a hack right now." - (interactive) - (cond ((looking-at "[[({]") (forward-sexp 1) (backward-char 1)) - ((looking-at "[])}]") (forward-char 1) (backward-sexp 1)) - (t (ding)))) - -(defun vi-backward-blank-delimited-word (count) - "Backward COUNT blank-delimited words." - (interactive "p") - (if (re-search-backward "[ \t\n`][^ \t\n`]+" nil t count) - (if (not (bobp)) (forward-char 1)))) - -(defun vi-forward-blank-delimited-word (count) - "Forward COUNT blank-delimited words." - (interactive "p") - (if (re-search-forward "[^ \t\n]*[ \t\n]+[^ \t\n]" nil t count) - (if (not (eobp)) (backward-char 1)))) - -(defun vi-end-of-blank-delimited-word (count) - "Forward to the end of the COUNT'th blank-delimited word." - (interactive "p") - (if (re-search-forward "[^ \t\n']+[ \t\n']" nil t count) - (if (not (eobp)) (backward-char 2)))) - -(defun vi-home-window-line (arg) - "To window home or arg'th line from the top of the window." - (interactive "p") - (move-to-window-line (1- arg)) - (back-to-indentation)) - -(defun vi-last-window-line (arg) - "To window last line or arg'th line from the bottom of the window." - (interactive "p") - (move-to-window-line (- arg)) - (back-to-indentation)) - -(defun vi-middle-window-line () - "To the middle line of the window." - (interactive) - (move-to-window-line nil) - (back-to-indentation)) - -(defun vi-forward-word (count) - "Stop at the beginning of the COUNT'th words from point." - (interactive "p") - (if (re-search-forward "\\w*\\W+\\<" nil t count) - t - (vi-ding))) - -(defun vi-set-last-change-command (fun &rest args) - "Set (FUN . ARGS) as the `last-change-command'." - (setq vi-last-change-command (cons fun args))) - -(defun vi-redo-last-change-command (count &optional command) - "Redo last change command COUNT times. If the optional COMMAND is given, -it is used instead of the current `last-change-command'." - (interactive "p") - (if (null command) - (setq command vi-last-change-command)) - (if (null command) - (message "No last change command available.") - (while (> count 0) - (apply (car command) (cdr command)) - (setq count (1- count))))) - -(defun vi-kill-char (count) - "Kill COUNT chars from current point." - (interactive "*p") - (delete-char count t) ; save in kill ring - (vi-set-last-change-command 'delete-char count t)) - -(defun vi-transpose-objects (arg unit) - "Transpose objects. -The following char specifies unit of objects to be -transposed -- \"c\" for chars, \"l\" for lines, \"w\" for words, \"s\" for - sexp, \"p\" for paragraph. -For the use of the prefix-arg, refer to individual functions called." - (interactive "*P\nc") - (if (char-equal unit ??) - (progn - (message "Transpose: c(har), l(ine), p(aragraph), s(-exp), w(ord),") - (setq unit (read-char)))) - (vi-set-last-change-command 'vi-transpose-objects arg unit) - (cond ((char-equal unit ?c) (transpose-chars arg)) - ((char-equal unit ?l) (transpose-lines (vi-prefix-numeric-value arg))) - ((char-equal unit ?p) (transpose-paragraphs (vi-prefix-numeric-value arg))) - ((char-equal unit ?s) (transpose-sexps (vi-prefix-numeric-value arg))) - ((char-equal unit ?w) (transpose-words (vi-prefix-numeric-value arg))) - (t (vi-transpose-objects arg ??)))) - -(defun vi-query-replace (arg) - "Query replace, use regexp version if ARG is non-nil." - (interactive "*P") - (let ((rcmd (if arg 'query-replace-regexp 'query-replace))) - (call-interactively rcmd nil))) - -(defun vi-replace (arg) - "Replace strings, use regexp version if ARG is non-nil." - (interactive "*P") - (let ((rcmd (if arg 'replace-regexp 'replace-string))) - (call-interactively rcmd nil))) - -(defun vi-adjust-window (arg position) - "Move current line to the top/center/bottom of the window." - (interactive "p\nc") - (cond ((char-equal position ?\r) (recenter 0)) - ((char-equal position ?-) (recenter -1)) - ((char-equal position ?.) (recenter (/ (window-height) 2))) - (t (message "Move current line to: \\r(top) -(bottom) .(middle)") - (setq position (read-char)) - (vi-adjust-window arg position)))) - -(defun vi-goto-column (col) - "Go to given column of the current line." - (interactive "p") - (let ((opoint (point))) - (beginning-of-line) - (while (> col 1) - (if (eolp) - (setq col 0) - (forward-char 1) - (setq col (1- col)))) - (if (= col 1) - t - (goto-char opoint) - (ding)))) - -(defun vi-name-last-change-or-macro (arg char) - "Give name to the last change command or just defined kbd macro. -If prefix ARG is given, name last macro, otherwise name last change command. -The following CHAR will be the name for the command or macro." - (interactive "P\nc") - (if arg - (name-last-kbd-macro (intern (char-to-string char))) - (if (eq (car vi-last-change-command) 'vi-first-redo-insertion) - (let* ((args (cdr vi-last-change-command)) ; save the insertion text - (str (buffer-substring (nth 0 args) (nth 1 args))) - (overwrite-p (nth 2 args)) - (prefix-code (nth 3 args))) - (vi-set-last-change-command 'vi-more-redo-insertion str - overwrite-p prefix-code))) - (fset (intern (char-to-string char)) vi-last-change-command))) - -(defun vi-call-named-change-or-macro (count char) - "Execute COUNT times the keyboard macro definition named by the following CHAR." - (interactive "p\nc") - (if (stringp (symbol-function (intern (char-to-string char)))) - (execute-kbd-macro (intern (char-to-string char)) count) - (vi-redo-last-change-command count (symbol-function (intern (char-to-string char)))))) - -(defun vi-change-case (arg) ; could be made as an operator ? - "Change the case of the char after point." - (interactive "*p") - (catch 'exit - (if (looking-at "[a-z]") - (upcase-region (point) (+ (point) arg)) - (if (looking-at "[A-Z]") - (downcase-region (point) (+ (point) arg)) - (ding) - (throw 'exit nil))) - (vi-set-last-change-command 'vi-change-case arg) ;should avoid redundant save - (forward-char arg))) - -(defun vi-ask-for-info (char) - "Inquire status info. The next CHAR will specify the particular info requested." - (interactive "c") - (cond ((char-equal char ?l) (what-line)) - ((char-equal char ?c) (what-cursor-position)) - ((char-equal char ?p) (what-page)) - (t (message "Ask for: l(ine number), c(ursor position), p(age number)") - (setq char (read-char)) - (vi-ask-for-info char)))) - -(declare-function c-mark-function "cc-cmds" ()) - -(defun vi-mark-region (arg region) - "Mark region appropriately. The next char REGION is d(efun),s(-exp),b(uffer), -p(aragraph), P(age), f(unction in C/Pascal etc.), w(ord), e(nd of sentence), -l(ines)." - (interactive "p\nc") - (cond ((char-equal region ?d) (mark-defun)) - ((char-equal region ?s) (mark-sexp arg)) - ((char-equal region ?b) (with-no-warnings (mark-whole-buffer))) - ((char-equal region ?p) (mark-paragraph)) - ((char-equal region ?P) (mark-page arg)) - ((char-equal region ?f) (c-mark-function)) - ((char-equal region ?w) (mark-word arg)) - ((char-equal region ?e) (mark-end-of-sentence arg)) - ((char-equal region ?l) (vi-mark-lines arg)) - (t (message "Mark: d(efun),s(-exp),b(uf),p(arag),P(age),f(unct),w(ord),e(os),l(ines)") - (setq region (read-char)) - (vi-mark-region arg region)))) - -(defun vi-mark-lines (num) - "Mark NUM of lines from current line as current region." - (beginning-of-line 1) - (push-mark) - (end-of-line num)) - -(defun vi-verify-spelling (arg unit) - "Verify spelling for the objects specified by char UNIT : [b(uffer), -r(egion), s(tring), w(ord) ]." - (interactive "P\nc") - (setq prefix-arg arg) ; seems not needed - (cond ((char-equal unit ?b) (call-interactively 'spell-buffer)) - ((char-equal unit ?r) (call-interactively 'spell-region)) - ((char-equal unit ?s) (call-interactively 'spell-string)) - ((char-equal unit ?w) (call-interactively 'spell-word)) - (t (message "Spell check: b(uffer), r(egion), s(tring), w(ord)") - (setq unit (read-char)) - (vi-verify-spelling arg unit)))) - -(defun vi-do-old-mode-C-c-command (arg) - "This is a hack for accessing mode specific C-c commands in vi-mode." - (interactive "P") - (let ((cmd (lookup-key vi-mode-old-local-map - (concat "\C-c" (char-to-string (read-char)))))) - (if (catch 'exit-vi-mode ; kludge hack due to dynamic binding - ; of case-fold-search - (if (null cmd) - (progn (ding) nil) - (let ((case-fold-search vi-mode-old-case-fold)) ; a hack - (setq prefix-arg arg) - (command-execute cmd nil) - nil))) - (progn - (vi-back-to-old-mode) - (setq prefix-arg arg) - (command-execute cmd nil))))) - -(defun vi-quote-words (arg char) - "Quote ARG words from the word point is on with pattern specified by CHAR. -Currently, CHAR could be [,{,(,\",',`,<,*, etc." - (interactive "*p\nc") - (while (not (string-match "[[({<\"'`*]" (char-to-string char))) - (message "Enter any of [,{,(,<,\",',`,* as quoting character.") - (setq char (read-char))) - (vi-set-last-change-command 'vi-quote-words arg char) - (if (not (looking-at "\\<")) (forward-word -1)) - (insert char) - (cond ((char-equal char ?\[) (setq char ?\])) - ((char-equal char ?{) (setq char ?})) - ((char-equal char ?<) (setq char ?>)) - ((char-equal char ?\() (setq char ?\))) - ((char-equal char ?`) (setq char ?'))) - (vi-end-of-word arg) - (forward-char 1) - (insert char)) - -(defun vi-locate-def () - "Locate definition in current file for the name before the point. -It assumes a `(def..' always starts at the beginning of a line." - (interactive) - (let (name) - (save-excursion - (setq name (buffer-substring (progn (vi-backward-blank-delimited-word 1) - (skip-chars-forward "^a-zA-Z") - (point)) - (progn (vi-end-of-blank-delimited-word 1) - (forward-char) - (skip-chars-backward "^a-zA-Z") - (point))))) - (set-mark-command nil) - (goto-char (point-min)) - (if (re-search-forward (concat "^(def[unvarconst ]*" name) nil t) - nil - (ding) - (message "No definition for \"%s\" in current file." name) - (set-mark-command t)))) - -(defun vi-split-open-line (arg) - "Insert a newline and leave point before it. -With ARG, inserts that many newlines." - (interactive "*p") - (vi-goto-insert-state 1 - (list (function (lambda (arg) - (let ((flag (and (bolp) (not (bobp))))) - (if flag (forward-char -1)) - (while (> arg 0) - (save-excursion - (insert ?\n) - (if fill-prefix (insert fill-prefix))) - (setq arg (1- arg))) - (if flag (forward-char 1))))) arg) - t)) - -(provide 'vi) - -;;; vi.el ends here diff --git a/lisp/obsolete/vip.el b/lisp/obsolete/vip.el deleted file mode 100644 index eecedbd5e74..00000000000 --- a/lisp/obsolete/vip.el +++ /dev/null @@ -1,3050 +0,0 @@ -;;; vip.el --- a VI Package for GNU Emacs -*- lexical-binding: t; -*- - -;; Copyright (C) 1986-1988, 1992-1993, 1998, 2001-2024 Free Software -;; Foundation, Inc. - -;; Author: Masahiko Sato -;; Keywords: emulations -;; Obsolete-since: 24.5 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; This file is obsolete. Consider using viper instead. - -;; A full-featured vi(1) emulator. -;; -;; In Japan, the author's address is: masahiko@sato.riec.tohoku.junet -;; -;; Send suggestions and bug reports to one of the above addresses. -;; When you report a bug, be sure to include the version number of VIP and -;; Emacs you are using. - -;; Execute info command by typing "M-x info" to get information on VIP. - -;;; Code: - -(defgroup vip nil - "A VI Package for GNU Emacs." - :prefix "vip-" - :group 'emulations) - -;; external variables - -(defvar vip-emacs-local-map nil - "Local map used in Emacs mode. (Buffer-specific.)") - -(defvar vip-insert-local-map nil - "Local map used in insert command mode. (Buffer-specific.)") - -(make-variable-buffer-local 'vip-emacs-local-map) -(make-variable-buffer-local 'vip-insert-local-map) - -(defvar vip-insert-point nil - "Remember insert point as a marker. (Buffer-specific.)") - -(set-default 'vip-insert-point (make-marker)) -(make-variable-buffer-local 'vip-insert-point) - -(defvar vip-com-point nil - "Remember com point as a marker. (Buffer-specific.)") - -(set-default 'vip-com-point (make-marker)) -(make-variable-buffer-local 'vip-com-point) - -(defvar vip-current-mode nil - "Current mode. One of `emacs-mode', `vi-mode', `insert-mode'.") - -(make-variable-buffer-local 'vip-current-mode) -(setq-default vip-current-mode 'emacs-mode) - -(defvar vip-emacs-mode-line-buffer-identification nil - "Value of mode-line-buffer-identification in Emacs mode within vip.") -(make-variable-buffer-local 'vip-emacs-mode-line-buffer-identification) -(setq-default vip-emacs-mode-line-buffer-identification - '("Emacs: %17b")) - -(defvar vip-current-major-mode nil - "vip-current-major-mode is the major-mode vi considers it is now. -\(buffer specific)") - -(make-variable-buffer-local 'vip-current-major-mode) - -(defvar vip-last-shell-com nil - "Last shell command executed by ! command.") - -(defvar vip-use-register nil - "Name of register to store deleted or yanked strings.") - -(defvar vip-d-com nil - "How to reexecute last destructive command. Value is list (M-COM VAL COM).") - -(defcustom vip-shift-width 8 - "The number of columns shifted by > and < command." - :type 'integer) - -(defcustom vip-re-replace nil - "If t then do regexp replace, if nil then do string replace." - :type 'boolean) - -(defvar vip-d-char nil - "The character remembered by the vi \"r\" command.") - -(defvar vip-f-char nil - "For use by \";\" command.") - -(defvar vip-F-char nil - "For use by \".\" command.") - -(defvar vip-f-forward nil - "For use by \";\" command.") - -(defvar vip-f-offset nil - "For use by \";\" command.") - -(defcustom vip-search-wrap-around t - "If t, search wraps around." - :type 'boolean) - -(defcustom vip-re-search nil - "If t, search is reg-exp search, otherwise vanilla search." - :type 'boolean) - -(defvar vip-s-string nil - "Last vip search string.") - -(defvar vip-s-forward nil - "If t, search is forward.") - -(defcustom vip-case-fold-search nil - "If t, search ignores cases." - :type 'boolean) - -(defcustom vip-re-query-replace nil - "If t then do regexp replace, if nil then do string replace." - :type 'boolean) - -(defcustom vip-open-with-indent nil - "If t, indent when open a new line." - :type 'boolean) - -(defcustom vip-help-in-insert-mode nil - "If t then C-h is bound to help-command in insert mode. -If nil then it is bound to `delete-backward-char'." - :type 'boolean) - -(defvar vip-quote-string "> " - "String inserted at the beginning of region.") - -(defvar vip-tags-file-name "TAGS") - -(defvar vip-inhibit-startup-message nil) - -(defvar vip-startup-file (locate-user-emacs-file "vip" ".vip") - "Filename used as startup file for vip.") - -;; key bindings - -(defvar vip-mode-map - (let ((map (make-keymap))) - (define-key map "\C-a" #'beginning-of-line) - (define-key map "\C-b" #'vip-scroll-back) - (define-key map "\C-c" #'vip-ctl-c) - (define-key map "\C-d" #'vip-scroll-up) - (define-key map "\C-e" #'vip-scroll-up-one) - (define-key map "\C-f" #'vip-scroll) - (define-key map "\C-g" #'vip-keyboard-quit) - (define-key map "\C-h" #'help-command) - (define-key map "\C-m" #'vip-scroll-back) - (define-key map "\C-n" #'vip-other-window) - (define-key map "\C-o" #'vip-open-line-at-point) - (define-key map "\C-u" #'vip-scroll-down) - (define-key map "\C-x" #'vip-ctl-x) - (define-key map "\C-y" #'vip-scroll-down-one) - (define-key map "\C-z" #'vip-change-mode-to-emacs) - (define-key map "\e" #'vip-ESC) - - (define-key map [?\S-\ ] #'vip-scroll-back) - (define-key map " " #'vip-scroll) - (define-key map "!" #'vip-command-argument) - (define-key map "\"" #'vip-command-argument) - (define-key map "#" #'vip-command-argument) - (define-key map "$" #'vip-goto-eol) - (define-key map "%" #'vip-paren-match) - (define-key map "&" #'vip-nil) - (define-key map "'" #'vip-goto-mark-and-skip-white) - (define-key map "(" #'vip-backward-sentence) - (define-key map ")" #'vip-forward-sentence) - (define-key map "*" #'call-last-kbd-macro) - (define-key map "+" #'vip-next-line-at-bol) - (define-key map "," #'vip-repeat-find-opposite) - (define-key map "-" #'vip-previous-line-at-bol) - (define-key map "." #'vip-repeat) - (define-key map "/" #'vip-search-forward) - - (define-key map "0" #'vip-beginning-of-line) - (define-key map "1" #'vip-digit-argument) - (define-key map "2" #'vip-digit-argument) - (define-key map "3" #'vip-digit-argument) - (define-key map "4" #'vip-digit-argument) - (define-key map "5" #'vip-digit-argument) - (define-key map "6" #'vip-digit-argument) - (define-key map "7" #'vip-digit-argument) - (define-key map "8" #'vip-digit-argument) - (define-key map "9" #'vip-digit-argument) - - (define-key map ":" #'vip-ex) - (define-key map ";" #'vip-repeat-find) - (define-key map "<" #'vip-command-argument) - (define-key map "=" #'vip-command-argument) - (define-key map ">" #'vip-command-argument) - (define-key map "?" #'vip-search-backward) - (define-key map "@" #'vip-nil) - - (define-key map "A" #'vip-Append) - (define-key map "B" #'vip-backward-Word) - (define-key map "C" #'vip-ctl-c-equivalent) - (define-key map "D" #'vip-kill-line) - (define-key map "E" #'vip-end-of-Word) - (define-key map "F" #'vip-find-char-backward) - (define-key map "G" #'vip-goto-line) - (define-key map "H" #'vip-window-top) - (define-key map "I" #'vip-Insert) - (define-key map "J" #'vip-join-lines) - (define-key map "K" #'vip-kill-buffer) - (define-key map "L" #'vip-window-bottom) - (define-key map "M" #'vip-window-middle) - (define-key map "N" #'vip-search-Next) - (define-key map "O" #'vip-Open-line) - (define-key map "P" #'vip-Put-back) - (define-key map "Q" #'vip-query-replace) - (define-key map "R" #'vip-replace-string) - (define-key map "S" #'vip-switch-to-buffer-other-window) - (define-key map "T" #'vip-goto-char-backward) - (define-key map "U" #'vip-nil) - (define-key map "V" #'vip-find-file-other-window) - (define-key map "W" #'vip-forward-Word) - (define-key map "X" #'vip-ctl-x-equivalent) - (define-key map "Y" #'vip-yank-line) - (define-key map "ZZ" #'save-buffers-kill-emacs) - - (define-key map "[" #'vip-nil) - (define-key map "\\" #'vip-escape-to-emacs) - (define-key map "]" #'vip-nil) - (define-key map "^" #'vip-bol-and-skip-white) - (define-key map "_" #'vip-nil) - (define-key map "`" #'vip-goto-mark) - - (define-key map "a" #'vip-append) - (define-key map "b" #'vip-backward-word) - (define-key map "c" #'vip-command-argument) - (define-key map "d" #'vip-command-argument) - (define-key map "e" #'vip-end-of-word) - (define-key map "f" #'vip-find-char-forward) - (define-key map "g" #'vip-info-on-file) - (define-key map "h" #'vip-backward-char) - (define-key map "i" #'vip-insert) - (define-key map "j" #'vip-next-line) - (define-key map "k" #'vip-previous-line) - (define-key map "l" #'vip-forward-char) - (define-key map "m" #'vip-mark-point) - (define-key map "n" #'vip-search-next) - (define-key map "o" #'vip-open-line) - (define-key map "p" #'vip-put-back) - (define-key map "q" #'vip-nil) - (define-key map "r" #'vip-replace-char) - (define-key map "s" #'vip-switch-to-buffer) - (define-key map "t" #'vip-goto-char-forward) - (define-key map "u" #'vip-undo) - (define-key map "v" #'vip-find-file) - (define-key map "w" #'vip-forward-word) - (define-key map "x" #'vip-delete-char) - (define-key map "y" #'vip-command-argument) - (define-key map "zH" #'vip-line-to-top) - (define-key map "zM" #'vip-line-to-middle) - (define-key map "zL" #'vip-line-to-bottom) - (define-key map "z\C-m" #'vip-line-to-top) - (define-key map "z." #'vip-line-to-middle) - (define-key map "z-" #'vip-line-to-bottom) - - (define-key map "{" #'vip-backward-paragraph) - (define-key map "|" #'vip-goto-col) - (define-key map "}" #'vip-forward-paragraph) - (define-key map "~" #'vip-nil) - (define-key map "\177" #'vip-delete-backward-char) - map)) - -(defun vip-version () - (interactive) - (message "VIP version 3.5 of September 15, 1987")) - - -;; basic set up - -;;;###autoload -(defun vip-setup () - "Set up bindings for C-x 7 and C-z that are useful for VIP users." - (define-key ctl-x-map "7" #'vip-buffer-in-two-windows) - (global-set-key "\C-z" #'vip-change-mode-to-vi)) - -(defmacro vip-loop (count body) - "(COUNT BODY) Execute BODY COUNT times." - `(let ((count ,count)) - (while (> count 0) - ,body - (setq count (1- count))))) - -(defun vip-push-mark-silent (&optional location) - "Set mark at LOCATION (point, by default) and push old mark on mark ring. -No message." - (if (null (mark t)) - nil - (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring)) - (if (> (length mark-ring) mark-ring-max) - (progn - (move-marker (car (nthcdr mark-ring-max mark-ring)) nil) - (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil)))) - (set-mark (or location (point)))) - -(defun vip-goto-col (arg) - "Go to ARG's column." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (save-excursion - (end-of-line) - (if (> val (1+ (current-column))) (error ""))) - (if com (move-marker vip-com-point (point))) - (beginning-of-line) - (forward-char (1- val)) - (if com (vip-execute-com 'vip-goto-col val com)))) - -(defun vip-copy-keymap (map) - (if (null map) (make-sparse-keymap) (copy-keymap map))) - - -;; changing mode - -(defun vip-change-mode (new-mode) - "Change mode to NEW-MODE---either emacs-mode, vi-mode, or insert-mode." - (or (eq new-mode vip-current-mode) - (progn - (cond ((eq new-mode 'vi-mode) - (if (eq vip-current-mode 'insert-mode) - (progn - (vip-copy-region-as-kill (point) vip-insert-point) - (vip-repeat-insert-command)) - (setq vip-emacs-local-map (current-local-map) - vip-emacs-mode-line-buffer-identification - mode-line-buffer-identification - vip-insert-local-map (vip-copy-keymap - (current-local-map)))) - (vip-change-mode-line "Vi: ") - (use-local-map vip-mode-map)) - ((eq new-mode 'insert-mode) - (move-marker vip-insert-point (point)) - (if (eq vip-current-mode 'emacs-mode) - (setq vip-emacs-local-map (current-local-map) - vip-emacs-mode-line-buffer-identification - mode-line-buffer-identification - vip-insert-local-map (vip-copy-keymap - (current-local-map))) - (setq vip-insert-local-map (vip-copy-keymap - vip-emacs-local-map))) - (vip-change-mode-line "Insert") - (use-local-map vip-insert-local-map) - (define-key vip-insert-local-map "\e" #'vip-change-mode-to-vi) - (define-key vip-insert-local-map "\C-z" #'vip-ESC) - (define-key vip-insert-local-map "\C-h" - (if vip-help-in-insert-mode #'help-command - #'delete-backward-char)) - (define-key vip-insert-local-map "\C-w" - #'vip-delete-backward-word)) - ((eq new-mode 'emacs-mode) - (vip-change-mode-line "Emacs:") - (use-local-map vip-emacs-local-map))) - (setq vip-current-mode new-mode) - (force-mode-line-update)))) - -(defun vip-copy-region-as-kill (beg end) - "If BEG and END do not belong to the same buffer, it copies empty region." - (condition-case nil - (copy-region-as-kill beg end) - (error (copy-region-as-kill beg beg)))) - -(defun vip-change-mode-line (string) - "Assuming that the mode line format contains the string \"Emacs:\", this -function replaces the string by \"Vi: \" etc." - (setq mode-line-buffer-identification - (if (string= string "Emacs:") - vip-emacs-mode-line-buffer-identification - (list (concat string " %17b"))))) - -;;;###autoload -(defun vip-mode () - "Turn on VIP emulation of VI." - (interactive) - (if (not vip-inhibit-startup-message) - (progn - (switch-to-buffer "VIP Startup Message") - (erase-buffer) - (insert - "VIP is a Vi emulation package for GNU Emacs. VIP provides most Vi commands -including Ex commands. VIP is however different from Vi in several points. -You can get more information on VIP by: - 1. Typing `M-x info' and selecting menu item \"vip\". - 2. Typing `C-h k' followed by a key whose description you want. - 3. Printing VIP manual which can be found as GNU/man/vip.texinfo - 4. Printing VIP Reference Card which can be found as GNU/etc/vipcard.tex - -This startup message appears whenever you load VIP unless you type `y' now. -Type `n' to quit this window for now.\n") - (goto-char (point-min)) - (if (y-or-n-p "Inhibit VIP startup message? ") - (progn - (with-current-buffer - (find-file-noselect - (substitute-in-file-name vip-startup-file)) - (goto-char (point-max)) - (insert "\n(setq vip-inhibit-startup-message t)\n") - (save-buffer) - (kill-buffer (current-buffer))) - (message "VIP startup message inhibited.") - (sit-for 2))) - (kill-buffer (current-buffer)) - (message "") - (setq vip-inhibit-startup-message t))) - (vip-change-mode-to-vi)) - -(defun vip-change-mode-to-vi () - "Change mode to vi mode." - (interactive) - (vip-change-mode 'vi-mode)) - -(defun vip-change-mode-to-insert () - "Change mode to insert mode." - (interactive) - (vip-change-mode 'insert-mode)) - -(defun vip-change-mode-to-emacs () - "Change mode to Emacs mode." - (interactive) - (vip-change-mode 'emacs-mode)) - - -;; escape to emacs mode temporarily - -(defun vip-escape-to-emacs (arg &optional events) - "Escape to Emacs mode for one Emacs command. -ARG is used as the prefix value for the executed command. If -EVENTS is a list of events, which become the beginning of the command." - (interactive "P") - (let (com (old-map (current-local-map))) - (if events (setq unread-command-events - (append events unread-command-events))) - (setq prefix-arg arg) - (use-local-map vip-emacs-local-map) - (unwind-protect - (setq com (key-binding (read-key-sequence nil))) - (use-local-map old-map)) - (command-execute com prefix-arg) - (setq prefix-arg nil) ;; reset prefix arg - )) - -(defun vip-message-conditions (conditions) - "Print CONDITIONS as a message." - (let ((case (car conditions)) (msg (cdr conditions))) - (if (null msg) - (message "%s" case) - (message "%s %s" case (prin1-to-string msg))) - (ding))) - -(defun vip-ESC (arg) - "Emulate ESC key in Emacs mode." - (interactive "P") - (vip-escape-to-emacs arg '(?\e))) - -(defun vip-ctl-c (arg) - "Emulate C-c key in Emacs mode." - (interactive "P") - (vip-escape-to-emacs arg '(?\C-c))) - -(defun vip-ctl-x (arg) - "Emulate C-x key in Emacs mode." - (interactive "P") - (vip-escape-to-emacs arg '(?\C-x))) - -(defun vip-ctl-h (arg) - "Emulate C-h key in Emacs mode." - (interactive "P") - (vip-escape-to-emacs arg '(?\C-h))) - - -;; prefix argument for vi mode - -;; In vi mode, prefix argument is a dotted pair (NUM . COM) where NUM -;; represents the numeric value of the prefix argument and COM represents -;; command prefix such as "c", "d", "m" and "y". - -(defun vip-prefix-arg-value (char value com) - "Compute numeric prefix arg value. Invoked by CHAR. VALUE is the value -obtained so far, and COM is the command part obtained so far." - (while (and (>= char ?0) (<= char ?9)) - (setq value (+ (* (if (numberp value) value 0) 10) (- char ?0))) - (setq char (read-char))) - (setq prefix-arg value) - (if com (setq prefix-arg (cons prefix-arg com))) - (while (= char ?U) - (vip-describe-arg prefix-arg) - (setq char (read-char))) - (push char unread-command-events)) - -(defun vip-prefix-arg-com (char value com) - "Vi operator as prefix argument." - (let ((cont t)) - (while (and cont - (or (= char ?c) (= char ?d) (= char ?y) - (= char ?!) (= char ?<) (= char ?>) (= char ?=) - (= char ?#) (= char ?r) (= char ?R) (= char ?\"))) - (if com - ;; this means that we already have a command character, so we - ;; construct a com list and exit while. however, if char is " - ;; it is an error. - (progn - ;; new com is (CHAR . OLDCOM) - (if (or (= char ?#) (= char ?\")) (error "")) - (setq com (cons char com)) - (setq cont nil)) - ;; if com is nil we set com as char, and read more. again, if char - ;; is ", we read the name of register and store it in vip-use-register. - ;; if char is !, =, or #, a complete com is formed so we exit while. - (cond ((or (= char ?!) (= char ?=)) - (setq com char) - (setq char (read-char)) - (setq cont nil)) - ((= char ?#) - ;; read a char and encode it as com - (setq com (+ 128 (read-char))) - (setq char (read-char)) - (setq cont nil)) - ((or (= char ?<) (= char ?>)) - (setq com char) - (setq char (read-char)) - (if (= com char) (setq com (cons char com))) - (setq cont nil)) - ((= char ?\") - (let ((reg (read-char))) - (if (or (and (<= ?A reg) (<= reg ?z)) - (and (<= ?1 reg) (<= reg ?9))) - (setq vip-use-register reg) - (error "")) - (setq char (read-char)))) - (t - (setq com char) - (setq char (read-char))))))) - (if (atom com) - ;; com is a single char, so we construct prefix-arg - ;; and if char is ?, describe prefix arg, otherwise exit by - ;; pushing the char back - (progn - (setq prefix-arg (cons value com)) - (while (= char ?U) - (vip-describe-arg prefix-arg) - (setq char (read-char))) - (push char unread-command-events)) - ;; as com is non-nil, this means that we have a command to execute - (if (or (= (car com) ?r) (= (car com) ?R)) - ;; execute appropriate region command. - (let ((char (car com)) (com (cdr com))) - (setq prefix-arg (cons value com)) - (if (= char ?r) (vip-region prefix-arg) - (vip-Region prefix-arg)) - ;; reset prefix-arg - (setq prefix-arg nil)) - ;; otherwise, reset prefix arg and call appropriate command - (setq value (if (null value) 1 value)) - (setq prefix-arg nil) - (cond ((equal com '(?c . ?c)) (vip-line (cons value ?C))) - ((equal com '(?d . ?d)) (vip-line (cons value ?D))) - ((equal com '(?d . ?y)) (vip-yank-defun)) - ((equal com '(?y . ?y)) (vip-line (cons value ?Y))) - ((equal com '(?< . ?<)) (vip-line (cons value ?<))) - ((equal com '(?> . ?>)) (vip-line (cons value ?>))) - ((equal com '(?! . ?!)) (vip-line (cons value ?!))) - ((equal com '(?= . ?=)) (vip-line (cons value ?=))) - (t (error "")))))) - -(defun vip-describe-arg (arg) - (let (val com) - (setq val (vip-P-val arg) - com (vip-getcom arg)) - (if (null val) - (if (null com) - (message "Value is nil, and command is nil.") - (message "Value is nil, and command is %c." com)) - (if (null com) - (message "Value is %d, and command is nil." val) - (message "Value is %d, and command is %c." val com))))) - -(defun vip-digit-argument (arg) - "Begin numeric argument for the next command." - (interactive "P") - (vip-prefix-arg-value last-command-event nil - (if (consp arg) (cdr arg) nil))) - -(defun vip-command-argument (arg) - "Accept a motion command as an argument." - (interactive "P") - (condition-case nil - (vip-prefix-arg-com - last-command-event - (cond ((null arg) nil) - ((consp arg) (car arg)) - ((numberp arg) arg) - (t (error "Strange arg"))) - (cond ((null arg) nil) - ((consp arg) (cdr arg)) - ((numberp arg) nil) - (t (error "Strange arg")))) - (quit - (setq vip-use-register nil) - (signal 'quit nil)))) - -(defun vip-p-val (arg) - "Get value part of prefix-argument ARG." - (cond ((null arg) 1) - ((consp arg) (if (null (car arg)) 1 (car arg))) - (t arg))) - -(defun vip-P-val (arg) - "Get value part of prefix-argument ARG." - (cond ((consp arg) (car arg)) - (t arg))) - -(defun vip-getcom (arg) - "Get com part of prefix-argument ARG." - (cond ((null arg) nil) - ((consp arg) (cdr arg)) - (t nil))) - -(defun vip-getCom (arg) - "Get com part of prefix-argument ARG and modify it." - (let ((com (vip-getcom arg))) - (cond ((equal com ?c) ?C) - ((equal com ?d) ?D) - ((equal com ?y) ?Y) - (t com)))) - - -;; repeat last destructive command - -(defun vip-append-to-register (reg start end) - "Append region to text in register REG. -START and END are buffer positions indicating what to append." - (set-register reg (concat (or (get-register reg) "") - (buffer-substring start end)))) - -(defun vip-execute-com (m-com val com) - "(M-COM VAL COM) Execute command COM. The list (M-COM VAL COM) is set -to vip-d-com for later use by vip-repeat" - (let ((reg vip-use-register)) - (if com - (cond ((= com ?c) (vip-change vip-com-point (point))) - ((= com (- ?c)) (vip-change-subr vip-com-point (point))) - ((or (= com ?C) (= com (- ?C))) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register (mark) (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (mark) (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (delete-region (mark) (point))) - (open-line 1) - (if (= com ?C) (vip-change-mode-to-insert) (yank))) - ((= com ?d) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register vip-com-point (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) vip-com-point (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (setq last-command - (if (eq last-command 'd-command) 'kill-region nil)) - (kill-region vip-com-point (point)) - (setq this-command 'd-command)) - ((= com ?D) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register (mark) (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (mark) (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (setq last-command - (if (eq last-command 'D-command) 'kill-region nil)) - (kill-region (mark) (point)) - (if (eq m-com 'vip-line) (setq this-command 'D-command))) - (back-to-indentation)) - ((= com ?y) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register vip-com-point (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) vip-com-point (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (setq last-command nil) - (copy-region-as-kill vip-com-point (point)) - (goto-char vip-com-point)) - ((= com ?Y) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register (mark) (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (mark) (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (setq last-command nil) - (copy-region-as-kill (mark) (point))) - (goto-char vip-com-point)) - ((or (= com ?!) (= com (- ?!))) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (shell-command-on-region - (mark) (point) - (if (= com ?!) - (setq vip-last-shell-com (vip-read-string "!")) - vip-last-shell-com) - t t))) - ((= com ?=) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (if (> (mark) (point)) (exchange-point-and-mark)) - (indent-region (mark) (point) nil))) - ((= com ?<) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (indent-rigidly (mark) (point) (- vip-shift-width))) - (goto-char vip-com-point)) - ((= com ?>) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (indent-rigidly (mark) (point) vip-shift-width)) - (goto-char vip-com-point)) - ((>= com 128) - ;; this is special command # - (vip-special-prefix-com (- com 128))))) - (setq vip-d-com (list m-com val (if (or (= com ?c) (= com ?C) (= com ?!)) - (- com) com) - reg)))) - -(defun vip-repeat (arg) - "(ARG) Re-execute last destructive command. vip-d-com has the form -\(COM ARG CH REG), where COM is the command to be re-executed, ARG is the -argument for COM, CH is a flag for repeat, and REG is optional and if exists -is the name of the register for COM." - (interactive "P") - (if (eq last-command 'vip-undo) - ;; if the last command was vip-undo, then undo-more - (vip-undo-more) - ;; otherwise execute the command stored in vip-d-com. if arg is non-nil - ;; its prefix value is used as new prefix value for the command. - (let ((m-com (car vip-d-com)) - (val (vip-P-val arg)) - (com (car (cdr (cdr vip-d-com)))) - (reg (nth 3 vip-d-com))) - (if (null val) (setq val (car (cdr vip-d-com)))) - (if (null m-com) (error "No previous command to repeat")) - (setq vip-use-register reg) - (funcall m-com (cons val com))))) - -(defun vip-special-prefix-com (char) - "This command is invoked interactively by the key sequence #" - (cond ((= char ?c) - (downcase-region (min vip-com-point (point)) - (max vip-com-point (point)))) - ((= char ?C) - (upcase-region (min vip-com-point (point)) - (max vip-com-point (point)))) - ((= char ?g) - (set-mark vip-com-point) - (vip-global-execute)) - ((= char ?q) - (set-mark vip-com-point) - (vip-quote-region)) - ((= char ?s) (ispell-region vip-com-point (point))))) - - -;; undoing - -(defun vip-undo () - "Undo previous change." - (interactive) - (message "undo!") - (undo-start) - (undo-more 2) - (setq this-command 'vip-undo)) - -(defun vip-undo-more () - "Continue undoing previous changes." - (message "undo more!") - (undo-more 1) - (setq this-command 'vip-undo)) - - -;; utilities - -(defun vip-string-tail (str) - (if (or (null str) (string= str "")) nil - (substring str 1))) - -(defun vip-yank-defun () - (mark-defun) - (copy-region-as-kill (point) (mark))) - -(defun vip-enlarge-region (beg end) - "Enlarge region between BEG and END." - (if (< beg end) - (progn (goto-char beg) (set-mark end)) - (goto-char end) - (set-mark beg)) - (beginning-of-line) - (exchange-point-and-mark) - (if (or (not (eobp)) (not (bolp))) (with-no-warnings (next-line 1))) - (beginning-of-line) - (if (> beg end) (exchange-point-and-mark))) - -(defun vip-global-execute () - "Call last keyboard macro for each line in the region." - (if (> (point) (mark)) (exchange-point-and-mark)) - (beginning-of-line) - (call-last-kbd-macro) - (while (< (point) (mark)) - (forward-line 1) - (beginning-of-line) - (call-last-kbd-macro))) - -(defun vip-quote-region () - "Quote region by inserting the user supplied string at the beginning of -each line in the region." - (setq vip-quote-string - (let ((str - (vip-read-string (format "quote string (default %s): " - vip-quote-string)))) - (if (string= str "") vip-quote-string str))) - (vip-enlarge-region (point) (mark)) - (if (> (point) (mark)) (exchange-point-and-mark)) - (insert vip-quote-string) - (beginning-of-line) - (forward-line 1) - (while (and (< (point) (mark)) (bolp)) - (insert vip-quote-string) - (beginning-of-line) - (forward-line 1))) - -(defun vip-end-with-a-newline-p (string) - "Check if the string ends with a newline." - (or (string= string "") - (= (aref string (1- (length string))) ?\n))) - -(defvar vip-save-minibuffer-local-map) - -(defun vip-read-string (prompt &optional init) - (setq vip-save-minibuffer-local-map (copy-keymap minibuffer-local-map)) - (define-key minibuffer-local-map "\C-h" #'backward-char) - (define-key minibuffer-local-map "\C-w" #'backward-word) - (define-key minibuffer-local-map "\e" #'exit-minibuffer) - (let (str) - (condition-case nil - (setq str (read-string prompt init)) - (quit - (setq minibuffer-local-map vip-save-minibuffer-local-map) - (signal 'quit nil))) - (setq minibuffer-local-map vip-save-minibuffer-local-map) - str)) - - -;; insertion commands - -(defun vip-repeat-insert-command () - "This function is called when mode changes from insertion mode to -vi command mode. It will repeat the insertion command if original insertion -command was invoked with argument > 1." - (let ((i-com (car vip-d-com)) (val (car (cdr vip-d-com)))) - (if (and val (> val 1)) ;; first check that val is non-nil - (progn - (setq vip-d-com (list i-com (1- val) ?r)) - (vip-repeat nil) - (setq vip-d-com (list i-com val ?r)))))) - -(defun vip-insert (arg) "" - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-insert val ?r)) - (if com (vip-loop val (yank)) - (vip-change-mode-to-insert)))) - -(defun vip-append (arg) - "Append after point." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-append val ?r)) - (if (not (eolp)) (forward-char)) - (if (equal com ?r) - (vip-loop val (yank)) - (vip-change-mode-to-insert)))) - -(defun vip-Append (arg) - "Append at end of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-Append val ?r)) - (end-of-line) - (if (equal com ?r) - (vip-loop val (yank)) - (vip-change-mode-to-insert)))) - -(defun vip-Insert (arg) - "Insert before first non-white." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-Insert val ?r)) - (back-to-indentation) - (if (equal com ?r) - (vip-loop val (yank)) - (vip-change-mode-to-insert)))) - -(defun vip-open-line (arg) - "Open line below." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-open-line val ?r)) - (let ((col (current-indentation))) - (if (equal com ?r) - (vip-loop val - (progn - (end-of-line) - (newline 1) - (if vip-open-with-indent (indent-to col)) - (yank))) - (end-of-line) - (newline 1) - (if vip-open-with-indent (indent-to col)) - (vip-change-mode-to-insert))))) - -(defun vip-Open-line (arg) - "Open line above." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-Open-line val ?r)) - (let ((col (current-indentation))) - (if (equal com ?r) - (vip-loop val - (progn - (beginning-of-line) - (open-line 1) - (if vip-open-with-indent (indent-to col)) - (yank))) - (beginning-of-line) - (open-line 1) - (if vip-open-with-indent (indent-to col)) - (vip-change-mode-to-insert))))) - -(defun vip-open-line-at-point (arg) - "Open line at point." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-open-line-at-point val ?r)) - (if (equal com ?r) - (vip-loop val - (progn - (open-line 1) - (yank))) - (open-line 1) - (vip-change-mode-to-insert)))) - -(defun vip-substitute (arg) - "Substitute characters." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (save-excursion - (set-mark (point)) - (forward-char val) - (if (equal com ?r) - (vip-change-subr (mark) (point)) - (vip-change (mark) (point)))) - (setq vip-d-com (list 'vip-substitute val ?r)))) - -(defun vip-substitute-line (arg) - "Substitute lines." - (interactive "p") - (vip-line (cons arg ?C))) - - -;; line command - -(defun vip-line (arg) - (let ((val (car arg)) (com (cdr arg))) - (move-marker vip-com-point (point)) - (with-no-warnings (next-line (1- val))) - (vip-execute-com 'vip-line val com))) - -(defun vip-yank-line (arg) - "Yank ARG lines (in vi's sense)" - (interactive "P") - (let ((val (vip-p-val arg))) - (vip-line (cons val ?Y)))) - - -;; region command - -(defun vip-region (arg) - (interactive "P") - (let ((val (vip-P-val arg)) - (com (vip-getcom arg))) - (move-marker vip-com-point (point)) - (exchange-point-and-mark) - (vip-execute-com 'vip-region val com))) - -(defun vip-Region (arg) - (interactive "P") - (let ((val (vip-P-val arg)) - (com (vip-getCom arg))) - (move-marker vip-com-point (point)) - (exchange-point-and-mark) - (vip-execute-com 'vip-Region val com))) - -(defun vip-replace-char (arg) - "Replace the following ARG chars by the character read." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-replace-char val ?r)) - (vip-replace-char-subr (if (equal com ?r) vip-d-char (read-char)) val))) - -(defun vip-replace-char-subr (char arg) - (delete-char arg t) - (setq vip-d-char char) - (vip-loop (if (> arg 0) arg (- arg)) (insert char)) - (backward-char arg)) - -(defun vip-replace-string () - "Replace string. If you supply null string as the string to be replaced, -the query replace mode will toggle between string replace and regexp replace." - (interactive) - (let (str) - (setq str (vip-read-string - (if vip-re-replace "Replace regexp: " "Replace string: "))) - (if (string= str "") - (progn - (setq vip-re-replace (not vip-re-replace)) - (message "Replace mode changed to %s." - (if vip-re-replace "regexp replace" - "string replace"))) - (if vip-re-replace - ;; (replace-regexp - ;; str - ;; (vip-read-string (format "Replace regexp \"%s\" with: " str))) - (while (re-search-forward str nil t) - (replace-match (vip-read-string - (format "Replace regexp \"%s\" with: " str)) - nil nil)) - (with-no-warnings - (replace-string - str - (vip-read-string (format "Replace \"%s\" with: " str)))))))) - - -;; basic cursor movement. j, k, l, m commands. - -(defun vip-forward-char (arg) - "Move point right ARG characters (left if ARG negative).On reaching end -of buffer, stop and signal error." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-char val) - (if com (vip-execute-com 'vip-forward-char val com)))) - -(defun vip-backward-char (arg) - "Move point left ARG characters (right if ARG negative). On reaching -beginning of buffer, stop and signal error." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (backward-char val) - (if com (vip-execute-com 'vip-backward-char val com)))) - - -;; word command - -(defun vip-forward-word (arg) - "Forward word." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-word val) - (skip-chars-forward " \t\n") - (if com - (progn - (if (or (= com ?c) (= com (- ?c))) - (progn (backward-word 1) (forward-word 1))) - (if (or (= com ?d) (= com ?y)) - (progn - (backward-word 1) - (forward-word 1) - (skip-chars-forward " \t"))) - (vip-execute-com 'vip-forward-word val com))))) - -(defun vip-end-of-word (arg) - "Move point to end of current word." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-char) - (forward-word val) - (backward-char) - (if com - (progn - (forward-char) - (vip-execute-com 'vip-end-of-word val com))))) - -(defun vip-backward-word (arg) - "Backward word." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (backward-word val) - (if com (vip-execute-com 'vip-backward-word val com)))) - -(defun vip-forward-Word (arg) - "Forward word delimited by white character." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (re-search-forward "[^ \t\n]*[ \t\n]+" nil t val) - (if com - (progn - (if (or (= com ?c) (= com (- ?c))) - (progn (backward-word 1) (forward-word 1))) - (if (or (= com ?d) (= com ?y)) - (progn - (backward-word 1) - (forward-word 1) - (skip-chars-forward " \t"))) - (vip-execute-com 'vip-forward-Word val com))))) - -(defun vip-end-of-Word (arg) - "Move forward to end of word delimited by white character." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-char) - (if (re-search-forward "[^ \t\n]+" nil t val) (backward-char)) - (if com - (progn - (forward-char) - (vip-execute-com 'vip-end-of-Word val com))))) - -(defun vip-backward-Word (arg) - "Backward word delimited by white character." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (if (re-search-backward "[ \t\n]+[^ \t\n]+" nil t val) - (forward-char) - (goto-char (point-min))) - (if com (vip-execute-com 'vip-backward-Word val com)))) - -(defun vip-beginning-of-line (arg) - "Go to beginning of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (beginning-of-line val) - (if com (vip-execute-com 'vip-beginning-of-line val com)))) - -(defun vip-bol-and-skip-white (arg) - "Beginning of line at first non-white character." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (back-to-indentation) - (if com (vip-execute-com 'vip-bol-and-skip-white val com)))) - -(defun vip-goto-eol (arg) - "Go to end of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (end-of-line val) - (if com (vip-execute-com 'vip-goto-eol val com)))) - -(defun vip-next-line (arg) - "Go to next line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (line-move val) - (setq this-command 'next-line) - (if com (vip-execute-com 'vip-next-line val com)))) - -(defun vip-next-line-at-bol (arg) - "Next line at beginning of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (with-no-warnings (next-line val)) - (back-to-indentation) - (if com (vip-execute-com 'vip-next-line-at-bol val com)))) - -(defun vip-previous-line (arg) - "Go to previous line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (with-no-warnings (next-line (- val))) - (setq this-command 'previous-line) - (if com (vip-execute-com 'vip-previous-line val com)))) - -(defun vip-previous-line-at-bol (arg) - "Previous line at beginning of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (with-no-warnings (next-line (- val))) - (back-to-indentation) - (if com (vip-execute-com 'vip-previous-line val com)))) - -(defun vip-change-to-eol (arg) - "Change to end of line." - (interactive "P") - (vip-goto-eol (cons arg ?c))) - -(defun vip-kill-line (arg) - "Delete line." - (interactive "P") - (vip-goto-eol (cons arg ?d))) - - -;; moving around - -(defun vip-goto-line (arg) - "Go to ARG's line. Without ARG go to end of buffer." - (interactive "P") - (let ((val (vip-P-val arg)) (com (vip-getCom arg))) - (move-marker vip-com-point (point)) - (set-mark (point)) - (if (null val) - (goto-char (point-max)) - (goto-char (point-min)) - (forward-line (1- val))) - (back-to-indentation) - (if com (vip-execute-com 'vip-goto-line val com)))) - -(defun vip-find-char (arg char forward offset) - "Find ARG's occurrence of CHAR on the current line. If FORWARD then -search is forward, otherwise backward. OFFSET is used to adjust point -after search." - (let ((arg (if forward arg (- arg))) point) - (save-excursion - (save-restriction - (if (> arg 0) - (narrow-to-region - ;; forward search begins here - (if (eolp) (error "") (point)) - ;; forward search ends here - (progn (with-no-warnings (next-line 1)) (beginning-of-line) (point))) - (narrow-to-region - ;; backward search begins from here - (if (bolp) (error "") (point)) - ;; backward search ends here - (progn (beginning-of-line) (point)))) - ;; if arg > 0, point is forwarded before search. - (if (> arg 0) (goto-char (1+ (point-min))) - (goto-char (point-max))) - (let ((case-fold-search nil)) - (search-forward (char-to-string char) nil 0 arg)) - (setq point (point)) - (if (or (and (> arg 0) (= point (point-max))) - (and (< arg 0) (= point (point-min)))) - (error "")))) - (goto-char (+ point (if (> arg 0) (if offset -2 -1) (if offset 1 0)))))) - -(defun vip-find-char-forward (arg) - "Find char on the line. If called interactively read the char to find -from the terminal, and if called from vip-repeat, the char last used is -used. This behavior is controlled by the sign of prefix numeric value." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (> val 0) - ;; this means that the function was called interactively - (setq vip-f-char (read-char) - vip-f-forward t - vip-f-offset nil) - (setq val (- val))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val (if (> (vip-p-val arg) 0) vip-f-char vip-F-char) t nil) - (setq val (- val)) - (if com - (progn - (setq vip-F-char vip-f-char);; set new vip-F-char - (forward-char) - (vip-execute-com 'vip-find-char-forward val com))))) - -(defun vip-goto-char-forward (arg) - "Go up to char ARG forward on line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (> val 0) - ;; this means that the function was called interactively - (setq vip-f-char (read-char) - vip-f-forward t - vip-f-offset t) - (setq val (- val))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val (if (> (vip-p-val arg) 0) vip-f-char vip-F-char) t t) - (setq val (- val)) - (if com - (progn - (setq vip-F-char vip-f-char);; set new vip-F-char - (forward-char) - (vip-execute-com 'vip-goto-char-forward val com))))) - -(defun vip-find-char-backward (arg) - "Find char ARG on line backward." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (> val 0) - ;; this means that the function was called interactively - (setq vip-f-char (read-char) - vip-f-forward nil - vip-f-offset nil) - (setq val (- val))) - (if com (move-marker vip-com-point (point))) - (vip-find-char - val (if (> (vip-p-val arg) 0) vip-f-char vip-F-char) nil nil) - (setq val (- val)) - (if com - (progn - (setq vip-F-char vip-f-char);; set new vip-F-char - (vip-execute-com 'vip-find-char-backward val com))))) - -(defun vip-goto-char-backward (arg) - "Go up to char ARG backward on line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (> val 0) - ;; this means that the function was called interactively - (setq vip-f-char (read-char) - vip-f-forward nil - vip-f-offset t) - (setq val (- val))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val (if (> (vip-p-val arg) 0) vip-f-char vip-F-char) nil t) - (setq val (- val)) - (if com - (progn - (setq vip-F-char vip-f-char);; set new vip-F-char - (vip-execute-com 'vip-goto-char-backward val com))))) - -(defun vip-repeat-find (arg) - "Repeat previous find command." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val vip-f-char vip-f-forward vip-f-offset) - (if com - (progn - (if vip-f-forward (forward-char)) - (vip-execute-com 'vip-repeat-find val com))))) - -(defun vip-repeat-find-opposite (arg) - "Repeat previous find command in the opposite direction." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val vip-f-char (not vip-f-forward) vip-f-offset) - (if com - (progn - (if vip-f-forward (forward-char)) - (vip-execute-com 'vip-repeat-find-opposite val com))))) - - -;; window scrolling etc. - -(defun vip-other-window (arg) - "Switch to other window." - (interactive "p") - (other-window arg) - (or (not (eq vip-current-mode 'emacs-mode)) - (string= (buffer-name (current-buffer)) " *Minibuf-1*") - (vip-change-mode-to-vi))) - -(defun vip-window-top (arg) - "Go to home window line." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (move-to-window-line (1- val)) - (if com (vip-execute-com 'vip-window-top val com)))) - -(defun vip-window-middle (arg) - "Go to middle window line." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (move-to-window-line (+ (/ (1- (window-height)) 2) (1- val))) - (if com (vip-execute-com 'vip-window-middle val com)))) - -(defun vip-window-bottom (arg) - "Go to last window line." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (move-to-window-line (- val)) - (if com (vip-execute-com 'vip-window-bottom val com)))) - -(defun vip-line-to-top (arg) - "Put current line on the home line." - (interactive "p") - (recenter (1- arg))) - -(defun vip-line-to-middle (arg) - "Put current line on the middle line." - (interactive "p") - (recenter (+ (1- arg) (/ (1- (window-height)) 2)))) - -(defun vip-line-to-bottom (arg) - "Put current line on the last line." - (interactive "p") - (recenter (- (window-height) (1+ arg)))) - - -;; paren match - -(defun vip-paren-match (arg) - "Go to the matching parenthesis." - (interactive "P") - (let ((com (vip-getcom arg))) - (if (numberp arg) - (if (or (> arg 99) (< arg 1)) - (error "Prefix must be between 1 and 99") - (goto-char - (if (> (point-max) 80000) - (* (/ (point-max) 100) arg) - (/ (* (point-max) arg) 100))) - (back-to-indentation)) - (cond ((looking-at "[([{]") - (if com (move-marker vip-com-point (point))) - (forward-sexp 1) - (if com - (vip-execute-com 'vip-paren-match nil com) - (backward-char))) - ((looking-at "[])}]") - (forward-char) - (if com (move-marker vip-com-point (point))) - (backward-sexp 1) - (if com (vip-execute-com 'vip-paren-match nil com))) - (t (error "")))))) - - -;; sentence and paragraph - -(defun vip-forward-sentence (arg) - "Forward sentence." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-sentence val) - (if com (vip-execute-com 'vip-forward-sentence nil com)))) - -(defun vip-backward-sentence (arg) - "Backward sentence." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (backward-sentence val) - (if com (vip-execute-com 'vip-backward-sentence nil com)))) - -(defun vip-forward-paragraph (arg) - "Forward paragraph." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (forward-paragraph val) - (if com (vip-execute-com 'vip-forward-paragraph nil com)))) - -(defun vip-backward-paragraph (arg) - "Backward paragraph." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (backward-paragraph val) - (if com (vip-execute-com 'vip-backward-paragraph nil com)))) - - -;; scrolling - -(defun vip-scroll (arg) - "Scroll to next screen." - (interactive "p") - (if (> arg 0) - (while (> arg 0) - (scroll-up) - (setq arg (1- arg))) - (while (> 0 arg) - (scroll-down) - (setq arg (1+ arg))))) - -(defun vip-scroll-back (arg) - "Scroll to previous screen." - (interactive "p") - (vip-scroll (- arg))) - -(defun vip-scroll-down (arg) - "Scroll up half screen." - (interactive "P") - (if (null arg) (scroll-down (/ (window-height) 2)) - (scroll-down arg))) - -(defun vip-scroll-down-one (arg) - "Scroll up one line." - (interactive "p") - (scroll-down arg)) - -(defun vip-scroll-up (arg) - "Scroll down half screen." - (interactive "P") - (if (null arg) (scroll-up (/ (window-height) 2)) - (scroll-up arg))) - -(defun vip-scroll-up-one (arg) - "Scroll down one line." - (interactive "p") - (scroll-up arg)) - - -;; splitting window - -(defun vip-buffer-in-two-windows () - "Show current buffer in two windows." - (interactive) - (delete-other-windows) - (split-window-below)) - - -;; searching - -(defun vip-search-forward (arg) - "Search a string forward. ARG is used to find the ARG's occurrence -of the string. Default is vanilla search. Search mode can be toggled by -giving null search string." - (interactive "P") - (let ((val (vip-P-val arg)) (com (vip-getcom arg))) - (setq vip-s-forward t - vip-s-string (vip-read-string (if vip-re-search "RE-/" "/"))) - (if (string= vip-s-string "") - (progn - (setq vip-re-search (not vip-re-search)) - (message "Search mode changed to %s search." - (if vip-re-search "regular expression" - "vanilla"))) - (vip-search vip-s-string t val) - (if com - (progn - (move-marker vip-com-point (mark)) - (vip-execute-com 'vip-search-next val com)))))) - -(defun vip-search-backward (arg) - "Search a string backward. ARG is used to find the ARG's occurrence -of the string. Default is vanilla search. Search mode can be toggled by -giving null search string." - (interactive "P") - (let ((val (vip-P-val arg)) (com (vip-getcom arg))) - (setq vip-s-forward nil - vip-s-string (vip-read-string (if vip-re-search "RE-?" "?"))) - (if (string= vip-s-string "") - (progn - (setq vip-re-search (not vip-re-search)) - (message "Search mode changed to %s search." - (if vip-re-search "regular expression" - "vanilla"))) - (vip-search vip-s-string nil val) - (if com - (progn - (move-marker vip-com-point (mark)) - (vip-execute-com 'vip-search-next val com)))))) - -(defun vip-search (string forward arg &optional no-offset init-point) - "(STRING FORWARD COUNT &optional NO-OFFSET) Search COUNT's occurrence of -STRING. Search will be forward if FORWARD, otherwise backward." - (let ((val (vip-p-val arg)) (com (vip-getcom arg)) - (null-arg (null (vip-P-val arg))) (offset (not no-offset)) - (case-fold-search vip-case-fold-search) - (start-point (or init-point (point)))) - (if forward - (condition-case conditions - (progn - (if (and offset (not (eobp))) (forward-char)) - (if vip-re-search - (progn - (re-search-forward string nil nil val) - (re-search-backward string)) - (search-forward string nil nil val) - (search-backward string)) - (push-mark start-point)) - (search-failed - (if (and null-arg vip-search-wrap-around) - (progn - (goto-char (point-min)) - (vip-search string forward (cons 1 com) t start-point)) - (goto-char start-point) - (signal 'search-failed (cdr conditions))))) - (condition-case conditions - (progn - (if vip-re-search - (re-search-backward string nil nil val) - (search-backward string nil nil val)) - (push-mark start-point)) - (search-failed - (if (and null-arg vip-search-wrap-around) - (progn - (goto-char (point-max)) - (vip-search string forward (cons 1 com) t start-point)) - (goto-char start-point) - (signal 'search-failed (cdr conditions)))))))) - -(defun vip-search-next (arg) - "Repeat previous search." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (null vip-s-string) (error "No previous search string")) - (vip-search vip-s-string vip-s-forward arg) - (if com (vip-execute-com 'vip-search-next val com)))) - -(defun vip-search-Next (arg) - "Repeat previous search in the reverse direction." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (null vip-s-string) (error "No previous search string")) - (vip-search vip-s-string (not vip-s-forward) arg) - (if com (vip-execute-com 'vip-search-Next val com)))) - - -;; visiting and killing files, buffers - -(defun vip-switch-to-buffer () - "Switch to buffer in the current window." - (interactive) - (let (buffer) - (setq buffer - (read-buffer - (format "switch to buffer (%s): " - (buffer-name (other-buffer (current-buffer)))))) - (switch-to-buffer buffer) - (vip-change-mode-to-vi))) - -(defun vip-switch-to-buffer-other-window () - "Switch to buffer in another window." - (interactive) - (let (buffer) - (setq buffer - (read-buffer - (format "Switch to buffer (%s): " - (buffer-name (other-buffer (current-buffer)))))) - (switch-to-buffer-other-window buffer) - (vip-change-mode-to-vi))) - -(defun vip-kill-buffer () - "Kill a buffer." - (interactive) - (let (buffer buffer-name) - (setq buffer-name - (read-buffer - (format "Kill buffer (%s): " - (buffer-name (current-buffer))))) - (setq buffer - (if (null buffer-name) - (current-buffer) - (get-buffer buffer-name))) - (if (null buffer) (error "Buffer %s nonexistent" buffer-name)) - (if (or (not (buffer-modified-p buffer)) - (y-or-n-p "Buffer is modified, are you sure? ")) - (kill-buffer buffer) - (error "Buffer not killed")))) - -(defun vip-find-file () - "Visit file in the current window." - (interactive) - (let (file) - (setq file (read-file-name "visit file: ")) - (switch-to-buffer (find-file-noselect file)) - (vip-change-mode-to-vi))) - -(defun vip-find-file-other-window () - "Visit file in another window." - (interactive) - (let (file) - (setq file (read-file-name "Visit file: ")) - (switch-to-buffer-other-window (find-file-noselect file)) - (vip-change-mode-to-vi))) - -(defun vip-info-on-file () - "Give information of the file associated to the current buffer." - (interactive) - (message "\"%s\" line %d of %d" - (if (buffer-file-name) (buffer-file-name) "") - (1+ (count-lines (point-min) (point))) - (1+ (count-lines (point-min) (point-max))))) - - -;; yank and pop - -(defun vip-yank (text) - "yank TEXT silently." - (save-excursion - (vip-push-mark-silent (point)) - (insert text) - (exchange-point-and-mark)) - (skip-chars-forward " \t")) - -(defun vip-put-back (arg) - "Put back after point/below line." - (interactive "P") - (let ((val (vip-p-val arg)) - (text (if vip-use-register - (if (and (<= ?1 vip-use-register) (<= vip-use-register ?9)) - (current-kill (- vip-use-register ?1) 'do-not-rotate) - (get-register vip-use-register)) - (current-kill 0)))) - (if (null text) - (if vip-use-register - (let ((reg vip-use-register)) - (setq vip-use-register nil) - (error "Nothing in register %c" reg)) - (error ""))) - (setq vip-use-register nil) - (if (vip-end-with-a-newline-p text) - (progn - (with-no-warnings (next-line 1)) - (beginning-of-line)) - (if (and (not (eolp)) (not (eobp))) (forward-char))) - (setq vip-d-com (list 'vip-put-back val nil vip-use-register)) - (vip-loop val (vip-yank text)))) - -(defun vip-Put-back (arg) - "Put back at point/above line." - (interactive "P") - (let ((val (vip-p-val arg)) - (text (if vip-use-register - (if (and (<= ?1 vip-use-register) (<= vip-use-register ?9)) - (current-kill (- vip-use-register ?1) 'do-not-rotate) - (get-register vip-use-register)) - (current-kill 0)))) - (if (null text) - (if vip-use-register - (let ((reg vip-use-register)) - (setq vip-use-register nil) - (error "Nothing in register %c" reg)) - (error ""))) - (setq vip-use-register nil) - (if (vip-end-with-a-newline-p text) (beginning-of-line)) - (setq vip-d-com (list 'vip-Put-back val nil vip-use-register)) - (vip-loop val (vip-yank text)))) - -(defun vip-delete-char (arg) - "Delete character." - (interactive "P") - (let ((val (vip-p-val arg))) - (setq vip-d-com (list 'vip-delete-char val nil)) - (if vip-use-register - (progn - (if (and (<= ?A vip-use-register) (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (point) (- (point) val)) - (copy-to-register vip-use-register (point) (- (point) val) nil)) - (setq vip-use-register nil))) - (delete-char val t))) - -(defun vip-delete-backward-char (arg) - "Delete previous character." - (interactive "P") - (let ((val (vip-p-val arg))) - (setq vip-d-com (list 'vip-delete-backward-char val nil)) - (if vip-use-register - (progn - (if (and (<= ?A vip-use-register) (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (point) (+ (point) val)) - (copy-to-register vip-use-register (point) (+ (point) val) nil)) - (setq vip-use-register nil))) - (with-no-warnings (delete-backward-char val t)))) - - -;; join lines. - -(defun vip-join-lines (arg) - "Join this line to next, if ARG is nil. Otherwise, join ARG lines" - (interactive "*P") - (let ((val (vip-P-val arg))) - (setq vip-d-com (list 'vip-join-lines val nil)) - (vip-loop (if (null val) 1 (1- val)) - (progn - (end-of-line) - (if (not (eobp)) - (progn - (forward-line 1) - (delete-region (point) (1- (point))) - (fixup-whitespace))))))) - - -;; making small changes - -(defvar vip-c-string) - -(defun vip-change (beg end) - (setq vip-c-string - (vip-read-string (format "%s => " (buffer-substring beg end)))) - (vip-change-subr beg end)) - -(defun vip-change-subr (beg end) - (if vip-use-register - (progn - (copy-to-register vip-use-register beg end nil) - (setq vip-use-register nil))) - (kill-region beg end) - (setq this-command 'vip-change) - (insert vip-c-string)) - - -;; query replace - -(defun vip-query-replace () - "Query replace. If you supply null string as the string to be replaced, -the query replace mode will toggle between string replace and regexp replace." - (interactive) - (let (str) - (setq str (vip-read-string - (if vip-re-query-replace "Query replace regexp: " - "Query replace: "))) - (if (string= str "") - (progn - (setq vip-re-query-replace (not vip-re-query-replace)) - (message "Query replace mode changed to %s." - (if vip-re-query-replace "regexp replace" - "string replace"))) - (if vip-re-query-replace - (query-replace-regexp - str - (vip-read-string (format "Query replace regexp \"%s\" with: " str))) - (query-replace - str - (vip-read-string (format "Query replace \"%s\" with: " str))))))) - - -;; marking - -(defun vip-mark-beginning-of-buffer () - (interactive) - (set-mark (point)) - (goto-char (point-min)) - (exchange-point-and-mark) - (message "mark set at the beginning of buffer")) - -(defun vip-mark-end-of-buffer () - (interactive) - (set-mark (point)) - (goto-char (point-max)) - (exchange-point-and-mark) - (message "mark set at the end of buffer")) - -(defun vip-mark-point (char) - (interactive "c") - (cond ((and (<= ?a char) (<= char ?z)) - (point-to-register (- char (- ?a ?\C-a)) nil)) - ((= char ?<) (vip-mark-beginning-of-buffer)) - ((= char ?>) (vip-mark-end-of-buffer)) - ((= char ?.) (push-mark)) - ((= char ?,) (set-mark-command 1)) - ((= char ?D) (mark-defun)) - (t (error "")))) - -(defun vip-goto-mark (arg) - "Go to mark." - (interactive "P") - (let ((char (read-char)) (com (vip-getcom arg))) - (vip-goto-mark-subr char com nil))) - -(defun vip-goto-mark-and-skip-white (arg) - "Go to mark and skip to first non-white on line." - (interactive "P") - (let ((char (read-char)) (com (vip-getCom arg))) - (vip-goto-mark-subr char com t))) - -(defun vip-goto-mark-subr (char com skip-white) - (cond ((and (<= ?a char) (<= char ?z)) - (let ((buff (current-buffer))) - (if com (move-marker vip-com-point (point))) - (goto-char (register-to-point (- char (- ?a ?\C-a)))) - (if skip-white (back-to-indentation)) - (vip-change-mode-to-vi) - (if com - (if (equal buff (current-buffer)) - (vip-execute-com (if skip-white - 'vip-goto-mark-and-skip-white - 'vip-goto-mark) - nil com) - (switch-to-buffer buff) - (goto-char vip-com-point) - (vip-change-mode-to-vi) - (error ""))))) - ((and (not skip-white) (= char ?`)) - (if com (move-marker vip-com-point (point))) - (exchange-point-and-mark) - (if com (vip-execute-com 'vip-goto-mark nil com))) - ((and skip-white (= char ?')) - (if com (move-marker vip-com-point (point))) - (exchange-point-and-mark) - (back-to-indentation) - (if com (vip-execute-com 'vip-goto-mark-and-skip-white nil com))) - (t (error "")))) - -(defun vip-exchange-point-and-mark () - (interactive) - (exchange-point-and-mark) - (back-to-indentation)) - -(defun vip-keyboard-quit () - "Abort partially formed or running command." - (interactive) - (setq vip-use-register nil) - (keyboard-quit)) - -(defun vip-ctl-c-equivalent (arg) - "Emulate C-c in Emacs mode." - (interactive "P") - (vip-ctl-key-equivalent "\C-c" arg)) - -(defun vip-ctl-x-equivalent (arg) - "Emulate C-x in Emacs mode." - (interactive "P") - (vip-ctl-key-equivalent "\C-x" arg)) - -(defun vip-ctl-key-equivalent (key arg) - (let ((char (read-char))) - (if (and (<= ?A char) (<= char ?Z)) - (setq char (- char (- ?A ?\C-a)))) - (vip-escape-to-emacs arg (list (aref key 0) char)))) - -;; commands in insertion mode - -(defun vip-delete-backward-word (arg) - "Delete previous word." - (interactive "p") - (save-excursion - (set-mark (point)) - (backward-word arg) - (delete-region (point) (mark)))) - - -;; implement ex commands - -(defvar ex-token-type nil - "type of token. if non-nil, gives type of address. if nil, it -is a command.") - -(defvar ex-token nil - "value of token.") - -(defvar ex-addresses nil - "list of ex addresses") - -(defvar ex-flag nil - "flag for ex flag") - -(defvar ex-buffer nil - "name of ex buffer") - -(defvar ex-count nil - "value of ex count") - -(defvar ex-g-flag nil - "flag for global command") - -(defvar ex-g-variant nil - "if t global command is executed on lines not matching ex-g-pat") - -(defvar ex-reg-exp nil - "save reg-exp used in substitute") - -(defvar ex-repl nil - "replace pattern for substitute") - -(defvar ex-g-pat nil - "pattern for global command") - -(defvar ex-map (make-sparse-keymap) - "save commands for mapped keys") - -(defvar ex-tag nil - "save ex tag") - -(defvar ex-file nil) - -(defvar ex-variant nil) - -(defvar ex-offset nil) - -(defvar ex-append nil) - -(defun vip-nil () - (interactive) - (error "")) - -(defun vip-looking-back (str) - "returns t if looking back reg-exp STR before point." - (and (save-excursion (re-search-backward str nil t)) - (= (point) (match-end 0)))) - -(defun vip-check-sub (str) - "check if ex-token is an initial segment of STR" - (let ((length (length ex-token))) - (if (and (<= length (length str)) - (string= ex-token (substring str 0 length))) - (setq ex-token str) - (setq ex-token-type "non-command")))) - -(defun vip-get-ex-com-subr () - "get a complete ex command" - (set-mark (point)) - (re-search-forward "[a-z][a-z]*") - (setq ex-token-type "command") - (setq ex-token (buffer-substring (point) (mark))) - (exchange-point-and-mark) - (cond ((looking-at "a") - (cond ((looking-at "ab") (vip-check-sub "abbreviate")) - ((looking-at "ar") (vip-check-sub "args")) - (t (vip-check-sub "append")))) - ((looking-at "[bh]") (setq ex-token-type "non-command")) - ((looking-at "c") - (if (looking-at "co") (vip-check-sub "copy") - (vip-check-sub "change"))) - ((looking-at "d") (vip-check-sub "delete")) - ((looking-at "e") - (if (looking-at "ex") (vip-check-sub "ex") - (vip-check-sub "edit"))) - ((looking-at "f") (vip-check-sub "file")) - ((looking-at "g") (vip-check-sub "global")) - ((looking-at "i") (vip-check-sub "insert")) - ((looking-at "j") (vip-check-sub "join")) - ((looking-at "l") (vip-check-sub "list")) - ((looking-at "m") - (cond ((looking-at "map") (vip-check-sub "map")) - ((looking-at "mar") (vip-check-sub "mark")) - (t (vip-check-sub "move")))) - ((looking-at "n") - (if (looking-at "nu") (vip-check-sub "number") - (vip-check-sub "next"))) - ((looking-at "o") (vip-check-sub "open")) - ((looking-at "p") - (cond ((looking-at "pre") (vip-check-sub "preserve")) - ((looking-at "pu") (vip-check-sub "put")) - (t (vip-check-sub "print")))) - ((looking-at "q") (vip-check-sub "quit")) - ((looking-at "r") - (cond ((looking-at "rec") (vip-check-sub "recover")) - ((looking-at "rew") (vip-check-sub "rewind")) - (t (vip-check-sub "read")))) - ((looking-at "s") - (cond ((looking-at "se") (vip-check-sub "set")) - ((looking-at "sh") (vip-check-sub "shell")) - ((looking-at "so") (vip-check-sub "source")) - ((looking-at "st") (vip-check-sub "stop")) - (t (vip-check-sub "substitute")))) - ((looking-at "t") - (if (looking-at "ta") (vip-check-sub "tag") - (vip-check-sub "t"))) - ((looking-at "u") - (cond ((looking-at "una") (vip-check-sub "unabbreviate")) - ((looking-at "unm") (vip-check-sub "unmap")) - (t (vip-check-sub "undo")))) - ((looking-at "v") - (cond ((looking-at "ve") (vip-check-sub "version")) - ((looking-at "vi") (vip-check-sub "visual")) - (t (vip-check-sub "v")))) - ((looking-at "w") - (if (looking-at "wq") (vip-check-sub "wq") - (vip-check-sub "write"))) - ((looking-at "x") (vip-check-sub "xit")) - ((looking-at "y") (vip-check-sub "yank")) - ((looking-at "z") (vip-check-sub "z"))) - (exchange-point-and-mark)) - -(defun vip-get-ex-token () - "get an ex-token which is either an address or a command. -a token has type \(command, address, end-mark) and value." - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (cond ((looking-at "[k#]") - (setq ex-token-type "command") - (setq ex-token (char-to-string (following-char))) - (forward-char 1)) - ((looking-at "[a-z]") (vip-get-ex-com-subr)) - ((looking-at "\\.") - (forward-char 1) - (setq ex-token-type "dot")) - ((looking-at "[0-9]") - (set-mark (point)) - (re-search-forward "[0-9]*") - (setq ex-token-type - (cond ((string= ex-token-type "plus") "add-number") - ((string= ex-token-type "minus") "sub-number") - (t "abs-number"))) - (setq ex-token (string-to-number (buffer-substring (point) (mark))))) - ((looking-at "\\$") - (forward-char 1) - (setq ex-token-type "end")) - ((looking-at "%") - (forward-char 1) - (setq ex-token-type "whole")) - ((looking-at "\\+") - (cond ((looking-at "\\+[-+\n|]") - (forward-char 1) - (insert "1") - (backward-char 1) - (setq ex-token-type "plus")) - ((looking-at "\\+[0-9]") - (forward-char 1) - (setq ex-token-type "plus")) - (t - (error "Badly formed address")))) - ((looking-at "-") - (cond ((looking-at "-[-+\n|]") - (forward-char 1) - (insert "1") - (backward-char 1) - (setq ex-token-type "minus")) - ((looking-at "-[0-9]") - (forward-char 1) - (setq ex-token-type "minus")) - (t - (error "Badly formed address")))) - ((looking-at "/") - (forward-char 1) - (set-mark (point)) - (let ((cont t)) - (while (and (not (eolp)) cont) - ;;(re-search-forward "[^/]*/") - (re-search-forward "[^/]*\\(/\\|\n\\)") - (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/")) - (setq cont nil)))) - (backward-char 1) - (setq ex-token (buffer-substring (point) (mark))) - (if (looking-at "/") (forward-char 1)) - (setq ex-token-type "search-forward")) - ((looking-at "\\?") - (forward-char 1) - (set-mark (point)) - (let ((cont t)) - (while (and (not (eolp)) cont) - ;;(re-search-forward "[^\\?]*\\?") - (re-search-forward "[^\\?]*\\(\\?\\|\n\\)") - (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\\\?")) - (setq cont nil)) - (backward-char 1) - (if (not (looking-at "\n")) (forward-char 1)))) - (setq ex-token-type "search-backward") - (setq ex-token (buffer-substring (1- (point)) (mark)))) - ((looking-at ",") - (forward-char 1) - (setq ex-token-type "comma")) - ((looking-at ";") - (forward-char 1) - (setq ex-token-type "semi-colon")) - ((looking-at "[!=><&~]") - (setq ex-token-type "command") - (setq ex-token (char-to-string (following-char))) - (forward-char 1)) - ((looking-at "'") - (setq ex-token-type "goto-mark") - (forward-char 1) - (cond ((looking-at "'") (setq ex-token nil)) - ((looking-at "[a-z]") (setq ex-token (following-char))) - (t (error "%s" "Marks are ' and a-z"))) - (forward-char 1)) - ((looking-at "\n") - (setq ex-token-type "end-mark") - (setq ex-token "goto")) - (t - (error "Invalid token"))))) - -(defun vip-ex (&optional string) - "ex commands within VIP." - (interactive) - (or string - (setq ex-g-flag nil - ex-g-variant nil)) - (let ((com-str (or string (vip-read-string ":"))) - (address nil) (cont t) (dot (point))) - (with-current-buffer (get-buffer-create " *ex-working-space*") - (delete-region (point-min) (point-max)) - (insert com-str "\n") - (goto-char (point-min))) - (setq ex-token-type "") - (setq ex-addresses nil) - (while cont - (vip-get-ex-token) - (cond ((or (string= ex-token-type "command") - (string= ex-token-type "end-mark")) - (if address (setq ex-addresses (cons address ex-addresses))) - (cond ((string= ex-token "global") - (ex-global nil) - (setq cont nil)) - ((string= ex-token "v") - (ex-global t) - (setq cont nil)) - (t - (vip-execute-ex-command) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (cond ((looking-at "|") - (forward-char 1)) - ((looking-at "\n") - (setq cont nil)) - (t (error "Extra character at end of a command"))))))) - ((string= ex-token-type "non-command") - (error "%s: Not an editor command" ex-token)) - ((string= ex-token-type "whole") - (setq ex-addresses - (cons (point-max) (cons (point-min) ex-addresses)))) - ((string= ex-token-type "comma") - (setq ex-addresses - (cons (if (null address) (point) address) ex-addresses))) - ((string= ex-token-type "semi-colon") - (if address (setq dot address)) - (setq ex-addresses - (cons (if (null address) (point) address) ex-addresses))) - (t (let ((ans (vip-get-ex-address-subr address dot))) - (if ans (setq address ans)))))))) - -(defun vip-get-ex-pat () - "get a regular expression and set ex-variant if found" - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq ex-g-variant (not ex-g-variant) - ex-g-flag (not ex-g-flag)) - (forward-char 1) - (skip-chars-forward " \t"))) - (if (looking-at "/") - (progn - (forward-char 1) - (set-mark (point)) - (let ((cont t)) - (while (and (not (eolp)) cont) - (re-search-forward "[^/]*\\(/\\|\n\\)") - ;;(re-search-forward "[^/]*/") - (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/")) - (setq cont nil)))) - (setq ex-token - (if (= (mark) (point)) "" - (buffer-substring (1- (point)) (mark)))) - (backward-char 1)) - (setq ex-token nil)))) - -(defun vip-get-ex-command () - "get an ex command" - (with-current-buffer " *ex-working-space*" - (if (looking-at "/") (forward-char 1)) - (skip-chars-forward " \t") - (cond ((looking-at "[a-z]") - (vip-get-ex-com-subr) - (if (string= ex-token-type "non-command") - (error "%s: Not an editor command" ex-token))) - ((looking-at "[!=><&~]") - (setq ex-token (char-to-string (following-char))) - (forward-char 1)) - (t (error "Could not find an ex command"))))) - -(defun vip-get-ex-opt-gc () - "get an ex option g or c" - (with-current-buffer " *ex-working-space*" - (if (looking-at "/") (forward-char 1)) - (skip-chars-forward " \t") - (cond ((looking-at "g") - (setq ex-token "g") - (forward-char 1) - t) - ((looking-at "c") - (setq ex-token "c") - (forward-char 1) - t) - (t nil)))) - -(defun vip-default-ex-addresses (&optional whole-flag) - "compute default addresses. whole-flag means whole buffer." - (cond ((null ex-addresses) - (setq ex-addresses - (if whole-flag - (cons (point-max) (cons (point-min) nil)) - (cons (point) (cons (point) nil))))) - ((null (cdr ex-addresses)) - (setq ex-addresses - (cons (car ex-addresses) ex-addresses))))) - -(defun vip-get-ex-address () - "get an ex-address as a marker and set ex-flag if a flag is found" - (let ((address (point-marker)) (cont t)) - (setq ex-token "") - (setq ex-flag nil) - (while cont - (vip-get-ex-token) - (cond ((string= ex-token-type "command") - (if (or (string= ex-token "print") (string= ex-token "list") - (string= ex-token "#")) - (progn - (setq ex-flag t) - (setq cont nil)) - (error "Address expected"))) - ((string= ex-token-type "end-mark") - (setq cont nil)) - ((string= ex-token-type "whole") - (error "a trailing address is expected")) - ((string= ex-token-type "comma") - (error "Extra characters after an address")) - (t (let ((ans (vip-get-ex-address-subr address (point-marker)))) - (if ans (setq address ans)))))) - address)) - -(defun vip-get-ex-address-subr (old-address dot) - "returns an address as a point" - (let ((address nil)) - (if (null old-address) (setq old-address dot)) - (cond ((string= ex-token-type "dot") - (setq address dot)) - ((string= ex-token-type "add-number") - (save-excursion - (goto-char old-address) - (forward-line (if (= old-address 0) (1- ex-token) ex-token)) - (setq address (point-marker)))) - ((string= ex-token-type "sub-number") - (save-excursion - (goto-char old-address) - (forward-line (- ex-token)) - (setq address (point-marker)))) - ((string= ex-token-type "abs-number") - (save-excursion - (goto-char (point-min)) - (if (= ex-token 0) (setq address 0) - (forward-line (1- ex-token)) - (setq address (point-marker))))) - ((string= ex-token-type "end") - (setq address (point-max-marker))) - ((string= ex-token-type "plus") t);; do nothing - ((string= ex-token-type "minus") t);; do nothing - ((string= ex-token-type "search-forward") - (save-excursion - (ex-search-address t) - (setq address (point-marker)))) - ((string= ex-token-type "search-backward") - (save-excursion - (ex-search-address nil) - (setq address (point-marker)))) - ((string= ex-token-type "goto-mark") - (save-excursion - (if (null ex-token) - (exchange-point-and-mark) - (goto-char (register-to-point (- ex-token (- ?a ?\C-a))))) - (setq address (point-marker))))) - address)) - -(defun ex-search-address (forward) - "search pattern and set address" - (if (string= ex-token "") - (if (null vip-s-string) (error "No previous search string") - (setq ex-token vip-s-string)) - (setq vip-s-string ex-token)) - (if forward - (progn - (forward-line 1) - (re-search-forward ex-token)) - (forward-line -1) - (re-search-backward ex-token))) - -(defun vip-get-ex-buffer () - "get a buffer name and set ex-count and ex-flag if found" - (setq ex-buffer nil) - (setq ex-count nil) - (setq ex-flag nil) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "[a-zA-Z]") - (progn - (setq ex-buffer (following-char)) - (forward-char 1) - (skip-chars-forward " \t"))) - (if (looking-at "[0-9]") - (progn - (set-mark (point)) - (re-search-forward "[0-9][0-9]*") - (setq ex-count (string-to-number (buffer-substring (point) (mark)))) - (skip-chars-forward " \t"))) - (if (looking-at "[pl#]") - (progn - (setq ex-flag t) - (forward-char 1))) - (if (not (looking-at "[\n|]")) - (error "Invalid extra characters")))) - -(defun vip-get-ex-count () - (setq ex-variant nil - ex-count nil - ex-flag nil) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq ex-variant t) - (forward-char 1))) - (skip-chars-forward " \t") - (if (looking-at "[0-9]") - (progn - (set-mark (point)) - (re-search-forward "[0-9][0-9]*") - (setq ex-count (string-to-number (buffer-substring (point) (mark)))) - (skip-chars-forward " \t"))) - (if (looking-at "[pl#]") - (progn - (setq ex-flag t) - (forward-char 1))) - (if (not (looking-at "[\n|]")) - (error "Invalid extra characters")))) - -(defun vip-get-ex-file () - "get a file name and set ex-variant, ex-append and ex-offset if found" - (setq ex-file nil - ex-variant nil - ex-append nil - ex-offset nil) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq ex-variant t) - (forward-char 1) - (skip-chars-forward " \t"))) - (if (looking-at ">>") - (progn - (setq ex-append t - ex-variant t) - (forward-char 2) - (skip-chars-forward " \t"))) - (if (looking-at "\\+") - (progn - (forward-char 1) - (set-mark (point)) - (re-search-forward "[ \t\n]") - (backward-char 1) - (setq ex-offset (buffer-substring (point) (mark))) - (forward-char 1) - (skip-chars-forward " \t"))) - (set-mark (point)) - (re-search-forward "[ \t\n]") - (backward-char 1) - (setq ex-file (buffer-substring (point) (mark))))) - -(defun vip-execute-ex-command () - "execute ex command using the value of addresses." - (cond ((string= ex-token "goto") (ex-goto)) - ((string= ex-token "copy") (ex-copy nil)) - ((string= ex-token "delete") (ex-delete)) - ((string= ex-token "edit") (ex-edit)) - ((string= ex-token "file") (vip-info-on-file)) - ;((string= ex-token "global") (ex-global nil)) - ((string= ex-token "join") (ex-line "join")) - ((string= ex-token "k") (ex-mark)) - ((string= ex-token "mark") (ex-mark)) - ((string= ex-token "map") (ex-map)) - ((string= ex-token "move") (ex-copy t)) - ((string= ex-token "put") (ex-put)) - ((string= ex-token "quit") (ex-quit)) - ((string= ex-token "read") (ex-read)) - ((string= ex-token "set") (ex-set)) - ((string= ex-token "shell") (ex-shell)) - ((string= ex-token "substitute") (ex-substitute)) - ((string= ex-token "stop") (suspend-emacs)) - ((string= ex-token "t") (ex-copy nil)) - ((string= ex-token "tag") (ex-tag)) - ((string= ex-token "undo") (vip-undo)) - ((string= ex-token "unmap") (ex-unmap)) - ;((string= ex-token "v") (ex-global t)) - ((string= ex-token "version") (vip-version)) - ((string= ex-token "visual") (ex-edit)) - ((string= ex-token "write") (ex-write nil)) - ((string= ex-token "wq") (ex-write t)) - ((string= ex-token "yank") (ex-yank)) - ((string= ex-token "!") (ex-command)) - ((string= ex-token "=") (ex-line-no)) - ((string= ex-token ">") (ex-line "right")) - ((string= ex-token "<") (ex-line "left")) - ((string= ex-token "&") (ex-substitute t)) - ((string= ex-token "~") (ex-substitute t t)) - ((or (string= ex-token "append") - (string= ex-token "args") - (string= ex-token "change") - (string= ex-token "insert") - (string= ex-token "open") - ) - (error "%s: No such command from VIP" ex-token)) - ((or (string= ex-token "abbreviate") - (string= ex-token "list") - (string= ex-token "next") - (string= ex-token "print") - (string= ex-token "preserve") - (string= ex-token "recover") - (string= ex-token "rewind") - (string= ex-token "source") - (string= ex-token "unabbreviate") - (string= ex-token "xit") - (string= ex-token "z") - ) - (error "%s: Not implemented in VIP" ex-token)) - (t (error "%s: Not an editor command" ex-token)))) - -(defun ex-goto () - "ex goto command" - (if (null ex-addresses) - (setq ex-addresses (cons (point) nil))) - (push-mark) - (goto-char (car ex-addresses)) - (beginning-of-line)) - -(defun ex-copy (del-flag) - "ex copy and move command. DEL-FLAG means delete." - (vip-default-ex-addresses) - (let ((address (vip-get-ex-address)) - (end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (goto-char end) - (save-excursion - (set-mark beg) - (vip-enlarge-region (mark) (point)) - (if del-flag (kill-region (point) (mark)) - (copy-region-as-kill (point) (mark))) - (if ex-flag - (progn - (with-output-to-temp-buffer "*copy text*" - (princ - (if (or del-flag ex-g-flag ex-g-variant) - (current-kill 0) - (buffer-substring (point) (mark))))) - (condition-case nil - (progn - (vip-read-string "[Hit return to continue] ") - (save-excursion (kill-buffer "*copy text*"))) - (quit - (save-excursion (kill-buffer "*copy text*")) - (signal 'quit nil)))))) - (if (= address 0) - (goto-char (point-min)) - (goto-char address) - (forward-line 1)) - (insert (current-kill 0)))) - -(defun ex-delete () - "ex delete" - (vip-default-ex-addresses) - (vip-get-ex-buffer) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (exchange-point-and-mark) - (if ex-count - (progn - (set-mark (point)) - (forward-line (1- ex-count))) - (set-mark end)) - (vip-enlarge-region (point) (mark)) - (if ex-flag - ;; show text to be deleted and ask for confirmation - (progn - (with-output-to-temp-buffer " *delete text*" - (princ (buffer-substring (point) (mark)))) - (condition-case nil - (vip-read-string "[Hit return to continue] ") - (quit - (save-excursion (kill-buffer " *delete text*")) - (error ""))) - (save-excursion (kill-buffer " *delete text*"))) - (if ex-buffer - (if (and (<= ?A ex-buffer) (<= ex-buffer ?Z)) - (vip-append-to-register - (+ ex-buffer 32) (point) (mark)) - (copy-to-register ex-buffer (point) (mark) nil))) - (delete-region (point) (mark)))))) - -(defun ex-edit () - "ex-edit" - (vip-get-ex-file) - (if (and (not ex-variant) (buffer-modified-p) buffer-file-name) - (error "No write since last change (:e! overrides)")) - (vip-change-mode-to-emacs) - (set-buffer - (find-file-noselect (concat default-directory ex-file))) - (vip-change-mode-to-vi) - (goto-char (point-min)) - (if ex-offset - (progn - (with-current-buffer " *ex-working-space*" - (delete-region (point-min) (point-max)) - (insert ex-offset "\n") - (goto-char (point-min))) - (goto-char (vip-get-ex-address)) - (beginning-of-line)))) - -(defun ex-global (variant) - "ex global command" - (if (or ex-g-flag ex-g-variant) - (error "Global within global not allowed") - (if variant - (setq ex-g-flag nil - ex-g-variant t) - (setq ex-g-flag t - ex-g-variant nil))) - (vip-get-ex-pat) - (if (null ex-token) - (error "Missing regular expression for global command")) - (if (string= ex-token "") - (if (null vip-s-string) (error "No previous search string") - (setq ex-g-pat vip-s-string)) - (setq ex-g-pat ex-token - vip-s-string ex-token)) - (if (null ex-addresses) - (setq ex-addresses (list (point-max) (point-min)))) - (let ((marks nil) (mark-count 0) - com-str (end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (exchange-point-and-mark) - (let ((cont t) (limit (point-marker))) - (exchange-point-and-mark) - ;; skip the last line if empty - (beginning-of-line) - (if (and (eobp) (not (bobp))) (backward-char 1)) - (while (and cont (not (bobp)) (>= (point) limit)) - (beginning-of-line) - (set-mark (point)) - (end-of-line) - (let ((found (re-search-backward ex-g-pat (mark) t))) - (if (or (and ex-g-flag found) - (and ex-g-variant (not found))) - (progn - (end-of-line) - (setq mark-count (1+ mark-count)) - (setq marks (cons (point-marker) marks))))) - (beginning-of-line) - (if (bobp) (setq cont nil) - (forward-line -1) - (end-of-line))))) - (with-current-buffer " *ex-working-space*" - (setq com-str (buffer-substring (1+ (point)) (1- (point-max))))) - (while marks - (goto-char (car marks)) - ;; report progress of execution on a slow machine. - ;;(message "Executing global command...") - ;;(if (zerop (% mark-count 10)) - ;; (message "Executing global command...%d" mark-count)) - (vip-ex com-str) - (setq mark-count (1- mark-count)) - (setq marks (cdr marks))))) -;;(message "Executing global command...done"))) - -(defun ex-line (com) - "ex line commands. COM is join, shift-right or shift-left." - (vip-default-ex-addresses) - (vip-get-ex-count) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses))) point) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (exchange-point-and-mark) - (if ex-count - (progn - (set-mark (point)) - (forward-line ex-count))) - (if ex-flag - ;; show text to be joined and ask for confirmation - (progn - (with-output-to-temp-buffer " *text*" - (princ (buffer-substring (point) (mark)))) - (condition-case nil - (progn - (vip-read-string "[Hit return to continue] ") - (ex-line-subr com (point) (mark))) - (quit - (ding))) - (save-excursion (kill-buffer " *text*"))) - (ex-line-subr com (point) (mark))) - (setq point (point))) - (goto-char (1- point)) - (beginning-of-line))) - -(defun ex-line-subr (com beg end) - (cond ((string= com "join") - (goto-char (min beg end)) - (while (and (not (eobp)) (< (point) (max beg end))) - (end-of-line) - (if (and (<= (point) (max beg end)) (not (eobp))) - (progn - (forward-line 1) - (delete-region (point) (1- (point))) - (if (not ex-variant) (fixup-whitespace)))))) - ((or (string= com "right") (string= com "left")) - (indent-rigidly - (min beg end) (max beg end) - (if (string= com "right") vip-shift-width (- vip-shift-width))) - (goto-char (max beg end)) - (end-of-line) - (forward-char 1)))) - -(defun ex-mark () - "ex mark" - (let (char) - (if (null ex-addresses) - (setq ex-addresses - (cons (point) nil))) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "[a-z]") - (progn - (setq char (following-char)) - (forward-char 1) - (skip-chars-forward " \t") - (if (not (looking-at "[\n|]")) - (error "Extra characters at end of \"k\" command"))) - (if (looking-at "[\n|]") - (error "\"k\" requires a following letter") - (error "Mark must specify a letter")))) - (save-excursion - (goto-char (car ex-addresses)) - (point-to-register (- char (- ?a ?\C-a)) nil)))) - -(defun ex-map () - "ex map" - (let (char string) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (setq char (char-to-string (following-char))) - (forward-char 1) - (skip-chars-forward " \t") - (if (looking-at "[\n|]") (error "Missing rhs")) - (set-mark (point)) - (with-no-warnings - (end-of-buffer)) - (backward-char 1) - (setq string (buffer-substring (mark) (point)))) - (if (not (lookup-key ex-map char)) - (define-key ex-map char - (or (lookup-key vip-mode-map char) 'vip-nil))) - (define-key vip-mode-map char - (lambda (count) - (interactive "p") - (execute-kbd-macro string count))))) - -(defun ex-unmap () - "ex unmap" - (let (char) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (setq char (char-to-string (following-char))) - (forward-char 1) - (skip-chars-forward " \t") - (if (not (looking-at "[\n|]")) (error "Macro must be a character"))) - (if (not (lookup-key ex-map char)) - (error "That macro wasn't mapped")) - (define-key vip-mode-map char (lookup-key ex-map char)) - (define-key ex-map char nil))) - -(defun ex-put () - "ex put" - (let ((point (if (null ex-addresses) (point) (car ex-addresses)))) - (vip-get-ex-buffer) - (setq vip-use-register ex-buffer) - (goto-char point) - (if (= point 0) (vip-Put-back 1) (vip-put-back 1)))) - -(defun ex-quit () - "ex quit" - (let (char) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (setq char (following-char))) - (if (= char ?!) (kill-emacs t) (save-buffers-kill-emacs)))) - -(defun ex-read () - "ex read" - (let ((point (if (null ex-addresses) (point) (car ex-addresses))) - (variant nil) command file) - (goto-char point) - (if (not (= point 0)) (with-no-warnings (next-line 1))) - (beginning-of-line) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq variant t) - (forward-char 1) - (skip-chars-forward " \t") - (set-mark (point)) - (end-of-line) - (setq command (buffer-substring (mark) (point)))) - (set-mark (point)) - (re-search-forward "[ \t\n]") - (backward-char 1) - (setq file (buffer-substring (point) (mark))))) - (if variant - (shell-command command t) - (with-no-warnings - (insert-file file))))) - -(defalias 'ex-set #'set-variable) - -(defun ex-shell () - "ex shell" - (vip-change-mode-to-emacs) - (shell)) - -(defun ex-substitute (&optional repeat r-flag) - "ex substitute. -If REPEAT use previous reg-exp which is ex-reg-exp or -vip-s-string" - (let (pat repl (opt-g nil) (opt-c nil) (matched-pos nil)) - (if repeat (setq ex-token nil) (vip-get-ex-pat)) - (if (null ex-token) - (setq pat (if r-flag vip-s-string ex-reg-exp) - repl ex-repl) - (setq pat (if (string= ex-token "") vip-s-string ex-token)) - (setq vip-s-string pat - ex-reg-exp pat) - (vip-get-ex-pat) - (if (null ex-token) - (setq ex-token "" - ex-repl "") - (setq repl ex-token - ex-repl ex-token))) - (while (vip-get-ex-opt-gc) - (if (string= ex-token "g") (setq opt-g t) (setq opt-c t))) - (vip-get-ex-count) - (if ex-count - (save-excursion - (if ex-addresses (goto-char (car ex-addresses))) - (set-mark (point)) - (forward-line (1- ex-count)) - (setq ex-addresses (cons (point) (cons (mark) nil)))) - (if (null ex-addresses) - (setq ex-addresses (cons (point) (cons (point) nil))) - (if (null (cdr ex-addresses)) - (setq ex-addresses (cons (car ex-addresses) ex-addresses))))) - ;(setq G opt-g) - (let ((beg (car ex-addresses)) (end (car (cdr ex-addresses))) - eol-mark) ;;(cont t) - (save-excursion - (vip-enlarge-region beg end) - (let ((limit (save-excursion - (goto-char (max (point) (mark))) - (point-marker)))) - (goto-char (min (point) (mark))) - (while (< (point) limit) - (end-of-line) - (setq eol-mark (point-marker)) - (beginning-of-line) - (if opt-g - (progn - (while (and (not (eolp)) - (re-search-forward pat eol-mark t)) - (if (or (not opt-c) (y-or-n-p "Replace? ")) - (progn - (setq matched-pos (point)) - (replace-match repl)))) - (end-of-line) - (forward-char)) - (if (and (re-search-forward pat eol-mark t) - (or (not opt-c) (y-or-n-p "Replace? "))) - (progn - (setq matched-pos (point)) - (replace-match repl))) - (end-of-line) - (forward-char)))))) - (if matched-pos (goto-char matched-pos)) - (beginning-of-line) - (if opt-c (message "done")))) - -(defun ex-tag () - "ex tag" - (let (tag) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (set-mark (point)) - (skip-chars-forward "^ |\t\n") - (setq tag (buffer-substring (mark) (point)))) - (if (not (string= tag "")) (setq ex-tag tag)) - (vip-change-mode-to-emacs) - (condition-case conditions - (progn - (with-suppressed-warnings ((obsolete find-tag find-tag-other-window)) - (if (string= tag "") - (find-tag ex-tag t) - (find-tag-other-window ex-tag))) - (vip-change-mode-to-vi)) - (error - (vip-change-mode-to-vi) - (vip-message-conditions conditions))))) - -(defun ex-write (q-flag) - "ex write" - (vip-default-ex-addresses t) - (vip-get-ex-file) - (if (string= ex-file "") - (progn - (if (null buffer-file-name) - (error "No file associated with this buffer")) - (setq ex-file buffer-file-name)) - (setq ex-file (expand-file-name ex-file))) - (if (and (not (string= ex-file (buffer-file-name))) - (file-exists-p ex-file) - (not ex-variant)) - (error "\"%s\" File exists - use w! to override" ex-file)) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (write-region (point) (mark) ex-file ex-append t))) - (if (null buffer-file-name) (setq buffer-file-name ex-file)) - (if q-flag (save-buffers-kill-emacs))) - -(defun ex-yank () - "ex yank" - (vip-default-ex-addresses) - (vip-get-ex-buffer) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (exchange-point-and-mark) - (if (or ex-g-flag ex-g-variant) (error "Can't yank within global")) - (if ex-count - (progn - (set-mark (point)) - (forward-line (1- ex-count))) - (set-mark end)) - (vip-enlarge-region (point) (mark)) - (if ex-flag (error "Extra characters at end of command")) - (if ex-buffer - (copy-to-register ex-buffer (point) (mark) nil)) - (copy-region-as-kill (point) (mark))))) - -(defun ex-command () - "execute shell command" - (let (command) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (set-mark (point)) - (end-of-line) - (setq command (buffer-substring (mark) (point)))) - (if (null ex-addresses) - (shell-command command) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (null beg) (setq beg end)) - (save-excursion - (goto-char beg) - (set-mark end) - (vip-enlarge-region (point) (mark)) - (shell-command-on-region (point) (mark) command t t)) - (goto-char beg))))) - -(defun ex-line-no () - "print line number" - (message "%d" - (1+ (count-lines - (point-min) - (if (null ex-addresses) (point-max) (car ex-addresses)))))) - -(if (file-exists-p vip-startup-file) (load vip-startup-file)) - -(provide 'vip) - -;;; vip.el ends here diff --git a/lisp/obsolete/ws-mode.el b/lisp/obsolete/ws-mode.el deleted file mode 100644 index a3f44a2c4a3..00000000000 --- a/lisp/obsolete/ws-mode.el +++ /dev/null @@ -1,538 +0,0 @@ -;;; ws-mode.el --- WordStar emulation mode for GNU Emacs -*- lexical-binding: t -*- - -;; Copyright (C) 1991, 2001-2024 Free Software Foundation, Inc. - -;; Author: Juergen Nickelsen -;; Version: 0.7 -;; Keywords: emulations -;; Obsolete-since: 24.5 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; This provides emulation of WordStar with a minor mode. - -;;; Code: - -(defgroup wordstar nil - "WordStar emulation within Emacs." - :prefix "wordstar-" - :prefix "ws-" - :group 'emulations) - -(defcustom wordstar-mode-lighter " WordStar" - "Lighter shown in the modeline for `wordstar' mode." - :type 'string) - -(defvar wordstar-C-k-map - (let ((map (make-keymap))) - (define-key map " " ()) - (define-key map "0" #'ws-set-marker-0) - (define-key map "1" #'ws-set-marker-1) - (define-key map "2" #'ws-set-marker-2) - (define-key map "3" #'ws-set-marker-3) - (define-key map "4" #'ws-set-marker-4) - (define-key map "5" #'ws-set-marker-5) - (define-key map "6" #'ws-set-marker-6) - (define-key map "7" #'ws-set-marker-7) - (define-key map "8" #'ws-set-marker-8) - (define-key map "9" #'ws-set-marker-9) - (define-key map "b" #'ws-begin-block) - (define-key map "\C-b" #'ws-begin-block) - (define-key map "c" #'ws-copy-block) - (define-key map "\C-c" #'ws-copy-block) - (define-key map "d" #'save-buffers-kill-emacs) - (define-key map "\C-d" #'save-buffers-kill-emacs) - (define-key map "f" #'find-file) - (define-key map "\C-f" #'find-file) - (define-key map "h" #'ws-show-markers) - (define-key map "\C-h" #'ws-show-markers) - (define-key map "i" #'ws-indent-block) - (define-key map "\C-i" #'ws-indent-block) - (define-key map "k" #'ws-end-block) - (define-key map "\C-k" #'ws-end-block) - (define-key map "p" #'ws-print-block) - (define-key map "\C-p" #'ws-print-block) - (define-key map "q" #'kill-emacs) - (define-key map "\C-q" #'kill-emacs) - (define-key map "r" #'insert-file) - (define-key map "\C-r" #'insert-file) - (define-key map "s" #'save-some-buffers) - (define-key map "\C-s" #'save-some-buffers) - (define-key map "t" #'ws-mark-word) - (define-key map "\C-t" #'ws-mark-word) - (define-key map "u" #'ws-exdent-block) - (define-key map "\C-u" #'keyboard-quit) - (define-key map "v" #'ws-move-block) - (define-key map "\C-v" #'ws-move-block) - (define-key map "w" #'ws-write-block) - (define-key map "\C-w" #'ws-write-block) - (define-key map "x" #'save-buffers-kill-emacs) - (define-key map "\C-x" #'save-buffers-kill-emacs) - (define-key map "y" #'ws-delete-block) - (define-key map "\C-y" #'ws-delete-block) - map)) - -(defvar wordstar-C-o-map - (let ((map (make-keymap))) - (define-key map " " ()) - (define-key map "c" #'wordstar-center-line) - (define-key map "\C-c" #'wordstar-center-line) - (define-key map "b" #'switch-to-buffer) - (define-key map "\C-b" #'switch-to-buffer) - (define-key map "j" #'justify-current-line) - (define-key map "\C-j" #'justify-current-line) - (define-key map "k" #'kill-buffer) - (define-key map "\C-k" #'kill-buffer) - (define-key map "l" #'list-buffers) - (define-key map "\C-l" #'list-buffers) - (define-key map "m" #'auto-fill-mode) - (define-key map "\C-m" #'auto-fill-mode) - (define-key map "r" #'set-fill-column) - (define-key map "\C-r" #'set-fill-column) - (define-key map "\C-u" #'keyboard-quit) - (define-key map "wd" #'delete-other-windows) - (define-key map "wh" #'split-window-right) - (define-key map "wo" #'other-window) - (define-key map "wv" #'split-window-below) - map)) - -(defvar wordstar-C-q-map - (let ((map (make-keymap))) - (define-key map " " ()) - (define-key map "0" #'ws-find-marker-0) - (define-key map "1" #'ws-find-marker-1) - (define-key map "2" #'ws-find-marker-2) - (define-key map "3" #'ws-find-marker-3) - (define-key map "4" #'ws-find-marker-4) - (define-key map "5" #'ws-find-marker-5) - (define-key map "6" #'ws-find-marker-6) - (define-key map "7" #'ws-find-marker-7) - (define-key map "8" #'ws-find-marker-8) - (define-key map "9" #'ws-find-marker-9) - (define-key map "a" #'ws-query-replace) - (define-key map "\C-a" #'ws-query-replace) - (define-key map "b" #'ws-goto-block-begin) - (define-key map "\C-b" #'ws-goto-block-begin) - (define-key map "c" #'end-of-buffer) - (define-key map "\C-c" #'end-of-buffer) - (define-key map "d" #'end-of-line) - (define-key map "\C-d" #'end-of-line) - (define-key map "f" #'ws-search) - (define-key map "\C-f" #'ws-search) - (define-key map "k" #'ws-goto-block-end) - (define-key map "\C-k" #'ws-goto-block-end) - (define-key map "l" #'ws-undo) - (define-key map "\C-l" #'ws-undo) - ;; (define-key map "p" #'ws-last-cursorp) - ;; (define-key map "\C-p" #'ws-last-cursorp) - (define-key map "r" #'beginning-of-buffer) - (define-key map "\C-r" #'beginning-of-buffer) - (define-key map "s" #'beginning-of-line) - (define-key map "\C-s" #'beginning-of-line) - (define-key map "\C-u" #'keyboard-quit) - (define-key map "w" #'ws-last-error) - (define-key map "\C-w" #'ws-last-error) - (define-key map "y" #'ws-kill-eol) - (define-key map "\C-y" #'ws-kill-eol) - (define-key map "\177" #'ws-kill-bol) - map)) - -(defvar wordstar-mode-map - (let ((map (make-keymap))) - (define-key map "\C-a" #'backward-word) - (define-key map "\C-b" #'fill-paragraph) - (define-key map "\C-c" #'scroll-up-command) - (define-key map "\C-d" #'forward-char) - (define-key map "\C-e" #'previous-line) - (define-key map "\C-f" #'forward-word) - (define-key map "\C-g" #'delete-char) - (define-key map "\C-h" #'backward-char) - (define-key map "\C-i" #'indent-for-tab-command) - (define-key map "\C-k" wordstar-C-k-map) - (define-key map "\C-l" #'ws-repeat-search) - (define-key map "\C-n" #'open-line) - (define-key map "\C-o" wordstar-C-o-map) - (define-key map "\C-p" #'quoted-insert) - (define-key map "\C-q" wordstar-C-q-map) - (define-key map "\C-r" #'scroll-down-command) - (define-key map "\C-s" #'backward-char) - (define-key map "\C-t" #'kill-word) - (define-key map "\C-u" #'keyboard-quit) - (define-key map "\C-v" #'overwrite-mode) - (define-key map "\C-w" #'scroll-down-line) - (define-key map "\C-x" #'next-line) - (define-key map "\C-y" #'kill-complete-line) - (define-key map "\C-z" #'scroll-up-line) - map)) - -;; wordstar-C-j-map not yet implemented -(defvar wordstar-C-j-map nil) - -;;;###autoload -(define-minor-mode wordstar-mode - "Minor mode with WordStar-like key bindings. - -BUGS: - - Help menus with WordStar commands (C-j just calls help-for-help) - are not implemented - - Options for search and replace - - Show markers (C-k h) is somewhat strange - - Search and replace (C-q a) is only available in forward direction - -No key bindings beginning with ESC are installed, they will work -Emacs-like." - :group 'wordstar - :lighter wordstar-mode-lighter - :keymap wordstar-mode-map) - -(defun turn-on-wordstar-mode () - (when (and (not (minibufferp)) - (not wordstar-mode)) - (wordstar-mode 1))) - -(define-globalized-minor-mode global-wordstar-mode wordstar-mode - turn-on-wordstar-mode) - -(defun wordstar-center-paragraph () - "Center each line in the paragraph at or after point. -See `wordstar-center-line' for more info." - (interactive) - (save-excursion - (forward-paragraph) - (or (bolp) (newline 1)) - (let ((end (point))) - (backward-paragraph) - (wordstar-center-region (point) end)))) - -(defun wordstar-center-region (from to) - "Center each line starting in the region. -See `wordstar-center-line' for more info." - (interactive "r") - (if (> from to) - (let ((tem to)) - (setq to from from tem))) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char from) - (while (not (eobp)) - (wordstar-center-line) - (forward-line 1))))) - -(defun wordstar-center-line () - "Center the line point is on, within the width specified by `fill-column'. -This means adjusting the indentation to match -the distance between the end of the text and `fill-column'." - (interactive) - (save-excursion - (let (line-length) - (beginning-of-line) - (delete-horizontal-space) - (end-of-line) - (delete-horizontal-space) - (setq line-length (current-column)) - (beginning-of-line) - (indent-to - (+ left-margin - (/ (- fill-column left-margin line-length) 2)))))) - -;;;;;;;;;;; -;; wordstar special variables: - -(defvar ws-marker-0 nil "Position marker 0 in WordStar mode.") -(defvar ws-marker-1 nil "Position marker 1 in WordStar mode.") -(defvar ws-marker-2 nil "Position marker 2 in WordStar mode.") -(defvar ws-marker-3 nil "Position marker 3 in WordStar mode.") -(defvar ws-marker-4 nil "Position marker 4 in WordStar mode.") -(defvar ws-marker-5 nil "Position marker 5 in WordStar mode.") -(defvar ws-marker-6 nil "Position marker 6 in WordStar mode.") -(defvar ws-marker-7 nil "Position marker 7 in WordStar mode.") -(defvar ws-marker-8 nil "Position marker 8 in WordStar mode.") -(defvar ws-marker-9 nil "Position marker 9 in WordStar mode.") - -(defvar ws-block-begin-marker nil "Beginning of \"Block\" in WordStar mode.") -(defvar ws-block-end-marker nil "End of \"Block\" in WordStar mode.") - -(defvar ws-search-string nil "String of last search in WordStar mode.") -(defvar ws-search-direction t - "Direction of last search in WordStar mode. t if forward, nil if backward.") - -(defvar ws-last-cursorposition nil - "Position before last search etc. in WordStar mode.") - -(defvar ws-last-errormessage nil - "Last error message issued by a WordStar mode function.") - -;;;;;;;;;;; -;; wordstar special functions: - -(defun ws-error (string) - "Report error of a WordStar special function. -Error message is saved in `ws-last-errormessage' for recovery -with C-q w." - (setq ws-last-errormessage string) - (error string)) - -(defun ws-begin-block () - "In WordStar mode: Set block begin marker to current cursor position." - (interactive) - (setq ws-block-begin-marker (point-marker)) - (message "Block begin marker set")) - -(defun ws-show-markers () - "In WordStar mode: Show block markers." - (interactive) - (if (or ws-block-begin-marker ws-block-end-marker) - (save-excursion - (if ws-block-begin-marker - (progn - (goto-char ws-block-begin-marker) - (message "Block begin marker") - (sit-for 2)) - (message "Block begin marker not set") - (sit-for 2)) - (if ws-block-end-marker - (progn - (goto-char ws-block-end-marker) - (message "Block end marker") - (sit-for 2)) - (message "Block end marker not set")) - (message "")) - (message "Block markers not set"))) - -(defun ws-indent-block () - "In WordStar mode: Indent block (not yet implemented)." - (interactive) - (ws-error "Indent block not yet implemented")) - -(defun ws-end-block () - "In WordStar mode: Set block end marker to current cursor position." - (interactive) - (setq ws-block-end-marker (point-marker)) - (message "Block end marker set")) - -(defun ws-print-block () - "In WordStar mode: Print block." - (interactive) - (message "Don't do this. Write block to a file (C-k w) and print this file")) - -(defun ws-mark-word () - "In WordStar mode: Mark current word as block." - (interactive) - (save-excursion - (forward-word 1) - (sit-for 1) - (ws-end-block) - (forward-word -1) - (sit-for 1) - (ws-begin-block))) - -(defun ws-exdent-block () - "I don't know what this (C-k u) should do." - (interactive) - (ws-error "This won't be done -- not yet implemented")) - -(defun ws-move-block () - "In WordStar mode: Move block to current cursor position." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (progn - (kill-region ws-block-begin-marker ws-block-end-marker) - (yank) - (save-excursion - (goto-char (region-beginning)) - (setq ws-block-begin-marker (point-marker)) - (goto-char (region-end)) - (setq ws-block-end-marker (point-marker)))) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - -(defun ws-write-block () - "In WordStar mode: Write block to file." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (let ((filename (read-file-name "Write block to file: "))) - (write-region ws-block-begin-marker ws-block-end-marker filename)) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - - -(defun ws-delete-block () - "In WordStar mode: Delete block." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (progn - (kill-region ws-block-begin-marker ws-block-end-marker) - (setq ws-block-end-marker nil) - (setq ws-block-begin-marker nil)) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - -(defun ws-goto-block-begin () - "In WordStar mode: Go to block begin marker." - (interactive) - (if ws-block-begin-marker - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-block-begin-marker)) - (ws-error "Block begin marker not set"))) - -(defun ws-search (string) - "In WordStar mode: Search string, remember string for repetition." - (interactive "sSearch for: ") - (message "Forward (f) or backward (b)") - (let ((direction - (read-char))) - (cond ((equal (upcase direction) ?F) - (setq ws-search-string string) - (setq ws-search-direction t) - (setq ws-last-cursorposition (point-marker)) - (search-forward string)) - ((equal (upcase direction) ?B) - (setq ws-search-string string) - (setq ws-search-direction nil) - (setq ws-last-cursorposition (point-marker)) - (search-backward string)) - (t (keyboard-quit))))) - -(defun ws-goto-block-end () - "In WordStar mode: Go to block end marker." - (interactive) - (if ws-block-end-marker - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-block-end-marker)) - (ws-error "Block end marker not set"))) - -(defun ws-undo () - "In WordStar mode: Undo and give message about undoing more changes." - (interactive) - (undo) - (message "Repeat C-q l to undo more changes")) - -(defun ws-goto-last-cursorposition () - "In WordStar mode: Go to position before last search." - (interactive) - (if ws-last-cursorposition - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-last-cursorposition)) - (ws-error "No last cursor position available"))) - -(defun ws-last-error () - "In WordStar mode: repeat last error message. -This will only work for errors raised by WordStar mode functions." - (interactive) - (if ws-last-errormessage - (message "%s" ws-last-errormessage) - (message "No WordStar error yet"))) - -(defun ws-kill-eol () - "In WordStar mode: Kill to end of line (like WordStar, not like Emacs)." - (interactive) - (let ((p (point))) - (end-of-line) - (kill-region p (point)))) - -(defun ws-kill-bol () - "In WordStar mode: Kill to beginning of line (like WordStar, not like Emacs)." - (interactive) - (let ((p (point))) - (beginning-of-line) - (kill-region (point) p))) - -(defun kill-complete-line () - "Kill the complete line." - (interactive) - (beginning-of-line) - (if (eobp) (error "End of buffer")) - (let ((beg (point))) - (forward-line 1) - (kill-region beg (point)))) - -(defun ws-repeat-search () - "In WordStar mode: Repeat last search." - (interactive) - (setq ws-last-cursorposition (point-marker)) - (if ws-search-string - (if ws-search-direction - (search-forward ws-search-string) - (search-backward ws-search-string)) - (ws-error "No search to repeat"))) - -(defun ws-query-replace (from to) - "In WordStar mode: Search string, remember string for repetition." - (interactive "sReplace: \n\ -sWith: " ) - (setq ws-search-string from) - (setq ws-search-direction t) - (setq ws-last-cursorposition (point-marker)) - (query-replace from to)) - -(defun ws-copy-block () - "In WordStar mode: Copy block to current cursor position." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (progn - (copy-region-as-kill ws-block-begin-marker ws-block-end-marker) - (yank) - (save-excursion - (goto-char (region-beginning)) - (setq ws-block-begin-marker (point-marker)) - (goto-char (region-end)) - (setq ws-block-end-marker (point-marker)))) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - -(defmacro ws-set-marker (&rest indices) - (let (n forms) - (while indices - (setq n (pop indices)) - (push `(defun ,(intern (format "ws-set-marker-%d" n)) () - ,(format "In WordStar mode: Set marker %d to current cursor position" n) - (interactive) - (setq ,(intern (format "ws-marker-%d" n)) (point-marker)) - (message ,(format "Marker %d set" n))) - forms)) - `(progn ,@(nreverse forms)))) - -(ws-set-marker 0 1 2 3 4 5 6 7 8 9) - -(defmacro ws-find-marker (&rest indices) - (let (n forms) - (while indices - (setq n (pop indices)) - (push `(defun ,(intern (format "ws-find-marker-%d" n)) () - ,(format "In WordStar mode: Go to marker %d." n) - (interactive) - (if ,(intern (format "ws-marker-%d" n)) - (progn (setq ws-last-cursorposition (point-marker)) - (goto-char ,(intern (format "ws-marker-%d" n)))) - (ws-error ,(format "Marker %d not set" n)))) - forms)) - `(progn ,@(nreverse forms)))) - -(ws-find-marker 0 1 2 3 4 5 6 7 8 9) - -(provide 'ws-mode) - -;;; ws-mode.el ends here diff --git a/lisp/obsolete/yow.el b/lisp/obsolete/yow.el deleted file mode 100644 index eb4c65c4084..00000000000 --- a/lisp/obsolete/yow.el +++ /dev/null @@ -1,94 +0,0 @@ -;;; yow.el --- quote random zippyisms -*- lexical-binding: t; -*- - -;; Copyright (C) 1993-1995, 2000-2024 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik -;; Maintainer: emacs-devel@gnu.org -;; Keywords: games -;; Obsolete-since: 24.4 - -;; 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 3 of the License, 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. If not, see . - -;;; Commentary: - -;; Important pinheadery for GNU Emacs. -;; This file is obsolete. For similar functionality, see -;; fortune.el and cookie1.el. - -;;; Code: - -(require 'cookie1) - -(defgroup yow nil - "Quote random zippyisms." - :prefix "yow-" - :group 'games) - -(defcustom yow-file (expand-file-name "yow.lines" data-directory) - "File containing pertinent pinhead phrases." - :type 'file) - -(defconst yow-load-message "Am I CONSING yet?...") -(defconst yow-after-load-message "I have SEEN the CONSING!!") - -;;;###autoload -(defun yow (&optional insert display) - "Return or display a random Zippy quotation. With prefix arg, insert it." - (interactive "P\np") - (let ((yow (cookie yow-file yow-load-message yow-after-load-message))) - (cond (insert - (insert yow)) - ((not display) - yow) - (t - (message "%s" yow))))) - -(defsubst read-zippyism (prompt &optional require-match) - "Read a Zippyism from the minibuffer with completion, prompting with PROMPT. -If optional second arg is non-nil, require input to match a completion." - (cookie-read prompt yow-file yow-load-message yow-after-load-message - require-match)) - -;;;###autoload -(defun insert-zippyism (&optional zippyism) - "Prompt with completion for a known Zippy quotation, and insert it at point." - (interactive (list (read-zippyism "Pinhead wisdom: " t))) - (insert zippyism)) - -;;;###autoload -(defun apropos-zippy (regexp) - "Return a list of all Zippy quotes matching REGEXP. -If called interactively, display a list of matches." - (interactive "sApropos Zippy (regexp): ") - (cookie-apropos regexp yow-file (called-interactively-p 'interactive))) - - -;; Yowza!! Feed zippy quotes to the doctor. Watch results. -;; fun, fun, fun. Entertainment for hours... -;; -;; written by Kayvan Aghaiepour - -(declare-function doctor-ret-or-read "doctor" (arg)) - -;;;###autoload -(defun psychoanalyze-pinhead () - "Zippy goes to the analyst." - (interactive) - (cookie-doctor yow-file)) - -(provide 'yow) - -;;; yow.el ends here