diff options
Diffstat (limited to 'lisp/international/mule-cmds.el')
| -rw-r--r-- | lisp/international/mule-cmds.el | 365 |
1 files changed, 241 insertions, 124 deletions
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 28be35d65d2..27defef6480 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -88,7 +88,7 @@ (bindings--define-key map [separator-3] menu-bar-separator) (bindings--define-key map [set-terminal-coding-system] '(menu-item "For Terminal" set-terminal-coding-system - :enable (null (memq initial-window-system '(x w32 ns))) + :enable (null (memq initial-window-system '(x w32 ns haiku pgtk))) :help "How to encode terminal output")) (bindings--define-key map [set-keyboard-coding-system] '(menu-item "For Keyboard" set-keyboard-coding-system @@ -1638,30 +1638,31 @@ If `default-transient-input-method' was not yet defined, prompt for it." (interactive (list (read-input-method-name (format-prompt "Describe input method" current-input-method)))) - (if (and input-method (symbolp input-method)) - (setq input-method (symbol-name input-method))) - (help-setup-xref (list #'describe-input-method - (or input-method current-input-method)) - (called-interactively-p 'interactive)) - - (if (null input-method) - (describe-current-input-method) - (let ((current current-input-method)) - (condition-case nil - (progn - (save-excursion - (activate-input-method input-method) - (describe-current-input-method)) - (activate-input-method current)) - (error - (activate-input-method current) - (help-setup-xref (list #'describe-input-method input-method) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (let ((elt (assoc input-method input-method-alist))) - (princ (format-message - "Input method: %s (`%s' in mode line) for %s\n %s\n" - input-method (nth 3 elt) (nth 1 elt) (nth 4 elt)))))))))) + (let ((help-buffer-under-preparation t)) + (if (and input-method (symbolp input-method)) + (setq input-method (symbol-name input-method))) + (help-setup-xref (list #'describe-input-method + (or input-method current-input-method)) + (called-interactively-p 'interactive)) + + (if (null input-method) + (describe-current-input-method) + (let ((current current-input-method)) + (condition-case nil + (progn + (save-excursion + (activate-input-method input-method) + (describe-current-input-method)) + (activate-input-method current)) + (error + (activate-input-method current) + (help-setup-xref (list #'describe-input-method input-method) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (let ((elt (assoc input-method input-method-alist))) + (princ (format-message + "Input method: %s (`%s' in mode line) for %s\n %s\n" + input-method (nth 3 elt) (nth 1 elt) (nth 4 elt))))))))))) (defun describe-current-input-method () "Describe the input method currently in use. @@ -2162,89 +2163,90 @@ See `set-language-info-alist' for use in programs." (list (read-language-name 'documentation (format-prompt "Describe language environment" current-language-environment)))) - (if (null language-name) - (setq language-name current-language-environment)) - (if (or (null language-name) - (null (get-language-info language-name 'documentation))) - (error "No documentation for the specified language")) - (if (symbolp language-name) - (setq language-name (symbol-name language-name))) - (dolist (feature (get-language-info language-name 'features)) - (require feature)) - (let ((doc (get-language-info language-name 'documentation))) - (help-setup-xref (list #'describe-language-environment language-name) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (insert language-name " language environment\n\n") - (if (stringp doc) - (insert (substitute-command-keys doc) "\n\n")) - (condition-case nil - (let ((str (eval (get-language-info language-name 'sample-text)))) - (if (stringp str) - (insert "Sample text:\n " - (string-replace "\n" "\n " str) - "\n\n"))) - (error nil)) - (let ((input-method (get-language-info language-name 'input-method)) - (l (copy-sequence input-method-alist)) - (first t)) - (when (and input-method - (setq input-method (assoc input-method l))) - (insert "Input methods (default " (car input-method) ")\n") - (setq l (cons input-method (delete input-method l)) - first nil)) - (dolist (elt l) - (when (or (eq input-method elt) - (eq t (compare-strings language-name nil nil - (nth 1 elt) nil nil t))) - (when first - (insert "Input methods:\n") - (setq first nil)) - (insert " " (car elt)) - (search-backward (car elt)) - (help-xref-button 0 'help-input-method (car elt)) - (goto-char (point-max)) - (insert " (\"" - (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt))) - "\" in mode line)\n"))) - (or first - (insert "\n"))) - (insert "Character sets:\n") - (let ((l (get-language-info language-name 'charset))) - (if (null l) - (insert " nothing specific to " language-name "\n") - (while l - (insert " " (symbol-name (car l))) - (search-backward (symbol-name (car l))) - (help-xref-button 0 'help-character-set (car l)) - (goto-char (point-max)) - (insert ": " (charset-description (car l)) "\n") - (setq l (cdr l))))) - (insert "\n") - (insert "Coding systems:\n") - (let ((l (get-language-info language-name 'coding-system))) - (if (null l) - (insert " nothing specific to " language-name "\n") - (while l - (insert " " (symbol-name (car l))) - (search-backward (symbol-name (car l))) - (help-xref-button 0 'help-coding-system (car l)) - (goto-char (point-max)) - (insert (substitute-command-keys " (`") - (coding-system-mnemonic (car l)) - (substitute-command-keys "' in mode line):\n\t") - (substitute-command-keys - (coding-system-doc-string (car l))) - "\n") - (let ((aliases (coding-system-aliases (car l)))) - (when aliases - (insert "\t(alias:") - (while aliases - (insert " " (symbol-name (car aliases))) - (setq aliases (cdr aliases))) - (insert ")\n"))) - (setq l (cdr l))))))))) + (let ((help-buffer-under-preparation t)) + (if (null language-name) + (setq language-name current-language-environment)) + (if (or (null language-name) + (null (get-language-info language-name 'documentation))) + (error "No documentation for the specified language")) + (if (symbolp language-name) + (setq language-name (symbol-name language-name))) + (dolist (feature (get-language-info language-name 'features)) + (require feature)) + (let ((doc (get-language-info language-name 'documentation))) + (help-setup-xref (list #'describe-language-environment language-name) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (insert language-name " language environment\n\n") + (if (stringp doc) + (insert (substitute-command-keys doc) "\n\n")) + (condition-case nil + (let ((str (eval (get-language-info language-name 'sample-text)))) + (if (stringp str) + (insert "Sample text:\n " + (string-replace "\n" "\n " str) + "\n\n"))) + (error nil)) + (let ((input-method (get-language-info language-name 'input-method)) + (l (copy-sequence input-method-alist)) + (first t)) + (when (and input-method + (setq input-method (assoc input-method l))) + (insert "Input methods (default " (car input-method) ")\n") + (setq l (cons input-method (delete input-method l)) + first nil)) + (dolist (elt l) + (when (or (eq input-method elt) + (eq t (compare-strings language-name nil nil + (nth 1 elt) nil nil t))) + (when first + (insert "Input methods:\n") + (setq first nil)) + (insert " " (car elt)) + (search-backward (car elt)) + (help-xref-button 0 'help-input-method (car elt)) + (goto-char (point-max)) + (insert " (\"" + (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt))) + "\" in mode line)\n"))) + (or first + (insert "\n"))) + (insert "Character sets:\n") + (let ((l (get-language-info language-name 'charset))) + (if (null l) + (insert " nothing specific to " language-name "\n") + (while l + (insert " " (symbol-name (car l))) + (search-backward (symbol-name (car l))) + (help-xref-button 0 'help-character-set (car l)) + (goto-char (point-max)) + (insert ": " (charset-description (car l)) "\n") + (setq l (cdr l))))) + (insert "\n") + (insert "Coding systems:\n") + (let ((l (get-language-info language-name 'coding-system))) + (if (null l) + (insert " nothing specific to " language-name "\n") + (while l + (insert " " (symbol-name (car l))) + (search-backward (symbol-name (car l))) + (help-xref-button 0 'help-coding-system (car l)) + (goto-char (point-max)) + (insert (substitute-command-keys " (`") + (coding-system-mnemonic (car l)) + (substitute-command-keys "' in mode line):\n\t") + (substitute-command-keys + (coding-system-doc-string (car l))) + "\n") + (let ((aliases (coding-system-aliases (car l)))) + (when aliases + (insert "\t(alias:") + (while aliases + (insert " " (symbol-name (car aliases))) + (setq aliases (cdr aliases))) + (insert ")\n"))) + (setq l (cdr l)))))))))) ;;; Locales. @@ -2665,6 +2667,20 @@ For example, translate \"swedish\" into \"sv_SE.ISO8859-1\"." locale)) locale)) +(defvar current-locale-environment nil + "The currently set locale environment.") + +(defmacro with-locale-environment (locale-name &rest body) + "Execute BODY with the locale set to LOCALE-NAME." + (declare (indent 1) (debug (sexp def-body))) + (let ((current (gensym))) + `(let ((,current current-locale-environment)) + (unwind-protect + (progn + (set-locale-environment ,locale-name) + ,@body) + (set-locale-environment ,current))))) + (defun set-locale-environment (&optional locale-name frame) "Set up multilingual environment for using LOCALE-NAME. This sets the language environment, the coding system priority, @@ -2690,6 +2706,10 @@ If FRAME is non-nil, only set the keyboard coding system and the terminal coding system for the terminal of that frame, and don't touch session-global parameters like the language environment. +This function sets the `current-locale-environment' variable. To +change the locale temporarily, `with-locale-environment' can be +used. + See also `locale-charset-language-names', `locale-language-names', `locale-preferred-coding-systems' and `locale-coding-system'." (interactive (list (completing-read "Set environment for locale: " @@ -2723,6 +2743,7 @@ See also `locale-charset-language-names', `locale-language-names', (when locale (setq locale (locale-translate locale)) + (setq current-locale-environment locale) ;; Leave the system locales alone if the caller did not specify ;; an explicit locale name, as their defaults are set from @@ -2927,6 +2948,7 @@ Optional 3rd argument DOCSTRING is a documentation string of the property. See also the documentation of `get-char-code-property' and `put-char-code-property'." + (declare (indent defun)) (or (symbolp name) (error "Not a symbol: %s" name)) (if (char-table-p table) @@ -3061,22 +3083,6 @@ on encoding." 0)) (substring enc2 i0 i2))))) -;; Backwards compatibility. These might be better with :init-value t, -;; but that breaks loadup. -(define-minor-mode unify-8859-on-encoding-mode - "Exists only for backwards compatibility." - :group 'mule - :global t) -;; Doc said "obsolete" in 23.1, this statement only added in 24.1. -(make-obsolete 'unify-8859-on-encoding-mode "don't use it." "23.1") - -(define-minor-mode unify-8859-on-decoding-mode - "Exists only for backwards compatibility." - :group 'mule - :global t) -;; Doc said "obsolete" in 23.1, this statement only added in 24.1. -(make-obsolete 'unify-8859-on-decoding-mode "don't use it." "23.1") - (defvar ucs-names nil "Hash table of cached CHAR-NAME keys to CHAR-CODE values.") @@ -3244,5 +3250,116 @@ as names, not numbers." (define-obsolete-function-alias 'ucs-insert 'insert-char "24.3") (define-key ctl-x-map "8\r" 'insert-char) +(define-key ctl-x-map "8e" + (define-keymap + "e" #'emoji-insert + "i" #'emoji-insert + "s" #'emoji-search + "d" #'emoji-describe + "r" #'emoji-recent + "l" #'emoji-list)) + +(defface confusingly-reordered + '((((supports :underline (:style wave))) + :underline (:style wave :color "Red1")) + (t + :inherit warning)) + "Face for highlighting text that was bidi-reordered in confusing ways." + :version "29.1") + +(defvar reorder-starters "[\u202A\u202B\u202D\u202E\u2066-\u2068]+" + "Regular expression for characters that start forced-reordered text.") +(defvar reorder-enders "[\u202C\u2069]+\\|\n" + "Regular expression for characters that end forced-reordered text.") + +(autoload 'text-property-search-forward "text-property-search") +(autoload 'prop-match-beginning "text-property-search") +(autoload 'prop-match-end "text-property-search") + +(defun highlight-confusing-reorderings (beg end &optional remove) + "Highlight text in region that might be bidi-reordered in suspicious ways. +This command find and highlights segments of buffer text that could have +been reordered on display by using directional control characters, such +as RLO and LRI, in a way that their display is deliberately meant to +confuse the reader. These techniques can be used for obfuscating +malicious source code. The suspicious stretches of buffer text are +highlighted using the `confusingly-reordered' face. + +If the region is active, check the text inside the region. Otherwise +check the entire buffer. When called from Lisp, pass BEG and END to +specify the portion of the buffer to check. + +Optional argument REMOVE, if non-nil (interactively, prefix argument), +means remove the highlighting from the region between BEG and END, +or the active region if that is set." + (interactive + (if (use-region-p) + (list (region-beginning) (region-end) current-prefix-arg) + (list (point-min) (point-max) current-prefix-arg))) + (save-excursion + (if remove + (let (prop-match) + (goto-char beg) + (while (and + (setq prop-match + (text-property-search-forward 'font-lock-face + 'confusingly-reordered t)) + (< (prop-match-beginning prop-match) end)) + (with-silent-modifications + (remove-list-of-text-properties (prop-match-beginning prop-match) + (prop-match-end prop-match) + '(font-lock-face face mouse-face + help-echo))))) + (let ((count 0) + next) + (goto-char beg) + (while (setq next + (bidi-find-overridden-directionality + (point) end nil + (current-bidi-paragraph-direction))) + (goto-char next) + ;; We detect the problematic parts by watching directional + ;; properties of strong L2R and R2L characters. But + ;; malicious reordering in source buffers can, and usuually + ;; does, include syntactically-important punctuation + ;; characters. Those have "weak" directionality, so we + ;; cannot easily detect when they are affected in malicious + ;; ways. Therefore, once we find a strong directional + ;; character whose directionality was tweaked, we highlight + ;; the text around it, between the first bidi control + ;; character we find before it that starts an + ;; override/embedding/isolate, and the first control after + ;; it that ends these. This could sometimes highlight only + ;; part of the affected text. An alternative would be to + ;; find the first "starter" following BOL and the last + ;; "ender" before EOL, and highlight everything in between + ;; them -- this could sometimes highlight too much. + (let ((start + (save-excursion + (re-search-backward reorder-starters nil t))) + (finish + (save-excursion + (let ((fin (re-search-forward reorder-enders nil t))) + (if fin (1- fin) + (point-max)))))) + (with-silent-modifications + (add-text-properties start finish + '(font-lock-face + confusingly-reordered + face confusingly-reordered + mouse-face highlight + help-echo "\ +This text is reordered on display in a way that could change its semantics; +use \\[forward-char] and \\[backward-char] to see the actual order of characters."))) + (goto-char finish) + (setq count (1+ count)))) + (message + (if (> count 0) + (ngettext + "Highlighted %d confusingly-reordered text string" + "Highlighted %d confusingly-reordered text strings" + count) + "No confusingly-reordered text strings were found") + count))))) ;;; mule-cmds.el ends here |