mirror of https://github.com/Chizi123/.emacs.d.git

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