└── pos-tip.el /pos-tip.el: -------------------------------------------------------------------------------- 1 | ;;; pos-tip.el --- Show tooltip at point -*- coding: utf-8 -*- 2 | 3 | ;; Copyright (C) 2010 S. Irie 4 | 5 | ;; Author: S. Irie 6 | ;; Maintainer: S. Irie 7 | ;; Keywords: Tooltip 8 | 9 | ;; Package-Version: 0.4.7 10 | 11 | (defconst pos-tip-version "0.4.7") 12 | 13 | ;; This program is free software; you can redistribute it and/or 14 | ;; modify it under the terms of the GNU General Public License as 15 | ;; published by the Free Software Foundation; either version 2, or 16 | ;; (at your option) any later version. 17 | 18 | ;; It is distributed in the hope that it will be useful, but WITHOUT 19 | ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 20 | ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public 21 | ;; License for more details. 22 | 23 | ;; You should have received a copy of the GNU General Public 24 | ;; License along with this program; if not, write to the Free 25 | ;; Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, 26 | ;; MA 02110-1301 USA 27 | 28 | ;;; Commentary: 29 | 30 | ;; The standard library tooltip.el provides the function for displaying 31 | ;; a tooltip at mouse position which allows users to easily show it. 32 | ;; However, locating tooltip at arbitrary buffer position in window 33 | ;; is not easy. This program provides such function to be used by other 34 | ;; frontend programs. 35 | 36 | ;; This program is tested on GNU Emacs 22, 23 under X window system and 37 | ;; Emacs 23 for MS-Windows. 38 | 39 | ;; 40 | ;; Installation: 41 | ;; 42 | ;; First, save this file as pos-tip.el and byte-compile in 43 | ;; a directory that is listed in load-path. 44 | ;; 45 | ;; Put the following in your .emacs file: 46 | ;; 47 | ;; (require 'pos-tip) 48 | ;; 49 | ;; To use the full features of this program on MS-Windows, 50 | ;; put the additional setting in .emacs file: 51 | ;; 52 | ;; (pos-tip-w32-max-width-height) ; Maximize frame temporarily 53 | ;; 54 | ;; or 55 | ;; 56 | ;; (pos-tip-w32-max-width-height t) ; Keep frame maximized 57 | 58 | ;; 59 | ;; Examples: 60 | ;; 61 | ;; We can display a tooltip at the current position by the following: 62 | ;; 63 | ;; (pos-tip-show "foo bar") 64 | ;; 65 | ;; If you'd like to specify the tooltip color, use an expression as: 66 | ;; 67 | ;; (pos-tip-show "foo bar" '("white" . "red")) 68 | ;; 69 | ;; Here, "white" and "red" are the foreground color and background 70 | ;; color, respectively. 71 | 72 | 73 | ;;; History: 74 | ;; 2023-07-21 75 | ;; * Various bug fixes 76 | ;; * Settings were changed to use defcustom. 77 | ;; * Version 0.4.7 78 | ;; 79 | ;; 2013-07-16 P. Kalinowski 80 | ;; * Adjusted `pos-tip-show' to correctly set tooltip text foreground 81 | ;; color when using custom color themes. 82 | ;; * Version 0.4.6 83 | ;; 84 | ;; 2010-09-27 S. Irie 85 | ;; * Simplified implementation of `pos-tip-window-system' 86 | ;; * Version 0.4.5 87 | ;; 88 | ;; 2010-08-20 S. Irie 89 | ;; * Changed to use `window-line-height' to calculate tooltip position 90 | ;; * Changed `pos-tip-string-width-height' to ignore last empty line 91 | ;; * Version 0.4.4 92 | ;; 93 | ;; 2010-07-25 S. Irie 94 | ;; * Bug fix 95 | ;; * Version 0.4.3 96 | ;; 97 | ;; 2010-06-09 S. Irie 98 | ;; * Bug fix 99 | ;; * Version 0.4.2 100 | ;; 101 | ;; 2010-06-04 S. Irie 102 | ;; * Added support for text-scale-mode 103 | ;; * Version 0.4.1 104 | ;; 105 | ;; 2010-05-04 S. Irie 106 | ;; * Added functions: 107 | ;; `pos-tip-x-display-width', `pos-tip-x-display-height' 108 | ;; `pos-tip-normalize-natnum', `pos-tip-frame-relative-position' 109 | ;; * Fixed the supports for multi-displays and multi-frames 110 | ;; * Version 0.4.0 111 | ;; 112 | ;; 2010-04-29 S. Irie 113 | ;; * Modified to avoid byte-compile warning 114 | ;; * Bug fix 115 | ;; * Version 0.3.6 116 | ;; 117 | ;; 2010-04-29 S. Irie 118 | ;; * Renamed argument MAX-HEIGHT of `pos-tip-fill-string' to MAX-ROWS 119 | ;; * Modified old FSF address 120 | ;; * Version 0.3.5 121 | ;; 122 | ;; 2010-04-29 S. Irie 123 | ;; * Modified `pos-tip-show' to truncate string exceeding display size 124 | ;; * Added function `pos-tip-truncate-string' 125 | ;; * Added optional argument MAX-ROWS to `pos-tip-split-string' 126 | ;; * Added optional argument MAX-HEIGHT to `pos-tip-fill-string' 127 | ;; * Version 0.3.4 128 | ;; 129 | ;; 2010-04-16 S. Irie 130 | ;; * Changed `pos-tip-show' not to fill paragraph unless exceeding WIDTH 131 | ;; * Version 0.3.3 132 | ;; 133 | ;; 2010-04-08 S. Irie 134 | ;; * Bug fix 135 | ;; * Version 0.3.2 136 | ;; 137 | ;; 2010-03-31 S. Irie 138 | ;; * Bug fix 139 | ;; * Version 0.3.1 140 | ;; 141 | ;; 2010-03-30 S. Irie 142 | ;; * Added support for MS-Windows 143 | ;; * Added option `pos-tip-use-relative-coordinates' 144 | ;; * Bug fixes 145 | ;; * Version 0.3.0 146 | ;; 147 | ;; 2010-03-23 S. Irie 148 | ;; * Changed argument WORD-WRAP to JUSTIFY 149 | ;; * Added optional argument SQUEEZE 150 | ;; * Added function `pos-tip-fill-string' 151 | ;; * Added option `pos-tip-tab-width' used to expand tab characters 152 | ;; * Bug fixes 153 | ;; * Version 0.2.0 154 | ;; 155 | ;; 2010-03-22 S. Irie 156 | ;; * Added optional argument WORD-WRAP to `pos-tip-split-string' 157 | ;; * Changed `pos-tip-show' to perform word wrap or kinsoku shori 158 | ;; * Version 0.1.8 159 | ;; 160 | ;; 2010-03-20 S. Irie 161 | ;; * Added optional argument DY 162 | ;; * Bug fix 163 | ;; * Modified docstrings 164 | ;; * Version 0.1.7 165 | ;; 166 | ;; 2010-03-18 S. Irie 167 | ;; * Added/modified docstrings 168 | ;; * Changed working buffer name to " *xwininfo*" 169 | ;; * Version 0.1.6 170 | ;; 171 | ;; 2010-03-17 S. Irie 172 | ;; * Fixed typos in docstrings 173 | ;; * Version 0.1.5 174 | ;; 175 | ;; 2010-03-16 S. Irie 176 | ;; * Added support for multi-display environment 177 | ;; * Bug fix 178 | ;; * Version 0.1.4 179 | ;; 180 | ;; 2010-03-16 S. Irie 181 | ;; * Bug fix 182 | ;; * Changed calculation for `x-max-tooltip-size' 183 | ;; * Modified docstring 184 | ;; * Version 0.1.3 185 | ;; 186 | ;; 2010-03-11 S. Irie 187 | ;; * Modified commentary 188 | ;; * Version 0.1.2 189 | ;; 190 | ;; 2010-03-11 S. Irie 191 | ;; * Re-implemented `pos-tip-string-width-height' 192 | ;; * Added indicator variable `pos-tip-upperside-p' 193 | ;; * Version 0.1.1 194 | ;; 195 | ;; 2010-03-09 S. Irie 196 | ;; * Re-implemented `pos-tip-show' (*incompatibly changed*) 197 | ;; - Use frame default font 198 | ;; - Automatically calculate tooltip pixel size 199 | ;; - Added optional arguments: TIP-COLOR, MAX-WIDTH 200 | ;; * Added utility functions: 201 | ;; `pos-tip-split-string', `pos-tip-string-width-height' 202 | ;; * Bug fixes 203 | ;; * Version 0.1.0 204 | ;; 205 | ;; 2010-03-08 S. Irie 206 | ;; * Added optional argument DX 207 | ;; * Version 0.0.4 208 | ;; 209 | ;; 2010-03-08 S. Irie 210 | ;; * Bug fix 211 | ;; * Version 0.0.3 212 | ;; 213 | ;; 2010-03-08 S. Irie 214 | ;; * Modified to move out mouse pointer 215 | ;; * Version 0.0.2 216 | ;; 217 | ;; 2010-03-07 S. Irie 218 | ;; * First release 219 | ;; * Version 0.0.1 220 | 221 | ;; ToDo: 222 | 223 | ;;; Code: 224 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 225 | ;; Settings 226 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 227 | 228 | (defgroup pos-tip nil 229 | "Show tooltip at point" 230 | :group 'faces 231 | :prefix "pos-tip-") 232 | 233 | (defcustom pos-tip-border-width 1 234 | "Outer border width of pos-tip's tooltip." 235 | :type 'integer 236 | :group 'pos-tip) 237 | 238 | (defcustom pos-tip-internal-border-width 2 239 | "Text margin of pos-tip's tooltip." 240 | :type 'integer 241 | :group 'pos-tip) 242 | 243 | (defcustom pos-tip-foreground-color nil 244 | "Default foreground color of pos-tip's tooltip. 245 | When `nil', look up the foreground color of the `tooltip' face." 246 | :type '(choice (const :tag "Default" nil) 247 | string) 248 | :group 'pos-tip) 249 | 250 | (defcustom pos-tip-background-color nil 251 | "Default background color of pos-tip's tooltip. 252 | When `nil', look up the background color of the `tooltip' face." 253 | :type '(choice (const :tag "Default" nil) 254 | string) 255 | :group 'pos-tip) 256 | 257 | (defcustom pos-tip-tab-width nil 258 | "Tab width used for `pos-tip-split-string' and `pos-tip-fill-string' 259 | to expand tab characters. nil means use default value of `tab-width'." 260 | :type '(choice (const :tag "Default" nil) 261 | integer) 262 | :group 'pos-tip) 263 | 264 | (defcustom pos-tip-use-relative-coordinates nil 265 | "Non-nil means tooltip location is calculated as a coordinates 266 | relative to the top left corner of frame. In this case the tooltip 267 | will always be displayed within the frame. 268 | 269 | Note that this variable is automatically set to non-nil if absolute 270 | coordinates can't be obtained by `pos-tip-compute-pixel-position'." 271 | :type 'boolean 272 | :group 'pos-tip) 273 | 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | ;; Functions 276 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 277 | 278 | (defun pos-tip-window-system (&optional frame) 279 | "The name of the window system that FRAME is displaying through. 280 | The value is a symbol---for instance, `x' for X windows. 281 | The value is nil if Emacs is using a text-only terminal. 282 | 283 | FRAME defaults to the currently selected frame." 284 | (let ((type (framep (or frame (selected-frame))))) 285 | (if type 286 | (and (not (eq type t)) 287 | type) 288 | (signal 'wrong-type-argument (list 'framep frame))))) 289 | 290 | (defun pos-tip-normalize-natnum (object &optional n) 291 | "Return a Nth power of 2 if OBJECT is a positive integer. 292 | Otherwise return 0. Omitting N means return 1 for a positive integer." 293 | (ash (if (and (natnump object) (> object 0)) 1 0) 294 | (or n 0))) 295 | 296 | (defvar pos-tip-saved-frame-coordinates '(0 . 0) 297 | "The latest result of `pos-tip-frame-top-left-coordinates'.") 298 | 299 | (defvar pos-tip-frame-offset nil 300 | "The latest result of `pos-tip-calibrate-frame-offset'. This value 301 | is used for non-X graphical environment.") 302 | 303 | (defvar pos-tip-frame-offset-array [nil nil nil nil] 304 | "Array of the results of `pos-tip-calibrate-frame-offset'. They are 305 | recorded only when `pos-tip-frame-top-left-coordinates' is called for a 306 | non-X but graphical frame. 307 | 308 | The 2nd and 4th elements are the values for frames having a menu bar. 309 | The 3rd and 4th elements are the values for frames having a tool bar.") 310 | 311 | (defun pos-tip-frame-top-left-coordinates (&optional frame) 312 | "Return the pixel coordinates of FRAME as a cons cell (LEFT . TOP), 313 | which are relative to top left corner of screen. 314 | 315 | Return nil if failing to acquire the coordinates. 316 | 317 | If FRAME is omitted, use selected-frame. 318 | 319 | Users can also get the frame coordinates by referring the variable 320 | `pos-tip-saved-frame-coordinates' just after calling this function." 321 | (let ((winsys (pos-tip-window-system frame))) 322 | (cond 323 | ((null winsys) 324 | (error "text-only frame: %S" frame)) 325 | ((eq winsys 'x) 326 | (condition-case nil 327 | (with-current-buffer (get-buffer-create " *xwininfo*") 328 | (let ((case-fold-search nil)) 329 | (buffer-disable-undo) 330 | (erase-buffer) 331 | (call-process shell-file-name nil t nil shell-command-switch 332 | (format "xwininfo -display %s -id %s" 333 | (frame-parameter frame 'display) 334 | (frame-parameter frame 'window-id))) 335 | (goto-char (point-min)) 336 | (search-forward "\n Absolute") 337 | (setq pos-tip-saved-frame-coordinates 338 | (cons (string-to-number (buffer-substring-no-properties 339 | (search-forward "X: ") 340 | (line-end-position))) 341 | (string-to-number (buffer-substring-no-properties 342 | (search-forward "Y: ") 343 | (line-end-position))))))) 344 | (error nil))) 345 | (t 346 | (let* ((index (+ (pos-tip-normalize-natnum 347 | (frame-parameter frame 'menu-bar-lines) 0) 348 | (pos-tip-normalize-natnum 349 | (frame-parameter frame 'tool-bar-lines) 1))) 350 | (offset (or (aref pos-tip-frame-offset-array index) 351 | (aset pos-tip-frame-offset-array index 352 | (pos-tip-calibrate-frame-offset frame))))) 353 | (if offset 354 | (setq pos-tip-saved-frame-coordinates 355 | (cons (+ (eval (frame-parameter frame 'left)) 356 | (car offset)) 357 | (+ (eval (frame-parameter frame 'top)) 358 | (cdr offset)))))))))) 359 | 360 | (defun pos-tip-frame-relative-position 361 | (frame1 frame2 &optional w32-frame frame-coord1 frame-coord2) 362 | "Return the pixel coordinates of FRAME1 relative to FRAME2 363 | as a cons cell (LEFT . TOP). 364 | 365 | W32-FRAME non-nil means both of frames are under `w32' window system. 366 | 367 | FRAME-COORD1 and FRAME-COORD2, if given, specify the absolute 368 | coordinates of FRAME1 and FRAME2, respectively, which make the 369 | calculations faster if the frames have different heights of menu bars 370 | and tool bars." 371 | (if (and (eq (pos-tip-normalize-natnum 372 | (frame-parameter frame1 'menu-bar-lines)) 373 | (pos-tip-normalize-natnum 374 | (frame-parameter frame2 'menu-bar-lines))) 375 | (or w32-frame 376 | (eq (pos-tip-normalize-natnum 377 | (frame-parameter frame1 'tool-bar-lines)) 378 | (pos-tip-normalize-natnum 379 | (frame-parameter frame2 'tool-bar-lines))))) 380 | (cons (- (eval (frame-parameter frame1 'left)) 381 | (eval (frame-parameter frame2 'left))) 382 | (- (eval (frame-parameter frame1 'top)) 383 | (eval (frame-parameter frame2 'top)))) 384 | (unless frame-coord1 385 | (setq frame-coord1 (let (pos-tip-saved-frame-coordinates) 386 | (pos-tip-frame-top-left-coordinates frame1)))) 387 | (unless frame-coord2 388 | (setq frame-coord2 (let (pos-tip-saved-frame-coordinates) 389 | (pos-tip-frame-top-left-coordinates frame2)))) 390 | (cons (- (car frame-coord1) (car frame-coord2)) 391 | (- (cdr frame-coord1) (cdr frame-coord2))))) 392 | 393 | (defvar pos-tip-upperside-p nil 394 | "Non-nil indicates the latest result of `pos-tip-compute-pixel-position' 395 | was upper than the location specified by the arguments.") 396 | 397 | (defvar pos-tip-w32-saved-max-width-height nil 398 | "Display pixel size effective for showing tooltip in MS-Windows desktop. 399 | This doesn't include the taskbar area, so isn't same as actual display size.") 400 | 401 | (defun pos-tip-compute-pixel-position 402 | (&optional pos window pixel-width pixel-height frame-coordinates dx dy) 403 | "Return pixel position of POS in WINDOW like (X . Y), which indicates 404 | the absolute or relative coordinates of bottom left corner of the object. 405 | 406 | Omitting POS and WINDOW means use current position and selected window, 407 | respectively. 408 | 409 | If PIXEL-WIDTH and PIXEL-HEIGHT are given, this function assumes these 410 | values as the size of small window like tooltip which is located around the 411 | object at POS. These values are used to adjust the location in order that 412 | the tooltip won't disappear by sticking out of the display. By referring 413 | the variable `pos-tip-upperside-p' after calling this function, user can 414 | examine whether the tooltip will be located above the specified position. 415 | 416 | If FRAME-COORDINATES is omitted or nil, automatically obtain the absolute 417 | coordinates of the top left corner of frame which WINDOW is on. Here, 418 | `top left corner of frame' represents the origin of `window-pixel-edges' 419 | and its coordinates are essential for calculating the return value as 420 | absolute coordinates. If a cons cell like (LEFT . TOP), specifies the 421 | frame absolute location and makes the calculation slightly faster, but can 422 | be used only when it's clear that frame is in the specified position. Users 423 | can get the latest values of frame coordinates for using in the next call 424 | by referring the variable `pos-tip-saved-frame-coordinates' just after 425 | calling this function. Otherwise, FRAME-COORDINATES `relative' means return 426 | pixel coordinates of the object relative to the top left corner of the frame. 427 | This is the same effect as `pos-tip-use-relative-coordinates' is non-nil. 428 | 429 | DX specifies horizontal offset in pixel. 430 | 431 | DY specifies vertical offset in pixel. This makes the calculations done 432 | without considering the height of object at POS, so the object might be 433 | hidden by the tooltip." 434 | (let* ((frame (window-frame (or window (selected-window)))) 435 | (w32-frame (eq (pos-tip-window-system frame) 'w32)) 436 | (relative (or pos-tip-use-relative-coordinates 437 | (eq frame-coordinates 'relative) 438 | (and w32-frame 439 | (null pos-tip-w32-saved-max-width-height)))) 440 | (frame-coord (or (and relative '(0 . 0)) 441 | frame-coordinates 442 | (pos-tip-frame-top-left-coordinates frame) 443 | (progn 444 | (setq relative t 445 | pos-tip-use-relative-coordinates t) 446 | '(0 . 0)))) 447 | (posn (posn-at-point (or pos (window-point window)) window)) 448 | (line (cdr (posn-actual-col-row posn))) 449 | (line-height (and line 450 | (or (window-line-height line window) 451 | (and (redisplay t) 452 | (window-line-height line window))))) 453 | (x-y (or (posn-x-y posn) 454 | (let ((geom (pos-visible-in-window-p 455 | (or pos (window-point window)) window t))) 456 | (and geom (cons (car geom) (cadr geom)))) 457 | '(0 . 0))) 458 | (x (+ (car frame-coord) 459 | (car (window-inside-pixel-edges window)) 460 | (car x-y) 461 | (or dx 0))) 462 | (y0 (+ (cdr frame-coord) 463 | (cadr (window-pixel-edges window)) 464 | (or (nth 2 line-height) (cdr x-y)))) 465 | (y (+ y0 466 | (or dy 467 | (car line-height) 468 | (with-current-buffer (window-buffer window) 469 | (cond 470 | ;; `posn-object-width-height' returns an incorrect value 471 | ;; when the header line is displayed (Emacs bug #4426). 472 | ((and posn 473 | (null header-line-format)) 474 | (cdr (posn-object-width-height posn))) 475 | ((and (bound-and-true-p text-scale-mode) 476 | (not (zerop (with-no-warnings 477 | text-scale-mode-amount)))) 478 | (round (* (frame-char-height frame) 479 | (with-no-warnings 480 | (expt text-scale-mode-step 481 | text-scale-mode-amount))))) 482 | (t 483 | (frame-char-height frame))))))) 484 | xmax ymax) 485 | (cond 486 | (relative 487 | (setq xmax (frame-pixel-width frame) 488 | ymax (frame-pixel-height frame))) 489 | (w32-frame 490 | (setq xmax (car pos-tip-w32-saved-max-width-height) 491 | ymax (cdr pos-tip-w32-saved-max-width-height))) 492 | (t 493 | (setq xmax (x-display-pixel-width frame) 494 | ymax (x-display-pixel-height frame)))) 495 | (setq pos-tip-upperside-p (> (+ y (or pixel-height 0)) 496 | ymax)) 497 | (cons (max 0 (min x (- xmax (or pixel-width 0)))) 498 | (max 0 (if pos-tip-upperside-p 499 | (- (if dy ymax y0) (or pixel-height 0)) 500 | y))))) 501 | 502 | (defun pos-tip-cancel-timer () 503 | "Cancel timeout of tooltip." 504 | (mapc (lambda (timer) 505 | (if (eq (aref timer 5) 'x-hide-tip) 506 | (cancel-timer timer))) 507 | timer-list)) 508 | 509 | (defun pos-tip-avoid-mouse (left right top bottom &optional frame) 510 | "Move out mouse pointer if it is inside region (LEFT RIGHT TOP BOTTOM) 511 | in FRAME. Return new mouse position like (FRAME . (X . Y))." 512 | (unless frame 513 | (setq frame (selected-frame))) 514 | (let* ((mpos (with-selected-window (frame-selected-window frame) 515 | (mouse-pixel-position))) 516 | (mframe (pop mpos)) 517 | (mx (car mpos)) 518 | (my (cdr mpos))) 519 | (when (and (eq mframe frame) 520 | (numberp mx)) 521 | (let* ((large-number (+ (frame-pixel-width frame) (frame-pixel-height frame))) 522 | (dl (if (> left 2) 523 | (1+ (- mx left)) 524 | large-number)) 525 | (dr (if (< (1+ right) (frame-pixel-width frame)) 526 | (- right mx) 527 | large-number)) 528 | (dt (if (> top 2) 529 | (1+ (- my top)) 530 | large-number)) 531 | (db (if (< (1+ bottom) (frame-pixel-height frame)) 532 | (- bottom my) 533 | large-number)) 534 | (d (min dl dr dt db))) 535 | (when (> d -2) 536 | (cond 537 | ((= d dl) 538 | (setq mx (- left 2))) 539 | ((= d dr) 540 | (setq mx (1+ right))) 541 | ((= d dt) 542 | (setq my (- top 2))) 543 | (t 544 | (setq my (1+ bottom)))) 545 | (set-mouse-pixel-position frame mx my) 546 | (sit-for 0.0001)))) 547 | (cons mframe (and mpos (cons mx my))))) 548 | 549 | (defun pos-tip-compute-foreground-color (tip-color) 550 | "Compute the foreground color to use for tooltip. 551 | 552 | TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR). 553 | If it is nil, use `pos-tip-foreground-color' or the foreground color of the 554 | `tooltip' face." 555 | (or (and (facep tip-color) 556 | (face-attribute tip-color :foreground)) 557 | (car-safe tip-color) 558 | pos-tip-foreground-color 559 | (face-foreground 'tooltip))) 560 | 561 | (defun pos-tip-compute-background-color (tip-color) 562 | "Compute the background color to use for tooltip. 563 | 564 | TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR). 565 | If it is nil, use `pos-tip-background-color' or the background color of the 566 | `tooltip' face." 567 | (or (and (facep tip-color) 568 | (face-attribute tip-color :background)) 569 | (cdr-safe tip-color) 570 | pos-tip-background-color 571 | (face-background 'tooltip))) 572 | 573 | (defun pos-tip-show-no-propertize 574 | (string &optional tip-color pos window timeout pixel-width pixel-height frame-coordinates dx dy) 575 | "Show STRING in a tooltip at POS in WINDOW. 576 | Analogous to `pos-tip-show' except don't propertize STRING by `pos-tip' face. 577 | 578 | PIXEL-WIDTH and PIXEL-HEIGHT specify the size of tooltip, if given. These 579 | are used to adjust the tooltip position in order that it doesn't disappear by 580 | sticking out of the display, and also used to prevent it from vanishing by 581 | overlapping with mouse pointer. 582 | 583 | Note that this function itself doesn't calculate tooltip size because the 584 | character width and height specified by faces are unknown. So users should 585 | calculate PIXEL-WIDTH and PIXEL-HEIGHT by using `pos-tip-tooltip-width' and 586 | `pos-tip-tooltip-height', or use `pos-tip-show' instead, which can 587 | automatically calculate tooltip size. 588 | 589 | See `pos-tip-show' for details. 590 | 591 | Example: 592 | 593 | \(defface my-tooltip 594 | \\='((t 595 | :background \"gray85\" 596 | :foreground \"black\" 597 | :inherit variable-pitch)) 598 | \"Face for my tooltip.\") 599 | 600 | \(defface my-tooltip-highlight 601 | \\='((t 602 | :background \"blue\" 603 | :foreground \"white\" 604 | :inherit my-tooltip)) 605 | \"Face for my tooltip highlighted.\") 606 | 607 | \(let ((str (propertize \" foo \\n bar \\n baz \" \\='face \\='my-tooltip))) 608 | (put-text-property 6 11 \\='face \\='my-tooltip-highlight str) 609 | (pos-tip-show-no-propertize str \\='my-tooltip))" 610 | (unless window 611 | (setq window (selected-window))) 612 | (let* ((frame (window-frame window)) 613 | (winsys (pos-tip-window-system frame)) 614 | (x-frame (eq winsys 'x)) 615 | (w32-frame (eq winsys 'w32)) 616 | (relative (or pos-tip-use-relative-coordinates 617 | (eq frame-coordinates 'relative) 618 | (and w32-frame 619 | (null pos-tip-w32-saved-max-width-height)))) 620 | (x-y (prog1 621 | (pos-tip-compute-pixel-position pos window 622 | pixel-width pixel-height 623 | frame-coordinates dx dy) 624 | (if pos-tip-use-relative-coordinates 625 | (setq relative t)))) 626 | (ax (car x-y)) 627 | (ay (cdr x-y)) 628 | (rx (if relative ax (- ax (car pos-tip-saved-frame-coordinates)))) 629 | (ry (if relative ay (- ay (cdr pos-tip-saved-frame-coordinates)))) 630 | (retval (cons rx ry)) 631 | (fg (pos-tip-compute-foreground-color tip-color)) 632 | (bg (pos-tip-compute-background-color tip-color)) 633 | (use-dxdy (or relative 634 | (not x-frame))) 635 | (spacing (frame-parameter frame 'line-spacing)) 636 | (border (ash (+ pos-tip-border-width 637 | pos-tip-internal-border-width) 638 | 1)) 639 | (x-max-tooltip-size 640 | (cons (+ (if x-frame 1 0) 641 | (/ (- (or pixel-width 642 | (cond 643 | (relative 644 | (frame-pixel-width frame)) 645 | (w32-frame 646 | (car pos-tip-w32-saved-max-width-height)) 647 | (t 648 | (x-display-pixel-width frame)))) 649 | border) 650 | (frame-char-width frame))) 651 | ;; In case of non-zero line spacing, pixel-height will include some 652 | ;; extra space, as required to display the tooltip, but char height 653 | ;; will not. However, it seems that x-show-tip will use char height 654 | ;; to convert maximum row count into maximum tooltip height, so we 655 | ;; need to round up the row count to allow the last line to be 656 | ;; shown. 657 | (ceiling (/ (- (or pixel-height 658 | (x-display-pixel-height frame)) 659 | border) 660 | (float (frame-char-height frame)))))) 661 | (x-gtk-use-system-tooltips nil) ; Don't use Gtk+ tooltip in Emacs 24 662 | (mpos (with-selected-window window (mouse-pixel-position))) 663 | (mframe (car mpos)) 664 | default-frame-alist) 665 | (if (or relative 666 | (and use-dxdy 667 | (null (cadr mpos)))) 668 | (unless (and (cadr mpos) 669 | (eq mframe frame)) 670 | (let* ((edges (window-inside-pixel-edges (cadr (window-list frame)))) 671 | (mx (ash (+ (pop edges) (cadr edges)) -1)) 672 | (my (ash (+ (pop edges) (cadr edges)) -1))) 673 | (setq mframe frame) 674 | (set-mouse-pixel-position mframe mx my) 675 | (sit-for 0.0001))) 676 | (when (and (cadr mpos) 677 | (not (eq mframe frame))) 678 | (let ((rel-coord (pos-tip-frame-relative-position frame mframe w32-frame 679 | frame-coordinates))) 680 | (setq rx (+ rx (car rel-coord)) 681 | ry (+ ry (cdr rel-coord)))))) 682 | (and pixel-width pixel-height 683 | (setq mpos (pos-tip-avoid-mouse rx (+ rx pixel-width 684 | (if w32-frame 3 0)) 685 | ry (+ ry pixel-height) 686 | mframe))) 687 | (x-show-tip string mframe 688 | `((border-width . ,pos-tip-border-width) 689 | (internal-border-width . ,pos-tip-internal-border-width) 690 | ,@(and (not use-dxdy) `((left . ,ax) 691 | (top . ,ay))) 692 | (font . ,(frame-parameter frame 'font)) 693 | ,@(and spacing `((line-spacing . ,spacing))) 694 | ,@(and (stringp fg) `((foreground-color . ,fg))) 695 | ,@(and (stringp bg) `((background-color . ,bg)))) 696 | (and timeout (> timeout 0) timeout) 697 | (and use-dxdy (- rx (cadr mpos))) 698 | (and use-dxdy (- ry (cddr mpos)))) 699 | (if (and timeout (<= timeout 0)) 700 | (pos-tip-cancel-timer)) 701 | retval)) 702 | 703 | (defun pos-tip-split-string (string &optional width margin justify squeeze max-rows) 704 | "Split STRING into fixed width strings. Return a list of these strings. 705 | 706 | WIDTH specifies the width of filling each paragraph. WIDTH nil means use 707 | the width of currently selected frame. Note that this function doesn't add any 708 | padding characters at the end of each row. 709 | 710 | MARGIN, if non-nil, specifies left margin width which is the number of spece 711 | characters to add at the beginning of each row. 712 | 713 | The optional fourth argument JUSTIFY specifies which kind of justification 714 | to do: `full', `left', `right', `center', or `none'. A value of t means handle 715 | each paragraph as specified by its text properties. Omitting JUSTIFY means 716 | don't perform justification, word wrap and kinsoku shori (禁則処理). 717 | 718 | SQUEEZE nil means leave whitespaces other than line breaks untouched. 719 | 720 | MAX-ROWS, if given, specifies maximum number of elements of return value. 721 | The elements exceeding this number are discarded." 722 | (with-temp-buffer 723 | (let* ((tab-width (or pos-tip-tab-width tab-width)) 724 | (fill-column (or width (frame-width))) 725 | (left-margin (or margin 0)) 726 | (kinsoku-limit 1) 727 | indent-tabs-mode 728 | row rows) 729 | (insert string) 730 | (untabify (point-min) (point-max)) 731 | (if justify 732 | (fill-region (point-min) (point-max) justify (not squeeze)) 733 | (setq margin (make-string left-margin ?\s))) 734 | (goto-char (point-min)) 735 | (while (prog2 736 | (let ((line (buffer-substring 737 | (point) (progn (end-of-line) (point))))) 738 | (if justify 739 | (push line rows) 740 | (while (progn 741 | (setq line (concat margin line) 742 | row (truncate-string-to-width line fill-column)) 743 | (push row rows) 744 | (if (not (= (length row) (length line))) 745 | (setq line (substring line (length row)))))))) 746 | (< (point) (point-max)) 747 | (beginning-of-line 2))) 748 | (nreverse (if max-rows 749 | (last rows max-rows) 750 | rows))))) 751 | 752 | (defun pos-tip-fill-string (string &optional width margin justify squeeze max-rows) 753 | "Fill each of the paragraphs in STRING. 754 | 755 | WIDTH specifies the width of filling each paragraph. WIDTH nil means use 756 | the width of currently selected frame. Note that this function doesn't add any 757 | padding characters at the end of each row. 758 | 759 | MARGIN, if non-nil, specifies left margin width which is the number of spece 760 | characters to add at the beginning of each row. 761 | 762 | The optional fourth argument JUSTIFY specifies which kind of justification 763 | to do: `full', `left', `right', `center', or `none'. A value of t means handle 764 | each paragraph as specified by its text properties. Omitting JUSTIFY means 765 | don't perform justification, word wrap and kinsoku shori (禁則処理). 766 | 767 | SQUEEZE nil means leave whitespaces other than line breaks untouched. 768 | 769 | MAX-ROWS, if given, specifies maximum number of rows. The rows exceeding 770 | this number are discarded." 771 | (if justify 772 | (with-temp-buffer 773 | (let* ((tab-width (or pos-tip-tab-width tab-width)) 774 | (fill-column (or width (frame-width))) 775 | (left-margin (or margin 0)) 776 | (kinsoku-limit 1) 777 | indent-tabs-mode) 778 | (insert string) 779 | (untabify (point-min) (point-max)) 780 | (fill-region (point-min) (point-max) justify (not squeeze)) 781 | (if max-rows 782 | (buffer-substring (goto-char (point-min)) 783 | (line-end-position max-rows)) 784 | (buffer-string)))) 785 | (mapconcat 'identity 786 | (pos-tip-split-string string width margin nil nil max-rows) 787 | "\n"))) 788 | 789 | (defun pos-tip-truncate-string (string width height) 790 | "Truncate each line of STRING to WIDTH and discard lines exceeding HEIGHT." 791 | (with-temp-buffer 792 | (insert string) 793 | (goto-char (point-min)) 794 | (let ((nrow 0) 795 | rows) 796 | (while (and (< nrow height) 797 | (prog2 798 | (push (truncate-string-to-width 799 | (buffer-substring (point) (progn (end-of-line) (point))) 800 | width) 801 | rows) 802 | (< (point) (point-max)) 803 | (beginning-of-line 2) 804 | (setq nrow (1+ nrow))))) 805 | (mapconcat 'identity (nreverse rows) "\n")))) 806 | 807 | (defun pos-tip-string-width-height (string) 808 | "Count columns and rows of STRING. Return a cons cell like (WIDTH . HEIGHT). 809 | The last empty line of STRING is ignored. 810 | 811 | Example: 812 | 813 | \(pos-tip-string-width-height \"abc\\nあいう\\n123\") 814 | ;; => (6 . 3)" 815 | (with-temp-buffer 816 | (insert string) 817 | (goto-char (point-min)) 818 | (end-of-line) 819 | (let ((width (current-column)) 820 | (height (if (eq (char-before (point-max)) ?\n) 0 1))) 821 | (while (< (point) (point-max)) 822 | (end-of-line 2) 823 | (setq width (max (current-column) width) 824 | height (1+ height))) 825 | (cons width height)))) 826 | 827 | (defun pos-tip-x-display-width (&optional frame) 828 | "Return maximum column number in tooltip which occupies the full width 829 | of display. Omitting FRAME means use display that selected frame is in." 830 | (1+ (/ (x-display-pixel-width frame) (frame-char-width frame)))) 831 | 832 | (defun pos-tip-x-display-height (&optional frame) 833 | "Return maximum row number in tooltip which occupies the full height 834 | of display. Omitting FRAME means use display that selected frame is in." 835 | (1+ (/ (x-display-pixel-height frame) (frame-char-height frame)))) 836 | 837 | (defun pos-tip-tooltip-width (width char-width) 838 | "Calculate tooltip pixel width." 839 | (+ (* width char-width) 840 | (ash (+ pos-tip-border-width 841 | pos-tip-internal-border-width) 842 | 1))) 843 | 844 | (defun pos-tip-tooltip-height (height char-height &optional frame) 845 | "Calculate tooltip pixel height." 846 | (let ((spacing (or (default-value 'line-spacing) 847 | (frame-parameter frame 'line-spacing)))) 848 | (+ (* height (+ char-height 849 | (cond 850 | ((integerp spacing) 851 | spacing) 852 | ((floatp spacing) 853 | (truncate (* (frame-char-height frame) 854 | spacing))) 855 | (t 0)))) 856 | (ash (+ pos-tip-border-width 857 | pos-tip-internal-border-width) 858 | 1)))) 859 | 860 | (defun pos-tip-show 861 | (string &optional tip-color pos window timeout width frame-coordinates dx dy) 862 | "Show STRING in a tooltip, which is a small X window, at POS in WINDOW 863 | using frame's default font with TIP-COLOR. 864 | 865 | Return pixel position of tooltip relative to top left corner of frame as 866 | a cons cell like (X . Y). 867 | 868 | TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR) 869 | used to specify *only* foreground-color and background-color of tooltip. If 870 | omitted, use `pos-tip-foreground-color' and `pos-tip-background-color' or the 871 | foreground and background color of the `tooltip' face instead. 872 | 873 | Omitting POS and WINDOW means use current position and selected window, 874 | respectively. 875 | 876 | Automatically hide the tooltip after TIMEOUT seconds. Omitting TIMEOUT means 877 | use the default timeout of 5 seconds. Non-positive TIMEOUT means don't hide 878 | tooltip automatically. 879 | 880 | WIDTH, if non-nil, specifies the width of filling each paragraph. 881 | 882 | If FRAME-COORDINATES is omitted or nil, automatically obtain the absolute 883 | coordinates of the top left corner of frame which WINDOW is on. Here, 884 | `top left corner of frame' represents the origin of `window-pixel-edges' 885 | and its coordinates are essential for calculating the absolute coordinates 886 | of the tooltip. If a cons cell like (LEFT . TOP), specifies the frame 887 | absolute location and makes the calculation slightly faster, but can be 888 | used only when it's clear that frame is in the specified position. Users 889 | can get the latest values of frame coordinates for using in the next call 890 | by referring the variable `pos-tip-saved-frame-coordinates' just after 891 | calling this function. Otherwise, FRAME-COORDINATES `relative' means use 892 | the pixel coordinates relative to the top left corner of the frame for 893 | displaying the tooltip. This is the same effect as 894 | `pos-tip-use-relative-coordinates' is non-nil. 895 | 896 | DX specifies horizontal offset in pixel. 897 | 898 | DY specifies vertical offset in pixel. This makes the calculations done 899 | without considering the height of object at POS, so the object might be 900 | hidden by the tooltip. 901 | 902 | See also `pos-tip-show-no-propertize'." 903 | (unless window 904 | (setq window (selected-window))) 905 | (let* ((frame (window-frame window)) 906 | (max-width (pos-tip-x-display-width frame)) 907 | (max-height (pos-tip-x-display-height frame)) 908 | (w-h (pos-tip-string-width-height string)) 909 | (fg (pos-tip-compute-foreground-color tip-color)) 910 | (bg (pos-tip-compute-background-color tip-color)) 911 | (frame-font (face-attribute 'default :font frame)) 912 | (tip-face-attrs (list :font frame-font :foreground fg :background bg))) 913 | (cond 914 | ((and width 915 | (> (car w-h) width)) 916 | (setq string (pos-tip-fill-string string width nil 'none nil max-height) 917 | w-h (pos-tip-string-width-height string))) 918 | ((or (> (car w-h) max-width) 919 | (> (cdr w-h) max-height)) 920 | (setq string (pos-tip-truncate-string string max-width max-height) 921 | w-h (pos-tip-string-width-height string)))) 922 | (pos-tip-show-no-propertize 923 | (propertize string 'face tip-face-attrs) 924 | tip-color pos window timeout 925 | (pos-tip-tooltip-width (car w-h) (frame-char-width frame)) 926 | (pos-tip-tooltip-height (cdr w-h) (frame-char-height frame) frame) 927 | frame-coordinates dx dy))) 928 | 929 | (defalias 'pos-tip-hide 'x-hide-tip 930 | "Hide pos-tip's tooltip.") 931 | 932 | (defun pos-tip-calibrate-frame-offset (&optional frame) 933 | "Return coordinates of FRAME origin relative to the top left corner of 934 | the FRAME extent, like (LEFT . TOP). The return value is recorded to 935 | `pos-tip-frame-offset'. 936 | 937 | Note that this function doesn't correctly work for X frame and Emacs 22." 938 | (setq pos-tip-frame-offset nil) 939 | (let* ((window (frame-first-window frame)) 940 | (delete-frame-functions 941 | '((lambda (frame) 942 | (if (equal (frame-parameter frame 'name) "tooltip") 943 | (setq pos-tip-frame-offset 944 | (cons (eval (frame-parameter frame 'left)) 945 | (eval (frame-parameter frame 'top)))))))) 946 | (pos-tip-border-width 0) 947 | (pos-tip-internal-border-width 1) 948 | (rpos (pos-tip-show "" 949 | `(nil . ,(frame-parameter frame 'background-color)) 950 | (window-start window) window 951 | nil nil 'relative nil 0))) 952 | (sit-for 0) 953 | (pos-tip-hide) 954 | (and pos-tip-frame-offset 955 | (setq pos-tip-frame-offset 956 | (cons (- (car pos-tip-frame-offset) 957 | (car rpos) 958 | (eval (frame-parameter frame 'left))) 959 | (- (cdr pos-tip-frame-offset) 960 | (cdr rpos) 961 | (eval (frame-parameter frame 'top)))))))) 962 | 963 | (defun pos-tip-w32-max-width-height (&optional keep-maximize) 964 | "Maximize the currently selected frame temporarily and set 965 | `pos-tip-w32-saved-max-width-height' the effective display size in order 966 | to become possible to calculate the absolute location of tooltip. 967 | 968 | KEEP-MAXIMIZE non-nil means leave the frame maximized. 969 | 970 | Note that this function is usable only in Emacs 23 for MS-Windows." 971 | (interactive) 972 | (unless (eq window-system 'w32) 973 | (error "`pos-tip-w32-max-width-height' can be used only in w32 frame.")) 974 | ;; Maximize frame 975 | (with-no-warnings (w32-send-sys-command 61488)) 976 | (sit-for 0) 977 | (let ((offset (pos-tip-calibrate-frame-offset))) 978 | (prog1 979 | (setq pos-tip-w32-saved-max-width-height 980 | (cons (frame-pixel-width) 981 | (+ (frame-pixel-height) 982 | (- (cdr offset) (car offset))))) 983 | (if (called-interactively-p 'interactive) 984 | (message "%S" pos-tip-w32-saved-max-width-height)) 985 | (unless keep-maximize 986 | ;; Restore frame 987 | (with-no-warnings (w32-send-sys-command 61728)))))) 988 | 989 | 990 | (provide 'pos-tip) 991 | 992 | ;;; 993 | ;;; pos-tip.el ends here 994 | --------------------------------------------------------------------------------