annotate lisp/mouse.el @ 665:fdefd0186b75

[xemacs-hg @ 2001-09-20 06:28:42 by ben] The great integral types renaming. The purpose of this is to rationalize the names used for various integral types, so that they match their intended uses and follow consist conventions, and eliminate types that were not semantically different from each other. The conventions are: -- All integral types that measure quantities of anything are signed. Some people disagree vociferously with this, but their arguments are mostly theoretical, and are vastly outweighed by the practical headaches of mixing signed and unsigned values, and more importantly by the far increased likelihood of inadvertent bugs: Because of the broken "viral" nature of unsigned quantities in C (operations involving mixed signed/unsigned are done unsigned, when exactly the opposite is nearly always wanted), even a single error in declaring a quantity unsigned that should be signed, or even the even more subtle error of comparing signed and unsigned values and forgetting the necessary cast, can be catastrophic, as comparisons will yield wrong results. -Wsign-compare is turned on specifically to catch this, but this tends to result in a great number of warnings when mixing signed and unsigned, and the casts are annoying. More has been written on this elsewhere. -- All such quantity types just mentioned boil down to EMACS_INT, which is 32 bits on 32-bit machines and 64 bits on 64-bit machines. This is guaranteed to be the same size as Lisp objects of type `int', and (as far as I can tell) of size_t (unsigned!) and ssize_t. The only type below that is not an EMACS_INT is Hashcode, which is an unsigned value of the same size as EMACS_INT. -- Type names should be relatively short (no more than 10 characters or so), with the first letter capitalized and no underscores if they can at all be avoided. -- "count" == a zero-based measurement of some quantity. Includes sizes, offsets, and indexes. -- "bpos" == a one-based measurement of a position in a buffer. "Charbpos" and "Bytebpos" count text in the buffer, rather than bytes in memory; thus Bytebpos does not directly correspond to the memory representation. Use "Membpos" for this. -- "Char" refers to internal-format characters, not to the C type "char", which is really a byte. -- For the actual name changes, see the script below. I ran the following script to do the conversion. (NOTE: This script is idempotent. You can safely run it multiple times and it will not screw up previous results -- in fact, it will do nothing if nothing has changed. Thus, it can be run repeatedly as necessary to handle patches coming in from old workspaces, or old branches.) There are two tags, just before and just after the change: `pre-integral-type-rename' and `post-integral-type-rename'. When merging code from the main trunk into a branch, the best thing to do is first merge up to `pre-integral-type-rename', then apply the script and associated changes, then merge from `post-integral-type-change' to the present. (Alternatively, just do the merging in one operation; but you may then have a lot of conflicts needing to be resolved by hand.) Script `fixtypes.sh' follows: ----------------------------------- cut ------------------------------------ files="*.[ch] s/*.h m/*.h config.h.in ../configure.in Makefile.in.in ../lib-src/*.[ch] ../lwlib/*.[ch]" gr Memory_Count Bytecount $files gr Lstream_Data_Count Bytecount $files gr Element_Count Elemcount $files gr Hash_Code Hashcode $files gr extcount bytecount $files gr bufpos charbpos $files gr bytind bytebpos $files gr memind membpos $files gr bufbyte intbyte $files gr Extcount Bytecount $files gr Bufpos Charbpos $files gr Bytind Bytebpos $files gr Memind Membpos $files gr Bufbyte Intbyte $files gr EXTCOUNT BYTECOUNT $files gr BUFPOS CHARBPOS $files gr BYTIND BYTEBPOS $files gr MEMIND MEMBPOS $files gr BUFBYTE INTBYTE $files gr MEMORY_COUNT BYTECOUNT $files gr LSTREAM_DATA_COUNT BYTECOUNT $files gr ELEMENT_COUNT ELEMCOUNT $files gr HASH_CODE HASHCODE $files ----------------------------------- cut ------------------------------------ `fixtypes.sh' is a Bourne-shell script; it uses 'gr': ----------------------------------- cut ------------------------------------ #!/bin/sh # Usage is like this: # gr FROM TO FILES ... # globally replace FROM with TO in FILES. FROM and TO are regular expressions. # backup files are stored in the `backup' directory. from="$1" to="$2" shift 2 echo ${1+"$@"} | xargs global-replace "s/$from/$to/g" ----------------------------------- cut ------------------------------------ `gr' in turn uses a Perl script to do its real work, `global-replace', which follows: ----------------------------------- cut ------------------------------------ : #-*- Perl -*- ### global-modify --- modify the contents of a file by a Perl expression ## Copyright (C) 1999 Martin Buchholz. ## Copyright (C) 2001 Ben Wing. ## Authors: Martin Buchholz <martin@xemacs.org>, Ben Wing <ben@xemacs.org> ## Maintainer: Ben Wing <ben@xemacs.org> ## Current Version: 1.0, May 5, 2001 # 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 XEmacs; see the file COPYING. If not, write to the Free # Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA # 02111-1307, USA. eval 'exec perl -w -S $0 ${1+"$@"}' if 0; use strict; use FileHandle; use Carp; use Getopt::Long; use File::Basename; (my $myName = $0) =~ s@.*/@@; my $usage=" Usage: $myName [--help] [--backup-dir=DIR] [--line-mode] [--hunk-mode] PERLEXPR FILE ... Globally modify a file, either line by line or in one big hunk. Typical usage is like this: [with GNU print, GNU xargs: guaranteed to handle spaces, quotes, etc. in file names] find . -name '*.[ch]' -print0 | xargs -0 $0 's/\bCONST\b/const/g'\n [with non-GNU print, xargs] find . -name '*.[ch]' -print | xargs $0 's/\bCONST\b/const/g'\n The file is read in, either line by line (with --line-mode specified) or in one big hunk (with --hunk-mode specified; it's the default), and the Perl expression is then evalled with \$_ set to the line or hunk of text, including the terminating newline if there is one. It should destructively modify the value there, storing the changed result in \$_. Files in which any modifications are made are backed up to the directory specified using --backup-dir, or to `backup' by default. To disable this, use --backup-dir= with no argument. Hunk mode is the default because it is MUCH MUCH faster than line-by-line. Use line-by-line only when it matters, e.g. you want to do a replacement only once per line (the default without the `g' argument). Conversely, when using hunk mode, *ALWAYS* use `g'; otherwise, you will only make one replacement in the entire file! "; my %options = (); $Getopt::Long::ignorecase = 0; &GetOptions ( \%options, 'help', 'backup-dir=s', 'line-mode', 'hunk-mode', ); die $usage if $options{"help"} or @ARGV <= 1; my $code = shift; die $usage if grep (-d || ! -w, @ARGV); sub SafeOpen { open ((my $fh = new FileHandle), $_[0]); confess "Can't open $_[0]: $!" if ! defined $fh; return $fh; } sub SafeClose { close $_[0] or confess "Can't close $_[0]: $!"; } sub FileContents { my $fh = SafeOpen ("< $_[0]"); my $olddollarslash = $/; local $/ = undef; my $contents = <$fh>; $/ = $olddollarslash; return $contents; } sub WriteStringToFile { my $fh = SafeOpen ("> $_[0]"); binmode $fh; print $fh $_[1] or confess "$_[0]: $!\n"; SafeClose $fh; } foreach my $file (@ARGV) { my $changed_p = 0; my $new_contents = ""; if ($options{"line-mode"}) { my $fh = SafeOpen $file; while (<$fh>) { my $save_line = $_; eval $code; $changed_p = 1 if $save_line ne $_; $new_contents .= $_; } } else { my $orig_contents = $_ = FileContents $file; eval $code; if ($_ ne $orig_contents) { $changed_p = 1; $new_contents = $_; } } if ($changed_p) { my $backdir = $options{"backup-dir"}; $backdir = "backup" if !defined ($backdir); if ($backdir) { my ($name, $path, $suffix) = fileparse ($file, ""); my $backfulldir = $path . $backdir; my $backfile = "$backfulldir/$name"; mkdir $backfulldir, 0755 unless -d $backfulldir; print "modifying $file (original saved in $backfile)\n"; rename $file, $backfile; } WriteStringToFile ($file, $new_contents); } } ----------------------------------- cut ------------------------------------ In addition to those programs, I needed to fix up a few other things, particularly relating to the duplicate definitions of types, now that some types merged with others. Specifically: 1. in lisp.h, removed duplicate declarations of Bytecount. The changed code should now look like this: (In each code snippet below, the first and last lines are the same as the original, as are all lines outside of those lines. That allows you to locate the section to be replaced, and replace the stuff in that section, verifying that there isn't anything new added that would need to be kept.) --------------------------------- snip ------------------------------------- /* Counts of bytes or chars */ typedef EMACS_INT Bytecount; typedef EMACS_INT Charcount; /* Counts of elements */ typedef EMACS_INT Elemcount; /* Hash codes */ typedef unsigned long Hashcode; /* ------------------------ dynamic arrays ------------------- */ --------------------------------- snip ------------------------------------- 2. in lstream.h, removed duplicate declaration of Bytecount. Rewrote the comment about this type. The changed code should now look like this: --------------------------------- snip ------------------------------------- #endif /* The have been some arguments over the what the type should be that specifies a count of bytes in a data block to be written out or read in, using Lstream_read(), Lstream_write(), and related functions. Originally it was long, which worked fine; Martin "corrected" these to size_t and ssize_t on the grounds that this is theoretically cleaner and is in keeping with the C standards. Unfortunately, this practice is horribly error-prone due to design flaws in the way that mixed signed/unsigned arithmetic happens. In fact, by doing this change, Martin introduced a subtle but fatal error that caused the operation of sending large mail messages to the SMTP server under Windows to fail. By putting all values back to be signed, avoiding any signed/unsigned mixing, the bug immediately went away. The type then in use was Lstream_Data_Count, so that it be reverted cleanly if a vote came to that. Now it is Bytecount. Some earlier comments about why the type must be signed: This MUST BE SIGNED, since it also is used in functions that return the number of bytes actually read to or written from in an operation, and these functions can return -1 to signal error. Note that the standard Unix read() and write() functions define the count going in as a size_t, which is UNSIGNED, and the count going out as an ssize_t, which is SIGNED. This is a horrible design flaw. Not only is it highly likely to lead to logic errors when a -1 gets interpreted as a large positive number, but operations are bound to fail in all sorts of horrible ways when a number in the upper-half of the size_t range is passed in -- this number is unrepresentable as an ssize_t, so code that checks to see how many bytes are actually written (which is mandatory if you are dealing with certain types of devices) will get completely screwed up. --ben */ typedef enum lstream_buffering --------------------------------- snip ------------------------------------- 3. in dumper.c, there are four places, all inside of switch() statements, where XD_BYTECOUNT appears twice as a case tag. In each case, the two case blocks contain identical code, and you should *REMOVE THE SECOND* and leave the first.
author ben
date Thu, 20 Sep 2001 06:31:11 +0000
parents 666d73d6ac56
children 79940b592197
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 ;;; mouse.el --- window system-independent mouse support.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 ;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4 ;; Copyright (C) 1995 Tinker Systems
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5 ;; Copyright (C) 1995, 1996, 2000 Ben Wing.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Maintainer: XEmacs Development Team
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 ;; Keywords: mouse, dumped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;; XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;; under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 ;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;; XEmacs is distributed in the hope that it will be useful, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 ;; General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 ;; You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 ;; along with XEmacs; see the file COPYING. If not, write to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25 ;; Boston, MA 02111-1307, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27 ;;; Synched up with: Not synched with FSF. Almost completely divergent.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 ;; This file is dumped with XEmacs (when window system support is compiled in).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
33 ;;; Authorship:
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
34
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
35 ;; Probably originally derived from FSF 19 pre-release.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
36 ;; much hacked upon by Jamie Zawinski and crew, pre-1994.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
37 ;; (only mouse-motion stuff currently remains from that era)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
38 ;; all mouse-track stuff completely rewritten by Ben Wing, 1995-1996.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
39 ;; mouse-eval-sexp and *-inside-extent-p from Stig, 1995.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
40 ;; vertical divider code c. 1998 from ?.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
41
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 ;;; Code:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 (provide 'mouse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 (global-set-key 'button1 'mouse-track)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 (global-set-key '(shift button1) 'mouse-track-adjust)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 (global-set-key '(control button1) 'mouse-track-insert)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 (global-set-key '(control shift button1) 'mouse-track-delete-and-insert)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 (global-set-key '(meta button1) 'mouse-track-do-rectangle)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
51 (global-set-key 'button2 'mouse-track)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 (defgroup mouse nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 "Window system-independent mouse support."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 :group 'editing)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 (defcustom mouse-track-rectangle-p nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 "*If true, then dragging out a region with the mouse selects rectangles
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 instead of simple start/end regions."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 :type 'boolean
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 :group 'mouse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 (defcustom mouse-yank-at-point nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 "*If non-nil, the function `mouse-yank' will yank text at the cursor location.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 Otherwise, the cursor will be moved to the location of the pointer click before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 text is inserted."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 :type 'boolean
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 :group 'mouse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 (defcustom mouse-highlight-text 'context
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 "*Choose the default double-click highlighting behavior.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 If set to `context', double-click will highlight words when the mouse
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73 is at a word character, or a symbol if the mouse is at a symbol
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 character.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 If set to `word', double-click will always attempt to highlight a word.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 If set to `symbol', double-click will always attempt to highlight a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 symbol (the default behavior in previous XEmacs versions)."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 :type '(choice (const context)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 (const word)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 (const symbol))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 :group 'mouse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 (defvar mouse-yank-function 'mouse-consolidated-yank
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 "Function that is called upon by `mouse-yank' to actually insert text.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 (defun mouse-consolidated-yank ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 "Insert the current selection or, if there is none under X insert
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 the X cutbuffer. A mark is pushed, so that the inserted text lies
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 between point and mark."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 (if (and (not (console-on-window-system-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 (and (featurep 'gpm)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 487
diff changeset
93 (not (declare-boundp gpm-minor-mode))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 (yank)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 (push-mark)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 (if (region-active-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 (if (consp zmacs-region-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 ;; pirated code from insert-rectangle in rect.el
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 ;; perhaps that code should be modified to handle a list of extents
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 ;; as the rectangle to be inserted?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 (let ((lines zmacs-region-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 (insertcolumn (current-column))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 (first t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 (push-mark)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 (while lines
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 (or first
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 (forward-line 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 (or (bolp) (insert ?\n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 (move-to-column insertcolumn t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 (setq first nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 (insert (extent-string (car lines)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 (setq lines (cdr lines))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 (insert (extent-string zmacs-region-extent)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 (insert-selection t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 (defun insert-selection (&optional check-cutbuffer-p move-point-event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 "Insert the current selection into buffer at point."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 (interactive "P")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 ;; we fallback to the clipboard if the current selection is not existent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 (let ((text (if check-cutbuffer-p
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
122 (or (get-selection-no-error)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 (get-cutbuffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 (get-selection-no-error 'CLIPBOARD)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 (error "No selection, clipboard or cut buffer available"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 (or (get-selection-no-error)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 (get-selection 'CLIPBOARD)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (cond (move-point-event
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 (mouse-set-point move-point-event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 (push-mark (point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 ((interactive-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 (push-mark (point))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 (insert text)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 (defun mouse-select ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 "Select Emacs window the mouse is on."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 (interactive "@"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 (defun mouse-delete-window ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 "Delete the Emacs window the mouse is on."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 (interactive "@")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 (delete-window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 (defun mouse-keep-one-window ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 "Select Emacs window mouse is on, then kill all other Emacs windows."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 (interactive "@")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 (delete-other-windows))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 (defun mouse-select-and-split ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 "Select Emacs window mouse is on, then split it vertically in half."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 (interactive "@")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 (split-window-vertically nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 (defun mouse-set-point (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 "Select Emacs window mouse is on, and move point to mouse position."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 (interactive "@e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 (let ((window (event-window event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 (pos (event-point event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 (close-pos (event-closest-point event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 (or window (error "not in a window"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 (select-window window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 (if (and pos (> pos 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 ;; If the event was over a text char, it's easy.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 (goto-char (max (min pos (point-max)) (point-min)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 (if (and close-pos (> close-pos 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 (goto-char (max (min close-pos (point-max)) (point-min)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 ;; When the event occurs outside of the frame directly to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 ;; left or right of a modeline, close-point is nil, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 ;; event-over-modeline is also nil. That will drop us to this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 ;; point. So instead of erroring, just return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 (defun mouse-yank (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 "Paste text with the mouse.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 If the variable `mouse-yank-at-point' is nil, then pasting occurs at the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 location of the click; otherwise, pasting occurs at the current cursor
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 location."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 (interactive "e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 (and (not mouse-yank-at-point)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 (mouse-set-point event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 (funcall mouse-yank-function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 (defun click-inside-extent-p (click extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 "Return non-nil if the button event is within the primary selection-extent.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 Return nil otherwise."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 (let ((ewin (event-window click))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 (epnt (event-point click)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 (and ewin
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 epnt
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 (eq (window-buffer ewin)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 (extent-object extent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 (extent-start-position extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 (> epnt (extent-start-position extent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 (> (extent-end-position extent) epnt))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 (defun click-inside-selection-p (click)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 (or (click-inside-extent-p click primary-selection-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 (click-inside-extent-p click zmacs-region-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 (defun point-inside-extent-p (extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 "Return t if point is within the bounds of the primary selection extent.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 Return t is point is at the end position of the extent.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 Return nil otherwise."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 (and extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 (eq (current-buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 (extent-object extent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 (> (point) (extent-start-position extent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 (>= (extent-end-position extent) (point))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 (defun point-inside-selection-p ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 (or (point-inside-extent-p primary-selection-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 (point-inside-extent-p zmacs-region-extent)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
218 (defun mouse-begin-drag-n-drop (event)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
219 "Begin a drag-n-drop operation.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
220 EVENT should be the button event that initiated the drag.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
221 Returns whether a drag was begun."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
222 ;; #### barely implemented.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
223 (when (click-inside-selection-p event)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
224 (cond ((featurep 'offix)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
225 (offix-start-drag-region
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
226 event
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
227 (extent-start-position zmacs-region-extent)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
228 (extent-end-position zmacs-region-extent))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
229 t)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
230 ((featurep 'cde)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
231 ;; should also work with CDE
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
232 (cde-start-drag-region event
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
233 (extent-start-position zmacs-region-extent)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
234 (extent-end-position zmacs-region-extent))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
235 t))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 (defun mouse-eval-sexp (click force-window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 "Evaluate the sexp under the mouse. Usually, this is the last sexp before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 the click, but if you click on a left paren, then it is the sexp beginning
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 with the paren that is evaluated. Also, since strings evaluate to themselves,
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
241 they're fed to `re-search-forward' and the matched region is highlighted until
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 the mouse button is released.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 Perhaps the most useful thing about this function is that the evaluation of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 the expression which is clicked upon is relative not to the window where you
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 click, but to the current window and the current position of point. Thus,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 you can use `mouse-eval-sexp' to interactively test code that acts upon a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 buffer...something you cannot do with the standard `eval-last-sexp' function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 It's also fantastic for debugging regular expressions."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 (interactive "e\nP")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 (let (exp val result-str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 (setq exp (save-window-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 (mouse-set-point click)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 (or (looking-at "(") (forward-sexp -1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 (read (point-marker))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 (cond ((stringp exp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 (if (setq val (re-search-forward exp nil t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 (let* ((oo (make-extent (match-beginning 0) (match-end 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 (set-extent-face oo 'highlight)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 (set-extent-priority oo 1000)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 ;; wait for button release...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 (setq unread-command-event (next-command-event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 (delete-extent oo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 (message "Regex \"%s\" not found" exp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 (ding nil 'quiet)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 (t (setq val (if (fboundp 'eval-interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 (eval-interactive exp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 (eval exp)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 (setq result-str (prin1-to-string val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 ;; #### -- need better test
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 (if (and (not force-window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 (<= (length result-str) (window-width (selected-window))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 (message "%s" result-str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 (with-output-to-temp-buffer "*Mouse-Eval*"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 (pprint val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 (error (prin1 val))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 )))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 (defun mouse-line-length (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 "Print the length of the line indicated by the pointer."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 (interactive "@e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 (mouse-set-point event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 (message "Line length: %d" (- (point-at-eol) (point-at-bol))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 (sleep-for 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 (defun mouse-set-mark (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 "Select Emacs window mouse is on, and set mark at mouse position.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 Display cursor at that position for a second."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 (interactive "@e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 (let ((point-save (point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 (unwind-protect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 (progn (mouse-set-point event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 (push-mark nil t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 (sit-for 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 (goto-char point-save))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 (defun mouse-scroll (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 "Scroll point to the mouse position."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 (interactive "@e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 (mouse-set-point event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 (recenter 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 (scroll-right (event-x event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 (defun mouse-del-char (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 "Delete the char pointed to by the mouse."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 (interactive "@e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 (mouse-set-point event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 (delete-char 1 nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 (defun mouse-kill-line (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 "Kill the line pointed to by the mouse."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 (interactive "@e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 (mouse-set-point event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 (kill-line nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 (defun mouse-bury-buffer (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 "Bury the buffer pointed to by the mouse, thus selecting the next one."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 (interactive "e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 (save-selected-window
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 (select-window (event-window event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 (bury-buffer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 (defun mouse-unbury-buffer (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 "Unbury and select the most recently buried buffer."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 (interactive "e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 (save-selected-window
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 (select-window (event-window event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 (let* ((bufs (buffer-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 (entry (1- (length bufs)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 (while (not (setq val (nth entry bufs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 val (and (/= (aref (buffer-name val) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 ? )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 val)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 (setq entry (1- entry)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 (switch-to-buffer val))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 (defun narrow-window-to-region (m n)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
346 "Narrow window to region between point and last mark."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 (interactive "r")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 (save-restriction
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 (if (eq (selected-window) (next-window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 (split-window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 (goto-char m)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 (recenter 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 (if (eq (selected-window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 (if (zerop (minibuffer-depth))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 (next-window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358 (shrink-window (- (- (window-height) (count-lines m n)) 1))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 (defun mouse-window-to-region (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 "Narrow window to region between cursor and mouse pointer."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 (interactive "@e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 (let ((point-save (point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 (unwind-protect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 (progn (mouse-set-point event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 (push-mark nil t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 (sit-for 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 (goto-char point-save)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 (narrow-window-to-region (region-beginning) (region-end)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 (defun mouse-ignore ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 "Don't do anything."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 (interactive))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 ;;; mouse/selection tracking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 ;;; generalized mouse-track
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 (defvar default-mouse-track-normalize-point-function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 'default-mouse-track-normalize-point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 "Function called to normalize position of point.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 Called with two arguments: TYPE depends on the number of times that the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 mouse has been clicked and is a member of `default-mouse-track-type-list',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 FORWARDP determines the direction in which the point should be moved.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 (defvar mouse-track-down-hook nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 "Function or functions called when the user presses the mouse.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 This hook is invoked by `mouse-track'; thus, it will not be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 for any buttons with a different binding. The functions will be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 called with two arguments: the button-press event and a click
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 count (see `mouse-track-click-hook').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 If any function returns non-nil, the remaining functions will not be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 Note that most applications should take action when the mouse is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 released, not when it is pressed.'")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 (defvar mouse-track-drag-hook nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 "Function or functions called when the user drags the mouse.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 This hook is invoked by `mouse-track'; thus, it will not be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 for any buttons with a different binding. The functions will be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 called with three arguments: the mouse-motion event, a click
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 count (see `mouse-track-click-hook'), and whether the call to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 this hook occurred as a result of a drag timeout (see
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 `mouse-track-scroll-delay').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 If any function returns non-nil, the remaining functions will not be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 Note that no calls to this function will be made until the user
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 initiates a drag (i.e. moves the mouse more than a certain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 threshold in either the X or the Y direction, as defined by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 `mouse-track-x-threshold' and `mouse-track-y-threshold').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 See also `mouse-track-drag-up-hook'.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 (defvar mouse-track-drag-up-hook nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 "Function or functions called when the user finishes a drag.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 This hook is invoked by `mouse-track'; thus, it will not be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 for any buttons with a different binding. The functions will be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 called with two arguments: the button-press event and a click
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 count (see `mouse-track-click-hook').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 If any function returns non-nil, the remaining functions will not be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 Note that this hook will not be invoked unless the user has
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 initiated a drag, i.e. moved the mouse more than a certain threshold
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 (see `mouse-track-drag-hook'). When this function is invoked,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 `mouse-track-drag-hook' will have been invoked at least once.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 See also `mouse-track-click-hook'.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 (defvar mouse-track-click-hook nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 "Function or functions called when the user clicks the mouse.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 `Clicking' means pressing and releasing the mouse without having
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 initiated a drag (i.e. without having moved more than a certain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 threshold -- see `mouse-track-drag-hook').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 This hook is invoked by `mouse-track'; thus, it will not be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 for any buttons with a different binding. The functions will be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 called with two arguments: the button-release event and a click
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 count, which specifies the number of times that the mouse has been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 clicked in a series of clicks, each of which is separated by at most
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 `mouse-track-multi-click-time'. This can be used to implement actions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 that are called on double clicks, triple clicks, etc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 If any function returns non-nil, the remaining functions will not be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 See also `mouse-track-drag-up-hook.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 (defvar mouse-track-up-hook nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 "Function or functions called when the user releases the mouse.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 This hook is invoked by `mouse-track'; thus, it will not be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 for any buttons with a different binding. The functions will be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 called with two arguments: the button-release event and a click
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 count (see `mouse-track-click-hook').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 For many applications, it is more appropriate to use one or both
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 of `mouse-track-click-hook' and `mouse-track-drag-up-hook'.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 (defvar mouse-track-cleanup-hook nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 "Function or functions called when `mouse-track' terminates.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 This hook will be called in all circumstances, even upon a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 non-local exit out of `mouse-track', and so is useful for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 doing cleanup work such as removing extents that may have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 been created during the operation of `mouse-track'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 Unlike all of the other mouse-track hooks, this is a \"normal\"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 hook: the hook functions are called with no arguments, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 all hook functions are called regardless of their return
479
52626a2f02ef [xemacs-hg @ 2001-04-20 11:31:53 by ben]
ben
parents: 446
diff changeset
474 values.
52626a2f02ef [xemacs-hg @ 2001-04-20 11:31:53 by ben]
ben
parents: 446
diff changeset
475
52626a2f02ef [xemacs-hg @ 2001-04-20 11:31:53 by ben]
ben
parents: 446
diff changeset
476 This function is called with the buffer where the mouse was clicked
52626a2f02ef [xemacs-hg @ 2001-04-20 11:31:53 by ben]
ben
parents: 446
diff changeset
477 set to the current buffer, unless that buffer was killed.")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 (defcustom mouse-track-multi-click-time 400
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 "*Maximum number of milliseconds allowed between clicks for a multi-click.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 See `mouse-track-click-hook'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 :type 'integer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 :group 'mouse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 (defcustom mouse-track-scroll-delay 100
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 "Maximum of milliseconds between calls to `mouse-track-drag-hook'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 If the user is dragging the mouse (i.e. the button is held down and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 a drag has been initiated) and does not move the mouse for this many
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 milliseconds, the hook will be called with t as the value of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 WAS-TIMEOUT parameter. This can be used to implement scrolling
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 in a selection when the user drags the mouse out the window it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 was in.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 A value of nil disables the timeout feature."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 :type '(choice integer (const :tag "Disabled" nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 :group 'mouse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
498 (defcustom mouse-track-activate-strokes '(button1-double-click button2-click)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
499 "List of mouse strokes that can cause \"activation\" of the text extent
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
500 under the mouse. The exact meaning of \"activation\" is dependent on the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
501 text clicked on and the mode of the buffer, but typically entails actions
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
502 such as following a hyperlink or selecting an entry in a completion buffer.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
503
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
504 Possible list entries are
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
505
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
506 button1-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
507 button1-double-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
508 button1-triple-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
509 button1-down
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
510 button2-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
511 button2-double-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
512 button2-triple-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
513 button2-down
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
514
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
515 As a general rule, you should not use the \"-down\" values, because this
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
516 makes it impossible to have other simultaneous actions, such as selection."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
517 :type '(set
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
518 button1-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
519 button1-double-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
520 button1-triple-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
521 button1-down
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
522 button2-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
523 button2-double-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
524 button2-triple-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
525 button2-down)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
526 :group 'mouse)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
527
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528 (defvar mouse-track-x-threshold '(face-width 'default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 "Minimum number of pixels in the X direction for a drag to be initiated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 If the mouse is moved more than either the X or Y threshold while the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 button is held down (see also `mouse-track-y-threshold'), then a drag
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 is initiated; otherwise the gesture is considered to be a click.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 See `mouse-track'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534
539
eec22eb29327 [xemacs-hg @ 2001-05-14 10:00:08 by adrian]
adrian
parents: 502
diff changeset
535 The value should be either a number or a form to be evaluated to
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 produce a number.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 (defvar mouse-track-y-threshold '(face-height 'default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 "Minimum number of pixels in the Y direction for a drag to be initiated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 If the mouse is moved more than either the X or Y threshold while the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 button is held down (see also `mouse-track-x-threshold'), then a drag
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 is initiated; otherwise the gesture is considered to be a click.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 See `mouse-track'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 The value should be either a number of a form to be evaluated to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 produce a number.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 ;; these variables are private to mouse-track.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 (defvar mouse-track-up-time nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 (defvar mouse-track-up-x nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 (defvar mouse-track-up-y nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 (defvar mouse-track-timeout-id nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 (defvar mouse-track-click-count nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 (defun mouse-track-set-timeout (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 (if mouse-track-timeout-id
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 (disable-timeout mouse-track-timeout-id))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 (if mouse-track-scroll-delay
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 (setq mouse-track-timeout-id
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 (add-timeout (/ mouse-track-scroll-delay 1000.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 'mouse-track-scroll-undefined
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 (copy-event event)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
564 (defun mouse-track-do-activate (event)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
565 "Execute the activate function under EVENT, if any.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
566 Return true if the function was activated."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
567 (let ((ex (extent-at-event event 'activate-function)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
568 (when ex
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
569 (funcall (extent-property ex 'activate-function)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
570 event ex)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
571 t)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
572
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
573 (defvar Mouse-track-gensym (gensym))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
574
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
575 (defun mouse-track-run-hook (hook override event &rest args)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 ;; ugh, can't use run-hook-with-args-until-success because we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 ;; to get the value using symbol-value-in-buffer. Doing a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 ;; save-excursion/set-buffer is wrong because the hook might want to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 ;; change the buffer, but just doing a set-buffer is wrong because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 ;; the hook might not want to change the buffer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 ;; #### What we need here is a Lisp interface to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 ;; run_hook_with_args_in_buffer. Here is a poor man's version.
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
583 (let ((overridden (plist-get override hook Mouse-track-gensym)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
584 (if (not (eq overridden Mouse-track-gensym))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
585 (if (and (listp overridden) (not (eq (car overridden) 'lambda)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
586 (some #'(lambda (val) (apply val event args)) overridden)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
587 (apply overridden event args))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
588 (let ((buffer (event-buffer event)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
589 (and mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
590 (when buffer
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
591 (let ((value (symbol-value-in-buffer hook buffer nil)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
592 (if (and (listp value) (not (eq (car value) 'lambda)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
593 ;; List of functions.
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
594 (let (retval)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
595 (while (and value (null retval))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
596 ;; Found `t': should process default value. We could
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
597 ;; splice it into the buffer-local value, but that
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
598 ;; would cons, which is not a good thing for
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
599 ;; mouse-track hooks.
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
600 (if (eq (car value) t)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
601 (let ((global (default-value hook)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
602 (if (and (listp global) (not (eq (car global)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
603 'lambda)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
604 ;; List of functions.
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
605 (while (and global
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
606 (null (setq retval
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
607 (apply (car global)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
608 event args))))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
609 (pop global))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
610 ;; lambda
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
611 (setq retval (apply (car global) event args))))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
612 (setq retval (apply (car value) event args)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
613 (pop value))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
614 retval)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
615 ;; lambda
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
616 (apply value event args))))))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 (defun mouse-track-scroll-undefined (random)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 ;; the old implementation didn't actually define this function,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 ;; and in normal use it won't ever be called because the timeout
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 ;; will either be removed before it fires or will be picked off
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 ;; with next-event and not dispatched. However, if you're
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 ;; attempting to debug a click-hook (which is pretty damn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 ;; difficult to do), this function may get called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
627 (defun mouse-track (event &optional overriding-hooks)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
628 "Generalized mouse-button handler. This should be bound to a mouse button.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
629 The behavior of this function is customizable using various hooks and
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
630 variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 `mouse-track-cleanup-hook', `mouse-track-multi-click-time',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 `mouse-track-scroll-delay', `mouse-track-x-threshold', and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 `mouse-track-y-threshold'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 Default handlers are provided to implement standard selecting/positioning
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 behavior. You can explicitly request this default behavior, and override
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 any custom-supplied handlers, by using the function `mouse-track-default'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 instead of `mouse-track'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
641 \(In general, you can override specific hooks by using the argument
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
642 OVERRIDING-HOOKS, which should be a plist of alternating hook names
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
643 and values.)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
644
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 Default behavior is as follows:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 If you click-and-drag, the selection will be set to the region between the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 point of the initial click and the point at which you release the button.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 These positions need not be ordered.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 If you click-and-release without moving the mouse, then the point is moved
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 and the selection is disowned (there will be no selection owner). The mark
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 will be set to the previous position of point.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 If you double-click, the selection will extend by symbols instead of by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 characters. If you triple-click, the selection will extend by lines.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 If you drag the mouse off the top or bottom of the window, you can select
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 pieces of text which are larger than the visible part of the buffer; the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 buffer will scroll as necessary.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 The selected text becomes the current X Selection. The point will be left
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 at the position at which you released the button, and the mark will be left
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 at the initial click position."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 (interactive "e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 (let ((mouse-down t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 (xthresh (eval mouse-track-x-threshold))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 (ythresh (eval mouse-track-y-threshold))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 (orig-x (event-x-pixel event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 (orig-y (event-y-pixel event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 (buffer (event-buffer event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 (mouse-grabbed-buffer (event-buffer event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 mouse-moved)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 (if (or (not mouse-track-up-x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 (not mouse-track-up-y)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 (not mouse-track-up-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 (> (- (event-timestamp event) mouse-track-up-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 mouse-track-multi-click-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 (> (abs (- mouse-track-up-x orig-x)) xthresh)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 (> (abs (- mouse-track-up-y orig-y)) ythresh))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 (setq mouse-track-click-count 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 (setq mouse-track-click-count (1+ mouse-track-click-count)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 (if (not (event-window event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 (error "Not over a window."))
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
685 (mouse-track-run-hook 'mouse-track-down-hook overriding-hooks
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 event mouse-track-click-count)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 (unwind-protect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 (while mouse-down
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 (setq event (next-event event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 (cond ((motion-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 (if (and (not mouse-moved)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 (or (> (abs (- (event-x-pixel event) orig-x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 xthresh)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 (> (abs (- (event-y-pixel event) orig-y))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 ythresh)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 (setq mouse-moved t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 (if mouse-moved
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 (mouse-track-run-hook 'mouse-track-drag-hook
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
699 overriding-hooks
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
700 event mouse-track-click-count nil))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 (mouse-track-set-timeout event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 ((and (timeout-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 (eq (event-function event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 'mouse-track-scroll-undefined))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 (if mouse-moved
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 (mouse-track-run-hook 'mouse-track-drag-hook
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
707 overriding-hooks
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
708 (event-object event)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
709 mouse-track-click-count t))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 (mouse-track-set-timeout (event-object event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 ((button-release-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 (setq mouse-track-up-time (event-timestamp event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 (setq mouse-track-up-x (event-x-pixel event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 (setq mouse-track-up-y (event-y-pixel event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 (setq mouse-down nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 (mouse-track-run-hook 'mouse-track-up-hook
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
717 overriding-hooks
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
718 event mouse-track-click-count)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 (if mouse-moved
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 (mouse-track-run-hook 'mouse-track-drag-up-hook
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
721 overriding-hooks
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
722 event mouse-track-click-count)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 (mouse-track-run-hook 'mouse-track-click-hook
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
724 overriding-hooks
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
725 event mouse-track-click-count)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 ((or (key-press-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 (and (misc-user-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 (eq (event-function event) 'cancel-mode-internal)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 (error "Selection aborted"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 (dispatch-event event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 ;; protected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 (if mouse-track-timeout-id
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 (disable-timeout mouse-track-timeout-id))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 (setq mouse-track-timeout-id nil)
479
52626a2f02ef [xemacs-hg @ 2001-04-20 11:31:53 by ben]
ben
parents: 446
diff changeset
736 (and (buffer-live-p buffer)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 (set-buffer buffer)
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
739 (let ((override (plist-get overriding-hooks
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
740 'mouse-track-cleanup-hook
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
741 Mouse-track-gensym)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
742 (if (not (eq override Mouse-track-gensym))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
743 (if (and (listp override) (not (eq (car override) 'lambda)))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
744 (mapc #'funcall override)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
745 (funcall override))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
746 (run-hooks 'mouse-track-cleanup-hook))))))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 ;;;;;;;;;;;; default handlers: new version of mouse-track
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 (defvar default-mouse-track-type nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 (defvar default-mouse-track-type-list '(char word line))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 (defvar default-mouse-track-window nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 (defvar default-mouse-track-extent nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 (defvar default-mouse-track-adjust nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 (defvar default-mouse-track-min-anchor nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 (defvar default-mouse-track-max-anchor nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 (defvar default-mouse-track-result nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759 (defvar default-mouse-track-down-event nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 ;; D. Verna Feb. 17 1998
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 ;; This function used to assume that when (event-window event) differs from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763 ;; window, we have to scroll. This is WRONG, for instance when there are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 ;; toolbars on the side, in which case window-event returns nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 (defun default-mouse-track-set-point-in-window (event window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 (if (event-over-modeline-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 nil ;; Scroll
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768 ;; Not over a modeline
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 (if (eq (event-window event) window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 (let ((p (event-closest-point event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 (if (or (not p) (not (pos-visible-in-window-p p window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 nil ;; Scroll
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 (mouse-set-point event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 ;; Not over a modeline, not the same window. Check if the Y position
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776 ;; is still overlapping the original window.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 (let* ((edges (window-pixel-edges window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 (row (event-y-pixel event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 (text-start (nth 1 edges))
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
780 (text-end (nth 3 edges)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781 (if (or (< row text-start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 (> row text-end))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 nil ;; Scroll
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 ;; The Y pos in overlapping the original window. Check however if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 ;; the position is really visible, because there could be a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 ;; scrollbar or a modeline at this place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 ;; Find the mean line height (height / lines nb), and approximate
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 ;; the line number for Y pos.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 (select-window window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 (let ((line (/ (* (- row text-start) (window-height))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791 (- text-end text-start))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 (if (not (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 (goto-char (window-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 (pos-visible-in-window-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 (point-at-bol (+ 1 line)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796 nil ;; Scroll
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 ;; OK, we can go to that position
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 (goto-char (window-start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 (forward-line line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 ;; On the right side: go to end-of-line.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 (when (>= (event-x-pixel event) (nth 2 edges))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 (goto-char (point-at-eol)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 )))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 (defun default-mouse-track-scroll-and-set-point (event window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 (select-window window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 (let ((edges (window-pixel-edges window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 (row (event-y-pixel event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 (height (face-height 'default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 (cond ((< (abs (- row (nth 1 edges))) (abs (- row (nth 3 edges))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 ;; closer to window's top than to bottom, so move up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 (let ((delta (max 1 (/ (- (nth 1 edges) row) height))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 (condition-case () (scroll-down delta) (error))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 (goto-char (window-start))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 ((>= (point) (point-max)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 ;; scroll by one line if over the modeline or a clipped line
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 (let ((delta (if (or (event-over-modeline-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 (< row (nth 3 edges)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 (+ (/ (- row (nth 3 edges)) height) 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 (close-pos (event-closest-point event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 (condition-case () (scroll-up delta) (error))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 (if (and close-pos (pos-visible-in-window-p close-pos))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 (goto-char close-pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 (goto-char (window-end))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 (vertical-motion delta)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 ;; window-end reports the end of the clipped line, even if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 ;; scroll-on-clipped-lines is t. compensate.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 ;; (If window-end gets fixed this can be removed.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 (if (not (pos-visible-in-window-p (max (1- (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 (point-min))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 (vertical-motion -1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 (condition-case () (backward-char 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 (error (end-of-line)))))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 ;; This remembers the last position at which the user clicked, for the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 ;; benefit of mouse-track-adjust (for example, button1; scroll until the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 ;; position of the click is off the frame; then Sh-button1 to select the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 ;; new region.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 (defvar default-mouse-track-previous-point nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 (defun default-mouse-track-set-point (event window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 (if (default-mouse-track-set-point-in-window event window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 (default-mouse-track-scroll-and-set-point event window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 (defsubst default-mouse-track-beginning-of-word (symbolp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 ((null symbolp) "\\w")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 (t "[^ \t\n]")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 (white-space "[ \t]"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 (cond ((bobp) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 ((looking-at word-constituent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858 (backward-char)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 (while (and (not (bobp)) (looking-at word-constituent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 (backward-char))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 (if (or (not (bobp)) (not (looking-at word-constituent)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 (forward-char)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 ((looking-at white-space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 (backward-char)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 (while (looking-at white-space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 (backward-char))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 (forward-char)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 (defun default-mouse-track-end-of-word (symbolp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 ((null symbolp) "\\w")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 (t "[^ \t\n]")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 (white-space "[ \t]"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 (cond ((looking-at word-constituent) ; word or symbol constituent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 (while (looking-at word-constituent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 (forward-char)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 ((looking-at white-space) ; word or symbol constituent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 (while (looking-at white-space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 (forward-char))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 ;; Decide what will be the SYMBOLP argument to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 ;; default-mouse-track-{beginning,end}-of-word, according to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 ;; syntax of the current character and value of mouse-highlight-text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 (defsubst default-mouse-track-symbolp (syntax)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 (cond ((eq mouse-highlight-text 'context)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 (eq syntax ?_))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 ((eq mouse-highlight-text 'symbol)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 ;; Return t if point is at an opening quote character. This is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 ;; determined by testing whether the syntax of the following character
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 ;; is `string', which will always be true for opening quotes and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 ;; always false for closing quotes.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 (defun default-mouse-track-point-at-opening-quote-p ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 (forward-char 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 (eq (buffer-syntactic-context) 'string)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 (defun default-mouse-track-normalize-point (type forwardp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 (cond ((eq type 'word)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 ;; trap the beginning and end of buffer errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904 (ignore-errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 (setq type (char-syntax (char-after (point))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 (if forwardp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 (if (or (= type ?\()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 (and (= type ?\")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 (default-mouse-track-point-at-opening-quote-p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 (goto-char (scan-sexps (point) 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911 (default-mouse-track-end-of-word
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
912 (default-mouse-track-symbolp type)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
913 (if (or (= type ?\))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914 (and (= type ?\")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 (not (default-mouse-track-point-at-opening-quote-p))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 (goto-char (scan-sexps (1+ (point)) -1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 (default-mouse-track-beginning-of-word
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918 (default-mouse-track-symbolp type))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 ((eq type 'line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 (if forwardp (end-of-line) (beginning-of-line)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 ((eq type 'buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 (if forwardp (end-of-buffer) (beginning-of-buffer)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 (defun default-mouse-track-next-move (min-anchor max-anchor extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 (let ((anchor (if (<= (point) min-anchor) max-anchor min-anchor)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 (funcall default-mouse-track-normalize-point-function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 default-mouse-track-type (> (point) anchor))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928 (if (consp extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 (default-mouse-track-next-move-rect anchor (point) extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 (if extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 (if (<= anchor (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 (set-extent-endpoints extent anchor (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 (set-extent-endpoints extent (point) anchor))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 (defun default-mouse-track-next-move-rect (start end extents &optional pad-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 (if (< end start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 (let ((tmp start)) (setq start end end tmp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 ((= start end) ; never delete the last remaining extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 (mapcar 'delete-extent (cdr extents))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 (setcdr extents nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 (set-extent-endpoints (car extents) start start))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 (let ((indent-tabs-mode nil) ; if pad-p, don't use tabs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 (rest extents)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 left right last p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 (save-restriction
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 (goto-char end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950 (setq right (current-column))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951 (goto-char start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 (setq left (current-column))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 (if (< right left)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 (let ((tmp left))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 (setq left right right tmp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 (setq start (- start (- right left))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 end (+ end (- right left)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 ;; End may have been set to a value greater than point-max if drag
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 ;; or movement extends to end of buffer, so reset it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 (setq end (min end (point-max)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 (beginning-of-line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 (narrow-to-region (point) end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 (goto-char start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 (while (and rest (not (eobp)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 (setq p (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 (move-to-column right pad-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967 (set-extent-endpoints (car rest) p (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 ;; this code used to look at the return value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969 ;; of forward-line, but that doesn't work because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 ;; forward-line has bogus behavior: If you're on
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 ;; the last line of a buffer but not at the very
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 ;; end, forward-line will move you to the very
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 ;; end and return 0 instead of 1, like it should.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 ;; the result was frequent infinite loops here,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 ;; creating very large numbers of extents at
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 ;; the same position. There was an N^2 sorting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 ;; algorithm in extents.c for extents at a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 ;; particular position, and the result was very
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 ;; bad news.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 (forward-line 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 (if (not (eobp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 (move-to-column left pad-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 (setq last rest
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 rest (cdr rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 (cond (rest
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 (mapcar 'delete-extent rest)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 (setcdr last nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 ((not (eobp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 (while (not (eobp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 (setq p (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 (move-to-column right pad-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 (let ((e (make-extent p (point))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 (set-extent-face e (extent-face (car extents)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 (set-extent-priority e (extent-priority (car extents)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 (setcdr last (cons e nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 (setq last (cdr last)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 (forward-line 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 (if (not (eobp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 (move-to-column left pad-p))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 )))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 ))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 (defun default-mouse-track-has-selection-p (buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 (and (selection-owner-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005 (extent-live-p primary-selection-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006 (not (extent-detached-p primary-selection-extent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 (eq buffer (extent-object primary-selection-extent))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 (defun default-mouse-track-anchor (adjust previous-point)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 (if adjust
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 (if (default-mouse-track-has-selection-p (current-buffer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 (let ((start (extent-start-position primary-selection-extent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1013 (end (extent-end-position primary-selection-extent)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 (cond ((< (point) start) end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 ((> (point) end) start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 ((> (- (point) start) (- end (point))) start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017 (t end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 previous-point)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019 (point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021 (defun default-mouse-track-maybe-own-selection (pair type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022 (let ((start (car pair))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1023 (end (cdr pair)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1024 (or (= start end) (push-mark (if (= (point) start) end start)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1025 (cond (zmacs-regions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026 (if (= start end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 ;; #### UTTER KLUDGE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029 ;; If we don't have this sit-for here, then triple-clicking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 ;; will result in the line not being highlighted as it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 ;; should. What appears to be happening is this:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 ;; -- each time the button goes down, the selection is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 ;; disowned (see comment "remove the existing selection
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1035 ;; to unclutter the display", below).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 ;; -- this causes a SelectionClear event to be sent to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037 ;; XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038 ;; -- each time the button goes up except the first, the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039 ;; selection is owned again.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1040 ;; -- later, XEmacs processes the SelectionClear event.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 ;; The selection code attempts to keep track of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042 ;; time that it last asserted the selection, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043 ;; compare it to the time of the SelectionClear event,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1044 ;; to see if it's a bogus notification or not (as
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045 ;; is the case here). However, for some unknown
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 ;; reason this doesn't work in the triple-clicking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1047 ;; case, and the selection code bogusly thinks this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1048 ;; SelectionClear event is the real thing.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1049 ;; -- putting the sit-for in causes the pending
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1050 ;; SelectionClear events to get processed before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 ;; the selection is reasserted, so everything works
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 ;; out OK.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054 ;; Presumably(?) this means there is a weird timing bug
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1055 ;; in the selection code, but there's not a chance in hell
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1056 ;; that I have the patience to track it down. Blame the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 ;; designers of X for fucking everything up so badly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1058 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059 ;; This was originally a sit-for 0 but that wasn't
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1060 ;; sufficient to make things work. Even this isn't
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 ;; always sufficient but it seems to give something
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062 ;; approaching a 99% success rate. Making it higher yet
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063 ;; would help guarantee success with the price that the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 ;; delay would start to become noticeable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1065 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1066 (and (eq (console-type) 'x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 (sit-for 0.15 t))
487
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1068 ;; zmacs-activate-region -> zmacs-activate-region-hook ->
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1069 ;; activate-region-as-selection -> either own-selection or
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1070 ;; mouse-track-activate-rectangular-selection
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 (zmacs-activate-region)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1072 ((console-on-window-system-p)
487
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1073 ;; #### do we need this? we don't do it when zmacs-regions = t
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 (if (= start end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 (disown-selection type)
487
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1076 (activate-region-as-selection))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1077 (if (and (eq 'x (console-type))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 (not (= start end)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079 ;; I guess cutbuffers should do something with rectangles too.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080 ;; does anybody use them?
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 487
diff changeset
1081 (declare-fboundp (x-store-cutbuffer (buffer-substring start end))))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082
487
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1083 (defun mouse-track-activate-rectangular-selection ()
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1084 (if (consp default-mouse-track-extent)
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1085 ;; own the rectangular region
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1086 ;; this is a hack
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1087 (let ((r default-mouse-track-extent))
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1088 (save-excursion
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1089 (set-buffer (get-buffer-create " *rect yank temp buf*"))
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1090 (erase-buffer)
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1091 (while r
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1092 (insert (extent-string (car r)) "\n")
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1093 (setq r (cdr r)))
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1094 (own-selection (buffer-substring (point-min) (point-max)))))))
54fa1a5c2d12 [xemacs-hg @ 2001-04-28 07:48:36 by ben]
ben
parents: 479
diff changeset
1095
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 (defun default-mouse-track-deal-with-down-event (click-count)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 (let ((event default-mouse-track-down-event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 (if (null event) nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 (select-frame (event-frame event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100 (let ((adjust default-mouse-track-adjust)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101 ;; ####When you click on the splash-screen,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1102 ;; event-{closest-,}point can be out of bounds. Should
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103 ;; event-closest-point really be allowed to return a bad
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 ;; position like that? Maybe pixel_to_glyph_translation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105 ;; needs to invalidate its cache when the buffer changes.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 ;; -dkindred@cs.cmu.edu
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107 (close-pos (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108 (set-buffer (event-buffer event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109 (let ((p (event-closest-point event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 (and p (min (max p (point-min)) (point-max))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 extent previous-point)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113 (if (not (event-window event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 (error "not over window?"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 (setq default-mouse-track-type
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1116 (nth (mod (1- click-count)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117 (length default-mouse-track-type-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 default-mouse-track-type-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 (setq default-mouse-track-window (event-window event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 ;; Note that the extent used here is NOT the extent which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1121 ;; ends up as the value of zmacs-region-extent - this one is used
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122 ;; just during mouse-dragging.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 (setq default-mouse-track-extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124 (make-extent close-pos close-pos (event-buffer event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 (setq extent default-mouse-track-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 (set-extent-face extent 'zmacs-region)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127 ;; While the selection is being dragged out, give the selection extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128 ;; slightly higher priority than any mouse-highlighted extent, so that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129 ;; the exact endpoints of the selection will be visible while the mouse
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 ;; is down. Normally, the selection and mouse highlighting have the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131 ;; same priority, so that conflicts between the two of them are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132 ;; resolved by the usual size-and-endpoint-comparison method.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 (set-extent-priority extent (1+ mouse-highlight-priority))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134 (if mouse-track-rectangle-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135 (setq default-mouse-track-extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 (list default-mouse-track-extent)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 (setq previous-point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139 (if (and adjust
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 (markerp default-mouse-track-previous-point)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141 (eq (current-buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1142 (marker-buffer default-mouse-track-previous-point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1143 (marker-position default-mouse-track-previous-point)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1144 (point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 (default-mouse-track-set-point event default-mouse-track-window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 (if (not adjust)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147 (if (markerp default-mouse-track-previous-point)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 (set-marker default-mouse-track-previous-point (point))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 (setq default-mouse-track-previous-point (point-marker))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 ;; adjust point to a word or line boundary if appropriate
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 (let ((anchor (default-mouse-track-anchor adjust previous-point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 (setq default-mouse-track-min-anchor
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 (save-excursion (goto-char anchor)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 (funcall
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156 default-mouse-track-normalize-point-function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 default-mouse-track-type nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 (point)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 (setq default-mouse-track-max-anchor
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160 (save-excursion (goto-char anchor)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 (funcall
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 default-mouse-track-normalize-point-function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 default-mouse-track-type t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164 (point))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 ;; remove the existing selection to unclutter the display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 (if (not adjust)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 (cond (zmacs-regions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 (zmacs-deactivate-region))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 ((console-on-window-system-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 (disown-selection)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172 (setq default-mouse-track-down-event nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1173
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1174 ;; return t if the button or motion event involved the specified button.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1175 (defun default-mouse-track-event-is-with-button (event n)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1176 (cond ((button-event-p event)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1177 (= n (event-button event)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1178 ((motion-event-p event)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1179 (memq (cdr
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1180 (assq n '((1 . button1) (2 . button2) (3 . button3)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1181 (4 . button4) (5 . button5))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1182 (event-modifiers event)))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1183
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1184 (defun default-mouse-track-down-hook (event click-count)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1185 (cond ((default-mouse-track-event-is-with-button event 1)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1186 (if (and (memq 'button1-down mouse-track-activate-strokes)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1187 (mouse-track-do-activate event))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1188 t
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1189 (setq default-mouse-track-down-event (copy-event event))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1190 nil))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1191 ((default-mouse-track-event-is-with-button event 2)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1192 (and (memq 'button2-down mouse-track-activate-strokes)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1193 (mouse-track-do-activate event)))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1194
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1195 (defun default-mouse-track-cleanup-extents-hook ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196 (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197 (let ((extent default-mouse-track-extent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1198 (if (consp extent) ; rectangle-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 (mapcar 'delete-extent extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200 (if extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1201 (delete-extent extent)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1203 (defun default-mouse-track-cleanup-hook ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 (if zmacs-regions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 (funcall 'default-mouse-track-cleanup-extents-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 (let ((extent default-mouse-track-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207 (func #'(lambda (e)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1208 (and (extent-live-p e)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 (set-extent-face e 'primary-selection)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210 (add-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211 (if (consp extent) ; rectangle-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212 (mapcar func extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1213 (if extent
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1214 (funcall func extent)))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1215 t)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 (defun default-mouse-track-cleanup-extent ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218 (let ((dead-func
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1219 (function (lambda (x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 (or (not (extent-live-p x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 (extent-detached-p x)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222 (extent default-mouse-track-extent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 (if (consp extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 (if (funcall dead-func extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 (let (newval)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 (mapcar (function (lambda (x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 (if (not (funcall dead-func x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 (setq newval (cons x newval)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 (setq default-mouse-track-extent (nreverse newval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 (if (funcall dead-func extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 (setq default-mouse-track-extent nil)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 (defun default-mouse-track-drag-hook (event click-count was-timeout)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1235 (cond ((default-mouse-track-event-is-with-button event 1)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1236 (default-mouse-track-deal-with-down-event click-count)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1237 (default-mouse-track-set-point event default-mouse-track-window)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1238 (default-mouse-track-cleanup-extent)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1239 (default-mouse-track-next-move default-mouse-track-min-anchor
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1240 default-mouse-track-max-anchor
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1241 default-mouse-track-extent)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1242 t)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1243 ((default-mouse-track-event-is-with-button event 2)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1244 (mouse-begin-drag-n-drop event))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 (defun default-mouse-track-return-dragged-selection (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 (default-mouse-track-cleanup-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 (let ((extent default-mouse-track-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 result)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 (default-mouse-track-set-point-in-window event default-mouse-track-window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1251 (default-mouse-track-next-move default-mouse-track-min-anchor
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 default-mouse-track-max-anchor
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 (cond ((consp extent) ; rectangle-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255 (let ((first (car extent))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1256 (last (car (setq extent (nreverse extent)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 ;; nreverse is destructive so we need to reset this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 (setq default-mouse-track-extent extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259 (setq result (cons (extent-start-position first)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 (extent-end-position last)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 ;; kludge to fix up region when dragging backwards...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 (if (and (/= (point) (extent-start-position first))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 (/= (point) (extent-end-position last))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264 (= (point) (extent-end-position first)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1265 (goto-char (car result)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1266 (extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 (setq result (cons (extent-start-position extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 (extent-end-position extent)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269 ;; Minor kludge: if we're selecting in line-mode, include the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1270 ;; final newline. It's hard to do this in *-normalize-point.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 (if (and result (eq default-mouse-track-type 'line))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 (let ((end-p (= (point) (cdr result))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 (goto-char (cdr result))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 (if (not (eobp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 (setcdr result (1+ (cdr result))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 (goto-char (if end-p (cdr result) (car result)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 ;;; ;; Minor kludge sub 2. If in char mode, and we drag the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 ;;; ;; mouse past EOL, include the newline.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279 ;;; ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1280 ;;; ;; Major problem: can't easily distinguish between being
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 ;;; ;; just past the last char on a line, and well past it,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 ;;; ;; to determine whether or not to include it in the region
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 ;;; ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 ;;; (if nil ; (eq default-mouse-track-type 'char)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 ;;; (let ((after-end-p (and (not (eobp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 ;;; (eolp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 ;;; (> (point) (car result)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 ;;; (if after-end-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 ;;; (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1290 ;;; (setcdr result (1+ (cdr result)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 ;;; (goto-char (cdr result))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 result))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 (defun default-mouse-track-drag-up-hook (event click-count)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1295 (when (default-mouse-track-event-is-with-button event 1)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1296 (let ((result (default-mouse-track-return-dragged-selection event)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1297 (if result
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1298 (default-mouse-track-maybe-own-selection result 'PRIMARY)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1299 t))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 (defun default-mouse-track-click-hook (event click-count)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1302 (cond ((default-mouse-track-event-is-with-button event 1)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1303 (if (and
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1304 (or (and (= click-count 1)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1305 (memq 'button1-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1306 mouse-track-activate-strokes))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1307 (and (= click-count 2)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1308 (memq 'button1-double-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1309 mouse-track-activate-strokes))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1310 (and (= click-count 3)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1311 (memq 'button1-triple-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1312 mouse-track-activate-strokes)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1313 (mouse-track-do-activate event))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1314 t
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1315 (default-mouse-track-drag-hook event click-count nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1316 (default-mouse-track-drag-up-hook event click-count)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1317 t))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1318 ((default-mouse-track-event-is-with-button event 2)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1319 (if (and
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1320 (or (and (= click-count 1)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1321 (memq 'button2-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1322 mouse-track-activate-strokes))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1323 (and (= click-count 2)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1324 (memq 'button2-double-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1325 mouse-track-activate-strokes))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1326 (and (= click-count 3)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1327 (memq 'button2-triple-click
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1328 mouse-track-activate-strokes)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1329 (mouse-track-do-activate event))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1330 t
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1331 (mouse-yank event)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1332 t))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1333
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 (add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 (add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337 (add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1338 (add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 (add-hook 'mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 ;;;;;;;;;;;; other mouse-track stuff (mostly associated with the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 ;;;;;;;;;;;; default handlers)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 (defun mouse-track-default (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 "Invoke `mouse-track' with only the default handlers active."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 (interactive "e")
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1348 (mouse-track event
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1349 '(mouse-track-down-hook
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1350 default-mouse-track-down-hook
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1351 mouse-track-up-hook nil
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1352 mouse-track-drag-hook default-mouse-track-drag-hook
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1353 mouse-track-drag-up-hook default-mouse-track-drag-up-hook
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1354 mouse-track-click-hook default-mouse-track-click-hook
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1355 mouse-track-cleanup-hook default-mouse-track-cleanup-hook)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 (defun mouse-track-do-rectangle (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 "Like `mouse-track' but selects rectangles instead of regions."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 (interactive "e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360 (let ((mouse-track-rectangle-p t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 (mouse-track event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 (defun mouse-track-adjust (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364 "Extend the existing selection. This should be bound to a mouse button.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1365 The selection will be enlarged or shrunk so that the point of the mouse
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366 click is one of its endpoints. This function in fact behaves fairly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 similarly to `mouse-track', but begins by extending the existing selection
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368 (or creating a new selection from the previous text cursor position to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369 the current mouse position) instead of creating a new, empty selection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 The mouse-track handlers are run from this command just like from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 `mouse-track'. Therefore, do not call this command from a mouse-track
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 handler!"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 (interactive "e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1375 (let ((default-mouse-track-adjust t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1376 (mouse-track event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378 (defun mouse-track-adjust-default (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 "Extend the existing selection, using only the default handlers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380 This is just like `mouse-track-adjust' but will override any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1381 custom mouse-track handlers that the user may have installed."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 (interactive "e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383 (let ((default-mouse-track-adjust t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 (mouse-track-default event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 (defun mouse-track-insert (event &optional delete)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387 "Make a selection with the mouse and insert it at point.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1388 This is exactly the same as the `mouse-track' command on \\[mouse-track],
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1389 except that point is not moved; the selected text is immediately inserted
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1390 after being selected\; and the selection is immediately disowned afterwards."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1391 (interactive "*e")
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1392 (let (s selreg)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1393 (flet ((Mouse-track-insert-drag-up-hook (event count)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1394 (setq selreg
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1395 (default-mouse-track-return-dragged-selection event))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1396 t)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1397 (Mouse-track-insert-click-hook (event count)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1398 (default-mouse-track-drag-hook event count nil)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1399 (setq selreg
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1400 (default-mouse-track-return-dragged-selection event))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1401 t))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1402 (save-excursion
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1403 (save-window-excursion
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1404 (mouse-track
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1405 event
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1406 '(mouse-track-drag-up-hook
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1407 Mouse-track-insert-drag-up-hook
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1408 mouse-track-click-hook
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1409 Mouse-track-insert-click-hook))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1410 (if (consp selreg)
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1411 (let ((pair selreg))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1412 (setq s (prog1
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1413 (buffer-substring (car pair) (cdr pair))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1414 (if delete
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1415 (kill-region (car pair) (cdr pair))))))))))
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 539
diff changeset
1416 (or (null s) (equal s "") (insert s))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 (defun mouse-track-delete-and-insert (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419 "Make a selection with the mouse and insert it at point.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420 This is exactly the same as the `mouse-track' command on \\[mouse-track],
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1421 except that point is not moved; the selected text is immediately inserted
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1422 after being selected\; and the text of the selection is deleted."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1423 (interactive "*e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1424 (mouse-track-insert event t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1425
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1426 ;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1429 (defvar inhibit-help-echo nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430 "Inhibits display of `help-echo' extent properties in the minibuffer.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 (defvar last-help-echo-object nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 (defvar help-echo-owns-message nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1434 (defun clear-help-echo (&optional ignored-frame)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1435 (if help-echo-owns-message
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1436 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1437 (setq help-echo-owns-message nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1438 last-help-echo-object nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1439 (clear-message 'help-echo))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1441 (defun show-help-echo (mess)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 ;; (clear-help-echo)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443 (setq help-echo-owns-message t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1444 (display-message 'help-echo mess))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1445
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 (add-hook 'mouse-leave-frame-hook 'clear-help-echo)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448 ;; It may be a good idea to move this to C, for better performance of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 ;; extent highlighting and pointer changes.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1450 (defun default-mouse-motion-handler (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451 "For use as the value of `mouse-motion-handler'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 This implements the various pointer-shape variables,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1453 as well as extent highlighting, help-echo, toolbar up/down,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1454 and `mode-motion-hook'."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1455 (let* ((frame (or (event-frame event) (selected-frame)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1456 (window (event-window event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1457 (buffer (event-buffer event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1458 (modeline-point (and buffer (event-modeline-position event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1459 (modeline-string (and modeline-point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1460 (symbol-value-in-buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1461 'generated-modeline-string buffer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1462 ;; point must be invalidated by modeline-point.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1463 (point (and buffer (not modeline-point)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1464 (event-point event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1465 (extent (or (and point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1466 (extent-at point buffer 'mouse-face))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1467 (and modeline-point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1468 (extent-at modeline-point modeline-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1469 ;; Modeline extents don't have a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1470 ;; mouse-face property set.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1471 'help-echo))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1472 (glyph-extent1 (event-glyph-extent event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1473 (glyph-extent (and glyph-extent1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1474 (extent-live-p glyph-extent1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1475 glyph-extent1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1476 ;; This is an extent:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1477 (user-pointer1 (or (and glyph-extent
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1478 (extent-property glyph-extent 'pointer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1479 glyph-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1480 (and point (extent-at point buffer 'pointer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1481 (and modeline-point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1482 (extent-at modeline-point modeline-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1483 'pointer))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1484 ;; And this should be a glyph:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1485 (user-pointer (and user-pointer1 (extent-live-p user-pointer1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1486 (extent-property user-pointer1 'pointer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1487 (button (event-toolbar-button event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1488 (help (or (and glyph-extent (extent-property glyph-extent 'help-echo)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1489 glyph-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1490 (and button (not (null (toolbar-button-help-string button)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1491 button)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1492 (and point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1493 (extent-at point buffer 'help-echo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1494 (and modeline-point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1495 (extent-at modeline-point modeline-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1496 'help-echo))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1497 ;; vars is a list of glyph variables to check for a pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1498 ;; value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1499 (vars (cond
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
1500 ;; Checking if button is non-nil is not sufficient
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1501 ;; since the pointer could be over a blank portion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1502 ;; of the toolbar.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1503 ((event-over-toolbar-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1504 '(toolbar-pointer-glyph nontext-pointer-glyph
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1505 text-pointer-glyph))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1506 ((or extent glyph-extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1507 '(selection-pointer-glyph text-pointer-glyph))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1508 ((event-over-modeline-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1509 '(modeline-pointer-glyph nontext-pointer-glyph
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1510 text-pointer-glyph))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1511 ((and (event-over-vertical-divider-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1512 ;; #### I disagree with the check below.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1513 ;; Discuss it with Kirill for 21.1. --hniksic
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1514 (specifier-instance vertical-divider-always-visible-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1515 (event-window event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1516 '(divider-pointer-glyph nontext-pointer-glyph
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 text-pointer-glyph))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518 (point '(text-pointer-glyph))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1519 (buffer '(nontext-pointer-glyph text-pointer-glyph))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1520 (t '(nontext-pointer-glyph text-pointer-glyph))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521 pointer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522 (and user-pointer (glyphp user-pointer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1523 (push 'user-pointer vars))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1524 (while (and vars (not (pointer-image-instance-p pointer)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1525 (setq pointer (glyph-image-instance (symbol-value (car vars))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 (or window frame))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 vars (cdr vars)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1528
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1529 (if (pointer-image-instance-p pointer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1530 (set-frame-pointer frame pointer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1532 ;; If last-pressed-toolbar-button is not nil, then check and see
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1533 ;; if we have moved to a new button and adjust the down flags
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534 ;; accordingly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535 (when (and (featurep 'toolbar) toolbar-active)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536 (unless (eq last-pressed-toolbar-button button)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 (release-previous-toolbar-button event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1538 (and button (press-toolbar-button event))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 (cond (extent (highlight-extent extent t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 (glyph-extent (highlight-extent glyph-extent t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1542 (t (highlight-extent nil nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1543 (cond ((extentp help)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1544 (or inhibit-help-echo
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1545 (eq help last-help-echo-object) ;save some time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1546 (eq (selected-window) (minibuffer-window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1547 (let ((hprop (extent-property help 'help-echo)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1548 (setq last-help-echo-object help)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1549 (or (stringp hprop)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1550 (setq hprop (funcall hprop help)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1551 (and hprop (show-help-echo hprop)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1552 ((and (featurep 'toolbar)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1553 (toolbar-button-p help)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1554 (toolbar-button-enabled-p help))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1555 (or (not toolbar-help-enabled)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1556 (eq help last-help-echo-object) ;save some time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1557 (eq (selected-window) (minibuffer-window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1558 (let ((hstring (toolbar-button-help-string button)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1559 (setq last-help-echo-object help)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1560 (or (stringp hstring)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1561 (setq hstring (funcall hstring help)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1562 (and hstring (show-help-echo hstring)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1563 (last-help-echo-object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1564 (clear-help-echo)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1565 (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1566 (if (and buffer (symbol-value-in-buffer 'mode-motion-hook buffer nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1567 (with-current-buffer buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1568 (run-hook-with-args 'mode-motion-hook event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1569
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1570 ;; If the mode-motion-hook created a highlightable extent around
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1571 ;; the mouse-point, highlight it right away. Otherwise it wouldn't
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1572 ;; be highlighted until the *next* motion event came in.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1573 (if (and point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1574 (null extent)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1575 (setq extent (extent-at point
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1576 (event-buffer event) ; not buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1577 'mouse-face)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1578 (highlight-extent extent t)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1579 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1580
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1581 (setq mouse-motion-handler 'default-mouse-motion-handler)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1582
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1583 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1584 ;; Vertical divider dragging
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1585 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586 (defun drag-window-divider (event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1587 "Handle resizing windows by dragging window dividers.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1588 This is an internal function, normally bound to button1 event in
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1589 window-divider-map. You would not call it, but you may bind it to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1590 other mouse buttons."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1591 (interactive "e")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592 ;; #### I disagree with the check below.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593 ;; Discuss it with Kirill for 21.1. --hniksic
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594 (if (not (specifier-instance vertical-divider-always-visible-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1595 (event-window event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1596 (error "Not over a window"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1597 (let-specifier ((vertical-divider-shadow-thickness
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1598 (- (specifier-instance vertical-divider-shadow-thickness
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1599 (event-window event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1600 (event-window event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1601 (let* ((window (event-window event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1602 (frame (event-channel event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603 (last-timestamp (event-timestamp event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1604 done)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1605 (while (not done)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1606 (let* ((edges (window-pixel-edges window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1607 (old-right (caddr edges))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1608 (old-left (car edges))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1609 (backup-conf (current-window-configuration frame))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1610 (old-edges-all-windows (mapcar 'window-pixel-edges
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1611 (window-list))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1612
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1613 ;; This is borrowed from modeline.el:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1614 ;; requeue event and quit if this is a misc-user, eval or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1615 ;; keypress event.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1616 ;; quit if this is a button press or release event, or if the event
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1617 ;; occurred in some other frame.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1618 ;; drag if this is a mouse motion event and the time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1619 ;; between this event and the last event is greater than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1620 ;; drag-divider-event-lag.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1621 ;; do nothing if this is any other kind of event.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1622 (setq event (next-event event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1623 (cond ((or (misc-user-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1624 (key-press-event-p event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1625 (setq unread-command-events (nconc unread-command-events
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626 (list event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1627 done t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1628 ((button-release-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1629 (setq done t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1630 ((button-event-p event)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1631 (setq done t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 ((not (motion-event-p event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633 (dispatch-event event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1634 ((not (eq frame (event-frame event)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1635 (setq done t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636 ((< (abs (- (event-timestamp event) last-timestamp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1637 drag-divider-event-lag))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1638 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1639 (setq last-timestamp (event-timestamp event))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1640 ;; Enlarge the window, calculating change in characters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1641 ;; of default font. Do not let the window to become
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
1642 ;; less than allowed minimum (not because that's critical
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1643 ;; for the code performance, just the visual effect is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1644 ;; better: when cursor goes to the left of the next left
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
1645 ;; divider, the window being resized shrinks to minimal
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1646 ;; size.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1647 (enlarge-window (max (- window-min-width (window-width window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1648 (/ (- (event-x-pixel event) old-right)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1649 (face-width 'default window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1650 t window)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1651 ;; Backout the change if some windows got deleted, or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1652 ;; if the change caused more than two windows to resize
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1653 ;; (shifting the whole stack right is ugly), or if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1654 ;; left window side has slipped (right side cannot be
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
1655 ;; moved any further to the right, so enlarge-window
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1656 ;; plays bad games with the left edge.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1657 (if (or (/= (count-windows) (length old-edges-all-windows))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1658 (/= old-left (car (window-pixel-edges window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659 ;; This check is very hairy. We allow any number
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1660 ;; of left edges to change, but only to the same
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1661 ;; new value. Similar procedure is for the right edges.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662 (let ((all-that-bad nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1663 (new-left-ok nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1664 (new-right-ok nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1665 (mapcar* (lambda (window old-edges)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1666 (let ((new (car (window-pixel-edges window))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1667 (if (/= new (car old-edges))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1668 (if (and new-left-ok
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1669 (/= new-left-ok new))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1670 (setq all-that-bad t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1671 (setq new-left-ok new)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1672 (window-list) old-edges-all-windows)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1673 (mapcar* (lambda (window old-edges)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 (let ((new (caddr (window-pixel-edges window))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1675 (if (/= new (caddr old-edges))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1676 (if (and new-right-ok
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1677 (/= new-right-ok new))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1678 (setq all-that-bad t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1679 (setq new-right-ok new)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680 (window-list) old-edges-all-windows)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1681 all-that-bad))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1682 (set-window-configuration backup-conf)))))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1683
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1684 (setq vertical-divider-map (make-keymap))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1685 (define-key vertical-divider-map 'button1 'drag-window-divider)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1686
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687 ;;; mouse.el ends here