xemacs-21.4 / lisp / mouse.el

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
;;; mouse.el --- window system-independent mouse support.

;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995 Tinker Systems
;; Copyright (C) 1995, 1996 Ben Wing.

;; Maintainer: XEmacs Development Team
;; Keywords: mouse, dumped

;; This file is part of XEmacs.

;; XEmacs 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.

;; XEmacs 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, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: Not synched with FSF.  Almost completely divergent.

;;; Commentary:

;; This file is dumped with XEmacs (when window system support is compiled in).

;;; Code:

(provide 'mouse)

(global-set-key 'button1 'mouse-track)
(global-set-key '(shift button1) 'mouse-track-adjust)
(global-set-key '(control button1) 'mouse-track-insert)
(global-set-key '(control shift button1) 'mouse-track-delete-and-insert)
(global-set-key '(meta button1) 'mouse-track-do-rectangle)

;; enable drag regions (ograf@fga.de)
;; if button2 is dragged from within a region, this becomes a drop
(if (featurep '(or offix cde mswindows))
    (global-set-key 'button2 'mouse-drag-or-yank)
  (global-set-key 'button2 'mouse-yank))

;; enable drops from OffiX (ograf@fga.de) or mswindows
;; accept any button1,2,3 drop with `mouse-offix-drop' or 'mswindows-mouse-drop'
(cond ((featurep 'offix)
       (global-set-key 'drop1 'mouse-offix-drop)
       (global-set-key 'drop2 'mouse-offix-drop)
       (global-set-key 'drop3 'mouse-offix-drop))
      ((featurep 'mswindows)
       (global-set-key 'drop0 'mouse-mswindows-drop)
       (global-set-key 'drop1 'mouse-mswindows-drop)
       (global-set-key 'drop2 'mouse-mswindows-drop)
       (global-set-key 'drop3 'mouse-mswindows-drop)))

(defgroup mouse nil
  "Window system-independent mouse support."
  :group 'editing)

(defcustom mouse-track-rectangle-p nil
  "*If true, then dragging out a region with the mouse selects rectangles
instead of simple start/end regions."
  :type 'boolean
  :group 'mouse)

(defcustom mouse-yank-at-point nil
  "*If non-nil, the function `mouse-yank' will yank text at the cursor location.
Otherwise, the cursor will be moved to the location of the pointer click before
text is inserted."
  :type 'boolean
  :group 'mouse)

(defcustom mouse-highlight-text 'context
  "*Choose the default double-click highlighting behaviour.
If set to `context', double-click will highlight words when the mouse
 is at a word character, or a symbol if the mouse is at a symbol
 character.
If set to `word', double-click will always attempt to highlight a word.
If set to `symbol', double-click will always attempt to highlight a
 symbol (the default behaviour in previous XEmacs versions)."
  :type '(choice (const context)
		 (const word)
		 (const symbol))
  :group 'mouse)

(defvar mouse-yank-function 'mouse-consolidated-yank
  "Function that is called upon by `mouse-yank' to actually insert text.")

(defun mouse-consolidated-yank ()
  (interactive)
  (case (device-type)
    (x (x-yank-function))
    (tty (yank))
    (otherwise (yank))))


(defun mouse-select ()
  "Select Emacs window the mouse is on."
  (interactive "@"))

(defun mouse-delete-window ()
  "Delete the Emacs window the mouse is on."
  (interactive "@")
  (delete-window))

(defun mouse-keep-one-window ()
  "Select Emacs window mouse is on, then kill all other Emacs windows."
  (interactive "@")
  (delete-other-windows))

(defun mouse-select-and-split ()
  "Select Emacs window mouse is on, then split it vertically in half."
  (interactive "@")
  (split-window-vertically nil))

(defun mouse-set-point (event)
  "Select Emacs window mouse is on, and move point to mouse position."
  (interactive "@e")
  (let ((window (event-window event))
	(pos (event-point event))
	(close-pos (event-closest-point event)))
    (or window (error "not in a window"))
    (select-window window)
    (if (and pos (> pos 0))
	;; If the event was over a text char, it's easy.
	(goto-char (max (min pos (point-max)) (point-min)))
      (if (and close-pos (> close-pos 0))
	  (goto-char (max (min close-pos (point-max)) (point-min)))
	;; When the event occurs outside of the frame directly to the
	;; left or right of a modeline, close-point is nil, but
	;; event-over-modeline is also nil.  That will drop us to this
	;; point.  So instead of erroring, just return nil.
	nil))))

(defun mouse-yank (event)
  "Paste text with the mouse.
If the variable `mouse-yank-at-point' is nil, then pasting occurs at the
location of the click; otherwise, pasting occurs at the current cursor
location."
  (interactive "e")
  (and (not mouse-yank-at-point)
       (mouse-set-point event))
  (funcall mouse-yank-function))

(defun click-inside-extent-p (click extent)
  "Return non-nil if the button event is within the primary selection-extent.
Return nil otherwise."
  ;; stig@hackvan.com
  (let ((ewin (event-window click))
	(epnt (event-point click)))
    (and ewin
	 epnt
	 extent
	 (eq (window-buffer ewin)
	     (extent-object extent))
	 (extent-start-position extent)
	 (> epnt (extent-start-position extent))
	 (> (extent-end-position extent) epnt))))

(defun click-inside-selection-p (click)
  (or (click-inside-extent-p click primary-selection-extent)
      (click-inside-extent-p click zmacs-region-extent)
      ))

(defun point-inside-extent-p (extent)
  "Return t if point is within the bounds of the primary selection extent.
Return t is point is at the end position of the extent.
Return nil otherwise."
  ;; stig@hackvan.com
  (and extent
       (eq (current-buffer)
	   (extent-object extent))
       (> (point) (extent-start-position extent))
       (>= (extent-end-position extent) (point))))

(defun point-inside-selection-p ()
  ;; by Stig@hackvan.com
  (or (point-inside-extent-p primary-selection-extent)
      (point-inside-extent-p zmacs-region-extent)))

(defun mouse-drag-or-yank (event)
  "Either drag or paste the current selection.
If the variable `mouse-yank-at-point' is non-nil,
move the cursor to the location of the click before pasting.
This functions has to be improved.  Currently it is just a (working) test."
  ;; by Oliver Graf <ograf@fga.de>
  (interactive "e")
  (if (click-inside-extent-p event zmacs-region-extent)
      ;; okay, this is a drag
      (cond ((featurep 'offix)
	     (offix-start-drag-region event
				      (extent-start-position zmacs-region-extent)
				      (extent-end-position zmacs-region-extent)))
	    ((featurep 'cde)
	     ;; should also work with CDE
	     (cde-start-drag
	      (extent-start-position zmacs-region-extent)
	      (extent-end-position zmacs-region-extent)))
	    (t (error "No offix or CDE support compiled in")))
    ;; no drag, call region-funct
    (and (not mouse-yank-at-point)
	 (mouse-set-point event))
    (funcall mouse-yank-function))
  )

(defun mouse-offix-drop (event)
  "Do something with an OffiX drop event.
Insert Text drops and execute appropriate commands for specific drops.
Text drops follow the `mouse-yank-at-point' variable."
  ;; by Oliver Graf <ograf@fga.de>
  (interactive "e")
  (let ((type (car (event-drag-and-drop-data event)))
	(data (cadr (event-drag-and-drop-data event)))
	(frame (event-channel event)))
    (cond ((= type 2)
	   (let ((x pop-up-windows))
	     (setq pop-up-windows nil)
	     (pop-to-buffer (find-file-noselect data) nil frame)
	     (make-frame-visible frame)
	     (setq pop-up-windows x)))
	  ((= type 3)
	   (let ((x pop-up-windows))
	     (setq pop-up-windows nil)
	     (while (not (eq data ()))
	       (pop-to-buffer (find-file-noselect (car data)) nil frame)
	       (setq data (cdr data)))
	     (make-frame-visible frame)
	     (setq pop-up-windows x)))
	  ((= type 4)
	   (and (not mouse-yank-at-point)
		(mouse-set-point event))
	   (insert data))
	  ((= type 5) (dired data))
	  ((or (= type 6) (= type 7)) (dired data)) ;; this is junk
	  ((= type 8) (funcall browse-url-browser-function data))
	  ((= type 9)
	   (let ((buf (generate-new-buffer "DndMIME")))
	     (set-buffer buf)
	     (pop-to-buffer buf nil frame)
	     (insert data)
	     (make-frame-visible frame)))
	  (t ;; this is raw data or unknown stuff
	   (let ((buf (generate-new-buffer "DndRawData")))
	     (set-buffer buf)
	     (pop-to-buffer buf nil frame)
	     (insert data)
	     (hexlify-buffer)
	     (make-frame-visible frame))))
    (undo-boundary)))

(defun mouse-mswindows-drop (event)
  "Do something with a drop event.
Insert Text drops and execute appropriate commands for specific drops.
Text drops follow the `mouse-yank-at-point' variable."
  (interactive "e")
  (let* ((type (car (event-drag-and-drop-data event)))
	(data (cadr (event-drag-and-drop-data event)))
	(frame (event-channel event))
	(window (if frame (event-window event) (frame-selected-window))))
    (cond ((= type 2)	;; file
	   (let ((x pop-up-windows))
	     (setq pop-up-windows nil)
	     (cond (window
		    (select-window window)))
	     (switch-to-buffer (find-file-noselect data))
	     (make-frame-visible frame)
	     (setq pop-up-windows x)))
	  ((= type 3)	;; files
	   (let ((x pop-up-windows))
	     (setq pop-up-windows nil)
	     (while (not (eq data ()))
	       (pop-to-buffer (find-file-noselect (car data)) nil frame)
	       (setq data (cdr data)))
	     (make-frame-visible frame)
	     (setq pop-up-windows x)))
	  ((= type 4)	;; text
	   (and (not mouse-yank-at-point)
		(mouse-set-point event))
	   (insert data))
	  (t ;; this is raw data or unknown stuff
	   (let ((buf (generate-new-buffer "DndRawData")))
	     (set-buffer buf)
	     (pop-to-buffer buf nil frame)
	     (insert data)
	     (hexlify-buffer)
	     (make-frame-visible frame))))
    (undo-boundary)))

(defun mouse-eval-sexp (click force-window)
  "Evaluate the sexp under the mouse.  Usually, this is the last sexp before
the click, but if you click on a left paren, then it is the sexp beginning
with the paren that is evaluated.  Also, since strings evaluate to themselves,
they're fed to re-search-forward and the matched region is highlighted until
the mouse button is released.

Perhaps the most useful thing about this function is that the evaluation of
the expression which is clicked upon is relative not to the window where you
click, but to the current window and the current position of point.  Thus,
you can use `mouse-eval-sexp' to interactively test code that acts upon a
buffer...something you cannot do with the standard `eval-last-sexp' function.
It's also fantastic for debugging regular expressions."
  ;; by Stig@hackvan.com
  (interactive "e\nP")
  (let (exp val result-str)
    (setq exp (save-window-excursion
		(save-excursion
		  (mouse-set-point click)
		  (save-excursion
		    (or (looking-at "(") (forward-sexp -1))
		    (read (point-marker))))))
    (cond ((stringp exp)
	   (if (setq val (re-search-forward exp nil t))
	       (let* ((oo (make-extent (match-beginning 0) (match-end 0))))
		 (set-extent-face oo 'highlight)
		 (set-extent-priority oo 1000)
		 ;; wait for button release...
		 (setq unread-command-event (next-command-event))
		 (delete-extent oo))
	     (message "Regex \"%s\" not found" exp)
	     (ding nil 'quiet)))
	  (t (setq val (if (fboundp 'eval-interactive)
			   (eval-interactive exp)
			 (eval exp)))))
    (setq result-str (prin1-to-string val))
    ;; #### -- need better test
    (if (and (not force-window)
	     (<= (length result-str) (window-width (selected-window))))
	(message "%s" result-str)
      (with-output-to-temp-buffer "*Mouse-Eval*"
	(condition-case nil
	    (pprint val)
	  (error (prin1 val))))
      )))

(defun mouse-line-length (event)
  "Print the length of the line indicated by the pointer."
  (interactive "@e")
  (save-excursion
    (mouse-set-point event)
    (message "Line length: %d" (- (point-at-eol) (point-at-bol))))
  (sleep-for 1))

(defun mouse-set-mark (event)
  "Select Emacs window mouse is on, and set mark at mouse position.
Display cursor at that position for a second."
  (interactive "@e")
  (let ((point-save (point)))
    (unwind-protect
	(progn (mouse-set-point event)
	       (push-mark nil t)
	       (sit-for 1))
      (goto-char point-save))))

(defun mouse-scroll (event)
  "Scroll point to the mouse position."
  (interactive "@e")
  (save-excursion
    (mouse-set-point event)
    (recenter 0)
    (scroll-right (event-x event))))

(defun mouse-del-char (event)
  "Delete the char pointed to by the mouse."
  (interactive "@e")
  (save-excursion
    (mouse-set-point event)
    (delete-char 1 nil)))

(defun mouse-kill-line (event)
  "Kill the line pointed to by the mouse."
  (interactive "@e")
  (save-excursion
    (mouse-set-point event)
    (kill-line nil)))

(defun mouse-bury-buffer (event)
  "Bury the buffer pointed to by the mouse, thus selecting the next one."
  (interactive "e")
  (save-selected-window
    (select-window (event-window event))
    (bury-buffer)))

(defun mouse-unbury-buffer (event)
  "Unbury and select the most recently buried buffer."
  (interactive "e")
  (save-selected-window
    (select-window (event-window event))
    (let* ((bufs (buffer-list))
	   (entry (1- (length bufs)))
	   val)
      (while (not (setq val (nth entry bufs)
			val (and (/= (aref (buffer-name val) 0)
				     ? )
				 val)))
	(setq entry (1- entry)))
      (switch-to-buffer val))))

(defun narrow-window-to-region (m n)
  "Narrow window to region between point and last mark"
  (interactive "r")
  (save-excursion
    (save-restriction
      (if (eq (selected-window) (next-window))
	  (split-window))
      (goto-char m)
      (recenter 0)
      (if (eq (selected-window)
	      (if (zerop (minibuffer-depth))
		  (next-window)))
	  ()
	(shrink-window (- (- (window-height) (count-lines m n)) 1))))))

(defun mouse-window-to-region (event)
  "Narrow window to region between cursor and mouse pointer."
  (interactive "@e")
  (let ((point-save (point)))
    (unwind-protect
	(progn (mouse-set-point event)
	       (push-mark nil t)
	       (sit-for 1))
      (goto-char point-save)
      (narrow-window-to-region (region-beginning) (region-end)))))

(defun mouse-ignore ()
  "Don't do anything."
  (interactive))


;;; mouse/selection tracking
;;; generalized mouse-track

(defvar default-mouse-track-normalize-point-function
  'default-mouse-track-normalize-point
  "Function called to normalize position of point.
Called with two arguments: TYPE depends on the number of times that the
mouse has been clicked and is a member of `default-mouse-track-type-list',
FORWARDP determines the direction in which the point should be moved.")

(defvar mouse-track-down-hook nil
  "Function or functions called when the user presses the mouse.
This hook is invoked by `mouse-track'; thus, it will not be called
for any buttons with a different binding.  The functions will be
called with two arguments: the button-press event and a click
count (see `mouse-track-click-hook').

If any function returns non-nil, the remaining functions will not be
called.

Note that most applications should take action when the mouse is
released, not when it is pressed.'")

(defvar mouse-track-drag-hook nil
  "Function or functions called when the user drags the mouse.
This hook is invoked by `mouse-track'; thus, it will not be called
for any buttons with a different binding.  The functions will be
called with three arguments: the mouse-motion event, a click
count (see `mouse-track-click-hook'), and whether the call to
this hook occurred as a result of a drag timeout (see
`mouse-track-scroll-delay').

If any function returns non-nil, the remaining functions will not be
called.

Note that no calls to this function will be made until the user
initiates a drag (i.e. moves the mouse more than a certain
threshold in either the X or the Y direction, as defined by
`mouse-track-x-threshold' and `mouse-track-y-threshold').

See also `mouse-track-drag-up-hook'.")

(defvar mouse-track-drag-up-hook nil
  "Function or functions called when the user finishes a drag.
This hook is invoked by `mouse-track'; thus, it will not be called
for any buttons with a different binding.  The functions will be
called with two arguments: the button-press event and a click
count (see `mouse-track-click-hook').

If any function returns non-nil, the remaining functions will not be
called.

Note that this hook will not be invoked unless the user has
initiated a drag, i.e. moved the mouse more than a certain threshold
(see `mouse-track-drag-hook').  When this function is invoked,
`mouse-track-drag-hook' will have been invoked at least once.

See also `mouse-track-click-hook'.")

(defvar mouse-track-click-hook nil
  "Function or functions called when the user clicks the mouse.
`Clicking' means pressing and releasing the mouse without having
initiated a drag (i.e. without having moved more than a certain
threshold -- see `mouse-track-drag-hook').

This hook is invoked by `mouse-track'; thus, it will not be called
for any buttons with a different binding.  The functions will be
called with two arguments: the button-release event and a click
count, which specifies the number of times that the mouse has been
clicked in a series of clicks, each of which is separated by at most
`mouse-track-multi-click-time'.  This can be used to implement actions
that are called on double clicks, triple clicks, etc.

If any function returns non-nil, the remaining functions will not be
called.

See also `mouse-track-drag-up-hook.")

(defvar mouse-track-up-hook nil
  "Function or functions called when the user releases the mouse.
This hook is invoked by `mouse-track'; thus, it will not be called
for any buttons with a different binding.  The functions will be
called with two arguments: the button-release event and a click
count (see `mouse-track-click-hook').

For many applications, it is more appropriate to use one or both
of `mouse-track-click-hook' and `mouse-track-drag-up-hook'.")

(defvar mouse-track-cleanup-hook nil
  "Function or functions called when `mouse-track' terminates.
This hook will be called in all circumstances, even upon a
non-local exit out of `mouse-track', and so is useful for
doing cleanup work such as removing extents that may have
been created during the operation of `mouse-track'.

Unlike all of the other mouse-track hooks, this is a \"normal\"
hook: the hook functions are called with no arguments, and
all hook functions are called regardless of their return
values.")

(defcustom mouse-track-multi-click-time 400
  "*Maximum number of milliseconds allowed between clicks for a multi-click.
See `mouse-track-click-hook'."
  :type 'integer
  :group 'mouse)

(defcustom mouse-track-scroll-delay 100
  "Maximum of milliseconds between calls to `mouse-track-drag-hook'.
If the user is dragging the mouse (i.e. the button is held down and
a drag has been initiated) and does not move the mouse for this many
milliseconds, the hook will be called with t as the value of the
WAS-TIMEOUT parameter.  This can be used to implement scrolling
in a selection when the user drags the mouse out the window it
was in.

A value of nil disables the timeout feature."
  :type '(choice integer (const :tag "Disabled" nil))
  :group 'mouse)

(defvar mouse-track-x-threshold '(face-width 'default)
  "Minimum number of pixels in the X direction for a drag to be initiated.
If the mouse is moved more than either the X or Y threshold while the
button is held down (see also `mouse-track-y-threshold'), then a drag
is initiated; otherwise the gesture is considered to be a click.
See `mouse-track'.

The value should be either a number of a form to be evaluated to
produce a number.")

(defvar mouse-track-y-threshold '(face-height 'default)
  "Minimum number of pixels in the Y direction for a drag to be initiated.
If the mouse is moved more than either the X or Y threshold while the
button is held down (see also `mouse-track-x-threshold'), then a drag
is initiated; otherwise the gesture is considered to be a click.
See `mouse-track'.

The value should be either a number of a form to be evaluated to
produce a number.")

;; these variables are private to mouse-track.
(defvar mouse-track-up-time nil)
(defvar mouse-track-up-x nil)
(defvar mouse-track-up-y nil)
(defvar mouse-track-timeout-id nil)
(defvar mouse-track-click-count nil)

(defun mouse-track-set-timeout (event)
  (if mouse-track-timeout-id
      (disable-timeout mouse-track-timeout-id))
  (if mouse-track-scroll-delay
      (setq mouse-track-timeout-id
	    (add-timeout (/ mouse-track-scroll-delay 1000.0)
			 'mouse-track-scroll-undefined
			 (copy-event event)))))

(defun mouse-track-run-hook (hook event &rest args)
  ;; ugh, can't use run-hook-with-args-until-success because we have
  ;; to get the value using symbol-value-in-buffer.  Doing a
  ;; save-excursion/set-buffer is wrong because the hook might want to
  ;; change the buffer, but just doing a set-buffer is wrong because
  ;; the hook might not want to change the buffer.
  ;; #### What we need here is a Lisp interface to
  ;; run_hook_with_args_in_buffer.  Here is a poor man's version.
  (let ((buffer (event-buffer event)))
    (and mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
    (when buffer
      (let ((value (symbol-value-in-buffer hook buffer nil)))
	(if (and (listp value) (not (eq (car value) 'lambda)))
	    ;; List of functions.
	    (let (retval)
	      (while (and value (null retval))
		;; Found `t': should process default value.  We could
		;; splice it into the buffer-local value, but that
		;; would cons, which is not a good thing for
		;; mouse-track hooks.
		(if (eq (car value) t)
		    (let ((global (default-value hook)))
		      (if (and (listp global) (not (eq (car global) 'lambda)))
			  ;; List of functions.
			  (while (and global
				      (null (setq retval
						  (apply (car global) event args))))
			    (pop global))
			;; lambda
			(setq retval (apply (car global) event args))))
		  (setq retval (apply (car value) event args)))
		(pop value))
	      retval)
	  ;; lambda
	  (apply value event args))))))

(defun mouse-track-scroll-undefined (random)
  ;; the old implementation didn't actually define this function,
  ;; and in normal use it won't ever be called because the timeout
  ;; will either be removed before it fires or will be picked off
  ;; with next-event and not dispatched.  However, if you're
  ;; attempting to debug a click-hook (which is pretty damn
  ;; difficult to do), this function may get called.
)

(defun mouse-track (event)
  "Make a selection with the mouse.  This should be bound to a mouse button.
The behavior of XEmacs during mouse selection is customizable using various
hooks and variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
`mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
`mouse-track-cleanup-hook', `mouse-track-multi-click-time',
`mouse-track-scroll-delay', `mouse-track-x-threshold', and
`mouse-track-y-threshold'.

Default handlers are provided to implement standard selecting/positioning
behavior.  You can explicitly request this default behavior, and override
any custom-supplied handlers, by using the function `mouse-track-default'
instead of `mouse-track'.

Default behavior is as follows:

If you click-and-drag, the selection will be set to the region between the
point of the initial click and the point at which you release the button.
These positions need not be ordered.

If you click-and-release without moving the mouse, then the point is moved
and the selection is disowned (there will be no selection owner).  The mark
will be set to the previous position of point.

If you double-click, the selection will extend by symbols instead of by
characters.  If you triple-click, the selection will extend by lines.

If you drag the mouse off the top or bottom of the window, you can select
pieces of text which are larger than the visible part of the buffer; the
buffer will scroll as necessary.

The selected text becomes the current X Selection.  The point will be left
at the position at which you released the button, and the mark will be left
at the initial click position."
  (interactive "e")
  (let ((mouse-down t)
	(xthresh (eval mouse-track-x-threshold))
	(ythresh (eval mouse-track-y-threshold))
	(orig-x (event-x-pixel event))
	(orig-y (event-y-pixel event))
	(buffer (event-buffer event))
	(mouse-grabbed-buffer (event-buffer event))
	mouse-moved)
    (if (or (not mouse-track-up-x)
	    (not mouse-track-up-y)
	    (not mouse-track-up-time)
	    (> (- (event-timestamp event) mouse-track-up-time)
	       mouse-track-multi-click-time)
	    (> (abs (- mouse-track-up-x orig-x)) xthresh)
	    (> (abs (- mouse-track-up-y orig-y)) ythresh))
	(setq mouse-track-click-count 1)
      (setq mouse-track-click-count (1+ mouse-track-click-count)))
    (if (not (event-window event))
	(error "Not over a window."))
    (mouse-track-run-hook 'mouse-track-down-hook
			  event mouse-track-click-count)
    (unwind-protect
	(while mouse-down
	  (setq event (next-event event))
	  (cond ((motion-event-p event)
		 (if (and (not mouse-moved)
			  (or (> (abs (- (event-x-pixel event) orig-x))
				 xthresh)
			      (> (abs (- (event-y-pixel event) orig-y))
				 ythresh)))
		     (setq mouse-moved t))
		 (if mouse-moved
		     (mouse-track-run-hook 'mouse-track-drag-hook
		      event mouse-track-click-count nil))
		 (mouse-track-set-timeout event))
		((and (timeout-event-p event)
		      (eq (event-function event)
			  'mouse-track-scroll-undefined))
		 (if mouse-moved
		     (mouse-track-run-hook 'mouse-track-drag-hook
		      (event-object event) mouse-track-click-count t))
		 (mouse-track-set-timeout (event-object event)))
		((button-release-event-p event)
		 (setq mouse-track-up-time (event-timestamp event))
		 (setq mouse-track-up-x (event-x-pixel event))
		 (setq mouse-track-up-y (event-y-pixel event))
		 (setq mouse-down nil)
		 (mouse-track-run-hook 'mouse-track-up-hook
		  event mouse-track-click-count)
		 (if mouse-moved
		     (mouse-track-run-hook 'mouse-track-drag-up-hook
		      event mouse-track-click-count)
		   (mouse-track-run-hook 'mouse-track-click-hook
		    event mouse-track-click-count)))
		((key-press-event-p event)
		 (error "Selection aborted"))
		(t
		 (dispatch-event event))))
      ;; protected
      (if mouse-track-timeout-id
	  (disable-timeout mouse-track-timeout-id))
      (setq mouse-track-timeout-id nil)
      (and buffer
	   (save-excursion
	     (set-buffer buffer)
	     (run-hooks 'mouse-track-cleanup-hook))))))


;;;;;;;;;;;; default handlers: new version of mouse-track

(defvar default-mouse-track-type nil)
(defvar default-mouse-track-type-list '(char word line))
(defvar default-mouse-track-window nil)
(defvar default-mouse-track-extent nil)
(defvar default-mouse-track-adjust nil)
(defvar default-mouse-track-min-anchor nil)
(defvar default-mouse-track-max-anchor nil)
(defvar default-mouse-track-result nil)
(defvar default-mouse-track-down-event nil)

;; D. Verna Feb. 17 1998
;; This function used to assume that when (event-window event) differs from
;; window, we have to scroll. This is WRONG, for instance when there are
;; toolbars on the side, in which case window-event returns nil.
(defun default-mouse-track-set-point-in-window (event window)
  (if (event-over-modeline-p event)
      nil ;; Scroll
    ;; Not over a modeline
    (if (eq (event-window event) window)
	(let ((p (event-closest-point event)))
	  (if  (or (not p) (not (pos-visible-in-window-p p window)))
	      nil ;; Scroll
	    (mouse-set-point event)
	    t))
      ;; Not over a modeline, not the same window. Check if the Y position
      ;; is still overlapping the original window.
      (let* ((edges (window-pixel-edges window))
	     (row (event-y-pixel event))
	     (text-start (nth 1 edges))
	     (text-end (+ (nth 3 edges))))
	(if (or (< row text-start)
		(> row text-end))
	    nil ;; Scroll
	  ;; The Y pos in overlapping the original window. Check however if
	  ;; the position is really visible, because there could be a
	  ;; scrollbar or a modeline at this place.
	  ;; Find the mean line height (height / lines nb), and approximate
	  ;; the line number for Y pos.
	  (select-window window)
	  (let ((line (/ (* (- row text-start) (window-height))
			 (- text-end text-start))))
	    (if (not (save-excursion
		       (goto-char (window-start))
		       (pos-visible-in-window-p
			(point-at-bol (+ 1 line)))))
		nil ;; Scroll
	      ;; OK, we can go to that position
	      (goto-char (window-start))
	      (forward-line line)
	      ;; On the right side: go to end-of-line.
	      (when (>= (event-x-pixel event) (nth 2 edges))
		(goto-char (point-at-eol)))
	      t))))
      )))


(defun default-mouse-track-scroll-and-set-point (event window)
  (select-window window)
  (let ((edges (window-pixel-edges window))
	(row (event-y-pixel event))
	(height (face-height 'default)))
    (cond ((< (abs (- row (nth 1 edges))) (abs (- row (nth 3 edges))))
	   ;; closer to window's top than to bottom, so move up
	   (let ((delta (max 1 (/ (- (nth 1 edges) row) height))))
	     (condition-case () (scroll-down delta) (error))
	     (goto-char (window-start))))
	  ((>= (point) (point-max)))
	  (t
	   ;; scroll by one line if over the modeline or a clipped line
	   (let ((delta (if (or (event-over-modeline-p event)
				(< row (nth 3 edges)))
			    1
			  (+ (/ (- row (nth 3 edges)) height) 1)))
		 (close-pos (event-closest-point event)))
	     (condition-case () (scroll-up delta) (error))
	     (if (and close-pos (pos-visible-in-window-p close-pos))
		 (goto-char close-pos)
	       (goto-char (window-end))
	       (vertical-motion delta)
	       ;; window-end reports the end of the clipped line, even if
	       ;; scroll-on-clipped-lines is t.  compensate.
	       ;; (If window-end gets fixed this can be removed.)
	       (if (not (pos-visible-in-window-p (max (1- (point))
						      (point-min))))
		   (vertical-motion -1))
	       (condition-case () (backward-char 1)
		 (error (end-of-line)))))))))


;; This remembers the last position at which the user clicked, for the
;; benefit of mouse-track-adjust (for example, button1; scroll until the
;; position of the click is off the frame; then Sh-button1 to select the
;; new region.
(defvar default-mouse-track-previous-point nil)

(defun default-mouse-track-set-point (event window)
  (if (default-mouse-track-set-point-in-window event window)
      nil
    (default-mouse-track-scroll-and-set-point event window)))

(defsubst default-mouse-track-beginning-of-word (symbolp)
  (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
				((null symbolp) "\\w")
				(t "[^ \t\n]")))
	(white-space "[ \t]"))
    (cond ((bobp) nil)
	  ((looking-at word-constituent)
	   (backward-char)
	   (while (and (not (bobp)) (looking-at word-constituent))
	     (backward-char))
	   (if (or (not (bobp)) (not (looking-at word-constituent)))
	       (forward-char)))
	  ((looking-at white-space)
	   (backward-char)
	   (while (looking-at white-space)
	     (backward-char))
	   (forward-char)))))

(defun default-mouse-track-end-of-word (symbolp)
  (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
				((null symbolp) "\\w")
				(t "[^ \t\n]")))
	(white-space "[ \t]"))
    (cond ((looking-at word-constituent) ; word or symbol constituent
	   (while (looking-at word-constituent)
	     (forward-char)))
	  ((looking-at white-space) ; word or symbol constituent
	   (while (looking-at white-space)
	     (forward-char))))))

;; Decide what will be the SYMBOLP argument to
;; default-mouse-track-{beginning,end}-of-word, according to the
;; syntax of the current character and value of mouse-highlight-text.
(defsubst default-mouse-symbolp (syntax)
  (cond ((eq mouse-highlight-text 'context)
	 (eq syntax ?_))
	((eq mouse-highlight-text 'symbol)
	 t)
	(t
	 nil)))

(defun default-mouse-track-normalize-point (type forwardp)
  (cond ((eq type 'word)
	 ;; trap the beginning and end of buffer errors
	 (ignore-errors
	   (setq type (char-syntax (char-after (point))))
	   (if forwardp
	       (if (= type ?\()
		   (goto-char (scan-sexps (point) 1))
		 (if (= type  ?\))
		     (forward-char 1)
		   (default-mouse-track-end-of-word
		     (default-mouse-symbolp type))))
	     (if (= type ?\))
		 (goto-char (scan-sexps (1+ (point)) -1))
	       (default-mouse-track-beginning-of-word
		 (default-mouse-symbolp type))))))
	((eq type 'line)
	 (if forwardp (end-of-line) (beginning-of-line)))
	((eq type 'buffer)
	 (if forwardp (end-of-buffer) (beginning-of-buffer)))))

(defun default-mouse-track-next-move (min-anchor max-anchor extent)
  (let ((anchor (if (<= (point) min-anchor) max-anchor min-anchor)))
    (funcall default-mouse-track-normalize-point-function
	     default-mouse-track-type (> (point) anchor))
    (if (consp extent)
	(default-mouse-track-next-move-rect anchor (point) extent)
      (if extent
	  (if (<= anchor (point))
	      (set-extent-endpoints extent anchor (point))
	    (set-extent-endpoints extent (point) anchor))))))

(defun default-mouse-track-next-move-rect (start end extents &optional pad-p)
  (if (< end start)
      (let ((tmp start)) (setq start end end tmp)))
  (cond
   ((= start end)		; never delete the last remaining extent
    (mapcar 'delete-extent (cdr extents))
    (setcdr extents nil)
    (set-extent-endpoints (car extents) start start))
   (t
    (let ((indent-tabs-mode nil)	; if pad-p, don't use tabs
	  (rest extents)
	  left right last p)
      (save-excursion
	(save-restriction
	  (goto-char end)
	  (setq right (current-column))
	  (goto-char start)
	  (setq left (current-column))
	  (if (< right left)
	      (let ((tmp left))
		(setq left right right tmp)
		(setq start (- start (- right left))
		      end (+ end (- right left)))))
	  ;; End may have been set to a value greater than point-max if drag
	  ;; or movement extends to end of buffer, so reset it.
	  (setq end (min end (point-max)))
	  (beginning-of-line)
	  (narrow-to-region (point) end)
	  (goto-char start)
	  (while (and rest (not (eobp)))
	    (setq p (point))
	    (move-to-column right pad-p)
	    (set-extent-endpoints (car rest) p (point))
	    ;; this code used to look at the return value
	    ;; of forward-line, but that doesn't work because
	    ;; forward-line has bogus behavior: If you're on
	    ;; the last line of a buffer but not at the very
	    ;; end, forward-line will move you to the very
	    ;; end and return 0 instead of 1, like it should.
	    ;; the result was frequent infinite loops here,
	    ;; creating very large numbers of extents at
	    ;; the same position.  There was an N^2 sorting
	    ;; algorithm in extents.c for extents at a
	    ;; particular position, and the result was very
	    ;; bad news.
	    (forward-line 1)
	    (if (not (eobp))
		(move-to-column left pad-p))
	    (setq last rest
		  rest (cdr rest)))
	  (cond (rest
		 (mapcar 'delete-extent rest)
		 (setcdr last nil))
		((not (eobp))
		 (while (not (eobp))
		   (setq p (point))
		   (move-to-column right pad-p)
		   (let ((e (make-extent p (point))))
		     (set-extent-face e (extent-face (car extents)))
		     (set-extent-priority e (extent-priority (car extents)))
		     (setcdr last (cons e nil))
		     (setq last (cdr last)))
		   (forward-line 1)
		   (if (not (eobp))
		       (move-to-column left pad-p))
		   )))))
      ))))

(defun default-mouse-track-has-selection-p (buffer)
  (and (or (not (eq 'x (console-type)))
	   (x-selection-owner-p))
       (extent-live-p primary-selection-extent)
       (not (extent-detached-p primary-selection-extent))
       (eq buffer (extent-object primary-selection-extent))))

(defun default-mouse-track-anchor (adjust previous-point)
  (if adjust
      (if (default-mouse-track-has-selection-p (current-buffer))
	  (let ((start (extent-start-position primary-selection-extent))
		(end (extent-end-position primary-selection-extent)))
	    (cond ((< (point) start) end)
		  ((> (point) end) start)
		  ((> (- (point) start) (- end (point))) start)
		  (t end)))
	previous-point)
    (point)))

(defun default-mouse-track-maybe-own-selection (pair type)
  (let ((start (car pair))
	(end (cdr pair)))
    (or (= start end) (push-mark (if (= (point) start) end start)))
    (cond (zmacs-regions
	   (if (= start end)
	       nil
	     ;; #### UTTER KLUDGE.
	     ;; If we don't have this sit-for here, then triple-clicking
	     ;; will result in the line not being highlighted as it
	     ;; should.  What appears to be happening is this:
	     ;;
	     ;; -- each time the button goes down, the selection is
	     ;;    disowned (see comment "remove the existing selection
	     ;;    to unclutter the display", below).
	     ;; -- this causes a SelectionClear event to be sent to
	     ;;    XEmacs.
	     ;; -- each time the button goes up except the first, the
	     ;;    selection is owned again.
	     ;; -- later, XEmacs processes the SelectionClear event.
	     ;;    The selection code attempts to keep track of the
	     ;;    time that it last asserted the selection, and
	     ;;    compare it to the time of the SelectionClear event,
	     ;;    to see if it's a bogus notification or not (as
	     ;;    is the case here).  However, for some unknown
	     ;;    reason this doesn't work in the triple-clicking
	     ;;    case, and the selection code bogusly thinks this
	     ;;    SelectionClear event is the real thing.
	     ;; -- putting the sit-for in causes the pending
	     ;;    SelectionClear events to get processed before
	     ;;    the selection is reasserted, so everything works
	     ;;    out OK.
	     ;;
	     ;; Presumably(?) this means there is a weird timing bug
	     ;; in the selection code, but there's not a chance in hell
	     ;; that I have the patience to track it down.  Blame the
	     ;; designers of X for fucking everything up so badly.
	     ;;
	     ;; This was originally a sit-for 0 but that wasn't
	     ;; sufficient to make things work.  Even this isn't
	     ;; always sufficient but it seems to give something
	     ;; approaching a 99% success rate.  Making it higher yet
	     ;; would help guarantee success with the price that the
	     ;; delay would start to become noticable.
	     ;;
	     (sit-for 0.15 t)
	     (zmacs-activate-region)))
	  ((eq 'x (console-type))
	   (if (= start end)
	       (x-disown-selection type)
	     (if (consp default-mouse-track-extent)
		 ;; own the rectangular region
		 ;; this is a hack
		 (let ((r default-mouse-track-extent))
		   (save-excursion
		     (set-buffer (get-buffer-create " *rect yank temp buf*"))
		     (while r
		       (insert (extent-string (car r)) "\n")
		       (setq r (cdr r)))
		     (x-own-selection (buffer-substring (point-min) (point-max)))
		     (kill-buffer (current-buffer))))
	       (x-own-selection (cons (set-marker (make-marker) start)
				      (set-marker (make-marker) end))
				type)))))
    (if (and (eq 'x (console-type))
	     (not (= start end)))
	;; I guess cutbuffers should do something with rectangles too.
	;; does anybody use them?
	(x-store-cutbuffer (buffer-substring start end)))))

(defun default-mouse-track-deal-with-down-event (click-count)
  (let ((event default-mouse-track-down-event))
    (if (null event) nil
      (select-frame (event-frame event))
      (let ((adjust default-mouse-track-adjust)
	    ;; ####When you click on the splash-screen,
	    ;; event-{closest-,}point can be out of bounds.  Should
	    ;; event-closest-point really be allowed to return a bad
	    ;; position like that?  Maybe pixel_to_glyph_translation
	    ;; needs to invalidate its cache when the buffer changes.
	    ;; -dkindred@cs.cmu.edu
	    (close-pos  (save-excursion
			  (set-buffer (event-buffer event))
			  (let ((p (event-closest-point event)))
			    (and p (min (max p (point-min)) (point-max))))))
	    extent previous-point)

	(if (not (event-window event))
	    (error "not over window?"))
	(setq default-mouse-track-type
	      (nth (mod (1- click-count)
			(length default-mouse-track-type-list))
		   default-mouse-track-type-list))
	(setq default-mouse-track-window (event-window event))
	;; Note that the extent used here is NOT the extent which
	;; ends up as the value of zmacs-region-extent - this one is used
	;; just during mouse-dragging.
	(setq default-mouse-track-extent
	      (make-extent close-pos close-pos (event-buffer event)))
	(setq extent default-mouse-track-extent)
	(set-extent-face extent 'zmacs-region)
	;; While the selection is being dragged out, give the selection extent
	;; slightly higher priority than any mouse-highlighted extent, so that
	;; the exact endpoints of the selection will be visible while the mouse
	;; is down.  Normally, the selection and mouse highlighting have the
	;; same priority, so that conflicts between the two of them are
	;; resolved by the usual size-and-endpoint-comparison method.
	(set-extent-priority extent (1+ mouse-highlight-priority))
	(if mouse-track-rectangle-p
	    (setq default-mouse-track-extent
		  (list default-mouse-track-extent)))

	(setq previous-point
	      (if (and adjust
		       (markerp default-mouse-track-previous-point)
		       (eq (current-buffer)
			   (marker-buffer default-mouse-track-previous-point)))
		  (marker-position default-mouse-track-previous-point)
		(point)))
	(default-mouse-track-set-point event default-mouse-track-window)
	(if (not adjust)
	    (if (markerp default-mouse-track-previous-point)
		(set-marker default-mouse-track-previous-point (point))
	      (setq default-mouse-track-previous-point (point-marker))))
	;;
	;; adjust point to a word or line boundary if appropriate
	(let ((anchor (default-mouse-track-anchor adjust previous-point)))
	  (setq default-mouse-track-min-anchor
		(save-excursion (goto-char anchor)
				(funcall
				 default-mouse-track-normalize-point-function
				 default-mouse-track-type nil)
				(point)))
	  (setq default-mouse-track-max-anchor
		(save-excursion (goto-char anchor)
				(funcall
				 default-mouse-track-normalize-point-function
				 default-mouse-track-type t)
				(point))))
	;;
	;; remove the existing selection to unclutter the display
	(if (not adjust)
	    (cond (zmacs-regions
		   (zmacs-deactivate-region))
		  ((eq 'x (console-type))
		   (x-disown-selection)))))
      (setq default-mouse-track-down-event nil))))

(defun default-mouse-track-down-hook (event click-count)
  (setq default-mouse-track-down-event (copy-event event))
  nil)

(defun default-mouse-track-cleanup-extents-hook ()
  (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
  (let ((extent default-mouse-track-extent))
    (if (consp extent) ; rectangle-p
	(mapcar 'delete-extent extent)
      (if extent
	  (delete-extent extent)))))

(defun default-mouse-track-cleanup-hook ()
  (if zmacs-regions
      (funcall 'default-mouse-track-cleanup-extents-hook)
    (let ((extent default-mouse-track-extent)
	  (func #'(lambda (e)
		    (and (extent-live-p e)
			 (set-extent-face e 'primary-selection)))))
      (add-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
      (if (consp extent)		; rectangle-p
	  (mapcar func extent)
	(if extent
	    (funcall func extent))))))

(defun default-mouse-track-cleanup-extent ()
  (let ((dead-func
	 (function (lambda (x)
		     (or (not (extent-live-p x))
			 (extent-detached-p x)))))
	(extent default-mouse-track-extent))
    (if (consp extent)
	(if (funcall dead-func extent)
	    (let (newval)
	      (mapcar (function (lambda (x)
				  (if (not (funcall dead-func x))
				      (setq newval (cons x newval)))))
		      extent)
	      (setq default-mouse-track-extent (nreverse newval))))
      (if (funcall dead-func extent)
	  (setq default-mouse-track-extent nil)))))

(defun default-mouse-track-drag-hook (event click-count was-timeout)
  (default-mouse-track-deal-with-down-event click-count)
  (default-mouse-track-set-point event default-mouse-track-window)
  (default-mouse-track-cleanup-extent)
  (default-mouse-track-next-move default-mouse-track-min-anchor
    default-mouse-track-max-anchor
    default-mouse-track-extent)
  t)

(defun default-mouse-track-return-dragged-selection (event)
  (default-mouse-track-cleanup-extent)
  (let ((extent default-mouse-track-extent)
	result)
    (default-mouse-track-set-point-in-window event default-mouse-track-window)
    (default-mouse-track-next-move default-mouse-track-min-anchor
			   default-mouse-track-max-anchor
			   extent)
    (cond ((consp extent) ; rectangle-p
	   (let ((first (car extent))
		 (last (car (setq extent (nreverse extent)))))
	     ;; nreverse is destructive so we need to reset this
	     (setq default-mouse-track-extent extent)
	     (setq result (cons (extent-start-position first)
				(extent-end-position last)))
	     ;; kludge to fix up region when dragging backwards...
	     (if (and (/= (point) (extent-start-position first))
		      (/= (point) (extent-end-position last))
		      (= (point) (extent-end-position first)))
		 (goto-char (car result)))))
	  (extent
	   (setq result (cons (extent-start-position extent)
			      (extent-end-position extent)))))
    ;; Minor kludge: if we're selecting in line-mode, include the
    ;; final newline.  It's hard to do this in *-normalize-point.
    (if (and result (eq default-mouse-track-type 'line))
	(let ((end-p (= (point) (cdr result))))
	  (goto-char (cdr result))
	  (if (not (eobp))
	      (setcdr result (1+ (cdr result))))
	  (goto-char (if end-p (cdr result) (car result)))))
;;;	  ;; Minor kludge sub 2.  If in char mode, and we drag the
;;;	  ;; mouse past EOL, include the newline.
;;;	  ;;
;;;	  ;; Major problem: can't easily distinguish between being
;;;	  ;; just past the last char on a line, and well past it,
;;;	  ;; to determine whether or not to include it in the region
;;;	  ;;
;;;	  (if nil ; (eq default-mouse-track-type 'char)
;;;	      (let ((after-end-p (and (not (eobp))
;;; 				      (eolp)
;;;				      (> (point) (car result)))))
;;;		(if after-end-p
;;;		    (progn
;;;		      (setcdr result (1+ (cdr result)))
;;;		      (goto-char (cdr result))))))
    result))

(defun default-mouse-track-drag-up-hook (event click-count)
  (let ((result (default-mouse-track-return-dragged-selection event)))
    (if result
	(default-mouse-track-maybe-own-selection result 'PRIMARY)))
  t)

(defun default-mouse-track-click-hook (event click-count)
  (default-mouse-track-drag-hook event click-count nil)
  (default-mouse-track-drag-up-hook event click-count)
  t)

(add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook)
(add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook)
(add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook)
(add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook)
(add-hook 'mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook)


;;;;;;;;;;;; other mouse-track stuff (mostly associated with the
;;;;;;;;;;;; default handlers)

(defun mouse-track-default (event)
  "Invoke `mouse-track' with only the default handlers active."
  (interactive "e")
  (let ((mouse-track-down-hook 'default-mouse-track-down-hook)
	(mouse-track-drag-hook 'default-mouse-track-drag-hook)
	(mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook)
	(mouse-track-click-hook 'default-mouse-track-click-hook)
	(mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook))
    (mouse-track event)))

(defun mouse-track-do-rectangle (event)
  "Like `mouse-track' but selects rectangles instead of regions."
  (interactive "e")
  (let ((mouse-track-rectangle-p t))
	(mouse-track event)))

(defun mouse-track-adjust (event)
  "Extend the existing selection.  This should be bound to a mouse button.
The selection will be enlarged or shrunk so that the point of the mouse
click is one of its endpoints.  This function in fact behaves fairly
similarly to `mouse-track', but begins by extending the existing selection
(or creating a new selection from the previous text cursor position to
the current mouse position) instead of creating a new, empty selection.

The mouse-track handlers are run from this command just like from
`mouse-track'.  Therefore, do not call this command from a mouse-track
handler!"
  (interactive "e")
  (let ((default-mouse-track-adjust t))
    (mouse-track event)))

(defun mouse-track-adjust-default (event)
  "Extend the existing selection, using only the default handlers.
This is just like `mouse-track-adjust' but will override any
custom mouse-track handlers that the user may have installed."
  (interactive "e")
  (let ((default-mouse-track-adjust t))
    (mouse-track-default event)))

(defvar mouse-track-insert-selected-region nil)

(defun mouse-track-insert-drag-up-hook (event click-count)
  (setq mouse-track-insert-selected-region
	(default-mouse-track-return-dragged-selection event)))

(defun mouse-track-insert (event &optional delete)
  "Make a selection with the mouse and insert it at point.
This is exactly the same as the `mouse-track' command on \\[mouse-track],
except that point is not moved; the selected text is immediately inserted
after being selected\; and the selection is immediately disowned afterwards."
  (interactive "*e")
  (setq mouse-track-insert-selected-region nil)
  (let ((mouse-track-drag-up-hook 'mouse-track-insert-drag-up-hook)
 	(mouse-track-click-hook 'mouse-track-insert-click-hook)
	s)
    (save-excursion
      (save-window-excursion
	(mouse-track event)
	(if (consp mouse-track-insert-selected-region)
	    (let ((pair mouse-track-insert-selected-region))
	      (setq s (prog1
			  (buffer-substring (car pair) (cdr pair))
			(if delete
			    (kill-region (car pair) (cdr pair)))))))))
	(or (null s) (equal s "") (insert s))))

(defun mouse-track-insert-click-hook (event click-count)
  (default-mouse-track-drag-hook event click-count nil)
  (mouse-track-insert-drag-up-hook event click-count)
  t)

(defun mouse-track-delete-and-insert (event)
  "Make a selection with the mouse and insert it at point.
This is exactly the same as the `mouse-track' command on \\[mouse-track],
except that point is not moved; the selected text is immediately inserted
after being selected\; and the text of the selection is deleted."
  (interactive "*e")
  (mouse-track-insert event t))

;;;;;;;;;;;;;;;;;;;;;;;;


(defvar inhibit-help-echo nil
  "Inhibits display of `help-echo' extent properties in the minibuffer.")
(defvar last-help-echo-object nil)
(defvar help-echo-owns-message nil)

(defun clear-help-echo (&optional ignored-frame)
  (if help-echo-owns-message
      (progn
	(setq help-echo-owns-message nil
	      last-help-echo-object nil)
	(clear-message 'help-echo))))

(defun show-help-echo (mess)
  ;; (clear-help-echo)
  (setq help-echo-owns-message t)
  (display-message 'help-echo mess))

(add-hook 'mouse-leave-frame-hook 'clear-help-echo)

;; It may be a good idea to move this to C, for better performance of
;; extent highlighting and pointer changes.
(defun default-mouse-motion-handler (event)
  "For use as the value of `mouse-motion-handler'.
This implements the various pointer-shape variables,
as well as extent highlighting, help-echo, toolbar up/down,
and `mode-motion-hook'."
  (let* ((frame (or (event-frame event) (selected-frame)))
	 (window (event-window event))
	 (buffer (event-buffer event))
	 (modeline-point (and buffer (event-modeline-position event)))
	 (modeline-string (and modeline-point
			       (symbol-value-in-buffer
				'generated-modeline-string buffer)))
	 ;; point must be invalidated by modeline-point.
	 (point (and buffer (not modeline-point)
		     (event-point event)))
	 (extent (or (and point
			  (extent-at point buffer 'mouse-face))
		     (and modeline-point
			  (extent-at modeline-point modeline-string
				     ;; Modeline extents don't have a
				     ;; mouse-face property set.
				     'help-echo))))
	 (glyph-extent1 (event-glyph-extent event))
	 (glyph-extent (and glyph-extent1
			    (extent-live-p glyph-extent1)
			    glyph-extent1))
	 ;; This is an extent:
	 (user-pointer1 (or (and glyph-extent
				 (extent-property glyph-extent 'pointer)
				 glyph-extent)
			    (and point (extent-at point buffer 'pointer))
			    (and modeline-point
				 (extent-at modeline-point modeline-string
					    'pointer))))
	 ;; And this should be a glyph:
	 (user-pointer (and user-pointer1 (extent-live-p user-pointer1)
			    (extent-property user-pointer1 'pointer)))
	 (button (event-toolbar-button event))
	 (help (or (and glyph-extent (extent-property glyph-extent 'help-echo)
			glyph-extent)
		   (and button (not (null (toolbar-button-help-string button)))
			button)
		   (and point
			(extent-at point buffer 'help-echo))
		   (and modeline-point
			(extent-at modeline-point modeline-string
				   'help-echo))))
	 ;; vars is a list of glyph variables to check for a pointer
	 ;; value.
	 (vars (cond
		;; Checking if button is non-nil is not sufficent
		;; since the pointer could be over a blank portion
		;; of the toolbar.
		((event-over-toolbar-p event)
		 '(toolbar-pointer-glyph nontext-pointer-glyph
					 text-pointer-glyph))
		((or extent glyph-extent)
		 '(selection-pointer-glyph text-pointer-glyph))
		((event-over-modeline-p event)
		 '(modeline-pointer-glyph nontext-pointer-glyph
					  text-pointer-glyph))
		(point '(text-pointer-glyph))
		(buffer '(nontext-pointer-glyph text-pointer-glyph))
		(t '(nontext-pointer-glyph text-pointer-glyph))))
	 pointer)
    (and user-pointer (glyphp user-pointer)
	 (push 'user-pointer vars))
    (while (and vars (not (pointer-image-instance-p pointer)))
      (setq pointer (glyph-image-instance (symbol-value (car vars))
					  (or window frame))
	    vars (cdr vars)))

    (if (pointer-image-instance-p pointer)
	(set-frame-pointer frame pointer))

    ;; If last-pressed-toolbar-button is not nil, then check and see
    ;; if we have moved to a new button and adjust the down flags
    ;; accordingly.
    (when (and (featurep 'toolbar) toolbar-active)
      (unless (eq last-pressed-toolbar-button button)
	(release-previous-toolbar-button event)
	(and button (press-toolbar-button event))))

    (cond (extent (highlight-extent extent t))
	  (glyph-extent (highlight-extent glyph-extent t))
	  (t (highlight-extent nil nil)))
    (cond ((extentp help)
           (or inhibit-help-echo
               (eq help last-help-echo-object) ;save some time
               (let ((hprop (extent-property help 'help-echo)))
                 (setq last-help-echo-object help)
                 (or (stringp hprop)
                     (setq hprop (funcall hprop help)))
                 (and hprop (show-help-echo hprop)))))
	  ((and (featurep 'toolbar)
                (toolbar-button-p help)
                (toolbar-button-enabled-p help))
	   (or (not toolbar-help-enabled)
	       (eq help last-help-echo-object) ;save some time
	       (let ((hstring (toolbar-button-help-string button)))
		 (setq last-help-echo-object help)
		 (or (stringp hstring)
		     (setq hstring (funcall hstring help)))
		 (show-help-echo hstring))))
          (last-help-echo-object
	   (clear-help-echo)))
    (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
    (if (and buffer (symbol-value-in-buffer 'mode-motion-hook buffer nil))
	(with-current-buffer buffer
	  (run-hook-with-args 'mode-motion-hook event)

	  ;; If the mode-motion-hook created a highlightable extent around
	  ;; the mouse-point, highlight it right away.  Otherwise it wouldn't
	  ;; be highlighted until the *next* motion event came in.
	  (if (and point
		   (null extent)
		   (setq extent (extent-at point
					   (event-buffer event) ; not buffer
					   'mouse-face)))
	      (highlight-extent extent t)))))
  nil)

(setq mouse-motion-handler 'default-mouse-motion-handler)

;;; mouse.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.