compat-28.el (31133B)
1 ;;; compat-28.el --- Compatibility Layer for Emacs 28.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 28.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 "28.1") 27 28 ;;;; Defined in fns.c 29 30 ;; FIXME Should handle multibyte regular expressions 31 (compat-defun string-search (needle haystack &optional start-pos) ;; <OK> 32 "Search for the string NEEDLE in the strign HAYSTACK. 33 34 The return value is the position of the first occurrence of 35 NEEDLE in HAYSTACK, or nil if no match was found. 36 37 The optional START-POS argument says where to start searching in 38 HAYSTACK and defaults to zero (start at the beginning). 39 It must be between zero and the length of HAYSTACK, inclusive. 40 41 Case is always significant and text properties are ignored. 42 43 NOTE: Prior to Emacs 27 `string-match' has issues handling 44 multibyte regular expressions. As the compatibility function 45 for `string-search' is implemented via `string-match', these 46 issues are inherited." 47 (when (and start-pos (or (< (length haystack) start-pos) 48 (< start-pos 0))) 49 (signal 'args-out-of-range (list start-pos))) 50 (save-match-data 51 (let ((case-fold-search nil)) 52 (string-match (regexp-quote needle) haystack start-pos)))) 53 54 (compat-defun length= (sequence length) ;; <OK> 55 "Returns non-nil if SEQUENCE has a length equal to LENGTH." 56 (cond 57 ((null sequence) (zerop length)) 58 ((consp sequence) 59 (and (null (nthcdr length sequence)) 60 (nthcdr (1- length) sequence) 61 t)) 62 ((arrayp sequence) 63 (= (length sequence) length)) 64 ((signal 'wrong-type-argument sequence)))) 65 66 (compat-defun length< (sequence length) ;; <OK> 67 "Returns non-nil if SEQUENCE is shorter than LENGTH." 68 (cond 69 ((null sequence) (not (zerop length))) 70 ((listp sequence) 71 (null (nthcdr (1- length) sequence))) 72 ((arrayp sequence) 73 (< (length sequence) length)) 74 ((signal 'wrong-type-argument sequence)))) 75 76 (compat-defun length> (sequence length) ;; <OK> 77 "Returns non-nil if SEQUENCE is longer than LENGTH." 78 (cond 79 ((listp sequence) 80 (and (nthcdr length sequence) t)) 81 ((arrayp sequence) 82 (> (length sequence) length)) 83 ((signal 'wrong-type-argument sequence)))) 84 85 ;;;; Defined in fileio.c 86 87 (compat-defun file-name-concat (directory &rest components) ;; <OK> 88 "Append COMPONENTS to DIRECTORY and return the resulting string. 89 Elements in COMPONENTS must be a string or nil. 90 DIRECTORY or the non-final elements in COMPONENTS may or may not end 91 with a slash -- if they don’t end with a slash, a slash will be 92 inserted before contatenating." 93 (let ((separator (eval-when-compile 94 (if (memq system-type '(ms-dos windows-nt cygwin)) 95 "\\" "/"))) 96 (components (delq nil 97 (mapcar (lambda (x) (and (not (equal "" x)) x)) 98 (cons directory components)))) 99 (result "")) 100 (while components 101 (let ((c (pop components))) 102 (setq result (concat result c 103 (and components 104 (not (string-suffix-p separator c)) 105 separator))))) 106 result)) 107 108 ;;;; Defined in alloc.c 109 110 (compat-defalias garbage-collect-maybe ignore) ;; <OK> 111 112 ;;;; Defined in filelock.c 113 114 (compat-defun unlock-buffer () ;; <UNTESTED> 115 "Handle `file-error' conditions. 116 Handles file system errors by calling ‘display-warning’ and 117 continuing as if the error did not occur." 118 :explicit t 119 (condition-case error 120 (unlock-buffer) 121 (file-error 122 (display-warning 123 '(unlock-file) 124 (message "%s, ignored" (error-message-string error)) 125 :warning)))) 126 127 ;;;; Defined in characters.c 128 129 (compat-defun string-width (string &optional from to) ;; <OK> 130 "Handle optional arguments FROM and TO. 131 Optional arguments FROM and TO specify the substring of STRING to 132 consider, and are interpreted as in `substring'." 133 :explicit t 134 (let* ((len (length string)) 135 (from (or from 0)) 136 (to (or to len))) 137 (if (and (= from 0) (= to len)) 138 (string-width string) 139 (string-width (substring string from to))))) 140 141 ;;;; Defined in dired.c 142 143 (compat-defun directory-files (directory &optional full match nosort count) ;; <UNTESTED> 144 "Handle additional optional argument COUNT. 145 If COUNT is non-nil and a natural number, the function will 146 return COUNT number of file names (if so many are present)." 147 :explicit t 148 (let ((files (directory-files directory full match nosort))) 149 (when (natnump count) 150 (setf (nthcdr count files) nil)) 151 files)) 152 153 ;;;; Defined in json.c 154 155 ;; TODO Check interaction with conditionally defined json functions 156 (compat-defun json-serialize (object &rest args) ;; <UNTESTED> 157 "Handle top-level JSON values (RFC 8259)." 158 :explicit t 159 :min-version "27" 160 (if (or (listp object) (vectorp object)) 161 (apply #'json-serialize object args) 162 (substring (json-serialize (list object)) 1 -1))) 163 164 ;; TODO Check interaction with conditionally defined json functions 165 (compat-defun json-insert (object &rest args) ;; <UNTESTED> 166 "Handle top-level JSON values (RFC 8259)." 167 :explicit t 168 :min-version "27" 169 (if (or (listp object) (vectorp object)) 170 (apply #'json-insert object args) 171 (insert (apply #'compat--json-serialize object args)))) 172 173 ;; TODO Check interaction with conditionally defined json functions 174 (compat-defun json-parse-string (string &rest args) ;; <UNTESTED> 175 "Handle top-level JSON values (RFC 8259)." 176 :explicit t 177 :min-version "27" 178 (if (string-match-p "\\`[[:space:]]*[[{]" string) 179 (apply #'json-parse-string string args) 180 ;; Wrap the string in an array, and extract the value back using 181 ;; `elt', to ensure that no matter what the value of `:array-type' 182 ;; is we can access the first element. 183 (elt (apply #'json-parse-string (concat "[" string "]") args) 0))) 184 185 ;; TODO Check interaction with conditionally defined json functions 186 (compat-defun json-parse-buffer (&rest args) ;; <UNTESTED> 187 "Handle top-level JSON values (RFC 8259)." 188 :explicit t 189 :min-version "27" 190 (if (looking-at-p "[[:space:]]*[[{]") 191 (apply #'json-parse-buffer args) 192 (catch 'escape 193 (atomic-change-group 194 (with-syntax-table 195 (let ((st (make-syntax-table))) 196 (modify-syntax-entry ?\" "\"" st) 197 (modify-syntax-entry ?. "_" st) 198 st) 199 (let ((inhibit-read-only t)) 200 (save-excursion 201 (insert "[") 202 (forward-sexp 1) 203 (insert "]")))) 204 (throw 'escape (elt (apply #'json-parse-buffer args) 0)))))) 205 206 ;;;; xfaces.c 207 208 (compat-defun color-values-from-color-spec (spec) ;; <OK> 209 "Parse color SPEC as a numeric color and return (RED GREEN BLUE). 210 This function recognises the following formats for SPEC: 211 212 #RGB, where R, G and B are hex numbers of equal length, 1-4 digits each. 213 rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each. 214 rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1]. 215 216 If SPEC is not in one of the above forms, return nil. 217 218 Each of the 3 integer members of the resulting list, RED, GREEN, 219 and BLUE, is normalized to have its value in [0,65535]." 220 (let ((case-fold-search nil)) 221 (save-match-data 222 (cond 223 ((string-match 224 ;; (rx bos "#" 225 ;; (or (: (group-n 1 (= 1 hex)) (group-n 2 (= 1 hex)) (group-n 3 (= 1 hex))) 226 ;; (: (group-n 1 (= 2 hex)) (group-n 2 (= 2 hex)) (group-n 3 (= 2 hex))) 227 ;; (: (group-n 1 (= 3 hex)) (group-n 2 (= 3 hex)) (group-n 3 (= 3 hex))) 228 ;; (: (group-n 1 (= 4 hex)) (group-n 2 (= 4 hex)) (group-n 3 (= 4 hex)))) 229 ;; eos) 230 "\\`#\\(?:\\(?1:[[:xdigit:]]\\{1\\}\\)\\(?2:[[:xdigit:]]\\{1\\}\\)\\(?3:[[:xdigit:]]\\{1\\}\\)\\|\\(?1:[[:xdigit:]]\\{2\\}\\)\\(?2:[[:xdigit:]]\\{2\\}\\)\\(?3:[[:xdigit:]]\\{2\\}\\)\\|\\(?1:[[:xdigit:]]\\{3\\}\\)\\(?2:[[:xdigit:]]\\{3\\}\\)\\(?3:[[:xdigit:]]\\{3\\}\\)\\|\\(?1:[[:xdigit:]]\\{4\\}\\)\\(?2:[[:xdigit:]]\\{4\\}\\)\\(?3:[[:xdigit:]]\\{4\\}\\)\\)\\'" 231 spec) 232 (let ((max (1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4))))) 233 (list (/ (* (string-to-number (match-string 1 spec) 16) 65535) max) 234 (/ (* (string-to-number (match-string 2 spec) 16) 65535) max) 235 (/ (* (string-to-number (match-string 3 spec) 16) 65535) max)))) 236 ((string-match 237 ;; (rx bos "rgb:" 238 ;; (group (** 1 4 hex)) "/" 239 ;; (group (** 1 4 hex)) "/" 240 ;; (group (** 1 4 hex)) 241 ;; eos) 242 "\\`rgb:\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)\\'" 243 spec) 244 (list (/ (* (string-to-number (match-string 1 spec) 16) 65535) 245 (1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4)))) 246 (/ (* (string-to-number (match-string 2 spec) 16) 65535) 247 (1- (ash 1 (* (- (match-end 2) (match-beginning 2)) 4)))) 248 (/ (* (string-to-number (match-string 3 spec) 16) 65535) 249 (1- (ash 1 (* (- (match-end 3) (match-beginning 3)) 4)))))) 250 ;; The "RGBi" (RGB Intensity) specification is defined by 251 ;; XCMS[0], see [1] for the implementation in Xlib. 252 ;; 253 ;; [0] http://www.nic.funet.fi/pub/X11/X11R4/DOCS/color/Xcms.text 254 ;; [1] https://gitlab.freedesktop.org/xorg/lib/libx11/-/blob/master/src/xcms/LRGB.c#L1392 255 ((string-match 256 ;; (rx bos "rgbi:" (* space) 257 ;; (group (? (or "-" "+")) 258 ;; (or (: (+ digit) (? "." (* digit))) 259 ;; (: "." (+ digit))) 260 ;; (? "e" (? (or "-" "+")) (+ digit))) 261 ;; "/" (* space) 262 ;; (group (? (or "-" "+")) 263 ;; (or (: (+ digit) (? "." (* digit))) 264 ;; (: "." (+ digit))) 265 ;; (? "e" (? (or "-" "+")) (+ digit))) 266 ;; "/" (* space) 267 ;; (group (? (or "-" "+")) 268 ;; (or (: (+ digit) (? "." (* digit))) 269 ;; (: "." (+ digit))) 270 ;; (? "e" (? (or "-" "+")) (+ digit))) 271 ;; eos) 272 "\\`rgbi:[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)\\'" 273 spec) 274 (let ((r (round (* (string-to-number (match-string 1 spec)) 65535))) 275 (g (round (* (string-to-number (match-string 2 spec)) 65535))) 276 (b (round (* (string-to-number (match-string 3 spec)) 65535)))) 277 (when (and (<= 0 r) (<= r 65535) 278 (<= 0 g) (<= g 65535) 279 (<= 0 b) (<= b 65535)) 280 (list r g b)))))))) 281 282 ;;;; Defined in simple.el 283 284 (compat-defun make-separator-line (&optional length) ;; <OK> 285 "Make a string appropriate for usage as a visual separator line. 286 If LENGTH is nil, use the window width." 287 (concat (propertize (make-string (or length (1- (window-width))) ?-) 288 'face 'separator-line) 289 "\n")) 290 291 ;;;; Defined in subr.el 292 293 ;; FIXME Should handle multibyte regular expressions 294 (compat-defun string-replace (fromstring tostring instring) ;; <OK> 295 "Replace FROMSTRING with TOSTRING in INSTRING each time it occurs." 296 (when (equal fromstring "") 297 (signal 'wrong-length-argument '(0))) 298 (let ((case-fold-search nil)) 299 (replace-regexp-in-string 300 (regexp-quote fromstring) 301 tostring instring 302 t t))) 303 304 (compat-defun always (&rest _arguments) ;; <OK> 305 "Do nothing and return t. 306 This function accepts any number of ARGUMENTS, but ignores them. 307 Also see `ignore'." 308 t) 309 310 (compat-defun insert-into-buffer (buffer &optional start end) ;; <OK> 311 "Insert the contents of the current buffer into BUFFER. 312 If START/END, only insert that region from the current buffer. 313 Point in BUFFER will be placed after the inserted text." 314 (let ((current (current-buffer))) 315 (with-current-buffer buffer 316 (insert-buffer-substring current start end)))) 317 318 (compat-defun replace-string-in-region (string replacement &optional start end) ;; <OK> 319 "Replace STRING with REPLACEMENT in the region from START to END. 320 The number of replaced occurrences are returned, or nil if STRING 321 doesn't exist in the region. 322 323 If START is nil, use the current point. If END is nil, use `point-max'. 324 325 Comparisons and replacements are done with fixed case." 326 (if start 327 (when (< start (point-min)) 328 (error "Start before start of buffer")) 329 (setq start (point))) 330 (if end 331 (when (> end (point-max)) 332 (error "End after end of buffer")) 333 (setq end (point-max))) 334 (save-excursion 335 (goto-char start) 336 (save-restriction 337 (narrow-to-region start end) 338 (let ((matches 0) 339 (case-fold-search nil)) 340 (while (search-forward string nil t) 341 (delete-region (match-beginning 0) (match-end 0)) 342 (insert replacement) 343 (setq matches (1+ matches))) 344 (and (not (zerop matches)) 345 matches))))) 346 347 (compat-defun replace-regexp-in-region (regexp replacement &optional start end) ;; <OK> 348 "Replace REGEXP with REPLACEMENT in the region from START to END. 349 The number of replaced occurrences are returned, or nil if REGEXP 350 doesn't exist in the region. 351 352 If START is nil, use the current point. If END is nil, use `point-max'. 353 354 Comparisons and replacements are done with fixed case. 355 356 REPLACEMENT can use the following special elements: 357 358 `\\&' in NEWTEXT means substitute original matched text. 359 `\\N' means substitute what matched the Nth `\\(...\\)'. 360 If Nth parens didn't match, substitute nothing. 361 `\\\\' means insert one `\\'. 362 `\\?' is treated literally." 363 (if start 364 (when (< start (point-min)) 365 (error "Start before start of buffer")) 366 (setq start (point))) 367 (if end 368 (when (> end (point-max)) 369 (error "End after end of buffer")) 370 (setq end (point-max))) 371 (save-excursion 372 (goto-char start) 373 (save-restriction 374 (narrow-to-region start end) 375 (let ((matches 0) 376 (case-fold-search nil)) 377 (while (re-search-forward regexp nil t) 378 (replace-match replacement t) 379 (setq matches (1+ matches))) 380 (and (not (zerop matches)) 381 matches))))) 382 383 (compat-defun buffer-local-boundp (symbol buffer) ;; <OK> 384 "Return non-nil if SYMBOL is bound in BUFFER. 385 Also see `local-variable-p'." 386 (catch 'fail 387 (condition-case nil 388 (buffer-local-value symbol buffer) 389 (void-variable nil (throw 'fail nil))) 390 t)) 391 392 (compat-defmacro with-existing-directory (&rest body) ;; <OK> 393 "Execute BODY with `default-directory' bound to an existing directory. 394 If `default-directory' is already an existing directory, it's not changed." 395 (declare (indent 0) (debug t)) 396 `(let ((default-directory 397 (or (catch 'quit 398 (dolist (dir (list default-directory 399 (expand-file-name "~/") 400 temporary-file-directory 401 (getenv "TMPDIR") 402 "/tmp/")) 403 (when (and dir (file-exists-p dir)) 404 (throw 'quit dir)))) 405 "/"))) 406 ,@body)) 407 408 (compat-defmacro dlet (binders &rest body) ;; <OK> 409 "Like `let' but using dynamic scoping." 410 (declare (indent 1) (debug let)) 411 `(let (_) 412 ,@(mapcar (lambda (binder) 413 `(defvar ,(if (consp binder) (car binder) binder))) 414 binders) 415 (let ,binders ,@body))) 416 417 (compat-defun ensure-list (object) ;; <OK> 418 "Return OBJECT as a list. 419 If OBJECT is already a list, return OBJECT itself. If it's 420 not a list, return a one-element list containing OBJECT." 421 (if (listp object) 422 object 423 (list object))) 424 425 (compat-defalias subr-primitive-p subrp) ;; <OK> 426 427 ;;;; Defined in subr-x.el 428 429 (compat-defun string-clean-whitespace (string) ;; <OK> 430 "Clean up whitespace in STRING. 431 All sequences of whitespaces in STRING are collapsed into a 432 single space character, and leading/trailing whitespace is 433 removed." 434 (let ((blank "[[:blank:]\r\n]+")) 435 (replace-regexp-in-string 436 "^[[:blank:]\r\n]+\\|[[:blank:]\r\n]+$" 437 "" 438 (replace-regexp-in-string 439 blank " " string)))) 440 441 (compat-defun string-fill (string length) ;; <OK> 442 "Clean up whitespace in STRING. 443 All sequences of whitespaces in STRING are collapsed into a 444 single space character, and leading/trailing whitespace is 445 removed." 446 (with-temp-buffer 447 (insert string) 448 (goto-char (point-min)) 449 (let ((fill-column length) 450 (adaptive-fill-mode nil)) 451 (fill-region (point-min) (point-max))) 452 (buffer-string))) 453 454 (compat-defun string-lines (string &optional omit-nulls) ;; <OK> 455 "Split STRING into a list of lines. 456 If OMIT-NULLS, empty lines will be removed from the results." 457 (split-string string "\n" omit-nulls)) 458 459 (compat-defun string-pad (string length &optional padding start) ;; <OK> 460 "Pad STRING to LENGTH using PADDING. 461 If PADDING is nil, the space character is used. If not nil, it 462 should be a character. 463 464 If STRING is longer than the absolute value of LENGTH, no padding 465 is done. 466 467 If START is nil (or not present), the padding is done to the end 468 of the string, and if non-nil, padding is done to the start of 469 the string." 470 (unless (natnump length) 471 (signal 'wrong-type-argument (list 'natnump length))) 472 (let ((pad-length (- length (length string)))) 473 (if (< pad-length 0) 474 string 475 (concat (and start 476 (make-string pad-length (or padding ?\s))) 477 string 478 (and (not start) 479 (make-string pad-length (or padding ?\s))))))) 480 481 (compat-defun string-chop-newline (string) ;; <OK> 482 "Remove the final newline (if any) from STRING." 483 (if (and (>= (length string) 1) (= (aref string (1- (length string))) ?\n)) 484 (substring string 0 -1) 485 string)) 486 487 (compat-defmacro named-let (name bindings &rest body) ;; <OK> 488 "Looping construct taken from Scheme. 489 Like `let', bind variables in BINDINGS and then evaluate BODY, 490 but with the twist that BODY can evaluate itself recursively by 491 calling NAME, where the arguments passed to NAME are used 492 as the new values of the bound variables in the recursive invocation." 493 (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body))) 494 (let ((fargs (mapcar (lambda (b) 495 (let ((var (if (consp b) (car b) b))) 496 (make-symbol (symbol-name var)))) 497 bindings)) 498 (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings)) 499 rargs) 500 (dotimes (i (length bindings)) 501 (let ((b (nth i bindings))) 502 (push (list (if (consp b) (car b) b) (nth i fargs)) 503 rargs) 504 (setf (if (consp b) (car b) b) 505 (nth i fargs)))) 506 (letrec 507 ((quit (make-symbol "quit")) (self (make-symbol "self")) 508 (total-tco t) 509 (macro (lambda (&rest args) 510 (setq total-tco nil) 511 `(funcall ,self . ,args))) 512 ;; Based on `cl--self-tco': 513 (tco-progn (lambda (exprs) 514 (append 515 (butlast exprs) 516 (list (funcall tco (car (last exprs))))))) 517 (tco (lambda (expr) 518 (cond 519 ((eq (car-safe expr) 'if) 520 (append (list 'if 521 (cadr expr) 522 (funcall tco (nth 2 expr))) 523 (funcall tco-progn (nthcdr 3 expr)))) 524 ((eq (car-safe expr) 'cond) 525 (let ((conds (cdr expr)) body) 526 (while conds 527 (let ((branch (pop conds))) 528 (push (cond 529 ((cdr branch) ;has tail 530 (funcall tco-progn branch)) 531 ((null conds) ;last element 532 (list t (funcall tco (car branch)))) 533 ((progn 534 branch))) 535 body))) 536 (cons 'cond (nreverse body)))) 537 ((eq (car-safe expr) 'or) 538 (if (cddr expr) 539 (let ((var (make-symbol "var"))) 540 `(let ((,var ,(cadr expr))) 541 (if ,var ,(funcall tco var) 542 ,(funcall tco (cons 'or (cddr expr)))))) 543 (funcall tco (cadr expr)))) 544 ((eq (car-safe expr) 'condition-case) 545 (append (list 'condition-case (cadr expr) (nth 2 expr)) 546 (mapcar 547 (lambda (handler) 548 (cons (car handler) 549 (funcall tco-progn (cdr handler)))) 550 (nthcdr 3 expr)))) 551 ((memq (car-safe expr) '(and progn)) 552 (cons (car expr) (funcall tco-progn (cdr expr)))) 553 ((memq (car-safe expr) '(let let*)) 554 (append (list (car expr) (cadr expr)) 555 (funcall tco-progn (cddr expr)))) 556 ((eq (car-safe expr) name) 557 (let (sets (args (cdr expr))) 558 (dolist (farg fargs) 559 (push (list farg (pop args)) 560 sets)) 561 (cons 'setq (apply #'nconc (nreverse sets))))) 562 (`(throw ',quit ,expr)))))) 563 (let ((tco-body (funcall tco (macroexpand-all (macroexp-progn body))))) 564 (when tco-body 565 (setq body `((catch ',quit 566 (while t (let ,rargs ,@(macroexp-unprogn tco-body)))))))) 567 (let ((expand (macroexpand-all (macroexp-progn body) (list (cons name macro))))) 568 (if total-tco 569 `(let ,bindings ,expand) 570 `(funcall 571 (letrec ((,self (lambda ,fargs ,expand))) ,self) 572 ,@aargs)))))) 573 574 ;;;; Defined in files.el 575 576 (compat-defun file-name-with-extension (filename extension) ;; <OK> 577 "Set the EXTENSION of a FILENAME. 578 The extension (in a file name) is the part that begins with the last \".\". 579 580 Trims a leading dot from the EXTENSION so that either \"foo\" or 581 \".foo\" can be given. 582 583 Errors if the FILENAME or EXTENSION are empty, or if the given 584 FILENAME has the format of a directory. 585 586 See also `file-name-sans-extension'." 587 (let ((extn (string-remove-prefix "." extension))) 588 (cond 589 ((string= filename "") 590 (error "Empty filename")) 591 ((string= extn "") 592 (error "Malformed extension: %s" extension)) 593 ((directory-name-p filename) 594 (error "Filename is a directory: %s" filename)) 595 (t 596 (concat (file-name-sans-extension filename) "." extn))))) 597 598 (compat-defun directory-empty-p (dir) ;; <UNTESTED> 599 "Return t if DIR names an existing directory containing no other files. 600 Return nil if DIR does not name a directory, or if there was 601 trouble determining whether DIR is a directory or empty. 602 603 Symbolic links to directories count as directories. 604 See `file-symlink-p' to distinguish symlinks." 605 (and (file-directory-p dir) 606 (null (directory-files dir nil directory-files-no-dot-files-regexp t)))) 607 608 (compat-defun file-modes-number-to-symbolic (mode &optional filetype) ;; <OK> 609 "Return a string describing a file's MODE. 610 For instance, if MODE is #o700, then it produces `-rwx------'. 611 FILETYPE if provided should be a character denoting the type of file, 612 such as `?d' for a directory, or `?l' for a symbolic link and will override 613 the leading `-' char." 614 (string 615 (or filetype 616 (pcase (ash mode -12) 617 ;; POSIX specifies that the file type is included in st_mode 618 ;; and provides names for the file types but values only for 619 ;; the permissions (e.g., S_IWOTH=2). 620 621 ;; (#o017 ??) ;; #define S_IFMT 00170000 622 (#o014 ?s) ;; #define S_IFSOCK 0140000 623 (#o012 ?l) ;; #define S_IFLNK 0120000 624 ;; (8 ??) ;; #define S_IFREG 0100000 625 (#o006 ?b) ;; #define S_IFBLK 0060000 626 (#o004 ?d) ;; #define S_IFDIR 0040000 627 (#o002 ?c) ;; #define S_IFCHR 0020000 628 (#o001 ?p) ;; #define S_IFIFO 0010000 629 (_ ?-))) 630 (if (zerop (logand 256 mode)) ?- ?r) 631 (if (zerop (logand 128 mode)) ?- ?w) 632 (if (zerop (logand 64 mode)) 633 (if (zerop (logand 2048 mode)) ?- ?S) 634 (if (zerop (logand 2048 mode)) ?x ?s)) 635 (if (zerop (logand 32 mode)) ?- ?r) 636 (if (zerop (logand 16 mode)) ?- ?w) 637 (if (zerop (logand 8 mode)) 638 (if (zerop (logand 1024 mode)) ?- ?S) 639 (if (zerop (logand 1024 mode)) ?x ?s)) 640 (if (zerop (logand 4 mode)) ?- ?r) 641 (if (zerop (logand 2 mode)) ?- ?w) 642 (if (zerop (logand 512 mode)) 643 (if (zerop (logand 1 mode)) ?- ?x) 644 (if (zerop (logand 1 mode)) ?T ?t)))) 645 646 (compat-defun file-backup-file-names (filename) ;; <UNTESTED> 647 "Return a list of backup files for FILENAME. 648 The list will be sorted by modification time so that the most 649 recent files are first." 650 ;; `make-backup-file-name' will get us the right directory for 651 ;; ordinary or numeric backups. It might create a directory for 652 ;; backups as a side-effect, according to `backup-directory-alist'. 653 (let* ((filename (file-name-sans-versions 654 (make-backup-file-name (expand-file-name filename)))) 655 (dir (file-name-directory filename)) 656 files) 657 (dolist (file (file-name-all-completions 658 (file-name-nondirectory filename) dir)) 659 (let ((candidate (concat dir file))) 660 (when (and (backup-file-name-p candidate) 661 (string= (file-name-sans-versions candidate) filename)) 662 (push candidate files)))) 663 (sort files #'file-newer-than-file-p))) 664 665 (compat-defun make-lock-file-name (filename) ;; <OK> 666 "Make a lock file name for FILENAME. 667 This prepends \".#\" to the non-directory part of FILENAME, and 668 doesn't respect `lock-file-name-transforms', as Emacs 28.1 and 669 onwards does." 670 (expand-file-name 671 (concat 672 ".#" (file-name-nondirectory filename)) 673 (file-name-directory filename))) 674 675 ;;;; Defined in files-x.el 676 677 (declare-function tramp-tramp-file-p "tramp" (name)) 678 679 (compat-defun null-device () ;; <UNTESTED> 680 "Return the best guess for the null device." 681 (require 'tramp) 682 (if (tramp-tramp-file-p default-directory) 683 "/dev/null" 684 null-device)) 685 686 ;;;; Defined in minibuffer.el 687 688 (compat-defun format-prompt (prompt default &rest format-args) ;; <OK> 689 "Format PROMPT with DEFAULT. 690 If FORMAT-ARGS is nil, PROMPT is used as a plain string. If 691 FORMAT-ARGS is non-nil, PROMPT is used as a format control 692 string, and FORMAT-ARGS are the arguments to be substituted into 693 it. See `format' for details. 694 695 If DEFAULT is a list, the first element is used as the default. 696 If not, the element is used as is. 697 698 If DEFAULT is nil or an empty string, no \"default value\" string 699 is included in the return value." 700 (concat 701 (if (null format-args) 702 prompt 703 (apply #'format prompt format-args)) 704 (and default 705 (or (not (stringp default)) 706 (> (length default) 0)) 707 (format " (default %s)" 708 (if (consp default) 709 (car default) 710 default))) 711 ": ")) 712 713 ;;;; Defined in windows.el 714 715 (compat-defun count-windows (&optional minibuf all-frames) ;; <UNTESTED> 716 "Handle optional argument ALL-FRAMES. 717 If ALL-FRAMES is non-nil, count the windows in all frames instead 718 just the selected frame." 719 :explicit t 720 (if all-frames 721 (let ((sum 0)) 722 (dolist (frame (frame-list)) 723 (with-selected-frame frame 724 (setq sum (+ (count-windows minibuf) sum)))) 725 sum) 726 (count-windows minibuf))) 727 728 ;;;; Defined in thingatpt.el 729 730 (compat-defun thing-at-mouse (event thing &optional no-properties) ;; <UNTESTED> 731 "Return the THING at mouse click. 732 Like `thing-at-point', but tries to use the event 733 where the mouse button is clicked to find a thing nearby." 734 :feature thingatpt 735 (save-excursion 736 (mouse-set-point event) 737 (thing-at-point thing no-properties))) 738 739 ;;;; Defined in macroexp.el 740 741 (compat-defun macroexp-file-name () ;; <OK> 742 "Return the name of the file from which the code comes. 743 Returns nil when we do not know. 744 A non-nil result is expected to be reliable when called from a macro in order 745 to find the file in which the macro's call was found, and it should be 746 reliable as well when used at the top-level of a file. 747 Other uses risk returning non-nil value that point to the wrong file." 748 (let ((file (car (last current-load-list)))) 749 (or (if (stringp file) file) 750 (bound-and-true-p byte-compile-current-file)))) 751 752 ;;;; Defined in env.el 753 754 (compat-defmacro with-environment-variables (variables &rest body) ;; <OK> 755 "Set VARIABLES in the environent and execute BODY. 756 VARIABLES is a list of variable settings of the form (VAR VALUE), 757 where VAR is the name of the variable (a string) and VALUE 758 is its value (also a string). 759 760 The previous values will be be restored upon exit." 761 (declare (indent 1) (debug (sexp body))) 762 (unless (consp variables) 763 (error "Invalid VARIABLES: %s" variables)) 764 `(let ((process-environment (copy-sequence process-environment))) 765 ,@(mapcar (lambda (elem) 766 `(setenv ,(car elem) ,(cadr elem))) 767 variables) 768 ,@body)) 769 770 ;;;; Defined in time-data.el 771 772 (compat-defun decoded-time-period (time) ;; <OK> 773 "Interpret DECODED as a period and return its length in seconds. 774 For computational purposes, years are 365 days long and months 775 are 30 days long." 776 :feature time-date 777 ;; Inlining the definitions from compat-27 778 (+ (if (consp (nth 0 time)) 779 ;; Fractional second. 780 (/ (float (car (nth 0 time))) 781 (cdr (nth 0 time))) 782 (or (nth 0 time) 0)) 783 (* (or (nth 1 time) 0) 60) 784 (* (or (nth 2 time) 0) 60 60) 785 (* (or (nth 3 time) 0) 60 60 24) 786 (* (or (nth 4 time) 0) 60 60 24 30) 787 (* (or (nth 5 time) 0) 60 60 24 365))) 788 789 (provide 'compat-28) 790 ;;; compat-28.el ends here