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