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