# HG changeset patch # User Richard M. Stallman # Date 861015149 0 # Node ID bbf1df3de440b70aaf2582aad01a1029fff6e444 # Parent 9a9062be968a4f1314900e32908613f29e0af0b4 Initial revision diff -r 9a9062be968a -r bbf1df3de440 lisp/mail/uce.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/uce.el Mon Apr 14 10:52:29 1997 +0000 @@ -0,0 +1,300 @@ +;;; uce.el --- facilitate reply to unsolicited commercial email + +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: stanislav shalunov +;; Created: 10 Dec 1996 +;; Version: 1.0 +;; Keywords: uce, unsolicited commercial email + +;; This file is part of GNU Emacs. + +;; This program 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 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; without any warranty; without even the implied warranty of +;; merchantability or fitness for a particular purpose. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Code in this file provides semi-automatic means of replying to +;; UCE's you might get. It works currently only with Rmail. If you +;; would like to make it work with other mail readers, Rmail-specific +;; section is marked below. If you want to play with code, would you +;; please grab the newest version from +;; http://math.wisc.edu/~shalunov/uce.el and let me know, if you would +;; like, about your changes so I can incorporate them. I'd appreciate +;; it. + +;; Function uce-reply-to-uce, if called when current message in RMAIL +;; buffer is a UCE, will setup *mail* buffer in the following way: it +;; scans full headers of message for 1) normal return address of +;; sender (From, Reply-To lines); and puts these addresses into To: +;; header, it also puts abuse@offenders.host address there 2) mailhub +;; that first saw this message; and puts address of its postmaster +;; into To: header 3) finally, it looks at Message-Id and adds +;; posmaster of that host to the list of addresses. + +;; Then, we add "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 put template into buffer (customizable message that +;; explains what has happened), customizable signature, and the +;; original message with full headers and envelope for postmasters. +;; Then buffer is left for editing. + +;; The reason that function uce-reply-to-uce is Rmail dependant is +;; that we want full headers of the original message, nothing +;; stripped. If we use normal means of inserting of the original +;; message into *mail* buffer headers like Received: (not really +;; headers, but envelope lines) will be stripped while they bear +;; valuable for us and postmasters information. I do wish that there +;; would be some way to write this function in some portable way, but +;; I am not aware of any. + +;;; Change log: + +;; Dec 10, 1996 -- posted draft version to gnu.sources.emacs + +;; Dec 11, 1996 -- fixed some typos, and Francesco Potorti` +;; 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). + +;;; Setup: + +;; put in your ~./emacs the following line: + +;; (autoload 'uce-reply-to-uce "uce" "Reply to UCEs" t nil) + +;; store this file (uce.el) somewhere in load-path and byte-compile it. + +;;; Variables: + +;; uce-message-text is template that will be inserted into buffer. It +;; has 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 line that separates your message from the UCE +;; that you enclose. + +;; uce-subject-line will be used as subject of outgoing message. If +;; nil, left blank. + +;;; Code: + +(require 'sendmail) +(require 'rmail) + +(defvar 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.") + +(defvar 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. + +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 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.") + +(defvar uce-uce-separator + "----- original unsolicited commercial email follows -----" + "Line that will begin quoting of the UCE. +Value nil means use no separator.") + +(defvar 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.") + +(defvar 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.") + +(defvar uce-subject-line + "Spam alert: unsolicited commercial e-mail" + "Subject of the message that will be sent in response to a UCE.") + +(defun uce-reply-to-uce (&optional ignored) + "Send reply to UCE in Rmail. +UCE stands for unsolicited commercial email. Function will set up reply +buffer with default To: to the sender, his postmaster, his abuse@ +address, and postmaster of the mail relay used." + (interactive "P") + (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 (and in many cases, really are). + (if to + (setq to (format "%s" (mail-strip-quoted-names to))) + (setq 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-match "@" to) + end-of-hostname (string-match "[ ,>]" to first-at-sign) + sender-host (substring to first-at-sign end-of-hostname)) + (if (string-match "\\." 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) + ;; Begin of Rmail dependant section. + (or (get-buffer "RMAIL") + (error "No buffer RMAIL, cannot find UCE")) + (switch-to-buffer "RMAIL") + (save-excursion + (save-restriction + (widen) + (rmail-maybe-set-message-counters) + (copy-region-as-kill (rmail-msgbeg rmail-current-message) + (rmail-msgend rmail-current-message)))) + (switch-to-buffer "*mail*") + (erase-buffer) + (setq temp (point)) + (yank) + (goto-char temp) + (forward-line 2) + (while (looking-at "Summary-Line:\\|Mail-From:") + (forward-line 1)) + (delete-region temp (point)) + ;; Now find the mail hub that first accepted this message. + (while (or (looking-at "Received:") + (looking-at " ") + (looking-at "\t")) + (forward-line 1)) + (while (or (looking-at " ") + (looking-at "\t")) + (forward-line -1)) + ;; Is this always good? It's the only thing I saw when I checked + ;; a few messages. + (search-forward ": from ") + (setq temp (point)) + (search-forward " ") + (forward-char -1) + ;; And add its postmaster to the list of addresses. + (if (string-match "\\." (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. + (search-forward "\nMessage-Id: ") + (search-forward "@") + (setq temp (point)) + (search-forward ">") + (forward-char -1) + (if (string-match "\\." (buffer-substring temp (point))) + (setq to (format "%s, postmaster@%s" + to (buffer-substring temp (point))))) + (search-forward "\n*** EOOH ***\n") + (forward-line -1) + (setq temp (point)) + (search-forward "\n\n" nil t) + (delete-region temp (point)) + ;; End of Rmail 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") + (insert-file "~/.signature") + ;; Function insert-file leaves point where it was, + ;; while we want to place signature in the ``middle'' + ;; of the message. + (exchange-point-and-mark)))) + (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 standart + ;; functions in mail-mode, etc. + (run-hooks 'mail-setup-hook 'uce-setup-hook))) + +(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 -r 9a9062be968a -r bbf1df3de440 lisp/vcursor.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vcursor.el Mon Apr 14 10:52:29 1997 +0000 @@ -0,0 +1,823 @@ +;;; vcursor.el --- manipulate an alternative ("virtual") cursor. + +;; Copyright (C) 1994, 1996 Peter Stephenson + +;; Author: Peter Stephenson +;; Keywords: virtual cursor, display, copying + +;; This program 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 2 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Virtual cursor commands. I got this idea from the old BBC micro. +;; You need Emacs 19 (I have not tried XEmacs) and a windowing +;; system: I have tried X Windows and Oemacs but any system which +;; supports multiple windows should have the ability to run vcursor. +;; In fact, only overlays are required to work, though some of the +;; key-bindings may need changing. +;; +;; This is much easier to use than the instructions are to read. +;; I suggest you simply load it and play around with holding down Ctrl +;; and Shift and pressing up, down, left, right, tab, return, and see +;; what happens. (Find a scratch buffer before using C-S-tab: that +;; toggles copying.) +;; +;; Most of the functions described in this documentation are in +;; parentheses so that if you have the package loaded you can type C-h +;; f on top of them for help. +;; +;; Using the cursor keys with both control and shift held down moves +;; around a virtual cursor, which is initially at point. When active, +;; it appears with an underline through it to distinguish it from the +;; normal cursor. You can then use one of the other commands to copy +;; characters from the location of the virtual cursor to point. This +;; is very useful, for example, when copying some previous text while +;; making changes to it at the same time, since you never have to move +;; the "real" cursor away from where you are inserting. +;; +;; The remaining default key bindings are based around the PC-type +;; cluster found above the cursor keys on a lot of keyboards, the +;; function keys which my limited knowledge of X terminals expects to +;; find at the top. Some functions are duplicated in more obvious +;; places for the X version. +;; +;; All the keybindings require you to hold down control and shift at +;; once. I assumed this combination wouldn't be heavily bound by most +;; people and that it would be easy to type with the left hand. +;; Inevitably it will clash with some other packages, but I can't help +;; that: an intuitive binding is a prerequisite here. See below for +;; other alternatives (search for "Oemacs"). +;; +;; Holding down control and shift and pressing insert (vcursor-copy) +;; copies one character from wherever the virtual cursor is to point; +;; point and the virtual cursor advance in the separate and equal +;; station to which... (etc.). M-C-S-return (vcursor-copy-line) +;; copies to the end of the line instead of just one character, +;; C-S-delete or C-S-remove (vcursor-copy-word) copies a word. +;; +;; A more general way of copying is to use C-S-tab, which is a toggle. +;; In the "on" state, moving the virtual cursor will copy the +;; moved-over text to the normal cursor position (including when going +;; backwards, though each piece of text moved over is copied forwards: +;; compare the behaviour of C-S-up and C-S-left). +;; +;; However, that's just a small part of the magic. If the virtual +;; cursor goes off the display, it will be redisplayed in some other +;; window. (See the function (vcursor-find-window) for details of how +;; this window is chosen.) This gives you fingertip control over two +;; windows at once. +;; +;; C-S-return (vcursor-disable) disables the virtual cursor, removing +;; it so that it starts from point whenever you move it again --- note +;; that simply moving the cursor and virtual cursor on top of one +;; another does not have this effect. +;; +;; If you gave C-S-return a positive prefix arg, it will also delete the +;; window (unless it's the current one). Whenever the virtual cursor +;; goes off-screen in its own window, point in that window is moved as +;; well to restore it to view. (It's easier that way, that's why. +;; However, point doesn't move unless the view in the window does, so +;; it's not tied to the virtual cursor location.) +;; +;; You can also use C-S-return with a negative prefix argument which +;; forces the vcursor to appear at point. This is particularly useful if +;; you actually want to edit in another window but would like to +;; remember the current cursor location for examining or copying from +;; that buffer. (I just hit C-S-right C-S-left, but I'm a hopeless +;; lowbrow.) +;; +;; There is also C-S-f6 (vcursor-other-window) which behaves like +;; C-x o on the virtual rather than the real cursor, except that it +;; will create another window if necessary. +;; +;; The keys C-S-prior (vcursor-scroll-down) and C-S-next +;; (vcursor-scroll-up) (i.e., PageUp and PageDown) will scroll the +;; virtual cursor window, appropriately chosen. They will always +;; create a new window or take over an old one if necessary. +;; Likewise, M-C-S-left and M-C-S-right move you to the +;; beginning or end of a line, C-S-home and C-S-end the +;; beginning or end of a buffer (these are also on M-C-S-up and +;; M-C-S-down for those of us stuck with DEC keyboards). +;; +;; C-S-f7 (vcursor-goto) will take you to the vcursor position +;; (swapping windows if it seems sensible) and (unless you give it a +;; prefix argument) delete the virtual cursor, so this is useful for +;; you to take over editing at the virtual cursor position. It is not +;; an error if the virtual cursor is not active; it simply leaves you +;; at point, because that is where the virtual cursor would start +;; from. +;; +;; In a similar vein, M-C-S-tab (hope your left hand's flexible; +;; C-S-select on DEC keyboards) (vcursor-swap-point) will take you to +;; the virtual cursor position but simultaneously put the virtual +;; cursor at the old cursor position. It is also supposed to ensure +;; that both are visible. +;; +;; C-S-f8 (C-S-find on DEC keyboards) (vcursor-isearch-forward) +;; allows you to do an isearch in another window. It works a bit like +;; vcursor-scroll-*; it moves into another window, calls isearch +;; there, and sets the virtual cursor position to the point found. In +;; other words, it works just like isearch but with the virtual cursor +;; instead of the real one (that's why it's called a "virtual +;; cursor"). While you are isearching, you are editing in the virtual +;; cursor window, but when you have finished you return to where you +;; started. Note that once you are in isearch all the keys are normal +;; --- use C-s, not C-S-f8, to search for the next occurrence. +;; +;; If you set the variable vcursor-auto-disable, then any command +;; which does not involve moving or copying from the virtual cursor +;; causes the virtual cursor to be disabled. If you don't intend to +;; use this, you can comment out the `add-hook' line at the bottom of +;; this file. (This feature partially emulates the way the "copy" key +;; on the BBC micro worked; actually, the copy cursor was homed when +;; you hit return. This was in keeping with the line-by-line way of +;; entering BASIC, but is less appropriate here.) +;; +;; There is a way of moving the virtual cursor using ordinary +;; commands: C-S-f9 (vcursor-execute-key) reads a key string, +;; moves to the virtual cursor position, executes the command bound to +;; the string, then returns to the original point. Thus C-S-f9 M-m +;; moves the virtual cursor back to the first non-whitespace character +;; on its line. As the command is called interactively all the usual +;; ways of passing information to the command called, such as by a +;; prefix argument, are available. C-S-f10 (C-S-x) +;; (vcursor-execute-command) behaves the same way but you enter the +;; name of the command. Of course, only some commands are useful +;; here, mainly simple movement commands. Killing at the virtual +;; cursor position in this way works as well; you can even save +;; another buffer with C-S-f9 C-x C-s. To do anything more +;; complicated, you are better off using M-C-S-tab +;; (vcursor-swap-point), doing whatever it is, then calling M-C-S-tab +;; again. +;; +;; If you want to add your own moving or copying functions you should +;; be able to do this fairly easily with (vcursor-relative-move) and +;; (vcursor-copy) together with (vcursor-get-char-count). If you want to +;; do something in a different window, use (vcursor-window-funcall). +;; +;; There is an alternative set of key bindings which will be used +;; automatically for a PC if Oemacs is detected. This set uses separate +;; control, shift and meta keys with function keys 1 to 10. In +;; particular, movement keys are concentrated on f5 to f8 with (in +;; increasing order of distance travelled) C-, M- and S- as prefixes. +;; See the actual bindings below (search for C-f1). This is because the +;; C-S- prefix is represented by weird key sequences and the set is +;; incomplete; if you don't mind that, some hints are given in comments +;; below. +;; +;; You can specify the usual or the Oemacs bindings by setting the +;; variable vcursor-key-bindings to `xterm' or `oemacs'. You can also set +;; it to nil, in which case vcursor will not make any key bindings +;; and you can define your own. The default is t, which makes vcursor +;; guess (it will use xterm unless it thinks Oemacs is running). The +;; oemacs set will work on an X terminal with function keys, but the +;; xterm set will not work under Oemacs. +;; +;; Un-features: +;; - The vcursor will not move to point-max, since otherwise it would +;; disappear. However, no error is flagged as point-max is a valid +;; point in the buffer. Thus cursor right or down at the second +;; last point in the file does not flag an error, which is inconsistent, +;; and if copying is on the last character (typically newline) will +;; be repeatedly copied. (I've tried making it flag an error +;; instead and that's worse since often the vcursor is sent to +;; point in some other window, which may be point-max.) +;; - The vcursor widens when over a tab character or right at the +;; end of the line. You're welcome to consider this a feature; +;; it's just a part of how overlays work. +;; - The vcursor obscures the real cursor. Creative use of overlays +;; could cure this. +;; - The vcursor does not remember its own previous positions. If +;; you cycle it back into a window it was in before, it will be at +;; point in that window. Often, that is where a previous recenter +;; left point, not where the vcursor was before. +;; (Note, however, that the vcursor does remember where it *is*, +;; even if it's off-screen. This can also lead to surprises, but I +;; don't think it's a bug.) +;; - vcursor-window-funcall could perhaps be smarter about restoring +;; the previous window state on failure. +;; - The logic in vcursor-find-window is rather complicated and +;; therefore bug-prone, though in practice it seems to work OK. +;; +;; Possible enhnacements: +;; It would be easy to implement vcursor-push (save vcursor position +;; as mark and deactivate) and vcursor-pop (deactivate vcursor and +;; move to last pushed position) functions. + +;;; Code: + +(or (memq 'vcursor (face-list)) + (progn + (copy-face 'modeline 'vcursor) + (if (or (fboundp 'oemacs-version) (x-display-color-p)) + (progn + (set-face-foreground 'vcursor "blue") + (set-face-background 'vcursor "cyan"))) + (set-face-underline-p 'vcursor t))) + +(defvar vcursor-auto-disable nil + "*If non-nil, disable the virtual cursor after use. +Any non-vcursor command will force `vcursor-disable' to be called.") + +(defvar vcursor-key-bindings t + "*How to bind keys when vcursor is loaded. +If t (the default), guess; if xterm, use bindings suitable for an +X terminal; if oemacs, use bindings which work on a PC with Oemacs. +If nil, don't define any key bindings.") + +(defvar vcursor-overlay nil + "Overlay for the virtual cursor. +It is nil if that is not enabled.") + +(defvar vcursor-window nil + "Last window to have displayed the virtual cursor. +See the function `vcursor-find-window' for how this is used.") + +(defvar vcursor-last-command nil + "Non-nil if last command was a vcursor command. +The commands `vcursor-copy', `vcursor-relative-move' and the ones for +scrolling set this. It is used by the `vcursor-auto-disable' code.") +;; could do some memq-ing with last-command instead, but this will +;; automatically handle any new commands using the primitives. + +(defvar vcursor-copy-flag nil + "*Non-nil means moving vcursor should copy characters moved over to point.") + +(defvar vcursor-temp-goal-column nil + "Keeps track of temporary goal columns for the virtual cursor.") + +(cond + ((not vcursor-key-bindings)) ;; don't set any key bindings + ((or (eq vcursor-key-bindings 'oemacs) + (and (eq vcursor-key-bindings t) (fboundp 'oemacs-version))) + (global-set-key [C-f1] 'vcursor-toggle-copy) + (global-set-key [C-f2] 'vcursor-copy) + (global-set-key [C-f3] 'vcursor-copy-word) + (global-set-key [C-f4] 'vcursor-copy-line) + + (global-set-key [S-f1] 'vcursor-disable) + (global-set-key [S-f2] 'vcursor-other-window) + (global-set-key [S-f3] 'vcursor-goto) + (global-set-key [S-f4] 'vcursor-swap-point) + + (global-set-key [C-f5] 'vcursor-backward-char) + (global-set-key [C-f6] 'vcursor-previous-line) + (global-set-key [C-f7] 'vcursor-next-line) + (global-set-key [C-f8] 'vcursor-forward-char) + + (global-set-key [M-f5] 'vcursor-beginning-of-line) + (global-set-key [M-f6] 'vcursor-backward-word) + (global-set-key [M-f6] 'vcursor-forward-word) + (global-set-key [M-f8] 'vcursor-end-of-line) + + (global-set-key [S-f5] 'vcursor-beginning-of-buffer) + (global-set-key [S-f6] 'vcursor-scroll-down) + (global-set-key [S-f7] 'vcursor-scroll-up) + (global-set-key [S-f8] 'vcursor-end-of-buffer) + + (global-set-key [C-f9] 'vcursor-isearch-forward) + + (global-set-key [S-f9] 'vcursor-execute-key) + (global-set-key [S-f10] 'vcursor-execute-command) + +;;; Partial dictionary of Oemacs key sequences for you to roll your own, +;;; e.g C-S-up: (global-set-key "\M-[\C-f\M-\C-m" 'vcursor-previous-line) +;;; Sequence: Sends: +;;; "\M-[\C-f\M-\C-m" C-S-up +;;; "\M-[\C-f\M-\C-q" C-S-down +;;; "\M-[\C-fs" C-S-left +;;; "\M-[\C-ft" C-S-right +;;; +;;; "\M-[\C-fw" C-S-home +;;; "\M-[\C-b\C-o" S-tab +;;; "\M-[\C-f\M-\C-r" C-S-insert +;;; "\M-[\C-fu" C-S-end +;;; "\M-[\C-f\M-\C-s" C-S-delete +;;; "\M-[\C-f\M-\C-d" C-S-prior +;;; "\M-[\C-fv" C-S-next +;;; +;;; "\M-[\C-f^" C-S-f1 +;;; "\M-[\C-f_" C-S-f2 +;;; "\M-[\C-f`" C-S-f3 +;;; "\M-[\C-fa" C-S-f4 +;;; "\M-[\C-fb" C-S-f5 +;;; "\M-[\C-fc" C-S-f6 +;;; "\M-[\C-fd" C-S-f7 +;;; "\M-[\C-fe" C-S-f8 +;;; "\M-[\C-ff" C-S-f9 +;;; "\M-[\C-fg" C-S-f10 + ) + (t + (global-set-key [C-S-up] 'vcursor-previous-line) + (global-set-key [C-S-down] 'vcursor-next-line) + (global-set-key [C-S-left] 'vcursor-backward-char) + (global-set-key [C-S-right] 'vcursor-forward-char) + + (global-set-key [C-S-return] 'vcursor-disable) + (global-set-key [C-S-insert] 'vcursor-copy) + (global-set-key [C-S-delete] 'vcursor-copy-word) + (global-set-key [C-S-remove] 'vcursor-copy-word) + (global-set-key [C-S-tab] 'vcursor-toggle-copy) + (global-set-key [C-S-home] 'vcursor-beginning-of-buffer) + (global-set-key [M-C-S-up] 'vcursor-beginning-of-buffer) + (global-set-key [C-S-end] 'vcursor-end-of-buffer) + (global-set-key [M-C-S-down] 'vcursor-end-of-buffer) + (global-set-key [C-S-prior] 'vcursor-scroll-down) + (global-set-key [C-S-next] 'vcursor-scroll-up) + + (global-set-key [C-S-f6] 'vcursor-other-window) + (global-set-key [C-S-f7] 'vcursor-goto) + + (global-set-key [C-S-select] 'vcursor-swap-point) ; DEC keyboards + (global-set-key [M-C-S-tab] 'vcursor-swap-point) + + (global-set-key [C-S-find] 'vcursor-isearch-forward) ; DEC keyboards + (global-set-key [C-S-f8] 'vcursor-isearch-forward) + + (global-set-key [M-C-S-left] 'vcursor-beginning-of-line) + (global-set-key [M-C-S-right] 'vcursor-end-of-line) + + (global-set-key [M-C-S-prior] 'vcursor-backward-word) + (global-set-key [M-C-S-next] 'vcursor-forward-word) + + (global-set-key [M-C-S-return] 'vcursor-copy-line) + + (global-set-key [C-S-f9] 'vcursor-execute-key) + (global-set-key [C-S-f10] 'vcursor-execute-command) + )) + +(defun vcursor-locate () + "Go to the starting point of the virtual cursor. +If that's disabled, don't go anywhere but don't complain." + ;; This is where we go off-mass-shell. Assume there is a + ;; save-excursion to get us back to the pole, er, point. + + (and (overlayp vcursor-overlay) + (overlay-buffer vcursor-overlay) + (set-buffer (overlay-buffer vcursor-overlay)) + (goto-char (overlay-start vcursor-overlay))) + ) + +(defun vcursor-find-window (&optional not-this new-win this-frame) + "Return a suitable window for displaying the virtual cursor. +This is the first window in cyclic order where the vcursor is visible. + +With optional NOT-THIS non-nil never return the current window. + +With NEW-WIN non-nil, display the virtual cursor buffer in another +window if the virtual cursor is not currently visible \(note, however, +that this function never changes window-point\). + +With THIS-FRAME non-nil, don't search other frames for a new window +\(though if the vcursor is already off-frame then its current window is +always considered, and the value of `pop-up-frames' is always respected\). + +Returns nil if the virtual cursor is not visible anywhere suitable. +Set `vcursor-window' to the returned value as a side effect." + + ;; The order of priorities (respecting NOT-THIS) is (1) + ;; vcursor-window if the virtual cursor is visible there (2) any + ;; window displaying the virtual cursor (3) vcursor-window provided + ;; it is still displaying the buffer containing the virtual cursor and + ;; is not selected (4) any unselected window displaying the vcursor + ;; buffer (5) with NEW-WIN, a window selected by display-buffer (so + ;; the variables pop-up-windows and pop-up-frames are significant) + ;; (6) nil. + + (let ((thiswin (selected-window)) winok winbuf) + (save-excursion + (vcursor-locate) + (or (and (window-live-p vcursor-window) + (eq (current-buffer) (window-buffer vcursor-window)) + (not (and not-this (eq thiswin vcursor-window)))) + (setq vcursor-window nil)) + (or (and vcursor-window ; choice 1 + (pos-visible-in-window-p (point) vcursor-window)) + (progn + (walk-windows + (function + (lambda (win) + (and (not winok) + (eq (current-buffer) (window-buffer win)) + (not (and not-this (eq thiswin win))) + (cond + ((pos-visible-in-window-p (point) win) (setq winok win)) + ((eq thiswin win)) + ((not winbuf) (setq winbuf win)))))) + nil (not this-frame)) + (setq vcursor-window + (cond + (winok) ; choice 2 + ((and vcursor-window ; choice 3 + (not (eq thiswin vcursor-window))) vcursor-window) + (winbuf) ; choice 4 + (new-win (display-buffer (current-buffer) t)) ; choice 5 + (t nil))))))) ; default (choice 6) + vcursor-window + ) + +(defun vcursor-toggle-copy (&optional arg nomsg) + "Toggle copying to point when the vcursor is moved. +With a prefix ARG, turn on if non-negative, off if negative. +Display a message unless optional NOMSG is non-nil." + (interactive "P") + (setq vcursor-copy-flag + (cond ((not arg) (not vcursor-copy-flag)) + ((< (prefix-numeric-value arg) 0) nil) + (t)) + vcursor-last-command t) + (or nomsg (message "Copying from the vcursor is now %s." + (if vcursor-copy-flag "on" "off"))) + ) + +(defun vcursor-move (pt) + "Move the virtual cursor to the character to the right of PT. +PT is an absolute location in the current buffer. + +If the new virtual cursor location would not be visible, display it in +another window." + ;; this works even if we're on-mass-shell, but usually we won't be. + + (if (eq pt (point-max)) (setq pt (1- pt))) + (if (vcursor-check t) + (move-overlay vcursor-overlay pt (+ pt 1) (current-buffer)) + (setq vcursor-overlay (make-overlay pt (+ pt 1))) + (overlay-put vcursor-overlay 'face 'vcursor)) + (vcursor-find-window nil t) + ;; vcursor-window now contains the right buffer + (or (pos-visible-in-window-p pt vcursor-window) + (set-window-point vcursor-window pt)) + ) + +(defun vcursor-relative-move (fn &rest args) + "Use FUNCTION with arbitrary ARG1 ... to move the virtual cursor. + +This is called by most of the virtual-cursor motion commands." + (let (text opoint) + (save-excursion + (vcursor-locate) + (setq opoint (point)) + (apply fn args) + (and (eq opoint (point-max)) (eq opoint (point)) + (signal 'end-of-buffer nil)) + (vcursor-move (point)) + (if vcursor-copy-flag (setq text (buffer-substring opoint (point))))) + (if text (insert text))) + (setq vcursor-last-command t) + ) + +(defun vcursor-goto (&optional arg) + "Move the real cursor to the virtual cursor position. +If the virtual cursor is (or was recently) visible in another window, +switch to that first. Without a prefix ARG, disable the virtual +cursor as well." + + (interactive "P") + (and (vcursor-find-window) (select-window vcursor-window)) + (let ((buf (and vcursor-overlay (overlay-buffer vcursor-overlay)))) + (and buf (not (eq (current-buffer) buf)) (switch-to-buffer buf))) + (vcursor-locate) + (or arg (vcursor-disable)) + ) + +(defun vcursor-swap-point () + "Swap the location of point and that of the virtual cursor. + +The virtual cursor window becomes the selected window and the old +window becomes the virtual cursor window. If the virtual cursor would +not be visible otherwise, display it in another window." + + (interactive) + (let ((buf (current-buffer)) (here (point)) (win (selected-window))) + (vcursor-goto) ; will disable the vcursor + (save-excursion + (set-buffer buf) + (setq vcursor-window win) + (vcursor-move here))) +) + +(defun vcursor-scroll-up (&optional n) + "Scroll up the vcursor window ARG lines or near full screen if none. +The vcursor will always appear in an unselected window." + + (interactive "P") + (vcursor-window-funcall 'scroll-up n) +) + +(defun vcursor-scroll-down (&optional n) + "Scroll down the vcursor window ARG lines or near-full screen if none. +The vcursor will always appear in an unselected window." + + (interactive "P") + (vcursor-window-funcall 'scroll-down n) + ) + +(defun vcursor-isearch-forward (&optional rep norecurs) + "Perform forward incremental search in the virtual cursor window. +The virtual cursor is moved to the resulting point; the ordinary +cursor stays where it was." + + (interactive "P") + (vcursor-window-funcall 'isearch-forward rep norecurs) + ) + +(defun vcursor-window-funcall (func &rest args) + "Call FUNC with ARGS ... in a virtual cursor window. +A window other than the currently-selected one will always be used. +The virtual cursor is moved to the value of point when the function +returns." + + (vcursor-find-window t t) + (let ((sw (selected-window)) text) + ;; We can't use save-window-excursion because that would restore + ;; the original display in the window we may want to alter. + (unwind-protect + (let ((here (point))) + (select-window vcursor-window) + (vcursor-locate) + (apply func args) + (if vcursor-copy-flag (setq text (buffer-substring here (point)))) + (vcursor-move (point))) + (select-window sw)) + (if text (insert text))) + (setq vcursor-last-command t) + ) + +(defun vcursor-get-char-count (fn &rest args) + "Apply FN to ARG1 ... and return the number of characters moved. +Point is temporarily set to the virtual cursor position before FN is +called. + +This is called by most of the virtual-cursor copying commands to find +out how much to copy." + + (vcursor-check) + (save-excursion + (set-buffer (overlay-buffer vcursor-overlay)) + (let ((start (goto-char (overlay-start vcursor-overlay)))) + (- (progn (apply fn args) (point)) start))) + ) + +;; Make sure the virtual cursor is active. Unless arg is non-nil, +;; report an error if it is not. +(defun vcursor-check (&optional arg) + (cond + ((and (overlayp vcursor-overlay) (overlay-start vcursor-overlay)) + t) + (arg nil) + (t (error "The virtual cursor is not active now."))) + ) + +(defun vcursor-disable (&optional arg) + "Disable the virtual cursor. +Next time you use it, it will start from point. + +With a positive prefix ARG, the first window in cyclic order +displaying the virtual cursor (or which was recently displaying the +virutal cursor) will be deleted unless it's the selected +window. + +With a negative prefix argument, enable the virtual cursor: make it +active at the same point as the real cursor. + +Copying mode is always turned off: the next use of the vcursor will +not copy text until you turn it on again." + + (interactive "P") + (if (overlayp vcursor-overlay) + (progn + (delete-overlay vcursor-overlay) + (setq vcursor-overlay nil))) + (cond + ((not (vcursor-find-window t))) + ((or (not arg) (< (prefix-numeric-value arg) 0))) + ((delete-window vcursor-window))) + (and arg (< (prefix-numeric-value arg) 0) + (progn + (vcursor-move (point)) + (setq vcursor-window (selected-window)))) + (setq vcursor-copy-flag nil) + ) + +(defun vcursor-other-window (n &optional all-frames) + "Activate the virtual cursor in another window. +This is the next window cylically after one currently showing the +virtual cursor, or else after the current selected window. If there +is no other window, the current window is split. + +Arguments N and optional ALL-FRAMES are the same as with other-window. +ALL-FRAMES is also used to decide whether to split the window." + + (interactive "p") + (if (if (fboundp 'oemacs-version) + (one-window-p nil) + (one-window-p nil all-frames)) + (display-buffer (current-buffer) t)) + (save-excursion + (save-window-excursion + ;; We don't use fancy vcursor-find-window trickery, since we're + ;; quite happy to have the vcursor cycle back into the current + ;; window. + (let ((sw (selected-window)) + (win (vcursor-find-window nil nil (not all-frames)))) + (if win (select-window win)) + ;; else start from here + (other-window n all-frames) + (vcursor-disable -1)))) + ) + +(defun vcursor-compare-windows (&optional arg) + "Call `compare-windows' in the vcursor window. +This has the effect of comparing the vcursor window with whichever +window `next-window' returns there, which may not be the selected one. + +A prefix argument, if any, is passed to `compare-windows'." + (interactive "P") + (vcursor-window-funcall 'compare-windows arg)) + +(defun vcursor-next-line (arg) + "Move the virtual cursor forward ARG lines." + ;; This is next-line rewritten for the vcursor. Maybe it would + ;; be easier simply to rewrite line-move. + (interactive "p") + (let (temporary-goal-column opoint text) + (save-excursion + (vcursor-locate) + (setq temporary-goal-column + (if (or (eq last-command 'vcursor-next-line) + (eq last-command 'vcursor-previous-line)) + (progn + (setq last-command 'next-line) ; trick line-move + vcursor-temp-goal-column) + (if (and track-eol (eolp) + (or (not (bolp)) (eq last-command 'end-of-line))) + 9999 + (current-column))) + opoint (point)) + (line-move arg) + (and (eq opoint (point-max)) (eq opoint (point)) + (signal 'end-of-buffer nil)) + (if vcursor-copy-flag (setq text (buffer-substring opoint (point)))) + (vcursor-move (point)) + (setq vcursor-temp-goal-column temporary-goal-column + vcursor-last-command t)) + (if text (insert text))) + ) + +(defun vcursor-previous-line (arg) + "Move the virtual cursor back ARG lines." + (interactive "p") + (vcursor-next-line (- arg)) + ) + +(defun vcursor-forward-char (arg) + "Move the virtual cursor forward ARG characters." + (interactive "p") + (vcursor-relative-move 'forward-char arg) + ) + +(defun vcursor-backward-char (arg) + "Move the virtual cursor backward ARG characters." + (interactive "p") + (vcursor-relative-move 'backward-char arg) + ) + +(defun vcursor-forward-word (arg) + "Move the virtual cursor forward ARG words." + (interactive "p") + (vcursor-relative-move 'forward-word arg) + ) + +(defun vcursor-backward-word (arg) + "Move the virtual cursor backward ARG words." + (interactive "p") + (vcursor-relative-move 'backward-word arg) + ) + +(defun vcursor-beginning-of-line (arg) + "Move the virtual cursor to beginning of its current line. +ARG is as for `beginning-of-line'." + (interactive "P") + (vcursor-relative-move 'beginning-of-line + (if arg (prefix-numeric-value arg))) + ) + +(defun vcursor-end-of-line (arg) + "Move the virtual cursor to end of its current line. +ARG is as for `end-of-line'." + (interactive "P") + (vcursor-relative-move 'end-of-line + (if arg (prefix-numeric-value arg))) + ) + +(defun vcursor-beginning-of-buffer (&optional arg) + "Move the virtual cursor to the beginning of its buffer. +ARG is as for beginning-of-buffer." + (interactive "P") + (vcursor-relative-move + (lambda (arg) + (goto-char (if arg (/ (* arg (- (point-max) (point-min))) 10) + (point-min)))) + (if arg (prefix-numeric-value arg))) + ) + +(defun vcursor-end-of-buffer (&optional arg) + "Move the virtual cursor to the end of its buffer. +ARG is as for end-of-buffer. + +Actually, the vcursor is moved to the second from last character or it +would be invisible." + (interactive "P") + (vcursor-relative-move + (lambda (arg) + (goto-char (if arg (- (point-max) + (/ (* arg (- (point-max) (point-min))) 10)) + (point-max)))) + (if arg (prefix-numeric-value arg))) + ) + +(defun vcursor-execute-command (cmd) + "Execute COMMAND for the virtual cursor. +COMMAND is called interactively. Not all commands (in fact, only a +small subset) are useful." + (interactive "CCommand: ") + (let (text opoint) + (save-excursion + (vcursor-locate) + (setq opoint (point)) + (call-interactively cmd) + (if vcursor-copy-flag (setq text (buffer-substring opoint (point)))) + (vcursor-move (point))) + (if text (insert text))) + (setq vcursor-last-command t) + ) + +(defun vcursor-execute-key (keys) + "Execute the command bound to KEYS for the virtual cursor. +The command found is called interactively, so prefix argument etc. +are usable." + + (interactive "kKey sequence: ") + (let ((cmd (key-binding keys))) + (if cmd (vcursor-execute-command (key-binding keys)))) + ) + +(defun vcursor-copy (arg) + "Copy ARG characters from the virtual cursor position to point." + (interactive "p") + (vcursor-check) + (insert + (save-excursion + (set-buffer (overlay-buffer vcursor-overlay)) + (let* ((ostart (overlay-start vcursor-overlay)) + (end (+ ostart arg))) + (prog1 + (buffer-substring ostart end) + (vcursor-move end))))) + (setq vcursor-last-command t) +) + +(defun vcursor-copy-word (arg) + "Copy ARG words from the virtual cursor position to point." + (interactive "p") + (vcursor-copy (vcursor-get-char-count 'forward-word arg)) + ) + +(defun vcursor-copy-line (arg) + "Copy up to ARGth line after virtual cursor position. +With no argument, copy to the end of the current line. + +Behaviour with regard to newlines is similar (but not identical) to +`kill-line'; the main difference is that whitespace at the end of the +line is treated like ordinary characters." + + (interactive "P") + (let* ((num (prefix-numeric-value arg)) + (count (vcursor-get-char-count 'end-of-line num))) + (vcursor-copy (if (or (= count 0) arg) (1+ count) count))) + ) + +(defun vcursor-post-command () + (and vcursor-auto-disable (not vcursor-last-command) + vcursor-overlay (vcursor-disable)) + (setq vcursor-last-command nil) + ) + +(add-hook 'post-command-hook 'vcursor-post-command) + +(provide 'vcursor) + +;; vcursor.el ends here