pdf-util.el (51653B)
1 ;;; pdf-util.el --- PDF Utility functions. -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2013, 2014 Andreas Politz 4 5 ;; Author: Andreas Politz <politza@fh-trier.de> 6 ;; Keywords: files, multimedia 7 8 ;; This program is free software; you can redistribute it and/or modify 9 ;; it under the terms of the GNU General Public License as published by 10 ;; the Free Software Foundation, either version 3 of the License, or 11 ;; (at your option) any later version. 12 13 ;; This program is distributed in the hope that it will be useful, 14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 ;; GNU General Public License for more details. 17 18 ;; You should have received a copy of the GNU General Public License 19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>. 20 21 ;;; Commentary: 22 ;; 23 ;;; Todo: 24 ;; 25 26 ;;; Code: 27 28 (require 'pdf-macs) 29 (require 'cl-lib) 30 (require 'format-spec) 31 (require 'faces) 32 33 ;; These functions are only used after a PdfView window was asserted, 34 ;; which won't succeed, if pdf-view.el isn't loaded. 35 (declare-function pdf-view-image-size "pdf-view") 36 (declare-function pdf-view-image-offset "pdf-view") 37 (declare-function pdf-cache-pagesize "pdf-cache") 38 (declare-function pdf-view-image-type "pdf-view") 39 40 41 42 ;; * ================================================================== * 43 ;; * Compatibility with older Emacssen (< 25.1) 44 ;; * ================================================================== * 45 46 ;; The with-file-modes macro is only available in recent Emacs 47 ;; versions. 48 (eval-when-compile 49 (unless (fboundp 'with-file-modes) 50 (defmacro with-file-modes (modes &rest body) 51 "Execute BODY with default file permissions temporarily set to MODES. 52 MODES is as for `set-default-file-modes'." 53 (declare (indent 1) (debug t)) 54 (let ((umask (make-symbol "umask"))) 55 `(let ((,umask (default-file-modes))) 56 (unwind-protect 57 (progn 58 (set-default-file-modes ,modes) 59 ,@body) 60 (set-default-file-modes ,umask))))))) 61 62 (unless (fboundp 'alist-get) ;;25.1 63 (defun alist-get (key alist &optional default remove) 64 "Get the value associated to KEY in ALIST. 65 DEFAULT is the value to return if KEY is not found in ALIST. 66 REMOVE, if non-nil, means that when setting this element, we should 67 remove the entry if the new value is `eql' to DEFAULT." 68 (ignore remove) ;;Silence byte-compiler. 69 (let ((x (assq key alist))) 70 (if x (cdr x) default)))) 71 72 (require 'register) 73 (unless (fboundp 'register-read-with-preview) 74 (defalias 'register-read-with-preview 'read-char 75 "Compatibility alias for pdf-tools.")) 76 77 ;; In Emacs 24.3 window-width does not have a PIXELWISE argument. 78 (defmacro pdf-util-window-pixel-width (&optional window) 79 "Return the width of WINDOW in pixel." 80 (if (< (cdr (subr-arity (symbol-function 'window-body-width))) 2) 81 (let ((window* (make-symbol "window"))) 82 `(let ((,window* ,window)) 83 (* (window-body-width ,window*) 84 (frame-char-width (window-frame ,window*))))) 85 `(window-body-width ,window t))) 86 87 ;; In Emacs 24.3 image-mode-winprops leads to infinite recursion. 88 (unless (or (> emacs-major-version 24) 89 (and (= emacs-major-version 24) 90 (>= emacs-minor-version 4))) 91 (require 'image-mode) 92 (defvar image-mode-winprops-original-function 93 (symbol-function 'image-mode-winprops)) 94 (defvar image-mode-winprops-alist) 95 (eval-after-load "image-mode" 96 '(defun image-mode-winprops (&optional window cleanup) 97 (if (not (eq major-mode 'pdf-view-mode)) 98 (funcall image-mode-winprops-original-function 99 window cleanup) 100 (cond ((null window) 101 (setq window 102 (if (eq (current-buffer) (window-buffer)) (selected-window) t))) 103 ((eq window t)) 104 ((not (windowp window)) 105 (error "Not a window: %s" window))) 106 (when cleanup 107 (setq image-mode-winprops-alist 108 (delq nil (mapcar (lambda (winprop) 109 (let ((w (car-safe winprop))) 110 (if (or (not (windowp w)) (window-live-p w)) 111 winprop))) 112 image-mode-winprops-alist)))) 113 (let ((winprops (assq window image-mode-winprops-alist))) 114 ;; For new windows, set defaults from the latest. 115 (if winprops 116 ;; Move window to front. 117 (setq image-mode-winprops-alist 118 (cons winprops (delq winprops image-mode-winprops-alist))) 119 (setq winprops (cons window 120 (copy-alist (cdar image-mode-winprops-alist)))) 121 ;; Add winprops before running the hook, to avoid inf-loops if the hook 122 ;; triggers window-configuration-change-hook. 123 (setq image-mode-winprops-alist 124 (cons winprops image-mode-winprops-alist)) 125 (run-hook-with-args 'image-mode-new-window-functions winprops)) 126 winprops))))) 127 128 129 130 ;; * ================================================================== * 131 ;; * Transforming coordinates 132 ;; * ================================================================== * 133 134 135 (defun pdf-util-scale (list-of-edges-or-pos scale &optional rounding-fn) 136 "Scale LIST-OF-EDGES-OR-POS by SCALE. 137 138 SCALE is a cons (SX . SY), by which edges/positions are scaled. 139 If ROUNDING-FN is non-nil, it should be a function of one 140 argument, a real value, returning a rounded 141 value (e.g. `ceiling'). 142 143 The elements in LIST-OF-EDGES-OR-POS should be either a list 144 \(LEFT TOP RIGHT BOT\) or a position \(X . Y\). 145 146 LIST-OF-EDGES-OR-POS may also be a single such element. 147 148 Return scaled list of edges if LIST-OF-EDGES-OR-POS was indeed a list, 149 else return the scaled singleton." 150 151 (let ((have-list-p (listp (car list-of-edges-or-pos)))) 152 (unless have-list-p 153 (setq list-of-edges-or-pos (list list-of-edges-or-pos))) 154 (let* ((sx (car scale)) 155 (sy (cdr scale)) 156 (result 157 (mapcar 158 (lambda (edges) 159 (cond 160 ((consp (cdr edges)) 161 (let ((e (list (* (nth 0 edges) sx) 162 (* (nth 1 edges) sy) 163 (* (nth 2 edges) sx) 164 (* (nth 3 edges) sy)))) 165 (if rounding-fn 166 (mapcar rounding-fn e) 167 e))) 168 (rounding-fn 169 (cons (funcall rounding-fn (* (car edges) sx)) 170 (funcall rounding-fn (* (cdr edges) sy)))) 171 (t 172 (cons (* (car edges) sx) 173 (* (cdr edges) sy))))) 174 list-of-edges-or-pos))) 175 (if have-list-p 176 result 177 (car result))))) 178 179 (defun pdf-util-scale-to (list-of-edges from to &optional rounding-fn) 180 "Scale LIST-OF-EDGES in FROM basis to TO. 181 182 FROM and TO should both be a cons \(WIDTH . HEIGHT\). See also 183 `pdf-util-scale'." 184 185 (pdf-util-scale list-of-edges 186 (cons (/ (float (car to)) 187 (float (car from))) 188 (/ (float (cdr to)) 189 (float (cdr from)))) 190 rounding-fn)) 191 192 (defun pdf-util-scale-pixel-to-points (list-of-pixel-edges 193 &optional rounding-fn displayed-p window) 194 "Scale LIST-OF-PIXEL-EDGES to point values. 195 196 The result depends on the currently displayed page in WINDOW. 197 See also `pdf-util-scale'." 198 (pdf-util-assert-pdf-window window) 199 (pdf-util-scale-to 200 list-of-pixel-edges 201 (pdf-view-image-size displayed-p window) 202 (pdf-cache-pagesize (pdf-view-current-page window)) 203 rounding-fn)) 204 205 (defun pdf-util-scale-points-to-pixel (list-of-points-edges 206 &optional rounding-fn displayed-p window) 207 "Scale LIST-OF-POINTS-EDGES to point values. 208 209 The result depends on the currently displayed page in WINDOW. 210 See also `pdf-util-scale'." 211 (pdf-util-assert-pdf-window window) 212 (pdf-util-scale-to 213 list-of-points-edges 214 (pdf-cache-pagesize (pdf-view-current-page window)) 215 (pdf-view-image-size displayed-p window) 216 rounding-fn)) 217 218 (defun pdf-util-scale-relative-to-points (list-of-relative-edges 219 &optional rounding-fn window) 220 "Scale LIST-OF-RELATIVE-EDGES to point values. 221 222 The result depends on the currently displayed page in WINDOW. 223 See also `pdf-util-scale'." 224 (pdf-util-assert-pdf-window window) 225 (pdf-util-scale-to 226 list-of-relative-edges 227 '(1.0 . 1.0) 228 (pdf-cache-pagesize (pdf-view-current-page window)) 229 rounding-fn)) 230 231 (defun pdf-util-scale-points-to-relative (list-of-points-edges 232 &optional rounding-fn window) 233 "Scale LIST-OF-POINTS-EDGES to relative values. 234 235 See also `pdf-util-scale'." 236 (pdf-util-assert-pdf-window window) 237 (pdf-util-scale-to 238 list-of-points-edges 239 (pdf-cache-pagesize (pdf-view-current-page window)) 240 '(1.0 . 1.0) 241 rounding-fn)) 242 243 (defun pdf-util-scale-pixel-to-relative (list-of-pixel-edges 244 &optional rounding-fn displayed-p window) 245 "Scale LIST-OF-PIXEL-EDGES to relative values. 246 247 The result depends on the currently displayed page in WINDOW. 248 See also `pdf-util-scale'." 249 (pdf-util-assert-pdf-window window) 250 (pdf-util-scale-to 251 list-of-pixel-edges 252 (pdf-view-image-size displayed-p window) 253 '(1.0 . 1.0) 254 rounding-fn)) 255 256 257 (defun pdf-util-scale-relative-to-pixel (list-of-relative-edges 258 &optional rounding-fn displayed-p window) 259 "Scale LIST-OF-EDGES to match SIZE. 260 261 The result depends on the currently displayed page in WINDOW. 262 See also `pdf-util-scale'." 263 (pdf-util-assert-pdf-window window) 264 (pdf-util-scale-to 265 list-of-relative-edges 266 '(1.0 . 1.0) 267 (pdf-view-image-size displayed-p window) 268 rounding-fn)) 269 270 (defun pdf-util-translate (list-of-edges-or-pos 271 offset &optional opposite-direction-p) 272 "Translate LIST-OF-EDGES-OR-POS by OFFSET 273 274 OFFSET should be a cons \(X . Y\), by which to translate 275 LIST-OF-EDGES-OR-POS. If OPPOSITE-DIRECTION-P is non-nil 276 translate by \(-X . -Y\). 277 278 See `pdf-util-scale' for the LIST-OF-EDGES-OR-POS argument." 279 280 (let ((have-list-p (listp (car list-of-edges-or-pos)))) 281 (unless have-list-p 282 (setq list-of-edges-or-pos (list list-of-edges-or-pos))) 283 (let* ((ox (if opposite-direction-p 284 (- (car offset)) 285 (car offset))) 286 (oy (if opposite-direction-p 287 (- (cdr offset)) 288 (cdr offset))) 289 (result 290 (mapcar 291 (lambda (edges) 292 (cond 293 ((consp (cdr edges)) 294 (list (+ (nth 0 edges) ox) 295 (+ (nth 1 edges) oy) 296 (+ (nth 2 edges) ox) 297 (+ (nth 3 edges) oy))) 298 (t 299 (cons (+ (car edges) ox) 300 (+ (cdr edges) oy))))) 301 list-of-edges-or-pos))) 302 (if have-list-p 303 result 304 (car result))))) 305 306 (defun pdf-util-edges-transform (region elts &optional to-region-p) 307 "Translate ELTS according to REGION. 308 309 ELTS may be one edges list or a position or a list thereof. 310 Translate each from region coordinates to (0 0 1 1) or the 311 opposite, if TO-REGION-P is non-nil. All coordinates should be 312 relative. 313 314 Returns the translated list of elements or the single one 315 depending on the input." 316 317 (when elts 318 (let ((have-list-p (consp (car-safe elts)))) 319 (unless have-list-p 320 (setq elts (list elts))) 321 (let ((result 322 (if (null region) 323 elts 324 (mapcar (lambda (edges) 325 (let ((have-pos-p (numberp (cdr edges)))) 326 (when have-pos-p 327 (setq edges (list (car edges) (cdr edges) 328 (car edges) (cdr edges)))) 329 (pdf-util-with-edges (edges region) 330 (let ((newedges 331 (mapcar (lambda (n) 332 (min 1.0 (max 0.0 n))) 333 (if to-region-p 334 `(,(/ (- edges-left region-left) 335 region-width) 336 ,(/ (- edges-top region-top) 337 region-height) 338 ,(/ (- edges-right region-left) 339 region-width) 340 ,(/ (- edges-bot region-top) 341 region-height)) 342 `(,(+ (* edges-left region-width) 343 region-left) 344 ,(+ (* edges-top region-height) 345 region-top) 346 ,(+ (* edges-right region-width) 347 region-left) 348 ,(+ (* edges-bot region-height) 349 region-top)))))) 350 (if have-pos-p 351 (cons (car newedges) (cadr newedges)) 352 newedges))))) 353 elts)))) 354 (if have-list-p 355 result 356 (car result)))))) 357 358 (defmacro pdf-util-with-edges (list-of-edges &rest body) 359 "Provide some convenient macros for the edges in LIST-OF-EDGES. 360 361 LIST-OF-EDGES should be a list of variables \(X ...\), each one 362 holding a list of edges. Inside BODY the symbols X-left, X-top, 363 X-right, X-bot, X-width and X-height expand to their respective 364 values." 365 366 (declare (indent 1) (debug (sexp &rest form))) 367 (unless (cl-every 'symbolp list-of-edges) 368 (error "Argument should be a list of symbols")) 369 (let ((list-of-syms 370 (mapcar (lambda (edge) 371 (cons edge (mapcar 372 (lambda (kind) 373 (intern (format "%s-%s" edge kind))) 374 '(left top right bot width height)))) 375 list-of-edges))) 376 (macroexpand-all 377 `(cl-symbol-macrolet 378 ,(apply 'nconc 379 (mapcar 380 (lambda (edge-syms) 381 (let ((edge (nth 0 edge-syms)) 382 (syms (cdr edge-syms))) 383 `((,(pop syms) (nth 0 ,edge)) 384 (,(pop syms) (nth 1 ,edge)) 385 (,(pop syms) (nth 2 ,edge)) 386 (,(pop syms) (nth 3 ,edge)) 387 (,(pop syms) (- (nth 2 ,edge) 388 (nth 0 ,edge))) 389 (,(pop syms) (- (nth 3 ,edge) 390 (nth 1 ,edge)))))) 391 list-of-syms)) 392 ,@body)))) 393 394 395 ;; * ================================================================== * 396 ;; * Scrolling 397 ;; * ================================================================== * 398 399 (defun pdf-util-image-displayed-edges (&optional window displayed-p) 400 "Return the visible region of the image in WINDOW. 401 402 Returns a list of pixel edges." 403 (pdf-util-assert-pdf-window) 404 (let* ((edges (window-inside-pixel-edges window)) 405 (isize (pdf-view-image-size displayed-p window)) 406 (offset (if displayed-p 407 `(0 . 0) 408 (pdf-view-image-offset window))) 409 (hscroll (* (window-hscroll window) 410 (frame-char-width (window-frame window)))) 411 (vscroll (window-vscroll window t)) 412 (x0 (+ hscroll (car offset))) 413 (y0 (+ vscroll (cdr offset))) 414 (x1 (min (car isize) 415 (+ x0 (- (nth 2 edges) (nth 0 edges))))) 416 (y1 (min (cdr isize) 417 (+ y0 (- (nth 3 edges) (nth 1 edges)))))) 418 (mapcar 'round (list x0 y0 x1 y1)))) 419 420 (defun pdf-util-required-hscroll (edges &optional eager-p context-pixel) 421 "Return the amount of scrolling necessary, to make image EDGES visible. 422 423 Scroll as little as necessary. Unless EAGER-P is non-nil, in 424 which case scroll as much as possible. 425 426 Keep CONTEXT-PIXEL pixel of the image visible at the bottom and 427 top of the window. CONTEXT-PIXEL defaults to 0. 428 429 Return the required hscroll in columns or nil, if scrolling is not 430 needed." 431 432 (pdf-util-assert-pdf-window) 433 (unless context-pixel 434 (setq context-pixel 0)) 435 (let* ((win (window-inside-pixel-edges)) 436 (image-width (car (pdf-view-image-size t))) 437 (image-left (* (frame-char-width) 438 (window-hscroll))) 439 (edges (pdf-util-translate 440 edges 441 (pdf-view-image-offset) t))) 442 (pdf-util-with-edges (win edges) 443 (let* ((edges-left (- edges-left context-pixel)) 444 (edges-right (+ edges-right context-pixel))) 445 (if (< edges-left image-left) 446 (round (/ (max 0 (if eager-p 447 (- edges-right win-width) 448 edges-left)) 449 (frame-char-width))) 450 (if (> (min image-width 451 edges-right) 452 (+ image-left win-width)) 453 (round (/ (min (- image-width win-width) 454 (if eager-p 455 edges-left 456 (- edges-right win-width))) 457 (frame-char-width))))))))) 458 459 (defun pdf-util-required-vscroll (edges &optional eager-p context-pixel) 460 "Return the amount of scrolling necessary, to make image EDGES visible. 461 462 Scroll as little as necessary. Unless EAGER-P is non-nil, in 463 which case scroll as much as possible. 464 465 Keep CONTEXT-PIXEL pixel of the image visible at the bottom and 466 top of the window. CONTEXT-PIXEL defaults to an equivalent pixel 467 value of `next-screen-context-lines'. 468 469 Return the required vscroll in pixels or nil, if scrolling is not 470 needed. 471 472 Note: For versions of emacs before 27 this will return lines instead of 473 pixels. This is because of a change that occurred to `image-mode' in 27." 474 (pdf-util-assert-pdf-window) 475 (let* ((win (window-inside-pixel-edges)) 476 (image-height (cdr (pdf-view-image-size t))) 477 (image-top (window-vscroll nil t)) 478 (edges (pdf-util-translate 479 edges 480 (pdf-view-image-offset) t))) 481 (pdf-util-with-edges (win edges) 482 (let* ((context-pixel (or context-pixel 483 (* next-screen-context-lines 484 (frame-char-height)))) 485 ;;Be careful not to modify edges. 486 (edges-top (- edges-top context-pixel)) 487 (edges-bot (+ edges-bot context-pixel)) 488 (vscroll 489 (cond ((< edges-top image-top) 490 (max 0 (if eager-p 491 (- edges-bot win-height) 492 edges-top))) 493 ((> (min image-height 494 edges-bot) 495 (+ image-top win-height)) 496 (min (- image-height win-height) 497 (if eager-p 498 edges-top 499 (- edges-bot win-height))))))) 500 501 502 (when vscroll 503 (round 504 ;; `image-set-window-vscroll' changed in version 27 to using 505 ;; pixels, not lines. 506 (if (version< emacs-version "27") 507 (/ vscroll (float (frame-char-height))) 508 vscroll))))))) 509 510 (defun pdf-util-scroll-to-edges (edges &optional eager-p) 511 "Scroll window such that image EDGES are visible. 512 513 Scroll as little as necessary. Unless EAGER-P is non-nil, in 514 which case scroll as much as possible." 515 516 (let ((vscroll (pdf-util-required-vscroll edges eager-p)) 517 (hscroll (pdf-util-required-hscroll edges eager-p))) 518 (when vscroll 519 (image-set-window-vscroll vscroll)) 520 (when hscroll 521 (image-set-window-hscroll hscroll)))) 522 523 524 525 ;; * ================================================================== * 526 ;; * Temporary files 527 ;; * ================================================================== * 528 529 (defvar pdf-util--base-directory nil 530 "Base directory for temporary files.") 531 532 (defvar-local pdf-util--dedicated-directory nil 533 "The relative name of buffer's dedicated directory.") 534 535 (defun pdf-util-dedicated-directory () 536 "Return the name of a existing dedicated directory. 537 538 The directory is exclusive to the current buffer. It will be 539 automatically deleted, if Emacs or the current buffer are 540 killed." 541 (with-file-modes #o0700 542 (unless (and pdf-util--base-directory 543 (file-directory-p 544 pdf-util--base-directory) 545 (not (file-symlink-p 546 pdf-util--base-directory))) 547 (add-hook 'kill-emacs-hook 548 (lambda nil 549 (when (and pdf-util--base-directory 550 (file-directory-p pdf-util--base-directory)) 551 (delete-directory pdf-util--base-directory t)))) 552 (setq pdf-util--base-directory 553 (make-temp-file "pdf-tools-" t))) 554 (unless (and pdf-util--dedicated-directory 555 (file-directory-p pdf-util--dedicated-directory) 556 (not (file-symlink-p 557 pdf-util--base-directory))) 558 (let ((temporary-file-directory 559 pdf-util--base-directory)) 560 (setq pdf-util--dedicated-directory 561 (make-temp-file (convert-standard-filename (pdf-util-temp-prefix)) 562 t)) 563 (add-hook 'kill-buffer-hook 'pdf-util-delete-dedicated-directory 564 nil t))) 565 pdf-util--dedicated-directory)) 566 567 (defun pdf-util-delete-dedicated-directory () 568 "Delete current buffer's dedicated directory." 569 (delete-directory (pdf-util-dedicated-directory) t)) 570 571 (defun pdf-util-expand-file-name (name) 572 "Expand filename against current buffer's dedicated directory." 573 (expand-file-name name (pdf-util-dedicated-directory))) 574 575 (defun pdf-util-temp-prefix () 576 "Create a temp-file prefix for the current buffer" 577 (concat (if buffer-file-name 578 (file-name-nondirectory buffer-file-name) 579 (replace-regexp-in-string "[^[:alnum:]]+" "-" (buffer-name))) 580 "-")) 581 582 (defun pdf-util-make-temp-file (&optional prefix dir-flag suffix) 583 "Create a temporary file in current buffer's dedicated directory. 584 585 See `make-temp-file' for the arguments." 586 (let ((temporary-file-directory (pdf-util-dedicated-directory))) 587 (make-temp-file (convert-standard-filename 588 (or prefix (pdf-util-temp-prefix))) 589 dir-flag suffix))) 590 591 592 ;; * ================================================================== * 593 ;; * Various 594 ;; * ================================================================== * 595 596 (defmacro pdf-util-debug (&rest body) 597 "Execute BODY only if debugging is enabled." 598 (declare (indent 0) (debug t)) 599 `(when (bound-and-true-p pdf-tools-debug) 600 ,@body)) 601 602 (defun pdf-util-pdf-buffer-p (&optional buffer) 603 (and (or (null buffer) 604 (buffer-live-p buffer)) 605 (save-current-buffer 606 (and buffer (set-buffer buffer)) 607 (derived-mode-p 'pdf-view-mode)))) 608 609 (defun pdf-util-assert-pdf-buffer (&optional buffer) 610 (unless (pdf-util-pdf-buffer-p buffer) 611 (error "Buffer is not in PDFView mode"))) 612 613 (defun pdf-util-pdf-window-p (&optional window) 614 (unless (or (null window) 615 (window-live-p window)) 616 (signal 'wrong-type-argument (list 'window-live-p window))) 617 (unless window (setq window (selected-window))) 618 (and (window-live-p window) 619 (with-selected-window window 620 (pdf-util-pdf-buffer-p)))) 621 622 (defun pdf-util-assert-pdf-window (&optional window) 623 (unless (pdf-util-pdf-window-p window) 624 (error "Window's buffer is not in PdfView mode"))) 625 626 (defun pdf-util-munch-file (filename &optional multibyte-p) 627 "Read contents from FILENAME and delete it. 628 629 Return the file's content as a unibyte string, unless MULTIBYTE-P 630 is non-nil." 631 (unwind-protect 632 (with-temp-buffer 633 (set-buffer-multibyte multibyte-p) 634 (insert-file-contents-literally filename) 635 (buffer-substring-no-properties 636 (point-min) 637 (point-max))) 638 (when (and filename 639 (file-exists-p filename)) 640 (delete-file filename)))) 641 642 (defun pdf-util-hexcolor (color) 643 "Return COLOR in hex-format. 644 645 Signal an error, if color is invalid." 646 (if (string-match "\\`#[[:xdigit:]]\\{6\\}\\'" color) 647 color 648 (let ((values (color-values color))) 649 (unless values 650 (signal 'wrong-type-argument (list 'color-defined-p color))) 651 (apply 'format "#%02x%02x%02x" 652 (mapcar (lambda (c) (lsh c -8)) 653 values))))) 654 655 (defun pdf-util-highlight-regexp-in-string (regexp string &optional face) 656 "Highlight all occurrences of REGEXP in STRING using FACE. 657 658 FACE defaults to the `match' face. Returns the new fontified 659 string." 660 (with-temp-buffer 661 (save-excursion (insert string)) 662 (while (and (not (eobp)) 663 (re-search-forward regexp nil t)) 664 (if (= (match-beginning 0) 665 (match-end 0)) 666 (forward-char) 667 (put-text-property 668 (match-beginning 0) 669 (point) 670 'face (or face 'match)))) 671 (buffer-string))) 672 673 (defun pdf-util-color-completions () 674 "Return a fontified list of defined colors." 675 (let ((color-list (list-colors-duplicates)) 676 colors) 677 (dolist (cl color-list) 678 (dolist (c (reverse cl)) 679 (push (propertize c 'face `(:background ,c)) 680 colors))) 681 (nreverse colors))) 682 683 (defun pdf-util-tooltip-in-window (text x y &optional window) 684 (let* ((we (window-inside-absolute-pixel-edges window)) 685 (dx (round (+ x (nth 0 we)))) 686 (dy (round (+ y (nth 1 we)))) 687 (tooltip-frame-parameters 688 `((left . ,dx) 689 (top . ,dy) 690 ,@tooltip-frame-parameters))) 691 (tooltip-show text))) 692 693 (defun pdf-util-tooltip-arrow (image-top &optional timeout) 694 (pdf-util-assert-pdf-window) 695 (when (floatp image-top) 696 (setq image-top 697 (round (* image-top (cdr (pdf-view-image-size)))))) 698 (let* (x-gtk-use-system-tooltips ;allow for display property in tooltip 699 (dx (+ (or (car (window-margins)) 0) 700 (car (window-fringes)))) 701 (dy image-top) 702 (pos (list dx dy dx (+ dy (* 2 (frame-char-height))))) 703 (vscroll 704 (pdf-util-required-vscroll pos)) 705 (tooltip-frame-parameters 706 `((border-width . 0) 707 (internal-border-width . 0) 708 ,@tooltip-frame-parameters)) 709 (tooltip-hide-delay (or timeout 3))) 710 (when vscroll 711 (image-set-window-vscroll vscroll)) 712 (setq dy (max 0 (- dy 713 (cdr (pdf-view-image-offset)) 714 (window-vscroll nil t) 715 (frame-char-height)))) 716 (when (overlay-get (pdf-view-current-overlay) 'before-string) 717 (let* ((e (window-inside-pixel-edges)) 718 (xw (pdf-util-with-edges (e) e-width))) 719 (cl-incf dx (/ (- xw (car (pdf-view-image-size t))) 2)))) 720 (pdf-util-tooltip-in-window 721 (propertize 722 " " 'display (propertize 723 "\u2192" ;;right arrow 724 'display '(height 2) 725 'face `(:foreground 726 "orange red" 727 :background 728 ,(cond 729 ((bound-and-true-p pdf-view-midnight-minor-mode) 730 (cdr pdf-view-midnight-colors)) 731 ((bound-and-true-p pdf-view-themed-minor-mode) 732 (face-background 'default nil)) 733 (t "white"))))) 734 dx dy))) 735 736 (defvar pdf-util--face-colors-cache (make-hash-table)) 737 738 (defadvice enable-theme (after pdf-util-clear-faces-cache activate) 739 (clrhash pdf-util--face-colors-cache)) 740 741 (defun pdf-util-face-colors (face &optional dark-p) 742 "Return both colors of FACE as a cons. 743 744 Look also in inherited faces. If DARK-P is non-nil, return dark 745 colors, otherwise light." 746 (let* ((bg (if dark-p 'dark 'light)) 747 (spec (list (get face 'face-defface-spec) 748 (get face 'theme-face) 749 (get face 'customized-face))) 750 (cached (gethash face pdf-util--face-colors-cache))) 751 (cl-destructuring-bind (&optional cspec color-alist) 752 cached 753 (or (and color-alist 754 (equal cspec spec) 755 (cdr (assq bg color-alist))) 756 (let* ((this-bg (frame-parameter nil 'background-mode)) 757 (frame-background-mode bg) 758 (f (and (not (eq bg this-bg)) 759 (x-create-frame-with-faces '((visibility . nil)))))) 760 (with-selected-frame (or f (selected-frame)) 761 (unwind-protect 762 (let ((colors 763 (cons (face-attribute face :foreground nil 'default) 764 (face-attribute face :background nil 'default)))) 765 (puthash face `(,(mapcar 'copy-sequence spec) 766 ((,bg . ,colors) ,@color-alist)) 767 pdf-util--face-colors-cache) 768 colors) 769 (when (and f (frame-live-p f)) 770 (delete-frame f))))))))) 771 772 (defun pdf-util-window-attach (awindow &optional window) 773 "Attach AWINDOW to WINDOW. 774 775 This has the following effect. Whenever WINDOW, defaulting to 776 the selected window, stops displaying the buffer it currently 777 displays (e.g., by switching buffers or because it was deleted) 778 AWINDOW is deleted." 779 (unless window (setq window (selected-window))) 780 (let ((buffer (window-buffer window)) 781 (hook (make-symbol "window-attach-hook"))) 782 (fset hook 783 (lambda () 784 (when (or (not (window-live-p window)) 785 (not (eq buffer (window-buffer window)))) 786 (remove-hook 'window-configuration-change-hook 787 hook) 788 ;; Deleting windows inside wcch may cause errors in 789 ;; windows.el . 790 (run-with-timer 791 0 nil (lambda (win) 792 (when (and (window-live-p win) 793 (not (eq win (selected-window)))) 794 (delete-window win))) 795 awindow)))) 796 (add-hook 'window-configuration-change-hook hook))) 797 798 (defun display-buffer-split-below-and-attach (buf alist) 799 "Display buffer action using `pdf-util-window-attach'." 800 (let ((window (selected-window)) 801 (height (cdr (assq 'window-height alist))) 802 newwin) 803 (when height 804 (when (floatp height) 805 (setq height (round (* height (frame-height))))) 806 (setq height (- (max height window-min-height)))) 807 (setq newwin (window--display-buffer 808 buf 809 (split-window-below height) 810 'window alist)) 811 (pdf-util-window-attach newwin window) 812 newwin)) 813 814 (defun pdf-util-goto-position (line &optional column) 815 "Goto LINE and COLUMN in the current buffer. 816 817 COLUMN defaults to 0. Widen the buffer, if the position is 818 outside the current limits." 819 (let ((pos 820 (when (> line 0) 821 (save-excursion 822 (save-restriction 823 (widen) 824 (goto-char 1) 825 (when (= 0 (forward-line (1- line))) 826 (when (and column (> column 0)) 827 (forward-char (1- column))) 828 (point))))))) 829 (when pos 830 (when (or (< pos (point-min)) 831 (> pos (point-max))) 832 (widen)) 833 (goto-char pos)))) 834 835 (defun pdf-util-seq-alignment (seq1 seq2 &optional similarity-fn alignment-type) 836 "Return an alignment of sequences SEQ1 and SEQ2. 837 838 SIMILARITY-FN should be a function. It is called with two 839 arguments: One element from SEQ1 and one from SEQ2. It should 840 return a number determining how similar the elements are, where 841 higher values mean `more similar'. The default returns 1 if the 842 elements are equal, else -1. 843 844 ALIGNMENT-TYPE may be one of the symbols `prefix', `suffix', 845 `infix' or nil. If it is `prefix', trailing elements in SEQ2 may 846 be ignored. For example the alignment of 847 848 \(0 1\) and \(0 1 2\) 849 850 using prefix matching is 0, since the prefixes are equal and the 851 trailing 2 is ignored. The other possible values have similar 852 effects. The default is nil, which means to match the whole 853 sequences. 854 855 Return a cons \(VALUE . ALIGNMENT\), where VALUE says how similar 856 the sequences are and ALIGNMENT is a list of \(E1 . E2\), where 857 E1 is an element from SEQ1 or nil, likewise for E2. If one of 858 them is nil, it means there is gap at this position in the 859 respective sequence." 860 861 (cl-macrolet ((make-matrix (rows columns) 862 (list 'apply (list 'quote 'vector) 863 (list 'cl-loop 'for 'i 'from 1 'to rows 864 'collect (list 'make-vector columns nil)))) 865 (mset (matrix row column newelt) 866 (list 'aset (list 'aref matrix row) column newelt)) 867 (mref (matrix row column) 868 (list 'aref (list 'aref matrix row) column))) 869 (let* ((nil-value nil) 870 (len1 (length seq1)) 871 (len2 (length seq2)) 872 (d (make-matrix (1+ len1) (1+ len2))) 873 (prefix-p (memq alignment-type '(prefix infix))) 874 (suffix-p (memq alignment-type '(suffix infix))) 875 (similarity-fn (or similarity-fn 876 (lambda (a b) 877 (if (equal a b) 1 -1))))) 878 879 (cl-loop for i from 0 to len1 do 880 (mset d i 0 (- i))) 881 (cl-loop for j from 0 to len2 do 882 (mset d 0 j (if suffix-p 0 (- j)))) 883 884 (cl-loop for i from 1 to len1 do 885 (cl-loop for j from 1 to len2 do 886 (let ((max (max 887 (1- (mref d (1- i) j)) 888 (+ (mref d i (1- j)) 889 (if (and prefix-p (= i len1)) 0 -1)) 890 (+ (mref d (1- i) (1- j)) 891 (funcall similarity-fn 892 (elt seq1 (1- i)) 893 (elt seq2 (1- j))))))) 894 (mset d i j max)))) 895 896 (let ((i len1) 897 (j len2) 898 alignment) 899 (while (or (> i 0) 900 (> j 0)) 901 (cond 902 ((and (> i 0) 903 (= (mref d i j) 904 (1- (mref d (1- i) j)))) 905 (cl-decf i) 906 (push (cons (elt seq1 i) nil-value) alignment)) 907 ((and (> j 0) 908 (= (mref d i j) 909 (+ (mref d i (1- j)) 910 (if (or (and (= i 0) suffix-p) 911 (and (= i len1) prefix-p)) 912 0 -1)))) 913 (cl-decf j) 914 (push (cons nil-value (elt seq2 j)) alignment)) 915 (t 916 (cl-assert (and (> i 0) (> j 0)) t) 917 (cl-decf i) 918 (cl-decf j) 919 (push (cons (elt seq1 i) 920 (elt seq2 j)) alignment)))) 921 (cons (mref d len1 len2) alignment))))) 922 923 924 (defun pdf-util-pcre-quote (string) 925 "Escape STRING for use as a PCRE. 926 927 See also `regexp-quote'." 928 929 (let ((to-escape 930 (eval-when-compile (append "\0\\|()[]{}^$*+?." nil))) 931 (chars (append string nil)) 932 escaped) 933 (dolist (ch chars) 934 (when (memq ch to-escape) 935 (push ?\\ escaped)) 936 (push ch escaped)) 937 (apply 'string (nreverse escaped)))) 938 939 (defun pdf-util-frame-ppi () 940 "Return the PPI of the current frame." 941 (let* ((props (frame-monitor-attributes)) 942 (px (nthcdr 2 (alist-get 'geometry props))) 943 (mm (alist-get 'mm-size props)) 944 (dp (sqrt (+ (expt (nth 0 px) 2) 945 (expt (nth 1 px) 2)))) 946 (di (sqrt (+ (expt (/ (nth 0 mm) 25.4) 2) 947 (expt (/ (nth 1 mm) 25.4) 2))))) 948 (/ dp di))) 949 950 (defvar pdf-view-use-scaling) 951 952 (defun pdf-util-frame-scale-factor () 953 "Return the frame scale factor depending on the image type used for display. 954 When `pdf-view-use-scaling' is non-nil, return the scale factor of the frame 955 if available. If the scale factor isn't available, return 2 if the 956 frame's PPI is larger than 180. Otherwise, return 1." 957 (if pdf-view-use-scaling 958 (or (and (fboundp 'frame-scale-factor) 959 (truncate (frame-scale-factor))) 960 (and (fboundp 'frame-monitor-attributes) 961 (cdr (assq 'backing-scale-factor (frame-monitor-attributes)))) 962 (if (>= (pdf-util-frame-ppi) 180) 963 2 964 1)) 965 1)) 966 967 968 ;; * ================================================================== * 969 ;; * Imagemagick's convert 970 ;; * ================================================================== * 971 972 (defcustom pdf-util-convert-program 973 ;; Avoid using the MS Windows command convert.exe . 974 (unless (memq system-type '(ms-dos windows-nt)) 975 (executable-find "convert")) 976 "Absolute path to the convert program." 977 :group 'pdf-tools 978 :type 'executable) 979 980 (defcustom pdf-util-fast-image-format nil 981 "An image format appropriate for fast displaying. 982 983 This should be a cons \(TYPE . EXT\) where type is the Emacs 984 image-type and EXT the appropriate file extension starting with a 985 dot. If nil, the value is determined automatically. 986 987 Different formats have different properties, with respect to 988 Emacs loading time, convert creation time and the file-size. In 989 general, uncompressed formats are faster, but may need a fair 990 amount of (temporary) disk space." 991 :group 'pdf-tools 992 :type '(cons symbol string)) 993 994 (defun pdf-util-assert-convert-program () 995 (unless (and pdf-util-convert-program 996 (file-executable-p pdf-util-convert-program)) 997 (error "The pdf-util-convert-program is unset or non-executable"))) 998 999 (defun pdf-util-image-file-size (image-file) 1000 "Determine the size of the image in IMAGE-FILE. 1001 1002 Returns a cons \(WIDTH . HEIGHT\)." 1003 (pdf-util-assert-convert-program) 1004 (with-temp-buffer 1005 (when (save-excursion 1006 (= 0 (call-process 1007 pdf-util-convert-program 1008 nil (current-buffer) nil 1009 image-file "-format" "%w %h" "info:"))) 1010 (let ((standard-input (current-buffer))) 1011 (cons (read) (read)))))) 1012 1013 (defun pdf-util-convert (in-file out-file &rest spec) 1014 "Convert image IN-FILE to OUT-FILE according to SPEC. 1015 1016 IN-FILE should be the name of a file containing an image. Write 1017 the result to OUT-FILE. The extension of this filename usually 1018 determines the resulting image-type. 1019 1020 SPEC is a property list, specifying what the convert program 1021 should do with the image. All manipulations operate on a 1022 rectangle, see below. 1023 1024 SPEC may contain the following keys, respectively values. 1025 1026 `:foreground' Set foreground color for all following operations. 1027 1028 `:background' Dito, for the background color. 1029 1030 `:commands' A list of strings representing arguments to convert 1031 for image manipulations. It may contain %-escape characters, as 1032 follows. 1033 1034 %f -- Expands to the foreground color. 1035 %b -- Expands to the background color. 1036 %g -- Expands to the geometry of the current rectangle, i.e. WxH+X+Y. 1037 %x -- Expands to the left edge of rectangle. 1038 %X -- Expands to the right edge of rectangle. 1039 %y -- Expands to the top edge of rectangle. 1040 %Y -- Expands to the bottom edge of rectangle. 1041 %w -- Expands to the width of rectangle. 1042 %h -- Expands to the height of rectangle. 1043 1044 Keep in mind, that every element of this list is seen by convert 1045 as a single argument. 1046 1047 `:formats' An alist of additional %-escapes. Every element 1048 should be a cons \(CHAR . STRING\) or \(CHAR . FUNCTION\). In 1049 the first case, all occurrences of %-CHAR in the above commands 1050 will be replaced by STRING. In the second case FUNCTION is 1051 called with the current rectangle and it should return the 1052 replacement string. 1053 1054 `:apply' A list of rectangles \(\(LEFT TOP RIGHT BOT\) ...\) in 1055 IN-FILE coordinates. Each such rectangle triggers one execution 1056 of the last commands given earlier in SPEC. E.g. a call like 1057 1058 \(pdf-util-convert 1059 image-file out-file 1060 :foreground \"black\" 1061 :background \"white\" 1062 :commands '\(\"-fill\" \"%f\" \"-draw\" \"rectangle %x,%y,%X,%Y\"\) 1063 :apply '\(\(0 0 10 10\) \(10 10 20 20\)\) 1064 :commands '\(\"-fill\" \"%b\" \"-draw\" \"rectangle %x,%y,%X,%Y\"\) 1065 :apply '\(\(10 0 20 10\) \(0 10 10 20\)\)\) 1066 1067 would draw a 4x4 checkerboard pattern in the left corner of the 1068 image, while leaving the rest of it as it was. 1069 1070 Returns OUT-FILE. 1071 1072 See url `http://www.imagemagick.org/script/convert.php'." 1073 (pdf-util-assert-convert-program) 1074 (let* ((cmds (pdf-util-convert--create-commands spec)) 1075 (status (apply 'call-process 1076 pdf-util-convert-program nil 1077 (get-buffer-create "*pdf-util-convert-output*") 1078 nil 1079 `(,in-file ,@cmds ,out-file)))) 1080 (unless (and (numberp status) (= 0 status)) 1081 (error "The convert program exited with error status: %s" status)) 1082 out-file)) 1083 1084 (defun pdf-util-convert-asynch (in-file out-file &rest spec-and-callback) 1085 "Like `pdf-util-convert', but asynchronous. 1086 1087 If the last argument is a function, it is installed as the 1088 process sentinel. 1089 1090 Returns the convert process." 1091 (pdf-util-assert-convert-program) 1092 (let ((callback (car (last spec-and-callback))) 1093 spec) 1094 (if (functionp callback) 1095 (setq spec (butlast spec-and-callback)) 1096 (setq spec spec-and-callback 1097 callback nil)) 1098 (let* ((cmds (pdf-util-convert--create-commands spec)) 1099 (proc 1100 (apply 'start-process "pdf-util-convert" 1101 (get-buffer-create "*pdf-util-convert-output*") 1102 pdf-util-convert-program 1103 `(,in-file ,@cmds ,out-file)))) 1104 (when callback 1105 (set-process-sentinel proc callback)) 1106 proc))) 1107 1108 (defun pdf-util-convert-page (&rest specs) 1109 "Convert image of current page according to SPECS. 1110 1111 Return the converted PNG image as a string. See also 1112 `pdf-util-convert'." 1113 1114 (pdf-util-assert-pdf-window) 1115 (let ((in-file (make-temp-file "pdf-util-convert" nil ".png")) 1116 (out-file (make-temp-file "pdf-util-convert" nil ".png"))) 1117 (unwind-protect 1118 (let ((image-data 1119 (plist-get (cdr (pdf-view-current-image)) :data))) 1120 (with-temp-file in-file 1121 (set-buffer-multibyte nil) 1122 (set-buffer-file-coding-system 'binary) 1123 (insert image-data)) 1124 (pdf-util-munch-file 1125 (apply 'pdf-util-convert 1126 in-file out-file specs))) 1127 (when (file-exists-p in-file) 1128 (delete-file in-file)) 1129 (when (file-exists-p out-file) 1130 (delete-file out-file))))) 1131 1132 1133 (defun pdf-util-convert--create-commands (spec) 1134 (let ((fg "red") 1135 (bg "red") 1136 formats result cmds s) 1137 (while (setq s (pop spec)) 1138 (unless spec 1139 (error "Missing value in convert spec:%s" (cons s spec))) 1140 (cl-case s 1141 (:foreground 1142 (setq fg (pop spec))) 1143 (:background 1144 (setq bg (pop spec))) 1145 (:commands 1146 (setq cmds (pop spec))) 1147 (:formats 1148 (setq formats (append formats (pop spec) nil))) 1149 (:apply 1150 (dolist (m (pop spec)) 1151 (pdf-util-with-edges (m) 1152 (let ((alist (append 1153 (mapcar (lambda (f) 1154 (cons (car f) 1155 (if (stringp (cdr f)) 1156 (cdr f) 1157 (funcall (cdr f) m)))) 1158 formats) 1159 `((?g . ,(format "%dx%d+%d+%d" 1160 m-width m-height 1161 m-left m-top)) 1162 (?x . ,m-left) 1163 (?X . ,m-right) 1164 (?y . ,m-top) 1165 (?Y . ,m-bot) 1166 (?w . ,(- m-right m-left)) 1167 (?h . ,(- m-bot m-top)) 1168 (?f . ,fg) 1169 (?b . ,bg))))) 1170 (dolist (fmt cmds) 1171 (push (format-spec fmt alist) result)))))))) 1172 (nreverse result))) 1173 1174 ;; FIXME: Check code below and document. 1175 1176 (defun pdf-util-edges-p (obj &optional relative-p) 1177 "Return non-nil, if OBJ look like edges. 1178 1179 If RELATIVE-P is non-nil, also check that all values <= 1." 1180 1181 (and (consp obj) 1182 (ignore-errors (= 4 (length obj))) 1183 (cl-every (lambda (x) 1184 (and (numberp x) 1185 (>= x 0) 1186 (or (null relative-p) 1187 (<= x 1)))) 1188 obj))) 1189 1190 (defun pdf-util-edges-empty-p (edges) 1191 "Return non-nil, if EDGES area is empty." 1192 (pdf-util-with-edges (edges) 1193 (or (<= edges-width 0) 1194 (<= edges-height 0)))) 1195 1196 (defun pdf-util-edges-inside-p (edges pos &optional epsilon) 1197 (pdf-util-edges-contained-p 1198 edges 1199 (list (car pos) (cdr pos) (car pos) (cdr pos)) 1200 epsilon)) 1201 1202 (defun pdf-util-edges-contained-p (edges contained &optional epsilon) 1203 (unless epsilon (setq epsilon 0)) 1204 (pdf-util-with-edges (edges contained) 1205 (and (<= (- edges-left epsilon) 1206 contained-left) 1207 (>= (+ edges-right epsilon) 1208 contained-right) 1209 (<= (- edges-top epsilon) 1210 contained-top) 1211 (>= (+ edges-bot epsilon) 1212 contained-bot)))) 1213 1214 (defun pdf-util-edges-intersection (e1 e2) 1215 (pdf-util-with-edges (edges1 e1 e2) 1216 (let ((left (max e1-left e2-left)) 1217 (top (max e1-top e2-top)) 1218 (right (min e1-right e2-right)) 1219 (bot (min e1-bot e2-bot))) 1220 (when (and (<= left right) 1221 (<= top bot)) 1222 (list left top right bot))))) 1223 1224 (defun pdf-util-edges-union (&rest edges) 1225 (if (null (cdr edges)) 1226 (car edges) 1227 (list (apply 'min (mapcar 'car edges)) 1228 (apply 'min (mapcar 'cadr edges)) 1229 (apply 'max (mapcar 'cl-caddr edges)) 1230 (apply 'max (mapcar 'cl-cadddr edges))))) 1231 1232 (defun pdf-util-edges-intersection-area (e1 e2) 1233 (let ((inters (pdf-util-edges-intersection e1 e2))) 1234 (if (null inters) 1235 0 1236 (pdf-util-with-edges (inters) 1237 (* inters-width inters-height))))) 1238 1239 (defun pdf-util-read-image-position (prompt) 1240 "Read a image position using prompt. 1241 1242 Return the event position object." 1243 (save-selected-window 1244 (let ((ev (pdf-util-read-click-event 1245 (propertize prompt 'face 'minibuffer-prompt))) 1246 (buffer (current-buffer))) 1247 (unless (mouse-event-p ev) 1248 (error "Not a mouse event")) 1249 (let ((posn (event-start ev))) 1250 (unless (and (eq (window-buffer 1251 (posn-window posn)) 1252 buffer) 1253 (eq 'image (car-safe (posn-object posn)))) 1254 (error "Invalid image position")) 1255 posn)))) 1256 1257 (defun pdf-util-read-click-event (&optional prompt seconds) 1258 (let ((down (read-event prompt seconds))) 1259 (unless (and (mouse-event-p down) 1260 (equal (event-modifiers down) 1261 '(down))) 1262 (error "No a mouse click event")) 1263 (let ((up (read-event prompt seconds))) 1264 (unless (and (mouse-event-p up) 1265 (equal (event-modifiers up) 1266 '(click))) 1267 (error "No a mouse click event")) 1268 up))) 1269 1270 (defun pdf-util-image-map-mouse-event-proxy (event) 1271 "Set POS-OR-AREA in EVENT to 1 and unread it." 1272 (interactive "e") 1273 (setcar (cdr (cadr event)) 1) 1274 (setq unread-command-events (list event))) 1275 1276 (defun pdf-util-image-map-divert-mouse-clicks (id &optional buttons) 1277 (dolist (kind '("" "down-" "drag-")) 1278 (dolist (b (or buttons '(2 3 4 5 6))) 1279 (local-set-key 1280 (vector id (intern (format "%smouse-%d" kind b))) 1281 'pdf-util-image-map-mouse-event-proxy)))) 1282 1283 (defmacro pdf-util-do-events (event-resolution-unread-p condition &rest body) 1284 "Read EVENTs while CONDITION executing BODY. 1285 1286 Process at most 1/RESOLUTION events per second. If UNREAD-p is 1287 non-nil, unread the final non-processed event. 1288 1289 \(FN (EVENT RESOLUTION &optional UNREAD-p) CONDITION &rest BODY\)" 1290 (declare (indent 2) (debug ((symbolp form &optional form) form body))) 1291 (cl-destructuring-bind (event resolution &optional unread-p) 1292 event-resolution-unread-p 1293 (let ((*seconds (make-symbol "seconds")) 1294 (*timestamp (make-symbol "timestamp")) 1295 (*clock (make-symbol "clock")) 1296 (*unread-p (make-symbol "unread-p")) 1297 (*resolution (make-symbol "resolution"))) 1298 `(let* ((,*unread-p ,unread-p) 1299 (,*resolution ,resolution) 1300 (,*seconds 0) 1301 (,*timestamp (float-time)) 1302 (,*clock (lambda (&optional secs) 1303 (when secs 1304 (setq ,*seconds secs 1305 ,*timestamp (float-time))) 1306 (- (+ ,*timestamp ,*seconds) 1307 (float-time)))) 1308 (,event (read-event))) 1309 (while ,condition 1310 (when (<= (funcall ,*clock) 0) 1311 (progn ,@body) 1312 (setq ,event nil) 1313 (funcall ,*clock ,*resolution)) 1314 (setq ,event 1315 (or (read-event nil nil 1316 (and ,event 1317 (max 0 (funcall ,*clock)))) 1318 ,event))) 1319 (when (and ,*unread-p ,event) 1320 (setq unread-command-events 1321 (append unread-command-events 1322 (list ,event)))))))) 1323 1324 (defmacro pdf-util-track-mouse-dragging (event-resolution &rest body) 1325 "Read mouse movement events executing BODY. 1326 1327 See also `pdf-util-do-events'. 1328 1329 This macro should be used inside a command bound to a down-mouse 1330 event. It evaluates to t, if at least one event was processed in 1331 BODY, otherwise nil. In the latter case, the only event (usually 1332 a mouse click event) is unread. 1333 1334 \(FN (EVENT RESOLUTION) &rest BODY\)" 1335 (declare (indent 1) (debug ((symbolp form) body))) 1336 (let ((ran-once-p (make-symbol "ran-once-p"))) 1337 `(let (,ran-once-p) 1338 (track-mouse 1339 (pdf-util-do-events (,@event-resolution t) 1340 (mouse-movement-p ,(car event-resolution)) 1341 (setq ,ran-once-p t) 1342 ,@body)) 1343 (when (and ,ran-once-p 1344 unread-command-events) 1345 (setq unread-command-events 1346 (butlast unread-command-events))) 1347 ,ran-once-p))) 1348 1349 (defun pdf-util-remove-duplicates (list) 1350 "Remove duplicates from LIST stably using `equal'." 1351 (let ((ht (make-hash-table :test 'equal)) 1352 result) 1353 (dolist (elt list (nreverse result)) 1354 (unless (gethash elt ht) 1355 (push elt result) 1356 (puthash elt t ht))))) 1357 1358 (provide 'pdf-util) 1359 1360 ;;; pdf-util.el ends here