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