compat-27.el (30003B)
1 ;;; compat-27.el --- Compatibility Layer for Emacs 27.1 -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2021-2023 Free Software Foundation, Inc. 4 5 ;; This program is free software; you can redistribute it and/or modify 6 ;; it under the terms of the GNU General Public License as published by 7 ;; the Free Software Foundation, either version 3 of the License, or 8 ;; (at your option) any later version. 9 10 ;; This program is distributed in the hope that it will be useful, 11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ;; GNU General Public License for more details. 14 15 ;; You should have received a copy of the GNU General Public License 16 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 17 18 ;;; Commentary: 19 20 ;; Find here the functionality added in Emacs 27.1, needed by older 21 ;; versions. 22 23 ;;; Code: 24 25 (eval-when-compile (load "compat-macs.el" nil t t)) 26 (compat-declare-version "27.1") 27 28 ;;;; Defined in fns.c 29 30 (compat-defun proper-list-p (object) ;; <OK> 31 "Return OBJECT's length if it is a proper list, nil otherwise. 32 A proper list is neither circular nor dotted (i.e., its last cdr 33 is nil)." 34 :min-version "26" ;; Errors on 26.1 and newer 35 (and (listp object) (ignore-errors (length object)))) 36 37 (compat-defun proper-list-p (object) ;; <OK> 38 "Return OBJECT's length if it is a proper list, nil otherwise. 39 A proper list is neither circular nor dotted (i.e., its last cdr 40 is nil)." 41 :max-version "26" ;; On older Emacs than 26.1 use Tortoise and Hare algorithm 42 (when (listp object) 43 (catch 'cycle 44 (let ((hare object) (tortoise object) 45 (max 2) (q 2)) 46 (while (consp hare) 47 (setq hare (cdr hare)) 48 (when (and (or (/= 0 (setq q (1- q))) 49 (ignore 50 (setq max (ash max 1) 51 q max 52 tortoise hare))) 53 (eq hare tortoise)) 54 (throw 'cycle nil))) 55 (and (null hare) (length object)))))) 56 57 (compat-defun string-distance (string1 string2 &optional bytecompare) ;; <OK> 58 "Return Levenshtein distance between STRING1 and STRING2. 59 The distance is the number of deletions, insertions, and substitutions 60 required to transform STRING1 into STRING2. 61 If BYTECOMPARE is nil or omitted, compute distance in terms of characters. 62 If BYTECOMPARE is non-nil, compute distance in terms of bytes. 63 Letter-case is significant, but text properties are ignored." 64 ;; https://en.wikipedia.org/wiki/Levenshtein_distance 65 (let ((s1 (if bytecompare 66 (encode-coding-string string1 'raw-text) 67 (concat string1 ""))) 68 (s2 (if bytecompare 69 (encode-coding-string string2 'raw-text) 70 string2))) 71 (let* ((len1 (length s1)) 72 (len2 (length s2)) 73 (column (make-vector (1+ len1) 0))) 74 (dotimes (y len1) 75 (setf (aref column (1+ y)) y)) 76 (dotimes (x len2) 77 (setf (aref column 0) (1+ x)) 78 (let ((lastdiag x) olddiag) 79 (dotimes (y len1) 80 (setf olddiag (aref column (1+ y)) 81 (aref column (1+ y)) 82 (min (+ (if (= (aref s1 y) (aref s2 x)) 0 1) 83 lastdiag) 84 (1+ (aref column (1+ y))) 85 (1+ (aref column y))) 86 lastdiag olddiag)))) 87 (aref column len1)))) 88 89 ;;;; Defined in window.c 90 91 (compat-defun recenter (&optional arg redisplay) ;; <OK> 92 "Handle optional argument REDISPLAY." 93 :explicit t 94 (recenter arg) 95 (when (and redisplay recenter-redisplay) 96 (redisplay))) 97 98 ;;;; Defined in keymap.c 99 100 (compat-defun lookup-key (keymap key &optional accept-default) ;; <OK> 101 "Allow for KEYMAP to be a list of keymaps." 102 :explicit t 103 (cond 104 ((keymapp keymap) 105 (lookup-key keymap key accept-default)) 106 ((listp keymap) 107 (catch 'found 108 (dolist (map keymap) 109 (let ((fn (lookup-key map key accept-default))) 110 (when fn (throw 'found fn)))))) 111 ((signal 'wrong-type-argument (list 'keymapp keymap))))) 112 113 ;;;; Defined in timefns.c 114 115 (compat-defun time-equal-p (t1 t2) ;; <OK> 116 "Return non-nil if time value T1 is equal to time value T2. 117 A nil value for either argument stands for the current time. 118 119 NOTE: This function is not as accurate as the actual `time-equal-p'." 120 (cond 121 ((eq t1 t2)) 122 ((and (consp t1) (consp t2)) 123 (equal t1 t2)) 124 (t 125 ;; Due to inaccuracies and the relatively slow evaluating of 126 ;; Emacs Lisp compared to C, we allow for slight inaccuracies 127 ;; (less than a millisecond) when comparing time values. 128 (< (abs (- (float-time t1) (float-time t2))) 129 (if (and t1 t2) 1e-6 1e-5))))) 130 131 ;;;; Defined in fileio.c 132 133 (compat-defun file-name-absolute-p (filename) ;; <OK> 134 "Return t if FILENAME is an absolute file name. 135 On Unix, absolute file names start with `/'. In Emacs, an absolute 136 file name can also start with an initial `~' or `~USER' component, 137 where USER is a valid login name." 138 ;; See definitions in filename.h 139 (let ((drive 140 (eval-when-compile 141 (cond 142 ((memq system-type '(windows-nt ms-dos)) 143 "\\`[A-Za-z]:[\\/]") 144 ((eq system-type 'cygwin) 145 "\\`\\([\\/]\\|[A-Za-z]:\\)") 146 ("\\`/")))) 147 (home 148 (eval-when-compile 149 (if (memq system-type '(cygwin windows-nt ms-dos)) 150 "\\`~[\\/]" "\\`~/"))) 151 (user-home 152 (eval-when-compile 153 (format "\\`\\(~.*?\\)\\(%s.*\\)?$" 154 (if (memq system-type '(cygwin windows-nt ms-dos)) 155 "[\\/]" "/"))))) 156 (or (and (string-match-p drive filename) t) 157 (and (string-match-p home filename) t) 158 (save-excursion 159 (when (string-match user-home filename) 160 (let ((init (match-string 1 filename))) 161 (not (string= 162 (file-name-base (expand-file-name init)) 163 init)))))))) 164 165 ;;;; Defined in subr.el 166 167 (compat-defmacro setq-local (&rest pairs) ;; <OK> 168 "Handle multiple assignments." 169 :explicit t 170 (unless (zerop (mod (length pairs) 2)) 171 (error "PAIRS must have an even number of variable/value members")) 172 (let (body) 173 (while pairs 174 (let* ((sym (pop pairs)) 175 (val (pop pairs))) 176 (unless (symbolp sym) 177 (error "Attempting to set a non-symbol: %s" (car pairs))) 178 (push `(set (make-local-variable ',sym) ,val) 179 body))) 180 (cons 'progn (nreverse body)))) 181 182 (compat-defun provided-mode-derived-p (mode &rest modes) ;; <OK> 183 "Non-nil if MODE is derived from one of MODES. 184 Uses the `derived-mode-parent' property of the symbol to trace backwards. 185 If you just want to check `major-mode', use `derived-mode-p'." 186 ;; If MODE is an alias, then look up the real mode function first. 187 (let ((alias (symbol-function mode))) 188 (when (and alias (symbolp alias)) 189 (setq mode alias))) 190 (while 191 (and 192 (not (memq mode modes)) 193 (let* ((parent (get mode 'derived-mode-parent)) 194 (parentfn (symbol-function parent))) 195 (setq mode (if (and parentfn (symbolp parentfn)) parentfn parent))))) 196 mode) 197 198 (compat-defun derived-mode-p (&rest modes) ;; <OK> 199 "Non-nil if the current major mode is derived from one of MODES. 200 Uses the `derived-mode-parent' property of the symbol to trace backwards." 201 (apply #'provided-mode-derived-p major-mode modes)) 202 203 (compat-defmacro ignore-error (condition &rest body) ;; <OK> 204 "Execute BODY; if the error CONDITION occurs, return nil. 205 Otherwise, return result of last form in BODY. 206 207 CONDITION can also be a list of error conditions." 208 (declare (debug t) (indent 1)) 209 `(condition-case nil (progn ,@body) (,condition nil))) 210 211 (compat-defmacro dolist-with-progress-reporter (spec reporter-or-message &rest body) ;; <UNTESTED> 212 "Loop over a list and report progress in the echo area. 213 Evaluate BODY with VAR bound to each car from LIST, in turn. 214 Then evaluate RESULT to get return value, default nil. 215 216 REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter 217 case, use this string to create a progress reporter. 218 219 At each iteration, print the reporter message followed by progress 220 percentage in the echo area. After the loop is finished, 221 print the reporter message followed by the word \"done\". 222 223 \(fn (VAR LIST [RESULT]) REPORTER-OR-MESSAGE BODY...)" 224 (declare (indent 2) (debug ((symbolp form &optional form) form body))) 225 (let ((prep (make-symbol "--dolist-progress-reporter--")) 226 (count (make-symbol "--dolist-count--")) 227 (list (make-symbol "--dolist-list--"))) 228 `(let ((,prep ,reporter-or-message) 229 (,count 0) 230 (,list ,(cadr spec))) 231 (when (stringp ,prep) 232 (setq ,prep (make-progress-reporter ,prep 0 (length ,list)))) 233 (dolist (,(car spec) ,list) 234 ,@body 235 (progress-reporter-update ,prep (setq ,count (1+ ,count)))) 236 (progress-reporter-done ,prep) 237 (or ,@(cdr (cdr spec)) nil)))) 238 239 (compat-defun flatten-tree (tree) ;; <OK> 240 "Return a \"flattened\" copy of TREE. 241 In other words, return a list of the non-nil terminal nodes, or 242 leaves, of the tree of cons cells rooted at TREE. Leaves in the 243 returned list are in the same order as in TREE. 244 245 \(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7)) 246 => (1 2 3 4 5 6 7)" 247 (let (elems) 248 (while (consp tree) 249 (let ((elem (pop tree))) 250 (while (consp elem) 251 (push (cdr elem) tree) 252 (setq elem (car elem))) 253 (if elem (push elem elems)))) 254 (if tree (push tree elems)) 255 (nreverse elems))) 256 257 (compat-defun xor (cond1 cond2) ;; <OK> 258 "Return the boolean exclusive-or of COND1 and COND2. 259 If only one of the arguments is non-nil, return it; otherwise 260 return nil." 261 (declare (pure t) (side-effect-free error-free)) 262 (cond ((not cond1) cond2) 263 ((not cond2) cond1))) 264 265 (compat-defvar regexp-unmatchable "\\`a\\`" ;; <OK> 266 "Standard regexp guaranteed not to match any string at all." 267 :constant t) 268 269 (compat-defun assoc-delete-all (key alist &optional test) ;; <OK> 270 "Handle optional argument TEST." 271 :explicit t 272 (unless test (setq test #'equal)) 273 (while (and (consp (car alist)) 274 (funcall test (caar alist) key)) 275 (setq alist (cdr alist))) 276 (let ((tail alist) tail-cdr) 277 (while (setq tail-cdr (cdr tail)) 278 (if (and (consp (car tail-cdr)) 279 (funcall test (caar tail-cdr) key)) 280 (setcdr tail (cdr tail-cdr)) 281 (setq tail tail-cdr)))) 282 alist) 283 284 ;;;; Defined in simple.el 285 286 (compat-defun decoded-time-second (time) ;; <OK> 287 "The seconds in TIME, which is a value returned by `decode-time'. 288 This is an integer between 0 and 60 (inclusive). (60 is a leap 289 second, which only some operating systems support.)" 290 (nth 0 time)) 291 292 (compat-defun decoded-time-minute (time) ;; <OK> 293 "The minutes in TIME, which is a value returned by `decode-time'. 294 This is an integer between 0 and 59 (inclusive)." 295 (nth 1 time)) 296 297 (compat-defun decoded-time-hour (time) ;; <OK> 298 "The hours in TIME, which is a value returned by `decode-time'. 299 This is an integer between 0 and 23 (inclusive)." 300 (nth 2 time)) 301 302 (compat-defun decoded-time-day (time) ;; <OK> 303 "The day-of-the-month in TIME, which is a value returned by `decode-time'. 304 This is an integer between 1 and 31 (inclusive)." 305 (nth 3 time)) 306 307 (compat-defun decoded-time-month (time) ;; <OK> 308 "The month in TIME, which is a value returned by `decode-time'. 309 This is an integer between 1 and 12 (inclusive). January is 1." 310 (nth 4 time)) 311 312 (compat-defun decoded-time-year (time) ;; <OK> 313 "The year in TIME, which is a value returned by `decode-time'. 314 This is a four digit integer." 315 (nth 5 time)) 316 317 (compat-defun decoded-time-weekday (time) ;; <OK> 318 "The day-of-the-week in TIME, which is a value returned by `decode-time'. 319 This is a number between 0 and 6, and 0 is Sunday." 320 (nth 6 time)) 321 322 (compat-defun decoded-time-dst (time) ;; <OK> 323 "The daylight saving time in TIME, which is a value returned by `decode-time'. 324 This is t if daylight saving time is in effect, and nil if not." 325 (nth 7 time)) 326 327 (compat-defun decoded-time-zone (time) ;; <OK> 328 "The time zone in TIME, which is a value returned by `decode-time'. 329 This is an integer indicating the UTC offset in seconds, i.e., 330 the number of seconds east of Greenwich." 331 (nth 8 time)) 332 333 ;; TODO define gv-setters for decoded-time-* 334 335 ;;;; Defined in image.el 336 337 (compat-defun image--set-property (image property value) ;; <OK> 338 "Set PROPERTY in IMAGE to VALUE. 339 Internal use only." 340 :explicit t 341 :feature image 342 (if (null value) 343 (while (cdr image) 344 (if (eq (cadr image) property) 345 (setcdr image (cdddr image)) 346 (setq image (cddr image)))) 347 (setcdr image (plist-put (cdr image) property value))) 348 value) 349 350 (if (eval-when-compile (version< emacs-version "26.1")) 351 (with-eval-after-load 'image 352 (gv-define-simple-setter image-property image--set-property)) 353 ;; HACK: image--set-property was broken with an off-by-one error on Emacs 26. 354 ;; The bug was fixed in a4ad7bed187493c1c230f223b52c71f5c34f7c89. Therefore we 355 ;; override the gv expander until Emacs 27.1. 356 (when (eval-when-compile (version< emacs-version "27.1")) 357 (with-eval-after-load 'image 358 (gv-define-simple-setter image-property compat--image--set-property)))) 359 360 ;;;; Defined in files.el 361 362 (compat-defun file-size-human-readable (file-size &optional flavor space unit) ;; <OK> 363 "Handle the optional arguments SPACE and UNIT. 364 365 Optional third argument SPACE is a string put between the number and unit. 366 It defaults to the empty string. We recommend a single space or 367 non-breaking space, unless other constraints prohibit a space in that 368 position. 369 370 Optional fourth argument UNIT is the unit to use. It defaults to \"B\" 371 when FLAVOR is `iec' and the empty string otherwise. We recommend \"B\" 372 in all cases, since that is the standard symbol for byte." 373 :explicit t 374 (let ((power (if (or (null flavor) (eq flavor 'iec)) 375 1024.0 376 1000.0)) 377 (prefixes '("" "k" "M" "G" "T" "P" "E" "Z" "Y"))) 378 (while (and (>= file-size power) (cdr prefixes)) 379 (setq file-size (/ file-size power) 380 prefixes (cdr prefixes))) 381 (let* ((prefix (car prefixes)) 382 (prefixed-unit (if (eq flavor 'iec) 383 (concat 384 (if (string= prefix "k") "K" prefix) 385 (if (string= prefix "") "" "i") 386 (or unit "B")) 387 (concat prefix unit)))) 388 (format (if (and (>= (mod file-size 1.0) 0.05) 389 (< (mod file-size 1.0) 0.95)) 390 "%.1f%s%s" 391 "%.0f%s%s") 392 file-size 393 (if (string= prefixed-unit "") "" (or space "")) 394 prefixed-unit)))) 395 396 (compat-defun exec-path () ;; <UNTESTED> 397 "Return list of directories to search programs to run in remote subprocesses. 398 The remote host is identified by `default-directory'. For remote 399 hosts that do not support subprocesses, this returns nil. 400 If `default-directory' is a local directory, this function returns 401 the value of the variable `exec-path'." 402 (cond 403 ((let ((handler (find-file-name-handler default-directory 'exec-path))) 404 ;; FIXME: The handler was added in 27.1, and this compatibility 405 ;; function only applies to versions of Emacs before that. 406 (when handler 407 (condition-case nil 408 (funcall handler 'exec-path) 409 (error nil))))) 410 ((file-remote-p default-directory) 411 ;; TODO: This is not completely portable, even if "sh" and 412 ;; "getconf" should be provided on every POSIX system, the chance 413 ;; of this not working are greater than zero. 414 ;; 415 ;; FIXME: This invokes a shell process every time exec-path is 416 ;; called. It should instead be cached on a host-local basis. 417 (with-temp-buffer 418 (if (condition-case nil 419 (zerop (process-file "sh" nil t nil "-c" "getconf PATH")) 420 (file-missing t)) 421 (list "/bin" "/usr/bin") 422 (let (path) 423 (while (re-search-forward "\\([^:]+?\\)[\n:]" nil t) 424 (push (match-string 1) path)) 425 (nreverse path))))) 426 (exec-path))) 427 428 (compat-defun executable-find (command &optional remote) ;; <UNTESTED> 429 "Search for COMMAND in `exec-path' and return the absolute file name. 430 Return nil if COMMAND is not found anywhere in `exec-path'. If 431 REMOTE is non-nil, search on the remote host indicated by 432 `default-directory' instead." 433 :explicit t 434 (if (and remote (file-remote-p default-directory)) 435 (let ((res (locate-file 436 command 437 (mapcar 438 (apply-partially 439 #'concat (file-remote-p default-directory)) 440 (exec-path)) 441 exec-suffixes 'file-executable-p))) 442 (when (stringp res) (file-local-name res))) 443 (executable-find command))) 444 445 (compat-defun make-empty-file (filename &optional parents) ;; <UNTESTED> 446 "Create an empty file FILENAME. 447 Optional arg PARENTS, if non-nil then creates parent dirs as needed." 448 (when (and (file-exists-p filename) (null parents)) 449 (signal 'file-already-exists (list "File exists" filename))) 450 (let ((paren-dir (file-name-directory filename))) 451 (when (and paren-dir (not (file-exists-p paren-dir))) 452 (make-directory paren-dir parents))) 453 (write-region "" nil filename nil 0)) 454 455 ;;;; Defined in regexp-opt.el 456 457 (compat-defun regexp-opt (strings &optional paren) ;; <OK> 458 "Handle an empty list of STRINGS." 459 :explicit t 460 (if (null strings) 461 (let ((re "\\`a\\`")) 462 (cond ((null paren) 463 (concat "\\(?:" re "\\)")) 464 ((stringp paren) 465 (concat paren re "\\)")) 466 ((eq paren 'words) 467 (concat "\\<\\(" re "\\)\\>")) 468 ((eq paren 'symbols) 469 (concat "\\_\\(<" re "\\)\\_>")) 470 ((concat "\\(" re "\\)")))) 471 (regexp-opt strings paren))) 472 473 ;;;; Defined in package.el 474 475 (declare-function lm-header "lisp-mnt") 476 477 (compat-defun package-get-version () ;; <UNTESTED> 478 "Return the version number of the package in which this is used. 479 Assumes it is used from an Elisp file placed inside the top-level directory 480 of an installed ELPA package. 481 The return value is a string (or nil in case we can’t find it)." 482 :feature package 483 ;; In a sense, this is a lie, but it does just what we want: precompute 484 ;; the version at compile time and hardcodes it into the .elc file! 485 (declare (pure t)) 486 ;; Hack alert! 487 (let ((file 488 (or (and (boundp 'byte-compile-current-file) byte-compile-current-file) 489 load-file-name 490 buffer-file-name))) 491 (cond 492 ((null file) nil) 493 ;; Packages are normally installed into directories named "<pkg>-<vers>", 494 ;; so get the version number from there. 495 ((string-match 496 "/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'" 497 file) 498 (match-string 1 file)) 499 ;; For packages run straight from the an elpa.git clone, there's no 500 ;; "-<vers>" in the directory name, so we have to fetch the version 501 ;; the hard way. 502 ((let* ((pkgdir (file-name-directory file)) 503 (pkgname (file-name-nondirectory (directory-file-name pkgdir))) 504 (mainfile (expand-file-name (concat pkgname ".el") pkgdir))) 505 (when (file-readable-p mainfile) 506 (require 'lisp-mnt) 507 (with-temp-buffer 508 (insert-file-contents mainfile) 509 (or (lm-header "package-version") 510 (lm-header "version"))))))))) 511 512 ;;;; Defined in dired.el 513 514 (compat-defun dired-get-marked-files ;; <UNTESTED> 515 (&optional localp arg filter distinguish-one-marked error) 516 "Handle optional argument ERROR." 517 :feature dired 518 :explicit t 519 (let ((result (dired-get-marked-files localp arg filter distinguish-one-marked))) 520 (if (and (null result) error) 521 (user-error (if (stringp error) error "No files specified")) 522 result))) 523 524 ;;;; Defined in time-date.el 525 526 (compat-defun date-days-in-month (year month) ;; <OK> 527 "The number of days in MONTH in YEAR." 528 :feature time-date 529 (unless (and (numberp month) 530 (<= 1 month) 531 (<= month 12)) 532 (error "Month %s is invalid" month)) 533 (if (= month 2) 534 (if (date-leap-year-p year) 535 29 536 28) 537 (if (memq month '(1 3 5 7 8 10 12)) 538 31 539 30))) 540 541 ;;;; Defined in text-property-search.el 542 543 (compat-defun make-prop-match (&rest attr) ;; <OK> 544 "Constructor for objects of type ‘prop-match’." 545 :max-version "26" 546 :feature text-property-search 547 (vector 'prop-match ;; Vector for older than 26.1 548 (plist-get attr :beginning) 549 (plist-get attr :end) 550 (plist-get attr :value))) 551 552 (compat-defun make-prop-match (&rest attr) ;; <OK> 553 "Constructor for objects of type ‘prop-match’." 554 :min-version "26" 555 :feature text-property-search 556 (record 'prop-match ;; record was introduced with 26.1 557 (plist-get attr :beginning) 558 (plist-get attr :end) 559 (plist-get attr :value))) 560 561 (compat-defun prop-match-p (match) ;; <OK> 562 "Return non-nil if MATCH is a `prop-match' object." 563 :max-version "26" ;; Vector before 26.1 564 :feature text-property-search 565 (and (vectorp match) 566 (> (length match) 0) 567 (eq (aref match 0) 'prop-match))) 568 569 (compat-defun prop-match-p (match) ;; <OK> 570 "Return non-nil if MATCH is a `prop-match' object." 571 :min-version "26" ;; Record for 26.1 and newer 572 :feature text-property-search 573 (eq (type-of match) 'prop-match)) 574 575 (compat-defun prop-match-beginning (match) ;; <OK> 576 "Retrieve the position where MATCH begins." 577 :feature text-property-search 578 (aref match 1)) 579 580 (compat-defun prop-match-end (match) ;; <OK> 581 "Retrieve the position where MATCH ends." 582 :feature text-property-search 583 (aref match 2)) 584 585 (compat-defun prop-match-value (match) ;; <OK> 586 "Retrieve the value that MATCH holds." 587 :feature text-property-search 588 (aref match 3)) 589 590 (compat-defun text-property-search-forward ;; <OK> 591 (property &optional value predicate not-current) 592 "Search for the next region of text where PREDICATE is true. 593 PREDICATE is used to decide whether a value of PROPERTY should be 594 considered as matching VALUE. 595 596 If PREDICATE is a function, it will be called with two arguments: 597 VALUE and the value of PROPERTY. The function should return 598 non-nil if these two values are to be considered a match. 599 600 Two special values of PREDICATE can also be used: 601 If PREDICATE is t, that means a value must `equal' VALUE to be 602 considered a match. 603 If PREDICATE is nil (which is the default value), a value will 604 match if is not `equal' to VALUE. Furthermore, a nil PREDICATE 605 means that the match region is ended if the value changes. For 606 instance, this means that if you loop with 607 608 (while (setq prop (text-property-search-forward \\='face)) 609 ...) 610 611 you will get all distinct regions with non-nil `face' values in 612 the buffer, and the `prop' object will have the details about the 613 match. See the manual for more details and examples about how 614 VALUE and PREDICATE interact. 615 616 If NOT-CURRENT is non-nil, the function will search for the first 617 region that doesn't include point and has a value of PROPERTY 618 that matches VALUE. 619 620 If no matches can be found, return nil and don't move point. 621 If found, move point to the end of the region and return a 622 `prop-match' object describing the match. To access the details 623 of the match, use `prop-match-beginning' and `prop-match-end' for 624 the buffer positions that limit the region, and 625 `prop-match-value' for the value of PROPERTY in the region." 626 :feature text-property-search 627 (let* ((match-p 628 (lambda (prop-value) 629 (funcall 630 (cond 631 ((eq predicate t) 632 #'equal) 633 ((eq predicate nil) 634 (lambda (val p-val) 635 (not (equal val p-val)))) 636 (predicate)) 637 value prop-value))) 638 (find-end 639 (lambda (start) 640 (let (end) 641 (if (and value 642 (null predicate)) 643 ;; This is the normal case: We're looking for areas where the 644 ;; values aren't, so we aren't interested in sub-areas where the 645 ;; property has different values, all non-matching value. 646 (let ((ended nil)) 647 (while (not ended) 648 (setq end (next-single-property-change (point) property)) 649 (if (not end) 650 (progn 651 (goto-char (point-max)) 652 (setq end (point) 653 ended t)) 654 (goto-char end) 655 (unless (funcall match-p (get-text-property (point) property)) 656 (setq ended t))))) 657 ;; End this at the first place the property changes value. 658 (setq end (next-single-property-change (point) property nil (point-max))) 659 (goto-char end)) 660 (make-prop-match 661 :beginning start 662 :end end 663 :value (get-text-property start property)))))) 664 (cond 665 ;; No matches at the end of the buffer. 666 ((eobp) 667 nil) 668 ;; We're standing in the property we're looking for, so find the 669 ;; end. 670 ((and (funcall match-p (get-text-property (point) property)) 671 (not not-current)) 672 (funcall find-end (point))) 673 (t 674 (let ((origin (point)) 675 (ended nil) 676 pos) 677 ;; Find the next candidate. 678 (while (not ended) 679 (setq pos (next-single-property-change (point) property)) 680 (if (not pos) 681 (progn 682 (goto-char origin) 683 (setq ended t)) 684 (goto-char pos) 685 (if (funcall match-p (get-text-property (point) property)) 686 (setq ended (funcall find-end (point))) 687 ;; Skip past this section of non-matches. 688 (setq pos (next-single-property-change (point) property)) 689 (unless pos 690 (goto-char origin) 691 (setq ended t))))) 692 (and (not (eq ended t)) 693 ended)))))) 694 695 (compat-defun text-property-search-backward ;; <OK> 696 (property &optional value predicate not-current) 697 "Search for the previous region of text whose PROPERTY matches VALUE. 698 699 Like `text-property-search-forward', which see, but searches backward, 700 and if a matching region is found, place point at the start of the region." 701 :feature text-property-search 702 (let* ((match-p 703 (lambda (prop-value) 704 (funcall 705 (cond 706 ((eq predicate t) 707 #'equal) 708 ((eq predicate nil) 709 (lambda (val p-val) 710 (not (equal val p-val)))) 711 (predicate)) 712 value prop-value))) 713 (find-end 714 (lambda (start) 715 (let (end) 716 (if (and value 717 (null predicate)) 718 ;; This is the normal case: We're looking for areas where the 719 ;; values aren't, so we aren't interested in sub-areas where the 720 ;; property has different values, all non-matching value. 721 (let ((ended nil)) 722 (while (not ended) 723 (setq end (previous-single-property-change (point) property)) 724 (if (not end) 725 (progn 726 (goto-char (point-min)) 727 (setq end (point) 728 ended t)) 729 (goto-char (1- end)) 730 (unless (funcall match-p (get-text-property (point) property)) 731 (goto-char end) 732 (setq ended t))))) 733 ;; End this at the first place the property changes value. 734 (setq end (previous-single-property-change 735 (point) property nil (point-min))) 736 (goto-char end)) 737 (make-prop-match 738 :beginning end 739 :end (1+ start) 740 :value (get-text-property end property)))))) 741 (cond 742 ;; We're at the start of the buffer; no previous matches. 743 ((bobp) 744 nil) 745 ;; We're standing in the property we're looking for, so find the 746 ;; end. 747 ((funcall match-p (get-text-property (1- (point)) property)) 748 (let ((origin (point)) 749 (match (funcall find-end (1- (point)) property value predicate))) 750 ;; When we want to ignore the current element, then repeat the 751 ;; search if we haven't moved out of it yet. 752 (if (and not-current 753 (equal (get-text-property (point) property) 754 (get-text-property origin property))) 755 (text-property-search-backward property value predicate) 756 match))) 757 (t 758 (let ((origin (point)) 759 (ended nil) 760 pos) 761 ;; Find the previous candidate. 762 (while (not ended) 763 (setq pos (previous-single-property-change (point) property)) 764 (if (not pos) 765 (progn 766 (goto-char origin) 767 (setq ended t)) 768 (goto-char (1- pos)) 769 (if (funcall match-p (get-text-property (point) property)) 770 (setq ended 771 (funcall find-end (point))) 772 ;; Skip past this section of non-matches. 773 (setq pos (previous-single-property-change (point) property)) 774 (unless pos 775 (goto-char origin) 776 (setq ended t))))) 777 (and (not (eq ended t)) 778 ended)))))) 779 780 (provide 'compat-27) 781 ;;; compat-27.el ends here