diff options
| author | Miles Bader <miles@gnu.org> | 2007-10-11 16:24:58 +0000 |
|---|---|---|
| committer | Miles Bader <miles@gnu.org> | 2007-10-11 16:24:58 +0000 |
| commit | c73bd236f75b742ad4642ec94798987ae6e3e1e8 (patch) | |
| tree | ef5edc8db557fc1d25a17c379e4ae63a38b3ba5c /lisp | |
| parent | ecb21060d5c1752d41d7a742be565c59b5fcb855 (diff) | |
| parent | 58ade22bf16a9ec2ff0aee6c59d8db4d1703e94f (diff) | |
| download | emacs-c73bd236f75b742ad4642ec94798987ae6e3e1e8.tar.gz | |
Merge from emacs--devo--0
Patches applied:
* emacs--devo--0 (patch 866-879)
- Merge multi-tty branch
- Update from CVS
- Merge from emacs--rel--22
Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-257
Diffstat (limited to 'lisp')
146 files changed, 5474 insertions, 4136 deletions
diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index ab8f743eb34..0aa053702b8 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -618,15 +618,15 @@ (calc-init-prefixes) - (mapcar (function - (lambda (x) - (define-key calc-mode-map (format "c%c" x) 'calc-clean-num) - (define-key calc-mode-map (format "j%c" x) 'calc-select-part) - (define-key calc-mode-map (format "r%c" x) 'calc-recall-quick) - (define-key calc-mode-map (format "s%c" x) 'calc-store-quick) - (define-key calc-mode-map (format "t%c" x) 'calc-store-into-quick) - (define-key calc-mode-map (format "u%c" x) 'calc-quick-units))) - "0123456789") + (mapc (function + (lambda (x) + (define-key calc-mode-map (format "c%c" x) 'calc-clean-num) + (define-key calc-mode-map (format "j%c" x) 'calc-select-part) + (define-key calc-mode-map (format "r%c" x) 'calc-recall-quick) + (define-key calc-mode-map (format "s%c" x) 'calc-store-quick) + (define-key calc-mode-map (format "t%c" x) 'calc-store-into-quick) + (define-key calc-mode-map (format "u%c" x) 'calc-quick-units))) + "0123456789") (let ((i ?A)) (while (<= i ?z) @@ -635,7 +635,7 @@ (cons 'keymap (cons (cons ?\e (aref (nth 1 calc-mode-map) i)) (cdr (aref (nth 1 calc-mode-map) i)))))) (setq i (1+ i)))) - + (setq calc-alg-map (copy-keymap calc-mode-map) calc-alg-esc-map (copy-keymap esc-map)) (let ((i 32)) @@ -651,7 +651,7 @@ (define-key calc-alg-map "\e\177" 'calc-pop-above) ;;;; (Autoloads here) - (mapcar (function (lambda (x) + (mapc (function (lambda (x) (mapcar (function (lambda (func) (autoload func (car x)))) (cdr x)))) '( @@ -1021,7 +1021,7 @@ calc-arctan calc-arctan2 calc-arctanh calc-conj calc-cos calc-cosh calc-cot calc-coth calc-csc calc-csch calc-degrees-mode calc-exp calc-expm1 calc-hypot calc-ilog calc-imaginary calc-isqrt calc-ln calc-lnp1 calc-log calc-log10 -calc-pi calc-radians-mode calc-sec calc-sech +calc-pi calc-radians-mode calc-sec calc-sech calc-sin calc-sincos calc-sinh calc-sqrt calc-tan calc-tanh calc-to-degrees calc-to-radians) @@ -1277,7 +1277,7 @@ calc-kill calc-kill-region calc-yank)))) calc-redo-list nil) (let (calc-stack calc-user-parse-tables calc-standard-date-formats calc-invocation-macro) - (mapcar (function (lambda (v) (set v nil))) calc-local-var-list) + (mapc (function (lambda (v) (set v nil))) calc-local-var-list) (if (and arg (<= arg 0)) (calc-mode-var-list-restore-default-values) (calc-mode-var-list-restore-saved-values))) @@ -1357,7 +1357,7 @@ calc-kill calc-kill-region calc-yank)))) (with-current-buffer calc-main-buffer calc-hyperbolic-flag) calc-hyperbolic-flag)) - (msg (if hyp-flag + (msg (if hyp-flag "Inverse Hyperbolic..." "Inverse..."))) (calc-fancy-prefix 'calc-inverse-flag msg n))) @@ -1438,7 +1438,7 @@ calc-kill calc-kill-region calc-yank)))) (with-current-buffer calc-main-buffer calc-inverse-flag) calc-inverse-flag)) - (msg (if inv-flag + (msg (if inv-flag "Inverse Hyperbolic..." "Hyperbolic..."))) (calc-fancy-prefix 'calc-hyperbolic-flag msg n))) @@ -1849,7 +1849,7 @@ calc-kill calc-kill-region calc-yank)))) (setq calc-z-prefix-buf (concat (if (= flags 1) "SHIFT + " "") desc)) (if (> (+ (length calc-z-prefix-buf) (length desc)) 58) - (setq calc-z-prefix-msgs + (setq calc-z-prefix-msgs (cons calc-z-prefix-buf calc-z-prefix-msgs) calc-z-prefix-buf (concat (if (= flags 1) "SHIFT + " "") desc)) @@ -1879,14 +1879,14 @@ calc-kill calc-kill-region calc-yank)))) (last-val (intern (concat (symbol-name name) "-last")))) (list 'progn ; (list 'defvar cache-prec (if init (math-numdigs (nth 1 init)) -100)) - (list 'defvar cache-prec + (list 'defvar cache-prec `(cond ((consp ,init) (math-numdigs (nth 1 ,init))) - (,init + (,init (nth 1 (math-numdigs (eval ,init)))) (t -100))) - (list 'defvar cache-val + (list 'defvar cache-val `(cond ((consp ,init) ,init) (,init (eval ,init)) @@ -1963,7 +1963,7 @@ calc-kill calc-kill-region calc-yank)))) (defconst math-approx-sqrt-e (math-read-number-simple "1.648721270700128146849") "An approximation for sqrt(3).") - + (math-defcache math-sqrt-e math-approx-sqrt-e (math-add-float '(float 1 0) (math-exp-minus-1-raw '(float 5 -1)))) @@ -1975,11 +1975,11 @@ calc-kill calc-kill-region calc-yank)))) '(float 5 -1))) (defconst math-approx-gamma-const - (math-read-number-simple + (math-read-number-simple "0.5772156649015328606065120900824024310421593359399235988057672348848677267776646709369470632917467495") "An approximation for gamma.") -(math-defcache math-gamma-const nil +(math-defcache math-gamma-const nil math-approx-gamma-const) (defun math-half-circle (symb) @@ -2148,12 +2148,12 @@ calc-kill calc-kill-region calc-yank)))) (unless a (setq a 1)) (and - (not (memq nil (mapcar + (not (memq nil (mapcar (lambda (x) (eq x 0)) (nthcdr (1+ n) row)))) - (not (memq nil (mapcar + (not (memq nil (mapcar (lambda (x) (eq x 0)) - (butlast + (butlast (cdr row) (- (length row) n))))) (eq (elt row n) a))) @@ -2218,7 +2218,7 @@ If X is not an error form, return X." (if (eq (car-safe x) 'sdev) (nth 1 x) x)) - + (defun math-get-sdev (x &optional one) "Get the standard deviation of the error form X. If X is not an error form, return 1." @@ -2331,15 +2331,15 @@ If X is not an error form, return 1." (and (symbolp (car math-normalize-a)) (or (eq calc-simplify-mode 'none) (and (eq calc-simplify-mode 'num) - (let ((aptr (setq math-normalize-a + (let ((aptr (setq math-normalize-a (cons (car math-normalize-a) - (mapcar 'math-normalize + (mapcar 'math-normalize (cdr math-normalize-a)))))) (while (and aptr (math-constp (car aptr))) (setq aptr (cdr aptr))) aptr))) - (cons (car math-normalize-a) + (cons (car math-normalize-a) (mapcar 'math-normalize (cdr math-normalize-a)))))) @@ -2720,8 +2720,8 @@ If X is not an error form, return 1." (setq mmt-nextval (funcall math-mt-func mmt-expr)) (not (equal mmt-expr mmt-nextval))) (setq mmt-expr mmt-nextval - math-mt-many (if (> math-mt-many 0) - (1- math-mt-many) + math-mt-many (if (> math-mt-many 0) + (1- math-mt-many) (1+ math-mt-many)))) (if (or (Math-primp mmt-expr) (<= math-mt-many 0)) @@ -3046,10 +3046,10 @@ If X is not an error form, return 1." math-read-big-baseline math-read-big-h2 new-pos p) (while (setq new-pos (string-match "\n" str pos)) - (setq math-read-big-lines + (setq math-read-big-lines (cons (substring str pos new-pos) math-read-big-lines) pos (1+ new-pos))) - (setq math-read-big-lines + (setq math-read-big-lines (nreverse (cons (substring str pos) math-read-big-lines)) p math-read-big-lines) (while p diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index 871f281aa5e..ed1c93e8694 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -321,11 +321,11 @@ C-w Describe how there is no warranty for Calc." (defun calc-describe-function (&optional func) (interactive) (unless calc-help-function-list - (setq calc-help-function-list + (setq calc-help-function-list (calc-help-index-entries "Function" "Command"))) (or func (setq func (completing-read "Describe function: " - calc-help-function-list + calc-help-function-list nil t))) (if (string-match "\\`calc-." func) (calc-describe-thing func "Command Index") @@ -334,7 +334,7 @@ C-w Describe how there is no warranty for Calc." (defun calc-describe-variable (&optional var) (interactive) (unless calc-help-variable-list - (setq calc-help-variable-list + (setq calc-help-variable-list (calc-help-index-entries "Variable"))) (or var (setq var (completing-read "Describe variable: " @@ -419,49 +419,49 @@ C-w Describe how there is no warranty for Calc." (princ "Or type `h i' to read the full Calc manual on-line.\n\n") (princ "Basic keys:\n") (let* ((calc-full-help-flag t)) - (mapcar (function (lambda (x) (princ (format " %s\n" x)))) - (nreverse (cdr (reverse (cdr (calc-help)))))) - (mapcar (function (lambda (prefix) - (let ((msgs (condition-case err - (funcall prefix) - (error nil)))) - (if (car msgs) - (princ - (if (eq (nth 2 msgs) ?v) - "\n`v' or `V' prefix (vector/matrix) keys: \n" - (if (nth 2 msgs) - (format - "\n`%c' prefix (%s) keys:\n" - (nth 2 msgs) - (or (cdr (assq (nth 2 msgs) - calc-help-long-names)) - (nth 1 msgs))) - (format "\n%s-modified keys:\n" - (capitalize (nth 1 msgs))))))) - (mapcar (function (lambda (x) - (princ (format " %s\n" x)))) - (car msgs))))) - '(calc-inverse-prefix-help - calc-hyperbolic-prefix-help - calc-inv-hyp-prefix-help - calc-a-prefix-help - calc-b-prefix-help - calc-c-prefix-help - calc-d-prefix-help - calc-f-prefix-help - calc-g-prefix-help - calc-h-prefix-help - calc-j-prefix-help - calc-k-prefix-help - calc-m-prefix-help - calc-r-prefix-help - calc-s-prefix-help - calc-t-prefix-help - calc-u-prefix-help - calc-v-prefix-help - calc-shift-Y-prefix-help - calc-shift-Z-prefix-help - calc-z-prefix-help))) + (mapc (function (lambda (x) (princ (format " %s\n" x)))) + (nreverse (cdr (reverse (cdr (calc-help)))))) + (mapc (function (lambda (prefix) + (let ((msgs (condition-case err + (funcall prefix) + (error nil)))) + (if (car msgs) + (princ + (if (eq (nth 2 msgs) ?v) + "\n`v' or `V' prefix (vector/matrix) keys: \n" + (if (nth 2 msgs) + (format + "\n`%c' prefix (%s) keys:\n" + (nth 2 msgs) + (or (cdr (assq (nth 2 msgs) + calc-help-long-names)) + (nth 1 msgs))) + (format "\n%s-modified keys:\n" + (capitalize (nth 1 msgs))))))) + (mapcar (function (lambda (x) + (princ (format " %s\n" x)))) + (car msgs))))) + '(calc-inverse-prefix-help + calc-hyperbolic-prefix-help + calc-inv-hyp-prefix-help + calc-a-prefix-help + calc-b-prefix-help + calc-c-prefix-help + calc-d-prefix-help + calc-f-prefix-help + calc-g-prefix-help + calc-h-prefix-help + calc-j-prefix-help + calc-k-prefix-help + calc-m-prefix-help + calc-r-prefix-help + calc-s-prefix-help + calc-t-prefix-help + calc-u-prefix-help + calc-v-prefix-help + calc-shift-Y-prefix-help + calc-shift-Z-prefix-help + calc-z-prefix-help))) (print-help-return-message))) (defun calc-h-prefix-help () diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el index 3e4743d58ae..3a2319e9a2c 100644 --- a/lisp/calc/calc-math.el +++ b/lisp/calc/calc-math.el @@ -53,28 +53,41 @@ ;;; is an Emacs float, for acceptable d.dddd.... (defvar math-largest-emacs-expt - (let ((x 1)) - (while (condition-case nil - (expt 10.0 x) - (error nil)) - (setq x (* 2 x))) - (setq x (/ x 2)) - (while (condition-case nil - (expt 10.0 x) - (error nil)) - (setq x (1+ x))) - (- x 2)) + (let ((x 1) + (pow 1e2)) + ;; The following loop is for efficiency; it should stop when + ;; 10^(2x) is too large. This could be indicated by a range + ;; error when computing 10^(2x) or an infinite value for 10^(2x). + (while (and + pow + (< pow 1.0e+INF)) + (setq x (* 2 x)) + (setq pow (condition-case nil + (expt 10.0 (* 2 x)) + (error nil)))) + ;; The following loop should stop when 10^(x+1) is too large. + (setq pow (condition-case nil + (expt 10.0 (1+ x)) + (error nil))) + (while (and + pow + (< pow 1.0e+INF)) + (setq x (1+ x)) + (setq pow (condition-case nil + (expt 10.0 (1+ x)) + (error nil)))) + (1- x)) "The largest exponent which Calc will convert to an Emacs float.") (defvar math-smallest-emacs-expt (let ((x -1)) (while (condition-case nil - (expt 10.0 x) + (> (expt 10.0 x) 0.0) (error nil)) (setq x (* 2 x))) (setq x (/ x 2)) (while (condition-case nil - (expt 10.0 x) + (> (expt 10.0 x) 0.0) (error nil)) (setq x (1- x))) (+ x 2)) diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index 10222fc1625..b660e046a21 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -145,9 +145,9 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C). "Create another, independent Calculator buffer." (interactive) (if (eq major-mode 'calc-mode) - (mapcar (function - (lambda (v) - (set-default v (symbol-value v)))) calc-local-var-list)) + (mapc (function + (lambda (v) + (set-default v (symbol-value v)))) calc-local-var-list)) (set-buffer (generate-new-buffer "*Calculator*")) (pop-to-buffer (current-buffer)) (calc-mode)) diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index 75a17661746..e439150814a 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -127,7 +127,7 @@ (cond ((and (memq var '(var-e var-i var-pi var-phi var-gamma)) (eq (car-safe old) 'special-const)) - (setq msg (format " (Note: Built-in definition of %s has been lost)" + (setq msg (format " (Note: Built-in definition of %s has been lost)" (calc-var-name var)))) ((and (memq var '(var-inf var-uinf var-nan)) (null old)) @@ -172,28 +172,28 @@ () (setq calc-var-name-map (copy-keymap minibuffer-local-completion-map)) (define-key calc-var-name-map " " 'self-insert-command) - (mapcar (function - (lambda (x) - (define-key calc-var-name-map (char-to-string x) - 'calcVar-digit))) - "0123456789") - (mapcar (function - (lambda (x) - (define-key calc-var-name-map (char-to-string x) - 'calcVar-oper))) - "+-*/^|")) + (mapc (function + (lambda (x) + (define-key calc-var-name-map (char-to-string x) + 'calcVar-digit))) + "0123456789") + (mapc (function + (lambda (x) + (define-key calc-var-name-map (char-to-string x) + 'calcVar-oper))) + "+-*/^|")) (defvar calc-store-opers) (defun calc-read-var-name (prompt &optional calc-store-opers) (setq calc-given-value nil calc-aborted-prefix nil) - (let ((var (concat + (let ((var (concat "var-" (let ((minibuffer-completion-table - (mapcar (lambda (x) (substring x 4)) + (mapcar (lambda (x) (substring x 4)) (all-completions "var-" obarray))) - (minibuffer-completion-predicate + (minibuffer-completion-predicate (lambda (x) (boundp (intern (concat "var-" x))))) (minibuffer-completion-confirm t)) (read-from-minibuffer prompt nil calc-var-name-map nil))))) @@ -401,7 +401,7 @@ (unless (string= sconst "") (let ((value (cdr (assoc sconst sc)))) (or var (setq var (calc-read-var-name - (format "Copy special constant %s, to: " + (format "Copy special constant %s, to: " sconst)))) (if var (let ((msg (calc-store-value var value ""))) @@ -417,7 +417,7 @@ (or value (error "No such variable: \"%s\"" (calc-var-name var1))) (or var2 (setq var2 (calc-read-var-name - (format "Copy variable: %s, to: " + (format "Copy variable: %s, to: " (calc-var-name var1))))) (if var2 (let ((msg (calc-store-value var2 value ""))) diff --git a/lisp/calc/calc-stuff.el b/lisp/calc/calc-stuff.el index a1f50816519..5dcc5365d10 100644 --- a/lisp/calc/calc-stuff.el +++ b/lisp/calc/calc-stuff.el @@ -191,7 +191,7 @@ With a prefix, push that prefix as a number onto the stack." math-eval-rules-cache-tag t math-format-date-cache nil math-holidays-cache-tag t) - (mapcar (function (lambda (x) (set x -100))) math-cache-list) + (mapc (function (lambda (x) (set x -100))) math-cache-list) (unless inhibit-msg (message "All internal calculator caches have been reset")))) diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index 3724490169a..839bac77581 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el @@ -54,7 +54,7 @@ ( ft "12 in" "Foot" ) ( yd "3 ft" "Yard" ) ( mi "5280 ft" "Mile" ) - ( au "149597870691. m" "Astronomical Unit" ) + ( au "149597870691. m" "Astronomical Unit" ) ;; (approx) NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html) ( lyr "c yr" "Light Year" ) ( pc "3.0856775854e16 m" "Parsec" ) ;; (approx) ESUWM @@ -91,7 +91,7 @@ ( tbsp "3 tsp" "Tablespoon" ) ;; ESUWM defines a US gallon as 231 in^3. ;; That gives the following exact value for tsp. - ( tsp "492892159375*10^(-11) ml" "Teaspoon" ) + ( tsp "492892159375*10^(-11) ml" "Teaspoon" ) ( vol "tsp+tbsp+ozfl+cup+pt+qt+gal" "Gallons + ... + teaspoons" ) ( galC "galUK" "Canadian Gallon" ) ( galUK "454609*10^(-5) L" "UK Gallon" ) ;; NIST @@ -342,13 +342,13 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") If EXPR is nil, return nil." (if expr (let ((cexpr (math-compose-expr expr 0))) - (replace-regexp-in-string + (replace-regexp-in-string " / " "/" (if (stringp cexpr) cexpr (math-composition-to-string cexpr)))))) -(defvar math-default-units-table +(defvar math-default-units-table (make-hash-table :test 'equal) "A table storing previously converted units.") @@ -356,7 +356,7 @@ If EXPR is nil, return nil." "Get default units to use when converting the units in EXPR." (let* ((units (math-get-units expr)) (standard-units (math-get-standard-units expr)) - (default-units (gethash + (default-units (gethash standard-units math-default-units-table))) (if (equal units (car default-units)) @@ -403,7 +403,7 @@ If EXPR is nil, return nil." (setq expr (math-mul expr uold)))) (unless new-units (setq defunits (math-get-default-units expr)) - (setq new-units + (setq new-units (read-string (concat (if uoldname (concat "Old units: " @@ -412,11 +412,11 @@ If EXPR is nil, return nil." "New units") (if defunits (concat - " (default: " + " (default " defunits "): ") ": ")))) - + (if (and (string= new-units "") defunits) @@ -476,7 +476,7 @@ If EXPR is nil, return nil." (setq defunits (math-get-default-units expr)) (setq unew (or new-units (math-read-expr - (read-string + (read-string (concat (if uoldname (concat "Old temperature units: " @@ -484,7 +484,7 @@ If EXPR is nil, return nil." ", new units") "New temperature units") (if defunits - (concat " (default: " + (concat " (default " defunits "): ") ": ")))))) @@ -507,7 +507,7 @@ If EXPR is nil, return nil." (calc-enter-result 1 "rmun" (math-simplify-units (math-extract-units (calc-top-n 1)))))) -;; The variables calc-num-units and calc-den-units are local to +;; The variables calc-num-units and calc-den-units are local to ;; calc-explain-units, but are used by calc-explain-units-rec, ;; which is called by calc-explain-units. (defvar calc-num-units) @@ -752,7 +752,7 @@ If EXPR is nil, return nil." (list (cons (car x) 1)))))) combined-units)) (let ((math-units-table tab)) - (mapcar 'math-find-base-units tab)) + (mapc 'math-find-base-units tab)) (message "Building units table...done") (setq math-units-table tab)))) @@ -794,7 +794,7 @@ If EXPR is nil, return nil." (old (assq (car (car ulist)) math-fbu-base))) (if old (setcdr old (+ (cdr old) p)) - (setq math-fbu-base + (setq math-fbu-base (cons (cons (car (car ulist)) p) math-fbu-base)))) (setq ulist (cdr ulist))))) ((math-scalarp expr)) @@ -988,8 +988,8 @@ If EXPR is nil, return nil." (if (equal (nth 4 math-fcu-u) (nth 4 u2)) (cons expr pow)))))) -;; The variables math-cu-new-units and math-cu-pure are local to -;; math-convert-units, but are used by math-convert-units-rec, +;; The variables math-cu-new-units and math-cu-pure are local to +;; math-convert-units, but are used by math-convert-units-rec, ;; which is called by math-convert-units. (defvar math-cu-new-units) (defvar math-cu-pure) @@ -1001,7 +1001,7 @@ If EXPR is nil, return nil." (if (eq (car-safe (nth 1 unew)) '+) (setq math-cu-new-units (nth 1 unew))))) (math-with-extra-prec 2 - (let ((compat (and (not math-cu-pure) + (let ((compat (and (not math-cu-pure) (math-find-compatible-unit expr math-cu-new-units))) (math-cu-unit-list nil) (math-combining-units nil)) @@ -1028,7 +1028,7 @@ If EXPR is nil, return nil." (defun math-convert-units-rec (expr) (if (math-units-in-expr-p expr nil) - (math-apply-units (math-to-standard-units + (math-apply-units (math-to-standard-units (list '/ expr math-cu-new-units) nil) math-cu-new-units math-cu-unit-list math-cu-pure) (if (Math-primp expr) @@ -1093,7 +1093,7 @@ If EXPR is nil, return nil." (calc-record-why "*Inconsistent units" math-simplify-expr) math-simplify-expr) (list '* (math-add (math-remove-units (nth 1 math-simplify-expr)) - (if (eq (car math-simplify-expr) '-) + (if (eq (car math-simplify-expr) '-) (math-neg ratio) ratio)) units))))) @@ -1187,7 +1187,7 @@ If EXPR is nil, return nil." (math-simplify-units-divisor np (cdr (cdr math-simplify-expr))) (if (eq math-try-cancel-units 0) (let* ((math-simplifying-units nil) - (base (math-simplify + (base (math-simplify (math-to-standard-units math-simplify-expr nil)))) (if (Math-numberp base) (setq math-simplify-expr base)))) @@ -1243,11 +1243,11 @@ If EXPR is nil, return nil." (math-realp (nth 2 math-simplify-expr)) (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) (list (car (nth 1 math-simplify-expr)) - (list '^ (nth 1 (nth 1 math-simplify-expr)) + (list '^ (nth 1 (nth 1 math-simplify-expr)) (nth 2 math-simplify-expr)) - (list '^ (nth 2 (nth 1 math-simplify-expr)) + (list '^ (nth 2 (nth 1 math-simplify-expr)) (nth 2 math-simplify-expr))) - (math-simplify-units-pow (nth 1 math-simplify-expr) + (math-simplify-units-pow (nth 1 math-simplify-expr) (nth 2 math-simplify-expr))))) (math-defsimplify calcFunc-sqrt diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 8e416293a45..913b02e003f 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -213,7 +213,7 @@ :group 'applications) ;;;###autoload -(defcustom calc-settings-file +(defcustom calc-settings-file (convert-standard-filename "~/.calc.el") "*File in which to record permanent settings." :group 'calc @@ -233,10 +233,10 @@ (texinfo-mode . calc-normal-language)) "*Alist of major modes with appropriate Calc languages." :group 'calc - :type '(alist :key-type (symbol :tag "Major mode") + :type '(alist :key-type (symbol :tag "Major mode") :value-type (symbol :tag "Calc language"))) -(defcustom calc-embedded-announce-formula +(defcustom calc-embedded-announce-formula "%Embed\n\\(% .*\n\\)*" "*A regular expression which is sure to be followed by a calc-embedded formula." :group 'calc @@ -259,13 +259,13 @@ :type '(alist :key-type (symbol :tag "Major mode") :value-type (regexp :tag "Regexp to announce formula"))) -(defcustom calc-embedded-open-formula +(defcustom calc-embedded-open-formula "\\`\\|^\n\\|\\$\\$?\\|\\\\\\[\\|^\\\\begin[^{].*\n\\|^\\\\begin{.*[^x]}.*\n\\|^@.*\n\\|^\\.EQ.*\n\\|\\\\(\\|^%\n\\|^\\.\\\\\"\n" "*A regular expression for the opening delimiter of a formula used by calc-embedded." :group 'calc :type '(regexp)) -(defcustom calc-embedded-close-formula +(defcustom calc-embedded-close-formula "\\'\\|\n$\\|\\$\\$?\\|\\\\]\\|^\\\\end[^{].*\n\\|^\\\\end{.*[^x]}.*\n\\|^@.*\n\\|^\\.EN.*\n\\|\\\\)\\|\n%\n\\|^\\.\\\\\"\n" "*A regular expression for the closing delimiter of a formula used by calc-embedded." :group 'calc @@ -279,13 +279,13 @@ :value-type (list (regexp :tag "Opening formula delimiter") (regexp :tag "Closing formula delimiter")))) -(defcustom calc-embedded-open-word +(defcustom calc-embedded-open-word "^\\|[^-+0-9.eE]" "*A regular expression for the opening delimiter of a formula used by calc-embedded-word." :group 'calc :type '(regexp)) -(defcustom calc-embedded-close-word +(defcustom calc-embedded-close-word "$\\|[^-+0-9.eE]" "*A regular expression for the closing delimiter of a formula used by calc-embedded-word." :group 'calc @@ -299,7 +299,7 @@ :value-type (list (regexp :tag "Opening word delimiter") (regexp :tag "Closing word delimiter")))) -(defcustom calc-embedded-open-plain +(defcustom calc-embedded-open-plain "%%% " "*A string which is the opening delimiter for a \"plain\" formula. If calc-show-plain mode is enabled, this is inserted at the front of @@ -307,7 +307,7 @@ each formula." :group 'calc :type '(string)) -(defcustom calc-embedded-close-plain +(defcustom calc-embedded-close-plain " %%%\n" "*A string which is the closing delimiter for a \"plain\" formula. See calc-embedded-open-plain." @@ -332,13 +332,13 @@ See calc-embedded-open-plain." :value-type (list (string :tag "Opening \"plain\" delimiter") (string :tag "Closing \"plain\" delimiter")))) -(defcustom calc-embedded-open-new-formula +(defcustom calc-embedded-open-new-formula "\n\n" "*A string which is inserted at front of formula by calc-embedded-new-formula." :group 'calc :type '(string)) -(defcustom calc-embedded-close-new-formula +(defcustom calc-embedded-close-new-formula "\n\n" "*A string which is inserted at end of formula by calc-embedded-new-formula." :group 'calc @@ -352,14 +352,14 @@ See calc-embedded-open-plain." :value-type (list (string :tag "Opening new formula delimiter") (string :tag "Closing new formula delimiter")))) -(defcustom calc-embedded-open-mode +(defcustom calc-embedded-open-mode "% " "*A string which should precede calc-embedded mode annotations. This is not required to be present for user-written mode annotations." :group 'calc :type '(string)) -(defcustom calc-embedded-close-mode +(defcustom calc-embedded-close-mode "\n" "*A string which should follow calc-embedded mode annotations. This is not required to be present for user-written mode annotations." @@ -384,19 +384,19 @@ This is not required to be present for user-written mode annotations." :value-type (list (string :tag "Opening annotation delimiter") (string :tag "Closing annotation delimiter")))) -(defcustom calc-gnuplot-name +(defcustom calc-gnuplot-name "gnuplot" "*Name of GNUPLOT program, for calc-graph features." :group 'calc :type '(string)) -(defcustom calc-gnuplot-plot-command +(defcustom calc-gnuplot-plot-command nil "*Name of command for displaying GNUPLOT output; %s = file name to print." :group 'calc :type '(choice (string) (sexp))) -(defcustom calc-gnuplot-print-command +(defcustom calc-gnuplot-print-command "lp %s" "*Name of command for printing GNUPLOT output; %s = file name to print." :group 'calc @@ -520,7 +520,7 @@ This is used only when calc-group-digits mode is on.") (defcalcmodevar calc-point-char "." "The character (in the form of a string) to be used as a decimal point.") - + (defcalcmodevar calc-frac-format '(":" nil) "Format of displayed fractions; a string of one or two of \":\" or \"/\".") @@ -710,9 +710,9 @@ If nil, selections displayed but ignored.") "YYddd< hh:mm:ss>")) (defcalcmodevar calc-autorange-units nil) - + (defcalcmodevar calc-was-keypad-mode nil) - + (defcalcmodevar calc-full-mode nil) (defcalcmodevar calc-user-parse-tables nil) @@ -722,7 +722,7 @@ If nil, selections displayed but ignored.") (defcalcmodevar calc-gnuplot-default-output "STDOUT") (defcalcmodevar calc-gnuplot-print-device "postscript") - + (defcalcmodevar calc-gnuplot-print-output "auto") (defcalcmodevar calc-gnuplot-geometry nil) @@ -730,7 +730,7 @@ If nil, selections displayed but ignored.") (defcalcmodevar calc-graph-default-resolution 15) (defcalcmodevar calc-graph-default-resolution-3d 5) - + (defcalcmodevar calc-invocation-macro nil) (defcalcmodevar calc-show-banner t @@ -926,8 +926,8 @@ If nil, selections displayed but ignored.") (defvar var-gamma '(special-const (math-gamma-const))) (defvar var-Modes '(special-const (math-get-modes-vec))) -(mapcar (lambda (v) (or (boundp v) (set v nil))) - calc-local-var-list) +(mapc (lambda (v) (or (boundp v) (set v nil))) + calc-local-var-list) (defvar calc-mode-map (let ((map (make-keymap))) @@ -983,89 +983,89 @@ If nil, selections displayed but ignored.") (if (eq (aref cmap i) 'undefined) 'undefined 'calcDigit-nondigit)) (setq i (1+ i))))) - (mapcar (lambda (x) (define-key map (char-to-string x) 'calcDigit-key)) - "_0123456789.e+-:n#@oh'\"mspM") - (mapcar (lambda (x) (define-key map (char-to-string x) 'calcDigit-letter)) + (mapc (lambda (x) (define-key map (char-to-string x) 'calcDigit-key)) + "_0123456789.e+-:n#@oh'\"mspM") + (mapc (lambda (x) (define-key map (char-to-string x) 'calcDigit-letter)) "abcdfgijklqrtuvwxyzABCDEFGHIJKLNOPQRSTUVWXYZ") (define-key map "'" 'calcDigit-algebraic) (define-key map "`" 'calcDigit-edit) (define-key map "\C-g" 'abort-recursive-edit) map)) -(mapcar (lambda (x) - (condition-case err - (progn - (define-key calc-digit-map x 'calcDigit-backspace) - (define-key calc-mode-map x 'calc-pop) - (define-key calc-mode-map - (if (vectorp x) - (if calc-emacs-type-lucid - (if (= (length x) 1) - (vector (if (consp (aref x 0)) - (cons 'meta (aref x 0)) - (list 'meta (aref x 0)))) - "\e\C-d") - (vconcat "\e" x)) - (concat "\e" x)) - 'calc-pop-above)) - (error nil))) - (if calc-scan-for-dels - (append (where-is-internal 'delete-backward-char global-map) - (where-is-internal 'backward-delete-char global-map) - '("\C-d")) - '("\177" "\C-d"))) +(mapc (lambda (x) + (condition-case err + (progn + (define-key calc-digit-map x 'calcDigit-backspace) + (define-key calc-mode-map x 'calc-pop) + (define-key calc-mode-map + (if (vectorp x) + (if calc-emacs-type-lucid + (if (= (length x) 1) + (vector (if (consp (aref x 0)) + (cons 'meta (aref x 0)) + (list 'meta (aref x 0)))) + "\e\C-d") + (vconcat "\e" x)) + (concat "\e" x)) + 'calc-pop-above)) + (error nil))) + (if calc-scan-for-dels + (append (where-is-internal 'delete-backward-char global-map) + (where-is-internal 'backward-delete-char global-map) + '("\C-d")) + '("\177" "\C-d"))) (defvar calc-dispatch-map (let ((map (make-keymap))) - (mapcar (lambda (x) - (define-key map (char-to-string (car x)) (cdr x)) - (when (string-match "abcdefhijklnopqrstuwxyz" - (char-to-string (car x))) - (define-key map (char-to-string (- (car x) ?a -1)) (cdr x))) - (define-key map (format "\e%c" (car x)) (cdr x))) - '( ( ?a . calc-embedded-activate ) - ( ?b . calc-big-or-small ) - ( ?c . calc ) - ( ?d . calc-embedded-duplicate ) - ( ?e . calc-embedded ) - ( ?f . calc-embedded-new-formula ) - ( ?g . calc-grab-region ) - ( ?h . calc-dispatch-help ) - ( ?i . calc-info ) - ( ?j . calc-embedded-select ) - ( ?k . calc-keypad ) - ( ?l . calc-load-everything ) - ( ?m . read-kbd-macro ) - ( ?n . calc-embedded-next ) - ( ?o . calc-other-window ) - ( ?p . calc-embedded-previous ) - ( ?q . quick-calc ) - ( ?r . calc-grab-rectangle ) - ( ?s . calc-info-summary ) - ( ?t . calc-tutorial ) - ( ?u . calc-embedded-update-formula ) - ( ?w . calc-embedded-word ) - ( ?x . calc-quit ) - ( ?y . calc-copy-to-buffer ) - ( ?z . calc-user-invocation ) - ( ?\' . calc-embedded-new-formula ) - ( ?\` . calc-embedded-edit ) - ( ?: . calc-grab-sum-down ) - ( ?_ . calc-grab-sum-across ) - ( ?0 . calc-reset ) - ( ?? . calc-dispatch-help ) - ( ?# . calc-same-interface ) - ( ?& . calc-same-interface ) - ( ?\\ . calc-same-interface ) - ( ?= . calc-same-interface ) - ( ?* . calc-same-interface ) - ( ?/ . calc-same-interface ) - ( ?+ . calc-same-interface ) - ( ?- . calc-same-interface ) )) + (mapc (lambda (x) + (define-key map (char-to-string (car x)) (cdr x)) + (when (string-match "abcdefhijklnopqrstuwxyz" + (char-to-string (car x))) + (define-key map (char-to-string (- (car x) ?a -1)) (cdr x))) + (define-key map (format "\e%c" (car x)) (cdr x))) + '( ( ?a . calc-embedded-activate ) + ( ?b . calc-big-or-small ) + ( ?c . calc ) + ( ?d . calc-embedded-duplicate ) + ( ?e . calc-embedded ) + ( ?f . calc-embedded-new-formula ) + ( ?g . calc-grab-region ) + ( ?h . calc-dispatch-help ) + ( ?i . calc-info ) + ( ?j . calc-embedded-select ) + ( ?k . calc-keypad ) + ( ?l . calc-load-everything ) + ( ?m . read-kbd-macro ) + ( ?n . calc-embedded-next ) + ( ?o . calc-other-window ) + ( ?p . calc-embedded-previous ) + ( ?q . quick-calc ) + ( ?r . calc-grab-rectangle ) + ( ?s . calc-info-summary ) + ( ?t . calc-tutorial ) + ( ?u . calc-embedded-update-formula ) + ( ?w . calc-embedded-word ) + ( ?x . calc-quit ) + ( ?y . calc-copy-to-buffer ) + ( ?z . calc-user-invocation ) + ( ?\' . calc-embedded-new-formula ) + ( ?\` . calc-embedded-edit ) + ( ?: . calc-grab-sum-down ) + ( ?_ . calc-grab-sum-across ) + ( ?0 . calc-reset ) + ( ?? . calc-dispatch-help ) + ( ?# . calc-same-interface ) + ( ?& . calc-same-interface ) + ( ?\\ . calc-same-interface ) + ( ?= . calc-same-interface ) + ( ?* . calc-same-interface ) + ( ?/ . calc-same-interface ) + ( ?+ . calc-same-interface ) + ( ?- . calc-same-interface ) )) map)) ;;;; (Autoloads here) -(mapcar +(mapc (lambda (x) (dolist (func (cdr x)) (autoload func (car x)))) '( @@ -1077,7 +1077,7 @@ If nil, selections displayed but ignored.") ("calc-embed" calc-do-embedded-activate) - ("calc-misc" + ("calc-misc" calc-do-handle-whys calc-do-refresh calc-num-prefix-name calc-record-list calc-record-why calc-report-bug calc-roll-down-stack calc-roll-up-stack calc-temp-minibuffer-message calcFunc-floor @@ -1087,7 +1087,7 @@ If nil, selections displayed but ignored.") math-negp math-posp math-pow math-read-radix-digit math-reject-arg math-trunc math-zerop))) -(mapcar +(mapc (lambda (x) (dolist (cmd (cdr x)) (autoload cmd (car x) nil t))) '( @@ -1095,7 +1095,7 @@ If nil, selections displayed but ignored.") calcDigit-algebraic calcDigit-edit) ("calc-misc" another-calc calc-big-or-small calc-dispatch-help - calc-help calc-info calc-info-goto-node calc-info-summary calc-inv + calc-help calc-info calc-info-goto-node calc-info-summary calc-inv calc-last-args-stub calc-missing-key calc-mod calc-other-window calc-over calc-percent calc-pop-above calc-power calc-roll-down calc-roll-up @@ -1193,12 +1193,12 @@ Notations: 3.14e6 3.14 * 10^6 \\{calc-mode-map} " (interactive) - (mapcar (function - (lambda (v) (set-default v (symbol-value v)))) calc-local-var-list) + (mapc (function + (lambda (v) (set-default v (symbol-value v)))) calc-local-var-list) (kill-all-local-variables) (use-local-map (if (eq calc-algebraic-mode 'total) (progn (require 'calc-ext) calc-alg-map) calc-mode-map)) - (mapcar (function (lambda (v) (make-local-variable v))) calc-local-var-list) + (mapc (function (lambda (v) (make-local-variable v))) calc-local-var-list) (make-local-variable 'overlay-arrow-position) (make-local-variable 'overlay-arrow-string) (add-hook 'change-major-mode-hook 'font-lock-defontify nil t) @@ -1375,8 +1375,8 @@ commands given here will actually operate on the *Calculator* stack." (calc-create-buffer)) (run-hooks 'calc-end-hook) (setq calc-undo-list nil calc-redo-list nil) - (mapcar (function (lambda (v) (set-default v (symbol-value v)))) - calc-local-var-list) + (mapc (function (lambda (v) (set-default v (symbol-value v)))) + calc-local-var-list) (let ((buf (current-buffer)) (win (get-buffer-window (current-buffer))) (kbuf (get-buffer "*Calc Keypad*"))) @@ -2284,7 +2284,7 @@ See calc-keypad for details." -(defconst math-bignum-digit-length +(defconst math-bignum-digit-length (truncate (/ (log10 (/ most-positive-fixnum 2)) 2)) "The length of a \"digit\" in Calc bignums. If a big integer is of the form (bigpos N0 N1 ...), this is the @@ -2292,11 +2292,11 @@ length of the allowable Emacs integers N0, N1,... The value of 2*10^(2*MATH-BIGNUM-DIGIT-LENGTH) must be less than the largest Emacs integer.") -(defconst math-bignum-digit-size +(defconst math-bignum-digit-size (expt 10 math-bignum-digit-length) "An upper bound for the size of the \"digit\"s in Calc bignums.") -(defconst math-small-integer-size +(defconst math-small-integer-size (expt math-bignum-digit-size 2) "An upper bound for the size of \"small integer\"s in Calc.") @@ -2307,16 +2307,16 @@ largest Emacs integer.") ;;; following forms: ;;; ;;; integer An integer. For normalized numbers, this format -;;; is used only for +;;; is used only for ;;; negative math-small-integer-size + 1 to ;;; math-small-integer-size - 1 ;;; -;;; (bigpos N0 N1 N2 ...) A big positive integer, -;;; N0 + N1*math-bignum-digit-size +;;; (bigpos N0 N1 N2 ...) A big positive integer, +;;; N0 + N1*math-bignum-digit-size ;;; + N2*(math-bignum-digit-size)^2 ... -;;; (bigneg N0 N1 N2 ...) A big negative integer, +;;; (bigneg N0 N1 N2 ...) A big negative integer, ;;; - N0 - N1*math-bignum-digit-size ... -;;; Each digit N is in the range +;;; Each digit N is in the range ;;; 0 ... math-bignum-digit-size -1. ;;; Normalized, always at least three N present, ;;; and the most significant N is nonzero. @@ -2407,14 +2407,14 @@ largest Emacs integer.") (cond ((not (consp math-normalize-a)) (if (integerp math-normalize-a) - (if (or (>= math-normalize-a math-small-integer-size) + (if (or (>= math-normalize-a math-small-integer-size) (<= math-normalize-a (- math-small-integer-size))) (math-bignum math-normalize-a) math-normalize-a) math-normalize-a)) ((eq (car math-normalize-a) 'bigpos) (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) - (let* ((last (setq math-normalize-a + (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a))) (digs math-normalize-a)) (while (setq digs (cdr digs)) (or (eq (car digs) 0) (setq last digs))) @@ -2422,14 +2422,14 @@ largest Emacs integer.") (if (cdr (cdr (cdr math-normalize-a))) math-normalize-a (cond - ((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a) - (* (nth 2 math-normalize-a) + ((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a) + (* (nth 2 math-normalize-a) math-bignum-digit-size))) ((cdr math-normalize-a) (nth 1 math-normalize-a)) (t 0)))) ((eq (car math-normalize-a) 'bigneg) (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) - (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a))) + (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a))) (digs math-normalize-a)) (while (setq digs (cdr digs)) (or (eq (car digs) 0) (setq last digs))) @@ -2437,21 +2437,21 @@ largest Emacs integer.") (if (cdr (cdr (cdr math-normalize-a))) math-normalize-a (cond - ((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a) - (* (nth 2 math-normalize-a) + ((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a) + (* (nth 2 math-normalize-a) math-bignum-digit-size)))) ((cdr math-normalize-a) (- (nth 1 math-normalize-a))) (t 0)))) ((eq (car math-normalize-a) 'float) - (math-make-float (math-normalize (nth 1 math-normalize-a)) + (math-make-float (math-normalize (nth 1 math-normalize-a)) (nth 2 math-normalize-a))) - ((or (memq (car math-normalize-a) + ((or (memq (car math-normalize-a) '(frac cplx polar hms date mod sdev intv vec var quote special-const calcFunc-if calcFunc-lambda calcFunc-quote calcFunc-condition calcFunc-evalto)) (integerp (car math-normalize-a)) - (and (consp (car math-normalize-a)) + (and (consp (car math-normalize-a)) (not (eq (car (car math-normalize-a)) 'lambda)))) (require 'calc-ext) (math-normalize-fancy math-normalize-a)) @@ -2461,7 +2461,7 @@ largest Emacs integer.") (math-normalize-nonstandard)) (let ((args (mapcar 'math-normalize (cdr math-normalize-a)))) (or (condition-case err - (let ((func + (let ((func (assq (car math-normalize-a) '( ( + . math-add ) ( - . math-sub ) ( * . math-mul ) @@ -2477,7 +2477,7 @@ largest Emacs integer.") (require 'calc-ext) (math-recompile-eval-rules))) (and (or math-eval-rules-cache-other - (assq (car math-normalize-a) + (assq (car math-normalize-a) math-eval-rules-cache)) (math-apply-rewrites (cons (car math-normalize-a) args) @@ -2496,12 +2496,12 @@ largest Emacs integer.") (cons (car math-normalize-a) args)) nil) (wrong-type-argument - (or calc-next-why + (or calc-next-why (calc-record-why "Wrong type of argument" (cons (car math-normalize-a) args))) nil) (args-out-of-range - (calc-record-why "*Argument out of range" + (calc-record-why "*Argument out of range" (cons (car math-normalize-a) args)) nil) (inexact-result @@ -2559,7 +2559,7 @@ largest Emacs integer.") (defun math-bignum-big (a) ; [L s] (if (= a 0) nil - (cons (% a math-bignum-digit-size) + (cons (% a math-bignum-digit-size) (math-bignum-big (/ a math-bignum-digit-size))))) @@ -2595,7 +2595,7 @@ largest Emacs integer.") (defun math-div10-bignum (a) ; [l l] (if (cdr a) - (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) + (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) (expt 10 (1- math-bignum-digit-length)))) (math-div10-bignum (cdr a))) (list (/ (car a) 10)))) @@ -2649,10 +2649,10 @@ largest Emacs integer.") (if (consp a) (cons (car a) (math-scale-left-bignum (cdr a) n)) (if (>= n math-bignum-digit-length) - (if (or (>= a math-bignum-digit-size) + (if (or (>= a math-bignum-digit-size) (<= a (- math-bignum-digit-size))) (math-scale-left (math-bignum a) n) - (math-scale-left (* a math-bignum-digit-size) + (math-scale-left (* a math-bignum-digit-size) (- n math-bignum-digit-length))) (let ((sz (expt 10 (- (* 2 math-bignum-digit-length) n)))) (if (or (>= a sz) (<= a (- sz))) @@ -2662,7 +2662,7 @@ largest Emacs integer.") (defun math-scale-left-bignum (a n) (if (>= n math-bignum-digit-length) (while (>= (setq a (cons 0 a) - n (- n math-bignum-digit-length)) + n (- n math-bignum-digit-length)) math-bignum-digit-length))) (if (> n 0) (math-mul-bignum-digit a (expt 10 n) 0) @@ -2679,7 +2679,7 @@ largest Emacs integer.") (- (math-scale-right (- a) n))) (if (>= n math-bignum-digit-length) (while (and (> (setq a (/ a math-bignum-digit-size)) 0) - (>= (setq n (- n math-bignum-digit-length)) + (>= (setq n (- n math-bignum-digit-length)) math-bignum-digit-length)))) (if (> n 0) (/ a (expt 10 n)) @@ -2701,12 +2701,12 @@ largest Emacs integer.") (math-normalize (cons (car a) (let ((val (if (< n (- math-bignum-digit-length)) - (math-scale-right-bignum - (cdr a) + (math-scale-right-bignum + (cdr a) (- (- math-bignum-digit-length) n)) (if (< n 0) - (math-mul-bignum-digit - (cdr a) + (math-mul-bignum-digit + (cdr a) (expt 10 (+ math-bignum-digit-length n)) 0) (cdr a))))) ; n = -math-bignum-digit-length (if (and val (>= (car val) (/ math-bignum-digit-size 2))) @@ -2779,7 +2779,7 @@ largest Emacs integer.") (let* ((a (copy-sequence a)) (aa a) (carry nil) sum) (while (and aa b) (if carry - (if (< (setq sum (+ (car aa) (car b))) + (if (< (setq sum (+ (car aa) (car b))) (1- math-bignum-digit-size)) (progn (setcar aa (1+ sum)) @@ -2895,7 +2895,7 @@ largest Emacs integer.") (defun math-mul (a b) (or (and (not (consp a)) (not (consp b)) - (< a math-bignum-digit-size) (> a (- math-bignum-digit-size)) + (< a math-bignum-digit-size) (> a (- math-bignum-digit-size)) (< b math-bignum-digit-size) (> b (- math-bignum-digit-size)) (* a b)) (and (Math-zerop a) (not (eq (car-safe b) 'mod)) @@ -2982,8 +2982,8 @@ largest Emacs integer.") (and (= d 1) a) (let* ((a (copy-sequence a)) (aa a) prod) (while (progn - (setcar aa - (% (setq prod (+ (* (car aa) d) c)) + (setcar aa + (% (setq prod (+ (* (car aa) d) c)) math-bignum-digit-size)) (cdr aa)) (setq aa (cdr aa) @@ -3076,7 +3076,7 @@ largest Emacs integer.") (cdr res2))))) (defun math-div-bignum-part (a b blen) ; a < b*math-bignum-digit-size [D.l l L] - (let* ((num (+ (* (or (nth blen a) 0) math-bignum-digit-size) + (let* ((num (+ (* (or (nth blen a) 0) math-bignum-digit-size) (or (nth (1- blen) a) 0))) (den (nth (1- blen) b)) (guess (min (/ num den) (1- math-bignum-digit-size)))) @@ -3390,14 +3390,14 @@ largest Emacs integer.") (if a (let ((s "")) (while (cdr (cdr a)) - (setq s (concat - (format - (concat "%0" - (number-to-string (* 2 math-bignum-digit-length)) + (setq s (concat + (format + (concat "%0" + (number-to-string (* 2 math-bignum-digit-length)) "d") (+ (* (nth 1 a) math-bignum-digit-size) (car a))) s) a (cdr (cdr a)))) - (concat (int-to-string + (concat (int-to-string (+ (* (or (nth 1 a) 0) math-bignum-digit-size) (car a))) s)) "0")) diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index e0d1c64875e..dae539b3436 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -143,19 +143,19 @@ Defaults to today's date if DATE is not given." (year (int-to-string y))) (mapconcat 'eval calendar-date-display-form "")))) -(defun calendar-print-bahai-date () +(defun calendar-bahai-print-date () "Show the Bahá'à calendar equivalent of the selected date." (interactive) (message "Bahá'à date: %s" (calendar-bahai-date-string (calendar-cursor-to-date t)))) -(defun calendar-goto-bahai-date (date &optional noecho) +(defun calendar-bahai-goto-date (date &optional noecho) "Move cursor to Bahá'à date DATE. Echo Bahá'à date unless NOECHO is t." (interactive (calendar-bahai-prompt-for-date)) (calendar-goto-date (calendar-gregorian-from-absolute (calendar-absolute-from-bahai date))) - (or noecho (calendar-print-bahai-date))) + (or noecho (calendar-bahai-print-date))) (defun calendar-bahai-prompt-for-date () "Ask for a Bahá'à date." @@ -204,7 +204,7 @@ nil if it is not visible in the current calendar window." (if (calendar-date-is-visible-p date) (list (list date string)))))))) -(defun diary-list-bahai-entries () +(defun diary-bahai-list-entries () "Add any Bahá'à date entries from the diary file to `diary-entries-list'. Bahá'à date diary entries must be prefaced by an `bahai-diary-entry-symbol' (normally a `B'). The same diary date @@ -458,7 +458,7 @@ A value of 0 in any position is a wildcard." (mark-visible-calendar-date (calendar-gregorian-from-absolute date))))))))) -(defun diary-insert-bahai-entry (arg) +(defun diary-bahai-insert-entry (arg) "Insert a diary entry. For the Bahá'à date corresponding to the date indicated by point. Prefix arg will make the entry nonmarking." @@ -512,17 +512,21 @@ Prefix arg will make the entry nonmarking." ;; Backward compatibility. (define-obsolete-function-alias - 'list-bahai-diary-entries 'diary-list-bahai-entries "23.1") + 'list-bahai-diary-entries 'diary-bahai-list-entries "23.1") (define-obsolete-function-alias - 'mark-bahai-diary-entries 'diary-mark-bahai-entries "23.1") + 'mark-bahai-diary-entries 'diary-bahai-mark-entries "23.1") (define-obsolete-function-alias - 'insert-bahai-diary-entry 'diary-insert-bahai-entry "23.1") + 'insert-bahai-diary-entry 'diary-bahai-insert-entry "23.1") (define-obsolete-function-alias - 'insert-monthly-bahai-diary-entry 'diary-insert-bahai-monthly-entry "23.1") + 'insert-monthly-bahai-diary-entry 'diary-bahai-insert-monthly-entry "23.1") (define-obsolete-function-alias - 'insert-yearly-bahai-diary-entry 'diary-insert-bahai-yearly-entry "23.1") + 'insert-yearly-bahai-diary-entry 'diary-bahai-insert-yearly-entry "23.1") (define-obsolete-function-alias 'mark-bahai-calendar-date-pattern 'calendar-bahai-mark-date-pattern "23.1") +(define-obsolete-function-alias + 'calendar-goto-bahai-date 'calendar-bahai-goto-date "23.1") +(define-obsolete-function-alias + 'calendar-print-bahai-date 'calendar-bahai-print-date "23.1") (provide 'cal-bahai) diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index f48d3b25e32..02cc9bfabb2 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -352,11 +352,11 @@ nil if it is not visible in the current calendar window." (list (calendar-gregorian-from-absolute (+ abs-r-h 20)) "Hoshanah Rabbah"))) (output-list - (filter-visible-calendar-holidays mandatory))) + (holiday-filter-visible-calendar mandatory))) (if all-hebrew-calendar-holidays (setq output-list (append - (filter-visible-calendar-holidays optional) + (holiday-filter-visible-calendar optional) output-list))) output-list))) @@ -372,7 +372,7 @@ nil if it is not visible in the current calendar window." (calendar-absolute-from-gregorian (list m (calendar-last-day-of-month m y) y))))) (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y)))) - (filter-visible-calendar-holidays + (holiday-filter-visible-calendar (list (list (calendar-gregorian-from-absolute (1- abs-h)) "Erev Hanukkah") @@ -469,11 +469,11 @@ nil if it is not visible in the current calendar window." (list (calendar-gregorian-from-absolute (+ abs-p 51)) "Shavuot (second day)"))) (output-list - (filter-visible-calendar-holidays mandatory))) + (holiday-filter-visible-calendar mandatory))) (if all-hebrew-calendar-holidays (setq output-list (append - (filter-visible-calendar-holidays optional) + (holiday-filter-visible-calendar optional) output-list))) output-list))) @@ -485,7 +485,7 @@ nil if it is not visible in the current calendar window." (let* ((abs-t-a (calendar-absolute-from-hebrew (list 5 9 (+ displayed-year 3760))))) - (filter-visible-calendar-holidays + (holiday-filter-visible-calendar (list (list (calendar-gregorian-from-absolute (if (= (% abs-t-a 7) 6) (- abs-t-a 20) (- abs-t-a 21))) diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index 1f4e4df736f..47fd4fc4c2a 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el @@ -54,9 +54,9 @@ ["Insert Cyclic" insert-cyclic-diary-entry] ("Insert Baha'i" [" " nil :suffix (calendar-bahai-date-string (calendar-cursor-to-date))] - ["One time" insert-bahai-diary-entry] - ["Monthly" insert-monthly-bahai-diary-entry] - ["Yearly" insert-yearly-bahai-diary-entry]) + ["One time" diary-bahai-insert-entry] + ["Monthly" diary-bahai-insert-monthly-entry] + ["Yearly" diary-bahai-insert-yearly-entry]) ("Insert Islamic" [" " nil :suffix (calendar-islamic-date-string (calendar-cursor-to-date))] ["One time" insert-islamic-diary-entry] @@ -87,7 +87,7 @@ ["For Cursor Date -" calendar-cursor-holidays :suffix (calendar-date-string (calendar-cursor-to-date) t t) :visible (calendar-cursor-to-date)] - ["For Window -" list-calendar-holidays + ["For Window -" calendar-list-holidays :suffix (cal-menu-holiday-window-suffix)] ["For Today -" cal-menu-today-holidays :suffix (calendar-date-string (calendar-current-date) t t)] @@ -98,7 +98,7 @@ (push (vector "For Year" `(lambda () (interactive) - (list-holidays (+ displayed-year ,(- i 5)))) + (holiday-list (+ displayed-year ,(- i 5)))) :suffix `(number-to-string (+ displayed-year ,(- i 5)))) l)) (nreverse l)) @@ -122,7 +122,7 @@ ["Astronomical Date" calendar-goto-astro-day-number] ["Hebrew Date" calendar-goto-hebrew-date] ["Persian Date" calendar-goto-persian-date] - ["Baha'i Date" calendar-goto-bahai-date] + ["Baha'i Date" calendar-bahai-goto-date] ["Islamic Date" calendar-goto-islamic-date] ["Julian Date" calendar-goto-julian-date] ["Chinese Date" calendar-goto-chinese-date] @@ -157,19 +157,19 @@ not available." "Display a list of the holidays of the selected date's year." (interactive) (let ((year (extract-calendar-year (calendar-cursor-to-date)))) - (list-holidays year year))) + (holiday-list year year))) (defun cal-menu-list-holidays-following-year () "Display a list of the holidays of the following year." (interactive) (let ((year (1+ (extract-calendar-year (calendar-cursor-to-date))))) - (list-holidays year year))) + (holiday-list year year))) (defun cal-menu-list-holidays-previous-year () "Display a list of the holidays of the previous year." (interactive) (let ((year (1- (extract-calendar-year (calendar-cursor-to-date))))) - (list-holidays year year))) + (holiday-list year year))) (defun calendar-event-to-date (&optional error) "Date of last event. @@ -194,14 +194,14 @@ ERROR is t, otherwise just returns nil." (calendar-cursor-to-date (calendar-current-date)) (calendar-cursor-holidays))) -(autoload 'check-calendar-holidays "holidays") +(autoload 'calendar-check-holidays "holidays") (autoload 'diary-list-entries "diary-lib") (defun calendar-mouse-holidays (&optional event) "Pop up menu of holidays for mouse selected date." (interactive "e") (let* ((date (calendar-event-to-date)) - (l (mapcar 'list (check-calendar-holidays date))) + (l (mapcar 'list (calendar-check-holidays date))) (selection (cal-menu-x-popup-menu event @@ -226,7 +226,7 @@ Any holidays are shown if `holidays-in-diary-buffer' is t." (mapcar (lambda (x) (split-string (cadr x) "\n")) (diary-list-entries date 1 'list-only))) (holidays (if holidays-in-diary-buffer - (check-calendar-holidays date))) + (calendar-check-holidays date))) (title (concat "Diary entries " (if diary (format "from %s " diary) "") "for " @@ -461,8 +461,8 @@ The output is in landscape format, one month to a page." ["Scroll forward" calendar-scroll-left-three-months] ["Scroll backward" calendar-scroll-right-three-months] ["Mark diary entries" mark-diary-entries] - ["List holidays" list-calendar-holidays] - ["Mark holidays" mark-calendar-holidays] + ["List holidays" calendar-list-holidays] + ["Mark holidays" calendar-mark-holidays] ["Unmark" calendar-unmark] ["Lunar phases" calendar-phases-of-moon] ["Show diary" diary-show-all-entries] diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index ea495777f19..c252341526a 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -823,7 +823,7 @@ describes the style of such diary entries." :type 'hook :options '(list-hebrew-diary-entries list-islamic-diary-entries - list-bahai-diary-entries) + diary-bahai-list-entries) :group 'diary) ;;;###autoload @@ -855,7 +855,7 @@ describes the style of such diary entries." :type 'hook :options '(mark-hebrew-diary-entries mark-islamic-diary-entries - mark-bahai-diary-entries) + diary-bahai-mark-entries) :group 'diary) ;;;###autoload @@ -1212,11 +1212,11 @@ of `general-holidays', `local-holidays' `christian-holidays', you can eliminate unwanted categories of holidays. The aforementioned variables control the holiday choices offered -by the function `list-holidays' when it is called interactively. +by the function `holiday-list' when it is called interactively. They also initialize the default value of `calendar-holidays', which is the default list of holidays used by the function -`list-holidays' in the non-interactive case. Note that these +`holiday-list' in the non-interactive case. Note that these variables have no effect on `calendar-holidays' after it has been set (e.g. after the calendar is loaded). In that case, customize `calendar-holidays' directly. @@ -1616,7 +1616,7 @@ the date indicated by the cursor position in the displayed three-month calendar." t) -(autoload 'list-calendar-holidays "holidays" +(autoload 'calendar-list-holidays "holidays" "Create a buffer containing the holidays for the current calendar window. The holidays are those in the list `calendar-notable-days'. Returns t if any holidays are found, nil if not." @@ -1688,7 +1688,7 @@ to be replaced by asterisks to highlight it whenever it is in the window." (diary-window (if diary-buffer (get-buffer-window diary-buffer))) (split-height-threshold (if diary-window 2 1000))) (if view-calendar-holidays-initially - (list-calendar-holidays))) + (calendar-list-holidays))) (run-hooks 'initial-calendar-window-hook)) (autoload 'view-other-diary-entries "diary-lib" @@ -1825,7 +1825,7 @@ Driven by the variable `calendar-date-display-form'.") (autoload 'calendar-islamic-date-string "cal-islam" "String of Islamic date of Gregorian date.") -(autoload 'calendar-goto-bahai-date "cal-bahai" +(autoload 'calendar-bahai-goto-date "cal-bahai" "Move cursor to Baha'i date DATE. Echo Baha'i date unless NOECHO is t." t) @@ -1955,17 +1955,17 @@ to the date indicated by point." to the date indicated by point." t) -(autoload 'insert-bahai-diary-entry "cal-bahai" +(autoload 'diary-bahai-insert-entry "cal-bahai" "Insert a diary entry for the Baha'i date corresponding to the date indicated by point." t) -(autoload 'insert-monthly-bahai-diary-entry "cal-bahai" +(autoload 'diary-bahai-insert-monthly-entry "cal-bahai" "Insert a monthly diary entry for the day of the Baha'i month corresponding to the date indicated by point." t) -(autoload 'insert-yearly-bahai-diary-entry "cal-bahai" +(autoload 'diary-bahai-insert-yearly-entry "cal-bahai" "Insert an annual diary entry for the day of the Baha'i year corresponding to the date indicated by point." t) @@ -2259,7 +2259,7 @@ movement commands will not work correctly." (define-key map "ga" 'calendar-goto-astro-day-number) (define-key map "gh" 'calendar-goto-hebrew-date) (define-key map "gi" 'calendar-goto-islamic-date) - (define-key map "gb" 'calendar-goto-bahai-date) + (define-key map "gb" 'calendar-bahai-goto-date) (define-key map "gC" 'calendar-goto-chinese-date) (define-key map "gk" 'calendar-goto-coptic-date) (define-key map "ge" 'calendar-goto-ethiopic-date) @@ -2284,7 +2284,7 @@ movement commands will not work correctly." (define-key map "." 'calendar-goto-today) (define-key map "o" 'calendar-other-month) (define-key map "q" 'exit-calendar) - (define-key map "a" 'list-calendar-holidays) + (define-key map "a" 'calendar-list-holidays) (define-key map "h" 'calendar-cursor-holidays) (define-key map "x" 'mark-calendar-holidays) (define-key map "u" 'calendar-unmark) @@ -2302,7 +2302,7 @@ movement commands will not work correctly." (define-key map "pa" 'calendar-print-astro-day-number) (define-key map "ph" 'calendar-print-hebrew-date) (define-key map "pi" 'calendar-print-islamic-date) - (define-key map "pb" 'calendar-print-bahai-date) + (define-key map "pb" 'calendar-bahai-print-date) (define-key map "pf" 'calendar-print-french-date) (define-key map "pm" 'calendar-print-mayan-date) (define-key map "po" 'calendar-print-other-dates) @@ -2319,9 +2319,9 @@ movement commands will not work correctly." (define-key map "iid" 'insert-islamic-diary-entry) (define-key map "iim" 'insert-monthly-islamic-diary-entry) (define-key map "iiy" 'insert-yearly-islamic-diary-entry) - (define-key map "iBd" 'insert-bahai-diary-entry) - (define-key map "iBm" 'insert-monthly-bahai-diary-entry) - (define-key map "iBy" 'insert-yearly-bahai-diary-entry) + (define-key map "iBd" 'diary-bahai-insert-entry) + (define-key map "iBm" 'diary-bahai-insert-monthly-entry) + (define-key map "iBy" 'diary-bahai-insert-yearly-entry) (define-key map "?" 'calendar-goto-info-node) (define-key map "Hm" 'cal-html-cursor-month) (define-key map "Hy" 'cal-html-cursor-year) diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 09034ab3a8d..df16595f3c5 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -75,7 +75,7 @@ D-FILE specifies the file to use as the diary file." (let ((diary-file d-file)) (diary-view-entries arg))) -(autoload 'check-calendar-holidays "holidays" +(autoload 'calendar-check-holidays "holidays" "Check the list of holidays for any that occur on DATE. The value returned is a list of strings of relevant holiday descriptions. The holidays are those in the list `calendar-holidays'.") @@ -117,13 +117,13 @@ The holidays are those in the list `calendar-holidays'.") (autoload 'diary-bahai-date "cal-bahai" "Baha'i calendar equivalent of date diary entry.") -(autoload 'list-bahai-diary-entries "cal-bahai" +(autoload 'diary-bahai-list-entries "cal-bahai" "Add any Baha'i date entries from the diary file to `diary-entries-list'.") -(autoload 'mark-bahai-diary-entries "cal-bahai" +(autoload 'diary-bahai-mark-entries "cal-bahai" "Mark days in the calendar window that have Baha'i date diary entries.") -(autoload 'mark-bahai-calendar-date-pattern "cal-bahai" +(autoload 'calendar-bahai-mark-date-pattern "cal-bahai" "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR.") (autoload 'diary-hebrew-date "cal-hebrew" @@ -598,7 +598,7 @@ changing the variable `diary-include-string'." (defun simple-diary-display () "Display the diary buffer if there are any relevant entries or holidays." (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) + (calendar-check-holidays original-date))) (hol-string (format "%s%s%s" date-string (if holiday-list ": " "") @@ -676,7 +676,7 @@ This function is provided for optional use as the `diary-display-hook'." (and (not (cdr diary-entries-list)) (string-equal (car (cdr (car diary-entries-list))) ""))) (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) + (calendar-check-holidays original-date))) (msg (format "No diary entries for %s %s" (concat date-string (if holiday-list ":" "")) (mapconcat 'identity holiday-list "; ")))) diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index a3a12aab2e3..f6134940169 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -107,8 +107,10 @@ This function is suitable for execution in a .emacs file." (calendar-current-date))) (displayed-month (extract-calendar-month date)) (displayed-year (extract-calendar-year date))) - (list-calendar-holidays)))) + (calendar-list-holidays)))) +;; rms: "Emacs commands to display a list of something generally start +;; with `list-'. Please make `list-holidays' the principal name." ;;;###autoload (defun list-holidays (y1 y2 &optional l label) "Display holidays for years Y1 to Y2 (inclusive). @@ -206,19 +208,18 @@ The optional LABEL is used to label the buffer created." (display-buffer holiday-buffer) (message "Computing holidays...done")))) +(defalias 'holiday-list 'list-holidays) -(defun check-calendar-holidays (date) +(defun calendar-check-holidays (date) "Check the list of holidays for any that occur on DATE. The value returned is a list of strings of relevant holiday descriptions. -The holidays are those in the list calendar-holidays." - (let* ((displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date)) - (h (calendar-holiday-list)) - (holiday-list)) - (while h - (if (calendar-date-equal date (car (car h))) - (setq holiday-list (append holiday-list (cdr (car h))))) - (setq h (cdr h))) +The holidays are those in the list `calendar-holidays'." + (let ((displayed-month (extract-calendar-month date)) + (displayed-year (extract-calendar-year date)) + (holiday-list)) + (dolist (h (calendar-holiday-list)) + (if (calendar-date-equal date (car h)) + (setq holiday-list (append holiday-list (cdr h))))) holiday-list)) (defun calendar-cursor-holidays () @@ -227,7 +228,7 @@ The holidays are those in the list calendar-holidays." (message "Checking holidays...") (let* ((date (calendar-cursor-to-date t)) (date-string (calendar-date-string date)) - (holiday-list (check-calendar-holidays date)) + (holiday-list (calendar-check-holidays date)) (holiday-string (mapconcat 'identity holiday-list "; ")) (msg (format "%s: %s" date-string holiday-string))) (if (not holiday-list) @@ -245,21 +246,19 @@ The holidays are those in the list calendar-holidays." (display-buffer holiday-buffer) (message "Checking holidays...done"))))) -(defun mark-calendar-holidays () +(defun calendar-mark-holidays () "Mark notable days in the calendar window." (interactive) (setq mark-holidays-in-calendar t) (message "Marking holidays...") - (let ((holiday-list (calendar-holiday-list))) - (while holiday-list - (mark-visible-calendar-date - (car (car holiday-list)) calendar-holiday-marker) - (setq holiday-list (cdr holiday-list)))) + (dolist (holiday (calendar-holiday-list)) + (mark-visible-calendar-date + (car holiday) calendar-holiday-marker)) (message "Marking holidays...done")) -(defun list-calendar-holidays () +(defun calendar-list-holidays () "Create a buffer containing the holidays for the current calendar window. -The holidays are those in the list calendar-notable-days. Returns t if any +The holidays are those in the list `calendar-notable-days'. Returns t if any holidays are found, nil if not." (interactive) (message "Looking up holidays...") @@ -297,22 +296,20 @@ holidays are found, nil if not." (defun calendar-holiday-list () "Form the list of holidays that occur on dates in the calendar window. -The holidays are those in the list calendar-holidays." - (let ((p calendar-holidays) - (holiday-list)) - (while p +The holidays are those in the list `calendar-holidays'." + (let ((holiday-list ())) + (dolist (p calendar-holidays) (let* ((holidays (if calendar-debug-sexp (let ((stack-trace-on-error t)) - (eval (car p))) + (eval p)) (condition-case nil - (eval (car p)) + (eval p) (error (beep) - (message "Bad holiday list item: %s" (car p)) + (message "Bad holiday list item: %s" p) (sleep-for 2)))))) (if holidays - (setq holiday-list (append holidays holiday-list)))) - (setq p (cdr p))) + (setq holiday-list (append holidays holiday-list))))) (setq holiday-list (sort holiday-list 'calendar-date-compare)))) ;; Below are the functions that calculate the dates of holidays; these @@ -396,16 +393,16 @@ date. If date is nil, or if the date is not visible, there is no holiday." (let ((m displayed-month) (y displayed-year)) (increment-calendar-month m y -1) - (filter-visible-calendar-holidays - (append + (holiday-filter-visible-calendar + (list (let* ((year y) (date (eval sexp)) (string (if date (eval string)))) - (list (list date string))) + (list date string)) (let* ((year (1+ y)) (date (eval sexp)) (string (if date (eval string)))) - (list (list date string))))))) + (list date string)))))) (defun holiday-advent (&optional n string) "Date of Nth day after advent (named STRING), if visible in calendar window. @@ -486,7 +483,7 @@ is non-nil)." (- (calendar-absolute-from-gregorian (list 4 19 displayed-year)) adjusted-epact)) (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))) - (filter-visible-calendar-holidays + (holiday-filter-visible-calendar (list (list (calendar-gregorian-from-absolute (+ abs-easter n)) string)))))) @@ -513,18 +510,26 @@ is non-nil)." (if (calendar-date-is-visible-p nicaean-easter) (list (list nicaean-easter "Pascha (Greek Orthodox Easter)")))))) -(defun filter-visible-calendar-holidays (l) +(defun holiday-filter-visible-calendar (l) "Return a list of all visible holidays of those on L." - (let ((visible) - (p l)) - (while p - (and (car (car p)) - (calendar-date-is-visible-p (car (car p))) - (setq visible (append (list (car p)) visible))) - (setq p (cdr p))) + (let ((visible ())) + (dolist (p l) + (and (car p) + (calendar-date-is-visible-p (car p)) + (push p visible))) visible)) +;; Backward compatibility. +(define-obsolete-function-alias + 'filter-visible-calendar-holidays 'holiday-filter-visible-calendar "23.1") +(define-obsolete-function-alias + 'list-calendar-holidays 'calendar-list-holidays "23.1") +(define-obsolete-function-alias + 'mark-calendar-holidays 'calendar-mark-holidays "23.1") +(define-obsolete-function-alias + 'check-calendar-holidays 'calendar-check-holidays "23.1") + (provide 'holidays) -;;; arch-tag: 48eb3117-75a7-4dbe-8fd9-873c3cbb0d37 +;; arch-tag: 48eb3117-75a7-4dbe-8fd9-873c3cbb0d37 ;;; holidays.el ends here diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 101aaf96e43..881e7490665 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -1531,24 +1531,24 @@ buffer `*icalendar-errors*'." ("%t" STATUS icalendar-import-format-status) ("%u" URL icalendar-import-format-url)))) ;; convert the specifiers in the format string - (mapcar (lambda (i) - (let* ((spec (car i)) - (prop (cadr i)) - (format (car (cddr i))) - (contents (icalendar--get-event-property event prop)) - (formatted-contents "")) - (when (and contents (> (length contents) 0)) - (setq formatted-contents - (icalendar--rris "%s" - (icalendar--convert-string-for-import - contents) - (symbol-value format) - t t))) - (setq string (icalendar--rris spec - formatted-contents - string - t t)))) - conversion-list) + (mapc (lambda (i) + (let* ((spec (car i)) + (prop (cadr i)) + (format (car (cddr i))) + (contents (icalendar--get-event-property event prop)) + (formatted-contents "")) + (when (and contents (> (length contents) 0)) + (setq formatted-contents + (icalendar--rris "%s" + (icalendar--convert-string-for-import + contents) + (symbol-value format) + t t))) + (setq string (icalendar--rris spec + formatted-contents + string + t t)))) + conversion-list) string)) (defun icalendar--convert-ical-to-diary (ical-list diary-file @@ -1637,11 +1637,11 @@ written into the buffer `*icalendar-errors*'." (rdate (icalendar--dmsg "rdate event") (setq diary-string "") - (mapcar (lambda (datestring) - (setq diary-string - (concat diary-string - (format "......")))) - (icalendar--split-value rdate))) + (mapc (lambda (datestring) + (setq diary-string + (concat diary-string + (format "......")))) + (icalendar--split-value rdate))) ;; non-recurring event ;; all-day event ((not (string= start-d end-d)) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index dbebf314798..d04550c187d 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2996,7 +2996,9 @@ in any of these classes." (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) (if origdoc (setq paragraphs (list origdoc))) (unless (eq style 'plain) - (push (concat "This " origtype " is advised.") paragraphs)) + (push (propertize (concat "This " origtype " is advised.") + 'face 'font-lock-warning-face) + paragraphs)) (ad-dolist (class ad-advice-classes) (ad-dolist (advice (ad-get-enabled-advices function class)) (setq advice-docstring diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 0c08e74d70b..4b490621f51 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -72,7 +72,7 @@ files.") ("Geoff Voelker" "voelker") ("Gerd M,Av(Bllmann" "Gerd Moellmann") ("Hallvard B. Furuseth" "Hallvard B Furuseth") - ("Hrvoje Nik,B9(Bi,Bf(B" "Hrvoje Niksic") + ("Hrvoje Nik$,1!!(Bi$,1 '(B" "Hrvoje Niksic") (nil "(afs@hplb.hpl.hp.com)") (nil "<Use-Author-Address-Header@\\[127.1\\]>") (nil "Code Extracted") @@ -81,7 +81,7 @@ files.") ("Jaeyoun Chung" "Jae-youn Chung" "Jae-you Chung" "Chung Jae-youn") ("Jan Dj,Ad(Brv" "Jan D." "Jan Djarv") ("Jay K. Adams" "jka@ece.cmu.edu" "Jay Adams") - ("J,Ai(Br,At(Bme Marant" "J,bi(Br,bt(Bme Marant" "Jerome Marant") + ("J,Ai(Br,At(Bme Marant" "J,Ai(Br,At(Bme Marant" "Jerome Marant") ("Jens-Ulrik Holger Petersen" "Jens-Ulrik Petersen") ("Jeremy Bertram Maitin-Shepard" "Jeremy Maitin-Shepard") ("Johan Bockg,Ae(Brd" "Johan Bockgard") @@ -90,11 +90,11 @@ files.") ("Joseph Arceneaux" "Joe Arceneaux") ("Juan Le,As(Bn Lahoz Garc,Am(Ba" "Juan-Leon Lahoz Garcia") ("K. Shane Hartman" "Shane Hartman") - ("Kai Gro,A_(Bjohann" "Kai Grossjohann" "Kai Gro,b_(Bjohann" + ("Kai Gro,A_(Bjohann" "Kai Grossjohann" "Kai Gro,A_(Bjohann" "Kai.Grossjohann@Cs.Uni-Dortmund.De" "Kai.Grossjohann@Gmx.Net") ("Karl Berry" "K. Berry") - ("K,Aa(Broly L$,1 q(Brentey" "K,Aa(Broly L,Bu(Brentey" "L$,1 q(Brentey K,Aa(Broly") + ("K,Aa(Broly L$,1 q(Brentey" "K,Aa(Broly L$,1 q(Brentey" "L$,1 q(Brentey K,Aa(Broly") ("Kazushi Marukawa" "Kazushi") ("Ken Manheimer" "Kenneth Manheimer") ("Kenichi Handa" "Ken'ichi Handa" "Kenichi HANDA") @@ -113,7 +113,7 @@ files.") ("Mikio Nakajima" "Nakajima Mikio") ("Paul Eggert" "eggert") ("Paul Reilly" "(pmr@legacy.pajato.com)") - ("Pavel Jan,Bm(Bk" "Pavel Jan,Am(Bk Ml." "Pavel Jan,Am(Bk" "Pavel@Janik.Cz") + ("Pavel Jan,Am(Bk" "Pavel Jan,Am(Bk Ml." "Pavel Jan,Am(Bk" "Pavel@Janik.Cz") ("Per Abrahamsen" "Per Abhiddenware") ("Peter S. Galbraith" "Peter Galbraith") ("Peter Runestig" "Peter 'luna' Runestig") @@ -666,8 +666,8 @@ list of their contributions.\n") (erase-buffer) (set-buffer-file-coding-system authors-coding-system) (insert "Unrecognized file entries found:\n\n") - (mapcar (lambda (f) (if (not (string-match "^[A-Za-z]+$" f)) (insert f "\n"))) - (sort authors-invalid-file-names 'string-lessp)) + (mapc (lambda (f) (if (not (string-match "^[A-Za-z]+$" f)) (insert f "\n"))) + (sort authors-invalid-file-names 'string-lessp)) (goto-char (point-min)) (compilation-mode) (message "Errors were found. See buffer %s" (buffer-name)))) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index ffac825acac..b8cf8362386 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -28,345 +28,306 @@ ;;; Commentary: -;; An AVL tree is a nearly-perfect balanced binary tree. A tree -;; consists of two cons cells, the first one holding the tag -;; 'AVL-TREE in the car cell, and the second one having the tree -;; in the car and the compare function in the cdr cell. The tree has -;; a dummy node as its root with the real tree in the left pointer. +;; An AVL tree is a nearly-perfect balanced binary tree. A tree consists of +;; two elements, the root node and the compare function. The actual tree +;; has a dummy node as its root with the real root in the left pointer. ;; ;; Each node of the tree consists of one data element, one left ;; sub-tree and one right sub-tree. Each node also has a balance ;; count, which is the difference in depth of the left and right ;; sub-trees. ;; -;; The "public" functions (prefixed with "avl-tree") are: -;; -create, -p, -compare-function, -empty, -enter, -delete, -;; -member, -map, -first, -last, -copy, -flatten, -size, -clear. +;; The functions with names of the form "avl-tree--" are intended for +;; internal use only. ;;; Code: -;;; ================================================================ -;;; Functions and macros handling an AVL tree node. - -(defmacro avl-tree-node-create (left right data balance) - ;; Create and return an avl-tree node. - `(vector ,left ,right ,data ,balance)) - -(defmacro avl-tree-node-left (node) - ;; Return the left pointer of NODE. - `(aref ,node 0)) - -(defmacro avl-tree-node-right (node) - ;; Return the right pointer of NODE. - `(aref ,node 1)) - -(defmacro avl-tree-node-data (node) - ;; Return the data of NODE. - `(aref ,node 2)) - -(defmacro avl-tree-node-set-left (node newleft) - ;; Set the left pointer of NODE to NEWLEFT. - `(aset ,node 0 ,newleft)) - -(defmacro avl-tree-node-set-right (node newright) - ;; Set the right pointer of NODE to NEWRIGHT. - `(aset ,node 1 ,newright)) - -(defmacro avl-tree-node-set-data (node newdata) - ;; Set the data of NODE to NEWDATA. - `(aset ,node 2 ,newdata)) - -(defmacro avl-tree-node-branch (node branch) +(eval-when-compile (require 'cl)) + +;; ================================================================ +;;; Functions and macros handling an AVL tree node. + +(defstruct (avl-tree--node + ;; We force a representation without tag so it matches the + ;; pre-defstruct representation. Also we use the underlying + ;; representation in the implementation of avl-tree--node-branch. + (:type vector) + (:constructor nil) + (:constructor avl-tree--node-create (left right data balance)) + (:copier nil)) + left right data balance) + +(defalias 'avl-tree--node-branch 'aref + ;; This implementation is efficient but breaks the defstruct abstraction. + ;; An alternative could be + ;; (funcall (aref [avl-tree-left avl-tree-right avl-tree-data] branch) node) "Get value of a branch of a node. NODE is the node, and BRANCH is the branch. -0 for left pointer, 1 for right pointer and 2 for the data.\"" - `(aref ,node ,branch)) - -(defmacro avl-tree-node-set-branch (node branch newval) - "Set value of a branch of a node. - -NODE is the node, and BRANCH is the branch. -0 for left pointer, 1 for the right pointer and 2 for the data. -NEWVAL is new value of the branch.\"" - `(aset ,node ,branch ,newval)) - -(defmacro avl-tree-node-balance (node) - ;; Return the balance field of a node. - `(aref ,node 3)) - -(defmacro avl-tree-node-set-balance (node newbal) - ;; Set the balance field of a node. - `(aset ,node 3 ,newbal)) +0 for left pointer, 1 for right pointer and 2 for the data.\" +\(fn node branch)") +;; The funcall/aref trick doesn't work for the setf method, unless we try +;; and access the underlying setter function, but this wouldn't be +;; portable either. +(defsetf avl-tree--node-branch aset) -;;; ================================================================ -;;; Internal functions for use in the AVL tree package - -(defmacro avl-tree-root (tree) +;; ================================================================ +;;; Internal functions for use in the AVL tree package + +(defstruct (avl-tree- + ;; A tagged list is the pre-defstruct representation. + ;; (:type list) + :named + (:constructor nil) + (:constructor avl-tree-create (cmpfun)) + (:predicate avl-tree-p) + (:copier nil)) + (dummyroot (avl-tree--node-create nil nil nil 0)) + cmpfun) + +(defmacro avl-tree--root (tree) ;; Return the root node for an avl-tree. INTERNAL USE ONLY. - `(avl-tree-node-left (car (cdr ,tree)))) - -(defmacro avl-tree-dummyroot (tree) - ;; Return the dummy node of an avl-tree. INTERNAL USE ONLY. - `(car (cdr ,tree))) - -(defmacro avl-tree-cmpfun (tree) - ;; Return the compare function of AVL tree TREE. INTERNAL USE ONLY. - `(cdr (cdr ,tree))) + `(avl-tree--node-left (avl-tree--dummyroot tree))) +(defsetf avl-tree--root (tree) (node) + `(setf (avl-tree--node-left (avl-tree--dummyroot ,tree)) ,node)) ;; ---------------------------------------------------------------- ;; Deleting data -(defun avl-tree-del-balance1 (node branch) +(defun avl-tree--del-balance1 (node branch) ;; Rebalance a tree and return t if the height of the tree has shrunk. - (let ((br (avl-tree-node-branch node branch)) + (let ((br (avl-tree--node-branch node branch)) p1 b1 p2 b2 result) (cond - ((< (avl-tree-node-balance br) 0) - (avl-tree-node-set-balance br 0) + ((< (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) 0) t) - ((= (avl-tree-node-balance br) 0) - (avl-tree-node-set-balance br +1) + ((= (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) +1) nil) (t ;; Rebalance. - (setq p1 (avl-tree-node-right br) - b1 (avl-tree-node-balance p1)) + (setq p1 (avl-tree--node-right br) + b1 (avl-tree--node-balance p1)) (if (>= b1 0) ;; Single RR rotation. (progn - (avl-tree-node-set-right br (avl-tree-node-left p1)) - (avl-tree-node-set-left p1 br) + (setf (avl-tree--node-right br) (avl-tree--node-left p1)) + (setf (avl-tree--node-left p1) br) (if (= 0 b1) (progn - (avl-tree-node-set-balance br +1) - (avl-tree-node-set-balance p1 -1) + (setf (avl-tree--node-balance br) +1) + (setf (avl-tree--node-balance p1) -1) (setq result nil)) - (avl-tree-node-set-balance br 0) - (avl-tree-node-set-balance p1 0) + (setf (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance p1) 0) (setq result t)) - (avl-tree-node-set-branch node branch p1) + (setf (avl-tree--node-branch node branch) p1) result) ;; Double RL rotation. - (setq p2 (avl-tree-node-left p1) - b2 (avl-tree-node-balance p2)) - (avl-tree-node-set-left p1 (avl-tree-node-right p2)) - (avl-tree-node-set-right p2 p1) - (avl-tree-node-set-right br (avl-tree-node-left p2)) - (avl-tree-node-set-left p2 br) - (if (> b2 0) - (avl-tree-node-set-balance br -1) - (avl-tree-node-set-balance br 0)) - (if (< b2 0) - (avl-tree-node-set-balance p1 +1) - (avl-tree-node-set-balance p1 0)) - (avl-tree-node-set-branch node branch p2) - (avl-tree-node-set-balance p2 0) + (setq p2 (avl-tree--node-left p1) + b2 (avl-tree--node-balance p2)) + (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) + (setf (avl-tree--node-right p2) p1) + (setf (avl-tree--node-right br) (avl-tree--node-left p2)) + (setf (avl-tree--node-left p2) br) + (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) + (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) + (setf (avl-tree--node-branch node branch) p2) + (setf (avl-tree--node-balance p2) 0) t))))) -(defun avl-tree-del-balance2 (node branch) - (let ((br (avl-tree-node-branch node branch)) +(defun avl-tree--del-balance2 (node branch) + (let ((br (avl-tree--node-branch node branch)) p1 b1 p2 b2 result) (cond - ((> (avl-tree-node-balance br) 0) - (avl-tree-node-set-balance br 0) + ((> (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) 0) t) - ((= (avl-tree-node-balance br) 0) - (avl-tree-node-set-balance br -1) + ((= (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) -1) nil) (t ;; Rebalance. - (setq p1 (avl-tree-node-left br) - b1 (avl-tree-node-balance p1)) + (setq p1 (avl-tree--node-left br) + b1 (avl-tree--node-balance p1)) (if (<= b1 0) ;; Single LL rotation. (progn - (avl-tree-node-set-left br (avl-tree-node-right p1)) - (avl-tree-node-set-right p1 br) + (setf (avl-tree--node-left br) (avl-tree--node-right p1)) + (setf (avl-tree--node-right p1) br) (if (= 0 b1) (progn - (avl-tree-node-set-balance br -1) - (avl-tree-node-set-balance p1 +1) + (setf (avl-tree--node-balance br) -1) + (setf (avl-tree--node-balance p1) +1) (setq result nil)) - (avl-tree-node-set-balance br 0) - (avl-tree-node-set-balance p1 0) + (setf (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance p1) 0) (setq result t)) - (avl-tree-node-set-branch node branch p1) + (setf (avl-tree--node-branch node branch) p1) result) ;; Double LR rotation. - (setq p2 (avl-tree-node-right p1) - b2 (avl-tree-node-balance p2)) - (avl-tree-node-set-right p1 (avl-tree-node-left p2)) - (avl-tree-node-set-left p2 p1) - (avl-tree-node-set-left br (avl-tree-node-right p2)) - (avl-tree-node-set-right p2 br) - (if (< b2 0) - (avl-tree-node-set-balance br +1) - (avl-tree-node-set-balance br 0)) - (if (> b2 0) - (avl-tree-node-set-balance p1 -1) - (avl-tree-node-set-balance p1 0)) - (avl-tree-node-set-branch node branch p2) - (avl-tree-node-set-balance p2 0) + (setq p2 (avl-tree--node-right p1) + b2 (avl-tree--node-balance p2)) + (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) + (setf (avl-tree--node-left p2) p1) + (setf (avl-tree--node-left br) (avl-tree--node-right p2)) + (setf (avl-tree--node-right p2) br) + (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) + (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) + (setf (avl-tree--node-branch node branch) p2) + (setf (avl-tree--node-balance p2) 0) t))))) -(defun avl-tree-do-del-internal (node branch q) - (let ((br (avl-tree-node-branch node branch))) - (if (avl-tree-node-right br) - (if (avl-tree-do-del-internal br +1 q) - (avl-tree-del-balance2 node branch)) - (avl-tree-node-set-data q (avl-tree-node-data br)) - (avl-tree-node-set-branch node branch - (avl-tree-node-left br)) +(defun avl-tree--do-del-internal (node branch q) + (let ((br (avl-tree--node-branch node branch))) + (if (avl-tree--node-right br) + (if (avl-tree--do-del-internal br +1 q) + (avl-tree--del-balance2 node branch)) + (setf (avl-tree--node-data q) (avl-tree--node-data br)) + (setf (avl-tree--node-branch node branch) + (avl-tree--node-left br)) t))) -(defun avl-tree-do-delete (cmpfun root branch data) +(defun avl-tree--do-delete (cmpfun root branch data) ;; Return t if the height of the tree has shrunk. - (let ((br (avl-tree-node-branch root branch))) + (let ((br (avl-tree--node-branch root branch))) (cond ((null br) nil) - ((funcall cmpfun data (avl-tree-node-data br)) - (if (avl-tree-do-delete cmpfun br 0 data) - (avl-tree-del-balance1 root branch))) + ((funcall cmpfun data (avl-tree--node-data br)) + (if (avl-tree--do-delete cmpfun br 0 data) + (avl-tree--del-balance1 root branch))) - ((funcall cmpfun (avl-tree-node-data br) data) - (if (avl-tree-do-delete cmpfun br 1 data) - (avl-tree-del-balance2 root branch))) + ((funcall cmpfun (avl-tree--node-data br) data) + (if (avl-tree--do-delete cmpfun br 1 data) + (avl-tree--del-balance2 root branch))) (t ;; Found it. Let's delete it. (cond - ((null (avl-tree-node-right br)) - (avl-tree-node-set-branch root branch (avl-tree-node-left br)) + ((null (avl-tree--node-right br)) + (setf (avl-tree--node-branch root branch) (avl-tree--node-left br)) t) - ((null (avl-tree-node-left br)) - (avl-tree-node-set-branch root branch (avl-tree-node-right br)) + ((null (avl-tree--node-left br)) + (setf (avl-tree--node-branch root branch) (avl-tree--node-right br)) t) (t - (if (avl-tree-do-del-internal br 0 br) - (avl-tree-del-balance1 root branch)))))))) + (if (avl-tree--do-del-internal br 0 br) + (avl-tree--del-balance1 root branch)))))))) ;; ---------------------------------------------------------------- ;; Entering data -(defun avl-tree-enter-balance1 (node branch) +(defun avl-tree--enter-balance1 (node branch) ;; Rebalance a tree and return t if the height of the tree has grown. - (let ((br (avl-tree-node-branch node branch)) + (let ((br (avl-tree--node-branch node branch)) p1 p2 b2 result) (cond - ((< (avl-tree-node-balance br) 0) - (avl-tree-node-set-balance br 0) + ((< (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) 0) nil) - ((= (avl-tree-node-balance br) 0) - (avl-tree-node-set-balance br +1) + ((= (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) +1) t) (t ;; Tree has grown => Rebalance. - (setq p1 (avl-tree-node-right br)) - (if (> (avl-tree-node-balance p1) 0) + (setq p1 (avl-tree--node-right br)) + (if (> (avl-tree--node-balance p1) 0) ;; Single RR rotation. (progn - (avl-tree-node-set-right br (avl-tree-node-left p1)) - (avl-tree-node-set-left p1 br) - (avl-tree-node-set-balance br 0) - (avl-tree-node-set-branch node branch p1)) + (setf (avl-tree--node-right br) (avl-tree--node-left p1)) + (setf (avl-tree--node-left p1) br) + (setf (avl-tree--node-balance br) 0) + (setf (avl-tree--node-branch node branch) p1)) ;; Double RL rotation. - (setq p2 (avl-tree-node-left p1) - b2 (avl-tree-node-balance p2)) - (avl-tree-node-set-left p1 (avl-tree-node-right p2)) - (avl-tree-node-set-right p2 p1) - (avl-tree-node-set-right br (avl-tree-node-left p2)) - (avl-tree-node-set-left p2 br) - (if (> b2 0) - (avl-tree-node-set-balance br -1) - (avl-tree-node-set-balance br 0)) - (if (< b2 0) - (avl-tree-node-set-balance p1 +1) - (avl-tree-node-set-balance p1 0)) - (avl-tree-node-set-branch node branch p2)) - (avl-tree-node-set-balance (avl-tree-node-branch node branch) 0) + (setq p2 (avl-tree--node-left p1) + b2 (avl-tree--node-balance p2)) + (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) + (setf (avl-tree--node-right p2) p1) + (setf (avl-tree--node-right br) (avl-tree--node-left p2)) + (setf (avl-tree--node-left p2) br) + (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) + (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) + (setf (avl-tree--node-branch node branch) p2)) + (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) nil)))) -(defun avl-tree-enter-balance2 (node branch) +(defun avl-tree--enter-balance2 (node branch) ;; Return t if the tree has grown. - (let ((br (avl-tree-node-branch node branch)) + (let ((br (avl-tree--node-branch node branch)) p1 p2 b2) (cond - ((> (avl-tree-node-balance br) 0) - (avl-tree-node-set-balance br 0) + ((> (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) 0) nil) - ((= (avl-tree-node-balance br) 0) - (avl-tree-node-set-balance br -1) + ((= (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) -1) t) (t ;; Balance was -1 => Rebalance. - (setq p1 (avl-tree-node-left br)) - (if (< (avl-tree-node-balance p1) 0) + (setq p1 (avl-tree--node-left br)) + (if (< (avl-tree--node-balance p1) 0) ;; Single LL rotation. (progn - (avl-tree-node-set-left br (avl-tree-node-right p1)) - (avl-tree-node-set-right p1 br) - (avl-tree-node-set-balance br 0) - (avl-tree-node-set-branch node branch p1)) + (setf (avl-tree--node-left br) (avl-tree--node-right p1)) + (setf (avl-tree--node-right p1) br) + (setf (avl-tree--node-balance br) 0) + (setf (avl-tree--node-branch node branch) p1)) ;; Double LR rotation. - (setq p2 (avl-tree-node-right p1) - b2 (avl-tree-node-balance p2)) - (avl-tree-node-set-right p1 (avl-tree-node-left p2)) - (avl-tree-node-set-left p2 p1) - (avl-tree-node-set-left br (avl-tree-node-right p2)) - (avl-tree-node-set-right p2 br) - (if (< b2 0) - (avl-tree-node-set-balance br +1) - (avl-tree-node-set-balance br 0)) - (if (> b2 0) - (avl-tree-node-set-balance p1 -1) - (avl-tree-node-set-balance p1 0)) - (avl-tree-node-set-branch node branch p2)) - (avl-tree-node-set-balance (avl-tree-node-branch node branch) 0) + (setq p2 (avl-tree--node-right p1) + b2 (avl-tree--node-balance p2)) + (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) + (setf (avl-tree--node-left p2) p1) + (setf (avl-tree--node-left br) (avl-tree--node-right p2)) + (setf (avl-tree--node-right p2) br) + (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) + (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) + (setf (avl-tree--node-branch node branch) p2)) + (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) nil)))) -(defun avl-tree-do-enter (cmpfun root branch data) +(defun avl-tree--do-enter (cmpfun root branch data) ;; Return t if height of tree ROOT has grown. INTERNAL USE ONLY. - (let ((br (avl-tree-node-branch root branch))) + (let ((br (avl-tree--node-branch root branch))) (cond ((null br) ;; Data not in tree, insert it. - (avl-tree-node-set-branch - root branch (avl-tree-node-create nil nil data 0)) + (setf (avl-tree--node-branch root branch) + (avl-tree--node-create nil nil data 0)) t) - ((funcall cmpfun data (avl-tree-node-data br)) - (and (avl-tree-do-enter cmpfun br 0 data) - (avl-tree-enter-balance2 root branch))) + ((funcall cmpfun data (avl-tree--node-data br)) + (and (avl-tree--do-enter cmpfun br 0 data) + (avl-tree--enter-balance2 root branch))) - ((funcall cmpfun (avl-tree-node-data br) data) - (and (avl-tree-do-enter cmpfun br 1 data) - (avl-tree-enter-balance1 root branch))) + ((funcall cmpfun (avl-tree--node-data br) data) + (and (avl-tree--do-enter cmpfun br 1 data) + (avl-tree--enter-balance1 root branch))) (t - (avl-tree-node-set-data br data) + (setf (avl-tree--node-data br) data) nil)))) ;; ---------------------------------------------------------------- -(defun avl-tree-mapc (map-function root) +(defun avl-tree--mapc (map-function root) ;; Apply MAP-FUNCTION to all nodes in the tree starting with ROOT. ;; The function is applied in-order. ;; @@ -378,72 +339,59 @@ NEWVAL is new value of the branch.\"" (push nil stack) (while node (if (and go-left - (avl-tree-node-left node)) + (avl-tree--node-left node)) ;; Do the left subtree first. (progn (push node stack) - (setq node (avl-tree-node-left node))) + (setq node (avl-tree--node-left node))) ;; Apply the function... (funcall map-function node) ;; and do the right subtree. - (if (avl-tree-node-right node) - (setq node (avl-tree-node-right node) - go-left t) - (setq node (pop stack) - go-left nil)))))) + (setq node (if (setq go-left (avl-tree--node-right node)) + (avl-tree--node-right node) + (pop stack))))))) -(defun avl-tree-do-copy (root) +(defun avl-tree--do-copy (root) ;; Copy the avl tree with ROOT as root. ;; Highly recursive. INTERNAL USE ONLY. (if (null root) nil - (avl-tree-node-create - (avl-tree-do-copy (avl-tree-node-left root)) - (avl-tree-do-copy (avl-tree-node-right root)) - (avl-tree-node-data root) - (avl-tree-node-balance root)))) + (avl-tree--node-create + (avl-tree--do-copy (avl-tree--node-left root)) + (avl-tree--do-copy (avl-tree--node-right root)) + (avl-tree--node-data root) + (avl-tree--node-balance root)))) -;;; ================================================================ -;;; The public functions which operate on AVL trees. - -(defun avl-tree-create (compare-function) - "Create a new empty avl tree and return it. -COMPARE-FUNCTION is a function which takes two arguments, A and B, -and returns non-nil if A is less than B, and nil otherwise." - (cons 'AVL-TREE - (cons (avl-tree-node-create nil nil nil 0) - compare-function))) +;; ================================================================ +;;; The public functions which operate on AVL trees. -(defun avl-tree-p (obj) - "Return t if OBJ is an avl tree, nil otherwise." - (eq (car-safe obj) 'AVL-TREE)) +(defalias 'avl-tree-compare-function 'avl-tree--cmpfun + "Return the comparison function for the avl tree TREE. -(defun avl-tree-compare-function (tree) - "Return the comparison function for the avl tree TREE." - (avl-tree-cmpfun tree)) +\(fn TREE)") (defun avl-tree-empty (tree) "Return t if avl tree TREE is emtpy, otherwise return nil." - (null (avl-tree-root tree))) + (null (avl-tree--root tree))) (defun avl-tree-enter (tree data) "In the avl tree TREE insert DATA. Return DATA." - (avl-tree-do-enter (avl-tree-cmpfun tree) - (avl-tree-dummyroot tree) - 0 - data) + (avl-tree--do-enter (avl-tree--cmpfun tree) + (avl-tree--dummyroot tree) + 0 + data) data) (defun avl-tree-delete (tree data) "From the avl tree TREE, delete DATA. Return the element in TREE which matched DATA, nil if no element matched." - (avl-tree-do-delete (avl-tree-cmpfun tree) - (avl-tree-dummyroot tree) - 0 - data)) + (avl-tree--do-delete (avl-tree--cmpfun tree) + (avl-tree--dummyroot tree) + 0 + data)) (defun avl-tree-member (tree data) "Return the element in the avl tree TREE which matches DATA. @@ -451,82 +399,72 @@ Matching uses the compare function previously specified in `avl-tree-create' when TREE was created. If there is no such element in the tree, the value is nil." - (let ((node (avl-tree-root tree)) - (compare-function (avl-tree-cmpfun tree)) + (let ((node (avl-tree--root tree)) + (compare-function (avl-tree--cmpfun tree)) found) (while (and node (not found)) (cond - ((funcall compare-function data (avl-tree-node-data node)) - (setq node (avl-tree-node-left node))) - ((funcall compare-function (avl-tree-node-data node) data) - (setq node (avl-tree-node-right node))) + ((funcall compare-function data (avl-tree--node-data node)) + (setq node (avl-tree--node-left node))) + ((funcall compare-function (avl-tree--node-data node) data) + (setq node (avl-tree--node-right node))) (t (setq found t)))) (if node - (avl-tree-node-data node) + (avl-tree--node-data node) nil))) (defun avl-tree-map (__map-function__ tree) "Apply __MAP-FUNCTION__ to all elements in the avl tree TREE." - (avl-tree-mapc - (function (lambda (node) - (avl-tree-node-set-data - node (funcall __map-function__ - (avl-tree-node-data node))))) - (avl-tree-root tree))) + (avl-tree--mapc + (lambda (node) + (setf (avl-tree--node-data node) + (funcall __map-function__ (avl-tree--node-data node)))) + (avl-tree--root tree))) (defun avl-tree-first (tree) "Return the first element in TREE, or nil if TREE is empty." - (let ((node (avl-tree-root tree))) - (if node - (progn - (while (avl-tree-node-left node) - (setq node (avl-tree-node-left node))) - (avl-tree-node-data node)) - nil))) + (let ((node (avl-tree--root tree))) + (when node + (while (avl-tree--node-left node) + (setq node (avl-tree--node-left node))) + (avl-tree--node-data node)))) (defun avl-tree-last (tree) "Return the last element in TREE, or nil if TREE is empty." - (let ((node (avl-tree-root tree))) - (if node - (progn - (while (avl-tree-node-right node) - (setq node (avl-tree-node-right node))) - (avl-tree-node-data node)) - nil))) + (let ((node (avl-tree--root tree))) + (when node + (while (avl-tree--node-right node) + (setq node (avl-tree--node-right node))) + (avl-tree--node-data node)))) (defun avl-tree-copy (tree) "Return a copy of the avl tree TREE." - (let ((new-tree (avl-tree-create (avl-tree-cmpfun tree)))) - (avl-tree-node-set-left (avl-tree-dummyroot new-tree) - (avl-tree-do-copy (avl-tree-root tree))) + (let ((new-tree (avl-tree-create (avl-tree--cmpfun tree)))) + (setf (avl-tree--root new-tree) (avl-tree--do-copy (avl-tree--root tree))) new-tree)) (defun avl-tree-flatten (tree) "Return a sorted list containing all elements of TREE." (nreverse (let ((treelist nil)) - (avl-tree-mapc - (function (lambda (node) - (setq treelist (cons (avl-tree-node-data node) - treelist)))) - (avl-tree-root tree)) + (avl-tree--mapc + (lambda (node) (push (avl-tree--node-data node) treelist)) + (avl-tree--root tree)) treelist))) (defun avl-tree-size (tree) "Return the number of elements in TREE." (let ((treesize 0)) - (avl-tree-mapc - (function (lambda (data) - (setq treesize (1+ treesize)) - data)) - (avl-tree-root tree)) + (avl-tree--mapc + (lambda (data) (setq treesize (1+ treesize))) + (avl-tree--root tree)) treesize)) (defun avl-tree-clear (tree) "Clear the avl tree TREE." - (avl-tree-node-set-left (avl-tree-dummyroot tree) nil)) + (setf (avl-tree--root tree) nil)) (provide 'avl-tree) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f56f1c7c943..ccffdb1a164 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -103,6 +103,7 @@ ;; not good to call from Lisp) ;; `make-local' (dubious calls to ;; `make-variable-buffer-local') +;; `mapcar' (mapcar called for effect) ;; byte-compile-compatibility Whether the compiler should ;; generate .elc files which can be loaded into ;; generic emacs 18. @@ -340,7 +341,8 @@ If it is 'byte, then only byte-level optimizations will be logged." (defconst byte-compile-warning-types '(redefine callargs free-vars unresolved - obsolete noruntime cl-functions interactive-only) + obsolete noruntime cl-functions interactive-only + make-local mapcar) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "*List of warnings that the byte-compiler should issue (t for all). @@ -359,7 +361,8 @@ Elements of the list may be: distinguished from macros and aliases). interactive-only commands that normally shouldn't be called from Lisp code. - make-local calls to make-variable-buffer-local that may be incorrect." + make-local calls to make-variable-buffer-local that may be incorrect. + mapcar mapcar called for effect." :group 'bytecomp :type `(choice (const :tag "All" t) (set :menu-tag "Some" @@ -367,7 +370,7 @@ Elements of the list may be: (const callargs) (const redefine) (const obsolete) (const noruntime) (const cl-functions) (const interactive-only) - (const make-local)))) + (const make-local) (const mapcar)))) (put 'byte-compile-warnings 'safe-local-variable 'byte-compile-warnings-safe-p) ;;;###autoload (defun byte-compile-warnings-safe-p (x) @@ -378,7 +381,8 @@ Elements of the list may be: (when (memq e '(free-vars unresolved callargs redefine obsolete noruntime - cl-functions interactive-only make-local)) + cl-functions interactive-only + make-local mapcar)) e)) x) x)))) @@ -975,7 +979,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (pos (if (and byte-compile-current-file (integerp byte-compile-read-position)) (with-current-buffer byte-compile-current-buffer - (format "%d:%d:" + (format "%d:%d:" (save-excursion (goto-char byte-compile-last-position) (1+ (count-lines (point-min) (point-at-bol)))) @@ -1037,8 +1041,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form nil) ;; Do this after setting default-directory. - (unless (eq major-mode 'compilation-mode) - (compilation-mode)) + (unless (derived-mode-p 'compilation-mode) (compilation-mode)) (compilation-forget-errors) pt)))) @@ -1552,7 +1555,7 @@ recompile every `.el' file that already has a `.elc' file." ;; compilation-mode copies value of default-directory. (unless (eq major-mode 'compilation-mode) (compilation-mode)) - (let ((directories (list (expand-file-name directory))) + (let ((directories (list default-directory)) (default-directory default-directory) (skip-count 0) (fail-count 0) @@ -1659,7 +1662,7 @@ The value is non-nil if there were no errors, nil if errors." byte-compile-dest-file) (setq target-file (byte-compile-dest-file filename)) (setq byte-compile-dest-file target-file) - (with-current-buffer + (with-current-buffer (setq input-buffer (get-buffer-create " *Compiler Input*")) (erase-buffer) (setq buffer-file-coding-system nil) @@ -2832,6 +2835,11 @@ That command is designed for interactive use only" fn)) (defun byte-compile-normal-call (form) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) + (when (and for-effect (eq (car form) 'mapcar) + (memq 'mapcar byte-compile-warnings)) + (byte-compile-set-symbol-position 'mapcar) + (byte-compile-warn + "`mapcar' called for effect; use `mapc' or `dolist' instead")) (byte-compile-push-constant (car form)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) @@ -4237,18 +4245,18 @@ and corresponding effects." (assq 'byte-code (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) - (mapcar (lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) - '(byte-compile-normal-call - byte-compile-form - byte-compile-body - ;; Inserted some more than necessary, to speed it up. - byte-compile-top-level - byte-compile-out-toplevel - byte-compile-constant - byte-compile-variable-ref)))) + (mapc (lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) + '(byte-compile-normal-call + byte-compile-form + byte-compile-body + ;; Inserted some more than necessary, to speed it up. + byte-compile-top-level + byte-compile-out-toplevel + byte-compile-constant + byte-compile-variable-ref)))) nil) (run-hooks 'bytecomp-load-hook) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index e1835d75fcb..edbf382f39e 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -199,6 +199,12 @@ :group 'lisp :version "20.3") +(defcustom checkdoc-minor-mode-string " CDoc" + "*String to display in mode line when Checkdoc mode is enabled; nil for none." + :type '(choice string (const :tag "None" nil)) + :group 'checkdoc + :version "23.1") + (defcustom checkdoc-autofix-flag 'semiautomatic "Non-nil means attempt auto-fixing of doc strings. If this value is the symbol `query', then the user is queried before @@ -227,7 +233,7 @@ and that it's good but not required practice to make non user visible items have doc strings." :group 'checkdoc :type 'boolean) -(put 'checkdoc-force-docstrings-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-force-docstrings-flag 'safe-local-variable 'booleanp) (defcustom checkdoc-force-history-flag t "Non-nil means that files should have a History section or ChangeLog file. @@ -243,7 +249,7 @@ should be used when the first part could stand alone as a sentence, but it indicates that a modifying clause follows." :group 'checkdoc :type 'boolean) -(put 'checkdoc-permit-comma-termination-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-permit-comma-termination-flag 'safe-local-variable 'booleanp) (defcustom checkdoc-spellcheck-documentation-flag nil "Non-nil means run Ispell on text based on value. @@ -1251,7 +1257,7 @@ bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-c checking of documentation strings. \\{checkdoc-minor-mode-map}" - nil " CDoc" nil + nil checkdoc-minor-mode-string nil :group 'checkdoc) ;;; Subst utils diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index b7e8c84cf27..77781ec390e 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -55,7 +55,7 @@ The second \\( \\) construct must match the years." (defcustom copyright-names-regexp "" "Regexp matching the names which correspond to the user. Only copyright lines where the name matches this regexp will be updated. -This allows you to avoid adding yars to a copyright notice belonging to +This allows you to avoid adding years to a copyright notice belonging to someone else or to a group for which you do not work." :group 'copyright :type 'regexp) @@ -184,10 +184,13 @@ interactively." either \\|; a\\^u eldono \\([0-9]+\\)a, ? a\\^u (la\\^u via \\)\ version \\([0-9]+\\), or (at" (copyright-limit) t) - (not (string= (match-string 3) copyright-current-gpl-version)) + ;; Don't update if the file is already using a more recent + ;; version than the "current" one. + (< (string-to-number (match-string 3)) + (string-to-number copyright-current-gpl-version)) (or noquery - (y-or-n-p (concat "Replace GPL version by " - copyright-current-gpl-version "? "))) + (y-or-n-p (format "Replace GPL version by %s? " + copyright-current-gpl-version))) (progn (if (match-end 2) ;; Esperanto bilingual comment in two-column.el diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el index 54ead36e725..fdfb4f11113 100644 --- a/lisp/emacs-lisp/cust-print.el +++ b/lisp/emacs-lisp/cust-print.el @@ -244,14 +244,14 @@ Any pair that has the same PREDICATE is first removed." ;; Save emacs routines. (if (not (fboundp 'cust-print-original-prin1)) - (mapcar 'cust-print-set-function-cell - '((cust-print-original-prin1 prin1) - (cust-print-original-princ princ) - (cust-print-original-print print) - (cust-print-original-prin1-to-string prin1-to-string) - (cust-print-original-format format) - (cust-print-original-message message) - (cust-print-original-error error)))) + (mapc 'cust-print-set-function-cell + '((cust-print-original-prin1 prin1) + (cust-print-original-princ princ) + (cust-print-original-print print) + (cust-print-original-prin1-to-string prin1-to-string) + (cust-print-original-format format) + (cust-print-original-message message) + (cust-print-original-error error)))) (defun custom-print-install () @@ -259,29 +259,29 @@ Any pair that has the same PREDICATE is first removed." The Emacs subroutines are saved away, and you can reinstall them by running `custom-print-uninstall'." (interactive) - (mapcar 'cust-print-set-function-cell - '((prin1 custom-prin1) - (princ custom-princ) - (print custom-print) - (prin1-to-string custom-prin1-to-string) - (format custom-format) - (message custom-message) - (error custom-error) - )) + (mapc 'cust-print-set-function-cell + '((prin1 custom-prin1) + (princ custom-princ) + (print custom-print) + (prin1-to-string custom-prin1-to-string) + (format custom-format) + (message custom-message) + (error custom-error) + )) t) (defun custom-print-uninstall () "Reset print functions to their Emacs subroutines." (interactive) - (mapcar 'cust-print-set-function-cell - '((prin1 cust-print-original-prin1) - (princ cust-print-original-princ) - (print cust-print-original-print) - (prin1-to-string cust-print-original-prin1-to-string) - (format cust-print-original-format) - (message cust-print-original-message) - (error cust-print-original-error) - )) + (mapc 'cust-print-set-function-cell + '((prin1 cust-print-original-prin1) + (princ cust-print-original-princ) + (print cust-print-original-print) + (prin1-to-string cust-print-original-prin1-to-string) + (format cust-print-original-format) + (message cust-print-original-message) + (error cust-print-original-error) + )) t) (defalias 'custom-print-funcs-installed-p 'custom-print-installed-p) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 01378a7f8d6..60b29bdb949 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -250,7 +250,7 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (+ indent disassemble-recursive-indent))) ((eq (car-safe (car-safe arg)) 'byte-code) (insert "(<byte code>...)\n") - (mapcar ;recurse on list of byte-code objects + (mapc ;recurse on list of byte-code objects '(lambda (obj) (disassemble-1 obj diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 80d1625ec9b..da0b76808d5 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -139,8 +139,8 @@ For example, you could write (setq body (list* lighter keymap body) lighter nil keymap nil)) ((keywordp keymap) (push keymap body) (setq keymap nil))) - (let* ((last-message (current-message)) - (mode-name (symbol-name mode)) + (let* ((last-message (make-symbol "last-message")) + (mode-name (symbol-name mode)) (pretty-name (easy-mmode-pretty-mode-name mode lighter)) (globalp nil) (set nil) @@ -222,28 +222,30 @@ With zero or negative ARG turn mode off. ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. (interactive (list (or current-prefix-arg 'toggle))) - (setq ,mode - (cond - ((eq arg 'toggle) (not ,mode)) - (arg (> (prefix-numeric-value arg) 0)) - (t - (if (null ,mode) t - (message - "Toggling %s off; better pass an explicit argument." - ',mode) - nil)))) - ,@body - ;; The on/off hooks are here for backward compatibility only. - (run-hooks ',hook (if ,mode ',hook-on ',hook-off)) - (if (called-interactively-p) - (progn - ,(if globalp `(customize-mark-as-set ',mode)) - ;; Avoid overwriting a message shown by the body, - ;; but do overwrite previous messages. - (unless ,(and (current-message) - (not (equal last-message (current-message)))) - (message ,(format "%s %%sabled" pretty-name) - (if ,mode "en" "dis"))))) + (let ((,last-message (current-message))) + (setq ,mode + (cond + ((eq arg 'toggle) (not ,mode)) + (arg (> (prefix-numeric-value arg) 0)) + (t + (if (null ,mode) t + (message + "Toggling %s off; better pass an explicit argument." + ',mode) + nil)))) + ,@body + ;; The on/off hooks are here for backward compatibility only. + (run-hooks ',hook (if ,mode ',hook-on ',hook-off)) + (if (called-interactively-p) + (progn + ,(if globalp `(customize-mark-as-set ',mode)) + ;; Avoid overwriting a message shown by the body, + ;; but do overwrite previous messages. + (unless (and (current-message) + (not (equal ,last-message + (current-message)))) + (message ,(format "%s %%sabled" pretty-name) + (if ,mode "en" "dis")))))) (force-mode-line-update) ;; Return the new setting. ,mode) @@ -456,7 +458,7 @@ ARGS is a list of additional keyword arguments." (let ((char (car cs)) (syntax (cdr cs))) (if (sequencep char) - (mapcar (lambda (c) (modify-syntax-entry c syntax st)) char) + (mapc (lambda (c) (modify-syntax-entry c syntax st)) char) (modify-syntax-entry char syntax st)))) (if parent (set-char-table-parent st (if (symbolp parent) (symbol-value parent) parent))) @@ -539,5 +541,5 @@ found, do `widen' first and then call NARROWFUN with no args after moving." (provide 'easy-mmode) -;;; arch-tag: d48a5250-6961-4528-9cb0-3c9ea042a66a +;; arch-tag: d48a5250-6961-4528-9cb0-3c9ea042a66a ;;; easy-mmode.el ends here diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 964688894af..01d883d63be 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -4421,7 +4421,7 @@ With prefix argument, make it a temporary breakpoint." (defun byte-compile-resolve-functions (funcs) "Say it is OK for the named functions to be unresolved." - (mapcar + (mapc (function (lambda (func) (setq byte-compile-unresolved-functions diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 1d2441f884a..7807fc763a4 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -109,7 +109,7 @@ truncated to make more of the arglist or documentation string visible." ;;; No user options below here. (defvar eldoc-message-commands-table-size 31 - "This is used by eldoc-add-command to initialize eldoc-message-commands + "This is used by `eldoc-add-command' to initialize `eldoc-message-commands' as an obarray. It should probably never be necessary to do so, but if you choose to increase the number of buckets, you must do so before loading @@ -121,7 +121,7 @@ Remember to keep it a prime number to improve hash performance.") "Commands after which it is appropriate to print in the echo area. Eldoc does not try to print function arglists, etc. after just any command, because some commands print their own messages in the echo area and these -functions would instantly overwrite them. But self-insert-command as well +functions would instantly overwrite them. But `self-insert-command' as well as most motion commands are good candidates. This variable contains an obarray of symbols; do not manipulate it directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") @@ -137,7 +137,7 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") (defvar eldoc-timer nil "eldoc's timer object.") (defvar eldoc-current-idle-delay eldoc-idle-delay - "idle time delay currently in use by timer. + "Idle time delay currently in use by timer. This is used to determine if `eldoc-idle-delay' is changed by the user.") @@ -474,13 +474,14 @@ ARGLIST is either a string, or a list of strings or symbols." (format "(%s)" arglist))) (defun eldoc-function-argstring-format (argstring) - "Apply `eldoc-argument-case' to each word in argstring. + "Apply `eldoc-argument-case' to each word in ARGSTRING. The words \"&rest\", \"&optional\" are returned unchanged." (mapconcat (lambda (s) (if (member s '("&optional" "&rest")) s (funcall eldoc-argument-case s))) - (split-string argstring) " ")) + (split-string argstring "[][ ()]+" t) " ")) + ;; When point is in a sexp, the function args are not reprinted in the echo ;; area after every possible interactive command because some of them print diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index f9bff300293..0501fbf171e 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -218,7 +218,7 @@ This environment can be passed to `macroexpand'." (buffer-file-name) (buffer-name)))) (elint-display-log) - (mapcar 'elint-top-form (elint-update-env)) + (mapc 'elint-top-form (elint-update-env)) ;; Tell the user we're finished. This is terribly klugy: we set ;; elint-top-form-logged so elint-log-message doesn't print the @@ -542,11 +542,11 @@ CODE can be a lambda expression, a macro, or byte-compiled code." (defun elint-check-defun-form (form env) "Lint a defun/defmacro/lambda FORM in ENV." (setq form (if (eq (car form) 'lambda) (cdr form) (cdr (cdr form)))) - (mapcar (function (lambda (p) - (or (memq p '(&optional &rest)) - (setq env (elint-env-add-var env p))) - )) - (car form)) + (mapc (function (lambda (p) + (or (memq p '(&optional &rest)) + (setq env (elint-env-add-var env p))) + )) + (car form)) (elint-forms (cdr form) env)) (defun elint-check-let-form (form env) @@ -566,21 +566,21 @@ CODE can be a lambda expression, a macro, or byte-compiled code." ;; Add variables to environment, and check the init values (let ((newenv env)) - (mapcar (function (lambda (s) - (cond - ((symbolp s) - (setq newenv (elint-env-add-var newenv s))) - ((and (consp s) (<= (length s) 2)) - (elint-form (car (cdr s)) - (if (eq (car form) 'let) - env - newenv)) - (setq newenv - (elint-env-add-var newenv (car s)))) - (t (elint-error - "Malformed `let' declaration: %s" s)) - ))) - varlist) + (mapc (function (lambda (s) + (cond + ((symbolp s) + (setq newenv (elint-env-add-var newenv s))) + ((and (consp s) (<= (length s) 2)) + (elint-form (car (cdr s)) + (if (eq (car form) 'let) + env + newenv)) + (setq newenv + (elint-env-add-var newenv (car s)))) + (t (elint-error + "Malformed `let' declaration: %s" s)) + ))) + varlist) ;; Lint the body forms (elint-forms (cdr (cdr form)) newenv) @@ -665,18 +665,18 @@ CODE can be a lambda expression, a macro, or byte-compiled code." errlist) (while errforms (setq errlist (car (car errforms))) - (mapcar (function (lambda (s) - (or (get s 'error-conditions) - (get s 'error-message) - (elint-warning - "Not an error symbol in error handler: %s" s)))) - (cond - ((symbolp errlist) (list errlist)) - ((listp errlist) errlist) - (t (elint-error "Bad error list in error handler: %s" - errlist) - nil)) - ) + (mapc (function (lambda (s) + (or (get s 'error-conditions) + (get s 'error-message) + (elint-warning + "Not an error symbol in error handler: %s" s)))) + (cond + ((symbolp errlist) (list errlist)) + ((listp errlist) errlist) + (t (elint-error "Bad error list in error handler: %s" + errlist) + nil)) + ) (elint-forms (cdr (car errforms)) newenv) (setq errforms (cdr errforms)) ))) @@ -767,11 +767,11 @@ Insert HEADER followed by a blank line if non-nil." (defun elint-initialize () "Initialize elint." (interactive) - (mapcar (function (lambda (x) - (or (not (symbolp (car x))) - (eq (cdr x) 'unknown) - (put (car x) 'elint-args (cdr x))))) - (elint-find-builtin-args)) + (mapc (function (lambda (x) + (or (not (symbolp (car x))) + (eq (cdr x) 'unknown) + (put (car x) 'elint-args (cdr x))))) + (elint-find-builtin-args)) (mapcar (function (lambda (x) (put (car x) 'elint-args (cdr x)))) elint-unknown-builtin-args)) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index ed09599f4dd..ade2a23608d 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -615,7 +615,7 @@ displayed." ;; buffer (if elp-sort-by-function (setq resvec (sort resvec elp-sort-by-function))) - (mapcar 'elp-output-result resvec)) + (mapc 'elp-output-result resvec)) ;; now pop up results buffer (set-buffer curbuf) (pop-to-buffer resultsbuf) diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index f041de2b1dc..99016d7c43a 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -205,7 +205,7 @@ See the file generic-x.el for some examples of `define-generic-mode'." (setq font-lock-defaults '(generic-font-lock-keywords)) ;; Call a list of functions - (mapcar 'funcall function-list) + (mapc 'funcall function-list) (run-mode-hooks mode-hook))) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index b6f6a450791..7eeefd349a9 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -261,7 +261,6 @@ (defvar lisp-mode-shared-map (let ((map (make-sparse-keymap))) - (define-key map "\t" 'lisp-indent-line) (define-key map "\e\C-q" 'indent-sexp) (define-key map "\177" 'backward-delete-char-untabify) ;; This gets in the way when viewing a Lisp file in view-mode. As @@ -785,8 +784,13 @@ which see." (let ((comment-start nil) (comment-start-skip nil)) (do-auto-fill)))))) -(defvar lisp-indent-offset nil - "If non-nil, indent second line of expressions that many more columns.") +(defcustom lisp-indent-offset nil + "If non-nil, indent second line of expressions that many more columns." + :group 'lisp + :type '(choice nil integer)) +(put 'lisp-body-indent 'safe-local-variable + (lambda (x) (or (null x) (integerp x)))) + (defvar lisp-indent-function 'lisp-indent-function) (defun lisp-indent-line (&optional whole-exp) @@ -1026,8 +1030,11 @@ This function also returns nil meaning don't specify the indentation." (method (funcall method indent-point state))))))) -(defvar lisp-body-indent 2 - "Number of columns to indent the second line of a `(def...)' form.") +(defcustom lisp-body-indent 2 + "Number of columns to indent the second line of a `(def...)' form." + :group 'lisp + :type 'integer) +(put 'lisp-body-indent 'safe-local-variable 'integerp) (defun lisp-indent-specform (count state indent-point normal-indent) (let ((containing-form-start (elt state 1)) diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index d859066c452..a0004be2394 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -515,7 +515,7 @@ optional fourth argument FORCE is non-nil." "Delete all RE Builder overlays in the `reb-target-buffer' buffer." (if (buffer-live-p reb-target-buffer) (with-current-buffer reb-target-buffer - (mapcar 'delete-overlay reb-overlays) + (mapc 'delete-overlay reb-overlays) (setq reb-overlays nil)))) (defun reb-assert-buffer-in-window () diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index ed3f846bf0e..267d7731435 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -166,7 +166,7 @@ useful information: ;; lets find the special tags and remove them from the working ;; frame. note that only the last special tag is used. - (mapcar + (mapc (function (lambda (entry) (let ((pred (car entry)) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index ae150078785..f46aea8540a 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -679,7 +679,7 @@ CHAR `not-newline', `nonl' matches any character except a newline. - . + `anything' matches any character diff --git a/lisp/emacs-lisp/sregex.el b/lisp/emacs-lisp/sregex.el index 901156cefc3..d4deb0f9101 100644 --- a/lisp/emacs-lisp/sregex.el +++ b/lisp/emacs-lisp/sregex.el @@ -565,7 +565,7 @@ has one of the following forms: (let ((chars (make-bool-vector 256 nil))) ; Yeah, right! (dolist (arg args) (cond ((integerp arg) (aset chars arg t)) - ((stringp arg) (mapcar (lambda (c) (aset chars c t)) arg)) + ((stringp arg) (mapc (lambda (c) (aset chars c t)) arg)) ((consp arg) (let ((start (car arg)) (end (cdr arg))) diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index 98a9b4d6361..fbb39ee66d3 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -911,6 +911,7 @@ If global mark is active, copy from register or one character." ;; That would make yank a no-op. (if (and (string= (filter-buffer-substring (point) (mark)) (car kill-ring)) + (fboundp 'mouse-region-match) (mouse-region-match)) (current-kill 1)) (cua-delete-region))) @@ -1233,9 +1234,9 @@ If ARG is the atom `-', scroll upward by nearly full screen." (memq 'shift (event-modifiers (aref (this-single-command-keys) 0))) ;; See if raw escape sequence maps to a shifted event, e.g. S-up or C-S-home. - (and (boundp 'function-key-map) - function-key-map - (let ((ev (lookup-key function-key-map + (and (boundp 'local-function-key-map) + local-function-key-map + (let ((ev (lookup-key local-function-key-map (this-single-command-raw-keys)))) (and (vector ev) (symbolp (setq ev (aref ev 0))) diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index 226f696dad2..5c4bc011464 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -731,7 +731,7 @@ If command is repeated at same position, delete the rectangle." (defun cua--deactivate-rectangle () ;; This is used to clean up after `cua--activate-rectangle'. - (mapcar (function delete-overlay) cua--rectangle-overlays) + (mapc (function delete-overlay) cua--rectangle-overlays) (setq cua--last-rectangle (cons (current-buffer) (cons (point) ;; cua-save-point cua--rectangle)) @@ -837,7 +837,7 @@ If command is repeated at same position, delete the rectangle." (overlay-put overlay 'window (selected-window)) (setq new (cons overlay new)))))) ;; Trim old trailing overlays. - (mapcar (function delete-overlay) old) + (mapc (function delete-overlay) old) (setq cua--rectangle-overlays (nreverse new)))) (defun cua--indent-rectangle (&optional ch to-col clear) @@ -1401,7 +1401,7 @@ With prefix arg, indent to that column." (cua--deactivate-rectangle)) (when cua--rectangle-overlays ;; clean-up after revert-buffer - (mapcar (function delete-overlay) cua--rectangle-overlays) + (mapc (function delete-overlay) cua--rectangle-overlays) (setq cua--rectangle-overlays nil) (setq deactivate-mark t))) (when cua--rect-undo-set-point diff --git a/lisp/emulation/viper-keym.el b/lisp/emulation/viper-keym.el index ac7231a3cac..0e502720f5e 100644 --- a/lisp/emulation/viper-keym.el +++ b/lisp/emulation/viper-keym.el @@ -170,7 +170,7 @@ Enter as a sexp. Examples: \"\\C-z\", [(control ?z)]." (let ((old-value (if (boundp 'viper-toggle-key) viper-toggle-key [(control ?z)]))) - (mapcar + (mapc (lambda (buf) (save-excursion (set-buffer buf) @@ -210,7 +210,7 @@ If running in a terminal, [(escape)] is not understood, so must use \"\\e\"." (let ((old-value (if (boundp 'viper-ESC-key) viper-ESC-key [(escape)]))) - (mapcar + (mapc (lambda (buf) (save-excursion (set-buffer buf) diff --git a/lisp/emulation/viper-macs.el b/lisp/emulation/viper-macs.el index ff046601a1b..bf3f0eefb39 100644 --- a/lisp/emulation/viper-macs.el +++ b/lisp/emulation/viper-macs.el @@ -466,7 +466,7 @@ If SCOPE is nil, the user is asked to specify the scope." (viper-array-to-string macro-name))) (setq lis2 (cons (car lis) lis2)) (setq lis (cdr lis))) - + (setq lis2 (reverse lis2)) (set macro-alist-var (append lis2 (cons new-elt lis))) (setq old-elt new-elt))) @@ -658,9 +658,9 @@ name from there." (interactive) (with-output-to-temp-buffer " *viper-info*" (princ "Macros in Vi state:\n===================\n") - (mapcar 'viper-describe-one-macro viper-vi-kbd-macro-alist) + (mapc 'viper-describe-one-macro viper-vi-kbd-macro-alist) (princ "\n\nMacros in Insert and Replace states:\n====================================\n") - (mapcar 'viper-describe-one-macro viper-insert-kbd-macro-alist) + (mapc 'viper-describe-one-macro viper-insert-kbd-macro-alist) (princ "\n\nMacros in Emacs state:\n======================\n") (mapcar 'viper-describe-one-macro viper-emacs-kbd-macro-alist) )) @@ -670,11 +670,11 @@ name from there." (viper-display-macro (car macro)))) (princ " ** Buffer-specific:") (if (viper-kbd-buf-alist macro) - (mapcar 'viper-describe-one-macro-elt (viper-kbd-buf-alist macro)) + (mapc 'viper-describe-one-macro-elt (viper-kbd-buf-alist macro)) (princ " none\n")) (princ "\n ** Mode-specific:") (if (viper-kbd-mode-alist macro) - (mapcar 'viper-describe-one-macro-elt (viper-kbd-mode-alist macro)) + (mapc 'viper-describe-one-macro-elt (viper-kbd-mode-alist macro)) (princ " none\n")) (princ "\n ** Global:") (if (viper-kbd-global-definition macro) diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index eebf09aed22..7073cd019dd 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -1260,9 +1260,9 @@ Arguments become related buffers. This function should normally be used in the `Local variables' section of a file." (setq viper-related-files-and-buffers-ring (make-ring (1+ (length other-files-or-buffers)))) - (mapcar '(lambda (elt) - (viper-ring-insert viper-related-files-and-buffers-ring elt)) - other-files-or-buffers) + (mapc '(lambda (elt) + (viper-ring-insert viper-related-files-and-buffers-ring elt)) + other-files-or-buffers) (viper-ring-insert viper-related-files-and-buffers-ring (buffer-name)) ) diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index ff3217ac144..c0118250167 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -799,7 +799,7 @@ It also can't undo some Viper settings." ;; set appropriate Viper state in buffers that changed major mode (defun set-viper-state-in-major-mode () - (mapcar + (mapc (lambda (buf) (if (viper-buffer-live-p buf) (with-current-buffer buf diff --git a/lisp/erc/ChangeLog b/lisp/erc/ChangeLog index 43f4c230d14..f262a6324fb 100644 --- a/lisp/erc/ChangeLog +++ b/lisp/erc/ChangeLog @@ -1,26 +1,346 @@ +2007-09-18 Exal de Jesus Garcia Carrillo <exal@gmx.de> (tiny change) + + * erc.texi (Special-Features): Fix small typo. + +2007-09-16 Michael Olson <mwolson@gnu.org> + + * erc-track.el (erc-track-switch-direction): Mention + erc-track-faces-priority-list. Thanks to Leo for the suggestion. + +2007-09-11 Exal de Jesus Garcia Carrillo <exal@gnu.org> (tiny change) + + * erc-sound.el: Fix typo in setting up instructions. + +2007-09-10 Michael Olson <mwolson@gnu.org> + + * Makefile (elpa): Copy dir template rather than echoing a few + lines. The reason for this is that the ELPA package for ERC was + getting a corrupt dir entry. + + * dir-template: Template for the ELPA dir file. + +2007-09-08 Michael Olson <mwolson@gnu.org> + + * erc-log.el (erc-log-filter-function): New option that specifies + the function to call for filtering text before writing it to a log + file. Thanks to David O'Toole for the suggestion. + (erc-save-buffer-in-logs): Use erc-log-filter-function. Make sure + we carry along the value of coding-system-for-write, because this + could potentially be shadowed by the temporary buffer. + + * erc.el (erc-version-string): Update to 5.3, development version. + +2007-09-07 Glenn Morris <rgm@gnu.org> + + * erc.el (erc-toggle-debug-irc-protocol): Fix call to + erc-view-mode-enter. + 2007-08-08 Glenn Morris <rgm@gnu.org> * erc-log.el, erc.el: Replace `iff' in doc-strings and comments. +2007-09-03 Michael Olson <mwolson@gnu.org> + + * erc.el (erc-default-port): Make this an integer value rather + than a string. Thanks to Luca Capello for the report. + +2007-08-27 Michael Olson <mwolson@gnu.org> + + * erc.el (erc-cmd-GQUIT): If erc-kill-queries-on-quit is non-nil, + kill all query buffers after 4 seconds. + +2007-08-16 Michael Olson <mwolson@gnu.org> + + * NEWS: Add ERC 5.3 changes section, and mention jbms' erc-track + compatibility note. + + * erc-track.el (erc-track-list-changed-hook): Turn this into a + customizable option. + (erc-track-switch-direction): Add 'importance option. + (erc-modified-channels-display): If erc-track-switch-direction is + 'importance, call erc-track-sort-by-importance. + (erc-track-face-priority): New function that returns a number + indicating the position of a face in + erc-track-faces-priority-list. + (erc-track-sort-by-importance): New function that sorts + erc-modified-channels-list according to erc-track-face-priority. + (erc-track-get-active-buffer): Make 'oldest a rough opposite of + 'importance. + +2007-08-14 Jeremy Maitin-Shepard <jbms@cmu.edu> + + * erc-track.el (erc-track-remove-disconnected-buffers): New + variable which controls whether buffers associated with a server + that is disconnected should be removed from + `erc-modified-channels-alist'. Existing behavior is to + unconditionally remove such buffers, which is achieved by setting + `erc-track-removed-disconnected-buffers' to t. When set to t, + which is the new default value, such buffers remain in the list, + which I think is often the desired behavior, since the user may + likely wish to find out about activity that occurred in a channel + prior to it being disconnected. + (erc-track-list-changed-hook): New hook that is run whenever the + contents of `erc-modified-channels-alist' changes; it is useful + for users such as myself that don't use the default mode-line + notification but instead use a separate mechanism (which is tied + to my window manager) to provide notification of channel activity. + (erc-track-get-buffer-window): New function that acts as a wrapper + around `get-buffer-window' that handles the `selected-visible' + option of `erc-track-visibility'; previously, the value of + `erc-track-visibility' was passed directly to `get-buffer-window', + which does not support `selected-visible'; consequently, + `selected-visible' was not properly supported. + (erc-track-modified-channels): Fix a bug in the logic for removing + buffers from the list in certain cases. + (erc-track-position-in-mode-line): Add a supported value that + specifies that the tracking information should not be added to the + mode line at all. The value of nil is used to indicate that the + information should not be added at all to the mode line. + (erc-track-add-to-mode-line): Check for position eq to t, rather + than non-nil. + (erc-buffer-visible): Use erc-track-get-buffer-window. + (erc-modified-channels-update): Take + erc-track-remove-disconnected-buffers into account. + (erc-modified-channels-display): Run + `erc-track-list-changed-hook'. + + * erc.el (erc-reuse-frames): New option that determines whether + new frames are always created. Defaults to t. This only has an + effect when erc-join-buffer is set to 'frame. + (erc-setup-buffer): Use it. + +2007-08-14 Michael Olson <mwolson@gnu.org> + + * erc-backend.el (erc-server-reconnect): If the server buffer has + been killed, use the current buffer instead. If the current + buffer is not an ERC buffer, give an error. This fixes a bug when + /reconnect is run from a channel buffer whose server buffer has + been deleted. Thanks to jbms for the report. + (erc-process-sentinel-1): Take server buffer as an argument, so + that we can make sure that it is current. + (erc-process-sentinel): Pass buffer to erc-process-sentinel-1. + (erc-process-sentinel-2): New function split from + erc-process-sentinel-1. If server buffer is deleted during a + reconnect attempt, stop trying to reconnect. Fix bug where + reconnect was not happening when erc-server-reconnect-attempts was + t. Call erc-server-reconnect-p only once each time. If we are + instructed to try connecting indefinitely, tell the user that they + can stop this by killing the server buffer. Call the process + sentinel by means of run-at-time, so that there is time to kill + the buffer if need be; this also removes the need for a while + loop. Refuse to reconnect again if erc-server-reconnect-timeout + is not an number. + + * erc.el (erc-command-no-process-p): Fix bug: the return value of + erc-extract-command-from-line is a list rather than a single + symbol. Thanks to jbms for the report. + (erc-cmd-RECONNECT): Use simpler logic, and use buffer-live-p + rather than bufferp. + (erc-send-current-line, erc-display-command, erc-display-msg): + Handle case where erc-server-process is nil, so that /reconnect + works. + +2007-08-12 Michael Olson <mwolson@gnu.org> + + * erc-identd.el (erc-identd-filter): Instead of sending an EOF + character, which now confuses freenode, stop the server process, + so that no new connections are accepted, and kill the current + client process. + 2007-07-30 Michael Olson <mwolson@gnu.org> * erc-nicklist.el: Remove from the Emacs source tree. This file is not release quality, and relies heavily on a module which cannot be distributed with ERC due to licensing reasons. +2007-07-29 Michael Olson <mwolson@gnu.org> + + * erc-list.el: Relicense to GPLv3. Since the file was already + licensed under version 2 or later, it turns out that we do not + need the permission of all of the authors in order to proceed. + 2007-07-25 Glenn Morris <rgm@gnu.org> * Relicense all FSF files to GPLv3 or later. +2007-07-13 Michael Olson <mwolson@gnu.org> + + * erc-goodies.el (erc-get-bg-color-face, erc-get-fg-color-face): + Use erc-error rather than message and beep. + + * erc-sound.el: Indentation fix. + + * erc.el (erc-command-no-process-p): New function that determines + if its argument is an ERC command that can be run when the server + process is not alive. + (erc-cmd-SET, erc-cmd-CLEAR, erc-cmd-COUNTRY, erc-cmd-HELP) + (erc-cmd-LASTLOG, erc-cmd-QUIT, erc-cmd-GQUIT) + (erc-cmd-RECONNECT, erc-cmd-SERVER): Denote that these commands + can be run even when the server process is not alive. + (erc-send-current-line): Call erc-command-no-process-p if the + server process is not alive, to determine if we have a command + that can be run anyway. Thanks to Tom Tromey for the bug report. + (erc-error): New function that either displays a message or throws + an error, depending on whether debug-on-error is non-nil. + (erc-cmd-SERVER, erc-send-current-line): Use it. + +2007-07-10 Michael Olson <mwolson@gnu.org> + + * Relicense all FSF-assigned code to GPLv3. + +2007-06-25 Michael Olson <mwolson@gnu.org> + + * erc.texi (Options): Fix typo. + (Getting Help and Reporting Bugs): Update webpage URL. Make Gmane + part more readable. + +2007-06-20 Michael Olson <mwolson@gnu.org> + + * erc-stamp.el (erc-timestamp-format-left): New option that + specifies the left timestamp to use for + erc-insert-timestamp-left-and-right. + (erc-timestamp-format-right): New option that specifies the right + timestamp to use for erc-insert-timestamp-left-and-right. + (erc-insert-timestamp-function): Change default to + erc-insert-timestamp-left-and-right. + (erc-insert-away-timestamp-function): Ditto. + (erc-timestamp-last-inserted-left) + (erc-timestamp-last-inserted-right): New variables to keep track + of data for erc-insert-timestamp-left-and-right. + (erc-insert-timestamp-left-and-right): New function that places + timestamps on both the left and right sides of the screen, but + only if each timestamp has changed since it was last computed. + Thanks to offby1 for urging me to merge this. + + * erc.el (erc-open-ssl-stream): Display informative error when + ssl.el not found. + (erc-tls): New function to connect using tls.el. + (erc-open-tls-stream): New function to initiate tls connection. + Display informative error when tls.el not found. + +2007-06-19 Michael Olson <mwolson@gnu.org> + + * erc-log.el: Update header with accurate instructions. + +2007-06-17 Michael Olson <mwolson@gnu.org> + + * erc-pkg.el: Update description to match what is currently in + ELPA. + 2007-06-14 Juanma Barranquero <lekktu@gmail.com> * erc-goodies.el (erc-scroll-to-bottom): Remove redundant check. +2007-06-13 Michael Olson <mwolson@gnu.org> + + * erc-compat.el (erc-with-selected-window): New compatibility + macro that implements `with-selected-window'. + + * erc-goodies.el (erc-scroll-to-bottom): Use it. This fixes a bug + with buffer ordering where ERC buffers would move to the top. + Thanks to Ivan Kanis for the patch. + +2007-06-10 Michael Olson <mwolson@gnu.org> + + * erc-log.el (erc-logging-enabled): Fix a bug that occurred when + `erc-log-channels-directory' had the name of a function. + 2007-06-06 Juanma Barranquero <lekktu@gmail.com> * erc.el (erc-show-channel-key-p, erc-startup-file-list): Fix typo in docstring. +2007-06-03 Michael Olson <mwolson@gnu.org> + + * erc-compat.el (erc-view-mode-enter): Make this its own function, + in order to document what we do, and provide sane fallback + behavior. + + * erc.el (erc-toggle-debug-irc-protocol): Don't pass any arguments + to erc-view-mode-enter, since we don't do anything special with + the exit function. This fixes a bug with Emacs 21 and Emacs 22. + Thanks to Leo for noticing. + +2007-05-30 Michael Olson <mwolson@gnu.org> + + * erc-compat.el (erc-user-emacs-directory): New variable that + determines where to find user-specific Emacs settings. For Emacs, + this is usually ~/.emacs.d, and for XEmacs this is usually + ~/.xemacs. + + * erc.el (erc-startup-file-list): Use erc-user-emacs-directory. + +2007-05-28 Michael Olson <mwolson@gnu.org> + + * erc-button.el (erc-button-url-regexp): Recognize parentheses as + part of URLs. Thanks to Lawrence Mitchell for the fix. + +2007-05-26 Michael Olson <mwolson@gnu.org> + + * erc.texi (Modules): Fix references to completion modules. + +2007-05-21 Michael Olson <mwolson@gnu.org> + + * Makefile (SOURCE): Remove erc-pkg.el. + (debclean): New rule to clean old Debian packages of ERC. + (debprepare): Don't modify the released tarball, but copy it as + the .orig.tar.gz file. + (debrelease. debrevision): Remove. + (debinstall): New target that copies the generated Debian file to + a distro-specific location. + (deb): New rule that chains together the stages in building a + Debian package. + (EXTRAS): Add erc-nicklist.el, since it is not release-quality. + (extras): Copy images directory. + + * erc-nicklist.el (erc-nicklist-icons-directory): Use + locate-library to find the "images" directory. This should be + more failsafe. Thanks to Tom Tromey for the idea. + +2007-05-19 Michael Olson <mwolson@gnu.org> + + * Makefile (ELPA): New variable that contains the location of my + local ELPA repository. + (elpa): New rule that makes an ELPA package for ERC. + +2007-04-19 Michael Olson <mwolson@gnu.org> + + * erc.el (erc-parse-prefix): New function that retrieves the + PREFIX server parameter from the current server and returns an + alist of prefix type to prefix character. + (erc-channel-receive-names): Use `erc-parse-prefix' to determine + whether the first character of a nick is a prefix character or + not. This should fix a bug reported by bromine about needing to + type "%" first to complete nicks of people who are "hops" on + Slashnet. This should also support for very exotic IRC server + setups, if any exist. + (erc-update-current-channel-member): Indentation. + +2007-04-15 Michael Olson <mwolson@gnu.org> + + * erc-log.el (erc-generate-log-file-name-function): Docfix. + Mention how to deal with the case for putting log files in + different directories. Change a customization type from `symbol' + to `function'. + (erc-log-channels-directory): Allow this to contain a function + name, which is called with the same args as in + `erc-generate-log-file-name-function'. Thanks to andrewy for the + report and use case. + (erc-current-logfile): Detect if `erc-log-channels-directory' is a + function and call it with arguments if so. + +2007-04-12 Michael Olson <mwolson@gnu.org> + + * erc-backend.el (define-erc-response-handler): Mention that hook + processing stops when the function returns non-nil. This should + help avoid a nasty "gotcha" when making custom functions. Thanks + to John Sullivan for the report. + +2007-04-08 Diane Murray <disumu@x3y2z1.net> + + * erc-nicklist.el (erc-nicklist-voiced-position): Fixed + customization mismatch. + 2007-04-01 Michael Olson <mwolson@gnu.org> * erc.el (erc-version-string): Release ERC 5.2. @@ -49,6 +369,10 @@ tarball. (upload-extras): New rule to upload the extras tarball. It's yucky to replicate upload, but oh well. + (DISTRIBUTOR): New variable used to differentiate between building + packages for Ubuntu and Debian. + (debrelease, debrevision): Use it. + (debbuild): Run linda in addition to lintian. * NEWS: Mention extras tarball. Note which files have been renamed. Note that erc-list is enabled by default, except in diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 349f9137066..4e250490e9c 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -550,11 +550,12 @@ We will store server variables in the buffer given by BUFFER." (defun erc-server-reconnect () "Reestablish the current IRC connection. Make sure you are in an ERC buffer when running this." - (let ((server (erc-server-buffer))) - (unless (and server - (buffer-live-p server)) - (error "Couldn't switch to server buffer")) - (with-current-buffer server + (let ((buffer (erc-server-buffer))) + (unless (buffer-live-p buffer) + (if (eq major-mode 'erc-mode) + (setq buffer (current-buffer)) + (error "Reconnect must be run from an ERC buffer"))) + (with-current-buffer buffer (erc-update-mode-line) (erc-set-active-buffer (current-buffer)) (setq erc-server-last-sent-time 0) @@ -609,39 +610,61 @@ EVENT is the message received from the closed connection process." ;; open-network-stream-nowait error for connection refused (not (string-match "^failed with code 111" event))))) -(defun erc-process-sentinel-1 (event) +(defun erc-process-sentinel-2 (event buffer) + "Called when `erc-process-sentinel-1' has detected an unexpected disconnect." + (if (not (buffer-live-p buffer)) + (erc-update-mode-line) + (with-current-buffer buffer + (let ((reconnect-p (erc-server-reconnect-p event))) + (erc-display-message nil 'error (current-buffer) + (if reconnect-p 'disconnected + 'disconnected-noreconnect)) + (if (not reconnect-p) + ;; terminate, do not reconnect + (progn + (erc-display-message nil 'error (current-buffer) + 'terminated ?e event) + ;; Update mode line indicators + (erc-update-mode-line) + (set-buffer-modified-p nil)) + ;; reconnect + (condition-case err + (progn + (setq erc-server-reconnecting nil) + (erc-server-reconnect) + (setq erc-server-reconnect-count 0)) + (error (when (buffer-live-p buffer) + (set-buffer buffer) + (if (integerp erc-server-reconnect-attempts) + (setq erc-server-reconnect-count + (1+ erc-server-reconnect-count)) + (message "%s ... %s" + "Reconnecting until we succeed" + "kill the ERC server buffer to stop")) + (if (numberp erc-server-reconnect-timeout) + (run-at-time erc-server-reconnect-timeout nil + #'erc-process-sentinel-2 + event buffer) + (error (concat "`erc-server-reconnect-timeout`" + " must be a number"))))))))))) + +(defun erc-process-sentinel-1 (event buffer) "Called when `erc-process-sentinel' has decided that we're disconnecting. Determine whether user has quit or whether erc has been terminated. Conditionally try to reconnect and take appropriate action." - (if erc-server-quitting - ;; normal quit - (progn - (erc-display-message nil 'error (current-buffer) 'finished) - (when erc-kill-server-buffer-on-quit + (with-current-buffer buffer + (if erc-server-quitting + ;; normal quit + (progn + (erc-display-message nil 'error (current-buffer) 'finished) + ;; Update mode line indicators + (erc-update-mode-line) + ;; Kill server buffer if user wants it (set-buffer-modified-p nil) - (kill-buffer (current-buffer)))) - ;; unexpected disconnect - (let ((again t)) - (while again - (setq again nil) - (erc-display-message nil 'error (current-buffer) - (if (erc-server-reconnect-p event) - 'disconnected - 'disconnected-noreconnect)) - (if (erc-server-reconnect-p event) - (condition-case err - (progn - (setq erc-server-reconnecting nil) - (erc-server-reconnect) - (setq erc-server-reconnect-count 0)) - (error (when (integerp erc-server-reconnect-attempts) - (setq erc-server-reconnect-count - (1+ erc-server-reconnect-count)) - (sit-for erc-server-reconnect-timeout) - (setq again t)))) - ;; terminate, do not reconnect - (erc-display-message nil 'error (current-buffer) - 'terminated ?e event)))))) + (when erc-kill-server-buffer-on-quit + (kill-buffer (current-buffer)))) + ;; unexpected disconnect + (erc-process-sentinel-2 event buffer)))) (defun erc-process-sentinel (cproc event) "Sentinel function for ERC process." @@ -668,12 +691,7 @@ Conditionally try to reconnect and take appropriate action." (delete-region (point) (point-max)) ;; Decide what to do with the buffer ;; Restart if disconnected - (erc-process-sentinel-1 event) - ;; Make sure we don't write to the buffer if it has been - ;; killed - (when (buffer-live-p buf) - (erc-update-mode-line) - (set-buffer-modified-p nil)))))) + (erc-process-sentinel-1 event buf))))) ;;;; Sending messages @@ -1054,8 +1072,11 @@ Would expand to: \"Some non-generic variable documentation. Hook called upon receiving a WHOIS server response. + Each function is called with two arguments, the process associated - with the response and the parsed response. + with the response and the parsed response. If the function returns + non-nil, stop processing the hook. Otherwise, continue. + See also `erc-server-311'.\") (defalias 'erc-server-WI 'erc-server-311) @@ -1064,7 +1085,9 @@ Would expand to: Hook called upon receiving a WI server response. Each function is called with two arguments, the process associated - with the response and the parsed response. + with the response and the parsed response. If the function returns + non-nil, stop processing the hook. Otherwise, continue. + See also `erc-server-311'.\")) \(fn (NAME &rest ALIASES) &optional EXTRA-FN-DOC EXTRA-VAR-DOC &rest FN-BODY)" @@ -1078,7 +1101,9 @@ Would expand to: (fn-name (intern (format "erc-server-%s" name))) (hook-doc (format "%sHook called upon receiving a %%s server response. Each function is called with two arguments, the process associated -with the response and the parsed response. +with the response and the parsed response. If the function returns +non-nil, stop processing the hook. Otherwise, continue. + See also `%s'." (if extra-var-doc (concat extra-var-doc "\n\n") diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index 35a20d5279f..81c604d0538 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -99,7 +99,7 @@ above them." (concat "\\(www\\.\\|\\(s?https?\\|" "ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\)" "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?" - "[-a-zA-Z0-9_=!?#$@~`%&*+\\/:;.,]+[-a-zA-Z0-9_=#$@~`%&*+\\/]") + "[-a-zA-Z0-9_=!?#$@~`%&*+\\/:;.,()]+[-a-zA-Z0-9_=#$@~`%&*+\\/()]") "Regular expression that matches URLs." :group 'erc-button :type 'regexp) diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 8be3bed1a78..47bdd94ade2 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -56,6 +56,18 @@ See `erc-encoding-coding-alist'." (format-time-string "%Y-%m-%d" emacs-build-time)) "Time at which Emacs was dumped out.") +;; Emacs 21 and XEmacs do not have user-emacs-directory, but XEmacs +;; has user-init-directory. +(defvar erc-user-emacs-directory + (cond ((boundp 'user-emacs-directory) + user-emacs-directory) + ((boundp 'user-init-directory) + user-init-directory) + (t "~/.emacs.d/")) + "Directory beneath which additional per-user Emacs-specific files +are placed. +Note that this should end with a directory separator.") + ;; XEmacs' `replace-match' does not replace matching subexpressions in strings. (defun erc-replace-match-subexpression-in-string (newtext string match subexp start &optional fixedcase literal) @@ -68,6 +80,7 @@ See `replace-match' for explanations of FIXEDCASE and LITERAL." (replace-match newtext fixedcase literal string)) (t (replace-match newtext fixedcase literal string subexp)))) +(defalias 'erc-with-selected-window 'with-selected-window) (defalias 'erc-cancel-timer 'cancel-timer) (defalias 'erc-make-obsolete 'make-obsolete) (defalias 'erc-make-obsolete-variable 'make-obsolete-variable) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 49a04513733..9131ce68282 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -84,8 +84,7 @@ DISPLAY-START is ignored." ;; works, but it solves the problem, and has no negative side effects. ;; (Fran Litterio, 2003/01/07) (let ((resize-mini-windows nil)) - (save-selected-window - (select-window window) + (erc-with-selected-window window (save-restriction (widen) (when (and erc-insert-marker @@ -282,10 +281,8 @@ The value `erc-interpret-controls-p' must also be t for this to work." "Fetches the right face for background color N (0-15)." (if (stringp n) (setq n (string-to-number n))) (if (not (numberp n)) - (progn - (message "erc-get-bg-color-face: n is NaN: %S" n) - (beep) - 'default) + (prog1 'default + (erc-error "erc-get-bg-color-face: n is NaN: %S" n)) (when (> n 16) (erc-log (format " Wrong color: %s" n)) (setq n (mod n 16))) @@ -298,10 +295,8 @@ The value `erc-interpret-controls-p' must also be t for this to work." "Fetches the right face for foreground color N (0-15)." (if (stringp n) (setq n (string-to-number n))) (if (not (numberp n)) - (progn - (message "erc-get-fg-color-face: n is NaN: %S" n) - (beep) - 'default) + (prog1 'default + (erc-error "erc-get-fg-color-face: n is NaN: %S" n)) (when (> n 16) (erc-log (format " Wrong color: %s" n)) (setq n (mod n 16))) diff --git a/lisp/erc/erc-identd.el b/lisp/erc/erc-identd.el index 4b72ee171b3..db933094e19 100644 --- a/lisp/erc/erc-identd.el +++ b/lisp/erc/erc-identd.el @@ -74,7 +74,8 @@ This can be either a string or a number." (format "%s, %s : USERID : %s : %s\n" port-on-server port-on-client system-type (user-login-name))) - (process-send-eof erc-identd-process))))) + (stop-process erc-identd-process) + (delete-process proc))))) ;;;###autoload (defun erc-identd-start (&optional port) diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 88132afae0c..1733b3d1b00 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -31,17 +31,26 @@ ;; Quick start: ;; -;; (setq erc-enable-logging t) +;; (require 'erc-log) ;; (setq erc-log-channels-directory "/path/to/logfiles") ; must be writable +;; (erc-log-enable) ;; -;; There are two ways to setup logging. The first will write to the log files -;; on each incoming or outgoing line - this may not be optimal on a laptop -;; HDD. To do this, M-x customize-variable erc-modules, and add "log". +;; Or: ;; -;; The second method will save buffers on /part, /quit, or killing the -;; channel buffer. To do this, add the following to your .emacs: +;; M-x customize-variable erc-modules, and add "log". ;; -;; (require 'erc-log) +;; There are two ways to setup logging. The first (default) method +;; will save buffers on /part, /quit, or killing the channel +;; buffer. +;; +;; The second will write to the log files on each incoming or outgoing +;; line - this may not be optimal on a laptop HDD. To use this +;; method, add the following to the above instructions. +;; +;; (setq erc-save-buffer-on-part nil +;; erc-save-queries-on-quit nil +;; erc-log-write-after-send t +;; erc-log-write-after-insert t) ;; ;; If you only want to save logs for some buffers, customise the ;; variable `erc-enable-logging'. @@ -99,15 +108,19 @@ The function must take five arguments: BUFFER, TARGET, NICK, SERVER and PORT. BUFFER is the buffer to be saved, TARGET is the name of the channel, or the target of the query, NICK is the current nick, -SERVER and PORT are the parameters used to connect BUFFERs -`erc-server-process'." +SERVER and PORT are the parameters that were used to connect to BUFFERs +`erc-server-process'. + +If you want to write logs into different directories, make a +custom function which returns the directory part and set +`erc-log-channels-directory' to its name." :group 'erc-log :type '(choice (const :tag "Long style" erc-generate-log-file-name-long) (const :tag "Long, but with network name rather than server" erc-generate-log-file-name-network) (const :tag "Short" erc-generate-log-file-name-short) (const :tag "With date" erc-generate-log-file-name-with-date) - (symbol :tag "Other function"))) + (function :tag "Other function"))) (defcustom erc-truncate-buffer-on-save nil "Truncate any ERC (channel, query, server) buffer when it is saved." @@ -134,10 +147,16 @@ Log files are stored in `erc-log-channels-directory'." "The directory to place log files for channels. Leave blank to disable logging. If not nil, all the channel buffers are logged in separate files in that directory. The -directory should not end with a trailing slash." +directory should not end with a trailing slash. + +If this is the name of a function, the function will be called +with the buffer, target, nick, server, and port arguments. See +`erc-generate-log-file-name-function' for a description of these +arguments." :group 'erc-log :type '(choice directory - (const nil))) + (function "Function") + (const :tag "Disable logging" nil))) (defcustom erc-log-insert-log-on-open nil "*Insert log file contents into the buffer if a log file exists." @@ -186,6 +205,16 @@ This should ideally, be a \"catch-all\" coding system, like `emacs-mule', or `iso-2022-7bit'." :group 'erc-log) +(defcustom erc-log-filter-function nil + "*If non-nil, pass text through the given function before writing it to +a log file. + +The function should take one argument, which is the text to filter." + :group 'erc-log + :type '(choice (function "Function") + (const :tag "No filtering" nil))) + + ;;;###autoload (autoload 'erc-log-mode "erc-log" nil t) (define-erc-module log nil "Automatically logs things you receive on IRC into files. @@ -297,7 +326,8 @@ Logging is enabled if `erc-log-channels-directory' is non-nil, the directory is writeable (it will be created as necessary) and `erc-enable-logging' returns a non-nil value." (and erc-log-channels-directory - (erc-directory-writable-p erc-log-channels-directory) + (or (functionp erc-log-channels-directory) + (erc-directory-writable-p erc-log-channels-directory)) (if (functionp erc-enable-logging) (funcall erc-enable-logging (or buffer (current-buffer))) erc-enable-logging))) @@ -316,14 +346,19 @@ filename is downcased." If BUFFER is nil, the value of `current-buffer' is used. This is determined by `erc-generate-log-file-name-function'. The result is converted to lowercase, as IRC is case-insensitive" - (expand-file-name - (erc-log-standardize-name - (funcall erc-generate-log-file-name-function - (or buffer (current-buffer)) - (or (buffer-name buffer) (erc-default-target)) - (erc-current-nick) - erc-session-server erc-session-port)) - erc-log-channels-directory)) + (unless buffer (setq buffer (current-buffer))) + (let ((target (or (buffer-name buffer) (erc-default-target))) + (nick (erc-current-nick)) + (server erc-session-server) + (port erc-session-port)) + (expand-file-name + (erc-log-standardize-name + (funcall erc-generate-log-file-name-function + buffer target nick server port)) + (if (functionp erc-log-channels-directory) + (funcall erc-log-channels-directory + buffer target nick server port) + erc-log-channels-directory)))) (defun erc-generate-log-file-name-with-date (buffer &rest ignore) "This function computes a short log file name. @@ -380,17 +415,25 @@ You can save every individual message by putting this function on (or buffer (setq buffer (current-buffer))) (when (erc-logging-enabled buffer) (let ((file (erc-current-logfile buffer)) - (coding-system-for-write erc-log-file-coding-system)) + (coding-system erc-log-file-coding-system)) (save-excursion (with-current-buffer buffer (save-restriction (widen) - ;; early on in the initalisation, don't try and write the log out + ;; early on in the initialization, don't try and write the log out (when (and (markerp erc-last-saved-position) (> erc-insert-marker (1+ erc-last-saved-position))) - (write-region (1+ (marker-position erc-last-saved-position)) - (marker-position erc-insert-marker) - file t 'nomessage) + (let ((start (1+ (marker-position erc-last-saved-position))) + (end (marker-position erc-insert-marker))) + (if (functionp erc-log-filter-function) + (let ((text (buffer-substring start end))) + (with-temp-buffer + (insert (funcall erc-log-filter-function text)) + (let ((coding-system-for-write coding-system)) + (write-region (point-min) (point-max) + file t 'nomessage)))) + (let ((coding-system-for-write coding-system)) + (write-region start end file t 'nomessage)))) (if (and erc-truncate-buffer-on-save (interactive-p)) (progn (let ((inhibit-read-only t)) (erase-buffer)) diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el index 4d3d792b1b8..7a1a28198bf 100644 --- a/lisp/erc/erc-sound.el +++ b/lisp/erc/erc-sound.el @@ -30,7 +30,7 @@ ;; Add the following to your .emacs if you want to play sounds. ;; -;; (require 'erc-soud) +;; (require 'erc-sound) ;; (erc-sound-enable) ;; ;; To send requests to other users from within query buffers, type the @@ -125,7 +125,7 @@ See also `play-sound-file'." (if (and (not filepath) erc-default-sound) (setq filepath erc-default-sound)) (cond ((and filepath (file-exists-p filepath)) - (play-sound-file filepath)) + (play-sound-file filepath)) (t (beep))) (erc-log (format "Playing sound file %S" filepath)))) @@ -142,5 +142,11 @@ See also `play-sound-file'." (provide 'erc-sound) -;; arch-tag: 53657d1d-007f-4a20-91c1-588e71cf0cee ;;; erc-sound.el ends here +;; +;; Local Variables: +;; indent-tabs-mode: t +;; tab-width: 8 +;; End: + +;; arch-tag: 53657d1d-007f-4a20-91c1-588e71cf0cee diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index d67dffeaede..3b7f5ba18f2 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -58,16 +58,48 @@ If nil, timestamping is turned off." :type '(choice (const nil) (string))) -(defcustom erc-insert-timestamp-function 'erc-insert-timestamp-right +(defcustom erc-timestamp-format-left "\n[%a %b %e %Y]\n" + "*If set to a string, messages will be timestamped. +This string is processed using `format-time-string'. +Good examples are \"%T\" and \"%H:%M\". + +This timestamp is used for timestamps on the left side of the +screen when `erc-insert-timestamp-function' is set to +`erc-insert-timestamp-left-and-right'. + +If nil, timestamping is turned off." + :group 'erc-stamp + :type '(choice (const nil) + (string))) + +(defcustom erc-timestamp-format-right " [%H:%M]" + "*If set to a string, messages will be timestamped. +This string is processed using `format-time-string'. +Good examples are \"%T\" and \"%H:%M\". + +This timestamp is used for timestamps on the right side of the +screen when `erc-insert-timestamp-function' is set to +`erc-insert-timestamp-left-and-right'. + +If nil, timestamping is turned off." + :group 'erc-stamp + :type '(choice (const nil) + (string))) + +(defcustom erc-insert-timestamp-function 'erc-insert-timestamp-left-and-right "*Function to use to insert timestamps. It takes a single argument STRING which is the final string which all text-properties already appended. This function only cares about inserting this string at the right position. Narrowing is in effect while it is called, so (point-min) and (point-max) determine the region to -operate on." +operate on. + +You will probably want to set +`erc-insert-away-timestamp-function' to the same value." :group 'erc-stamp - :type '(choice (const :tag "Right" erc-insert-timestamp-right) + :type '(choice (const :tag "Both sides" erc-insert-timestamp-left-and-right) + (const :tag "Right" erc-insert-timestamp-right) (const :tag "Left" erc-insert-timestamp-left) function)) @@ -82,12 +114,14 @@ If `erc-timestamp-format' is set, this will not be used." :type '(choice (const nil) (string))) -(defcustom erc-insert-away-timestamp-function 'erc-insert-timestamp-right +(defcustom erc-insert-away-timestamp-function + 'erc-insert-timestamp-left-and-right "*Function to use to insert the away timestamp. See `erc-insert-timestamp-function' for details." :group 'erc-stamp - :type '(choice (const :tag "Right" erc-insert-timestamp-right) + :type '(choice (const :tag "Both sides" erc-insert-timestamp-left-and-right) + (const :tag "Right" erc-insert-timestamp-right) (const :tag "Left" erc-insert-timestamp-left) function)) @@ -160,6 +194,18 @@ or `erc-send-modify-hook'." "Last timestamp inserted into the buffer.") (make-variable-buffer-local 'erc-timestamp-last-inserted) +(defvar erc-timestamp-last-inserted-left nil + "Last timestamp inserted into the left side of the buffer. +This is used when `erc-insert-timestamp-function' is set to +`erc-timestamp-left-and-right'") +(make-variable-buffer-local 'erc-timestamp-last-inserted-left) + +(defvar erc-timestamp-last-inserted-right nil + "Last timestamp inserted into the right side of the buffer. +This is used when `erc-insert-timestamp-function' is set to +`erc-timestamp-left-and-right'") +(make-variable-buffer-local 'erc-timestamp-last-inserted-right) + (defcustom erc-timestamp-only-if-changed-flag t "*Insert timestamp only if its value changed since last insertion. If `erc-insert-timestamp-function' is `erc-insert-timestamp-left', a @@ -272,6 +318,26 @@ be printed just before the window-width." (when erc-timestamp-intangible (erc-put-text-property from (1+ (point)) 'intangible t))))) +(defun erc-insert-timestamp-left-and-right (string) + "This is another function that can be assigned to +`erc-insert-timestamp-function'. If the date is changed, it will +print a blank line, the date, and another blank line. If the time is +changed, it will then print it off to the right." + (let* ((ct (current-time)) + (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) + (ts-right (erc-format-timestamp ct erc-timestamp-format-right))) + ;; insert left timestamp + (unless (string-equal ts-left erc-timestamp-last-inserted-left) + (goto-char (point-min)) + (erc-put-text-property 0 (length ts-left) 'field 'erc-timestamp ts-left) + (insert ts-left) + (setq erc-timestamp-last-inserted-left ts-left)) + ;; insert right timestamp + (let ((erc-timestamp-only-if-changed-flag t) + (erc-timestamp-last-inserted erc-timestamp-last-inserted-right)) + (erc-insert-timestamp-right ts-right) + (setq erc-timestamp-last-inserted-right ts-right)))) + ;; for testing: (setq erc-timestamp-only-if-changed-flag nil) (defun erc-format-timestamp (time format) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index f72a5be1de1..1408adcd942 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -95,6 +95,12 @@ Activity means that there was no user input in the last 10 seconds." :group 'erc-track :type '(repeat string)) +(defcustom erc-track-remove-disconnected-buffers nil + "*If true, remove buffers associated with a server that is +disconnected from `erc-modified-channels-alist'." + :group 'erc-track + :type 'boolean) + (defcustom erc-track-exclude-types '("NICK") "*List of message types to be ignored. This list could look like '(\"JOIN\" \"PART\")." @@ -151,6 +157,16 @@ If nil instead of a function, shortening is disabled." :type '(choice (const :tag "Disabled") function)) +(defcustom erc-track-list-changed-hook nil + "Hook that is run whenever the contents of +`erc-modified-channels-alist' changes. + +This is useful for people that don't use the default mode-line +notification but instead use a separate mechanism to provide +notification of channel activity." + :group 'erc-track + :type 'hook) + (defcustom erc-track-use-faces t "*Use faces in the mode-line. The faces used are the same as used for text in the buffers. @@ -192,12 +208,14 @@ Setting this variable only has effects in GNU Emacs versions above 21.3. Choices are: 'before-modes - add to the beginning of `mode-line-modes' 'after-modes - add to the end of `mode-line-modes' - -Any other value means add to the end of `global-mode-string'." +t - add to the end of `global-mode-string'. +nil - don't add to mode line +" :group 'erc-track :type '(choice (const :tag "Just before mode information" before-modes) (const :tag "Just after mode information" after-modes) - (const :tag "After all other information" nil)) + (const :tag "After all other information" t) + (const :tag "Don't display in mode line" nil)) :set (lambda (sym val) (set sym val) (when (and (boundp 'erc-track-mode) @@ -263,12 +281,18 @@ when there are no more active channels." (defcustom erc-track-switch-direction 'oldest "Direction `erc-track-switch-buffer' should switch. + importance - find buffer with the most important message oldest - find oldest active buffer newest - find newest active buffer leastactive - find buffer with least unseen messages - mostactive - find buffer with most unseen messages." + mostactive - find buffer with most unseen messages. + +If set to 'importance, the importance is determined by position +in `erc-track-faces-priority-list', where first is most +important." :group 'erc-track - :type '(choice (const oldest) + :type '(choice (const importance) + (const oldest) (const newest) (const leastactive) (const mostactive))) @@ -296,7 +320,7 @@ See `erc-track-position-in-mode-line' for possible values." (boundp 'mode-line-modes)) (add-to-list 'mode-line-modes '(t erc-modified-channels-object) t)) - (t + ((eq position t) (when (not global-mode-string) (setq global-mode-string '(""))) ; Padding for mode-line wart (add-to-list 'global-mode-string @@ -644,14 +668,21 @@ only consider active buffers visible.") (setq erc-buffer-activity (erc-current-time)) (erc-track-modified-channels)) +(defun erc-track-get-buffer-window (buffer frame-param) + (if (eq frame-param 'selected-visible) + (if (eq (frame-visible-p (selected-frame)) t) + (get-buffer-window buffer nil) + nil) + (get-buffer-window buffer frame-param))) + (defun erc-buffer-visible (buffer) "Return non-nil when the buffer is visible." (if erc-track-when-inactive (when erc-buffer-activity; could be nil - (and (get-buffer-window buffer erc-track-visibility) + (and (erc-track-get-buffer-window buffer erc-track-visibility) (<= (erc-time-diff erc-buffer-activity (erc-current-time)) erc-buffer-activity-timeout))) - (get-buffer-window buffer erc-track-visibility))) + (erc-track-get-buffer-window buffer erc-track-visibility))) ;;; Tracking the channel modifications @@ -668,18 +699,22 @@ called via `window-configuration-change-hook'. ARGS are ignored." (interactive) (unless erc-modified-channels-update-inside - (let ((erc-modified-channels-update-inside t)) + (let ((erc-modified-channels-update-inside t) + (removed-channel nil)) (mapcar (lambda (elt) (let ((buffer (car elt))) (when (or (not (bufferp buffer)) (not (buffer-live-p buffer)) (erc-buffer-visible buffer) + (and erc-track-remove-disconnected-buffers (not (with-current-buffer buffer - erc-server-connected))) + erc-server-connected)))) + (setq removed-channel t) (erc-modified-channels-remove-buffer buffer)))) erc-modified-channels-alist) + (when removed-channel (erc-modified-channels-display) - (force-mode-line-update t)))) + (force-mode-line-update t))))) (defvar erc-track-mouse-face (if (featurep 'xemacs) 'modeline-mousable @@ -729,10 +764,13 @@ If FACES are provided, color STRING with them." "Set `erc-modified-channels-object' according to `erc-modified-channels-alist'. Use `erc-make-mode-line-buffer-name' to create buttons." - (if (or - (eq 'mostactive erc-track-switch-direction) - (eq 'leastactive erc-track-switch-direction)) - (erc-track-sort-by-activest)) + (cond ((or (eq 'mostactive erc-track-switch-direction) + (eq 'leastactive erc-track-switch-direction)) + (erc-track-sort-by-activest)) + ((eq 'importance erc-track-switch-direction) + (erc-track-sort-by-importance))) + (run-hooks 'erc-track-list-changed-hook) + (unless (eq erc-track-position-in-mode-line nil) (if (null erc-modified-channels-alist) (setq erc-modified-channels-object (erc-modified-channels-object nil)) ;; erc-modified-channels-alist contains all the data we need. To @@ -768,7 +806,7 @@ Use `erc-make-mode-line-buffer-name' to create buttons." (when (featurep 'xemacs) (erc-modified-channels-object nil)) (setq erc-modified-channels-object - (erc-modified-channels-object strings))))) + (erc-modified-channels-object strings)))))) (defun erc-modified-channels-remove-buffer (buffer) "Remove BUFFER from `erc-modified-channels-alist'." @@ -802,8 +840,7 @@ is in `erc-mode'." (if (and (not (erc-buffer-visible (current-buffer))) (not (member this-channel erc-track-exclude)) (not (and erc-track-exclude-server-buffer - (string= this-channel - (buffer-name (erc-server-buffer))))) + (erc-server-buffer-p))) (not (erc-message-type-member (or (erc-find-parsed-property) (point-min)) @@ -847,10 +884,10 @@ is in `erc-mode'." (erc-modified-channels-display))) ;; Else if the active buffer is the current buffer, remove it ;; from our list. - (when (or (erc-buffer-visible (current-buffer)) + (when (and (or (erc-buffer-visible (current-buffer)) (and this-channel - (assq (current-buffer) erc-modified-channels-alist) (member this-channel erc-track-exclude))) + (assq (current-buffer) erc-modified-channels-alist)) ;; Remove it from mode-line if buffer is visible or ;; channel was added to erc-track-exclude recently. (erc-modified-channels-remove-buffer (current-buffer)) @@ -887,6 +924,29 @@ That means the number of unseen messages in a channel." (sort erc-modified-channels-alist (lambda (a b) (> (nth 1 a) (nth 1 b)))))) +(defun erc-track-face-priority (face) + "Return a number indicating the priority of FACE in +`erc-track-faces-priority-list'. Lower number means higher +priority. + +If face is not in `erc-track-faces-priority-list', it will have a +higher number than any other face in that list." + (let ((count 0)) + (catch 'done + (dolist (item erc-track-faces-priority-list) + (if (eq item face) + (throw 'done t) + (setq count (1+ count))))) + count)) + +(defun erc-track-sort-by-importance () + "Sort erc-modified-channels-alist by importance. +That means the position of the face in `erc-track-faces-priority-list'." + (setq erc-modified-channels-alist + (sort erc-modified-channels-alist + (lambda (a b) (< (erc-track-face-priority (cddr a)) + (erc-track-face-priority (cddr b))))))) + (defun erc-track-get-active-buffer (arg) "Return the buffer name of ARG in `erc-modified-channels-alist'. Negative arguments index in the opposite direction. This direction is @@ -898,7 +958,8 @@ relative to `erc-track-switch-direction'" (oldest 'newest) (newest 'oldest) (mostactive 'leastactive) - (leastactive 'mostactive))) + (leastactive 'mostactive) + (importance 'oldest))) (setq arg (- arg))) (setq offset (case dir ((oldest leastactive) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index c26bdf2a19f..2c5786adff3 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -66,7 +66,7 @@ ;;; Code: -(defconst erc-version-string "Version 5.2" +(defconst erc-version-string "Version 5.3 (devel)" "ERC version. This is used by function `erc-version'.") (eval-when-compile (require 'cl)) @@ -836,8 +836,9 @@ See `erc-server-flood-margin' for other flood-related parameters.") ;; Script parameters (defcustom erc-startup-file-list - '("~/.emacs.d/.ercrc.el" "~/.emacs.d/.ercrc" - "~/.ercrc.el" "~/.ercrc" ".ercrc.el" ".ercrc") + (list (concat erc-user-emacs-directory ".ercrc.el") + (concat erc-user-emacs-directory ".ercrc") + "~/.ercrc.el" "~/.ercrc" ".ercrc.el" ".ercrc") "List of files to try for a startup script. The first existent and readable one will get executed. @@ -1460,7 +1461,7 @@ Turning on `erc-mode' runs the hook `erc-mode-hook'." (defconst erc-default-server "irc.freenode.net" "IRC server to use if it cannot be detected otherwise.") -(defconst erc-default-port "6667" +(defconst erc-default-port 6667 "IRC port to use if it cannot be detected otherwise.") (defcustom erc-join-buffer 'buffer @@ -1491,6 +1492,14 @@ This only has effect when `erc-join-buffer' is set to `frame'." :group 'erc-buffers :type 'boolean) +(defcustom erc-reuse-frames t + "*Determines whether new frames are always created. +Non-nil means that a new frame is not created to display an ERC +buffer if there is already a window displaying it. This only has +effect when `erc-join-buffer' is set to `frame'." + :group 'erc-buffers + :type 'boolean) + (defun erc-channel-p (channel) "Return non-nil if CHANNEL seems to be an IRC channel name." (cond ((stringp channel) @@ -1888,14 +1897,16 @@ removed from the list will be disabled." ((eq erc-join-buffer 'bury) nil) ((eq erc-join-buffer 'frame) - (funcall '(lambda (frame) + (when (or (not erc-reuse-frames) + (not (get-buffer-window buffer t))) + ((lambda (frame) (raise-frame frame) (select-frame frame)) (make-frame (or erc-frame-alist default-frame-alist))) (switch-to-buffer buffer) (when erc-frame-dedicated-flag - (set-window-dedicated-p (selected-window) t))) + (set-window-dedicated-p (selected-window) t)))) (t (if (active-minibuffer-window) (display-buffer buffer) @@ -2155,16 +2166,48 @@ Arguments are the same as for `erc'." "Open an SSL stream to an IRC server. The process will be given the name NAME, its target buffer will be BUFFER. HOST and PORT specify the connection target." - (when (require 'tls) - (let ((proc (open-tls-stream name buffer host port))) + (when (condition-case nil + (require 'ssl) + (error (message "You don't have ssl.el. %s" + "Try using `erc-tls' instead.") + nil)) + (let ((proc (open-ssl-stream name buffer host port))) ;; Ugly hack, but it works for now. Problem is it is ;; very hard to detect when ssl is established, because s_client ;; doesn't give any CONNECTIONESTABLISHED kind of message, and ;; most IRC servers send nothing and wait for you to identify. - ;; Disabled when switching to tls.el -- jas - ;(sit-for 5) + (sit-for 5) proc))) +(defun erc-tls (&rest r) + "Interactively select TLS connection parameters and run ERC. +Arguments are the same as for `erc'." + (interactive (erc-select-read-args)) + (let ((erc-server-connect-function 'erc-open-tls-stream)) + (apply 'erc r))) + +(defun erc-open-tls-stream (name buffer host port) + "Open an TLS stream to an IRC server. +The process will be given the name NAME, its target buffer will be +BUFFER. HOST and PORT specify the connection target." + (when (condition-case nil + (require 'tls) + (error (message "You don't have tls.el. %s" + "Try using `erc-ssl' instead.") + nil)) + (open-tls-stream name buffer host port))) + +;;; Displaying error messages + +(defun erc-error (&rest args) + "Pass ARGS to `format', and display the result as an error message. +If `debug-on-error' is set to non-nil, then throw a real error with this +message instead, to make debugging easier." + (if debug-on-error + (apply #'error args) + (apply #'message args) + (beep))) + ;;; Debugging the protocol (defvar erc-debug-irc-protocol nil @@ -2228,7 +2271,7 @@ If ARG is non-nil, show the *erc-protocol* buffer." (interactive "P") (let* ((buf (get-buffer-create "*erc-protocol*"))) (with-current-buffer buf - (erc-view-mode-enter 1) + (erc-view-mode-enter) (when (null (current-local-map)) (let ((inhibit-read-only t)) (insert (erc-make-notice "This buffer displays all IRC protocol traffic exchanged with each server.\n")) @@ -2456,6 +2499,14 @@ See also `erc-server-send'." (match-string 1 arglist) arglist))) +(defun erc-command-no-process-p (str) + "Return non-nil if STR is an ERC command that can be run when the process +is not alive, nil otherwise." + (let ((fun (erc-extract-command-from-line str))) + (and fun + (symbolp (car fun)) + (get (car fun) 'process-not-needed)))) + (defun erc-command-name (cmd) "For CMD being the function name of a ERC command, something like erc-cmd-FOO, this returns a string /FOO." @@ -2565,6 +2616,7 @@ VALUE is computed by evaluating the rest of LINE in Lisp." (defalias 'erc-cmd-VAR 'erc-cmd-SET) (defalias 'erc-cmd-VARIABLE 'erc-cmd-SET) (put 'erc-cmd-SET 'do-not-parse-args t) +(put 'erc-cmd-SET 'process-not-needed t) (defun erc-cmd-default (line) "Fallback command. @@ -2623,6 +2675,7 @@ If no USER argument is specified, list the contents of `erc-ignore-list'." "Clear the window content." (recenter 0) t) +(put 'erc-cmd-CLEAR 'process-not-needed t) (defun erc-cmd-OPS () "Show the ops in the current channel." @@ -2656,6 +2709,7 @@ If no USER argument is specified, list the contents of `erc-ignore-list'." (erc-display-message nil 'notice 'active 'country-unknown ?d tld)) t)) +(put 'erc-cmd-COUNTRY 'process-not-needed t) (defun erc-cmd-AWAY (line) "Mark the user as being away, the reason being indicated by LINE. @@ -2736,6 +2790,7 @@ For a list of user commands (/join /part, ...): t)) (defalias 'erc-cmd-H 'erc-cmd-HELP) +(put 'erc-cmd-HELP 'process-not-needed t) (defun erc-cmd-JOIN (channel &optional key) "Join the channel given in CHANNEL, optionally with KEY. @@ -2973,6 +3028,7 @@ the matching is case-sensitive." (occur line) t) (put 'erc-cmd-LASTLOG 'do-not-parse-args t) +(put 'erc-cmd-LASTLOG 'process-not-needed t) (defun erc-send-message (line &optional force) "Send LINE to the current channel or user and display it. @@ -3195,20 +3251,34 @@ the message given by REASON." (defalias 'erc-cmd-EXIT 'erc-cmd-QUIT) (defalias 'erc-cmd-SIGNOFF 'erc-cmd-QUIT) (put 'erc-cmd-QUIT 'do-not-parse-args t) +(put 'erc-cmd-QUIT 'process-not-needed t) (defun erc-cmd-GQUIT (reason) "Disconnect from all servers at once with the same quit REASON." (erc-with-all-buffers-of-server nil #'erc-open-server-buffer-p - (erc-cmd-QUIT reason))) + (erc-cmd-QUIT reason)) + (when erc-kill-queries-on-quit + ;; if the query buffers have not been killed within 4 seconds, + ;; kill them + (run-at-time + 4 nil + (lambda () + (dolist (buffer (erc-buffer-list (lambda (buf) + (not (erc-server-buffer-p buf))))) + (kill-buffer buffer))))) + t) (defalias 'erc-cmd-GQ 'erc-cmd-GQUIT) (put 'erc-cmd-GQUIT 'do-not-parse-args t) +(put 'erc-cmd-GQUIT 'process-not-needed t) (defun erc-cmd-RECONNECT () "Try to reconnect to the current IRC server." - (let ((buffer (or (erc-server-buffer) (current-buffer))) + (let ((buffer (erc-server-buffer)) (process nil)) - (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) + (unless (buffer-live-p buffer) + (setq buffer (current-buffer))) + (with-current-buffer buffer (setq erc-server-quitting nil) (setq erc-server-reconnecting t) (setq erc-server-reconnect-count 0) @@ -3218,6 +3288,7 @@ the message given by REASON." (erc-server-reconnect)) (setq erc-server-reconnecting nil))) t) +(put 'erc-cmd-RECONNECT 'process-not-needed t) (defun erc-cmd-SERVER (server) "Connect to SERVER, leaving existing connection intact." @@ -3225,9 +3296,9 @@ the message given by REASON." (condition-case nil (erc :server server :nick (erc-current-nick)) (error - (message "Cannot find host %s." server) - (beep))) + (erc-error "Cannot find host %s." server))) t) +(put 'erc-cmd-SERVER 'process-not-needed t) (eval-when-compile (defvar motif-version-string) @@ -4411,33 +4482,65 @@ See also `erc-channel-begin-receiving-names'." erc-channel-users) (setq erc-channel-new-member-names nil)) +(defun erc-parse-prefix () + "Return an alist of valid prefix character types and their representations. +Example: (operator) o => @, (voiced) v => +." + (let ((str (or (cdr (assoc "PREFIX" (erc-with-server-buffer + erc-server-parameters))) + ;; provide a sane default + "(ov)@+")) + types chars) + (when (string-match "^(\\([^)]+\\))\\(.+\\)$" str) + (setq types (match-string 1 str) + chars (match-string 2 str)) + (let ((len (min (length types) (length chars))) + (i 0) + (alist nil)) + (while (< i len) + (setq alist (cons (cons (elt types i) (elt chars i)) + alist)) + (setq i (1+ i))) + alist)))) + (defun erc-channel-receive-names (names-string) "This function is for internal use only. Update `erc-channel-users' according to NAMES-STRING. NAMES-STRING is a string listing some of the names on the channel." - (let (names name op voice) - ;; We need to delete "" because in XEmacs, (split-string "a ") - ;; returns ("a" ""). - (setq names (delete "" (split-string names-string))) - (let ((erc-channel-members-changed-hook nil)) - (dolist (item names) - (cond ((string-match "^@\\(.*\\)$" item) - (setq name (match-string 1 item) - op 'on - voice 'off)) - ((string-match "^+\\(.*\\)$" item) - (setq name (match-string 1 item) - op 'off - voice 'on)) - (t (setq name item - op 'off - voice 'off))) - (puthash (erc-downcase name) t - erc-channel-new-member-names) - (erc-update-current-channel-member - name name t op voice))) + (let (prefix op-ch voice-ch names name op voice) + (setq prefix (erc-parse-prefix)) + (setq op-ch (cdr (assq ?o prefix)) + voice-ch (cdr (assq ?v prefix))) + ;; We need to delete "" because in XEmacs, (split-string "a ") + ;; returns ("a" ""). + (setq names (delete "" (split-string names-string))) + (let ((erc-channel-members-changed-hook nil)) + (dolist (item names) + (let ((updatep t) + ch) + (if (rassq (elt item 0) prefix) + (cond ((= (length item) 1) + (setq updatep nil)) + ((eq (elt item 0) op-ch) + (setq name (substring item 1) + op 'on + voice 'off)) + ((eq (elt item 0) voice-ch) + (setq name (substring item 1) + op 'off + voice 'on)) + (t (setq name (substring item 1) + op 'off + voice 'off))) + (setq name item + op 'off + voice 'off)) + (when updatep + (puthash (erc-downcase name) t + erc-channel-new-member-names) + (erc-update-current-channel-member + name name t op voice))))) (run-hooks 'erc-channel-members-changed-hook))) (defcustom erc-channel-members-changed-hook nil @@ -4529,15 +4632,15 @@ See also: `erc-update-user' and `erc-update-channel-member'." (setq changed t) (setf (erc-channel-user-op cuser) (cond ((eq op 'on) t) - ((eq op 'off) nil) - (t op)))) + ((eq op 'off) nil) + (t op)))) (when (and voice (not (eq (erc-channel-user-voice cuser) voice))) (setq changed t) (setf (erc-channel-user-voice cuser) (cond ((eq voice 'on) t) - ((eq voice 'off) nil) - (t voice)))) + ((eq voice 'off) nil) + (t voice)))) (when update-message-time (setf (erc-channel-user-last-message-time cuser) (current-time))) (setq user-changed @@ -4559,11 +4662,11 @@ See also: `erc-update-user' and `erc-update-channel-member'." (erc-server-user-buffers user)))) (setq cuser (make-erc-channel-user :op (cond ((eq op 'on) t) - ((eq op 'off) nil) - (t op)) + ((eq op 'off) nil) + (t op)) :voice (cond ((eq voice 'on) t) - ((eq voice 'off) nil) - (t voice)) + ((eq voice 'off) nil) + (t voice)) :last-message-time (if update-message-time (current-time)))) (puthash (erc-downcase nick) (cons user cuser) @@ -4892,39 +4995,37 @@ Specifically, return the position of `erc-insert-marker'." (interactive) (save-restriction (widen) - (cond - ((< (point) (erc-beg-of-input-line)) - (message "Point is not in the input area") - (beep)) - ((not (erc-server-buffer-live-p)) - (message "ERC: No process running") - (beep)) - (t - (erc-set-active-buffer (current-buffer)) + (if (< (point) (erc-beg-of-input-line)) + (erc-error "Point is not in the input area") (let ((inhibit-read-only t) (str (erc-user-input)) (old-buf (current-buffer))) - - ;; Kill the input and the prompt - (delete-region (erc-beg-of-input-line) - (erc-end-of-input-line)) - - (unwind-protect - (erc-send-input str) - ;; Fix the buffer if the command didn't kill it - (when (buffer-live-p old-buf) - (with-current-buffer old-buf - (save-restriction - (widen) - (goto-char (point-max)) - (set-marker (process-mark erc-server-process) (point)) - (set-marker erc-insert-marker (point)) - (let ((buffer-modified (buffer-modified-p))) - (erc-display-prompt) - (set-buffer-modified-p buffer-modified)))))) - - ;; Only when last hook has been run... - (run-hook-with-args 'erc-send-completed-hook str)))))) + (if (and (not (erc-server-buffer-live-p)) + (not (erc-command-no-process-p str))) + (erc-error "ERC: No process running") + (erc-set-active-buffer (current-buffer)) + + ;; Kill the input and the prompt + (delete-region (erc-beg-of-input-line) + (erc-end-of-input-line)) + + (unwind-protect + (erc-send-input str) + ;; Fix the buffer if the command didn't kill it + (when (buffer-live-p old-buf) + (with-current-buffer old-buf + (save-restriction + (widen) + (goto-char (point-max)) + (when (processp erc-server-process) + (set-marker (process-mark erc-server-process) (point))) + (set-marker erc-insert-marker (point)) + (let ((buffer-modified (buffer-modified-p))) + (erc-display-prompt) + (set-buffer-modified-p buffer-modified)))))) + + ;; Only when last hook has been run... + (run-hook-with-args 'erc-send-completed-hook str)))))) (defun erc-user-input () "Return the input of the user in the current buffer." @@ -4985,7 +5086,8 @@ This returns non-nil only if we actually send anything." (erc-put-text-property beg (point) 'face 'erc-command-indicator-face) (insert "\n")) - (set-marker (process-mark erc-server-process) (point)) + (when (processp erc-server-process) + (set-marker (process-mark erc-server-process) (point))) (set-marker erc-insert-marker (point)) (save-excursion (save-restriction @@ -5004,7 +5106,8 @@ current position." (erc-put-text-property beg (point) 'face 'erc-input-face)) (insert "\n") - (set-marker (process-mark erc-server-process) (point)) + (when (processp erc-server-process) + (set-marker (process-mark erc-server-process) (point))) (set-marker erc-insert-marker (point)) (save-excursion (save-restriction diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index 6dc02517ec1..aaad664918f 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -168,6 +168,35 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine." (put 'eshell/man 'eshell-no-numeric-conversions t) +(defun eshell/info (&rest args) + "Runs the info command in-frame with the same behaviour as command-line `info', ie: + 'info' => goes to top info window + 'info arg1' => IF arg1 is a file, then visits arg1 + 'info arg1' => OTHERWISE goes to top info window and then menu item arg1 + 'info arg1 arg2' => does action for arg1 (either visit-file or menu-item) and then menu item arg2 + etc." + (require 'info) + (let ((file (cond + ((not (stringp (car args))) + nil) + ((file-exists-p (expand-file-name (car args))) + (expand-file-name (car args))) + ((file-exists-p (concat (expand-file-name (car args)) ".info")) + (concat (expand-file-name (car args)) ".info"))))) + + ;; If the first arg is a file, then go to that file's Top node + ;; Otherwise, go to the global directory + (if file + (progn + (setq args (cdr args)) + (Info-find-node file "Top")) + (Info-directory)) + + ;; Treat all remaining args as menu references + (while args + (Info-menu (car args)) + (setq args (cdr args))))) + (defun eshell-remove-entries (path files &optional top-level) "From PATH, remove all of the given FILES, perhaps interactively." (while files @@ -930,7 +959,10 @@ Show wall-clock time elapsed during execution of COMMAND.") (add-hook 'eshell-post-command-hook 'eshell-show-elapsed-time nil t) ;; after setting (throw 'eshell-replace-command - (eshell-parse-command (car time-args) (cdr time-args)))))) + (eshell-parse-command (car time-args) +;;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2007-08/msg00205.html + (eshell-stringify-list + (eshell-flatten-list (cdr time-args)))))))) (defalias 'eshell/whoami 'user-login-name) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index e1a0f73a866..2da81996dfd 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -165,7 +165,8 @@ number, if the function `eshell-truncate-buffer' is on :group 'eshell-mode) (defcustom eshell-output-filter-functions - '(eshell-handle-control-codes + '(eshell-postoutput-scroll-to-bottom + eshell-handle-control-codes eshell-watch-for-password-prompt) "*Functions to call before output is displayed. These functions are only called for output that is displayed @@ -883,9 +884,6 @@ This function should be in the list `eshell-output-filter-functions'." nil t) (set-buffer current)))) -(custom-add-option 'eshell-output-filter-functions - 'eshell-postoutput-scroll-to-bottom) - (defun eshell-beginning-of-input () "Return the location of the start of the previous input." eshell-last-input-start) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 0cf879fd264..89d9d75c60e 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,64 @@ +2007-10-04 Juanma Barranquero <lekktu@gmail.com> + + * sieve-manage.el (sieve-manage-interactive-login): Doc fix. + (sieve-manage-open): Use `mapc' instead of `mapcar'. + +2007-10-02 Stefan Monnier <monnier@iro.umontreal.ca> + + * gnus-uu.el (gnus-uu-reginize-string, gnus-uu-expand-numbers): + Don't hardcode point-min==1. + +2007-09-30 David Kastrup <dak@gnu.org> + + * gnus-art.el (gnus-article-reply-with-original) + (gnus-article-followup-with-original): When `transient-mark-mode' is + off, refrain from active-region behavior for followups. + +2007-10-08 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-util.el (mm-charset-synonym-alist): Alias gbk to cp936. + +2007-10-04 Reiner Steib <Reiner.Steib@gmx.de> + + * Relicense "GPLv2 or later" files to "GPLv3 or later". + +2007-09-13 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-newsgroup-maximum-articles): Move from gnus.el. + Suggested by Leo <sdl.web@gmail.com>. + + * gnus.el: Do. + +2007-09-13 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus.el (gnus-newsgroup-maximum-articles): Rename from + gnus-maximum-newsgroup. Suggested by Leo <sdl.web@gmail.com>. + + * gnus-agent.el (gnus-agent-fetch-headers): Do. + + * gnus-sum.el (gnus-articles-to-read, gnus-list-of-unread-articles) + (gnus-list-of-read-articles, gnus-sequence-of-unread-articles): Do. + +2007-09-13 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnmbox.el (nnmbox-request-article): Don't assume delim regexp matches + newline. + (nnmbox-request-accept-article): Don't change article in source buffer; + narrow to header to use message-fetch-field rather than + nnmail-fetch-field; use with-current-buffer instead of save-excursion. + (nnmbox-request-replace-article): Quote lines that'll be misidentified + as delimiters; make sure article ends with newline. + (nnmbox-delete-mail): Correct last position of article to be deleted; + ignore X-Gnus-Newsgroup header in article body. + (nnmbox-save-mail): Quote lines looking like delimiters at the right + positions; make sure article ends with newline. + +2007-09-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-cus.el (gnus-score-extra): New widget. + (gnus-score-extra-convert): New function. + (gnus-score-customize): Use it for Extra. + 2007-08-23 Katsumi Yamaoka <yamaoka@jpl.org> * mml.el (mml-generate-mime): Make sure it uses multibyte temp buffer. diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 347b57983e6..21b442aebbb 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -1765,12 +1765,13 @@ article numbers will be returned." (gnus-agent-find-parameter group 'agent-predicate))))) (articles (if fetch-all - (if gnus-maximum-newsgroup + (if gnus-newsgroup-maximum-articles (let ((active (gnus-active group))) (gnus-uncompress-range (cons (max (car active) (- (cdr active) - gnus-maximum-newsgroup -1)) + gnus-newsgroup-maximum-articles + -1)) (cdr active)))) (gnus-uncompress-range (gnus-active group))) (gnus-list-of-unread-articles group))) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 696222e0043..a02a7d153bb 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -5749,7 +5749,7 @@ the entire article will be yanked." (interactive "P") (let ((article (cdr gnus-article-current)) contents) - (if (not (gnus-mark-active-p)) + (if (not (gnus-region-active-p)) (with-current-buffer gnus-summary-buffer (gnus-summary-reply (list (list article)) wide)) (setq contents (buffer-substring (point) (mark t))) @@ -5768,7 +5768,7 @@ the entire article will be yanked." (interactive) (let ((article (cdr gnus-article-current)) contents) - (if (not (gnus-mark-active-p)) + (if (not (gnus-region-active-p)) (with-current-buffer gnus-summary-buffer (gnus-summary-followup (list (list article)))) (setq contents (buffer-substring (point) (mark t))) diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index f1719eb04f4..1470f0cbac1 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -766,6 +766,67 @@ eh?"))) ,group)))) widget) +(define-widget 'gnus-score-extra 'group + "Edit score entries for extra headers." + :convert-widget 'gnus-score-extra-convert) + +(defun gnus-score-extra-convert (widget) + ;; Set args appropriately. + (let* ((tag (widget-get widget :tag)) + (item `(const :format "" :value ,(downcase tag))) + (match '(string :tag "Match")) + (score '(choice :tag "Score" + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) + (expire '(choice :tag "Expire" + (const :tag "off" nil) + (integer :format "%v" + :hide-front-space t))) + (type '(choice :tag "Type" + :value s + ;; I should really create a forgiving :match + ;; function for each type below, that only + ;; looked at the first letter. + (const :tag "Regexp" r) + (const :tag "Regexp (fixed case)" R) + (const :tag "Substring" s) + (const :tag "Substring (fixed case)" S) + (const :tag "Exact" e) + (const :tag "Exact (fixed case)" E) + (const :tag "Word" w) + (const :tag "Word (fixed case)" W) + (const :tag "default" nil))) + (header (if gnus-extra-headers + (let (name) + `(choice :tag "Header" + ,@(mapcar (lambda (h) + (setq name (symbol-name h)) + (list 'const :tag name name)) + gnus-extra-headers) + (string :tag "Other" :format "%v"))) + '(string :tag "Header"))) + (group `(group ,match ,score ,expire ,type ,header)) + (doc (concat (or (widget-get widget :doc) + (concat "Change score based on the " tag + " header.\n"))))) + (widget-put + widget :args + `(,item + (repeat :inline t + :indent 0 + :tag ,tag + :doc ,doc + :format "%t:\n%h%v%i\n\n" + (choice :format "%v" + :value ("" nil nil s + ,(if gnus-extra-headers + (symbol-name (car gnus-extra-headers)) + "")) + ,group + sexp))))) + widget) + (defvar gnus-custom-scores) (defvar gnus-custom-score-alist) @@ -822,7 +883,7 @@ if you do all your changes will be lost. ") (gnus-score-string :tag "Subject") (gnus-score-string :tag "References") (gnus-score-string :tag "Xref") - (gnus-score-string :tag "Extra") + (gnus-score-extra :tag "Extra") (gnus-score-string :tag "Message-ID") (gnus-score-integer :tag "Lines") (gnus-score-integer :tag "Chars") diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 851ec88c96f..36e93796a63 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1029,6 +1029,17 @@ default charset will be used instead." :type '(repeat symbol) :group 'gnus-charset) +(defcustom gnus-newsgroup-maximum-articles nil + "The maximum number of articles a newsgroup. +If this is a number, old articles in a newsgroup exceeding this number +are silently ignored. If it is nil, no article is ignored. Note that +setting this variable to a number might prevent you from reading very +old articles." + :group 'gnus-group-select + :version "22.2" + :type '(choice (const :tag "No limit" nil) + integer)) + (gnus-define-group-parameter ignored-charsets :type list @@ -5472,11 +5483,13 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; articles in the group, or (if that's nil), the ;; articles in the cache. (or - (if gnus-maximum-newsgroup + (if gnus-newsgroup-maximum-articles (let ((active (gnus-active group))) (gnus-uncompress-range (cons (max (car active) - (- (cdr active) gnus-maximum-newsgroup -1)) + (- (cdr active) + gnus-newsgroup-maximum-articles + -1)) (cdr active)))) (gnus-uncompress-range (gnus-active group))) (gnus-cache-articles-in-group group)) @@ -6540,8 +6553,9 @@ displayed, no centering will be performed." (let* ((read (gnus-info-read (gnus-get-info group))) (active (or (gnus-active group) (gnus-activate-group group))) (last (cdr active)) - (bottom (if gnus-maximum-newsgroup - (max (car active) (- last gnus-maximum-newsgroup -1)) + (bottom (if gnus-newsgroup-maximum-articles + (max (car active) + (- last gnus-newsgroup-maximum-articles -1)) (car active))) first nlast unread) ;; If none are read, then all are unread. @@ -6585,9 +6599,11 @@ displayed, no centering will be performed." (gnus-list-range-difference (gnus-sorted-complement (gnus-uncompress-range - (if gnus-maximum-newsgroup + (if gnus-newsgroup-maximum-articles (cons (max (car active) - (- (cdr active) gnus-maximum-newsgroup -1)) + (- (cdr active) + gnus-newsgroup-maximum-articles + -1)) (cdr active)) active)) (gnus-list-of-unread-articles group)) @@ -6601,8 +6617,9 @@ displayed, no centering will be performed." (let* ((read (gnus-info-read (gnus-get-info group))) (active (or (gnus-active group) (gnus-activate-group group))) (last (cdr active)) - (bottom (if gnus-maximum-newsgroup - (max (car active) (- last gnus-maximum-newsgroup -1)) + (bottom (if gnus-newsgroup-maximum-articles + (max (car active) + (- last gnus-newsgroup-maximum-articles -1)) (car active))) first nlast unread) ;; If none are read, then all are unread. diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 94fb854c960..86253f0deef 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -1089,7 +1089,7 @@ When called interactively, prompt for REGEXP." nil t) (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil)))) - (goto-char 1) + (goto-char (point-min)) (while (re-search-forward "[ \t]+" nil t) (replace-match "[ \t]+" t t)) @@ -1190,7 +1190,7 @@ When called interactively, prompt for REGEXP." (format "%06d" (string-to-number (buffer-substring (match-beginning 0) (match-end 0))))))) - (setq string (buffer-substring 1 (point-max))) + (setq string (buffer-substring (point-min) (point-max))) (setcar (car string-list) string) (setq string-list (cdr string-list)))) out-list)) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 3f75bba6d1c..0e8e9908cf4 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1501,17 +1501,6 @@ If it is nil, no confirmation is required." :type '(choice (const :tag "No limit" nil) integer)) -(defcustom gnus-maximum-newsgroup nil - "The maximum number of articles a newsgroup. -If this is a number, old articles in a newsgroup exceeding this number -are silently ignored. If it is nil, no article is ignored. Note that -setting this variable to a number might prevent you from reading very -old articles." - :group 'gnus-group-select - :version "22.2" - :type '(choice (const :tag "No limit" nil) - integer)) - (defcustom gnus-use-long-file-name (not (memq system-type '(usg-unix-v xenix))) "*Non-nil means that the default name of a file to save articles in is the group name. If it's nil, the directory form of the group name is used instead. diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index eb67313c92a..2c9e4045eca 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -256,6 +256,12 @@ the alias. Else windows-NUMBER is used." ,@(when (and (not (mm-coding-system-p 'windows-31j)) (mm-coding-system-p 'cp932)) '((windows-31j . cp932))) + ;; Charset name: GBK, Charset aliases: CP936, MS936, windows-936 + ;; http://www.iana.org/assignments/charset-reg/GBK + ;; Emacs 22.1 has cp936, but not gbk, so we alias it: + ,@(when (and (not (mm-coding-system-p 'gbk)) + (mm-coding-system-p 'cp936)) + '((gbk . cp936))) ) "A mapping from unknown or invalid charset names to the real charset names. diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index 6127974d24a..fd8ec27d225 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -153,11 +153,11 @@ (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) (setq start (point)) (forward-line 1) - (or (and (re-search-forward - (concat "^" message-unix-mail-delimiter) nil t) - (forward-line -1)) - (goto-char (point-max))) - (setq stop (point)) + (setq stop (if (re-search-forward (concat "^" + message-unix-mail-delimiter) + nil 'move) + (match-beginning 0) + (point))) (let ((nntp-server-buffer (or buffer nntp-server-buffer))) (set-buffer nntp-server-buffer) (erase-buffer) @@ -313,39 +313,45 @@ (nnmbox-possibly-change-newsgroup group server) (nnmail-check-syntax) (let ((buf (current-buffer)) - result) - (goto-char (point-min)) - ;; The From line may have been quoted by movemail. - (when (looking-at (concat ">" message-unix-mail-delimiter)) - (delete-char 1)) - (if (looking-at "X-From-Line: ") - (replace-match "From ") - (insert "From nobody " (current-time-string) "\n")) + result cont) (and (nnmail-activate 'nnmbox) - (progn - (set-buffer buf) + (with-temp-buffer + (insert-buffer-substring buf) (goto-char (point-min)) - (search-forward "\n\n" nil t) - (forward-line -1) + (cond (;; The From line may have been quoted by movemail. + (looking-at (concat ">" message-unix-mail-delimiter)) + (delete-char 1) + (forward-line 1)) + ((looking-at "X-From-Line: ") + (replace-match "From ") + (forward-line 1)) + (t + (insert "From nobody " (current-time-string) "\n"))) + (narrow-to-region (point) + (if (search-forward "\n\n" nil 'move) + (1- (point)) + (point))) (while (re-search-backward "^X-Gnus-Newsgroup: " nil t) (delete-region (point) (progn (forward-line 1) (point)))) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (message-fetch-field "message-id") group - (nnmail-fetch-field "subject") - (nnmail-fetch-field "from"))) + (message-fetch-field "subject") + (message-fetch-field "from"))) + (widen) (setq result (if (stringp group) (list (cons group (nnmbox-active-number group))) (nnmail-article-group 'nnmbox-active-number))) - (if (and (null result) - (yes-or-no-p "Moved to `junk' group; delete article? ")) - (setq result 'junk) - (setq result (car (nnmbox-save-mail result))))) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (prog1 + (if (and (null result) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + (setq result 'junk) + (setq result (car (nnmbox-save-mail result)))) + (setq cont (buffer-string)))) + (with-current-buffer nnmbox-mbox-buffer (goto-char (point-max)) - (insert-buffer-substring buf) + (insert cont) (when last (when nnmail-cache-accepted-message-ids (nnmail-cache-close)) @@ -360,7 +366,20 @@ (if (not (nnmbox-find-article article)) nil (nnmbox-delete-mail t t) - (insert-buffer-substring buffer) + (insert + (with-temp-buffer + (insert-buffer-substring buffer) + (goto-char (point-min)) + (when (looking-at "X-From-Line:") + (delete-region (point) (progn (forward-line 1) (point)))) + (while (re-search-forward (concat "^" message-unix-mail-delimiter) + nil t) + (goto-char (match-beginning 0)) + (insert ">")) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (buffer-string))) (nnmbox-save-buffer) t))) @@ -430,21 +449,20 @@ (save-excursion (save-restriction (narrow-to-region - (save-excursion - (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) - (if leave-delim (progn (forward-line 1) (point)) - (match-beginning 0))) - (progn - (forward-line 1) - (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) - nil t) - (if (and (not (bobp)) leave-delim) - (progn (forward-line -2) (point)) - (match-beginning 0))) - (point-max)))) + (prog2 + (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) + (if leave-delim (progn (forward-line 1) (point)) + (match-beginning 0)) + (forward-line 1)) + (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) + nil t) + (match-beginning 0)) + (point-max))) (goto-char (point-min)) ;; Only delete the article if no other group owns it as well. - (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) + (when (or force + (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)) + (search-backward "\n\n" nil t)) (delete-region (point-min) (point-max)))))) (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server) @@ -552,24 +570,26 @@ (let ((delim (concat "^" message-unix-mail-delimiter))) (goto-char (point-min)) ;; This might come from somewhere else. - (unless (looking-at delim) - (insert "From nobody " (current-time-string) "\n") - (goto-char (point-min))) + (if (looking-at delim) + (forward-line 1) + (insert "From nobody " (current-time-string) "\n")) ;; Quote all "From " lines in the article. - (forward-line 1) (while (re-search-forward delim nil t) - (beginning-of-line) - (insert "> ")) - (nnmail-insert-lines) - (nnmail-insert-xref group-art) - (nnmbox-insert-newsgroup-line group-art) - (let ((alist group-art)) - (while alist - (nnmbox-record-active-article (car alist)) - (setq alist (cdr alist)))) - (run-hooks 'nnmail-prepare-save-mail-hook) - (run-hooks 'nnmbox-prepare-save-mail-hook) - group-art)) + (goto-char (match-beginning 0)) + (insert ">"))) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (nnmail-insert-lines) + (nnmail-insert-xref group-art) + (nnmbox-insert-newsgroup-line group-art) + (let ((alist group-art)) + (while alist + (nnmbox-record-active-article (car alist)) + (setq alist (cdr alist)))) + (run-hooks 'nnmail-prepare-save-mail-hook) + (run-hooks 'nnmbox-prepare-save-mail-hook) + group-art) (defun nnmbox-insert-newsgroup-line (group-art) (save-excursion diff --git a/lisp/gnus/sieve-manage.el b/lisp/gnus/sieve-manage.el index e33e5d87ca6..2f0e54a234b 100644 --- a/lisp/gnus/sieve-manage.el +++ b/lisp/gnus/sieve-manage.el @@ -183,7 +183,7 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") (defun sieve-manage-interactive-login (buffer loginfunc) "Login to server in BUFFER. LOGINFUNC is passed a username and a password, it should return t if -it where sucessful authenticating itself to the server, nil otherwise. +it was successful authenticating itself to the server, nil otherwise. Returns t if login was successful, nil otherwise." (with-current-buffer buffer (make-local-variable 'sieve-manage-username) @@ -372,7 +372,7 @@ Optional variable BUFFER is buffer (buffer, or string naming buffer) to work in." (setq buffer (or buffer (format " *sieve* %s:%d" server (or port 2000)))) (with-current-buffer (get-buffer-create buffer) - (mapcar 'make-local-variable sieve-manage-local-variables) + (mapc 'make-local-variable sieve-manage-local-variables) (sieve-manage-disable-multibyte) (buffer-disable-undo) (setq sieve-manage-server (or server sieve-manage-server)) diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 57ed3e5bb1f..5ea618c7b50 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -1170,9 +1170,9 @@ (?C . ?K) ; Chinese - Katakana )) -;;; Local Variables: -;;; coding: utf-8-emacs -;;; End: +;; Local Variables: +;; coding: utf-8-emacs +;; End: -;;; arch-tag: 85889c35-9f4d-4912-9bf5-82de31b0d42d +;; arch-tag: 85889c35-9f4d-4912-9bf5-82de31b0d42d ;;; characters.el ends here diff --git a/lisp/international/encoded-kb.el b/lisp/international/encoded-kb.el index 3956fd51bd3..62fa884a9ac 100644 --- a/lisp/international/encoded-kb.el +++ b/lisp/international/encoded-kb.el @@ -34,7 +34,7 @@ ;; Usually this map is empty (even if Encoded-kbd mode is on), but if ;; the keyboard coding system is iso-2022-based, it defines dummy key ;; bindings for ESC $ ..., etc. so that those bindings in -;; key-translation-map take effect. +;; input-decode-map take effect. (defconst encoded-kbd-mode-map (make-sparse-keymap) "Keymap for Encoded-kbd minor mode.") @@ -236,7 +236,7 @@ The following key sequence may cause multilingual text insertion." len (1- len))) (vector char))) -(defun encoded-kbd-setup-keymap (coding) +(defun encoded-kbd-setup-keymap (keymap coding) ;; At first, reset the keymap. (define-key encoded-kbd-mode-map "\e" nil) ;; Then setup the keymap according to the keyboard coding system. @@ -244,7 +244,7 @@ The following key sequence may cause multilingual text insertion." ((eq (coding-system-type coding) 'shift-jis) (let ((i 128)) (while (< i 256) - (define-key key-translation-map + (define-key keymap (vector i) 'encoded-kbd-self-insert-sjis) (setq i (1+ i)))) 8) @@ -260,7 +260,7 @@ The following key sequence may cause multilingual text insertion." (let ((from (max (car elt) 128)) (to (cdr elt))) (while (<= from to) - (define-key key-translation-map + (define-key keymap (vector from) 'encoded-kbd-self-insert-charset) (setq from (1+ from))))) 8) @@ -285,20 +285,20 @@ The following key sequence may cause multilingual text insertion." (aset encoded-kbd-iso2022-invocations 1 1)) (when (memq 'designation flags) (define-key encoded-kbd-mode-map "\e" 'encoded-kbd-iso2022-esc-prefix) - (define-key key-translation-map "\e" 'encoded-kbd-iso2022-esc-prefix)) + (define-key keymap "\e" 'encoded-kbd-iso2022-esc-prefix)) (when (or (aref designation 2) (aref designation 3)) - (define-key key-translation-map + (define-key keymap [?\216] 'encoded-kbd-iso2022-single-shift) - (define-key key-translation-map + (define-key keymap [?\217] 'encoded-kbd-iso2022-single-shift)) (or (eq (aref designation 0) 'ascii) (dotimes (i 96) - (define-key key-translation-map + (define-key keymap (vector (+ 32 i)) 'encoded-kbd-self-insert-iso2022-7bit))) (if (memq '7-bit flags) t (dotimes (i 96) - (define-key key-translation-map + (define-key keymap (vector (+ 160 i)) 'encoded-kbd-self-insert-iso2022-8bit)) 8)))) @@ -313,7 +313,7 @@ The following key sequence may cause multilingual text insertion." (setq from (setq to elt))) (while (<= from to) (if (>= from 128) - (define-key key-translation-map + (define-key keymap (vector from) 'encoded-kbd-self-insert-ccl)) (setq from (1+ from)))) 8)) @@ -321,7 +321,7 @@ The following key sequence may cause multilingual text insertion." ((eq (coding-system-type coding) 'utf-8) (let ((i #xC0)) (while (< i 256) - (define-key key-translation-map + (define-key keymap (vector i) 'encoded-kbd-self-insert-utf-8) (setq i (1+ i)))) 8) @@ -329,12 +329,9 @@ The following key sequence may cause multilingual text insertion." (t nil))) -;; key-translation-map at the time Encoded-kbd mode is turned on is -;; saved here. -(defvar saved-key-translation-map nil) - -;; Input mode at the time Encoded-kbd mode is turned on is saved here. -(defvar saved-input-mode nil) +;;;###autoload +(defun encoded-kbd-setup-display (display) + "Set up a `input-decode-map' for `keyboard-coding-system' on DISPLAY. (put 'encoded-kbd-mode 'permanent-local t) ;;;###autoload @@ -386,5 +383,5 @@ as a multilingual text encoded in a coding system set by (provide 'encoded-kb) -;;; arch-tag: 76f0f9b3-65e7-45c3-b692-59509a87ad44 +;; arch-tag: 76f0f9b3-65e7-45c3-b692-59509a87ad44 ;;; encoded-kb.el ends here diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 71f8168558f..164c3d7ca99 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -151,7 +151,7 @@ t) (define-key-after set-coding-system-map [set-terminal-coding-system] '(menu-item "For Terminal" set-terminal-coding-system - :enable (null (memq window-system '(x w32 mac))) + :enable (null (memq initial-window-system '(x w32 mac))) :help "How to encode terminal output") t) (define-key-after set-coding-system-map [separator-3] @@ -1767,7 +1767,7 @@ The default status is as follows: (reset-language-environment) -(defun set-display-table-and-terminal-coding-system (language-name &optional coding-system) +(defun set-display-table-and-terminal-coding-system (language-name &optional coding-system display) "Set up the display table and terminal coding system for LANGUAGE-NAME." (let ((coding (get-language-info language-name 'unibyte-display))) (if (and coding @@ -1783,7 +1783,7 @@ The default status is as follows: (dotimes (i 128) (aset standard-display-table (+ i 128) nil)))) (or (eq window-system 'pc) - (set-terminal-coding-system (or coding-system coding))))) + (set-terminal-coding-system (or coding-system coding) display)))) (defun set-language-environment (language-name) "Set up multi-lingual environment for using LANGUAGE-NAME. @@ -2410,7 +2410,7 @@ is returned. Thus, for instance, if charset \"ISO8859-2\", ;; too, for setting things such as calendar holidays, ps-print paper ;; size, spelling dictionary. -(defun set-locale-environment (&optional locale-name) +(defun set-locale-environment (&optional locale-name frame) "Set up multi-lingual environment for using LOCALE-NAME. This sets the language environment, the coding system priority, the default input method and sometimes other things. @@ -2431,6 +2431,10 @@ directory named `/usr/share/locale' or `/usr/lib/locale'. LOCALE-NAME will be translated according to the table specified by `locale-translation-file-name'. +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. + See also `locale-charset-language-names', `locale-language-names', `locale-preferred-coding-systems' and `locale-coding-system'." (interactive "sSet environment for locale: ") @@ -2460,7 +2464,7 @@ See also `locale-charset-language-names', `locale-language-names', (let ((vars '("LC_ALL" "LC_CTYPE" "LANG"))) (while (and vars (= 0 (length locale))) ; nil or empty string - (setq locale (getenv (pop vars)))))) + (setq locale (getenv (pop vars) frame))))) (unless locale ;; The two tests are kept separate so the byte-compiler sees @@ -2535,28 +2539,34 @@ See also `locale-charset-language-names', `locale-language-names', ;; Set up for this character set. This is now the right way ;; to do it for both unibyte and multibyte modes. - (set-language-environment language-name) + (unless frame + (set-language-environment language-name)) ;; If default-enable-multibyte-characters is nil, ;; we are using single-byte characters, ;; so the display table and terminal coding system are irrelevant. (when default-enable-multibyte-characters (set-display-table-and-terminal-coding-system - language-name coding-system)) + language-name coding-system frame)) ;; Set the `keyboard-coding-system' if appropriate (tty ;; only). At least X and MS Windows can generate ;; multilingual input. - (unless window-system - (let ((kcs (or coding-system - (car (get-language-info language-name - 'coding-system))))) - (if kcs (set-keyboard-coding-system kcs)))) - - (setq locale-coding-system - (car (get-language-info language-name 'coding-priority)))) - - (when (and coding-system + ;; XXX This was disabled unless `window-system', but that + ;; leads to buggy behaviour when a tty frame is opened + ;; later. Setting the keyboard coding system has no adverse + ;; effect on X, so let's do it anyway. -- Lorentey + (let ((kcs (or coding-system + (car (get-language-info language-name + 'coding-system))))) + (if kcs (set-keyboard-coding-system kcs frame))) + + (unless frame + (setq locale-coding-system + (car (get-language-info language-name 'coding-priority))))) + + (when (and (not frame) + coding-system (not (coding-system-equal coding-system locale-coding-system))) (prefer-coding-system coding-system) @@ -2585,9 +2595,9 @@ system codeset `%s' for this locale." coding-system codeset)))))))) (when (boundp 'w32-ansi-code-page) (let ((code-page-coding (intern (format "cp%d" w32-ansi-code-page)))) (when (coding-system-p code-page-coding) - (setq locale-coding-system code-page-coding) - (set-keyboard-coding-system code-page-coding) - (set-terminal-coding-system code-page-coding)))) + (unless frame (setq locale-coding-system code-page-coding)) + (set-keyboard-coding-system code-page-coding frame) + (set-terminal-coding-system code-page-coding frame)))) (when (eq system-type 'darwin) ;; On Darwin, file names are always encoded in utf-8, no matter @@ -2596,38 +2606,39 @@ system codeset `%s' for this locale." coding-system codeset)))))))) ;; Mac OS X's Terminal.app by default uses utf-8 regardless of ;; the locale. (when (and (null window-system) - (equal (getenv "TERM_PROGRAM") "Apple_Terminal")) + (equal (getenv "TERM_PROGRAM" frame) "Apple_Terminal")) (set-terminal-coding-system 'utf-8) (set-keyboard-coding-system 'utf-8))) ;; Default to A4 paper if we're not in a C, POSIX or US locale. ;; (See comments in Flocale_info.) - (let ((locale locale) - (paper (locale-info 'paper))) - (if paper - ;; This will always be null at the time of writing. - (cond - ((equal paper '(216 279)) - (setq ps-paper-type 'letter)) - ((equal paper '(210 297)) - (setq ps-paper-type 'a4))) - (let ((vars '("LC_ALL" "LC_PAPER" "LANG"))) - (while (and vars (= 0 (length locale))) - (setq locale (getenv (pop vars))))) - (when locale - ;; As of glibc 2.2.5, these are the only US Letter locales, - ;; and the rest are A4. - (setq ps-paper-type - (or (locale-name-match locale '(("c$" . letter) - ("posix$" . letter) - (".._us" . letter) - (".._pr" . letter) - (".._ca" . letter) - ("enu$" . letter) ; Windows - ("esu$" . letter) - ("enc$" . letter) - ("frc$" . letter))) - 'a4)))))) + (unless frame + (let ((locale locale) + (paper (locale-info 'paper))) + (if paper + ;; This will always be null at the time of writing. + (cond + ((equal paper '(216 279)) + (setq ps-paper-type 'letter)) + ((equal paper '(210 297)) + (setq ps-paper-type 'a4))) + (let ((vars '("LC_ALL" "LC_PAPER" "LANG"))) + (while (and vars (= 0 (length locale))) + (setq locale (getenv (pop vars) frame)))) + (when locale + ;; As of glibc 2.2.5, these are the only US Letter locales, + ;; and the rest are A4. + (setq ps-paper-type + (or (locale-name-match locale '(("c$" . letter) + ("posix$" . letter) + (".._us" . letter) + (".._pr" . letter) + (".._ca" . letter) + ("enu$" . letter) ; Windows + ("esu$" . letter) + ("enc$" . letter) + ("frc$" . letter))) + 'a4))))))) nil) ;;; Character property diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el index 75bf45f0525..b3f3b7eb006 100644 --- a/lisp/international/mule-diag.el +++ b/lisp/international/mule-diag.el @@ -638,7 +638,7 @@ Priority order for recognizing coding systems when reading files:\n") coding-system codings) (while categories (setq coding-system (symbol-value (car categories))) - (mapcar + (mapc (lambda (x) (if (and (not (eq x coding-system)) (let ((flags (coding-system-get :flags))) diff --git a/lisp/international/mule.el b/lisp/international/mule.el index c41cfbd1588..83468d25916 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -1211,13 +1211,17 @@ see) to CODING-SYSTEM." This is normally set according to the selected language environment. See also the command `set-terminal-coding-system'.") -(defun set-terminal-coding-system (coding-system) - "Set coding system of your terminal to CODING-SYSTEM. -All text output to the terminal will be encoded +(defun set-terminal-coding-system (coding-system &optional display) + "Set coding system of terminal output to CODING-SYSTEM. +All text output to DISPLAY will be encoded with the specified coding system. + For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]. The default is determined by the selected language environment -or by the previous use of this command." +or by the previous use of this command. + +DISPLAY may be a display id, a frame, or nil for the selected frame's display. +The setting has no effect on graphical displays." (interactive (list (let ((default (if (and (not (terminal-coding-system)) default-terminal-coding-system) @@ -1231,7 +1235,7 @@ or by the previous use of this command." (setq coding-system default-terminal-coding-system)) (if coding-system (setq default-terminal-coding-system coding-system)) - (set-terminal-coding-system-internal coding-system) + (set-terminal-coding-system-internal coding-system display) (redraw-frame (selected-frame))) (defvar default-keyboard-coding-system nil @@ -1239,14 +1243,17 @@ or by the previous use of this command." This is normally set according to the selected language environment. See also the command `set-keyboard-coding-system'.") -(defun set-keyboard-coding-system (coding-system) - "Set coding system for keyboard input to CODING-SYSTEM. -In addition, this command enables Encoded-kbd minor mode. -\(If CODING-SYSTEM is nil, Encoded-kbd mode is turned off -- see -`encoded-kbd-mode'.) +(defun set-keyboard-coding-system (coding-system &optional display) + "Set coding system for keyboard input on DISPLAY to CODING-SYSTEM. +In addition, this command calls `encoded-kbd-setup-display' to set up the +translation of keyboard input events to the specified coding system. + For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]. The default is determined by the selected language environment -or by the previous use of this command." +or by the previous use of this command. + +DISPLAY may be a display id, a frame, or nil for the selected frame's display. +The setting has no effect on graphical displays." (interactive (list (let ((default (if (and (not (keyboard-coding-system)) default-keyboard-coding-system) @@ -1264,9 +1271,9 @@ or by the previous use of this command." (not (coding-system-get coding-system :ascii-compatible-p)) (not (coding-system-get coding-system :suitable-for-keyboard))) (error "%s is not suitable for keyboard" coding-system)) - (set-keyboard-coding-system-internal coding-system) + (set-keyboard-coding-system-internal coding-system display) (setq keyboard-coding-system coding-system) - (encoded-kbd-mode (if coding-system 1 0))) + (encoded-kbd-setup-display display)) (defcustom keyboard-coding-system nil "Specify coding system for keyboard input. @@ -1282,8 +1289,8 @@ use either \\[customize] or \\[set-keyboard-coding-system]." :link '(info-link "(emacs)Terminal Coding") :link '(info-link "(emacs)Unibyte Mode") :set (lambda (symbol value) - ;; Don't load encoded-kbd-mode unnecessarily. - (if (or value (boundp 'encoded-kbd-mode)) + ;; Don't load encoded-kb unnecessarily. + (if (or value (boundp 'encoded-kbd-setup-display)) (set-keyboard-coding-system value) (set-default 'keyboard-coding-system nil))) ; must initialize :version "22.1" @@ -1569,8 +1576,9 @@ text, and convert it in the temporary buffer. Otherwise, convert in-place." (defcustom auto-coding-alist ;; .exe and .EXE are added to support archive-mode looking at DOS ;; self-extracting exe archives. - '(("\\.\\(arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|exe\\)\\'" . no-conversion) - ("\\.\\(ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|EXE\\)\\'" . no-conversion) + '(("\\.\\(\ +arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|exe\\|rar\\|\ +ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|EXE\\|RAR\\)\\'" . no-conversion) ("\\.\\(sx[dmicw]\\|odt\\|tar\\|tgz\\)\\'" . no-conversion) ("\\.\\(gz\\|Z\\|bz\\|bz2\\|gpg\\)\\'" . no-conversion) ("\\.\\(jpe?g\\|png\\|gif\\|tiff?\\|p[bpgn]m\\)\\'" . no-conversion) @@ -2284,25 +2292,26 @@ This function is intended to be added to `auto-coding-functions'." (defun sgml-html-meta-auto-coding-function (size) "If the buffer has an HTML meta tag, use it to determine encoding. This function is intended to be added to `auto-coding-functions'." - (setq size (min (+ (point) size) - (save-excursion - ;; Limit the search by the end of the HTML header. - (or (search-forward "</head>" size t) - ;; In case of no header, search only 10 lines. - (forward-line 10)) - (point)))) - ;; Make sure that the buffer really contains an HTML document, by - ;; checking that it starts with a doctype or a <HTML> start tag - ;; (allowing for whitespace at bob). Note: 'DOCTYPE NETSCAPE' is - ;; useful for Mozilla bookmark files. - (when (and (re-search-forward "\\`[[:space:]\n]*\\(<!doctype[[:space:]\n]+\\(html\\|netscape\\)\\|<html\\)" size t) - (re-search-forward "<meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']text/\\sw+;\\s-*charset=\\(.+?\\)[\"']" size t)) - (let* ((match (match-string 1)) - (sym (intern (downcase match)))) - (if (coding-system-p sym) - sym - (message "Warning: unknown coding system \"%s\"" match) - nil)))) + (let ((case-fold-search t)) + (setq size (min (+ (point) size) + (save-excursion + ;; Limit the search by the end of the HTML header. + (or (search-forward "</head>" size t) + ;; In case of no header, search only 10 lines. + (forward-line 10)) + (point)))) + ;; Make sure that the buffer really contains an HTML document, by + ;; checking that it starts with a doctype or a <HTML> start tag + ;; (allowing for whitespace at bob). Note: 'DOCTYPE NETSCAPE' is + ;; useful for Mozilla bookmark files. + (when (and (re-search-forward "\\`[[:space:]\n]*\\(<!doctype[[:space:]\n]+\\(html\\|netscape\\)\\|<html\\)" size t) + (re-search-forward "<meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']text/\\sw+;\\s-*charset=\\(.+?\\)[\"']" size t)) + (let* ((match (match-string 1)) + (sym (intern (downcase match)))) + (if (coding-system-p sym) + sym + (message "Warning: unknown coding system \"%s\"" match) + nil))))) ;;; (provide 'mule) diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 70169615b0d..ce98a608665 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -158,7 +158,7 @@ usually do not have translators to read other languages for them.\n\n") (insert "configured using `configure " system-configuration-options "'\n\n")) (insert "Important settings:\n") - (mapcar + (mapc '(lambda (var) (insert (format " value of $%s: %s\n" var (getenv var)))) '("LC_ALL" "LC_COLLATE" "LC_CTYPE" "LC_MESSAGES" diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index 324ce427b09..34a0aa0ad82 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -767,7 +767,13 @@ Prefix arg means don't delete this window." "Bury this mail buffer." (let ((newbuf (other-buffer (current-buffer)))) (bury-buffer (current-buffer)) - (if (and (or (window-dedicated-p (frame-selected-window)) + (if (and (or nil + ;; In this case, we need to go to a different frame. + (window-dedicated-p (frame-selected-window)) + ;; In this mode of operation, the frame was probably + ;; made for this buffer, so the user probably wants + ;; to delete it now. + (and pop-up-frames (one-window-p)) (cdr (assq 'mail-dedicated-frame (frame-parameters)))) (not (null (delq (selected-frame) (visible-frame-list))))) (progn diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index cf9c9369497..61e7d0a00eb 100644 --- a/lisp/mail/supercite.el +++ b/lisp/mail/supercite.el @@ -1038,12 +1038,12 @@ supplied, is used instead of the line point is on in the current buffer." (let ((elements (length namelist)) (position -1) keepers filtered-list) - (mapcar + (mapc (function (lambda (name) (setq position (1+ position)) (let ((keep-p t)) - (mapcar + (mapc (function (lambda (filter) (let ((regexp (car filter)) @@ -1061,7 +1061,7 @@ supplied, is used instead of the line point is on in the current buffer." (setq keepers (cons position keepers))) ))) namelist) - (mapcar + (mapc (function (lambda (position) (setq filtered-list (cons (nth position namelist) filtered-list)) diff --git a/lisp/mh-e/ChangeLog b/lisp/mh-e/ChangeLog index 956f7b39cf1..2619e20e6f7 100644 --- a/lisp/mh-e/ChangeLog +++ b/lisp/mh-e/ChangeLog @@ -1,3 +1,7 @@ +2007-09-11 Bill Wohler <wohler@newt.com> + + * mh-e.el (Version, mh-version): Add +cvs to version. + 2007-08-25 Stephen Gildea <gildea@stop.mail-abuse.org> * mh-e.el (mh-annotate-msg-hook): New variable. @@ -8,22 +12,22 @@ 2007-08-21 Jeffrey C Honig <jch@honig.net> * mh-folder.el (mh-folder-message-menu, mh-folder-mode-map): Add - folder mode support for mh-show-preferred-alternative. (Clooses - SF 1777321). + folder mode support for mh-show-preferred-alternative (closes SF + #1777321). * mh-show.el (mh-show-preferred-alternative) (mh-show-write-message-to-file, mh-show-message-menu) (mh-show-mode-map): Add mh-show-preferred-alternative (bound to ":") which will show the message's preferred alternative - overriding the users configured preference. Useful for showing - HTML when text content is lacking. (Closses SF 1777321). + overriding the users configured preference. Useful for showing + HTML when text content is lacking (closes SF #1777321). - * mh-e.el: - (mh-invisible-header-fields-internal): Exclude Fax and Phone. Put + * mh-e.el: + (mh-invisible-header-fields-internal): Exclude Fax and Phone. Put known exclusions as comments before the list and move parens to - separate lines to aid in sorting. (Closes SF 1701231). + separate lines to aid in sorting (closes SF #1701231). - * mh-mime.el (mm-decode-body): remove explicit autoload of + * mh-mime.el (mm-decode-body): Remove explicit autoload of mh-alias-expand. * mh-alias.el (mh-alias-expand): Set up automatic autoload of @@ -34,11 +38,11 @@ * mh-mime.el (message-options-set): Add missing autoloads from my last change. - * mh-comp.el (mh-forward): Address SF 1730393. When forwarding - with mml, messages were included in reverse order. + * mh-comp.el (mh-forward): When forwarding with mml, messages are + no longer included in reverse order (closes SF #1730393). - * mh-mime.el (mh-mml-forward-message): Address SF 1378993 and - forward messages as inline attatchments. + * mh-mime.el (mh-mml-forward-message): Forward messages as inline + attatchments (closes SF #1378993). 2007-08-19 Jeffrey C Honig <jch@honig.net> @@ -46,13 +50,13 @@ Comments: and hide Comment:, not the other way around. * mh-mime.el (mh-mml-to-mime): GPG requires e-mail addresses, not - aliases. So resolve aliases before passing addresses to GPG/PGP. - Closes SF #649226. + aliases. So resolve aliases before passing addresses to GPG/PGP + (closes SF #649226). * mh-e.el (mh-invisible-header-fields-internal): Update with all the entries from http://people.dsv.su.se/~jpalme/ietf/mail-headers, plus some of my - own. I added attributions to entries we already had that did not + own. I added attributions to entries we already had that did not list an RFC. 2007-08-08 Glenn Morris <rgm@gnu.org> diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index 8c8446e1b7c..faec4db35b7 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -6,7 +6,7 @@ ;; Author: Bill Wohler <wohler@newt.com> ;; Maintainer: Bill Wohler <wohler@newt.com> -;; Version: 8.0.3 +;; Version: 8.0.3+cvs ;; Keywords: mail ;; This file is part of GNU Emacs. @@ -133,7 +133,7 @@ ;; Try to keep variables local to a single file. Provide accessors if ;; variables are shared. Use this section as a last resort. -(defconst mh-version "8.0.3" "Version number of MH-E.") +(defconst mh-version "8.0.3+cvs" "Version number of MH-E.") ;; Variants diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 2f06344ccda..9962fd14613 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -4372,12 +4372,18 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;; Treat each name as its own truename. (put 'file-truename 'ange-ftp 'identity) +;; We must return non-nil in order to mask our inability to do the job. +;; Otherwise there are errors when applied to the target file during +;; copying from a (localhost) Tramp file. +(put 'set-file-modes 'ange-ftp 'ignore) +(put 'set-file-times 'ange-ftp 'ignore) + ;; Turn off RCS/SCCS processing to save time. ;; This returns nil for any file name as argument. (put 'vc-registered 'ange-ftp 'null) ;; We can handle process-file in a restricted way (just for chown). -;; Nothing possible for start-file-process. +;; Nothing possible for `start-file-process'. (put 'process-file 'ange-ftp 'ange-ftp-process-file) (put 'start-file-process 'ange-ftp 'ignore) (put 'shell-command 'ange-ftp 'ange-ftp-shell-command) @@ -4574,7 +4580,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (rest (cdr args))) (if (equal "--" (car rest)) (setq rest (cdr rest))) - (mapcar + (mapc (lambda (file) (setq file (expand-file-name file)) (let ((parsed (ange-ftp-ftp-name file))) @@ -6049,8 +6055,8 @@ Other orders of $ and _ seem to all work just fine.") (puthash ".." t tbl) ;; add all additional pubsets, if not listing one of them (if (not (member pubset ange-ftp-bs2000-additional-pubsets)) - (mapcar (lambda (pubset) (puthash pubset t tbl)) - ange-ftp-bs2000-additional-pubsets)) + (mapc (lambda (pubset) (puthash pubset t tbl)) + ange-ftp-bs2000-additional-pubsets)) tbl)) (add-to-list 'ange-ftp-parse-list-func-alist diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 04f83ed465a..cfb3f2742e9 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -55,6 +55,7 @@ ;; browse-url-default-macosx-browser Mac OS X browser ;; browse-url-gnome-moz GNOME interface to Mozilla ;; browse-url-kde KDE konqueror (kfm) +;; browse-url-elinks Elinks Don't know (tried with 0.12.GIT) ;; [A version of the Netscape browser is now free software ;; <URL:http://www.mozilla.org/>, albeit not GPLed, so it is @@ -71,7 +72,7 @@ ;; control but which window DO you want to control and how do you ;; discover its id? -;; William M. Perry's excellent "w3" WWW browser for +;; William M. Perry's excellent "w3" WWW browser for ;; Emacs <URL:ftp://cs.indiana.edu/pub/elisp/w3/> ;; has a function w3-follow-url-at-point, but that ;; doesn't let you edit the URL like browse-url. @@ -216,7 +217,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Variables -(eval-when-compile (require 'thingatpt) +(eval-when-compile (require 'cl) + (require 'thingatpt) (require 'term) (require 'dired) (require 'executable) @@ -263,6 +265,7 @@ regexp should probably be \".\" to specify a default browser." (function-item :tag "Grail" :value browse-url-grail) (function-item :tag "MMM" :value browse-url-mmm) (function-item :tag "KDE" :value browse-url-kde) + (function-item :tag "Elinks" :value browse-url-elinks) (function-item :tag "Specified by `Browse Url Generic Program'" :value browse-url-generic) (function-item :tag "Default Windows browser" @@ -427,7 +430,7 @@ window." :group 'browse-url) (defcustom browse-url-new-window-flag nil - "If non-nil, always open a new browser window with appropriate browsers. + "Non-nil means always open a new browser window with appropriate browsers. Passing an interactive argument to \\[browse-url], or specific browser commands reverses the effect of this variable. Requires Netscape version 1.1N or later or XMosaic version 2.5 or later if using those browsers." @@ -608,6 +611,34 @@ down (this *won't* always work)." :type '(repeat (string :tag "Argument")) :group 'browse-url) +(defcustom browse-url-elinks-wrapper '("xterm" "-e") + "*Wrapper command prepended to the Elinks command-line." + :type '(repeat (string :tag "Wrapper")) + :group 'browse-url) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URL encoding + +(defun browse-url-url-encode-chars (text chars) + "URL-encode the chars in TEXT that match CHARS. +CHARS is a regexp-like character alternative (e.g., \"[,)$]\")." + (let ((encoded-text (copy-sequence text)) + (s 0)) + (while (setq s (string-match chars encoded-text s)) + (setq encoded-text + (replace-match (format "%%%x" + (string-to-char (match-string 0 encoded-text))) + t t encoded-text) + s (1+ s))) + encoded-text)) + +(defun browse-url-encode-url (url) + "Escape annoying characters in URL. +The annoying characters are those that can mislead a webbrowser +regarding its parameter treatment. For instance, `,' can +be misleading because it could be used to separate URLs." + (browse-url-url-encode-chars url "[,)$]")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL input @@ -680,14 +711,7 @@ Use variable `browse-url-filename-alist' to map filenames to URLs." (or file-name-coding-system default-file-name-coding-system)))) (if coding (setq file (encode-coding-string file coding)))) - ;; URL-encode special chars, do % first - (let ((s 0)) - (while (setq s (string-match "%" file s)) - (setq file (replace-match "%25" t t file) - s (1+ s)))) - (while (string-match "[*\"()',=;? ]" file) - (let ((enc (format "%%%x" (aref file (match-beginning 0))))) - (setq file (replace-match enc t t file)))) + (setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]")) (dolist (map browse-url-filename-alist) (when (and map (string-match (car map) file)) (setq file (replace-match (cdr map) t nil file)))) @@ -859,21 +883,21 @@ The order attempted is gnome-moz-remote, Mozilla, Firefox, Galeon, Konqueror, Netscape, Mosaic, IXI Mosaic, Lynx in an xterm, MMM, and then W3." (apply - (cond - ((executable-find browse-url-gnome-moz-program) 'browse-url-gnome-moz) - ((executable-find browse-url-mozilla-program) 'browse-url-mozilla) - ((executable-find browse-url-firefox-program) 'browse-url-firefox) - ((executable-find browse-url-galeon-program) 'browse-url-galeon) - ((executable-find browse-url-kde-program) 'browse-url-kde) - ((executable-find browse-url-netscape-program) 'browse-url-netscape) - ((executable-find browse-url-mosaic-program) 'browse-url-mosaic) - ((executable-find "tellw3b") 'browse-url-iximosaic) - ((executable-find browse-url-xterm-program) 'browse-url-lynx-xterm) - ((executable-find "mmm") 'browse-url-mmm) - ((locate-library "w3") 'browse-url-w3) - (t - (lambda (&ignore args) (error "No usable browser found")))) - url args)) + (cond + ((executable-find browse-url-gnome-moz-program) 'browse-url-gnome-moz) + ((executable-find browse-url-mozilla-program) 'browse-url-mozilla) + ((executable-find browse-url-firefox-program) 'browse-url-firefox) + ((executable-find browse-url-galeon-program) 'browse-url-galeon) + ((executable-find browse-url-kde-program) 'browse-url-kde) + ((executable-find browse-url-netscape-program) 'browse-url-netscape) + ((executable-find browse-url-mosaic-program) 'browse-url-mosaic) + ((executable-find "tellw3b") 'browse-url-iximosaic) + ((executable-find browse-url-xterm-program) 'browse-url-lynx-xterm) + ((executable-find "mmm") 'browse-url-mmm) + ((locate-library "w3") 'browse-url-w3) + (t + (lambda (&ignore args) (error "No usable browser found")))) + url args)) ;;;###autoload (defun browse-url-netscape (url &optional new-window) @@ -893,11 +917,7 @@ is loaded in a new tab in an existing window instead. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) - ;; URL encode any `confusing' characters in the URL. This needs to - ;; include at least commas; presumably also close parens and dollars. - (while (string-match "[,)$]" url) - (setq url (replace-match - (format "%%%x" (string-to-char (match-string 0 url))) t t url))) + (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) (process (apply 'start-process @@ -939,7 +959,7 @@ How depends on `browse-url-netscape-version'." ;; <peter.kruse@psychologie.uni-regensburg.de>. (browse-url-netscape-send (if (>= browse-url-netscape-version 4) "xfeDoCommand(reload)" - "reload"))) + "reload"))) (defun browse-url-netscape-send (command) "Send a remote control command to Netscape." @@ -967,11 +987,7 @@ new tab in an existing window instead. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) - ;; URL encode any `confusing' characters in the URL. This needs to - ;; include at least commas; presumably also close parens and dollars. - (while (string-match "[,)$]" url) - (setq url (replace-match - (format "%%%x" (string-to-char (match-string 0 url))) t t url))) + (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) (process (apply 'start-process @@ -1029,11 +1045,7 @@ command line parameter. Therefore, the are ignored as well. Firefox on Windows will always open the requested URL in a new window." (interactive (browse-url-interactive-arg "URL: ")) - ;; URL encode any `confusing' characters in the URL. This needs to - ;; include at least commas; presumably also close parens. - (while (string-match "[,)]" url) - (setq url (replace-match - (format "%%%x" (string-to-char (match-string 0 url))) t t url))) + (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) (process (apply 'start-process @@ -1085,11 +1097,7 @@ new tab in an existing window instead. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) - ;; URL encode any `confusing' characters in the URL. This needs to - ;; include at least commas; presumably also close parens and dollars. - (while (string-match "[,)$]" url) - (setq url (replace-match - (format "%%%x" (string-to-char (match-string 0 url))) t t url))) + (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) (process (apply 'start-process (concat "galeon " url) @@ -1134,11 +1142,7 @@ new tab in an existing window instead. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) - ;; URL encode any `confusing' characters in the URL. This needs to - ;; include at least commas; presumably also close parens and dollars. - (while (string-match "[,)$]" url) - (setq url (replace-match - (format "%%%x" (string-to-char (match-string 0 url))) t t url))) + (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) (process (apply 'start-process (concat "epiphany " url) @@ -1200,7 +1204,7 @@ used instead of `browse-url-new-window-flag'." (append browse-url-gnome-moz-arguments (if (browse-url-maybe-new-window new-window) - '("--newwin")) + '("--newwin")) (list "--raise" url)))) ;; --- Mosaic --- @@ -1331,7 +1335,7 @@ prefix argument reverses the effect of `browse-url-new-window-flag'. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "W3 URL: ")) - (require 'w3) ; w3-fetch-other-window not autoloaded + (require 'w3) ; w3-fetch-other-window not autoloaded (if (browse-url-maybe-new-window new-window) (w3-fetch-other-window url) (w3-fetch url))) @@ -1343,11 +1347,11 @@ used instead of `browse-url-new-window-flag'." The `browse-url-gnudoit-program' program is used with options given by `browse-url-gnudoit-args'. Default to the URL around or before point." (interactive (browse-url-interactive-arg "W3 URL: ")) - (apply 'start-process (concat "gnudoit:" url) nil - browse-url-gnudoit-program - (append browse-url-gnudoit-args - (list (concat "(w3-fetch \"" url "\")") - "(raise-frame)")))) + (apply 'start-process (concat "gnudoit:" url) nil + browse-url-gnudoit-program + (append browse-url-gnudoit-args + (list (concat "(w3-fetch \"" url "\")") + "(raise-frame)")))) ;; --- Lynx in an xterm --- @@ -1360,8 +1364,8 @@ in an Xterm window using the Xterm program named by `browse-url-xterm-program' with possible additional arguments `browse-url-xterm-args'." (interactive (browse-url-interactive-arg "Lynx URL: ")) (apply #'start-process `(,(concat "lynx" url) nil ,browse-url-xterm-program - ,@browse-url-xterm-args "-e" "lynx" - ,url))) + ,@browse-url-xterm-args "-e" "lynx" + ,url))) ;; --- Lynx in an Emacs "term" window --- @@ -1379,7 +1383,7 @@ reverses the effect of `browse-url-new-window-flag'. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "Lynx URL: ")) - (let* ((system-uses-terminfo t) ; Lynx uses terminfo + (let* ((system-uses-terminfo t) ; Lynx uses terminfo ;; (term-term-name "vt100") ; ?? (buf (get-buffer "*lynx*")) (proc (and buf (get-buffer-process buf))) @@ -1420,11 +1424,11 @@ used instead of `browse-url-new-window-flag'." (error "Please move out of the input field first")) ((eq browse-url-lynx-input-field 'avoid) (while (and (eq (following-char) ?_) (> n 0)) - (term-send-down) ; down arrow + (term-send-down) ; down arrow (sit-for browse-url-lynx-input-delay)) (if (eq (following-char) ?_) (error "Cannot move out of the input field, sorry"))))) - (term-send-string proc (concat "g" ; goto + (term-send-string proc (concat "g" ; goto "\C-u" ; kill default url url "\r"))))) @@ -1499,7 +1503,7 @@ browser is started up in a new process with possible additional arguments don't offer a form of remote control." (interactive (browse-url-interactive-arg "URL: ")) (if (not browse-url-generic-program) - (error "No browser defined (`browse-url-generic-program')")) + (error "No browser defined (`browse-url-generic-program')")) (apply 'call-process browse-url-generic-program nil 0 nil (append browse-url-generic-args (list url)))) @@ -1511,7 +1515,56 @@ Default to the URL around or before point." (interactive (browse-url-interactive-arg "KDE URL: ")) (message "Sending URL to KDE...") (apply #'start-process (concat "KDE " url) nil browse-url-kde-program - (append browse-url-kde-args (list url)))) + (append browse-url-kde-args (list url)))) + +(defun browse-url-elinks-new-window (url) + "Ask the Elinks WWW browser to load URL in a new window." + (let ((process-environment (browse-url-process-environment))) + (apply #'start-process + (append (list (concat "elinks:" url) + nil) + browse-url-elinks-wrapper + (list "elinks" url))))) + +;;;###autoload +(defun browse-url-elinks (url &optional new-window) + "Ask the Elinks WWW browser to load URL. +Default to the URL around the point. + +The document is loaded in a new tab of a running Elinks or, if +none yet running, a newly started instance. + +The Elinks command will be prepended by the program+arguments +from `browse-url-elinks-wrapper'." + (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) + (if new-window + (browse-url-elinks-new-window url) + (let ((process-environment (browse-url-process-environment)) + (elinks-ping-process (start-process "elinks-ping" nil + "elinks" "-remote" "ping()"))) + (set-process-sentinel elinks-ping-process + `(lambda (process change) + (browse-url-elinks-sentinel process ,url)))))) + +(defun browse-url-elinks-sentinel (process url) + "Determines if Elinks is running or a new one has to be started." + (let ((exit-status (process-exit-status process))) + ;; Try to determine if an instance is running or if we have to + ;; create a new one. + (case exit-status + (5 + ;; No instance, start a new one. + (browse-url-elinks-new-window url)) + (0 + ;; Found an instance, open URL in new tab. + (let ((process-environment (browse-url-process-environment))) + (start-process (concat "elinks:" url) nil + "elinks" "-remote" + (concat "openURL(\"" url "\",new-tab)")))) + (otherwise + (error "Unrecognized exit-code %d of process `elinks'" + exit-status))))) (provide 'browse-url) diff --git a/lisp/net/snmp-mode.el b/lisp/net/snmp-mode.el index bf438638794..0ce0b91c037 100644 --- a/lisp/net/snmp-mode.el +++ b/lisp/net/snmp-mode.el @@ -88,6 +88,8 @@ ;;; Code: (eval-when-compile + (require 'cl) + (require 'imenu) ; Need this stuff when compiling for imenu macros, etc. (require 'tempo)) ;;;---------------------------------------------------------------------------- @@ -102,42 +104,42 @@ :version "20.4") (defcustom snmp-special-indent t - "*If non-nil, use a simple heuristic to try to guess the right indentation. + "If non-nil, use a simple heuristic to try to guess the right indentation. If nil, then no special indentation is attempted." :type 'boolean :group 'snmp) (defcustom snmp-indent-level 4 - "*Indentation level for SNMP MIBs." + "Indentation level for SNMP MIBs." :type 'integer :group 'snmp) (defcustom snmp-tab-always-indent nil - "*Non-nil means TAB should always reindent the current line. + "Non-nil means TAB should always reindent the current line. A value of nil means reindent if point is within the initial line indentation; otherwise insert a TAB." :type 'boolean :group 'snmp) (defcustom snmp-completion-ignore-case t - "*Non-nil means that case differences are ignored during completion. + "Non-nil means that case differences are ignored during completion. A value of nil means that case is significant. This is used during Tempo template completion." :type 'boolean :group 'snmp) (defcustom snmp-common-mode-hook nil - "*Hook(s) evaluated when a buffer enters either SNMP or SNMPv2 mode." + "Hook(s) evaluated when a buffer enters either SNMP or SNMPv2 mode." :type 'hook :group 'snmp) (defcustom snmp-mode-hook nil - "*Hook(s) evaluated when a buffer enters SNMP mode." + "Hook(s) evaluated when a buffer enters SNMP mode." :type 'hook :group 'snmp) (defcustom snmpv2-mode-hook nil - "*Hook(s) evaluated when a buffer enters SNMPv2 mode." + "Hook(s) evaluated when a buffer enters SNMPv2 mode." :type 'hook :group 'snmp) @@ -195,26 +197,26 @@ This is used during Tempo template completion." "Predefined types for SYNTAX clauses.") (defvar snmp-rfc1155-types - '(("INTEGER") ("OCTET STRING") ("OBJECT IDENTIFIER") ("NULL") ("IpAddress") - ("NetworkAddress") ("Counter") ("Gauge") ("TimeTicks") ("Opaque")) + '("INTEGER" "OCTET STRING" "OBJECT IDENTIFIER" "NULL" "IpAddress" + "NetworkAddress" "Counter" "Gauge" "TimeTicks" "Opaque") "Types from RFC 1155 v1 SMI.") (defvar snmp-rfc1213-types - '(("DisplayString")) + '("DisplayString") "Types from RFC 1213 MIB-II.") (defvar snmp-rfc1902-types - '(("INTEGER") ("OCTET STRING") ("OBJECT IDENTIFIER") ("Integer32") - ("IpAddress") ("Counter32") ("Gauge32") ("Unsigned32") ("TimeTicks") - ("Opaque") ("Counter64")) + '("INTEGER" "OCTET STRING" "OBJECT IDENTIFIER" "Integer32" + "IpAddress" "Counter32" "Gauge32" "Unsigned32" "TimeTicks" + "Opaque" "Counter64") "Types from RFC 1902 v2 SMI.") (defvar snmp-rfc1903-types - '(("DisplayString") ("PhysAddress") ("MacAddress") ("TruthValue") - ("TestAndIncr") ("AutonomousType") ("InstancePointer") - ("VariablePointer") ("RowPointer") ("RowStatus") ("TimeStamp") - ("TimeInterval") ("DateAndTime") ("StorageType") ("TDomain") - ("TAddress")) + '("DisplayString" "PhysAddress" "MacAddress" "TruthValue" + "TestAndIncr" "AutonomousType" "InstancePointer" + "VariablePointer" "RowPointer" "RowStatus" "TimeStamp" + "TimeInterval" "DateAndTime" "StorageType" "TDomain" + "TAddress") "Types from RFC 1903 Textual Conventions.") @@ -222,12 +224,12 @@ This is used during Tempo template completion." "Predefined values for ACCESS clauses.") (defvar snmp-rfc1155-access - '(("read-only") ("read-write") ("write-only") ("not-accessible")) + '("read-only" "read-write" "write-only" "not-accessible") "ACCESS values from RFC 1155 v1 SMI.") (defvar snmp-rfc1902-access - '(("read-only") ("read-write") ("read-create") ("not-accessible") - ("accessible-for-notify")) + '("read-only" "read-write" "read-create" "not-accessible" + "accessible-for-notify") "ACCESS values from RFC 1155 v1 SMI.") @@ -235,11 +237,11 @@ This is used during Tempo template completion." "Predefined values for STATUS clauses.") (defvar snmp-rfc1212-status - '(("mandatory") ("obsolete") ("deprecated")) + '("mandatory" "obsolete" "deprecated") "STATUS values from RFC 1212 v1 SMI.") (defvar snmp-rfc1902-status - '(("current") ("obsolete") ("deprecated")) + '("current" "obsolete" "deprecated") "STATUS values from RFC 1902 v2 SMI.") @@ -252,13 +254,6 @@ This is used during Tempo template completion." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Need this stuff when compiling for imenu macros, etc. -;; -(eval-when-compile - (require 'cl) - (require 'imenu)) - - ;; Create abbrev table for SNMP MIB mode ;; (defvar snmp-mode-abbrev-table nil @@ -275,33 +270,30 @@ This is used during Tempo template completion." ;; Set up our keymap ;; -(defvar snmp-mode-map (make-sparse-keymap) +(defvar snmp-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\177" 'backward-delete-char-untabify) + (define-key map "\C-c\C-i" 'tempo-complete-tag) + (define-key map "\C-c\C-f" 'tempo-forward-mark) + (define-key map "\C-c\C-b" 'tempo-backward-mark) + map) "Keymap used in SNMP mode.") -(define-key snmp-mode-map "\t" 'snmp-indent-command) -(define-key snmp-mode-map "\177" 'backward-delete-char-untabify) - -(define-key snmp-mode-map "\C-c\C-i" 'tempo-complete-tag) -(define-key snmp-mode-map "\C-c\C-f" 'tempo-forward-mark) -(define-key snmp-mode-map "\C-c\C-b" 'tempo-backward-mark) - ;; Set up our syntax table ;; -(defvar snmp-mode-syntax-table nil +(defvar snmp-mode-syntax-table + (let ((st (make-syntax-table))) + (modify-syntax-entry ?\\ "\\" st) + (modify-syntax-entry ?- "_ 1234" st) + (modify-syntax-entry ?\n ">" st) + (modify-syntax-entry ?\^m ">" st) + (modify-syntax-entry ?_ "." st) + (modify-syntax-entry ?: "." st) + (modify-syntax-entry ?= "." st) + st) "Syntax table used for buffers in SNMP mode.") -(if snmp-mode-syntax-table - () - (setq snmp-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" snmp-mode-syntax-table) - (modify-syntax-entry ?- "_ 1234" snmp-mode-syntax-table) - (modify-syntax-entry ?\n ">" snmp-mode-syntax-table) - (modify-syntax-entry ?\^m ">" snmp-mode-syntax-table) - (modify-syntax-entry ?_ "." snmp-mode-syntax-table) - (modify-syntax-entry ?: "." snmp-mode-syntax-table) - (modify-syntax-entry ?= "." snmp-mode-syntax-table)) - ;; Set up the stuff that's common between snmp-mode and snmpv2-mode ;; (defun snmp-common-mode (name mode abbrev font-keywords imenu-index tempo-tags) @@ -335,10 +327,9 @@ This is used during Tempo template completion." (setq parse-sexp-ignore-comments t) ;; Set up indentation - (make-local-variable 'indent-line-function) - (setq indent-line-function (if snmp-special-indent - 'snmp-indent-line - 'indent-to-left-margin)) + (if snmp-special-indent + (set (make-local-variable 'indent-line-function) 'snmp-indent-line)) + (set (make-local-variable 'tab-always-indent) snmp-tab-always-indent) ;; Font Lock (make-local-variable 'font-lock-defaults) @@ -474,7 +465,7 @@ lines for the purposes of this function." "Indent current line as SNMP MIB code." (let ((indent (snmp-calculate-indent)) (pos (- (point-max) (point))) - shift-amt beg end) + shift-amt beg) (beginning-of-line) (setq beg (point)) (skip-chars-forward " \t") @@ -488,20 +479,6 @@ lines for the purposes of this function." (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos))))) -(defun snmp-indent-command () - "Indent current line as SNMP MIB code, or sometimes insert a TAB. -If `snmp-tab-always-indent' is t, always reindent the current line when -this command is run. -If `snmp-tab-always-indent' is nil, reindent the current line if point is -in the initial indentation. Otherwise, insert a TAB." - (interactive) - (if (and (not snmp-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (snmp-indent-line))) - ;;;---------------------------------------------------------------------------- ;; @@ -520,7 +497,7 @@ in the initial indentation. Otherwise, insert a TAB." (index-table-alist '()) (index-trap-alist '()) (case-fold-search nil) ; keywords must be uppercase - prev-pos token marker end) + prev-pos token end) (goto-char (point-min)) (imenu-progress-message prev-pos 0) ;; Search for a useful MIB item (that's not in a comment) @@ -529,7 +506,7 @@ in the initial indentation. Otherwise, insert a TAB." (imenu-progress-message prev-pos) (setq end (match-end 0) - token (cons (buffer-substring (match-beginning 1) (match-end 1)) + token (cons (match-string 1) (set-marker (make-marker) (match-beginning 1)))) (goto-char (match-beginning 2)) (cond ((looking-at "OBJECT-TYPE[ \t\n]+SYNTAX") @@ -719,5 +696,5 @@ controls whether case is significant." (provide 'snmp-mode) -;;; arch-tag: eb6cc0f9-1e47-4023-8625-bc9aae6c3527 +;; arch-tag: eb6cc0f9-1e47-4023-8625-bc9aae6c3527 ;;; snmp-mode.el ends here diff --git a/lisp/net/socks.el b/lisp/net/socks.el index 5a2364c652c..5079e84ce19 100644 --- a/lisp/net/socks.el +++ b/lisp/net/socks.el @@ -546,7 +546,9 @@ version.") atype host (if (stringp service) - (socks-find-services-entry service) + (or + (socks-find-services-entry service) + (error "Unknown service: %s" service)) service)) (puthash 'buffer buffer info) (puthash 'host host info) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index db08fe3b6df..35147e7907c 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -141,20 +141,20 @@ Remove also properties of all files in subdirectories." (defun tramp-cache-print (table) "Prints hash table TABLE." (when (hash-table-p table) - (let (result tmp) + (let (result) (maphash '(lambda (key value) - (setq tmp (format - "(%s %s)" - (if (processp key) - (prin1-to-string (prin1-to-string key)) - (prin1-to-string key)) - (if (hash-table-p value) - (tramp-cache-print value) - (if (bufferp value) - (prin1-to-string (prin1-to-string value)) - (prin1-to-string value)))) - result (if result (concat result " " tmp) tmp))) + (let ((tmp (format + "(%s %s)" + (if (processp key) + (prin1-to-string (prin1-to-string key)) + (prin1-to-string key)) + (if (hash-table-p value) + (tramp-cache-print value) + (if (bufferp value) + (prin1-to-string (prin1-to-string value)) + (prin1-to-string value)))))) + (setq result (if result (concat result " " tmp) tmp)))) table) result))) @@ -291,7 +291,8 @@ history." res)) ;; Read persistent connection history. -(when (zerop (hash-table-count tramp-cache-data)) +(when (and (stringp tramp-persistency-file-name) + (zerop (hash-table-count tramp-cache-data))) (condition-case err (with-temp-buffer (insert-file-contents tramp-persistency-file-name) @@ -306,7 +307,8 @@ history." (clrhash tramp-cache-data)) (error ;; File is corrupted. - (message "%s" (error-message-string err)) + (message "Tramp persistency file '%s' is corrupted: %s" + tramp-persistency-file-name (error-message-string err)) (clrhash tramp-cache-data)))) (provide 'tramp-cache) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el new file mode 100644 index 00000000000..19d25f43515 --- /dev/null +++ b/lisp/net/tramp-compat.el @@ -0,0 +1,237 @@ +;;; tramp-compat.el --- Tramp compatibility functions + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, see +;; <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tramp's main Emacs version for development is GNU Emacs 23. This +;; package provides compatibility functions for GNU Emacs 21, GNU +;; Emacs 22 and XEmacs 21.4+. + +;;; Code: + +(eval-and-compile + + ;; Pacify byte-compiler. + (require 'cl) + (require 'custom) + + ;; Load the appropriate timer package. + (if (featurep 'xemacs) + (require 'timer-funcs) + (require 'timer)) + + ;; tramp-util offers integration into other (X)Emacs packages like + ;; compile.el, gud.el etc. Not necessary in Emacs 23. + (eval-after-load "tramp" + ;; We check whether `start-file-process' is an alias. + '(when (or (not (fboundp 'start-file-process)) + (symbolp (symbol-function 'start-file-process))) + (require 'tramp-util) + (add-hook 'tramp-unload-hook + '(lambda () + (when (featurep 'tramp-util) + (unload-feature 'tramp-util 'force)))))) + + ;; Make sure that we get integration with the VC package. When it + ;; is loaded, we need to pull in the integration module. Not + ;; necessary in Emacs 23. + (eval-after-load "vc" + (eval-after-load "tramp" + ;; We check whether `start-file-process' is an alias. + '(when (or (not (fboundp 'start-file-process)) + (symbolp (symbol-function 'start-file-process))) + (require 'tramp-vc) + (add-hook 'tramp-unload-hook + '(lambda () + (when (featurep 'tramp-vc) + (unload-feature 'tramp-vc 'force))))))) + + ;; Avoid byte-compiler warnings if the byte-compiler supports this. + ;; Currently, XEmacs supports this. + (when (featurep 'xemacs) + (unless (boundp 'byte-compile-default-warnings) + (defvar byte-compile-default-warnings nil)) + (delq 'unused-vars byte-compile-default-warnings)) + + ;; `last-coding-system-used' is unknown in XEmacs. + (unless (boundp 'last-coding-system-used) + (defvar last-coding-system-used nil)) + + ;; `directory-sep-char' is an obsolete variable in Emacs. But it is + ;; used in XEmacs, so we set it here and there. The following is + ;; needed to pacify Emacs byte-compiler. + (unless (boundp 'byte-compile-not-obsolete-var) + (defvar byte-compile-not-obsolete-var nil)) + (setq byte-compile-not-obsolete-var 'directory-sep-char) + + ;; `with-temp-message' does not exists in XEmacs. + (condition-case nil + (with-temp-message (current-message) nil) + (error (defmacro with-temp-message (message &rest body) `(progn ,@body)))) + + ;; `set-buffer-multibyte' comes from Emacs Leim. + (unless (fboundp 'set-buffer-multibyte) + (defalias 'set-buffer-multibyte 'ignore)) + + ;; `font-lock-add-keywords' does not exist in XEmacs. + (unless (fboundp 'font-lock-add-keywords) + (defalias 'font-lock-add-keywords 'ignore)) + + ;; `file-remote-p' has been introduced with Emacs 22. The version + ;; of XEmacs is not a magic file name function (yet); this is + ;; corrected in tramp-util.el. Here it is sufficient if the + ;; function exists. + (unless (fboundp 'file-remote-p) + (defalias 'file-remote-p 'tramp-handle-file-remote-p)) + + ;; `process-file' exists since Emacs 22. + (unless (fboundp 'process-file) + (defalias 'process-file 'tramp-handle-process-file)) + + ;; `start-file-process' is new in Emacs 23. + (unless (fboundp 'start-file-process) + (defalias 'start-file-process 'tramp-handle-start-file-process)) + + ;; `set-file-times' is also new in Emacs 23. + (unless (fboundp 'set-file-times) + (defalias 'set-file-times 'tramp-handle-set-file-times))) + +(defsubst tramp-compat-line-end-position () + "Return point at end of line (compat function). +Calls `line-end-position' or `point-at-eol' if defined, else +own implementation." + (cond + ((fboundp 'line-end-position) (funcall (symbol-function 'line-end-position))) + ((fboundp 'point-at-eol) (funcall (symbol-function 'point-at-eol))) + (t (save-excursion (end-of-line) (point))))) + +(defsubst tramp-compat-temporary-file-directory () + "Return name of directory for temporary files (compat function). +For Emacs, this is the variable `temporary-file-directory', for XEmacs +this is the function `temp-directory'." + (cond + ((boundp 'temporary-file-directory) (symbol-value 'temporary-file-directory)) + ((fboundp 'temp-directory) (funcall (symbol-function 'temp-directory))) + ((let ((d (getenv "TEMP"))) (and d (file-directory-p d))) + (file-name-as-directory (getenv "TEMP"))) + ((let ((d (getenv "TMP"))) (and d (file-directory-p d))) + (file-name-as-directory (getenv "TMP"))) + ((let ((d (getenv "TMPDIR"))) (and d (file-directory-p d))) + (file-name-as-directory (getenv "TMPDIR"))) + ((file-exists-p "c:/temp") (file-name-as-directory "c:/temp")) + (t (message (concat "Neither `temporary-file-directory' nor " + "`temp-directory' is defined -- using /tmp.")) + (file-name-as-directory "/tmp")))) + +;; `make-temp-file' exists in Emacs only. The third parameter SUFFIX +;; has been introduced with Emacs 22. We try it, if it fails, we fall +;; back to `make-temp-name', creating the temporary file immediately +;; in order to avoid a security hole. +(defsubst tramp-compat-make-temp-file (filename) + "Create a temporary file (compat function). +Add the extension of FILENAME, if existing." + (let ((prefix (expand-file-name + (symbol-value 'tramp-temp-name-prefix) + (tramp-compat-temporary-file-directory))) + (extension (file-name-extension filename t)) + result) + (condition-case nil + (setq result + (funcall (symbol-function 'make-temp-file) prefix nil extension)) + (error + ;; We use our own implementation, taken from files.el. + (while + (condition-case () + (progn + (setq result (concat (make-temp-name prefix) extension)) + (write-region + "" nil result nil 'silent nil + ;; 7th parameter is MUSTBENEW in Emacs, and + ;; CODING-SYSTEM in XEmacs. It is not a security + ;; hole in XEmacs if we cannot use this parameter, + ;; because XEmacs uses a user-specific subdirectory + ;; with 0700 permissions. + (when (not (featurep 'xemacs)) 'excl)) + nil) + (file-already-exists t)) + ;; The file was somehow created by someone else between + ;; `make-temp-name' and `write-region', let's try again. + nil))) + result)) + +;; `most-positive-fixnum' arrived in Emacs 22. Before, and in XEmacs, +;; it is a fixed value. +(defsubst tramp-compat-most-positive-fixnum () + "Return largest positive integer value (compat function)." + (cond + ((boundp 'most-positive-fixnum) (symbol-value 'most-positive-fixnum)) + ;; Default value in XEmacs and Emacs 21. + (t 134217727))) + +;; ID-FORMAT exists since Emacs 22. +(defun tramp-compat-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files (compat function)." + (cond + ((or (null id-format) (eq id-format 'integer)) + (file-attributes filename)) + ((file-remote-p filename) + (funcall (symbol-function 'tramp-handle-file-attributes) + filename id-format)) + (t (condition-case nil + (funcall (symbol-function 'file-attributes) filename id-format) + (error (file-attributes filename)))))) + +;; PRESERVE-UID-GID has been introduced with Emacs 23. It does not +;; hurt to ignore it for other (X)Emacs versions. +(defun tramp-compat-copy-file + (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) + "Like `copy-file' for Tramp files (compat function)." + (if preserve-uid-gid + (funcall + (symbol-function 'copy-file) + filename newname ok-if-already-exists keep-date preserve-uid-gid) + (copy-file filename newname ok-if-already-exists keep-date))) + +;; `copy-tree' is a built-in function in XEmacs. In Emacs 21, it is +;; an auoloaded function in cl-extra.el. Since Emacs 22, it is part +;; of subr.el. There are problems when autoloading, therefore we test +;; for for `subrp' and `symbol-file'. Implementation is taken from Emacs23. +(defun tramp-compat-copy-tree (tree) + "Make a copy of TREE (compat function)." + (if (or (subrp 'copy-tree) (symbol-file 'copy-tree)) + (funcall (symbol-function 'copy-tree) tree) + (let (result) + (while (consp tree) + (let ((newcar (car tree))) + (if (consp (car tree)) + (setq newcar (tramp-compat-copy-tree (car tree)))) + (push newcar result)) + (setq tree (cdr tree))) + (nconc (nreverse result) tree)))) + +(provide 'tramp-compat) + +;;; TODO: + +;; arch-tag: 0e724b18-6699-4f87-ad96-640b272e5c85 +;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-fish.el b/lisp/net/tramp-fish.el index f0db302abcb..7116d144061 100644 --- a/lisp/net/tramp-fish.el +++ b/lisp/net/tramp-fish.el @@ -155,25 +155,7 @@ (require 'tramp) (require 'tramp-cache) - -;; Pacify byte-compiler -(eval-when-compile - (require 'cl) - (require 'custom)) - -;; Avoid byte-compiler warnings if the byte-compiler supports this. -;; Currently, XEmacs supports this. -(eval-when-compile - (when (featurep 'xemacs) - (byte-compiler-options (warnings (- unused-vars))))) - -;; `directory-sep-char' is an obsolete variable in Emacs. But it is -;; used in XEmacs, so we set it here and there. The following is needed -;; to pacify Emacs byte-compiler. -(eval-when-compile - (unless (boundp 'byte-compile-not-obsolete-var) - (defvar byte-compile-not-obsolete-var nil)) - (setq byte-compile-not-obsolete-var 'directory-sep-char)) +(require 'tramp-compat) ;; Define FISH method ... (defcustom tramp-fish-method "fish" @@ -365,7 +347,7 @@ pass to the OPERATION." (unless (file-name-absolute-p name) (setq name (concat (file-name-as-directory dir) name))) ;; If NAME is not a tramp file, run the real handler - (if (or (tramp-completion-mode) (not (tramp-tramp-file-p name))) + (if (or (tramp-completion-mode-p) (not (tramp-tramp-file-p name))) (tramp-drop-volume-letter (tramp-run-real-handler 'expand-file-name (list name nil))) ;; Dissect NAME. @@ -386,7 +368,7 @@ pass to the OPERATION." (tramp-fish-send-command-and-check v "#PWD") (with-current-buffer (tramp-get-buffer v) (goto-char (point-min)) - (buffer-substring (point) (tramp-line-end-position))))) + (buffer-substring (point) (tramp-compat-line-end-position))))) (setq localname (concat uname fname)))) ;; There might be a double slash, for example when "~/" ;; expands to "/". Remove this. @@ -399,7 +381,7 @@ pass to the OPERATION." ;; bound, because on Windows there would be problems with UNC ;; shares or Cygwin mounts. (tramp-let-maybe directory-sep-char ?/ - (let ((default-directory (tramp-temporary-file-directory))) + (let ((default-directory (tramp-compat-temporary-file-directory))) (tramp-make-tramp-file-name method user host (tramp-drop-volume-letter @@ -493,14 +475,14 @@ pass to the OPERATION." (tramp-error v 'file-error "Cannot make local copy of non-existing file `%s'" filename)) - (let ((tmpfil (tramp-make-temp-file filename))) - (tramp-message v 4 "Fetching %s to tmp file %s..." filename tmpfil) + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (tramp-message v 4 "Fetching %s to tmp file %s..." filename tmpfile) (when (tramp-fish-retrieve-data v) ;; Save file (with-current-buffer (tramp-get-buffer v) - (write-region (point-min) (point-max) tmpfil)) - (tramp-message v 4 "Fetching %s to tmp file %s...done" filename tmpfil) - tmpfil)))) + (write-region (point-min) (point-max) tmpfile)) + (tramp-message v 4 "Fetching %s to tmp file %s...done" filename tmpfile) + tmpfile)))) ;; This function should return "foo/" for directories and "bar" for ;; files. @@ -742,7 +724,7 @@ target of the symlink differ." (if (zerop (process-file "which" nil t nil command)) (progn (goto-char (point-min)) - (buffer-substring (point-min) (tramp-line-end-position)))))) + (buffer-substring (point-min) (tramp-compat-line-end-position)))))) (defun tramp-fish-handle-process-file (program &optional infile destination display &rest args) @@ -752,8 +734,8 @@ target of the symlink differ." (error "Implementation does not handle immediate return")) (with-parsed-tramp-file-name default-directory nil - (let ((temp-name-prefix (tramp-make-tramp-temp-file v)) - command input output stderr outbuf tmpfil ret) + (let (command input tmpinput output tmpoutput stderr tmpstderr + outbuf tmpfile ret) ;; Compute command. (setq command (mapconcat 'tramp-shell-quote-argument (cons program args) " ")) @@ -765,15 +747,14 @@ target of the symlink differ." ;; INFILE is on the same remote host. (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. - (setq input (concat temp-name-prefix ".in")) - (copy-file - infile - (tramp-make-tramp-file-name method user host input) - t))) + (setq input (tramp-make-tramp-temp-file v) + tmpinput (tramp-make-tramp-file-name method user host input)) + (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) ;; Determine output. - (setq output (concat temp-name-prefix ".out")) + (setq output (tramp-make-tramp-temp-file v) + tmpoutput (tramp-make-tramp-file-name method user host output)) (cond ;; Just a buffer ((bufferp destination) @@ -799,7 +780,9 @@ target of the symlink differ." (cadr destination) nil localname)) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. - (setq stderr (concat temp-name-prefix ".err")))) + (setq stderr (tramp-make-tramp-temp-file v) + tmpstderr (tramp-make-tramp-file-name + method user host stderr)))) ;; stderr to be discarded ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -808,9 +791,6 @@ target of the symlink differ." (setq outbuf (current-buffer)))) (when stderr (setq command (format "%s 2>%s" command stderr))) - ;; If we have a temporary file, it must be removed after operation. - (when (and input (string-match temp-name-prefix input)) - (setq command (format "%s; rm %s" command input))) ;; Goto working directory. (unless (tramp-fish-send-command-and-check @@ -823,31 +803,31 @@ target of the symlink differ." v (format "#EXEC %s %s" (tramp-shell-quote-argument command) output)) - (error)) + (error nil)) ;; Check return code. - (setq tmpfil (file-local-copy - (tramp-make-tramp-file-name method user host output))) + (setq tmpfile + (file-local-copy + (tramp-make-tramp-file-name method user host output))) (with-temp-buffer - (insert-file-contents tmpfil) + (insert-file-contents tmpfile) (goto-char (point-max)) (forward-line -1) (looking-at "^###RESULT: \\([0-9]+\\)") (setq ret (string-to-number (match-string 1))) (delete-region (point) (point-max)) - (write-region (point-min) (point-max) tmpfil)) + (write-region (point-min) (point-max) tmpfile)) ;; We should show the output anyway. (when outbuf - (with-current-buffer outbuf (insert-file-contents tmpfil)) - (when display (display-buffer outbuf))) - ;; Remove output file. - (delete-file (tramp-make-tramp-file-name method user host output))) + (with-current-buffer outbuf (insert-file-contents tmpfile)) + (when display (display-buffer outbuf)))) ;; When the user did interrupt, we should do it also. (error (setq ret 1))) - (unless ret - ;; Provide error file. - (when (and stderr (string-match temp-name-prefix stderr)) - (rename-file (tramp-make-tramp-file-name method user host stderr) - (cadr destination) t))) + + ;; Provide error file. + (when tmpstderr (rename-file tmpstderr (cadr destination) t)) + ;; Cleanup. + (when tmpinput (delete-file tmpinput)) + (when tmpoutput (delete-file tmpoutput)) ;; Return exit status. ret))) @@ -935,7 +915,7 @@ KEEP-DATE is non-nil, preserve the time stamp when copying." (tramp-shell-quote-argument v2-localname))))) ;; KEEP-DATE handling. (when (and keep-date (functionp 'set-file-times)) - (apply 'set-file-times (list newname (nth 5 (file-attributes filename))))) + (set-file-times newname (nth 5 (file-attributes filename)))) ;; Set the mode. (set-file-modes newname (file-modes filename))) @@ -961,7 +941,7 @@ SIZE MODE WEIRD INODE DEVICE)." ;; Read number of entries (goto-char (point-min)) (condition-case nil - (unless (integerp (setq num (read (current-buffer)))) (error)) + (unless (integerp (setq num (read (current-buffer)))) (error nil)) (error (return nil))) (forward-line) (delete-region (point-min) (point)) @@ -969,7 +949,7 @@ SIZE MODE WEIRD INODE DEVICE)." ;; Read return code (goto-char (point-min)) (condition-case nil - (unless (looking-at tramp-fish-continue-prompt-regexp) (error)) + (unless (looking-at tramp-fish-continue-prompt-regexp) (error nil)) (error (return nil))) (forward-line) (delete-region (point-min) (point)) @@ -986,7 +966,7 @@ SIZE MODE WEIRD INODE DEVICE)." ;; Read return code (goto-char (point-min)) (condition-case nil - (unless (looking-at tramp-fish-ok-prompt-regexp) (error)) + (unless (looking-at tramp-fish-ok-prompt-regexp) (error nil)) (error (tramp-error vec 'file-error "`%s' does not return a valid Lisp expression: `%s'" @@ -1071,7 +1051,7 @@ Returns the size of the data." ;; Read filesize (goto-char (point-min)) (condition-case nil - (unless (integerp (setq size (read (current-buffer)))) (error)) + (unless (integerp (setq size (read (current-buffer)))) (error nil)) (error (return nil))) (forward-line) (delete-region (point-min) (point)) @@ -1079,7 +1059,7 @@ Returns the size of the data." ;; Read return code (goto-char (point-min)) (condition-case nil - (unless (looking-at tramp-fish-continue-prompt-regexp) (error)) + (unless (looking-at tramp-fish-continue-prompt-regexp) (error nil)) (error (return nil))) (forward-line) (delete-region (point-min) (point)) @@ -1095,7 +1075,7 @@ Returns the size of the data." ;; Read return code (goto-char (+ (point-min) size)) (condition-case nil - (unless (looking-at tramp-fish-ok-prompt-regexp) (error)) + (unless (looking-at tramp-fish-ok-prompt-regexp) (error nil)) (error (return nil))) (delete-region (+ (point-min) size) (point-max)) size)))) @@ -1132,7 +1112,8 @@ connection if a previous connection has died for some reason." (coding-system-for-read 'binary) (coding-system-for-write 'binary) ;; This must be done in order to avoid our file name handler. - (p (let ((default-directory (tramp-temporary-file-directory))) + (p (let ((default-directory + (tramp-compat-temporary-file-directory))) (start-process (or (tramp-get-connection-property vec "process-name" nil) (tramp-buffer-name vec)) diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 6fe069636f7..85416d308d3 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -149,6 +149,19 @@ pass to the OPERATION." (with-parsed-tramp-file-name (car args) nil (tramp-set-connection-property v "started" t)) nil)) + ;; If the second argument of `copy-file' or `rename-file' is a + ;; remote file name but via FTP, ange-ftp doesn't check this. + ;; We must copy it locally first, because there is no place in + ;; ange-ftp for correct handling. + ((and (memq operation '(copy-file rename-file)) + (file-remote-p (cadr args)) + (not (tramp-ftp-file-name-p (cadr args)))) + (let* ((filename (car args)) + (newname (cadr args)) + (tmpfile (tramp-compat-make-temp-file filename)) + (args (cddr args))) + (apply operation filename tmpfile args) + (rename-file tmpfile newname (car args)))) ;; Normally, the handlers must be discarded. (t (let* ((inhibit-file-name-handlers (list 'tramp-file-name-handler diff --git a/lisp/net/tramp-gw.el b/lisp/net/tramp-gw.el index 3ac496d8a09..70a37f384fe 100644 --- a/lisp/net/tramp-gw.el +++ b/lisp/net/tramp-gw.el @@ -307,7 +307,7 @@ password in password cache. This is done for the first try only." "%s:%s" socks-username (tramp-read-passwd - proc + nil (format "Password for %s@[%s]: " socks-username (read (current-buffer))))))))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 5dbf12955d7..b4e68c77624 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -30,15 +30,7 @@ (require 'tramp) (require 'tramp-cache) - -;; Pacify byte-compiler -(eval-when-compile (require 'custom)) - -;; Avoid byte-compiler warnings if the byte-compiler supports this. -;; Currently, XEmacs supports this. -(eval-when-compile - (when (featurep 'xemacs) - (byte-compiler-options (warnings (- unused-vars))))) +(require 'tramp-compat) ;; Define SMB method ... (defcustom tramp-smb-method "smb" @@ -79,6 +71,7 @@ '(;; Connection error / timeout "Connection to \\S-+ failed" "Read from server failed, maybe it closed the connection" + "Call timed out: server did not respond" ;; Samba "ERRDOS" "ERRSRV" @@ -378,19 +371,19 @@ KEEP-DATE is not handled in case NEWNAME resides on an SMB server." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (let ((file (tramp-smb-get-localname localname t)) - (tmpfil (tramp-make-temp-file filename))) + (tmpfile (tramp-compat-make-temp-file filename))) (unless (file-exists-p filename) (tramp-error v 'file-error "Cannot make local copy of non-existing file `%s'" filename)) - (tramp-message v 4 "Fetching %s to tmp file %s..." filename tmpfil) - (if (tramp-smb-send-command v (format "get \"%s\" %s" file tmpfil)) + (tramp-message v 4 "Fetching %s to tmp file %s..." filename tmpfile) + (if (tramp-smb-send-command v (format "get \"%s\" %s" file tmpfile)) (tramp-message - v 4 "Fetching %s to tmp file %s...done" filename tmpfil) + v 4 "Fetching %s to tmp file %s...done" filename tmpfile) (tramp-error v 'file-error "Cannot make local copy of file `%s'" filename)) - tmpfil))) + tmpfile))) ;; This function should return "foo/" for directories and "bar" for ;; files. @@ -582,7 +575,7 @@ Catches errors for shares like \"C$/\", which are common in Microsoft Windows." (unless (eq append nil) (tramp-error v 'file-error "Cannot append to file using tramp (`%s')" filename)) - ;; XEmacs takes a coding system as the seventh argument, not `confirm' + ;; XEmacs takes a coding system as the seventh argument, not `confirm'. (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename)) (unless (y-or-n-p (format "File %s exists; overwrite anyway? " @@ -594,25 +587,23 @@ Catches errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-flush-file-property v localname) (let ((file (tramp-smb-get-localname localname t)) (curbuf (current-buffer)) - tmpfil) - ;; Write region into a tmp file. - (setq tmpfil (tramp-make-temp-file filename)) + (tmpfile (tramp-compat-make-temp-file filename))) ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. (tramp-run-real-handler 'write-region (if confirm ; don't pass this arg unless defined for backward compat. - (list start end tmpfil append 'no-message lockname confirm) - (list start end tmpfil append 'no-message lockname))) + (list start end tmpfile append 'no-message lockname confirm) + (list start end tmpfile append 'no-message lockname))) - (tramp-message v 5 "Writing tmp file %s to file %s..." tmpfil filename) - (if (tramp-smb-send-command v (format "put %s \"%s\"" tmpfil file)) + (tramp-message v 5 "Writing tmp file %s to file %s..." tmpfile filename) + (if (tramp-smb-send-command v (format "put %s \"%s\"" tmpfile file)) (tramp-message - v 5 "Writing tmp file %s to file %s...done" tmpfil filename) + v 5 "Writing tmp file %s to file %s...done" tmpfile filename) (tramp-error v 'file-error "Cannot write `%s'" filename)) - (delete-file tmpfil) + (delete-file tmpfile) (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error @@ -762,7 +753,7 @@ If SHARE is result, entries are of type dir. Otherwise, shares are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." ;; We are called from `tramp-smb-get-file-entries', which sets the ;; current buffer. - (let ((line (buffer-substring (point) (tramp-line-end-position))) + (let ((line (buffer-substring (point) (tramp-compat-line-end-position))) localname mode size month day hour min sec year mtime) (if (not share) @@ -890,7 +881,7 @@ connection if a previous connection has died for some reason." (when (and p (processp p)) (delete-process p)) (unless (let ((default-directory - (tramp-temporary-file-directory))) + (tramp-compat-temporary-file-directory))) (executable-find tramp-smb-program)) (error "Cannot find command %s in %s" tramp-smb-program exec-path)) @@ -929,7 +920,8 @@ connection if a previous connection has died for some reason." (let* ((coding-system-for-read nil) (process-connection-type tramp-process-connection-type) - (p (let ((default-directory (tramp-temporary-file-directory))) + (p (let ((default-directory + (tramp-compat-temporary-file-directory))) (apply #'start-process (tramp-buffer-name vec) (tramp-get-buffer vec) tramp-smb-program args)))) diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el index c399a0b211d..d9994e9dc83 100644 --- a/lisp/net/tramp-uu.el +++ b/lisp/net/tramp-uu.el @@ -1,5 +1,5 @@ -;;; -*- coding: utf-8; -*- ;;; tramp-uu.el --- uuencode in Lisp +;;; -*- coding: utf-8; -*- ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, ;; 2007 Free Software Foundation, Inc. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index affeac31c33..26846f562f5 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1,5 +1,5 @@ -;;; -*- mode: Emacs-Lisp; coding: utf-8; -*- ;;; tramp.el --- Transparent Remote Access, Multiple Protocol +;;; -*- mode: Emacs-Lisp; coding: utf-8; -*- ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007 Free Software Foundation, Inc. @@ -72,11 +72,11 @@ (when (featurep 'trampver) (unload-feature 'trampver 'force)))) -(require 'custom) - -(if (featurep 'xemacs) - (require 'timer-funcs) - (require 'timer)) +(require 'tramp-compat) +(add-hook 'tramp-unload-hook + '(lambda () + (when (featurep 'tramp-compat) + (unload-feature 'tramp-compat 'force)))) (require 'format-spec) ;from Gnus 5.8, also in tar ball ;; As long as password.el is not part of (X)Emacs, it shouldn't @@ -88,11 +88,6 @@ (require 'shell) (require 'advice) -;; `copy-tree' is part of subr.el since Emacs 22. -(eval-when-compile - (unless (functionp 'copy-tree) - (require 'cl))) - ;; Requiring 'tramp-cache results in an endless loop. (autoload 'tramp-get-file-property "tramp-cache") (autoload 'tramp-set-file-property "tramp-cache") @@ -149,56 +144,12 @@ (unload-feature 'tramp-fish 'force)))) ;; Load gateways. It needs `make-network-process' from Emacs 22. - (if (functionp 'make-network-process) - (progn - (require 'tramp-gw) - (add-hook 'tramp-unload-hook - '(lambda () - (when (featurep 'tramp-gw) - (unload-feature 'tramp-gw 'force))))) - ;; We need to declare used tramp-gw-* symbols at least. - (setq tramp-gw-tunnel-method "" - tramp-gw-socks-method "") - (defalias 'tramp-gw-open-connection 'ignore)) - - ;; tramp-util offers integration into other (X)Emacs packages like - ;; compile.el, gud.el etc. Not necessary in Emacs 23. - (unless (functionp 'start-file-process) - (require 'tramp-util) + (when (functionp 'make-network-process) + (require 'tramp-gw) (add-hook 'tramp-unload-hook '(lambda () - (when (featurep 'tramp-util) - (unload-feature 'tramp-util 'force))))))) - -;; Avoid byte-compiler warnings if the byte-compiler supports this. -;; Currently, XEmacs supports this. -(eval-when-compile - (when (featurep 'xemacs) - (byte-compiler-options (warnings (- unused-vars))))) - -;; `last-coding-system-used' is unknown in XEmacs. -(eval-when-compile - (unless (boundp 'last-coding-system-used) - (defvar last-coding-system-used nil))) - -;; `directory-sep-char' is an obsolete variable in Emacs. But it is -;; used in XEmacs, so we set it here and there. The following is needed -;; to pacify Emacs byte-compiler. -(eval-when-compile - (unless (boundp 'byte-compile-not-obsolete-var) - (defvar byte-compile-not-obsolete-var nil)) - (setq byte-compile-not-obsolete-var 'directory-sep-char)) - -;; `with-temp-message' does not exists in XEmacs. -(eval-and-compile - (condition-case nil - (with-temp-message (current-message) nil) - (error (defmacro with-temp-message (message &rest body) `(progn ,@body))))) - -;; `set-buffer-multibyte' comes from Emacs Leim. -(eval-and-compile - (unless (fboundp 'set-buffer-multibyte) - (defalias 'set-buffer-multibyte 'ignore))) + (when (featurep 'tramp-gw) + (unload-feature 'tramp-gw 'force))))))) ;;; User Customizable Internal Variables: @@ -208,7 +159,7 @@ :version "22.1") (defcustom tramp-verbose 3 - "*Verbosity level for tramp. + "*Verbosity level for Tramp. Any level x includes messages for all levels 1 .. x-1. The levels are 0 silent (no tramp messages at all) @@ -1118,7 +1069,7 @@ The answer will be provided by `tramp-action-process-alive', "*Prefix to use for temporary files. If this is a relative file name (such as \"tramp.\"), it is considered relative to the directory name returned by the function -`tramp-temporary-file-directory' (which see). It may also be an +`tramp-compat-temporary-file-directory' (which see). It may also be an absolute file name; don't forget to include a prefix for the filename part, though." :group 'tramp @@ -1311,7 +1262,7 @@ See `tramp-file-name-structure' for more explanations.") ((equal tramp-syntax 'sep) tramp-file-name-regexp-separate) ((equal tramp-syntax 'url) tramp-file-name-regexp-url) (t (error "Wrong `tramp-syntax' defined"))) - "*Regular expression matching file names handled by tramp. + "*Regular expression matching file names handled by Tramp. This regexp should match tramp file names but no other file names. \(When tramp.el is loaded, this regular expression is prepended to `file-name-handler-alist', and that is searched sequentially. Thus, @@ -1731,27 +1682,27 @@ while (my $data = <STDIN>) { Escape sequence %s is replaced with name of Perl binary. This string is passed to `format', so percent characters need to be doubled.") -(defconst tramp-file-mode-type-map '((0 . "-") ; Normal file (SVID-v2 and XPG2) - (1 . "p") ; fifo - (2 . "c") ; character device - (3 . "m") ; multiplexed character device (v7) - (4 . "d") ; directory - (5 . "?") ; Named special file (XENIX) - (6 . "b") ; block device - (7 . "?") ; multiplexed block device (v7) - (8 . "-") ; regular file - (9 . "n") ; network special file (HP-UX) - (10 . "l") ; symlink - (11 . "?") ; ACL shadow inode (Solaris, not userspace) - (12 . "s") ; socket - (13 . "D") ; door special (Solaris) - (14 . "w")) ; whiteout (BSD) +(defconst tramp-file-mode-type-map + '((0 . "-") ; Normal file (SVID-v2 and XPG2) + (1 . "p") ; fifo + (2 . "c") ; character device + (3 . "m") ; multiplexed character device (v7) + (4 . "d") ; directory + (5 . "?") ; Named special file (XENIX) + (6 . "b") ; block device + (7 . "?") ; multiplexed block device (v7) + (8 . "-") ; regular file + (9 . "n") ; network special file (HP-UX) + (10 . "l") ; symlink + (11 . "?") ; ACL shadow inode (Solaris, not userspace) + (12 . "s") ; socket + (13 . "D") ; door special (Solaris) + (14 . "w")) ; whiteout (BSD) "A list of file types returned from the `stat' system call. This is used to map a mode number to a permission string.") ;; New handlers should be added here. The following operations can be ;; handled using the normal primitives: file-name-as-directory, -;; file-name-directory, file-name-nondirectory, ;; file-name-sans-versions, get-file-buffer. (defconst tramp-file-name-handler-alist '((load . tramp-handle-load) @@ -1794,6 +1745,8 @@ This is used to map a mode number to a permission string.") (file-local-copy . tramp-handle-file-local-copy) (file-remote-p . tramp-handle-file-remote-p) (insert-file-contents . tramp-handle-insert-file-contents) + (insert-file-contents-literally + . tramp-handle-insert-file-contents-literally) (write-region . tramp-handle-write-region) (find-backup-file-name . tramp-handle-find-backup-file-name) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -1938,15 +1891,6 @@ an input event arrives. The other arguments are passed to `tramp-error'." (tramp-get-buffer vec-or-proc))) (sit-for 30)))))) -(defsubst tramp-line-end-position nil - "Return point at end of line. -Calls `line-end-position' or `point-at-eol' if defined, else -own implementation." - (cond - ((fboundp 'line-end-position) (funcall (symbol-function 'line-end-position))) - ((fboundp 'point-at-eol) (funcall (symbol-function 'point-at-eol))) - (t (save-excursion (end-of-line) (point))))) - (defmacro with-parsed-tramp-file-name (filename var &rest body) "Parse a Tramp filename and make components available in the body. @@ -1975,14 +1919,7 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (put 'with-parsed-tramp-file-name 'lisp-indent-function 2) (put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) -;; Enable debugging. -;(eval-and-compile -; (when (featurep 'edebug) -; (def-edebug-spec with-parsed-tramp-file-name (form symbolp body)))) -;; Highlight as keyword. -(when (functionp 'font-lock-add-keywords) - (funcall 'font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>"))) +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) (defmacro with-file-property (vec file property &rest body) "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. @@ -1997,8 +1934,10 @@ FILE must be a local file name on a connection identified via VEC." (tramp-set-file-property ,vec ,file ,property value)) value) ,@body)) + (put 'with-file-property 'lisp-indent-function 3) (put 'with-file-property 'edebug-form-spec t) +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-file-property\\>")) (defmacro with-connection-property (key property &rest body) "Checks in Tramp for property PROPERTY, otherwise executes BODY and set." @@ -2010,8 +1949,10 @@ FILE must be a local file name on a connection identified via VEC." (setq value (progn ,@body)) (tramp-set-connection-property ,key ,property value)) value)) + (put 'with-connection-property 'lisp-indent-function 2) (put 'with-connection-property 'edebug-form-spec t) +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-connection-property\\>")) (defmacro tramp-let-maybe (variable value &rest body) "Let-bind VARIABLE to VALUE in BODY, but only if VARIABLE is not obsolete. @@ -2024,6 +1965,44 @@ The intent is to protect against `obsolete variable' warnings." (put 'tramp-let-maybe 'lisp-indent-function 2) (put 'tramp-let-maybe 'edebug-form-spec t) +(defsubst tramp-make-tramp-temp-file (vec &optional dont-create) + "Create a temporary file on the remote host identified by VEC. +Return the local name of the temporary file. +If DONT-CREATE is non-nil, just the file name is returned without +creation of the temporary file. This is not the preferred way to run, +but it is necessary during connection setup, because we cannot create +a remote file at this time. This parameter shall NOT be set to +non-nil else." + (if dont-create + ;; It sounds a little bit stupid to create a LOCAL file name. + ;; But we intend to use the remote directory "/tmp", and we have + ;; no chance to check whether a temporary file exists already + ;; remotely, because we have no working connection yet. + (make-temp-name (expand-file-name tramp-temp-name-prefix "/tmp")) + + (let ((prefix + (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + (expand-file-name tramp-temp-name-prefix "/tmp"))) + result) + (while (not result) + ;; `make-temp-file' would be the first choice for + ;; implementation. But it calls `write-region' internally, + ;; which also needs a temporary file - we would end in an + ;; infinite loop. + (setq result (make-temp-name prefix)) + (if (file-exists-p result) + (setq result nil) + ;; This creates the file by side effect. + (set-file-times result) + (set-file-modes result (tramp-octal-to-decimal "0700")))) + + ;; Return the local part. + (with-parsed-tramp-file-name result nil localname)))) + + ;;; Config Manipulation Functions: (defun tramp-set-completion-function (method function-list) @@ -2076,6 +2055,55 @@ For definition of that list see `tramp-set-completion-function'." ;; The method related defaults. (cdr (assoc method tramp-completion-function-alist)))) + +;;; Fontification of `read-file-name'. + +;; rfn-eshadow.el is part of Emacs 22. Its is autoloaded. +(defvar tramp-rfn-eshadow-overlay) +(make-variable-buffer-local 'tramp-rfn-eshadow-overlay) + +(defun tramp-rfn-eshadow-setup-minibuffer () + "Set up a minibuffer for `file-name-shadow-mode'. +Adds another overlay hiding filename parts according to Tramp's +special handling of `substitute-in-file-name'." + (when (symbol-value 'minibuffer-completing-file-name) + (setq tramp-rfn-eshadow-overlay + (funcall (symbol-function 'make-overlay) + (funcall (symbol-function 'minibuffer-prompt-end)) + (funcall (symbol-function 'minibuffer-prompt-end)))) + ;; Copy rfn-eshadow-overlay properties. + (let ((props (funcall (symbol-function 'overlay-properties) + (symbol-value 'rfn-eshadow-overlay)))) + (while props + (funcall (symbol-function 'overlay-put) + tramp-rfn-eshadow-overlay (pop props) (pop props)))))) + +(when (boundp 'rfn-eshadow-setup-minibuffer-hook) + (add-hook 'rfn-eshadow-setup-minibuffer-hook + 'tramp-rfn-eshadow-setup-minibuffer)) + +(defun tramp-rfn-eshadow-update-overlay () + "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input. +This is intended to be used as a minibuffer `post-command-hook' for +`file-name-shadow-mode'; the minibuffer should have already +been set up by `rfn-eshadow-setup-minibuffer'." + ;; In remote files name, there is a shadowing just for the local part. + (let ((end (or (funcall (symbol-function 'overlay-end) + (symbol-value 'rfn-eshadow-overlay)) + (funcall (symbol-function 'minibuffer-prompt-end))))) + (when (file-remote-p (buffer-substring-no-properties end (point-max))) + (narrow-to-region + (1+ (or (string-match "/" (buffer-string) end) end)) (point-max)) + (let ((rfn-eshadow-overlay tramp-rfn-eshadow-overlay) + (rfn-eshadow-update-overlay-hook nil)) + (funcall (symbol-function 'rfn-eshadow-update-overlay))) + (widen)))) + +(when (boundp 'rfn-eshadow-update-overlay-hook) + (add-hook 'rfn-eshadow-update-overlay-hook + 'tramp-rfn-eshadow-update-overlay)) + + ;;; File Name Handler Functions: (defun tramp-handle-make-symbolic-link @@ -2112,9 +2140,9 @@ target of the symlink differ." ;; If FILENAME is a Tramp name, use just the localname component. (when (tramp-tramp-file-p filename) - (setq filename (tramp-file-name-localname - (tramp-dissect-file-name - (expand-file-name filename))))) + (setq filename + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name filename))))) ;; Right, they are on the same host, regardless of user, method, etc. ;; We now make the link on the remote machine. This will occur as the user @@ -2156,11 +2184,17 @@ target of the symlink differ." ;; Localname manipulation functions that grok TRAMP localnames... (defun tramp-handle-file-name-directory (file) "Like `file-name-directory' but aware of Tramp files." - ;; Everything except the last filename thing is the directory. - (with-parsed-tramp-file-name file nil + ;; Everything except the last filename thing is the directory. We + ;; cannot apply `with-parsed-tramp-file-name', because this expands + ;; the remote file name parts. This is a problem when we are in + ;; file name completion. + (let ((v (tramp-dissect-file-name file t))) ;; Run the command on the localname portion only. (tramp-make-tramp-file-name - method user host (file-name-directory (or localname ""))))) + (tramp-file-name-method v) + (tramp-file-name-user v) + (tramp-file-name-host v) + (file-name-directory (or (tramp-file-name-localname v) ""))))) (defun tramp-handle-file-name-nondirectory (file) "Like `file-name-nondirectory' but aware of Tramp files." @@ -2346,7 +2380,7 @@ target of the symlink differ." (when symlinkp (search-forward "-> ") (setq res-symlink-target - (buffer-substring (point) (tramp-line-end-position)))) + (buffer-substring (point) (tramp-compat-line-end-position)))) ;; return data gathered (list ;; 0. t for directory, string (name linked to) for symbolic @@ -2368,7 +2402,7 @@ target of the symlink differ." res-size ;; 8. File modes, as a string of ten letters or dashes as in ls -l. res-filemodes - ;; 9. t iff file's gid would change if file were deleted and + ;; 9. t if file's gid would change if file were deleted and ;; recreated. Will be set in `tramp-convert-file-attributes' t ;; 10. inode number. @@ -2560,7 +2594,7 @@ and gid of the corresponding user is taken. Both parameters must be integers." ;; `set-file-uid-gid'. (let ((uid (or (and (integerp uid) uid) (tramp-get-local-uid 'integer))) (gid (or (and (integerp gid) gid) (tramp-get-local-uid 'integer))) - (default-directory (tramp-temporary-file-directory))) + (default-directory (tramp-compat-temporary-file-directory))) (call-process "chown" nil nil nil (format "%d:%d" uid gid) (tramp-shell-quote-argument filename))))) @@ -2723,7 +2757,7 @@ and gid of the corresponding user is taken. Both parameters must be integers." (when (file-directory-p directory) (setq directory (expand-file-name directory)) (let* ((temp - (copy-tree + (tramp-compat-copy-tree (with-parsed-tramp-file-name directory nil (with-file-property v localname @@ -2817,7 +2851,8 @@ and gid of the corresponding user is taken. Both parameters must be integers." (with-current-buffer (tramp-get-buffer v) (goto-char (point-max)) (while (zerop (forward-line -1)) - (push (buffer-substring (point) (tramp-line-end-position)) + (push (buffer-substring + (point) (tramp-compat-line-end-position)) result))) result))))))) @@ -2873,17 +2908,23 @@ and gid of the corresponding user is taken. Both parameters must be integers." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) "Like `copy-file' for Tramp files." ;; Check if both files are local -- invoke normal copy-file. - ;; Otherwise, use tramp from local system. + ;; Otherwise, use Tramp from local system. (setq filename (expand-file-name filename)) (setq newname (expand-file-name newname)) - ;; At least one file a tramp file? - (if (or (tramp-tramp-file-p filename) - (tramp-tramp-file-p newname)) - (tramp-do-copy-or-rename-file - 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid) + (cond + ;; At least one file a tramp file? + ((or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid)) + ;; Compat section. + (preserve-uid-gid (tramp-run-real-handler 'copy-file - (list filename newname ok-if-already-exists keep-date preserve-uid-gid)))) + (list filename newname ok-if-already-exists keep-date preserve-uid-gid))) + (t + (tramp-run-real-handler + 'copy-file (list filename newname ok-if-already-exists keep-date))))) (defun tramp-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -3012,8 +3053,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (jka-compr-inhibit t)) (write-region (point-min) (point-max) newname)))) ;; KEEP-DATE handling. - (when (and keep-date (functionp 'set-file-times)) - (apply 'set-file-times (list newname modtime))) + (when keep-date (set-file-times newname modtime)) ;; Set the mode. (set-file-modes newname (file-modes filename)) ;; If the operation was `rename', delete the original file. @@ -3030,114 +3070,107 @@ the file (for rename). Both files must reside on the same host. KEEP-DATE means to make sure that NEWNAME has the same timestamp as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep the uid and gid from FILENAME." - (with-parsed-tramp-file-name (if t1 filename newname) nil - (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p") - ((eq op 'copy) "cp -f") - ((eq op 'rename) "mv -f") - (t (tramp-error - vec 'file-error - "Unknown operation `%s', must be `copy' or `rename'" - op)))) - (t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (localname1 - (if t1 (tramp-handle-file-remote-p filename 'localname) filename)) - (localname2 - (if t2 (tramp-handle-file-remote-p newname 'localname) newname)) - (prefix (tramp-handle-file-remote-p (if t1 filename newname))) - (tmpfile (tramp-make-temp-file localname1))) + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname))) + (with-parsed-tramp-file-name (if t1 filename newname) nil + (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p") + ((eq op 'copy) "cp -f") + ((eq op 'rename) "mv -f") + (t (tramp-error + v 'file-error + "Unknown operation `%s', must be `copy' or `rename'" + op)))) + (localname1 + (if t1 (tramp-handle-file-remote-p filename 'localname) filename)) + (localname2 + (if t2 (tramp-handle-file-remote-p newname 'localname) newname)) + (prefix (file-remote-p (if t1 filename newname)))) - (cond - ;; Both files are on a remote host, with same user. - ((and t1 t2) - (tramp-send-command - v - (format "%s %s %s" cmd - (tramp-shell-quote-argument localname1) - (tramp-shell-quote-argument localname2))) - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (unless - (or - (and keep-date - ;; Mask cp -f error. - (re-search-forward - tramp-operation-not-permitted-regexp nil t)) - (zerop (tramp-send-command-and-check v nil))) - (tramp-error-with-buffer - nil v 'file-error - "Copying directly failed, see buffer `%s' for details." - (buffer-name))))) - - ;; We are on the local host. - ((or t1 t2) (cond - ;; We can do it directly. - ((and (file-readable-p localname1) - (file-writable-p (file-name-directory localname2))) - (if (eq op 'copy) - (copy-file - localname1 localname2 ok-if-already-exists - keep-date preserve-uid-gid) - (rename-file localname1 localname2 ok-if-already-exists))) - - ;; We can do it directly with `tramp-send-command' - ((and (file-readable-p (concat prefix localname1)) - (file-writable-p - (file-name-directory (concat prefix localname2)))) - (tramp-do-copy-or-rename-file-directly - op (concat prefix localname1) (concat prefix localname2) - ok-if-already-exists keep-date t) - ;; We must change the ownership to the local user. - (tramp-set-file-uid-gid - (concat prefix localname2) - (tramp-get-local-uid 'integer) - (tramp-get-local-gid 'integer))) - - ;; We need a temporary file in between. - (t - ;; Create the temporary file. + ;; Both files are on a remote host, with same user. + ((and t1 t2) + (tramp-send-command + v + (format "%s %s %s" cmd + (tramp-shell-quote-argument localname1) + (tramp-shell-quote-argument localname2))) + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-min)) + (unless + (or + (and keep-date + ;; Mask cp -f error. + (re-search-forward + tramp-operation-not-permitted-regexp nil t)) + (zerop (tramp-send-command-and-check v nil))) + (tramp-error-with-buffer + nil v 'file-error + "Copying directly failed, see buffer `%s' for details." + (buffer-name))))) + + ;; We are on the local host. + ((or t1 t2) (cond - (t1 - (tramp-send-command - v (format - "%s %s %s" cmd - (tramp-shell-quote-argument localname1) - (tramp-shell-quote-argument tmpfile))) - ;; We must change the ownership as remote user. - (tramp-set-file-uid-gid - (concat prefix tmpfile) - (tramp-get-local-uid 'integer) - (tramp-get-local-gid 'integer))) - (t2 + ;; We can do it directly. + ((and (file-readable-p localname1) + (file-writable-p (file-name-directory localname2))) (if (eq op 'copy) - (copy-file - localname1 tmpfile ok-if-already-exists + (tramp-compat-copy-file + localname1 localname2 ok-if-already-exists keep-date preserve-uid-gid) - (rename-file localname1 tmpfile ok-if-already-exists)) - ;; We must change the ownership as local user. + (rename-file localname1 localname2 ok-if-already-exists))) + + ;; We can do it directly with `tramp-send-command' + ((and (file-readable-p (concat prefix localname1)) + (file-writable-p + (file-name-directory (concat prefix localname2)))) + (tramp-do-copy-or-rename-file-directly + op (concat prefix localname1) (concat prefix localname2) + ok-if-already-exists keep-date t) + ;; We must change the ownership to the local user. (tramp-set-file-uid-gid - tmpfile - (tramp-get-remote-uid v 'integer) - (tramp-get-remote-gid v 'integer)))) - - ;; Move the temporary file to its destination. - (cond - (t2 - (tramp-send-command - v (format - "%s %s %s" cmd - (tramp-shell-quote-argument tmpfile) - (tramp-shell-quote-argument localname2)))) - (t1 - (if (eq op 'copy) - (copy-file - tmpfile localname2 ok-if-already-exists - keep-date preserve-uid-gid) - (rename-file tmpfile localname2 ok-if-already-exists)))) + (concat prefix localname2) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) - ;; Remove temporary file. - (when (eq op 'copy) (delete-file tmpfile)))))) + ;; We need a temporary file in between. + (t + ;; Create the temporary file. + (let ((tmpfile (tramp-compat-make-temp-file localname1))) + (cond + (t1 + (tramp-send-command + v (format + "%s %s %s" cmd + (tramp-shell-quote-argument localname1) + (tramp-shell-quote-argument tmpfile))) + ;; We must change the ownership as remote user. + (tramp-set-file-uid-gid + (concat prefix tmpfile) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) + (t2 + (if (eq op 'copy) + (tramp-compat-copy-file + localname1 tmpfile ok-if-already-exists + keep-date preserve-uid-gid) + (rename-file localname1 tmpfile ok-if-already-exists)) + ;; We must change the ownership as local user. + (tramp-set-file-uid-gid + tmpfile + (tramp-get-remote-uid v 'integer) + (tramp-get-remote-gid v 'integer)))) + + ;; Move the temporary file to its destination. + (cond + (t2 + (tramp-send-command + v (format + "mv -f %s %s" + (tramp-shell-quote-argument tmpfile) + (tramp-shell-quote-argument localname2)))) + (t1 + (rename-file tmpfile localname2 ok-if-already-exists))))))))) ;; Set the time and mode. Mask possible errors. ;; Won't be applied for 'rename. @@ -3175,7 +3208,7 @@ be a local filename. The method used must be an out-of-band method." ;; Compose copy command. (setq spec `((?h . ,host) (?u . ,user) (?p . ,port) - (?t . ,(tramp-make-tramp-temp-file v)) + (?t . ,(tramp-make-tramp-temp-file v 'dont-create)) (?k . ,(if keep-date " " ""))) copy-program (tramp-get-method-parameter method 'tramp-copy-program) @@ -3196,7 +3229,7 @@ be a local filename. The method used must be an out-of-band method." ;; Check for program. (when (and (fboundp 'executable-find) (not (let ((default-directory - (tramp-temporary-file-directory))) + (tramp-compat-temporary-file-directory))) (executable-find copy-program)))) (tramp-error v 'file-error "Cannot find copy program: %s" copy-program)) @@ -3220,7 +3253,7 @@ be a local filename. The method used must be an out-of-band method." ;; set a timeout, because the copying of large files can ;; last longer than 60 secs. (let ((p (let ((default-directory - (tramp-temporary-file-directory))) + (tramp-compat-temporary-file-directory))) (apply 'start-process (tramp-get-connection-property v "process-name" nil) @@ -3241,9 +3274,8 @@ be a local filename. The method used must be an out-of-band method." (tramp-message v 0 "Transferring %s to %s...done" filename newname) ;; Handle KEEP-DATE argument. - (when (and keep-date (not copy-keep-date) (functionp 'set-file-times)) - (apply 'set-file-times - (list newname (nth 5 (file-attributes filename))))) + (when (and keep-date (not copy-keep-date)) + (set-file-times newname (nth 5 (file-attributes filename)))) ;; Set the mode. (unless (and keep-date copy-keep-date) @@ -3503,7 +3535,7 @@ the result will be a local, non-Tramp, filename." (tramp-send-command v (format "cd %s; pwd" uname)) (with-current-buffer (tramp-get-buffer v) (goto-char (point-min)) - (buffer-substring (point) (tramp-line-end-position))))) + (buffer-substring (point) (tramp-compat-line-end-position))))) (setq localname (concat uname fname)))) ;; There might be a double slash, for example when "~/" ;; expands to "/". Remove this. @@ -3516,7 +3548,7 @@ the result will be a local, non-Tramp, filename." ;; bound, because on Windows there would be problems with UNC ;; shares or Cygwin mounts. (tramp-let-maybe directory-sep-char ?/ - (let ((default-directory (tramp-temporary-file-directory))) + (let ((default-directory (tramp-compat-temporary-file-directory))) (tramp-make-tramp-file-name method user host (tramp-drop-volume-letter @@ -3554,7 +3586,7 @@ beginning of local filename are not substituted." ;; In XEmacs, electricity is implemented via a key map for ?/ and ?~, ;; which calls corresponding functions (see minibuf.el). (when (fboundp 'minibuffer-electric-separator) - (mapcar + (mapc '(lambda (x) (eval `(defadvice ,x @@ -3577,21 +3609,6 @@ beginning of local filename are not substituted." ;;; Remote commands. -(defsubst tramp-make-temp-file (filename) - (concat - (funcall (if (fboundp 'make-temp-file) 'make-temp-file 'make-temp-name) - (expand-file-name tramp-temp-name-prefix - (tramp-temporary-file-directory))) - (file-name-extension filename t))) - -(defsubst tramp-make-tramp-temp-file (vec) - (format - "/tmp/%s%s" - tramp-temp-name-prefix - (if (get-buffer-process (tramp-get-connection-buffer vec)) - (process-id (get-buffer-process (tramp-get-connection-buffer vec))) - (emacs-pid)))) - (defun tramp-handle-executable-find (command) "Like `executable-find' for Tramp files." (with-parsed-tramp-file-name default-directory nil @@ -3642,8 +3659,7 @@ beginning of local filename are not substituted." (error "Implementation does not handle immediate return")) (with-parsed-tramp-file-name default-directory nil - (let ((temp-name-prefix (tramp-make-tramp-temp-file v)) - command input stderr outbuf ret) + (let (command input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. (setq command (mapconcat 'tramp-shell-quote-argument (cons program args) " ")) @@ -3655,11 +3671,9 @@ beginning of local filename are not substituted." ;; INFILE is on the same remote host. (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. - (setq input (concat temp-name-prefix ".in")) - (copy-file - infile - (tramp-make-tramp-file-name method user host input) - t))) + (setq input (tramp-make-tramp-temp-file v) + tmpinput (tramp-make-tramp-file-name method user host input)) + (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) ;; Determine output. @@ -3688,7 +3702,9 @@ beginning of local filename are not substituted." (cadr destination) nil localname)) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. - (setq stderr (concat temp-name-prefix ".err")))) + (setq stderr (tramp-make-tramp-temp-file v) + tmpstderr (tramp-make-tramp-file-name + method user host stderr)))) ;; stderr to be discarded ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -3697,9 +3713,6 @@ beginning of local filename are not substituted." (setq outbuf (current-buffer)))) (when stderr (setq command (format "%s 2>%s" command stderr))) - ;; If we have a temporary file, it must be removed after operation. - (when (and input (string-match temp-name-prefix input)) - (setq command (format "%s; rm %s" command input))) ;; Goto working directory. (tramp-send-command v (format "cd %s" (tramp-shell-quote-argument localname))) @@ -3719,20 +3732,20 @@ beginning of local filename are not substituted." (error (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) - (unless ret - ;; Check return code. - (setq ret (tramp-send-command-and-check v nil)) - ;; Provide error file. - (when (and stderr (string-match temp-name-prefix stderr)) - (rename-file (tramp-make-tramp-file-name method user host stderr) - (cadr destination) t))) + + ;; Check return code. + (unless ret (setq ret (tramp-send-command-and-check v nil))) + ;; Provide error file. + (when tmpstderr (rename-file tmpstderr (cadr destination) t)) + ;; Cleanup. + (when tmpinput (delete-file tmpinput)) ;; Return exit status. ret))) (defun tramp-handle-call-process-region (start end program &optional delete buffer display &rest args) "Like `call-process-region' for Tramp files." - (let ((tmpfile (tramp-make-temp-file ""))) + (let ((tmpfile (tramp-compat-make-temp-file ""))) (write-region start end tmpfile) (when delete (delete-region start end)) (unwind-protect @@ -3770,7 +3783,7 @@ beginning of local filename are not substituted." (if (integerp asynchronous) (apply 'tramp-handle-start-file-process "*Async Shell*" buffer args) - (apply 'tramp-handle-process-file + (apply 'process-file (car args) nil buffer nil (cdr args))) ;; Insert error messages if they were separated. (when (listp buffer) @@ -3779,7 +3792,9 @@ beginning of local filename are not substituted." (delete-file (buffer-file-name (cadr buffer)))) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) - (display-message-or-buffer output-buffer))))) + (if (functionp 'display-message-or-buffer) + (funcall (symbol-function 'display-message-or-buffer) output-buffer) + (pop-to-buffer output-buffer)))))) ;; File Editing. @@ -3792,7 +3807,7 @@ beginning of local filename are not substituted." (with-parsed-tramp-file-name filename nil (let ((rem-enc (tramp-get-remote-coding v "remote-encoding")) (loc-dec (tramp-get-local-coding v "local-decoding")) - (tmpfil (tramp-make-temp-file filename))) + (tmpfile (tramp-compat-make-temp-file filename))) (unless (file-exists-p filename) (tramp-error v 'file-error @@ -3803,7 +3818,7 @@ beginning of local filename are not substituted." ((or (tramp-local-host-p v) (and (tramp-method-out-of-band-p v) (> (nth 7 (file-attributes filename)) tramp-copy-size-limit))) - (copy-file filename tmpfil t t)) + (copy-file filename tmpfile t t)) ;; Use inline encoding for file transfer. (rem-enc @@ -3828,29 +3843,29 @@ beginning of local filename are not substituted." filename loc-dec) (funcall loc-dec (point-min) (point-max)) (let ((coding-system-for-write 'binary)) - (write-region (point-min) (point-max) tmpfil)))) + (write-region (point-min) (point-max) tmpfile)))) ;; If tramp-decoding-function is not defined for this ;; method, we invoke tramp-decoding-command instead. - (let ((tmpfil2 (tramp-make-temp-file filename))) + (let ((tmpfile2 (tramp-compat-make-temp-file filename))) (let ((coding-system-for-write 'binary)) - (write-region (point-min) (point-max) tmpfil2)) + (write-region (point-min) (point-max) tmpfile2)) (tramp-message v 5 "Decoding remote file %s with command %s..." filename loc-dec) - (tramp-call-local-coding-command loc-dec tmpfil2 tmpfil) - (delete-file tmpfil2))) + (tramp-call-local-coding-command loc-dec tmpfile2 tmpfile) + (delete-file tmpfile2))) (tramp-message v 5 "Decoding remote file %s...done" filename) ;; Set proper permissions. - (set-file-modes tmpfil (file-modes filename)) + (set-file-modes tmpfile (file-modes filename)) ;; Set local user ownership. - (tramp-set-file-uid-gid tmpfil))) + (tramp-set-file-uid-gid tmpfile))) ;; Oops, I don't know what to do. (t (tramp-error v 'file-error "Wrong method specification for `%s'" method))) (run-hooks 'tramp-handle-file-local-copy-hook) - tmpfil))) + tmpfile))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." @@ -3887,7 +3902,7 @@ beginning of local filename are not substituted." (if (and (tramp-local-host-p v) (file-readable-p localname)) ;; Short track: if we are on the local host, we can run directly. - (insert-file-contents localname visit beg end replace) + (setq result (insert-file-contents localname visit beg end replace)) ;; `insert-file-contents-literally' takes care to avoid calling ;; jka-compr. By let-binding inhibit-file-name-operation, we @@ -3916,6 +3931,28 @@ beginning of local filename are not substituted." (list (expand-file-name filename) (cadr result)))))) +;; This is needed for XEmacs only. Code stolen from files.el. +(defun tramp-handle-insert-file-contents-literally + (filename &optional visit beg end replace) + "Like `insert-file-contents-literally' for Tramp files." + (let ((format-alist nil) + (after-insert-file-functions nil) + (coding-system-for-read 'no-conversion) + (coding-system-for-write 'no-conversion) + (find-buffer-file-type-function + (if (fboundp 'find-buffer-file-type) + (symbol-function 'find-buffer-file-type) + nil)) + (inhibit-file-name-handlers '(jka-compr-handler image-file-handler)) + (inhibit-file-name-operation 'insert-file-contents)) + (unwind-protect + (progn + (fset 'find-buffer-file-type (lambda (filename) t)) + (insert-file-contents filename visit beg end replace)) + (if find-buffer-file-type-function + (fset 'find-buffer-file-type find-buffer-file-type-function) + (fmakunbound 'find-buffer-file-type))))) + (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -3975,13 +4012,13 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for ;; all other cases we must do it ourselves. (when (boundp 'auto-save-file-name-transforms) - (mapcar + (mapc '(lambda (x) (when (and (string-match (car x) buffer-file-name) (not (car (cddr x)))) (setq tramp-auto-save-directory (or tramp-auto-save-directory - (tramp-temporary-file-directory))))) + (tramp-compat-temporary-file-directory))))) (symbol-value 'auto-save-file-name-transforms))) ;; Create directory. (when tramp-auto-save-directory @@ -4022,33 +4059,33 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." ;; (error ;; "tramp-handle-write-region: LOCKNAME must be nil or equal FILENAME")) - ;; XEmacs takes a coding system as the seventh argument, not `confirm' + ;; XEmacs takes a coding system as the seventh argument, not `confirm'. (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename)) (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename)) (tramp-error v 'file-error "File not overwritten"))) - (let ((rem-dec (tramp-get-remote-coding v "remote-decoding")) - (loc-enc (tramp-get-local-coding v "local-encoding")) - (modes (save-excursion (file-modes filename))) - ;; We use this to save the value of `last-coding-system-used' - ;; after writing the tmp file. At the end of the function, - ;; we set `last-coding-system-used' to this saved value. - ;; This way, any intermediary coding systems used while - ;; talking to the remote shell or suchlike won't hose this - ;; variable. This approach was snarfed from ange-ftp.el. - coding-system-used - ;; Write region into a tmp file. This isn't really needed if we - ;; use an encoding function, but currently we use it always - ;; because this makes the logic simpler. - (tmpfil (tramp-make-temp-file filename))) - - (if (and (tramp-local-host-p v) - (file-writable-p (file-name-directory localname))) - ;; Short track: if we are on the local host, we can run directly. - (if confirm - (write-region - start end localname append 'no-message lockname confirm) - (write-region start end localname append 'no-message lockname)) + (if (and (tramp-local-host-p v) + (file-writable-p (file-name-directory localname))) + ;; Short track: if we are on the local host, we can run directly. + (if confirm + (write-region + start end localname append 'no-message lockname confirm) + (write-region start end localname append 'no-message lockname)) + + (let ((rem-dec (tramp-get-remote-coding v "remote-decoding")) + (loc-enc (tramp-get-local-coding v "local-encoding")) + (modes (save-excursion (file-modes filename))) + ;; We use this to save the value of `last-coding-system-used' + ;; after writing the tmp file. At the end of the function, + ;; we set `last-coding-system-used' to this saved value. + ;; This way, any intermediary coding systems used while + ;; talking to the remote shell or suchlike won't hose this + ;; variable. This approach was snarfed from ange-ftp.el. + coding-system-used + ;; Write region into a tmp file. This isn't really needed if we + ;; use an encoding function, but currently we use it always + ;; because this makes the logic simpler. + (tmpfile (tramp-compat-make-temp-file filename))) ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call @@ -4056,8 +4093,8 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (tramp-run-real-handler 'write-region (if confirm ; don't pass this arg unless defined for backward compat. - (list start end tmpfil append 'no-message lockname confirm) - (list start end tmpfil append 'no-message lockname))) + (list start end tmpfile append 'no-message lockname confirm) + (list start end tmpfile append 'no-message lockname))) ;; Now, `last-coding-system-used' has the right value. Remember it. (when (boundp 'last-coding-system-used) (setq coding-system-used (symbol-value 'last-coding-system-used))) @@ -4065,7 +4102,7 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." ;; filename does not exist (eq modes nil) it has been renamed to ;; the backup file. This case `save-buffer' handles ;; permissions. - (when modes (set-file-modes tmpfil modes)) + (when modes (set-file-modes tmpfile modes)) ;; This is a bit lengthy due to the different methods possible for ;; file transfer. First, we check whether the method uses an rcp @@ -4079,11 +4116,11 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (and (tramp-method-out-of-band-p v) (integerp start) (> (- end start) tramp-copy-size-limit))) - (rename-file tmpfil filename t)) + (rename-file tmpfile filename t)) ;; Use inline file transfer (rem-dec - ;; Encode tmpfil + ;; Encode tmpfile (tramp-message v 5 "Encoding region...") (unwind-protect (with-temp-buffer @@ -4094,7 +4131,7 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." v 5 "Encoding region using function `%s'..." (symbol-name loc-enc)) (let ((coding-system-for-read 'binary)) - (insert-file-contents-literally tmpfil)) + (insert-file-contents-literally tmpfile)) ;; CCC. The following `let' is a workaround for ;; the base64.el that comes with pgnus-0.84. If ;; both of the following conditions are @@ -4105,13 +4142,13 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." ;; files, it seems.) The file in question is a ;; tmp file anyway. (let ((default-directory - (tramp-temporary-file-directory))) + (tramp-compat-temporary-file-directory))) (funcall loc-enc (point-min) (point-max)))) (tramp-message v 5 "Encoding region using command `%s'..." loc-enc) (unless (equal 0 (tramp-call-local-coding-command - loc-enc tmpfil t)) + loc-enc tmpfile t)) (tramp-error v 'file-error "Cannot write to `%s', local encoding command `%s' failed" @@ -4137,13 +4174,14 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." filename rem-dec) ;; When `file-precious-flag' is set, the region is ;; written to a temporary file. Check that the - ;; checksum is equal to that from the local tmpfil. + ;; checksum is equal to that from the local tmpfile. (when file-precious-flag (erase-buffer) (and ;; cksum runs locally - (let ((default-directory (tramp-temporary-file-directory))) - (zerop (call-process "cksum" tmpfil t))) + (let ((default-directory + (tramp-compat-temporary-file-directory))) + (zerop (call-process "cksum" tmpfile t))) ;; cksum runs remotely (zerop (tramp-send-command-and-check @@ -4164,7 +4202,7 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (tramp-flush-file-property v localname)) ;; Save exit. - (delete-file tmpfil))) + (delete-file tmpfile))) ;; That's not expected. (t @@ -4172,8 +4210,13 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." v 'file-error (concat "Method `%s' should specify both encoding and " "decoding command or an rcp program") - method)))) + method))) + + ;; Make `last-coding-system-used' have the right value. + (when coding-system-used + (set 'last-coding-system-used coding-system-used))) + ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime ;; We must pass modtime explicitely, because filename can be different @@ -4181,9 +4224,6 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (nth 5 (file-attributes filename)))) ;; Set the ownership. (tramp-set-file-uid-gid filename) - ;; Make `last-coding-system-used' have the right value. - (when coding-system-used - (set 'last-coding-system-used coding-system-used)) (when (or (eq visit t) (null visit) (stringp visit)) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))) @@ -4305,20 +4345,24 @@ ARGS are the arguments OPERATION has been called with." (defun tramp-find-foreign-file-name-handler (filename) "Return foreign file name handler if exists." - (when (and (stringp filename) (tramp-tramp-file-p filename) - (or (not (tramp-completion-mode)) - (not (string-match - tramp-completion-file-name-regexp filename)))) - (let (elt - res - (handler-alist tramp-foreign-file-name-handler-alist)) - (while handler-alist - (setq elt (car handler-alist) - handler-alist (cdr handler-alist)) - (when (funcall (car elt) filename) - (setq handler-alist nil) - (setq res (cdr elt)))) - res))) + (when (and (stringp filename) (tramp-tramp-file-p filename)) + (let ((v (tramp-dissect-file-name filename t)) + (handler tramp-foreign-file-name-handler-alist) + elt res) + ;; When we are not fully sure that filename completion is safe, + ;; we should not return a handler. + (when (or (tramp-file-name-method v) (tramp-file-name-user v) + (and (tramp-file-name-host v) + (not (member (tramp-file-name-host v) + (mapcar 'car tramp-methods)))) + (not (tramp-completion-mode-p))) + (while handler + (setq elt (car handler) + handler (cdr handler)) + (when (funcall (car elt) filename) + (setq handler nil + res (cdr elt)))) + res)))) ;; Main function. ;;;###autoload @@ -4327,7 +4371,7 @@ ARGS are the arguments OPERATION has been called with." Falls back to normal file name handler if no tramp file name handler exists." (save-match-data (let* ((filename (apply 'tramp-file-name-for-operation operation args)) - (completion (tramp-completion-mode)) + (completion (tramp-completion-mode-p)) (foreign (tramp-find-foreign-file-name-handler filename))) (with-parsed-tramp-file-name filename nil (cond @@ -4339,8 +4383,7 @@ Falls back to normal file name handler if no tramp file name handler exists." ((and completion (zerop (length localname)) (memq operation '(file-name-as-directory))) filename) - ;; Call the backend function. Set a connection property - ;; first, it will be reused for user/host name completion. + ;; Call the backend function. (foreign (apply foreign operation args)) ;; Nothing to do for us. (t (tramp-run-real-handler operation args))))))) @@ -4439,9 +4482,12 @@ Falls back to normal file name handler if no tramp file name handler exists." ;; `partial-completion-mode' is unknown in XEmacs. So we should ;; load it unconditionally there. In the GNU Emacs case, method/ ;; user/host name completion shall be bound to `partial-completion-mode'. + ;; `ido-mode' and `icy-mode' are other packages which extend file + ;; name completion. (when (or (not (boundp 'partial-completion-mode)) (symbol-value 'partial-completion-mode) - (featurep 'ido)) + (featurep 'ido) + (featurep 'icicles)) (add-to-list 'file-name-handler-alist (cons tramp-completion-file-name-regexp 'tramp-completion-file-name-handler)) @@ -4497,8 +4543,8 @@ Falls back to normal file name handler if no tramp file name handler exists." ;;- method user host ;;- (format "echo %s" (comint-quote-filename localname)))) (tramp-send-command v (format "echo %s" localname)) - (setq bufstr (buffer-substring (point-min) - (tramp-line-end-position))) + (setq bufstr (buffer-substring + (point-min) (tramp-compat-line-end-position))) (with-current-buffer (tramp-get-buffer v) (goto-char (point-min)) (if (string-equal localname bufstr) @@ -4528,7 +4574,15 @@ Falls back to normal file name handler if no tramp file name handler exists." (add-hook 'tramp-unload-hook '(lambda () (ad-unadvise 'PC-expand-many-files))))) -;;; File name handler functions for completion mode +;;; File name handler functions for completion mode. + +(defvar tramp-completion-mode nil + "If non-nil, external packages signal that they are in file name completion. + +This is necessary, because Tramp uses a heuristic depending on last +input event. This fails when external packages use other characters +but <TAB>, <SPACE> or ?\\? for file name completion. This variable +should never be set globally, the intention is to let-bind it.") ;; Necessary because `tramp-file-name-regexp-unified' and ;; `tramp-completion-file-name-regexp-unified' aren't different. If @@ -4541,35 +4595,38 @@ Falls back to normal file name handler if no tramp file name handler exists." ;; tramp file name syntax. Maybe another variable should be introduced ;; overwriting this check in such cases. Or we change tramp file name ;; syntax in order to avoid ambiguities, like in XEmacs ... -(defun tramp-completion-mode () +(defun tramp-completion-mode-p () "Checks whether method / user name / host name completion is active." - (or (equal last-input-event 'tab) - ;; Emacs - (and (natnump last-input-event) - (or - ;; ?\t has event-modifier 'control - (char-equal last-input-event ?\t) - (and (not (event-modifiers last-input-event)) - (or (char-equal last-input-event ?\?) - (char-equal last-input-event ?\ ))))) - ;; XEmacs - (and (featurep 'xemacs) - ;; `last-input-event' might be nil. - (not (null last-input-event)) - ;; `last-input-event' may have no character approximation. - (funcall (symbol-function 'event-to-character) last-input-event) - (or - ;; ?\t has event-modifier 'control - (char-equal - (funcall (symbol-function 'event-to-character) - last-input-event) ?\t) - (and (not (event-modifiers last-input-event)) - (or (char-equal - (funcall (symbol-function 'event-to-character) - last-input-event) ?\?) - (char-equal - (funcall (symbol-function 'event-to-character) - last-input-event) ?\ ))))))) + (or + ;; Signal from outside. + tramp-completion-mode + ;; Emacs. + (equal last-input-event 'tab) + (and (natnump last-input-event) + (or + ;; ?\t has event-modifier 'control. + (char-equal last-input-event ?\t) + (and (not (event-modifiers last-input-event)) + (or (char-equal last-input-event ?\?) + (char-equal last-input-event ?\ ))))) + ;; XEmacs. + (and (featurep 'xemacs) + ;; `last-input-event' might be nil. + (not (null last-input-event)) + ;; `last-input-event' may have no character approximation. + (funcall (symbol-function 'event-to-character) last-input-event) + (or + ;; ?\t has event-modifier 'control. + (char-equal + (funcall (symbol-function 'event-to-character) + last-input-event) ?\t) + (and (not (event-modifiers last-input-event)) + (or (char-equal + (funcall (symbol-function 'event-to-character) + last-input-event) ?\?) + (char-equal + (funcall (symbol-function 'event-to-character) + last-input-event) ?\ ))))))) ;; Method, host name and user name completion. ;; `tramp-completion-dissect-file-name' returns a list of @@ -4600,19 +4657,20 @@ Falls back to normal file name handler if no tramp file name handler exists." ;; Method dependent user / host combinations. (progn - (mapcar + (mapc (lambda (x) (setq all-user-hosts (append all-user-hosts (funcall (nth 0 x) (nth 1 x))))) (tramp-get-completion-function m)) - (setq result (append result - (mapcar - (lambda (x) - (tramp-get-completion-user-host - method user host (nth 0 x) (nth 1 x))) - (delq nil all-user-hosts))))) + (setq result + (append result + (mapcar + (lambda (x) + (tramp-get-completion-user-host + method user host (nth 0 x) (nth 1 x))) + (delq nil all-user-hosts))))) ;; Possible methods. (setq result @@ -4739,7 +4797,7 @@ They are collected by `tramp-completion-dissect-file-name1'." (concat tramp-prefix-regexp "/$")) 1 nil 3 nil))) - (mapcar (lambda (regexp) + (mapc (lambda (regexp) (add-to-list 'result (tramp-completion-dissect-file-name1 regexp name))) (list @@ -4821,7 +4879,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." Either user or host may be nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let ((default-directory (tramp-temporary-file-directory)) + (let ((default-directory (tramp-compat-temporary-file-directory)) res) (when (file-readable-p filename) (with-temp-buffer @@ -4839,7 +4897,7 @@ Either user or host may be nil." (concat "^\\(" tramp-host-regexp "\\)" "\\([ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) - (narrow-to-region (point) (tramp-line-end-position)) + (narrow-to-region (point) (tramp-compat-line-end-position)) (when (re-search-forward regexp nil t) (setq result (append (list (match-string 3) (match-string 1))))) (widen) @@ -4851,7 +4909,7 @@ Either user or host may be nil." User is always nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let ((default-directory (tramp-temporary-file-directory)) + (let ((default-directory (tramp-compat-temporary-file-directory)) res) (when (file-readable-p filename) (with-temp-buffer @@ -4866,7 +4924,7 @@ User is always nil." User is always nil." (let ((result) (regexp (concat "^\\(" tramp-host-regexp "\\)"))) - (narrow-to-region (point) (tramp-line-end-position)) + (narrow-to-region (point) (tramp-compat-line-end-position)) (when (re-search-forward regexp nil t) (setq result (list nil (match-string 1)))) (widen) @@ -4880,7 +4938,7 @@ User is always nil." User is always nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let ((default-directory (tramp-temporary-file-directory)) + (let ((default-directory (tramp-compat-temporary-file-directory)) res) (when (file-readable-p filename) (with-temp-buffer @@ -4895,7 +4953,7 @@ User is always nil." User is always nil." (let ((result) (regexp (concat "^[ \t]*Host[ \t]+" "\\(" tramp-host-regexp "\\)"))) - (narrow-to-region (point) (tramp-line-end-position)) + (narrow-to-region (point) (tramp-compat-line-end-position)) (when (re-search-forward regexp nil t) (setq result (list nil (match-string 1)))) (widen) @@ -4909,7 +4967,7 @@ User is always nil." User is always nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let* ((default-directory (tramp-temporary-file-directory)) + (let* ((default-directory (tramp-compat-temporary-file-directory)) (regexp (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$")) (files (when (file-directory-p dirname) (directory-files dirname))) result) @@ -4924,7 +4982,7 @@ User is always nil." User is always nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let* ((default-directory (tramp-temporary-file-directory)) + (let* ((default-directory (tramp-compat-temporary-file-directory)) (regexp (concat "^\\(" tramp-host-regexp "\\)\\.ssh-\\(dss\\|rsa\\)\\.pub$")) (files (when (file-directory-p dirname) (directory-files dirname))) @@ -4940,7 +4998,7 @@ User is always nil." User is always nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let ((default-directory (tramp-temporary-file-directory)) + (let ((default-directory (tramp-compat-temporary-file-directory)) res) (when (file-readable-p filename) (with-temp-buffer @@ -4955,7 +5013,7 @@ User is always nil." User is always nil." (let ((result) (regexp (concat "^\\(" tramp-host-regexp "\\)"))) - (narrow-to-region (point) (tramp-line-end-position)) + (narrow-to-region (point) (tramp-compat-line-end-position)) (when (re-search-forward regexp nil t) (unless (char-equal (or (char-after) ?\n) ?:) ; no IPv6 (setq result (list nil (match-string 1))))) @@ -4974,7 +5032,7 @@ User is always nil." Host is always \"localhost\"." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let ((default-directory (tramp-temporary-file-directory)) + (let ((default-directory (tramp-compat-temporary-file-directory)) res) (if (zerop (length tramp-current-user)) '(("root" nil)) @@ -4991,7 +5049,7 @@ Host is always \"localhost\"." Host is always \"localhost\"." (let ((result) (regexp (concat "^\\(" tramp-user-regexp "\\):"))) - (narrow-to-region (point) (tramp-line-end-position)) + (narrow-to-region (point) (tramp-compat-line-end-position)) (when (re-search-forward regexp nil t) (setq result (list (match-string 1) "localhost"))) (widen) @@ -5003,7 +5061,7 @@ Host is always \"localhost\"." User may be nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let ((default-directory (tramp-temporary-file-directory)) + (let ((default-directory (tramp-compat-temporary-file-directory)) res) (when (file-readable-p filename) (with-temp-buffer @@ -5021,7 +5079,7 @@ User may be nil." (concat "^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)" "\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) - (narrow-to-region (point) (tramp-line-end-position)) + (narrow-to-region (point) (tramp-compat-line-end-position)) (when (re-search-forward regexp nil t) (setq result (list (match-string 3) (match-string 1)))) (widen) @@ -5033,7 +5091,7 @@ User may be nil." User is always nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let ((default-directory (tramp-temporary-file-directory)) + (let ((default-directory (tramp-compat-temporary-file-directory)) res) (with-temp-buffer (when (zerop (call-process "reg" nil t nil "query" registry)) @@ -5047,7 +5105,7 @@ User is always nil." User is always nil." (let ((result) (regexp (concat (regexp-quote registry) "\\\\\\(.+\\)"))) - (narrow-to-region (point) (tramp-line-end-position)) + (narrow-to-region (point) (tramp-compat-line-end-position)) (when (re-search-forward regexp nil t) (setq result (list nil (match-string 1)))) (widen) @@ -5061,7 +5119,7 @@ User is always nil." Only send the definition if it has not already been done." (let* ((p (tramp-get-connection-process vec)) (scripts (tramp-get-connection-property p "scripts" nil))) - (unless (memq name scripts) + (unless (member name scripts) (tramp-message vec 5 "Sending script `%s'..." name) ;; The script could contain a call of Perl. This is masked with `%s'. (tramp-send-command-and-check @@ -5170,17 +5228,17 @@ from the default one." (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) (setq buffer-undo-list t) - ;; Activate outline-mode - (make-local-variable 'outline-regexp) - (make-local-variable 'outline-level) - ;; This runs `text-mode-hook' and `outline-mode-hook'. We must - ;; prevent that local processes die. Yes: I've seen - ;; `flyspell-mode', which starts "ispell" ... - (let ((default-directory (tramp-temporary-file-directory))) + ;; Activate outline-mode. This runs `text-mode-hook' and + ;; `outline-mode-hook'. We must prevent that local processes + ;; die. Yes: I've seen `flyspell-mode', which starts "ispell" + ;; ... + (let ((default-directory (tramp-compat-temporary-file-directory))) (outline-mode)) - (setq outline-regexp "[0-9]+:[0-9]+:[0-9]+ [a-z0-9-]+ (\\([0-9]+\\)) #") -; (setq outline-regexp "[a-z.-]+:[0-9]+: [a-z0-9-]+ (\\([0-9]+\\)) #") - (setq outline-level 'tramp-outline-level)) + (set (make-local-variable 'outline-regexp) + "[0-9]+:[0-9]+:[0-9]+ [a-z0-9-]+ (\\([0-9]+\\)) #") +; (set (make-local-variable 'outline-regexp) +; "[a-z.-]+:[0-9]+: [a-z0-9-]+ (\\([0-9]+\\)) #") + (set (make-local-variable 'outline-level) 'tramp-outline-level)) (current-buffer))) (defun tramp-outline-level () @@ -5235,7 +5293,8 @@ This function expects to be in the right *tramp* buffer." (when (search-backward "tramp_executable " nil t) (skip-chars-forward "^ ") (skip-chars-forward " ") - (setq result (buffer-substring (point) (tramp-line-end-position))))) + (setq result (buffer-substring + (point) (tramp-compat-line-end-position))))) result))) (defun tramp-set-remote-path (vec) @@ -5659,9 +5718,7 @@ process to set up. VEC specifies the connection." (tramp-send-command-internal vec "set +o vi +o emacs") (tramp-message vec 5 "Setting shell prompt") ;; Douglas Gray Stephens <DGrayStephens@slb.com> says that we must - ;; use "\n" here, not tramp-rsh-end-of-line. We also manually frob - ;; the last time we sent a command, to avoid `tramp-send-command' to - ;; send "echo are you awake". + ;; use "\n" here, not tramp-rsh-end-of-line. (tramp-send-command vec (format "PROMPT_COMMAND=''; PS1='%s%s%s'; PS2=''; PS3=''" @@ -5898,7 +5955,7 @@ INPUT can also be nil which means `/dev/null'. OUTPUT can be a string (which specifies a filename), or t (which means standard output and thus the current buffer), or nil (which means discard it)." - (let ((default-directory (tramp-temporary-file-directory))) + (let ((default-directory (tramp-compat-temporary-file-directory))) (call-process tramp-encoding-shell ;program (when (and input (not (string-match "%s" cmd))) @@ -5945,10 +6002,12 @@ Gateway hops are already opened." (setq choices tramp-default-proxies-alist))))) ;; Handle gateways. - (when (string-match (format - "^\\(%s\\|%s\\)$" - tramp-gw-tunnel-method tramp-gw-socks-method) - (tramp-file-name-method (car target-alist))) + (when (and (boundp 'tramp-gw-tunnel-method) + (string-match (format + "^\\(%s\\|%s\\)$" + (symbol-value 'tramp-gw-tunnel-method) + (symbol-value 'tramp-gw-socks-method)) + (tramp-file-name-method (car target-alist)))) (let ((gw (pop target-alist)) (hop (pop target-alist))) ;; Is the method prepared for gateways? @@ -5973,7 +6032,7 @@ Gateway hops are already opened." 'target-alist (vector (tramp-file-name-method hop) (tramp-file-name-user hop) - (tramp-gw-open-connection vec gw hop) nil)) + (funcall (symbol-function 'tramp-gw-open-connection) vec gw hop) nil)) ;; For the password prompt, we need the correct values. ;; Therefore, we must remember the gateway vector. But we ;; cannot do it as connection property, because it shouldn't @@ -6013,16 +6072,23 @@ connection if a previous connection has died for some reason." ;; tries to send some data to the remote end. So that's why we ;; try to send a command from time to time, then look again ;; whether the process is really alive. - (when (and (> (tramp-time-diff - (current-time) - (tramp-get-connection-property p "last-cmd-time" '(0 0 0))) - 60) - p (processp p) (memq (process-status p) '(run open))) - (tramp-send-command vec "echo are you awake" t t) - (unless (and (memq (process-status p) '(run open)) - (tramp-wait-for-output p 10)) - (delete-process p) - (setq p nil))) + (condition-case nil + (when (and (> (tramp-time-diff + (current-time) + (tramp-get-connection-property + p "last-cmd-time" '(0 0 0))) + 60) + p (processp p) (memq (process-status p) '(run open))) + (tramp-send-command vec "echo are you awake" t t) + (unless (and (memq (process-status p) '(run open)) + (tramp-wait-for-output p 10)) + ;; The error will be catched locally. + (tramp-error vec 'file-error "Awake did fail"))) + (file-error + (tramp-flush-connection-property vec nil) + (tramp-flush-connection-property p nil) + (delete-process p) + (setq p nil))) ;; New connection must be opened. (unless (and p (processp p) (memq (process-status p) '(run open))) @@ -6053,7 +6119,8 @@ connection if a previous connection has died for some reason." (process-adaptive-read-buffering nil) (coding-system-for-read nil) ;; This must be done in order to avoid our file name handler. - (p (let ((default-directory (tramp-temporary-file-directory))) + (p (let ((default-directory + (tramp-compat-temporary-file-directory))) (start-process (or (tramp-get-connection-property vec "process-name" nil) (tramp-buffer-name vec)) @@ -6113,7 +6180,7 @@ connection if a previous connection has died for some reason." l-user (or l-user "") l-port (or l-port "") spec `((?h . ,l-host) (?u . ,l-user) (?p . ,l-port) - (?t . ,(tramp-make-tramp-temp-file vec))) + (?t . ,(tramp-make-tramp-temp-file vec 'dont-create))) command (concat command " " @@ -6238,8 +6305,8 @@ In case there is no valid Lisp expression, it raises an error" (condition-case nil (prog1 (read (current-buffer)) ;; Error handling. - (when (re-search-forward "\\S-" (tramp-line-end-position) t) - (error))) + (when (re-search-forward "\\S-" (tramp-compat-line-end-position) t) + (error nil))) (error (tramp-error vec 'file-error "`%s' does not return a valid Lisp expression: `%s'" @@ -6380,7 +6447,8 @@ Return ATTR." ;; Convert file size. (when (< (nth 7 attr) 0) (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) (<= (nth 7 attr) most-positive-fixnum)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) (tramp-compat-most-positive-fixnum))) (setcar (nthcdr 7 attr) (round (nth 7 attr)))) ;; Convert file mode bits to string. (unless (stringp (nth 8 attr)) @@ -6524,7 +6592,7 @@ Not actually used. Use `(format \"%o\" i)' instead?" ;; The host part of a Tramp file name vector can be of kind ;; "host#port". Sometimes, we must extract these parts. -(defsubst tramp-file-name-real-host (vec) +(defun tramp-file-name-real-host (vec) "Return the host name of VEC without port." (let ((host (tramp-file-name-host vec))) (if (and (stringp host) @@ -6532,7 +6600,7 @@ Not actually used. Use `(format \"%o\" i)' instead?" (match-string 1 host) host))) -(defsubst tramp-file-name-port (vec) +(defun tramp-file-name-port (vec) "Return the port number of VEC." (let ((host (tramp-file-name-host vec))) (and (stringp host) @@ -6540,11 +6608,11 @@ Not actually used. Use `(format \"%o\" i)' instead?" (string-to-number (match-string 2 host))))) (defun tramp-tramp-file-p (name) - "Return t iff NAME is a tramp file." + "Return t if NAME is a tramp file." (save-match-data (string-match tramp-file-name-regexp name))) -(defsubst tramp-find-method (method user host) +(defun tramp-find-method (method user host) "Return the right method string to use. This is METHOD, if non-nil. Otherwise, do a lookup in `tramp-default-method-alist'." @@ -6560,7 +6628,7 @@ This is METHOD, if non-nil. Otherwise, do a lookup in lmethod) tramp-default-method)) -(defsubst tramp-find-user (method user host) +(defun tramp-find-user (method user host) "Return the right user string to use. This is USER, if non-nil. Otherwise, do a lookup in `tramp-default-user-alist'." @@ -6576,16 +6644,18 @@ This is USER, if non-nil. Otherwise, do a lookup in luser) tramp-default-user)) -(defsubst tramp-find-host (method user host) +(defun tramp-find-host (method user host) "Return the right host string to use. This is HOST, if non-nil. Otherwise, it is `tramp-default-host'." (or (and (> (length host) 0) host) tramp-default-host)) -(defun tramp-dissect-file-name (name) +(defun tramp-dissect-file-name (name &optional nodefault) "Return a `tramp-file-name' structure. -The structure consists of remote method, remote user, remote host and -localname (file name on remote host)." +The structure consists of remote method, remote user, remote host +and localname (file name on remote host). If NODEFAULT is +non-nil, the file name parts are not expanded to their default +values." (save-match-data (let ((match (string-match (nth 0 tramp-file-name-structure) name))) (unless match (error "Not a tramp file name: %s" name)) @@ -6593,11 +6663,13 @@ localname (file name on remote host)." (user (match-string (nth 2 tramp-file-name-structure) name)) (host (match-string (nth 3 tramp-file-name-structure) name)) (localname (match-string (nth 4 tramp-file-name-structure) name))) - (vector - (tramp-find-method method user host) - (tramp-find-user method user host) - (tramp-find-host method user host) - localname))))) + (if nodefault + (vector method user host localname) + (vector + (tramp-find-method method user host) + (tramp-find-user method user host) + (tramp-find-host method user host) + localname)))))) (defun tramp-equal-remote (file1 file2) "Checks, whether the remote parts of FILE1 and FILE2 are identical. @@ -6666,7 +6738,7 @@ necessary only. This function will be used in file name completion." (defun tramp-get-remote-path (vec) (with-connection-property vec "remote-path" - (let* ((remote-path (copy-tree tramp-remote-path)) + (let* ((remote-path (tramp-compat-copy-tree tramp-remote-path)) (elt (memq 'tramp-default-remote-path remote-path)) (default-remote-path (when elt @@ -6843,7 +6915,7 @@ necessary only. This function will be used in file name completion." (if (equal id-format 'integer) (user-uid) (user-login-name))) (defun tramp-get-local-gid (id-format) - (nth 3 (file-attributes "~/" id-format))) + (nth 3 (tramp-compat-file-attributes "~/" id-format))) ;; Some predefined connection properties. (defun tramp-get-remote-coding (vec prop) @@ -6951,25 +7023,6 @@ ALIST is of the form ((FROM . TO) ...)." ;; -- Compatibility functions section -- ;; ------------------------------------------------------------ -(defun tramp-temporary-file-directory () - "Return name of directory for temporary files (compat function). -For Emacs, this is the variable `temporary-file-directory', for XEmacs -this is the function `temp-directory'." - (cond ((boundp 'temporary-file-directory) - (symbol-value 'temporary-file-directory)) - ((fboundp 'temp-directory) - (funcall (symbol-function 'temp-directory))) ;pacify byte-compiler - ((let ((d (getenv "TEMP"))) (and d (file-directory-p d))) - (file-name-as-directory (getenv "TEMP"))) - ((let ((d (getenv "TMP"))) (and d (file-directory-p d))) - (file-name-as-directory (getenv "TMP"))) - ((let ((d (getenv "TMPDIR"))) (and d (file-directory-p d))) - (file-name-as-directory (getenv "TMPDIR"))) - ((file-exists-p "c:/temp") (file-name-as-directory "c:/temp")) - (t (message (concat "Neither `temporary-file-directory' nor " - "`temp-directory' is defined -- using /tmp.")) - (file-name-as-directory "/tmp")))) - (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Invokes `password-read' if available, `read-passwd' else." @@ -6982,8 +7035,9 @@ Invokes `password-read' if available, `read-passwd' else." (tramp-check-for-regexp proc tramp-password-prompt-regexp) (format "%s for %s " (capitalize (match-string 1)) key))))) (if (functionp 'password-read) - (let ((password (apply #'password-read (list pw-prompt key)))) - (apply #'password-cache-add (list key password)) + (let ((password (funcall (symbol-function 'password-read) + pw-prompt key))) + (funcall (symbol-function 'password-cache-add) key password) password) (read-passwd pw-prompt)))) @@ -6992,12 +7046,12 @@ Invokes `password-read' if available, `read-passwd' else." If METHOD, USER or HOST is given, take then for computing the key." (interactive) (when (functionp 'password-cache-remove) - (apply #'password-cache-remove - (list (tramp-make-tramp-file-name - tramp-current-method - tramp-current-user - tramp-current-host - ""))))) + (funcall (symbol-function 'password-cache-remove) + (tramp-make-tramp-file-name + tramp-current-method + tramp-current-user + tramp-current-host + "")))) ;; Snarfed code from time-date.el and parse-time.el @@ -7054,19 +7108,18 @@ T1 and T2 are time values (as returned by `current-time' for example)." "Return a coding system like CODING-SYSTEM but with given EOL-TYPE. EOL-TYPE can be one of `dos', `unix', or `mac'." (cond ((fboundp 'coding-system-change-eol-conversion) - (apply #'coding-system-change-eol-conversion - (list coding-system eol-type))) + (funcall (symbol-function 'coding-system-change-eol-conversion) + coding-system eol-type)) ((fboundp 'subsidiary-coding-system) - (apply - #'subsidiary-coding-system - (list coding-system - (cond ((eq eol-type 'dos) 'crlf) - ((eq eol-type 'unix) 'lf) - ((eq eol-type 'mac) 'cr) - (t - (error "Unknown EOL-TYPE `%s', must be %s" - eol-type - "`dos', `unix', or `mac'")))))) + (funcall (symbol-function 'subsidiary-coding-system) + coding-system + (cond ((eq eol-type 'dos) 'crlf) + ((eq eol-type 'unix) 'lf) + ((eq eol-type 'mac) 'cr) + (t + (error "Unknown EOL-TYPE `%s', must be %s" + eol-type + "`dos', `unix', or `mac'"))))) (t (error "Can't change EOL conversion -- is MULE missing?")))) (defun tramp-split-string (string pattern) @@ -7143,19 +7196,19 @@ Only works for Bourne-like shells." ;; CCC: This check is now also really awful; we should search all ;; of the filename format, not just the prefix. (when (string-match "\\[" tramp-prefix-format) - (defadvice file-expand-wildcards (around tramp-fix activate) + (defadvice file-expand-wildcards + (around tramp-advice-file-expand-wildcards activate) (let ((name (ad-get-arg 0))) (if (tramp-tramp-file-p name) ;; If it's a Tramp file, dissect it and look if wildcards ;; need to be expanded at all. - (let ((v (tramp-dissect-file-name name))) - (if (string-match "[[*?]" (tramp-file-name-localname v)) - (let ((res ad-do-it)) - (setq ad-return-value (or res (list name)))) - (setq ad-return-value (list name)))) + (if (string-match + "[[*?]" + (tramp-file-name-localname (tramp-dissect-file-name name))) + (setq ad-return-value (or ad-do-it (list name))) + (setq ad-return-value (list name))) ;; If it is not a Tramp file, just run the original function. - (let ((res ad-do-it)) - (setq ad-return-value (or res (list name))))))) + (setq ad-return-value (or ad-do-it (list name)))))) (add-hook 'tramp-unload-hook '(lambda () (ad-unadvise 'file-expand-wildcards)))) @@ -7250,7 +7303,7 @@ and what the local and remote machines are. If you can give a simple set of instructions to make this bug happen reliably, please include those. Thank you for helping -kill bugs in TRAMP. +kill bugs in Tramp. Another useful thing to do is to put @@ -7370,7 +7423,8 @@ Used for non-7bit chars in strings." (setq buffer-read-only nil) (goto-char (point-min)) (while (not (eobp)) - (if (re-search-forward tramp-buf-regexp (tramp-line-end-position) t) + (if (re-search-forward + tramp-buf-regexp (tramp-compat-line-end-position) t) (forward-line 1) (forward-line 0) (let ((start (point))) @@ -7443,18 +7497,6 @@ please ensure that the buffers are attached to your email.\n\n") (provide 'tramp) -;; Make sure that we get integration with the VC package. -;; When it is loaded, we need to pull in the integration module. -;; This must come after (provide 'tramp) because tramp-vc.el -;; requires tramp. Not necessary in Emacs 23. -(eval-after-load "vc" - '(unless (functionp 'start-file-process) - (require 'tramp-vc) - (add-hook 'tramp-unload-hook - '(lambda () - (when (featurep 'tramp-vc) - (unload-feature 'tramp-vc 'force)))))) - ;;; TODO: ;; * Allow putting passwords in the filename. @@ -7470,7 +7512,7 @@ please ensure that the buffers are attached to your email.\n\n") ;; indefinitely blocking piece of code. In this case it would be ;; within Tramp around one of its calls to accept-process-output (or ;; around one of the loops that calls accept-process-output) -;; (Stefann Monnier). +;; (Stefan Monnier). ;; * Autodetect if remote `ls' groks the "--dired" switch. ;; * Add fallback for inline encodings. This should be used ;; if the remote end doesn't support mimencode or a similar program. @@ -7528,14 +7570,8 @@ please ensure that the buffers are attached to your email.\n\n") ;; * When editing a remote CVS controlled file as a different user, VC ;; gets confused about the file locking status. Try to find out why ;; the workaround doesn't work. -;; * Change `copy-file' to grok the case where the filename handler -;; for the source and the target file are different. Right now, -;; it looks at the source file and then calls that handler, if -;; there is one. But since ange-ftp, for instance, does not know -;; about Tramp, it does not do the right thing if the target file -;; name is a Tramp name. ;; * Username and hostname completion. -;; ** Try to avoid usage of `last-input-event' in `tramp-completion-mode'. +;; ** Try to avoid usage of `last-input-event' in `tramp-completion-mode-p'. ;; ** Unify `tramp-parse-{rhosts,shosts,sconfig,hosts,passwd,netrc}'. ;; Code is nearly identical. ;; * Allow out-of-band methods as _last_ multi-hop. diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 6e48c3c7f47..c8da0add016 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -1,5 +1,5 @@ -;;; -*- mode: Emacs-Lisp; coding: utf-8; -*- ;;; trampver.el --- Transparent Remote Access, Multiple Protocol +;;; -*- mode: Emacs-Lisp; coding: utf-8; -*- ;;; lisp/trampver.el. Generated from trampver.el.in by configure. ;; Copyright (C) 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. diff --git a/lisp/obsolete/hilit19.el b/lisp/obsolete/hilit19.el index c29d4fad3dd..9221753a864 100644 --- a/lisp/obsolete/hilit19.el +++ b/lisp/obsolete/hilit19.el @@ -665,9 +665,9 @@ The optional 5th arg, PROP is a property to set instead of 'hilit." (or quietly hilit-quietly (message "Unhighlighting")) (let ((lstart 0)) (while (and start (> start lstart) (< start end)) - (mapcar (function (lambda (ovr) - (and (overlay-get ovr 'hilit) (delete-overlay ovr)))) - (overlays-at start)) + (mapc (function (lambda (ovr) + (and (overlay-get ovr 'hilit) (delete-overlay ovr)))) + (overlays-at start)) (setq lstart start start (next-overlay-change start)))) (or quietly hilit-quietly (message "Done unhighlighting"))) @@ -1023,11 +1023,11 @@ See the variable hilit-mode-enable-list. Takes optional arguments PARSE-FN and CASE-FOLD." ;; change pattern - (mapcar (function (lambda (p) - (and (stringp (car p)) - (null (nth 1 p)) - (setcar (cdr p) 0)))) - patterns) + (mapc (function (lambda (p) + (and (stringp (car p)) + (null (nth 1 p)) + (setcar (cdr p) 0)))) + patterns) (setq patterns (cons case-fold patterns)) (or (consp modelist) (setq modelist (list modelist))) diff --git a/lisp/obsolete/sun-fns.el b/lisp/obsolete/sun-fns.el index 2f95d5011c1..1b6a5d239bd 100644 --- a/lisp/obsolete/sun-fns.el +++ b/lisp/obsolete/sun-fns.el @@ -385,7 +385,6 @@ relative X divided by window width." ) (defmenu emacs-quit-menu - ("Suspend" suspend-emacstool) ("Quit" save-buffers-kill-emacs)) (defmenu emacs-menu diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el index 133c6efc0d2..5f8709d17b7 100644 --- a/lisp/play/bubbles.el +++ b/lisp/play/bubbles.el @@ -43,6 +43,9 @@ ;;; History: +;; 0.5 (2007-09-14) +;; - Minor bugfixes. + ;; 0.4 (2007-08-27) ;; - Allow for undoing last move. ;; - Bonus for removing all bubbles. @@ -78,7 +81,7 @@ ;;; Code: -(defconst bubbles-version "0.4" "Version number of bubbles.el.") +(defconst bubbles-version "0.5" "Version number of bubbles.el.") (require 'gamegrid) (require 'cl) @@ -824,89 +827,98 @@ static char * dot3d_xpm[] = { (bubbles--initialize-images) (bubbles--update-faces-or-images)) -;; bubbles mode map -(defvar bubbles-mode-map - (make-keymap 'bubbles-mode-map)) -(define-key bubbles-mode-map "q" 'bubbles-quit) -(define-key bubbles-mode-map "\n" 'bubbles-plop) -(define-key bubbles-mode-map " " 'bubbles-plop) -(define-key bubbles-mode-map [double-down-mouse-1] 'bubbles-plop) -(define-key bubbles-mode-map [mouse-2] 'bubbles-plop) -(define-key bubbles-mode-map "\C-m" 'bubbles-plop) -(define-key bubbles-mode-map "u" 'bubbles-undo) -(define-key bubbles-mode-map "p" 'previous-line) -(define-key bubbles-mode-map "n" 'next-line) -(define-key bubbles-mode-map "f" 'forward-char) -(define-key bubbles-mode-map "b" 'backward-char) - - ;; game theme menu -(defvar bubbles-game-theme-menu (make-sparse-keymap "Game Theme")) -(define-key bubbles-game-theme-menu [bubbles-set-game-userdefined] - (list 'menu-item "User defined" 'bubbles-set-game-userdefined - :button '(:radio . (eq bubbles-game-theme 'user-defined)))) -(define-key bubbles-game-theme-menu [bubbles-set-game-hard] - (list 'menu-item "Hard" 'bubbles-set-game-hard - :button '(:radio . (eq bubbles-game-theme 'hard)))) -(define-key bubbles-game-theme-menu [bubbles-set-game-difficult] - (list 'menu-item "Difficult" 'bubbles-set-game-difficult - :button '(:radio . (eq bubbles-game-theme 'difficult)))) -(define-key bubbles-game-theme-menu [bubbles-set-game-medium] - (list 'menu-item "Medium" 'bubbles-set-game-medium - :button '(:radio . (eq bubbles-game-theme 'medium)))) -(define-key bubbles-game-theme-menu [bubbles-set-game-easy] - (list 'menu-item "Easy" 'bubbles-set-game-easy - :button '(:radio . (eq bubbles-game-theme 'easy)))) +(defvar bubbles-game-theme-menu + (let ((menu (make-sparse-keymap "Game Theme"))) + (define-key menu [bubbles-set-game-userdefined] + (list 'menu-item "User defined" 'bubbles-set-game-userdefined + :button '(:radio . (eq bubbles-game-theme 'user-defined)))) + (define-key menu [bubbles-set-game-hard] + (list 'menu-item "Hard" 'bubbles-set-game-hard + :button '(:radio . (eq bubbles-game-theme 'hard)))) + (define-key menu [bubbles-set-game-difficult] + (list 'menu-item "Difficult" 'bubbles-set-game-difficult + :button '(:radio . (eq bubbles-game-theme 'difficult)))) + (define-key menu [bubbles-set-game-medium] + (list 'menu-item "Medium" 'bubbles-set-game-medium + :button '(:radio . (eq bubbles-game-theme 'medium)))) + (define-key menu [bubbles-set-game-easy] + (list 'menu-item "Easy" 'bubbles-set-game-easy + :button '(:radio . (eq bubbles-game-theme 'easy)))) + menu) + "Map for bubbles game theme menu.") ;; graphics theme menu -(defvar bubbles-graphics-theme-menu (make-sparse-keymap "Graphics Theme")) -(define-key bubbles-graphics-theme-menu [bubbles-set-graphics-theme-ascii] - (list 'menu-item "ASCII" 'bubbles-set-graphics-theme-ascii - :button '(:radio . (eq bubbles-graphics-theme 'ascii)))) -(define-key bubbles-graphics-theme-menu [bubbles-set-graphics-theme-emacs] - (list 'menu-item "Emacs" 'bubbles-set-graphics-theme-emacs - :button '(:radio . (eq bubbles-graphics-theme 'emacs)))) -(define-key bubbles-graphics-theme-menu [bubbles-set-graphics-theme-balls] - (list 'menu-item "Balls" 'bubbles-set-graphics-theme-balls - :button '(:radio . (eq bubbles-graphics-theme 'balls)))) -(define-key bubbles-graphics-theme-menu [bubbles-set-graphics-theme-diamonds] - (list 'menu-item "Diamonds" 'bubbles-set-graphics-theme-diamonds - :button '(:radio . (eq bubbles-graphics-theme 'diamonds)))) -(define-key bubbles-graphics-theme-menu [bubbles-set-graphics-theme-squares] - (list 'menu-item "Squares" 'bubbles-set-graphics-theme-squares - :button '(:radio . (eq bubbles-graphics-theme 'squares)))) -(define-key bubbles-graphics-theme-menu [bubbles-set-graphics-theme-circles] - (list 'menu-item "Circles" 'bubbles-set-graphics-theme-circles - :button '(:radio . (eq bubbles-graphics-theme 'circles)))) +(defvar bubbles-graphics-theme-menu + (let ((menu (make-sparse-keymap "Graphics Theme"))) + (define-key menu [bubbles-set-graphics-theme-ascii] + (list 'menu-item "ASCII" 'bubbles-set-graphics-theme-ascii + :button '(:radio . (eq bubbles-graphics-theme 'ascii)))) + (define-key menu [bubbles-set-graphics-theme-emacs] + (list 'menu-item "Emacs" 'bubbles-set-graphics-theme-emacs + :button '(:radio . (eq bubbles-graphics-theme 'emacs)))) + (define-key menu [bubbles-set-graphics-theme-balls] + (list 'menu-item "Balls" 'bubbles-set-graphics-theme-balls + :button '(:radio . (eq bubbles-graphics-theme 'balls)))) + (define-key menu [bubbles-set-graphics-theme-diamonds] + (list 'menu-item "Diamonds" 'bubbles-set-graphics-theme-diamonds + :button '(:radio . (eq bubbles-graphics-theme 'diamonds)))) + (define-key menu [bubbles-set-graphics-theme-squares] + (list 'menu-item "Squares" 'bubbles-set-graphics-theme-squares + :button '(:radio . (eq bubbles-graphics-theme 'squares)))) + (define-key menu [bubbles-set-graphics-theme-circles] + (list 'menu-item "Circles" 'bubbles-set-graphics-theme-circles + :button '(:radio . (eq bubbles-graphics-theme 'circles)))) + menu) + "Map for bubbles graphics theme menu.") ;; menu -(defvar bubbles-menu (make-sparse-keymap "Bubbles")) -(define-key bubbles-menu [bubbles-quit] - (list 'menu-item "Quit" 'bubbles-quit)) -(define-key bubbles-menu [bubbles] - (list 'menu-item "New game" 'bubbles)) -(define-key bubbles-menu [bubbles-separator-1] - '("--")) -(define-key bubbles-menu [bubbles-save-settings] - (list 'menu-item "Save all settings" 'bubbles-save-settings)) -(define-key bubbles-menu [bubbles-customize] - (list 'menu-item "Edit all settings" 'bubbles-customize)) -(define-key bubbles-menu [bubbles-game-theme-menu] - (list 'menu-item "Game Theme" bubbles-game-theme-menu)) -(define-key bubbles-menu [bubbles-graphics-theme-menu] - (list 'menu-item "Graphics Theme" bubbles-graphics-theme-menu - :enable 'bubbles--playing)) -(define-key bubbles-menu [bubbles-separator-2] - '("--")) -(define-key bubbles-menu [bubbles-undo] - (list 'menu-item "Undo last move" 'bubbles-undo - :enable '(and bubbles--playing bubbles--save-data))) - -;; bind menu to mouse -(define-key bubbles-mode-map [down-mouse-3] bubbles-menu) -;; Put menu in menu-bar -(define-key bubbles-mode-map [menu-bar Bubbles] - (cons "Bubbles" bubbles-menu)) +(defvar bubbles-menu + (let ((menu (make-sparse-keymap "Bubbles"))) + (define-key menu [bubbles-quit] + (list 'menu-item "Quit" 'bubbles-quit)) + (define-key menu [bubbles] + (list 'menu-item "New game" 'bubbles)) + (define-key menu [bubbles-separator-1] + '("--")) + (define-key menu [bubbles-save-settings] + (list 'menu-item "Save all settings" 'bubbles-save-settings)) + (define-key menu [bubbles-customize] + (list 'menu-item "Edit all settings" 'bubbles-customize)) + (define-key menu [bubbles-game-theme-menu] + (list 'menu-item "Game Theme" bubbles-game-theme-menu)) + (define-key menu [bubbles-graphics-theme-menu] + (list 'menu-item "Graphics Theme" bubbles-graphics-theme-menu + :enable 'bubbles--playing)) + (define-key menu [bubbles-separator-2] + '("--")) + (define-key menu [bubbles-undo] + (list 'menu-item "Undo last move" 'bubbles-undo + :enable '(and bubbles--playing (listp buffer-undo-list)))) + menu) + "Map for bubbles menu.") + +;; bubbles mode map +(defvar bubbles-mode-map + (let ((map (make-sparse-keymap 'bubbles-mode-map))) +;; (suppress-keymap map t) + (define-key map "q" 'bubbles-quit) + (define-key map "\n" 'bubbles-plop) + (define-key map " " 'bubbles-plop) + (define-key map [double-down-mouse-1] 'bubbles-plop) + (define-key map [mouse-2] 'bubbles-plop) + (define-key map "\C-m" 'bubbles-plop) + (define-key map "u" 'bubbles-undo) + (define-key map "p" 'previous-line) + (define-key map "n" 'next-line) + (define-key map "f" 'forward-char) + (define-key map "b" 'backward-char) + ;; bind menu to mouse + (define-key map [down-mouse-3] bubbles-menu) + ;; Put menu in menu-bar + (define-key map [menu-bar Bubbles] (cons "Bubbles" bubbles-menu)) + map) + "Mode map for bubbles.") (defun bubbles-mode () "Major mode for playing bubbles. @@ -916,7 +928,10 @@ static char * dot3d_xpm[] = { (setq major-mode 'bubbles-mode) (setq mode-name "Bubbles") (setq buffer-read-only t) - (buffer-enable-undo) + (buffer-disable-undo) + (setq buffer-undo-list t) + (force-mode-line-update) + (redisplay) (add-hook 'post-command-hook 'bubbles--mark-neighbourhood t t) (run-hooks 'bubbles-mode-hook)) @@ -1014,7 +1029,10 @@ Set `bubbles--col-offset' and `bubbles--row-offset'." (bubbles-mode) (bubbles--reset-score) (bubbles--update-faces-or-images) - (bubbles--goto 0 0)) + (bubbles--goto 0 0) + (setq buffer-undo-list t) + (force-mode-line-update) + (redisplay)) (defun bubbles--initialize-faces () "Prepare faces for playing `bubbles'." @@ -1196,7 +1214,6 @@ Use optional parameter POS instead of point if given." (when (and bubbles--playing (> bubbles--neighbourhood-score 0)) (setq bubbles--save-data (list bubbles--score (buffer-string))) - (setq buffer-undo-list '(apply bubbles-undo . nil)) (let ((inhibit-read-only t)) ;; blank out current neighbourhood (let ((row (bubbles--row (point))) @@ -1245,7 +1262,8 @@ Use optional parameter POS instead of point if given." (dotimes (j (bubbles--grid-width)) (bubbles--goto i j) (while (get-text-property (point) 'removed) - (setq shifted (or (bubbles--shift 'right i j) shifted)))))) + (setq shifted (or (bubbles--shift 'right i j) + shifted)))))) (bubbles--update-faces-or-images) (sleep-for 0.5)) (t ;; default shift-mode @@ -1259,7 +1277,8 @@ Use optional parameter POS instead of point if given." (dotimes (k shifted-cols) (let ((i (- (bubbles--grid-height) 2))) (while (>= i 0) - (setq shifted (or (bubbles--shift 'right i j) shifted)) + (setq shifted (or (bubbles--shift 'right i j) + shifted)) (setq i (1- i)))))))))) (when shifted ;;(sleep-for 0.5) @@ -1267,7 +1286,11 @@ Use optional parameter POS instead of point if given." (sit-for 0))) (put-text-property (point-min) (point-max) 'removed nil) (unless (bubbles--neighbourhood-available) - (bubbles--game-over))))) + (bubbles--game-over))) + ;; undo + (setq buffer-undo-list '((apply bubbles-undo . nil))) + (force-mode-line-update) + (redisplay))) (defun bubbles-undo () "Undo last move." @@ -1279,7 +1302,10 @@ Use optional parameter POS instead of point if given." (insert (cadr bubbles--save-data)) (bubbles--update-faces-or-images) (setq bubbles--score (car bubbles--save-data)) - (goto-char pos)))) + (goto-char pos)) + (setq buffer-undo-list t) + (force-mode-line-update) + (redisplay))) (defun bubbles--shift (from row col) "Move bubbles FROM one side to position ROW COL. @@ -1323,7 +1349,7 @@ Return t if new char is non-empty." (setq bubbles--empty-image (create-image (replace-regexp-in-string "^\"\\(.*\\)\t.*c .*\",$" - "\"\\1\tc #FFFFFF\"," template) + "\"\\1\tc None\"," template) 'xpm t ;;:mask 'heuristic :margin '(2 . 1))) @@ -1408,7 +1434,7 @@ Return t if new char is non-empty." (dotimes (i (bubbles--grid-height)) (dotimes (j (bubbles--grid-width)) (forward-char 1) - (let ((index (get-text-property (point) 'index))) + (let ((index (or (get-text-property (point) 'index) -1))) (let ((img bubbles--empty-image)) (if (>= index 0) (setq img (nth index bubbles--images))) diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index b041bbd2522..b5dde4323d0 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -326,8 +326,8 @@ static unsigned char gamegrid_bits[] = { (setq point-size (/ (* (float default-font-height) max-height) 10) pixel-size (floor (* resy (/ point-size 72.27))) point-size (* (/ pixel-size resy) 72.27)) - (set-face-attribute gamegrid-face nil - :height (floor (* point-size 10)))))))) + (face-spec-set gamegrid-face + `((t :height ,(floor (* point-size 10)))))))))) (defun gamegrid-initialize-display () (setq gamegrid-display-mode (gamegrid-display-type)) diff --git a/lisp/play/solitaire.el b/lisp/play/solitaire.el index b027db88ad6..e5dde1fe79c 100644 --- a/lisp/play/solitaire.el +++ b/lisp/play/solitaire.el @@ -400,7 +400,7 @@ which a stone will be taken away) and target." (<= (current-column) solitaire-end-x) (>= (solitaire-current-line) solitaire-start-y) (<= (solitaire-current-line) solitaire-end-y) - (mapcar + (mapc (lambda (movesymbol) (if (listp (solitaire-possible-move movesymbol)) (setq count (1+ count)))) @@ -446,13 +446,13 @@ Seen in info on text lines." ;; right S-left (solitaire-auto-eval nil)) (solitaire-center-point) - (mapcar (lambda (op) - (if (memq op '(S-left S-right S-up S-down)) - (sit-for 0.2)) - (execute-kbd-macro (vector op)) - (if (memq op '(S-left S-right S-up S-down)) - (sit-for 0.4))) - allmoves)) + (mapc (lambda (op) + (if (memq op '(S-left S-right S-up S-down)) + (sit-for 0.2)) + (execute-kbd-macro (vector op)) + (if (memq op '(S-left S-right S-up S-down)) + (sit-for 0.4))) + allmoves)) (solitaire-do-check)) (provide 'solitaire) diff --git a/lisp/play/zone.el b/lisp/play/zone.el index f1bbfb19938..896c1d4ac0a 100644 --- a/lisp/play/zone.el +++ b/lisp/play/zone.el @@ -86,30 +86,10 @@ If nil, don't interrupt for about 1^26 seconds.") ,@body)) (defmacro zone-hiding-modeline (&rest body) - `(let (bg mode-line-fg mode-line-bg mode-line-box) - (unwind-protect - (progn - (when (and (= 0 (get 'zone 'modeline-hidden-level)) - (display-color-p)) - (setq bg (face-background 'default) - mode-line-box (face-attribute 'mode-line :box) - mode-line-fg (face-attribute 'mode-line :foreground) - mode-line-bg (face-attribute 'mode-line :background)) - (set-face-attribute 'mode-line nil - :foreground bg - :background bg - :box nil)) - (put 'zone 'modeline-hidden-level - (1+ (get 'zone 'modeline-hidden-level))) - ,@body) - (put 'zone 'modeline-hidden-level - (1- (get 'zone 'modeline-hidden-level))) - (when (and (> 1 (get 'zone 'modeline-hidden-level)) - mode-line-fg) - (set-face-attribute 'mode-line nil - :foreground mode-line-fg - :background mode-line-bg - :box mode-line-box))))) + ;; This formerly worked by temporarily altering face `mode-line', + ;; which did not even work right, it seems. + `(let (mode-line-format) + ,@body)) (defun zone-call (program &optional timeout) "Call PROGRAM in a zoned way. @@ -158,6 +138,7 @@ If the element is a function or a list of a function and a number, (sit-for 0 500) (let ((pgm (elt zone-programs (random (length zone-programs)))) (ct (and f (frame-parameter f 'cursor-type))) + (show-trailing-whitespace nil) (restore (list '(kill-buffer outbuf)))) (when ct (modify-frame-parameters f '((cursor-type . (bar . 0)))) @@ -399,20 +380,20 @@ If the element is a function or a list of a function and a number, (let* ((specs (apply 'vector (let (res) - (mapcar (lambda (ent) - (let* ((beg (car ent)) - (end (cdr ent)) - (amt (if random-style - (funcall random-style) - (- (random 7) 3)))) - (when (< (- end (abs amt)) beg) - (setq amt (random (- end beg)))) - (unless (= 0 amt) - (setq res - (cons - (vector amt beg (- end (abs amt))) - res))))) - (zone-line-specs)) + (mapc (lambda (ent) + (let* ((beg (car ent)) + (end (cdr ent)) + (amt (if random-style + (funcall random-style) + (- (random 7) 3)))) + (when (< (- end (abs amt)) beg) + (setq amt (random (- end beg)))) + (unless (= 0 amt) + (setq res + (cons + (vector amt beg (- end (abs amt))) + res))))) + (zone-line-specs)) res))) (n (length specs)) amt aamt cut paste txt i ent) @@ -704,6 +685,7 @@ If nil, `zone-pgm-random-life' chooses a value from 0-3 (inclusive).") (life (or zone-pgm-random-life-wait (random 4))) (kill-buffer nil)))) + (random t) ;;;;;;;;;;;;;;; diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el index 478a07bc3b6..07d38dbdaa2 100644 --- a/lisp/progmodes/ada-mode.el +++ b/lisp/progmodes/ada-mode.el @@ -1145,7 +1145,7 @@ If you use ada-xref.el: (interactive) (kill-all-local-variables) - + (set-syntax-table ada-mode-syntax-table) (set (make-local-variable 'require-final-newline) mode-require-final-newline) @@ -1423,12 +1423,12 @@ If you use ada-xref.el: Casing exception lists are `ada-case-exception' and `ada-case-exception-substring'." (find-file (expand-file-name file-name)) (erase-buffer) - (mapcar (lambda (x) (insert (car x) "\n")) - (sort (copy-sequence ada-case-exception) - (lambda(a b) (string< (car a) (car b))))) - (mapcar (lambda (x) (insert "*" (car x) "\n")) - (sort (copy-sequence ada-case-exception-substring) - (lambda(a b) (string< (car a) (car b))))) + (mapc (lambda (x) (insert (car x) "\n")) + (sort (copy-sequence ada-case-exception) + (lambda(a b) (string< (car a) (car b))))) + (mapc (lambda (x) (insert "*" (car x) "\n")) + (sort (copy-sequence ada-case-exception-substring) + (lambda(a b) (string< (car a) (car b))))) (save-buffer) (kill-buffer nil) ) @@ -4583,7 +4583,7 @@ Moves to 'begin' if in a declarative part." ;; The following keys are bound to functions defined in ada-xref.el or ;; ada-prj,el., However, RMS rightly thinks that the code should be shared, ;; and activated only if the right compiler is used - + (define-key ada-mode-map (if (featurep 'xemacs) '(shift button3) [S-mouse-3]) 'ada-point-and-xref) (define-key ada-mode-map [(control tab)] 'ada-complete-identifier) diff --git a/lisp/progmodes/ada-prj.el b/lisp/progmodes/ada-prj.el index 7cff0158f8a..b3f059b2b34 100644 --- a/lisp/progmodes/ada-prj.el +++ b/lisp/progmodes/ada-prj.el @@ -254,8 +254,8 @@ The current buffer must be the project editing buffer." (progn (setq widget-field-new nil widget-field-list nil) - (mapcar (lambda (x) (delete-overlay x)) (car (overlay-lists))) - (mapcar (lambda (x) (delete-overlay x)) (cdr (overlay-lists))))) + (mapc (lambda (x) (delete-overlay x)) (car (overlay-lists))) + (mapc (lambda (x) (delete-overlay x)) (cdr (overlay-lists))))) ;; Display the tabs diff --git a/lisp/progmodes/autoconf.el b/lisp/progmodes/autoconf.el index e01579917f6..d47a1c4d2cc 100644 --- a/lisp/progmodes/autoconf.el +++ b/lisp/progmodes/autoconf.el @@ -49,7 +49,7 @@ '(("\\<dnl\\>" 0 '(11)))) (defconst autoconf-definition-regexp - "AC_\\(SUBST\\|DEFINE\\(_UNQUOTED\\)?\\)(\\(\\sw+\\)") + "AC_\\(SUBST\\|DEFINE\\(_UNQUOTED\\)?\\)(\\[*\\(\\sw+\\)\\]*") (defvar autoconf-font-lock-keywords `(("\\_<A[CHMS]_\\sw+" . font-lock-keyword-face) diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 48fa7d99f5a..860893bcfa6 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -3074,7 +3074,8 @@ non-nil." indent the current line syntactically." ;; Emacs has a variable called mark-active, XEmacs uses region-active-p (interactive) - (if (c-region-is-active-p) + (if (and transient-mark-mode mark-active + (not (eq (region-beginning) (region-end)))) (c-indent-region (region-beginning) (region-end)) (c-indent-line))) diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index d0ff9c523ad..a4dfe41ca78 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -1970,6 +1970,7 @@ identifiers that follows the type in a normal declaration." "Statement keywords followed directly by a substatement." t '("do" "else") c++ '("do" "else" "try") + objc '("do" "else" "@finally" "@try") java '("do" "else" "finally" "try") idl nil) @@ -1983,6 +1984,7 @@ identifiers that follows the type in a normal declaration." "Statement keywords followed by a paren sexp and then by a substatement." t '("for" "if" "switch" "while") c++ '("for" "if" "switch" "while" "catch") + objc '("for" "if" "switch" "while" "@catch" "@synchronized") java '("for" "if" "switch" "while" "catch" "synchronized") idl nil pike '("for" "if" "switch" "while" "foreach") @@ -2014,6 +2016,7 @@ identifiers that follows the type in a normal declaration." (c-lang-defconst c-simple-stmt-kwds "Statement keywords followed by an expression or nothing." t '("break" "continue" "goto" "return") + objc '("break" "continue" "goto" "return" "@throw") ;; Note: `goto' is not valid in Java, but the keyword is still reserved. java '("break" "continue" "goto" "return" "throw") idl nil diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 8669a41c2f0..f234404e81d 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -269,7 +269,9 @@ control). See \"cc-mode.el\" for more info." 'c-indent-new-comment-line c-mode-base-map global-map) (substitute-key-definition 'indent-for-tab-command - 'c-indent-command + ;; XXX Is this the right thing to do + ;; here? + 'c-indent-line-or-region c-mode-base-map global-map) (when (fboundp 'comment-indent-new-line) ;; indent-new-comment-line has changed name to diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 9b83cfc9f3d..9ed7ba09de9 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -240,7 +240,7 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) \\([0-9]+\\)\\(?:\\([.:]\\)\\([0-9]+\\)\\)?\ \\(?:-\\([0-9]+\\)?\\(?:\\3\\([0-9]+\\)\\)?\\)?:\ \\(?: *\\(\\(?:Future\\|Runtime\\)?[Ww]arning\\|W:\\)\\|\ - *\\([Ii]nfo\\(?:\\>\\|rmationa?l?\\)\\|I:\\|instantiated from\\)\\|\ + *\\([Ii]nfo\\(?:\\>\\|rmationa?l?\\)\\|I:\\|instantiated from\\|[Nn]ote\\)\\|\ \[0-9]?\\(?:[^0-9\n]\\|$\\)\\|[0-9][0-9][0-9]\\)" 1 (2 . 5) (4 . 6) (7 . 8)) @@ -1932,8 +1932,7 @@ FILE should be (FILENAME) or (RELATIVE-FILENAME . DIRNAME). In the former case, FILENAME may be relative or absolute. The file-structure looks like this: - (list (list FILENAME [DIR-FROM-PREV-MSG]) FMT LINE-STRUCT...) -" + (list (list FILENAME [DIR-FROM-PREV-MSG]) FMT LINE-STRUCT...)" (or (gethash file compilation-locs) ;; File was not previously encountered, at least not in the form passed. ;; Let's normalize it and look again. @@ -1977,9 +1976,7 @@ The file-structure looks like this: ;; directories have the same name: ;; http://lists.gnu.org/archive/html/emacs-devel/2007-08/msg00463.html (or (gethash (cons filename spec-directory) compilation-locs) - ;; TODO should this, without spec-directory, be - ;; done at all? - (puthash (list filename) + (puthash (cons filename spec-directory) (list (list filename spec-directory) fmt) compilation-locs)) compilation-locs)))) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index cdfb8870138..4de1a845ab4 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -2635,7 +2635,8 @@ Return the amount the indentation changed by." (t (skip-chars-forward " \t") (if (listp indent) (setq indent (car indent))) - (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") + (cond ((and (looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") + (not (looking-at "[smy]:\\|tr:"))) (and (> indent 0) (setq indent (max cperl-min-label-indent (+ indent cperl-label-offset))))) @@ -2810,9 +2811,9 @@ Will not look before LIM." (vector 'indentable 'first-line p)))) ((get-text-property char-after-pos 'REx-part2) (vector 'REx-part2 (point))) - ((nth 3 state) - [comment]) ((nth 4 state) + [comment]) + ((nth 3 state) [string]) ;; XXXX Do we need to special-case this? ((null containing-sexp) @@ -2918,7 +2919,9 @@ Will not look before LIM." (let ((colon-line-end 0)) (while (progn (skip-chars-forward " \t\n") - (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]")) + ;; s: foo : bar :x is NOT label + (and (looking-at "#\\|\\([a-zA-Z0-9_$]+\\):[^:]\\|=[a-zA-Z]") + (not (looking-at "[sym]:\\|tr:")))) ;; Skip over comments and labels following openbrace. (cond ((= (following-char) ?\#) (forward-line 1)) @@ -2989,8 +2992,7 @@ Will not look before LIM." (vector 'code-start-in-block containing-sexp char-after (and delim (not is-block)) ; is a HASH old-indent ; brace first thing on a line - nil (point) ; nothing interesting before - )))))))))))))) + nil (point))))))))))))))) ; nothing interesting before (defvar cperl-indent-rules-alist '((pod nil) ; via `syntax-type' property @@ -3004,9 +3006,7 @@ Will not look before LIM." "Alist of indentation rules for CPerl mode. The values mean: nil: do not indent; - number: add this amount of indentation. - -Not finished.") + number: add this amount of indentation.") (defun cperl-calculate-indent (&optional parse-data) ; was parse-start "Return appropriate indentation for current line as Perl code. @@ -3131,8 +3131,8 @@ and closing parentheses and brackets." ;; ((eq 'have-prev-sibling (elt i 0)) ;; [have-prev-sibling sibling-beg colon-line-end block-start] - (goto-char (elt i 1)) - (if (> (elt i 2) (point)) ; colon-line-end; After-label, same line + (goto-char (elt i 1)) ; sibling-beg + (if (> (elt i 2) (point)) ; colon-line-end; have label before point (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) @@ -3184,170 +3184,6 @@ and closing parentheses and brackets." (t (error "Got strange value of indent: %s" i)))))) -(defvar cperl-indent-alist - '((string nil) - (comment nil) - (toplevel 0) - (toplevel-after-parenth 2) - (toplevel-continued 2) - (expression 1)) - "Alist of indentation rules for CPerl mode. -The values mean: - nil: do not indent; - number: add this amount of indentation. - -Not finished, not used.") - -(defun cperl-where-am-i (&optional parse-start start-state) - ;; Unfinished - "Return a list of lists ((TYPE POS)...) of good points before the point. -POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'. - -Not finished, not used." - (save-excursion - (let* ((start-point (point)) unused - (s-s (cperl-get-state)) - (start (nth 0 s-s)) - (state (nth 1 s-s)) - (prestart (nth 3 s-s)) - (containing-sexp (car (cdr state))) - (case-fold-search nil) - (res (list (list 'parse-start start) (list 'parse-prestart prestart)))) - (cond ((nth 3 state) ; In string - (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string - ((nth 4 state) ; In comment - (setq res (cons '(comment) res))) - ((null containing-sexp) - ;; Line is at top level. - ;; Indent like the previous top level line - ;; unless that ends in a closeparen without semicolon, - ;; in which case this line is the first argument decl. - (cperl-backward-to-noncomment (or parse-start (point-min))) - ;;(skip-chars-backward " \t\f\n") - (cond - ((or (bobp) - (memq (preceding-char) (append ";}" nil))) - (setq res (cons (list 'toplevel start) res))) - ((eq (preceding-char) ?\) ) - (setq res (cons (list 'toplevel-after-parenth start) res))) - (t - (setq res (cons (list 'toplevel-continued start) res))))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - ;; skip blanks if we do not close the expression. - (setq res (cons (list 'expression-blanks - (progn - (goto-char (1+ containing-sexp)) - (or (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (point))) - (cons (list 'expression containing-sexp) res)))) - ((progn - ;; Containing-expr starts with \{. Check whether it is a hash. - (goto-char containing-sexp) - (not (cperl-block-p))) - (setq res (cons (list 'expression-blanks - (progn - (goto-char (1+ containing-sexp)) - (or (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (point))) - (cons (list 'expression containing-sexp) res)))) - (t - ;; Statement level. - (setq res (cons (list 'in-block containing-sexp) res)) - ;; Is it a continuation or a new statement? - ;; Find previous non-comment character. - (cperl-backward-to-noncomment containing-sexp) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - ;; Back up comma-delimited lines too ????? - (while (or (eq (preceding-char) ?\,) - (save-excursion (cperl-after-label))) - (if (eq (preceding-char) ?\,) - ;; Will go to beginning of line, essentially - ;; Will ignore embedded sexpr XXXX. - (cperl-backward-to-start-of-continued-exp containing-sexp)) - (beginning-of-line) - (cperl-backward-to-noncomment containing-sexp)) - ;; Now we get the answer. - (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, - ;; This line is continuation of preceding line's statement. - (list (list 'statement-continued containing-sexp)) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like - ;; it. If the first statement begins with label, do - ;; not believe when the indentation of the label is too - ;; small. - (save-excursion - (forward-char 1) - (let ((colon-line-end 0)) - (while (progn (skip-chars-forward " \t\n" start-point) - (and (< (point) start-point) - (looking-at - "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))) - ;; Skip over comments and labels following openbrace. - (cond ((= (following-char) ?\#) - ;;(forward-line 1) - (end-of-line)) - ;; label: - (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) - (search-forward ":")))) - ;; Now at the point, after label, or at start - ;; of first statement in the block. - (and (< (point) start-point) - (if (> colon-line-end (point)) - ;; Before statement after label - (if (> (current-indentation) - cperl-min-label-indent) - (list (list 'label-in-block (point))) - ;; Do not believe: `max' is involved - (list - (list 'label-in-block-min-indent (point)))) - ;; Before statement - (list 'statement-in-block (point)))))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open brace in column zero, don't let statement - ;; start there too. If cperl-indent-level is zero, - ;; use cperl-brace-offset + cperl-continued-statement-offset instead. - ;; For open-braces not the first thing in a line, - ;; add in cperl-brace-imaginary-offset. - - ;; If first thing on a line: ????? - (setq unused ; This is not finished... - (+ (if (and (bolp) (zerop cperl-indent-level)) - (+ cperl-brace-offset cperl-continued-statement-offset) - cperl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the cperl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 cperl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - ;; If line starts with label, calculate label indentation - (if (save-excursion - (beginning-of-line) - (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) - (if (> (current-indentation) cperl-min-label-indent) - (- (current-indentation) cperl-label-offset) - (cperl-calculate-indent)) - (current-indentation))))))))) - res))) - (defun cperl-calculate-indent-within-comment () "Return the indentation amount for line, assuming that the current line is to be regarded as part of a block comment." @@ -3742,12 +3578,10 @@ Should be called with the point before leading colon of an attribute." (set-syntax-table reset-st)))) (defsubst cperl-look-at-leading-count (is-x-REx e) - (if (and (> (point) e) - ;; return nil on failure, no moving - (re-search-forward (concat "\\=" - (if is-x-REx "[ \t\n]*" "") - "[{?+*]") - (1- e) t)) + (if (and + (< (point) e) + (re-search-forward (concat "\\=" (if is-x-REx "[ \t\n]*" "") "[{?+*]") + (1- e) t)) ; return nil on failure, no moving (if (eq ?\{ (preceding-char)) nil (cperl-postpone-fontification (1- (point)) (point) @@ -4791,8 +4625,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (and is-REx is-x-REx) (put-text-property (1+ b) (1- e) 'syntax-subtype 'x-REx))) - (if i2 - (progn + (if (and i2 e1 b1 (> e1 b1)) + (progn ; No errors finding the second part... (cperl-postpone-fontification (1- e1) e1 'face my-cperl-delimiters-face) (if (and (not (eobp)) @@ -4891,14 +4725,16 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (beginning-of-line) (if (memq (setq pr (get-text-property (point) 'syntax-type)) '(pod here-doc here-doc-delim)) - (cperl-unwind-to-safe nil) - (or (and (looking-at "^[ \t]*\\(#\\|$\\)") - (not (memq pr '(string prestring)))) - (progn (cperl-to-comment-or-eol) (bolp)) - (progn - (skip-chars-backward " \t") - (if (< p (point)) (goto-char p)) - (setq stop t))))))) + (progn + (cperl-unwind-to-safe nil) + (setq pr (get-text-property (point) 'syntax-type)))) + (or (and (looking-at "^[ \t]*\\(#\\|$\\)") + (not (memq pr '(string prestring)))) + (progn (cperl-to-comment-or-eol) (bolp)) + (progn + (skip-chars-backward " \t") + (if (< p (point)) (goto-char p)) + (setq stop t)))))) ;; Used only in `cperl-calculate-indent'... (defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! @@ -5723,10 +5559,11 @@ indentation and initial hashes. Behaves usually outside of comment." (defun cperl-windowed-init () "Initialization under windowed version." (cond ((featurep 'ps-print) - (unless cperl-faces-init - (if (boundp 'font-lock-multiline) - (setq cperl-font-lock-multiline t)) - (cperl-init-faces))) + (or cperl-faces-init + (progn + (and (boundp 'font-lock-multiline) + (setq cperl-font-lock-multiline t)) + (cperl-init-faces)))) ((not cperl-faces-init) (add-hook 'font-lock-mode-hook (function @@ -9041,7 +8878,7 @@ do extra unwind via `cperl-unwind-to-safe'." (cperl-fontify-syntaxically to))))) (defvar cperl-version - (let ((v "Revision: 5.22")) + (let ((v "Revision: 5.23")) (string-match ":\\s *\\([0-9.]+\\)" v) (substring v (match-beginning 1) (match-end 1))) "Version of IZ-supported CPerl package this file is based on.") diff --git a/lisp/progmodes/delphi.el b/lisp/progmodes/delphi.el index 99f03f8a545..6cbef6f426d 100644 --- a/lisp/progmodes/delphi.el +++ b/lisp/progmodes/delphi.el @@ -1677,21 +1677,21 @@ before the indent, the point is moved to the indent." (unit-file (downcase unit))) (catch 'done ;; Search for the file. - (mapcar #'(lambda (file) - (let ((path (concat dir "/" file))) - (if (and (string= unit-file (downcase file)) - (delphi-is-file path)) - (throw 'done path)))) - files) + (mapc #'(lambda (file) + (let ((path (concat dir "/" file))) + (if (and (string= unit-file (downcase file)) + (delphi-is-file path)) + (throw 'done path)))) + files) ;; Not found. Search subdirectories. (when recurse - (mapcar #'(lambda (subdir) - (unless (member subdir '("." "..")) - (let ((path (delphi-search-directory - unit (concat dir "/" subdir) recurse))) - (if path (throw 'done path))))) - files)) + (mapc #'(lambda (subdir) + (unless (member subdir '("." "..")) + (let ((path (delphi-search-directory + unit (concat dir "/" subdir) recurse))) + (if path (throw 'done path))))) + files)) ;; Not found. nil)))) @@ -1721,7 +1721,7 @@ before the indent, the point is moved to the indent." ((stringp delphi-search-path) (delphi-find-unit-in-directory unit delphi-search-path)) - ((mapcar + ((mapc #'(lambda (dir) (let ((file (delphi-find-unit-in-directory unit dir))) (if file (throw 'done file)))) @@ -1888,39 +1888,39 @@ comment block. If not in a // comment, just does a normal newline." (defvar delphi-debug-mode-map (let ((kmap (make-sparse-keymap))) - (mapcar #'(lambda (binding) (define-key kmap (car binding) (cadr binding))) - '(("n" delphi-debug-goto-next-token) - ("p" delphi-debug-goto-previous-token) - ("t" delphi-debug-show-current-token) - ("T" delphi-debug-tokenize-buffer) - ("W" delphi-debug-tokenize-window) - ("g" delphi-debug-goto-point) - ("s" delphi-debug-show-current-string) - ("a" delphi-debug-parse-buffer) - ("w" delphi-debug-parse-window) - ("f" delphi-debug-fontify-window) - ("F" delphi-debug-fontify-buffer) - ("r" delphi-debug-parse-region) - ("c" delphi-debug-unparse-buffer) - ("x" delphi-debug-show-is-stable) - )) + (mapc #'(lambda (binding) (define-key kmap (car binding) (cadr binding))) + '(("n" delphi-debug-goto-next-token) + ("p" delphi-debug-goto-previous-token) + ("t" delphi-debug-show-current-token) + ("T" delphi-debug-tokenize-buffer) + ("W" delphi-debug-tokenize-window) + ("g" delphi-debug-goto-point) + ("s" delphi-debug-show-current-string) + ("a" delphi-debug-parse-buffer) + ("w" delphi-debug-parse-window) + ("f" delphi-debug-fontify-window) + ("F" delphi-debug-fontify-buffer) + ("r" delphi-debug-parse-region) + ("c" delphi-debug-unparse-buffer) + ("x" delphi-debug-show-is-stable) + )) kmap) "Keystrokes for delphi-mode debug commands.") (defvar delphi-mode-map (let ((kmap (make-sparse-keymap))) - (mapcar #'(lambda (binding) (define-key kmap (car binding) (cadr binding))) - (list '("\r" delphi-newline) - '("\t" delphi-tab) - '("\177" backward-delete-char-untabify) -;; '("\C-cd" delphi-find-current-def) -;; '("\C-cx" delphi-find-current-xdef) -;; '("\C-cb" delphi-find-current-body) - '("\C-cu" delphi-find-unit) - '("\M-q" delphi-fill-comment) - '("\M-j" delphi-new-comment-line) - ;; Debug bindings: - (list "\C-c\C-d" delphi-debug-mode-map))) + (mapc #'(lambda (binding) (define-key kmap (car binding) (cadr binding))) + (list '("\r" delphi-newline) + '("\t" delphi-tab) + '("\177" backward-delete-char-untabify) +;; '("\C-cd" delphi-find-current-def) +;; '("\C-cx" delphi-find-current-xdef) +;; '("\C-cb" delphi-find-current-body) + '("\C-cu" delphi-find-unit) + '("\M-q" delphi-fill-comment) + '("\M-j" delphi-new-comment-line) + ;; Debug bindings: + (list "\C-c\C-d" delphi-debug-mode-map))) kmap) "Keymap used in Delphi mode.") @@ -1981,17 +1981,17 @@ no args, if that value is non-nil." (set-syntax-table delphi-mode-syntax-table) ;; Buffer locals: - (mapcar #'(lambda (var) - (let ((var-symb (car var)) - (var-val (cadr var))) - (make-local-variable var-symb) - (set var-symb var-val))) - (list '(indent-line-function delphi-indent-line) - '(comment-indent-function delphi-indent-line) - '(case-fold-search t) - '(delphi-progress-last-reported-point nil) - '(delphi-ignore-changes nil) - (list 'font-lock-defaults delphi-font-lock-defaults))) + (mapc #'(lambda (var) + (let ((var-symb (car var)) + (var-val (cadr var))) + (make-local-variable var-symb) + (set var-symb var-val))) + (list '(indent-line-function delphi-indent-line) + '(comment-indent-function delphi-indent-line) + '(case-fold-search t) + '(delphi-progress-last-reported-point nil) + '(delphi-ignore-changes nil) + (list 'font-lock-defaults delphi-font-lock-defaults))) ;; We need to keep track of changes to the buffer to determine if we need ;; to retokenize changed text. diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index 58a25ab5b88..9264bb42ba2 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -1148,15 +1148,15 @@ Tree mode key bindings: (erase-buffer) (message nil)) - (mapcar 'make-local-variable - '(ebrowse--tags-file-name - ebrowse--indentation - ebrowse--tree - ebrowse--header - ebrowse--show-file-names-flag - ebrowse--frozen-flag - ebrowse--tree-obarray - revert-buffer-function)) + (mapc 'make-local-variable + '(ebrowse--tags-file-name + ebrowse--indentation + ebrowse--tree + ebrowse--header + ebrowse--show-file-names-flag + ebrowse--frozen-flag + ebrowse--tree-obarray + revert-buffer-function)) (setf ebrowse--show-file-names-flag nil ebrowse--tree-obarray (make-vector 127 0) @@ -1638,10 +1638,10 @@ and possibly kill the viewed buffer." (setq original-frame-configuration ebrowse--frame-configuration exit-action ebrowse--view-exit-action)) ;; Delete the frame in which we viewed. - (mapcar 'delete-frame - (loop for frame in (frame-list) - when (not (assq frame original-frame-configuration)) - collect frame)) + (mapc 'delete-frame + (loop for frame in (frame-list) + when (not (assq frame original-frame-configuration)) + collect frame)) (when exit-action (funcall exit-action buffer)))) @@ -2004,7 +2004,7 @@ COLLAPSE non-nil means collapse the branch." (fillarray (car (cdr map)) 'ebrowse-electric-list-undefined) (fillarray (car (cdr submap)) 'ebrowse-electric-list-undefined) (define-key map "\e" submap) - (define-key map "\C-z" 'suspend-emacs) + (define-key map "\C-z" 'suspend-frame) (define-key map "\C-h" 'Helper-help) (define-key map "?" 'Helper-describe-bindings) (define-key map "\C-c" nil) @@ -2256,28 +2256,28 @@ See 'Electric-command-loop' for a description of STATE and CONDITION." (kill-all-local-variables) (use-local-map ebrowse-member-mode-map) (setq major-mode 'ebrowse-member-mode) - (mapcar 'make-local-variable - '(ebrowse--decl-column ;display column - ebrowse--n-columns ;number of short columns - ebrowse--column-width ;width of columns above - ebrowse--show-inherited-flag ;include inherited members? - ebrowse--filters ;public, protected, private - ebrowse--accessor ;vars, functions, friends - ebrowse--displayed-class ;class displayed - ebrowse--long-display-flag ;display with regexps? - ebrowse--source-regexp-flag ;show source regexp? - ebrowse--attributes-flag ;show `virtual' and `inline' - ebrowse--member-list ;list of members displayed - ebrowse--tree ;the class tree - ebrowse--member-mode-strings ;part of mode line - ebrowse--tags-file-name ; - ebrowse--header - ebrowse--tree-obarray - ebrowse--virtual-display-flag - ebrowse--inline-display-flag - ebrowse--const-display-flag - ebrowse--pure-display-flag - ebrowse--frozen-flag)) ;buffer not automagically reused + (mapc 'make-local-variable + '(ebrowse--decl-column ;display column + ebrowse--n-columns ;number of short columns + ebrowse--column-width ;width of columns above + ebrowse--show-inherited-flag ;include inherited members? + ebrowse--filters ;public, protected, private + ebrowse--accessor ;vars, functions, friends + ebrowse--displayed-class ;class displayed + ebrowse--long-display-flag ;display with regexps? + ebrowse--source-regexp-flag ;show source regexp? + ebrowse--attributes-flag ;show `virtual' and `inline' + ebrowse--member-list ;list of members displayed + ebrowse--tree ;the class tree + ebrowse--member-mode-strings ;part of mode line + ebrowse--tags-file-name ; + ebrowse--header + ebrowse--tree-obarray + ebrowse--virtual-display-flag + ebrowse--inline-display-flag + ebrowse--const-display-flag + ebrowse--pure-display-flag + ebrowse--frozen-flag)) ;buffer not automagically reused (setq mode-name "Ebrowse-Members" mode-line-buffer-identification (propertized-buffer-identification "C++ Members") @@ -3964,7 +3964,7 @@ Prefix arg ARG says how much." (fillarray (car (cdr map)) 'ebrowse-electric-position-undefined) (fillarray (car (cdr submap)) 'ebrowse-electric-position-undefined) (define-key map "\e" submap) - (define-key map "\C-z" 'suspend-emacs) + (define-key map "\C-z" 'suspend-frame) (define-key map "\C-h" 'Helper-help) (define-key map "?" 'Helper-describe-bindings) (define-key map "\C-c" nil) @@ -4148,7 +4148,7 @@ Otherwise, FILE-NAME specifies the file to save the tree in." (erase-buffer) (setf (ebrowse-hs-member-table header) nil) (insert (prin1-to-string header) " ") - (mapcar 'ebrowse-save-class tree) + (mapc 'ebrowse-save-class tree) (write-file file-name) (message "Tree written to file `%s'" file-name)) (kill-buffer temp-buffer) @@ -4163,7 +4163,7 @@ Otherwise, FILE-NAME specifies the file to save the tree in." (insert "[ebrowse-ts ") (prin1 (ebrowse-ts-class class)) ;class name (insert "(") ;list of subclasses - (mapcar 'ebrowse-save-class (ebrowse-ts-subclasses class)) + (mapc 'ebrowse-save-class (ebrowse-ts-subclasses class)) (insert ")") (dolist (func ebrowse-member-list-accessors) (prin1 (funcall func class)) diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el index 6c704916c65..c7042fb1f67 100644 --- a/lisp/progmodes/f90.el +++ b/lisp/progmodes/f90.el @@ -682,7 +682,7 @@ Used in the F90 entry in `hs-special-modes-alist'.") (let (abbrevs-changed) ;; Use the 6th arg (SYSTEM-FLAG) of define-abbrev if possible. ;; A little baroque to quieten the byte-compiler. - (mapcar + (mapc (function (lambda (element) (condition-case nil (apply 'define-abbrev f90-mode-abbrev-table diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index bcb571f8c87..016e484a6c5 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -56,7 +56,6 @@ ;; silence compiler (defvar dabbrev-case-fold-search) -(defvar font-lock-syntactic-keywords) (defvar gud-find-expr-function) (defvar imenu-case-fold-search) (defvar imenu-syntax-alist) @@ -151,7 +150,7 @@ You might want to change this to \"*\", for instance." ;; filling and doesn't seem to be necessary. (defcustom fortran-comment-line-start-skip "^[CcDd*!]\\(\\([^ \t\n]\\)\\2+\\)?[ \t]*" - "*Regexp to match the start of a full-line comment." + "Regexp to match the start of a full-line comment." :version "21.1" :type 'regexp :group 'fortran-comment) @@ -650,7 +649,7 @@ Used in the Fortran entry in `hs-special-modes-alist'.") (let (abbrevs-changed) ;; Use the 6th arg (SYSTEM-FLAG) of define-abbrev if possible. ;; Only use `apply' to quieten the byte-compiler. - (mapcar + (mapc (function (lambda (element) (condition-case nil (apply 'define-abbrev fortran-mode-abbrev-table @@ -827,9 +826,9 @@ with no args, if that value is non-nil." fortran-font-lock-keywords-3 fortran-font-lock-keywords-4) nil t ((?/ . "$/") ("_$" . "w")) - fortran-beginning-of-subprogram)) - (set (make-local-variable 'font-lock-syntactic-keywords) - (fortran-font-lock-syntactic-keywords)) + fortran-beginning-of-subprogram + (font-lock-syntactic-keywords + . (fortran-font-lock-syntactic-keywords)))) (set (make-local-variable 'imenu-case-fold-search) t) (set (make-local-variable 'imenu-generic-expression) fortran-imenu-generic-expression) @@ -853,20 +852,20 @@ Fortran mode. If the optional argument GLOBAL is non-nil, it affects all Fortran buffers, and also the default." (interactive "p") (let (new) - (mapcar (lambda (buff) - (with-current-buffer buff - (when (eq major-mode 'fortran-mode) - (setq fortran-line-length nchars - fill-column fortran-line-length - new (fortran-font-lock-syntactic-keywords)) - ;; Refontify only if necessary. - (unless (equal new font-lock-syntactic-keywords) - (setq font-lock-syntactic-keywords - (fortran-font-lock-syntactic-keywords)) - (if font-lock-mode (font-lock-mode 1)))))) - (if global - (buffer-list) - (list (current-buffer)))) + (mapc (lambda (buff) + (with-current-buffer buff + (when (eq major-mode 'fortran-mode) + (setq fortran-line-length nchars + fill-column fortran-line-length + new (fortran-font-lock-syntactic-keywords)) + ;; Refontify only if necessary. + (unless (equal new font-lock-syntactic-keywords) + (setq font-lock-syntactic-keywords + (fortran-font-lock-syntactic-keywords)) + (if font-lock-mode (font-lock-mode 1)))))) + (if global + (buffer-list) + (list (current-buffer)))) (if global (setq-default fortran-line-length nchars)))) diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el index 716b79138f9..89211732e44 100644 --- a/lisp/progmodes/gdb-ui.el +++ b/lisp/progmodes/gdb-ui.el @@ -34,8 +34,7 @@ ;; Emacs 21 such as the fringe/display margin for breakpoints, and the toolbar ;; (see the GDB Graphical Interface section in the Emacs info manual). -;; By default, M-x gdb will start the debugger. However, if you have customised -;; gud-gdb-command-name, then start it with M-x gdba. +;; By default, M-x gdb will start the debugger. ;; This file has evolved from gdba.el that was included with GDB 5.0 and ;; written by Tom Lord and Jim Kingdon. It uses GDB's annotation interface. @@ -218,10 +217,11 @@ handlers.") "List of changed register numbers (strings).") ;;;###autoload -(defun gdba (command-line) +(defun gdb (command-line) "Run gdb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger. +The directory containing FILE becomes the initial working +directory and source-file directory for your debugger. + If `gdb-many-windows' is nil (the default value) then gdb just pops up the GUD buffer unless `gdb-show-main' is t. In this case @@ -266,13 +266,61 @@ detailed description of this mode. | RET gdb-frames-select | SPC gdb-toggle-breakpoint | | | RET gdb-goto-breakpoint | | | D gdb-delete-breakpoint | -+-----------------------------------+----------------------------------+" - ;; - (interactive (list (gud-query-cmdline 'gdba))) - ;; - ;; Let's start with a basic gud-gdb buffer and then modify it a bit. - (gdb command-line) - (gdb-init-1)) ++-----------------------------------+----------------------------------+ + +To run GDB in text command mode, replace the GDB \"--annotate=3\" +option with \"--fullname\" either in the minibuffer for the +current Emacs session, or the custom variable +`gud-gdb-command-name' for all future sessions. You need to use +text command mode to debug multiple programs within one Emacs +session." + (interactive (list (gud-query-cmdline 'gdb))) + + (when (and gud-comint-buffer + (buffer-name gud-comint-buffer) + (get-buffer-process gud-comint-buffer) + (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) + (gdb-restore-windows) + (error + "Multiple debugging requires restarting in text command mode")) + + (gud-common-init command-line nil 'gud-gdba-marker-filter) + (set (make-local-variable 'gud-minor-mode) 'gdba) + + (gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.") + (gud-def gud-tbreak "tbreak %f:%l" "\C-t" + "Set temporary breakpoint at current line.") + (gud-def gud-remove "clear %f:%l" "\C-d" "Remove breakpoint at current line") + (gud-def gud-step "step %p" "\C-s" "Step one source line with display.") + (gud-def gud-stepi "stepi %p" "\C-i" "Step one instruction with display.") + (gud-def gud-next "next %p" "\C-n" "Step one line (skip functions).") + (gud-def gud-nexti "nexti %p" nil "Step one instruction (skip functions).") + (gud-def gud-cont "cont" "\C-r" "Continue with display.") + (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") + (gud-def gud-jump + (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l")) + "\C-j" "Set execution address to current line.") + + (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") + (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") + (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") + (gud-def gud-pstar "print* %e" nil + "Evaluate C dereferenced pointer expression at point.") + + ;; For debugging Emacs only. + (gud-def gud-pv "pv1 %e" "\C-v" "Print the value of the lisp variable.") + + (gud-def gud-until "until %l" "\C-u" "Continue to current line.") + (gud-def gud-run "run" nil "Run the program.") + + (local-set-key "\C-i" 'gud-gdb-complete-command) + (setq comint-prompt-regexp "^(.*gdb[+]?) *") + (setq paragraph-start comint-prompt-regexp) + (setq gdb-first-prompt t) + (setq gud-running nil) + (setq gdb-ready nil) + (setq gud-filter-pending-text nil) + (run-hooks 'gdb-mode-hook)) (defcustom gdb-debug-log-max 128 "Maximum size of `gdb-debug-log'. If nil, size is unlimited." @@ -465,9 +513,6 @@ otherwise do not." expr))) (defun gdb-init-1 () - (set (make-local-variable 'gud-minor-mode) 'gdba) - (set (make-local-variable 'gud-marker-filter) 'gud-gdba-marker-filter) - ;; (gud-def gud-break (if (not (string-match "Machine" mode-name)) (gud-call "break %f:%l" arg) (save-excursion @@ -599,7 +644,7 @@ otherwise do not." (gdb-enqueue-input (list "server list\n" 'ignore)) (gdb-enqueue-input (list "server info source\n" 'gdb-source-info)) - (run-hooks 'gdba-mode-hook)) + (run-hooks 'gdb-mode-hook)) (defun gdb-get-version () (goto-char (point-min)) @@ -1124,20 +1169,21 @@ The key should be one of the cars in `gdb-buffer-rules-assoc'." (defun gdb-send (proc string) "A comint send filter for gdb. This filter may simply queue input for a later time." - (with-current-buffer gud-comint-buffer - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(face)))) - (if gud-running - (progn - (let ((item (concat string "\n"))) - (if gdb-enable-debug (push (cons 'send item) gdb-debug-log)) - (process-send-string proc item))) - (if (string-match "\\\\\\'" string) - (setq gdb-continuation (concat gdb-continuation string "\n")) - (let ((item (concat gdb-continuation string - (if (not comint-input-sender-no-newline) "\n")))) - (gdb-enqueue-input item) - (setq gdb-continuation nil))))) + (when gdb-ready + (with-current-buffer gud-comint-buffer + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(face)))) + (if gud-running + (progn + (let ((item (concat string "\n"))) + (if gdb-enable-debug (push (cons 'send item) gdb-debug-log)) + (process-send-string proc item))) + (if (string-match "\\\\\\'" string) + (setq gdb-continuation (concat gdb-continuation string "\n")) + (let ((item (concat gdb-continuation string + (if (not comint-input-sender-no-newline) "\n")))) + (gdb-enqueue-input item) + (setq gdb-continuation nil)))))) ;; Note: Stuff enqueued here will be sent to the next prompt, even if it ;; is a query, or other non-top-level prompt. @@ -1193,8 +1239,8 @@ This filter may simply queue input for a later time." ;; any newlines. ;; -(defcustom gud-gdba-command-name "gdb -annotate=3" - "Default command to execute an executable under the GDB-UI debugger." +(defcustom gud-gdb-command-name "gdb --annotate=3" + "Default command to execute an executable under the GDB debugger." :type 'string :group 'gud :version "22.1") @@ -1506,6 +1552,10 @@ happens to be appropriate." (set-window-buffer source-window buffer)) source-window)) +;; Derived from gud-gdb-marker-regexp +(defvar gdb-fullname-regexp + (concat "\\(.:?[^" ":" "\n]*\\)" ":" "\\([0-9]*\\)" ":" ".*")) + (defun gud-gdba-marker-filter (string) "A gud marker filter for gdb. Handle a burst of output from GDB." (if gdb-flush-pending-output @@ -1522,34 +1572,50 @@ happens to be appropriate." ;; ;; Process all the complete markers in this chunk. (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc) - (let ((annotation (match-string 1 gud-marker-acc))) - ;; - ;; Stuff prior to the match is just ordinary output. - ;; It is either concatenated to OUTPUT or directed - ;; elsewhere. - (setq output - (gdb-concat-output - output - (substring gud-marker-acc 0 (match-beginning 0)))) - ;; - ;; Take that stuff off the gud-marker-acc. - (setq gud-marker-acc (substring gud-marker-acc (match-end 0))) + (let ((annotation (match-string 1 gud-marker-acc)) + (before (substring gud-marker-acc 0 (match-beginning 0))) + (after (substring gud-marker-acc (match-end 0)))) ;; ;; Parse the tag from the annotation, and maybe its arguments. (string-match "\\(\\S-*\\) ?\\(.*\\)" annotation) (let* ((annotation-type (match-string 1 annotation)) (annotation-arguments (match-string 2 annotation)) (annotation-rule (assoc annotation-type - gdb-annotation-rules))) + gdb-annotation-rules)) + (fullname (string-match gdb-fullname-regexp annotation-type))) + + ;; Stuff prior to the match is just ordinary output. + ;; It is either concatenated to OUTPUT or directed + ;; elsewhere. + (setq output + (gdb-concat-output output + (concat before (if fullname "\n")))) + + ;; Take that stuff off the gud-marker-acc. + (setq gud-marker-acc after) + ;; Call the handler for this annotation. (if annotation-rule (funcall (car (cdr annotation-rule)) annotation-arguments) - ;; Else the annotation is not recognized. Ignore it silently, - ;; so that GDB can add new annotations without causing - ;; us to blow up. - )))) - ;; + + ;; Switch to gud-gdb-marker-filter if appropriate. + (when fullname + + ;; Extract the frame position from the marker. + (setq gud-last-frame (cons (match-string 1 annotation) + (string-to-number + (match-string 2 annotation)))) + + (set (make-local-variable 'gud-minor-mode) 'gdb) + (set (make-local-variable 'gud-marker-filter) + 'gud-gdb-marker-filter))) + + ;; Else the annotation is not recognized. Ignore it silently, + ;; so that GDB can add new annotations without causing + ;; us to blow up. + ))) + ;; Does the remaining text end in a partial line? ;; If it does, then keep part of the gud-marker-acc until we get more. (if (string-match "\n\\'\\|\n\032\\'\\|\n\032\032.*\\'" @@ -2801,7 +2867,7 @@ corresponding to the mode line clicked." (let ((answer (get-buffer-window buf 0)) (must-split nil)) (if answer - (display-buffer buf nil 0) ;Raise the frame if necessary. + (display-buffer buf nil 0) ;Deiconify the frame if necessary. ;; The buffer is not yet displayed. (pop-to-buffer gud-comint-buffer) ;Select the right frame. (let ((window (get-lru-window))) @@ -2996,7 +3062,8 @@ buffers." (gdb-get-buffer-create 'gdb-breakpoints-buffer) (if gdb-show-main (let ((pop-up-windows t)) - (display-buffer (gud-find-file gdb-main-file)))))) + (display-buffer (gud-find-file gdb-main-file))))) + (setq gdb-ready t)) (defun gdb-get-location (bptno line flag) "Find the directory containing the relevant source file. diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 91518641938..091735ee09d 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -142,23 +142,31 @@ The following place holders should be present in the string: :version "22.1" :group 'grep) -(defcustom grep-files-aliases '( - ("el" . "*.el") - ("ch" . "*.[ch]") - ("c" . "*.c") - ("h" . "*.h") - ("asm" . "*.[sS]") - ("m" . "[Mm]akefile*") - ("l" . "[Cc]hange[Ll]og*") - ("tex" . "*.tex") - ("texi" . "*.texi") - ) +(defcustom grep-files-aliases + '(("asm" . "*.[sS]") + ("c" . "*.c") + ("cc" . "*.cc") + ("ch" . "*.[ch]") + ("el" . "*.el") + ("h" . "*.h") + ("l" . "[Cc]hange[Ll]og*") + ("m" . "[Mm]akefile*") + ("tex" . "*.tex") + ("texi" . "*.texi")) "*Alist of aliases for the FILES argument to `lgrep' and `rgrep'." :type 'alist :group 'grep) -(defcustom grep-find-ignored-directories '("CVS" ".svn" "{arch}" ".hg" "_darcs" - ".git" ".bzr") +(defcustom grep-find-ignored-directories + '(".bzr" + ".git" + ".hg" + ".svn" + "CVS" + "RCS" + "_MTN" + "_darcs" + "{arch}") "*List of names of sub-directories which `rgrep' shall not recurse into." :type '(repeat string) :group 'grep) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 4b0dec7002e..d2384232686 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -104,6 +104,8 @@ If SOFT is non-nil, returns nil if the symbol doesn't already exist." "Non-nil if debugged program is running. Used to grey out relevant toolbar icons.") +(defvar gdb-ready nil) + ;; Use existing Info buffer, if possible. (defun gud-goto-info () "Go to relevant Emacs info node." @@ -592,8 +594,9 @@ required by the caller." ;; History of argument lists passed to gdb. (defvar gud-gdb-history nil) -(defcustom gud-gdb-command-name "gdb --annotate=3" - "Default command to execute an executable under the GDB debugger." +(defcustom gud-gud-gdb-command-name "gdb --fullname" + "Default command to run an executable under GDB in text command mode. +The option \"--fullname\" must be included in this value." :type 'string :group 'gud) @@ -638,14 +641,6 @@ required by the caller." (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc) (let ((match (match-string 1 gud-marker-acc))) - ;; Pick up stopped annotation if attaching to process. - (if (string-equal match "stopped") (setq gdb-active-process t)) - - ;; Using annotations, switch to gud-gdba-marker-filter. - (when (string-equal match "prompt") - (require 'gdb-ui) - (gdb-prompt nil)) - (setq ;; Append any text before the marker to the output we're going ;; to return - we don't include the marker in this text. @@ -654,13 +649,7 @@ required by the caller." ;; Set the accumulator to the remaining text. - gud-marker-acc (substring gud-marker-acc (match-end 0))) - - ;; Pick up any errors that occur before first prompt annotation. - (if (string-equal match "error-begin") - (put-text-property 0 (length gud-marker-acc) - 'face font-lock-warning-face - gud-marker-acc)))) + gud-marker-acc (substring gud-marker-acc (match-end 0))))) ;; Does the remaining text look like it might end with the ;; beginning of another marker? If it does, then keep it in @@ -712,8 +701,9 @@ required by the caller." (defvar gud-filter-pending-text nil "Non-nil means this is text that has been saved for later in `gud-filter'.") +;; The old gdb command. The new one is in gdb-ui.el. ;;;###autoload -(defun gdb (command-line) +(defun gud-gdb (command-line) "Run gdb on program FILE in buffer *gud-FILE*. The directory containing FILE becomes the initial working directory and source-file directory for your debugger. By @@ -726,7 +716,9 @@ current Emacs session, or the custom variable `gud-gdb-command-name' for all future sessions. You need to use text command mode to debug multiple programs within one Emacs session." - (interactive (list (gud-query-cmdline 'gdb))) + (interactive (list (gud-query-cmdline 'gud-gdb))) + + (require 'gdb-ui) (when (and gud-comint-buffer (buffer-name gud-comint-buffer) @@ -736,8 +728,8 @@ session." (error "Multiple debugging requires restarting in text command mode")) - (gud-common-init command-line nil 'gud-gdb-marker-filter) - (set (make-local-variable 'gud-minor-mode) 'gdb) + (gud-common-init command-line nil 'gud-gdba-marker-filter) + (set (make-local-variable 'gud-minor-mode) 'gdba) (gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.") (gud-def gud-tbreak "tbreak %f:%l" "\C-t" @@ -769,8 +761,10 @@ session." (setq comint-prompt-regexp "^(.*gdb[+]?) *") (setq paragraph-start comint-prompt-regexp) (setq gdb-first-prompt t) + (setq gud-running nil) + (setq gdb-ready nil) (setq gud-filter-pending-text nil) - (run-hooks 'gdb-mode-hook)) + (run-hooks 'gud-gdb-mode-hook)) ;; One of the nice features of GDB is its impressive support for ;; context-sensitive command completion. We preserve that feature @@ -1643,7 +1637,7 @@ and source-file directory for your debugger." (gud-common-init command-line nil 'gud-pdb-marker-filter) (set (make-local-variable 'gud-minor-mode) 'pdb) - (gud-def gud-break "break %l" "\C-b" "Set breakpoint at current line.") + (gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.") (gud-def gud-remove "clear %f:%l" "\C-d" "Remove breakpoint at current line") (gud-def gud-step "step" "\C-s" "Step one source line with display.") (gud-def gud-next "next" "\C-n" "Step one line (skip functions).") @@ -2527,7 +2521,6 @@ comint mode, which see." (and file-word (file-name-nondirectory file)))) (set (make-local-variable 'gud-marker-filter) marker-filter) (if find-file (set (make-local-variable 'gud-find-file) find-file)) - (setq gud-running nil) (setq gud-last-last-frame nil) (set-process-filter (get-buffer-process (current-buffer)) 'gud-filter) @@ -2635,7 +2628,7 @@ It is saved for when this flag is not set.") ;; process-buffer is current-buffer (unwind-protect (progn - ;; Write something in *compilation* and hack its mode line, + ;; Write something in the GUD buffer and hack its mode line, (set-buffer (process-buffer proc)) ;; Fix the mode line. (setq mode-line-process @@ -2691,11 +2684,14 @@ Obeying it means displaying in another window the specified file and line." (buffer (with-current-buffer gud-comint-buffer (gud-find-file true-file))) - (window (and buffer (or (get-buffer-window buffer) - (if (memq gud-minor-mode '(gdbmi gdba)) - (unless (gdb-display-source-buffer buffer) - (gdb-display-buffer buffer nil))) - (display-buffer buffer)))) + (window (and buffer + (or (get-buffer-window buffer) + (if (memq gud-minor-mode '(gdbmi gdba)) + (or (if (get-buffer-window buffer 0) + (display-buffer buffer nil 0)) + (unless (gdb-display-source-buffer buffer) + (gdb-display-buffer buffer nil)))) + (display-buffer buffer)))) (pos)) (if buffer (progn diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el index 6b911dd1e7a..c70f5cdb6a1 100644 --- a/lisp/progmodes/meta-mode.el +++ b/lisp/progmodes/meta-mode.el @@ -124,7 +124,7 @@ ;; ;; This package was begun on February 1, 1997, exactly 20 years after ;; the genesis of TeX took place according to Don Knuth's own account -;; (cf. ``The Errors of TeX'', reprinted in ``Literate Programming'', +;; (cf. ``The Errors of TeX'', reprinted in ``Literate Programming'', ;; Chapter 10, p. 249). What better date could there be to choose? ;; @@ -194,42 +194,42 @@ (list ;; embedded TeX code in btex ... etex (cons (concat "\\(btex\\|verbatimtex\\)" - "[ \t]+\\(.*\\)[ \t]+" + "[ \t\f]+\\(.*\\)[ \t\f]+" "\\(etex\\)") '((1 font-lock-keyword-face) (2 font-lock-string-face) (3 font-lock-keyword-face))) ;; unary macro definitions: def, vardef, let (cons (concat "\\<" macro-keywords-1 "\\>" - "[ \t]+\\(\\sw+\\|\\s_+\\|\\s.+\\)") + "[ \t\f]+\\(\\sw+\\|\\s_+\\|\\s.+\\)") '((1 font-lock-keyword-face) (2 font-lock-function-name-face))) ;; binary macro defintions: <leveldef> x operator y (cons (concat "\\<" macro-keywords-2 "\\>" - "[ \t]+\\(\\sw+\\)" - "[ \t]*\\(\\sw+\\|\\s.+\\)" - "[ \t]*\\(\\sw+\\)") + "[ \t\f]+\\(\\sw+\\)" + "[ \t\f]*\\(\\sw+\\|\\s.+\\)" + "[ \t\f]*\\(\\sw+\\)") '((1 font-lock-keyword-face) (2 font-lock-variable-name-face nil t) (3 font-lock-function-name-face nil t) (4 font-lock-variable-name-face nil t))) ;; variable declarations: numeric, pair, color, ... (cons (concat "\\<" type-keywords "\\>" - "\\([ \t]+\\(\\sw+\\)\\)*") + "\\([ \t\f]+\\(\\sw+\\)\\)*") '((1 font-lock-type-face) (font-lock-match-meta-declaration-item-and-skip-to-next (goto-char (match-end 1)) nil (1 font-lock-variable-name-face nil t)))) ;; argument declarations: expr, suffix, text, ... (cons (concat "\\<" args-keywords "\\>" - "\\([ \t]+\\(\\sw+\\|\\s_+\\)\\)*") + "\\([ \t\f]+\\(\\sw+\\|\\s_+\\)\\)*") '((1 font-lock-type-face) (font-lock-match-meta-declaration-item-and-skip-to-next (goto-char (match-end 1)) nil (1 font-lock-variable-name-face nil t)))) ;; special case of arguments: expr x of y - (cons (concat "\\(expr\\)[ \t]+\\(\\sw+\\)" - "[ \t]+\\(of\\)[ \t]+\\(\\sw+\\)") + (cons (concat "\\(expr\\)[ \t\f]+\\(\\sw+\\)" + "[ \t\f]+\\(of\\)[ \t\f]+\\(\\sw+\\)") '((1 font-lock-type-face) (2 font-lock-variable-name-face) (3 font-lock-keyword-face nil t) @@ -245,7 +245,7 @@ 'font-lock-keyword-face) ;; input, generate (cons (concat "\\<" input-keywords "\\>" - "[ \t]+\\(\\sw+\\)") + "[ \t\f]+\\(\\sw+\\)") '((1 font-lock-keyword-face) (2 font-lock-constant-face))) ;; embedded Metafont/MetaPost code in comments @@ -264,7 +264,7 @@ ;; `forward-sexp'. The list of items is expected to be separated ;; by commas and terminated by semicolons or equals signs. ;; - (if (looking-at "[ \t]*\\(\\sw+\\|\\s_+\\)") + (if (looking-at "[ \t\f]*\\(\\sw+\\|\\s_+\\)") (save-match-data (condition-case nil (save-restriction @@ -272,7 +272,7 @@ (narrow-to-region (point-min) limit) (goto-char (match-end 1)) ;; Move over any item value, etc., to the next item. - (while (not (looking-at "[ \t]*\\(\\(,\\)\\|;\\|=\\|$\\)")) + (while (not (looking-at "[ \t\f]*\\(\\(,\\)\\|;\\|=\\|$\\)")) (goto-char (or (scan-sexps (point) 1) (point-max)))) (goto-char (match-end 2))) (error t))))) @@ -586,7 +586,7 @@ If the list was changed, sort the list and remove duplicates first." (if (and meta-left-comment-regexp (looking-at meta-left-comment-regexp)) (current-column) - (skip-chars-backward "\t ") + (skip-chars-backward "\t\f ") (max (if (bolp) 0 (1+ (current-column))) comment-column))) @@ -647,20 +647,24 @@ If the list was changed, sort the list and remove duplicates first." (defun meta-indent-previous-line () "Go to the previous line of code, skipping comments." - (skip-chars-backward "\n\t ") + (skip-chars-backward "\n\t\f ") (move-to-column (current-indentation)) ;; Ignore comments. (while (and (looking-at comment-start) (not (bobp))) - (skip-chars-backward "\n\t ") - (if (not (bobp)) - (move-to-column (current-indentation))))) + (skip-chars-backward "\n\t\f ") + (when (not (bobp)) + (move-to-column (current-indentation))))) (defun meta-indent-unfinished-line () "Tell if the current line of code ends with an unfinished expression." (save-excursion (end-of-line) ;; Skip backward the comments. - (while (search-backward comment-start (point-at-bol) t)) + (let ((point-not-in-string (point))) + (while (search-backward comment-start (point-at-bol) t) + (unless (meta-indent-in-string-p) + (setq point-not-in-string (point)))) + (goto-char point-not-in-string)) ;; Search for the end of the previous expression. (if (search-backward ";" (point-at-bol) t) (progn (while (and (meta-indent-in-string-p) @@ -672,7 +676,7 @@ If the list was changed, sort the list and remove duplicates first." ;; See if the last statement of the line is environment-related, ;; or exists at all. (if (meta-indent-looking-at-code - (concat "[ \t]*\\($\\|" (regexp-quote comment-start) + (concat "[ \t\f]*\\($\\|" (regexp-quote comment-start) "\\|\\<" meta-end-environment-regexp "\\>" "\\|\\<" meta-begin-environment-regexp "\\>" "\\|\\<" meta-within-environment-regexp "\\>\\)")) @@ -782,7 +786,7 @@ Returns t unless search stops due to beginning or end of buffer." (concat "\\<" meta-begin-defun-regexp "\\>") nil t arg) (progn (goto-char (match-beginning 0)) (skip-chars-backward "%") - (skip-chars-backward " \t") t))) + (skip-chars-backward " \t\f") t))) (defun meta-end-of-defun (&optional arg) "Move forward to end of a defun in Metafont or MetaPost code. @@ -796,7 +800,7 @@ Returns t unless search stops due to beginning or end of buffer." (concat "\\<" meta-end-defun-regexp "\\>") nil t arg) (progn (goto-char (match-end 0)) (skip-chars-forward ";") - (skip-chars-forward " \t") + (skip-chars-forward " \t\f") (if (looking-at "\n") (forward-line 1)) t))) @@ -864,78 +868,74 @@ The environment marked is the one that contains point or follows point." "Abbrev table used in Metafont or MetaPost mode.") (define-abbrev-table 'meta-mode-abbrev-table ()) -(defvar meta-mode-syntax-table nil +(defvar meta-mode-syntax-table + (let ((st (make-syntax-table))) + ;; underscores are word constituents + (modify-syntax-entry ?_ "w" st) + ;; miscellaneous non-word symbols + (modify-syntax-entry ?# "_" st) + (modify-syntax-entry ?@ "_" st) + (modify-syntax-entry ?$ "_" st) + (modify-syntax-entry ?? "_" st) + (modify-syntax-entry ?! "_" st) + ;; binary operators + (modify-syntax-entry ?& "." st) + (modify-syntax-entry ?+ "." st) + (modify-syntax-entry ?- "." st) + (modify-syntax-entry ?/ "." st) + (modify-syntax-entry ?* "." st) + (modify-syntax-entry ?. "." st) + (modify-syntax-entry ?: "." st) + (modify-syntax-entry ?= "." st) + (modify-syntax-entry ?< "." st) + (modify-syntax-entry ?> "." st) + (modify-syntax-entry ?| "." st) + ;; opening and closing delimiters + (modify-syntax-entry ?\( "()" st) + (modify-syntax-entry ?\) ")(" st) + (modify-syntax-entry ?\[ "(]" st) + (modify-syntax-entry ?\] ")[" st) + (modify-syntax-entry ?\{ "(}" st) + (modify-syntax-entry ?\} "){" st) + ;; comment character + (modify-syntax-entry ?% "<" st) + (modify-syntax-entry ?\n ">" st) + ;; escape character, needed for embedded TeX code + (modify-syntax-entry ?\\ "\\" st) + st) "Syntax table used in Metafont or MetaPost mode.") -(if meta-mode-syntax-table - () - (setq meta-mode-syntax-table (make-syntax-table)) - ;; underscores are word constituents - (modify-syntax-entry ?_ "w" meta-mode-syntax-table) - ;; miscellaneous non-word symbols - (modify-syntax-entry ?# "_" meta-mode-syntax-table) - (modify-syntax-entry ?@ "_" meta-mode-syntax-table) - (modify-syntax-entry ?$ "_" meta-mode-syntax-table) - (modify-syntax-entry ?? "_" meta-mode-syntax-table) - (modify-syntax-entry ?! "_" meta-mode-syntax-table) - ;; binary operators - (modify-syntax-entry ?& "." meta-mode-syntax-table) - (modify-syntax-entry ?+ "." meta-mode-syntax-table) - (modify-syntax-entry ?- "." meta-mode-syntax-table) - (modify-syntax-entry ?/ "." meta-mode-syntax-table) - (modify-syntax-entry ?* "." meta-mode-syntax-table) - (modify-syntax-entry ?. "." meta-mode-syntax-table) - (modify-syntax-entry ?: "." meta-mode-syntax-table) - (modify-syntax-entry ?= "." meta-mode-syntax-table) - (modify-syntax-entry ?< "." meta-mode-syntax-table) - (modify-syntax-entry ?> "." meta-mode-syntax-table) - (modify-syntax-entry ?| "." meta-mode-syntax-table) - ;; opening and closing delimiters - (modify-syntax-entry ?\( "()" meta-mode-syntax-table) - (modify-syntax-entry ?\) ")(" meta-mode-syntax-table) - (modify-syntax-entry ?\[ "(]" meta-mode-syntax-table) - (modify-syntax-entry ?\] ")[" meta-mode-syntax-table) - (modify-syntax-entry ?\{ "(}" meta-mode-syntax-table) - (modify-syntax-entry ?\} "){" meta-mode-syntax-table) - ;; comment character - (modify-syntax-entry ?% "<" meta-mode-syntax-table) - (modify-syntax-entry ?\n ">" meta-mode-syntax-table) - ;; escape character, needed for embedded TeX code - (modify-syntax-entry ?\\ "\\" meta-mode-syntax-table) - ) -(defvar meta-mode-map nil +(defvar meta-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-m" 'reindent-then-newline-and-indent) + ;; Comment Paragraphs: + ;; (define-key map "\M-a" 'backward-sentence) + ;; (define-key map "\M-e" 'forward-sentence) + ;; (define-key map "\M-h" 'mark-paragraph) + ;; (define-key map "\M-q" 'fill-paragraph) + ;; Navigation: + (define-key map "\M-\C-a" 'meta-beginning-of-defun) + (define-key map "\M-\C-e" 'meta-end-of-defun) + (define-key map "\M-\C-h" 'meta-mark-defun) + ;; Indentation: + (define-key map "\M-\C-q" 'meta-indent-defun) + (define-key map "\C-c\C-qe" 'meta-indent-defun) + (define-key map "\C-c\C-qr" 'meta-indent-region) + (define-key map "\C-c\C-qb" 'meta-indent-buffer) + ;; Commenting Out: + (define-key map "\C-c%" 'meta-comment-defun) + ;; (define-key map "\C-uC-c%" 'meta-uncomment-defun) + (define-key map "\C-c;" 'meta-comment-region) + (define-key map "\C-c:" 'meta-uncomment-region) + ;; Symbol Completion: + (define-key map "\M-\t" 'meta-complete-symbol) + ;; Shell Commands: + ;; (define-key map "\C-c\C-c" 'meta-command-file) + ;; (define-key map "\C-c\C-k" 'meta-kill-job) + ;; (define-key map "\C-c\C-l" 'meta-recenter-output) + map) "Keymap used in Metafont or MetaPost mode.") -(if meta-mode-map - () - (setq meta-mode-map (make-sparse-keymap)) - (define-key meta-mode-map "\t" 'meta-indent-line) - (define-key meta-mode-map "\C-m" 'reindent-then-newline-and-indent) - ;; Comment Paragraphs: -; (define-key meta-mode-map "\M-a" 'backward-sentence) -; (define-key meta-mode-map "\M-e" 'forward-sentence) -; (define-key meta-mode-map "\M-h" 'mark-paragraph) -; (define-key meta-mode-map "\M-q" 'fill-paragraph) - ;; Navigation: - (define-key meta-mode-map "\M-\C-a" 'meta-beginning-of-defun) - (define-key meta-mode-map "\M-\C-e" 'meta-end-of-defun) - (define-key meta-mode-map "\M-\C-h" 'meta-mark-defun) - ;; Indentation: - (define-key meta-mode-map "\M-\C-q" 'meta-indent-defun) - (define-key meta-mode-map "\C-c\C-qe" 'meta-indent-defun) - (define-key meta-mode-map "\C-c\C-qr" 'meta-indent-region) - (define-key meta-mode-map "\C-c\C-qb" 'meta-indent-buffer) - ;; Commenting Out: - (define-key meta-mode-map "\C-c%" 'meta-comment-defun) -; (define-key meta-mode-map "\C-uC-c%" 'meta-uncomment-defun) - (define-key meta-mode-map "\C-c;" 'meta-comment-region) - (define-key meta-mode-map "\C-c:" 'meta-uncomment-region) - ;; Symbol Completion: - (define-key meta-mode-map "\M-\t" 'meta-complete-symbol) - ;; Shell Commands: -; (define-key meta-mode-map "\C-c\C-c" 'meta-command-file) -; (define-key meta-mode-map "\C-c\C-k" 'meta-kill-job) -; (define-key meta-mode-map "\C-c\C-l" 'meta-recenter-output) - ) + (easy-menu-define meta-mode-menu meta-mode-map @@ -1014,11 +1014,14 @@ The environment marked is the one that contains point or follows point." (make-local-variable 'comment-start) (make-local-variable 'comment-end) (make-local-variable 'comment-multi-line) - (setq comment-start-skip "%+[ \t]*") + (setq comment-start-skip "%+[ \t\f]*") (setq comment-start "%") (setq comment-end "") (setq comment-multi-line nil) + ;; We use `back-to-indentation' but \f is no indentation sign. + (modify-syntax-entry ?\f "_ ") + (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments t) @@ -1100,5 +1103,5 @@ Turning on MetaPost mode calls the value of the variable (provide 'meta-mode) (run-hooks 'meta-mode-load-hook) -;;; arch-tag: ec2916b2-3a83-4cf7-962d-d8019370c006 +;; arch-tag: ec2916b2-3a83-4cf7-962d-d8019370c006 ;;; meta-mode.el ends here diff --git a/lisp/progmodes/octave-inf.el b/lisp/progmodes/octave-inf.el index 83d99ab8bee..7620649981c 100644 --- a/lisp/progmodes/octave-inf.el +++ b/lisp/progmodes/octave-inf.el @@ -153,10 +153,11 @@ Entry to this mode successively runs the hooks `comint-mode-hook' and (setq comint-input-ring-file-name (or (getenv "OCTAVE_HISTFILE") "~/.octave_hist") - comint-input-ring-size (or (getenv "OCTAVE_HISTSIZE") 1024) - comint-input-filter-functions '(inferior-octave-directory-tracker)) + comint-input-ring-size (or (getenv "OCTAVE_HISTSIZE") 1024)) (set (make-local-variable 'comint-dynamic-complete-functions) inferior-octave-dynamic-complete-functions) + (add-hook 'comint-input-filter-functions + 'inferior-octave-directory-tracker nil t) (comint-read-input-ring t) (run-mode-hooks 'inferior-octave-mode-hook)) diff --git a/lisp/progmodes/octave-mod.el b/lisp/progmodes/octave-mod.el index 3da3434cda2..4630fe1856d 100644 --- a/lisp/progmodes/octave-mod.el +++ b/lisp/progmodes/octave-mod.el @@ -63,7 +63,7 @@ All Octave abbrevs start with a grave accent (`).") (unless octave-abbrev-table (define-abbrev-table 'octave-abbrev-table ())) -(let ((ac abbrevs-changed)) +(let ((abbrevs-changed abbrevs-changed)) (define-abbrev octave-abbrev-table "`a" "all_va_args" nil 0 t) (define-abbrev octave-abbrev-table "`b" "break" nil 0 t) (define-abbrev octave-abbrev-table "`cs" "case" nil 0 t) @@ -89,10 +89,10 @@ All Octave abbrevs start with a grave accent (`).") (define-abbrev octave-abbrev-table "`r" "return" nil 0 t) (define-abbrev octave-abbrev-table "`s" "switch" nil 0 t) (define-abbrev octave-abbrev-table "`t" "try" nil 0 t) + (define-abbrev octave-abbrev-table "`u" "until ()" nil 0 t) (define-abbrev octave-abbrev-table "`up" "unwind_protect" nil 0 t) (define-abbrev octave-abbrev-table "`upc" "unwind_protect_cleanup" nil 0 t) - (define-abbrev octave-abbrev-table "`w" "while ()" nil 0 t) - (setq abbrevs-changed ac)) + (define-abbrev octave-abbrev-table "`w" "while ()" nil 0 t)) (defvar octave-comment-char ?# "Character to start an Octave comment.") @@ -103,32 +103,34 @@ All Octave abbrevs start with a grave accent (`).") "Regexp to match the start of an Octave comment up to its body.") (defvar octave-begin-keywords - '("for" "function" "if" "switch" "try" "unwind_protect" "while")) + '("do" "for" "function" "if" "switch" "try" "unwind_protect" "while")) (defvar octave-else-keywords '("case" "catch" "else" "elseif" "otherwise" "unwind_protect_cleanup")) +;; FIXME: only use specific "end" tokens here to avoid confusion when "end" +;; is used in indexing (the real fix is much more complex). (defvar octave-end-keywords - '("end" "endfor" "endfunction" "endif" "endswitch" "end_try_catch" - "end_unwind_protect" "endwhile")) + '("endfor" "endfunction" "endif" "endswitch" "end_try_catch" + "end_unwind_protect" "endwhile" "until")) (defvar octave-reserved-words (append octave-begin-keywords octave-else-keywords octave-end-keywords - '("all_va_args" "break" "continue" "global" "gplot" "gsplot" - "replot" "return")) + '("break" "continue" "end" "global" "persistent" "return")) "Reserved words in Octave.") (defvar octave-text-functions '("casesen" "cd" "chdir" "clear" "diary" "dir" "document" "echo" - "edit_history" "format" "gset" "gshow" "help" "history" "hold" - "load" "ls" "more" "run_history" "save" "set" "show" "type" + "edit_history" "format" "help" "history" "hold" + "load" "ls" "more" "run_history" "save" "type" "which" "who" "whos") - "Text functions in Octave (these names are also reserved).") + "Text functions in Octave.") (defvar octave-variables - '("EDITOR" "EXEC_PATH" "F_DUPFD" "F_GETFD" "F_GETFL" "F_SETFD" - "F_SETFL" "I" "IMAGEPATH" "INFO_FILE" "INFO_PROGRAM" "Inf" "J" - "LOADPATH" "NaN" "OCTAVE_VERSION" "O_APPEND" "O_CREAT" "O_EXCL" + '("DEFAULT_EXEC_PATH" "DEFAULT_LOADPATH" + "EDITOR" "EXEC_PATH" "F_DUPFD" "F_GETFD" "F_GETFL" "F_SETFD" + "F_SETFL" "I" "IMAGE_PATH" "Inf" "J" + "NaN" "OCTAVE_VERSION" "O_APPEND" "O_CREAT" "O_EXCL" "O_NONBLOCK" "O_RDONLY" "O_RDWR" "O_TRUNC" "O_WRONLY" "PAGER" "PS1" "PS2" "PS4" "PWD" "SEEK_CUR" "SEEK_END" "SEEK_SET" "__F_DUPFD__" "__F_GETFD__" "__F_GETFL__" "__F_SETFD__" "__F_SETFL__" "__I__" @@ -136,29 +138,23 @@ All Octave abbrevs start with a grave accent (`).") "__O_CREAT__" "__O_EXCL__" "__O_NONBLOCK__" "__O_RDONLY__" "__O_RDWR__" "__O_TRUNC__" "__O_WRONLY__" "__PWD__" "__SEEK_CUR__" "__SEEK_END__" "__SEEK_SET__" "__argv__" "__e__" "__eps__" - "__error_text__" "__i__" "__inf__" "__j__" "__nan__" "__pi__" + "__i__" "__inf__" "__j__" "__nan__" "__pi__" "__program_invocation_name__" "__program_name__" "__realmax__" "__realmin__" "__stderr__" "__stdin__" "__stdout__" "ans" "argv" - "automatic_replot" "beep_on_error" "completion_append_char" - "default_return_value" "default_save_format" - "define_all_return_values" "do_fortran_indexing" "e" - "echo_executing_commands" "empty_list_elements_ok" "eps" - "error_text" "gnuplot_binary" "gnuplot_has_multiplot" "history_file" - "history_size" "ignore_function_time_stamp" "implicit_str_to_num_ok" - "inf" "nan" "nargin" "ok_to_lose_imaginary_part" - "output_max_field_width" "output_precision" + "beep_on_error" "completion_append_char" + "crash_dumps_octave_core" "default_save_format" + "e" "echo_executing_commands" "eps" + "error_text" "gnuplot_binary" "history_file" + "history_size" "ignore_function_time_stamp" + "inf" "nan" "nargin" "output_max_field_width" "output_precision" "page_output_immediately" "page_screen_output" "pi" - "prefer_column_vectors" "prefer_zero_one_indexing" "print_answer_id_name" "print_empty_dimensions" - "program_invocation_name" "program_name" "propagate_empty_matrices" - "realmax" "realmin" "resize_on_range_error" - "return_last_computed_value" "save_precision" "saving_history" + "program_invocation_name" "program_name" + "realmax" "realmin" "return_last_computed_value" "save_precision" + "saving_history" "sighup_dumps_octave_core" "sigterm_dumps_octave_core" "silent_functions" "split_long_rows" "stderr" "stdin" "stdout" "string_fill_char" "struct_levels_to_print" - "suppress_verbose_help_message" "treat_neg_dim_as_zero" - "warn_assign_as_truth_value" "warn_comma_in_global_decl" - "warn_divide_by_zero" "warn_function_name_clash" - "warn_missing_semicolon" "whitespace_in_literal_matrix") + "suppress_verbose_help_message") "Builtin variables in Octave.") (defvar octave-function-header-regexp @@ -193,22 +189,18 @@ parenthetical grouping.") "Additional Octave expressions to highlight.") (defcustom inferior-octave-buffer "*Inferior Octave*" - "*Name of buffer for running an inferior Octave process." + "Name of buffer for running an inferior Octave process." :type 'string :group 'octave-inferior) (defvar inferior-octave-process nil) -(defvar octave-mode-map nil - "Keymap used in Octave mode.") -(if octave-mode-map - () +(defvar octave-mode-map (let ((map (make-sparse-keymap))) (define-key map "`" 'octave-abbrev-start) (define-key map ";" 'octave-electric-semi) (define-key map " " 'octave-electric-space) (define-key map "\n" 'octave-reindent-then-newline-and-indent) - (define-key map "\t" 'indent-according-to-mode) (define-key map "\e;" 'octave-indent-for-comment) (define-key map "\e\n" 'octave-indent-new-comment-line) (define-key map "\e\t" 'octave-complete-symbol) @@ -245,49 +237,51 @@ parenthetical grouping.") (define-key map "\C-c\C-i\C-s" 'octave-show-process-buffer) (define-key map "\C-c\C-i\C-h" 'octave-hide-process-buffer) (define-key map "\C-c\C-i\C-k" 'octave-kill-process) - (setq octave-mode-map map))) + map) + "Keymap used in Octave mode.") + (defvar octave-mode-menu - (list "Octave" - (list "Lines" - ["Previous Code Line" octave-previous-code-line t] - ["Next Code Line" octave-next-code-line t] - ["Begin of Continuation" octave-beginning-of-line t] - ["End of Continuation" octave-end-of-line t] - ["Split Line at Point" octave-indent-new-comment-line t]) - (list "Blocks" - ["Next Block" octave-forward-block t] - ["Previous Block" octave-backward-block t] - ["Down Block" octave-down-block t] - ["Up Block" octave-backward-up-block t] - ["Mark Block" octave-mark-block t] - ["Close Block" octave-close-block t]) - (list "Functions" - ["Begin of Function" octave-beginning-of-defun t] - ["End of Function" octave-end-of-defun t] - ["Mark Function" octave-mark-defun t] - ["Indent Function" octave-indent-defun t] - ["Insert Function" octave-insert-defun t]) - "-" - (list "Debug" - ["Send Current Line" octave-send-line t] - ["Send Current Block" octave-send-block t] - ["Send Current Function" octave-send-defun t] - ["Send Region" octave-send-region t] - ["Show Process Buffer" octave-show-process-buffer t] - ["Hide Process Buffer" octave-hide-process-buffer t] - ["Kill Process" octave-kill-process t]) - "-" - ["Indent Line" indent-according-to-mode t] - ["Complete Symbol" octave-complete-symbol t] - "-" - ["Toggle Abbrev Mode" abbrev-mode t] - ["Toggle Auto-Fill Mode" auto-fill-mode t] - "-" - ["Submit Bug Report" octave-submit-bug-report t] - "-" - ["Describe Octave Mode" octave-describe-major-mode t] - ["Lookup Octave Index" octave-help t]) + '("Octave" + '("Lines" + ["Previous Code Line" octave-previous-code-line t] + ["Next Code Line" octave-next-code-line t] + ["Begin of Continuation" octave-beginning-of-line t] + ["End of Continuation" octave-end-of-line t] + ["Split Line at Point" octave-indent-new-comment-line t]) + '("Blocks" + ["Next Block" octave-forward-block t] + ["Previous Block" octave-backward-block t] + ["Down Block" octave-down-block t] + ["Up Block" octave-backward-up-block t] + ["Mark Block" octave-mark-block t] + ["Close Block" octave-close-block t]) + '("Functions" + ["Begin of Function" octave-beginning-of-defun t] + ["End of Function" octave-end-of-defun t] + ["Mark Function" octave-mark-defun t] + ["Indent Function" octave-indent-defun t] + ["Insert Function" octave-insert-defun t]) + "-" + '("Debug" + ["Send Current Line" octave-send-line t] + ["Send Current Block" octave-send-block t] + ["Send Current Function" octave-send-defun t] + ["Send Region" octave-send-region t] + ["Show Process Buffer" octave-show-process-buffer t] + ["Hide Process Buffer" octave-hide-process-buffer t] + ["Kill Process" octave-kill-process t]) + "-" + ["Indent Line" indent-according-to-mode t] + ["Complete Symbol" octave-complete-symbol t] + "-" + ["Toggle Abbrev Mode" abbrev-mode t] + ["Toggle Auto-Fill Mode" auto-fill-mode t] + "-" + ["Submit Bug Report" octave-submit-bug-report t] + "-" + ["Describe Octave Mode" octave-describe-major-mode t] + ["Lookup Octave Index" octave-help t]) "Menu for Octave mode.") (defvar octave-mode-syntax-table @@ -316,23 +310,23 @@ parenthetical grouping.") "Syntax table in use in `octave-mode' buffers.") (defcustom octave-auto-indent nil - "*Non-nil means indent line after a semicolon or space in Octave mode." + "Non-nil means indent line after a semicolon or space in Octave mode." :type 'boolean :group 'octave) (defcustom octave-auto-newline nil - "*Non-nil means automatically newline after a semicolon in Octave mode." + "Non-nil means automatically newline after a semicolon in Octave mode." :type 'boolean :group 'octave) (defcustom octave-blink-matching-block t - "*Control the blinking of matching Octave block keywords. + "Control the blinking of matching Octave block keywords. Non-nil means show matching begin of block when inserting a space, newline or semicolon after an else or end keyword." :type 'boolean :group 'octave) (defcustom octave-block-offset 2 - "*Extra indentation applied to statements in Octave block structures." + "Extra indentation applied to statements in Octave block structures." :type 'integer :group 'octave) @@ -352,15 +346,17 @@ newline or semicolon after an else or end keyword." (concat octave-block-begin-regexp "\\|" octave-block-end-regexp)) (defvar octave-block-else-or-end-regexp (concat octave-block-else-regexp "\\|" octave-block-end-regexp)) +;; FIXME: only use specific "end" tokens here to avoid confusion when "end" +;; is used in indexing (the real fix is much more complex). (defvar octave-block-match-alist - '(("for" . ("end" "endfor")) - ("function" . ("end" "endfunction")) - ("if" . ("else" "elseif" "end" "endif")) - ("switch" . ("case" "otherwise" "end" "endswitch")) - ("try" . ("catch" "end" "end_try_catch")) - ("unwind_protect" . ("unwind_protect_cleanup" "end" - "end_unwind_protect")) - ("while" . ("end" "endwhile"))) + '(("do" . ("until")) + ("for" . ("endfor")) + ("function" . ("endfunction")) + ("if" . ("else" "elseif" "endif")) + ("switch" . ("case" "otherwise" "endswitch")) + ("try" . ("catch" "end_try_catch")) + ("unwind_protect" . ("unwind_protect_cleanup" "end_unwind_protect")) + ("while" . ("endwhile"))) "Alist with Octave's matching block keywords. Has Octave's begin keywords as keys and a list of the matching else or end keywords as associated values.") @@ -370,13 +366,13 @@ end keywords as associated values.") "String to insert to start a new Octave comment on an empty line.") (defcustom octave-continuation-offset 4 - "*Extra indentation applied to Octave continuation lines." + "Extra indentation applied to Octave continuation lines." :type 'integer :group 'octave) (defvar octave-continuation-regexp "[^#%\n]*\\(\\\\\\|\\.\\.\\.\\)\\s-*\\(\\s<.*\\)?$") (defcustom octave-continuation-string "\\" - "*Character string used for Octave continuation lines. Normally \\." + "Character string used for Octave continuation lines. Normally \\." :type 'string :group 'octave) @@ -392,27 +388,22 @@ Currently, only builtin variables can be completed.") (list nil octave-function-header-regexp 3)) "Imenu expression for Octave mode. See `imenu-generic-expression'.") -(defcustom octave-mode-startup-message t - "*nil means do not display the Octave mode startup message." - :type 'boolean - :group 'octave) - (defcustom octave-mode-hook nil - "*Hook to be run when Octave mode is started." + "Hook to be run when Octave mode is started." :type 'hook :group 'octave) (defcustom octave-send-show-buffer t - "*Non-nil means display `inferior-octave-buffer' after sending to it." + "Non-nil means display `inferior-octave-buffer' after sending to it." :type 'boolean :group 'octave) (defcustom octave-send-line-auto-forward t - "*Control auto-forward after sending to the inferior Octave process. + "Control auto-forward after sending to the inferior Octave process. Non-nil means always go to the next Octave code line after sending." :type 'boolean :group 'octave) (defcustom octave-send-echo-input t - "*Non-nil means echo input sent to the inferior Octave process." + "Non-nil means echo input sent to the inferior Octave process." :type 'boolean :group 'octave) @@ -423,7 +414,7 @@ Non-nil means always go to the next Octave code line after sending." This mode makes it easier to write Octave code by helping with indentation, doing some of the typing for you (with Abbrev mode) and by -showing keywords, comments, strings, etc. in different faces (with +showing keywords, comments, strings, etc.. in different faces (with Font Lock mode on terminals that support it). Octave itself is a high-level language, primarily intended for numerical @@ -433,7 +424,7 @@ can also be stored in files, and it can be used in a batch mode (which is why you need this mode!). The latest released version of Octave is always available via anonymous -ftp from bevo.che.wisc.edu in the directory `/pub/octave'. Complete +ftp from ftp.octave.org in the directory `/pub/octave'. Complete source and binaries for several popular systems are available. Type \\[list-abbrevs] to display the built-in abbrevs for Octave keywords. @@ -446,43 +437,39 @@ Keybindings Variables you can use to customize Octave mode ============================================== -octave-auto-indent +`octave-auto-indent' Non-nil means indent current line after a semicolon or space. Default is nil. -octave-auto-newline +`octave-auto-newline' Non-nil means auto-insert a newline and indent after a semicolon. Default is nil. -octave-blink-matching-block +`octave-blink-matching-block' Non-nil means show matching begin of block when inserting a space, newline or semicolon after an else or end keyword. Default is t. -octave-block-offset +`octave-block-offset' Extra indentation applied to statements in block structures. Default is 2. -octave-continuation-offset +`octave-continuation-offset' Extra indentation applied to Octave continuation lines. Default is 4. -octave-continuation-string +`octave-continuation-string' String used for Octave continuation lines. Default is a backslash. -octave-mode-startup-message - nil means do not display the Octave mode startup message. - Default is t. - -octave-send-echo-input +`octave-send-echo-input' Non-nil means always display `inferior-octave-buffer' after sending a command to the inferior Octave process. -octave-send-line-auto-forward +`octave-send-line-auto-forward' Non-nil means always go to the next unsent line of Octave code after sending a line to the inferior Octave process. -octave-send-echo-input +`octave-send-echo-input' Non-nil means echo input sent to the inferior Octave process. Turning on Octave mode runs the hook `octave-mode-hook'. @@ -490,19 +477,15 @@ Turning on Octave mode runs the hook `octave-mode-hook'. To begin using this mode for all `.m' files that you edit, add the following lines to your `.emacs' file: - (autoload 'octave-mode \"octave-mod\" nil t) - (setq auto-mode-alist - (cons '(\"\\\\.m$\" . octave-mode) auto-mode-alist)) + (add-to-list 'auto-mode-alist '(\"\\\\.m\\\\'\" . octave-mode)) -To automatically turn on the abbrev, auto-fill and font-lock features, +To automatically turn on the abbrev and auto-fill features, add the following lines to your `.emacs' file as well: (add-hook 'octave-mode-hook (lambda () (abbrev-mode 1) - (auto-fill-mode 1) - (if (eq window-system 'x) - (font-lock-mode 1)))) + (auto-fill-mode 1))) To submit a problem report, enter \\[octave-submit-bug-report] from \ an Octave mode buffer. @@ -773,7 +756,7 @@ The new line is properly indented." (octave-reindent-then-newline-and-indent)))) (defun octave-indent-defun () - "Properly indents the Octave function which contains point." + "Properly indent the Octave function which contains point." (interactive) (save-excursion (octave-mark-defun) @@ -856,8 +839,8 @@ does not end in `...' or `\\' or is inside an open parenthesis list." (zerop (forward-line 1))))) (end-of-line))) -(defun octave-scan-blocks (from count depth) - "Scan from character number FROM by COUNT Octave begin-end blocks. +(defun octave-scan-blocks (count depth) + "Scan from point by COUNT Octave begin-end blocks. Returns the character number of the position thus found. If DEPTH is nonzero, block depth begins counting from that value. @@ -895,7 +878,7 @@ With argument, do it that many times. Negative arg -N means move backward across N blocks." (interactive "p") (or arg (setq arg 1)) - (goto-char (or (octave-scan-blocks (point) arg 0) (buffer-end arg)))) + (goto-char (or (octave-scan-blocks arg 0) (buffer-end arg)))) (defun octave-backward-block (&optional arg) "Move backward across one balanced Octave begin-end block. @@ -913,7 +896,7 @@ In Lisp programs, an argument is required." (interactive "p") (let ((inc (if (> arg 0) 1 -1))) (while (/= arg 0) - (goto-char (or (octave-scan-blocks (point) inc -1) + (goto-char (or (octave-scan-blocks inc -1) (buffer-end arg))) (setq arg (- arg inc))))) @@ -933,7 +916,7 @@ In Lisp programs, an argument is required." (interactive "p") (let ((inc (if (> arg 0) 1 -1))) (while (/= arg 0) - (goto-char (or (octave-scan-blocks (point) inc 1) + (goto-char (or (octave-scan-blocks inc 1) (buffer-end arg))) (setq arg (- arg inc))))) @@ -1149,6 +1132,8 @@ otherwise." (defun octave-fill-paragraph (&optional arg) "Fill paragraph of Octave code, handling Octave comments." + ;; FIXME: now that the default fill-paragraph takes care of similar issues, + ;; this seems obsolete. --Stef (interactive "P") (save-excursion (let ((end (progn (forward-paragraph) (point))) @@ -1389,7 +1374,7 @@ entered without parens)." ;;; Menu (defun octave-add-octave-menu () - "Adds the `Octave' menu to the menu bar in Octave mode." + "Add the `Octave' menu to the menu bar in Octave mode." (require 'easymenu) (easy-menu-define octave-mode-menu-map octave-mode-map "Menu keymap for Octave mode." octave-mode-menu) @@ -1519,7 +1504,6 @@ code line." 'octave-continuation-offset 'octave-continuation-string 'octave-help-files - 'octave-mode-startup-message 'octave-send-echo-input 'octave-send-line-auto-forward 'octave-send-show-buffer)))) @@ -1528,5 +1512,5 @@ code line." (provide 'octave-mod) -;;; arch-tag: 05f1ce09-be87-4c00-803e-4919ffa26c23 +;; arch-tag: 05f1ce09-be87-4c00-803e-4919ffa26c23 ;;; octave-mod.el ends here diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 462445f3d71..f1d6d02020b 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -1,4 +1,4 @@ -;;; python.el --- silly walks for Python +;;; python.el --- silly walks for Python -*- coding: iso-8859-1 -*- ;; Copyright (C) 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. @@ -89,17 +89,17 @@ (defvar python-font-lock-keywords `(,(rx symbol-start - ;; From v 2.4 reference. + ;; From v 2.5 reference, § keywords. ;; def and class dealt with separately below - (or "and" "assert" "break" "continue" "del" "elif" "else" + (or "and" "as" "assert" "break" "continue" "del" "elif" "else" "except" "exec" "finally" "for" "from" "global" "if" "import" "in" "is" "lambda" "not" "or" "pass" "print" - "raise" "return" "try" "while" "yield" - ;; Future keywords - "as" "None" "with" + "raise" "return" "try" "while" "with" "yield" ;; Not real keywords, but close enough to be fontified as such "self" "True" "False") symbol-end) + (,(rx symbol-start "None" symbol-end) ; See § Keywords in 2.5 manual. + . font-lock-constant-face) ;; Definitions (,(rx symbol-start (group "class") (1+ space) (group (1+ (or word ?_)))) (1 font-lock-keyword-face) (2 font-lock-type-face)) @@ -151,7 +151,8 @@ Used for syntactic keywords. N is the match number (1, 2 or 3)." (cond ;; Consider property for the last char if in a fenced string. ((= n 3) - (let ((syntax (syntax-ppss))) + (let* ((font-lock-syntactic-keywords nil) + (syntax (syntax-ppss))) (when (eq t (nth 3 syntax)) ; after unclosed fence (goto-char (nth 8 syntax)) ; fence position (skip-chars-forward "uUrR") ; skip any prefix @@ -163,8 +164,9 @@ Used for syntactic keywords. N is the match number (1, 2 or 3)." (= (match-beginning 1) (match-end 1))) ; prefix is null (and (= n 1) ; prefix (/= (match-beginning 1) (match-end 1)))) ; non-empty - (unless (nth 3 (syntax-ppss)) - (eval-when-compile (string-to-syntax "|")))) + (let ((font-lock-syntactic-keywords nil)) + (unless (nth 3 (syntax-ppss)) + (eval-when-compile (string-to-syntax "|"))))) ;; Otherwise (we're in a non-matching string) the property is ;; nil, which is OK. ))) @@ -348,7 +350,7 @@ comments and strings, or that point is within brackets/parens." (error nil)))))))) (defun python-comment-line-p () - "Return non-nil if current line has only a comment." + "Return non-nil iff current line has only a comment." (save-excursion (end-of-line) (when (eq 'comment (syntax-ppss-context (syntax-ppss))) @@ -356,7 +358,7 @@ comments and strings, or that point is within brackets/parens." (looking-at (rx (or (syntax comment-start) line-end)))))) (defun python-blank-line-p () - "Return non-nil if current line is blank." + "Return non-nil iff current line is blank." (save-excursion (beginning-of-line) (looking-at "\\s-*$"))) @@ -850,7 +852,7 @@ multi-line bracketed expressions." "Skip out of any nested brackets. Skip forward if FORWARD is non-nil, else backward. If SYNTAX is non-nil it is the state returned by `syntax-ppss' at point. -Return non-nil if skipping was done." +Return non-nil iff skipping was done." (let ((depth (syntax-ppss-depth (or syntax (syntax-ppss)))) (forward (if forward -1 1))) (unless (zerop depth) @@ -1083,13 +1085,15 @@ just insert a single colon." (defun python-backspace (arg) "Maybe delete a level of indentation on the current line. -Do so if point is at the end of the line's indentation. +Do so if point is at the end of the line's indentation outside +strings and comments. Otherwise just call `backward-delete-char-untabify'. Repeat ARG times." (interactive "*p") (if (or (/= (current-indentation) (current-column)) (bolp) - (python-continuation-line-p)) + (python-continuation-line-p) + (python-in-string/comment)) (backward-delete-char-untabify arg) ;; Look for the largest valid indentation which is smaller than ;; the current indentation. @@ -1190,6 +1194,10 @@ local value.") 1 2) (,(rx " in file " (group (1+ not-newline)) " on line " (group (1+ digit))) + 1 2) + ;; pdb stack trace + (,(rx line-start "> " (group (1+ (not (any "(\"<")))) + "(" (group (1+ digit)) ")" (1+ (not (any "("))) "()") 1 2)) "`compilation-error-regexp-alist' for inferior Python.") @@ -1199,7 +1207,7 @@ local value.") (define-key map "\C-c\C-l" 'python-load-file) (define-key map "\C-c\C-v" 'python-check) ;; Note that we _can_ still use these commands which send to the - ;; Python process even at the prompt provided we have a normal prompt, + ;; Python process even at the prompt iff we have a normal prompt, ;; i.e. '>>> ' and not '... '. See the comment before ;; python-send-region. Fixme: uncomment these if we address that. @@ -1245,7 +1253,7 @@ For running multiple processes in multiple buffers, see `run-python' and ;; Still required by `comint-redirect-send-command', for instance ;; (and we need to match things like `>>> ... >>> '): (set (make-local-variable 'comint-prompt-regexp) - (rx line-start (1+ (and (repeat 3 (any ">.")) " ")))) + (rx line-start (1+ (and (or (repeat 3 (any ">.")) "(Pdb)") " ")))) (set (make-local-variable 'compilation-error-regexp-alist) python-compilation-regexp-alist) (compilation-shell-minor-mode 1)) @@ -1375,7 +1383,7 @@ buffer for a list of commands.)" ;; seems worth putting in a separate file, and it's probably cleaner ;; to put it in a module. ;; Ensure we're at a prompt before doing anything else. - (python-send-receive "import emacs; print '_emacs_out ()'"))) + (python-send-string "import emacs"))) (if (derived-mode-p 'python-mode) (setq python-buffer (default-value 'python-buffer))) ; buffer-local ;; Without this, help output goes into the inferior python buffer if @@ -1620,7 +1628,7 @@ The result is what follows `_emacs_out' in the output." ;; Fixme: Is there anything reasonable we can do with random methods? ;; (Currently only works with functions.) (defun python-eldoc-function () - "`eldoc-print-current-symbol-info' for Python. + "`eldoc-documentation-function' for Python. Only works when point is in a function name, not its arg list, for instance. Assumes an inferior Python is running." (let ((symbol (with-syntax-table python-dotty-syntax-table @@ -1737,47 +1745,57 @@ The criterion is either a match for `jython-mode' via (jython-mode))))))) (defun python-fill-paragraph (&optional justify) - "`fill-paragraph-function' handling comments and multi-line strings. -If any of the current line is a comment, fill the comment or the -paragraph of it that point is in, preserving the comment's -indentation and initial comment characters. Similarly if the end -of the current line is in or at the end of a multi-line string. -Otherwise, do nothing." + "`fill-paragraph-function' handling multi-line strings and possibly comments. +If any of the current line is in or at the end of a multi-line string, +fill the string or the paragraph of it that point is in, preserving +the strings's indentation." (interactive "P") (or (fill-comment-paragraph justify) - ;; The `paragraph-start' and `paragraph-separate' variables - ;; don't allow us to delimit the last paragraph in a multi-line - ;; string properly, so narrow to the string and then fill around - ;; (the end of) the current line. (save-excursion (end-of-line) (let* ((syntax (syntax-ppss)) (orig (point)) - (start (nth 8 syntax)) - end) - (cond ((eq t (nth 3 syntax)) ; in fenced string - (goto-char (nth 8 syntax)) ; string start + start end) + (cond ((nth 4 syntax) ; comment. fixme: loses with trailing one + (let (fill-paragraph-function) + (fill-paragraph justify))) + ;; The `paragraph-start' and `paragraph-separate' + ;; variables don't allow us to delimit the last + ;; paragraph in a multi-line string properly, so narrow + ;; to the string and then fill around (the end of) the + ;; current line. + ((eq t (nth 3 syntax)) ; in fenced string + (goto-char (nth 8 syntax)) ; string start + (setq start (line-beginning-position)) (setq end (condition-case () ; for unbalanced quotes - (progn (forward-sexp) (point)) + (progn (forward-sexp) + (- (point) 3)) (error (point-max))))) - ((re-search-backward "\\s|\\s-*\\=" nil t) ; end of fenced - ; string + ((re-search-backward "\\s|\\s-*\\=" nil t) ; end of fenced string (forward-char) (setq end (point)) (condition-case () (progn (backward-sexp) - (setq start (point))) - (error (setq end nil))))) + (setq start (line-beginning-position))) + (error nil)))) (when end (save-restriction (narrow-to-region start end) (goto-char orig) - (let ((paragraph-separate - ;; Make sure that fenced-string delimiters that stand - ;; on their own line stay there. - (concat "[ \t]*['\"]+[ \t]*$\\|" paragraph-separate))) - (fill-paragraph justify)))))) - t)) + ;; Avoid losing leading and trailing newlines in doc + ;; strings written like: + ;; """ + ;; ... + ;; """ + (let* ((paragraph-separate + (concat ".*\\s|\"\"$" ; newline after opening quotes + "\\|\\(?:" paragraph-separate "\\)")) + (paragraph-start + (concat ".*\\s|\"\"[ \t]*[^ \t].*" ; not newline after + ; opening quotes + "\\|\\(?:" paragraph-separate "\\)")) + (fill-paragraph-function)) + (fill-paragraph justify))))))) t) (defun python-shift-left (start end &optional count) "Shift lines in region COUNT (the prefix arg) columns to the left. @@ -1886,9 +1904,12 @@ Uses `python-beginning-of-block', `python-end-of-block'." (goto-char (point-min)) (while (re-search-forward "^import\\>\\|^from\\>" nil t) (unless (syntax-ppss-context (syntax-ppss)) - (push (buffer-substring (line-beginning-position) - (line-beginning-position 2)) - lines))) + (let ((start (line-beginning-position))) + ;; Skip over continued lines. + (while (and (eq ?\\ (char-before (line-end-position))) + (= 0 (forward-line 1)))) + (push (buffer-substring start (line-beginning-position 2)) + lines)))) (setq python-imports (if lines (apply #'concat @@ -2280,7 +2301,7 @@ with skeleton expansions for compound statement templates. ;; since it isn't (can't be) indentation-based. Also hide-level ;; doesn't seem to work properly. (add-to-list 'hs-special-modes-alist - `(python-mode "^\\s-*def\\>" nil "#" + `(python-mode "^\\s-*\\(?:def\\|class\\)\\>" nil "#" ,(lambda (arg) (python-end-of-defun) (skip-chars-backward " \t\n")) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index f9b7e18d467..e9d9247d7cb 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1029,7 +1029,7 @@ subshells can nest." (t (error "Internal error in sh-font-lock-quoted-subshell"))) (forward-char 1))) t)) - + (defun sh-is-quoted-p (pos) (and (eq (char-before pos) ?\\) @@ -1192,7 +1192,7 @@ This value is used for the `+' and `-' symbols in an indentation variable." nil means leave it as it is; t means indent it as a normal line, aligning it to previous non-blank non-comment line; -a number means align to that column, e.g. 0 means fist column." +a number means align to that column, e.g. 0 means first column." :type '(choice (const :tag "Leave as is." nil) (const :tag "Indent as a normal line." t) @@ -1906,14 +1906,14 @@ variable `sh-make-vars-local' has been set to nil. To revert all these variables to the global values, use command `sh-reset-indent-vars-to-global-values'." (interactive) - (mapcar 'make-local-variable sh-var-list) + (mapc 'make-local-variable sh-var-list) (message "Indentation variables are now local.")) (defun sh-reset-indent-vars-to-global-values () "Reset local indentation variables to the global values. Then, if variable `sh-make-vars-local' is non-nil, make them local." (interactive) - (mapcar 'kill-local-variable sh-var-list) + (mapc 'kill-local-variable sh-var-list) (if sh-make-vars-local (mapcar 'make-local-variable sh-var-list))) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 1187129bb33..a03b58b466c 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -863,7 +863,7 @@ Based on `comint-mode-map'.") (unless sql-mode-abbrev-table (define-abbrev-table 'sql-mode-abbrev-table nil)) -(mapcar +(mapc ;; In Emacs 22+, provide SYSTEM-FLAG to define-abbrev. '(lambda (abbrev) (let ((name (car abbrev)) diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 0d909a4a3ff..60d30eb8a6d 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -2811,7 +2811,7 @@ STRING are replaced by `-' and substrings are converted to lower case." ;; set up electric character functions to work with ;; `delete-selection-mode' (Emacs) and `pending-delete-mode' (XEmacs) -(mapcar +(mapc (function (lambda (sym) (put sym 'delete-selection t) ; for `delete-selection-mode' (Emacs) @@ -5296,7 +5296,7 @@ argument. The styles are chosen from the `vhdl-style-alist' variable." (or vars (error "ERROR: Invalid VHDL indentation style `%s'" style)) ;; set all the variables - (mapcar + (mapc (function (lambda (varentry) (let ((var (car varentry)) @@ -7148,7 +7148,7 @@ ENDPOS is encountered." (actual (vhdl-get-syntactic-context)) (expurgated)) ;; remove the library unit symbols - (mapcar + (mapc (function (lambda (elt) (if (memq (car elt) '(entity configuration package diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el index 5307445dc04..577ad024a2b 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -77,7 +77,8 @@ (defcustom which-func-modes '(emacs-lisp-mode c-mode c++-mode perl-mode cperl-mode python-mode - makefile-mode sh-mode fortran-mode f90-mode ada-mode) + makefile-mode sh-mode fortran-mode f90-mode ada-mode + diff-mode) "List of major modes for which Which Function mode should be used. For other modes it is disabled. If this is equal to t, then Which Function mode is enabled in any major mode that supports it." diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el index a820ca4cede..f437bb7da37 100644 --- a/lisp/progmodes/xscheme.el +++ b/lisp/progmodes/xscheme.el @@ -101,17 +101,17 @@ from being inserted into the process-buffer.") (setq-default scheme-mode-line-process '("" xscheme-runlight)) -(mapcar 'make-variable-buffer-local - '(xscheme-expressions-ring - xscheme-expressions-ring-yank-pointer - xscheme-process-filter-state - xscheme-running-p - xscheme-control-g-disabled-p - xscheme-allow-output-p - xscheme-prompt - xscheme-string-accumulator - xscheme-mode-string - scheme-mode-line-process)) +(mapc 'make-variable-buffer-local + '(xscheme-expressions-ring + xscheme-expressions-ring-yank-pointer + xscheme-process-filter-state + xscheme-running-p + xscheme-control-g-disabled-p + xscheme-allow-output-p + xscheme-prompt + xscheme-string-accumulator + xscheme-mode-string + scheme-mode-line-process)) (defgroup xscheme nil "Major mode for editing Scheme and interacting with MIT's C-Scheme." diff --git a/lisp/term/AT386.el b/lisp/term/AT386.el index 8adb94c07ca..23dfd8e2b11 100644 --- a/lisp/term/AT386.el +++ b/lisp/term/AT386.el @@ -29,34 +29,34 @@ ;;; Code: -(if (boundp 'AT386-keypad-map) - nil - ;; The terminal initialization should already have set up some keys - (setq AT386-keypad-map (lookup-key function-key-map "\e[")) - (if (not (keymapp AT386-keypad-map)) - (error "What? Your AT386 termcap/terminfo has no keycaps in it")) - - ;; Equivalents of these are set up automatically by termcap/terminfo - ;; (define-key AT386-keypad-map "A" [up]) - ;; (define-key AT386-keypad-map "B" [down]) - ;; (define-key AT386-keypad-map "C" [right]) - ;; (define-key AT386-keypad-map "D" [left]) - - ;; These would be set up by terminfo, but not termcap - (define-key AT386-keypad-map "H" [home]) - (define-key AT386-keypad-map "Y" [end]) - (define-key AT386-keypad-map "U" [next]) ;; PgDn - (define-key AT386-keypad-map "V" [prior]) ;; PgUp - (define-key AT386-keypad-map "@" [insert]) ;; Ins key - - ;; These are not normally set up by either - (define-key AT386-keypad-map "G" [kp-5]) ;; Unlabeled center key - (define-key AT386-keypad-map "S" [kp-subtract]) - (define-key AT386-keypad-map "T" [kp-add]) - - ;; Arrange for the ALT key to be equivalent to ESC - (define-key function-key-map "\eN" [27]) ; ALT map - ) +(defun terminal-init-AT386 () + "Terminal initialization function for AT386." + (let ((AT386-keypad-map (lookup-key local-function-key-map "\e["))) + ;; The terminal initialization should already have set up some keys + (if (not (keymapp AT386-keypad-map)) + (error "What? Your AT386 termcap/terminfo has no keycaps in it")) + + ;; Equivalents of these are set up automatically by termcap/terminfo + ;; (define-key AT386-keypad-map "A" [up]) + ;; (define-key AT386-keypad-map "B" [down]) + ;; (define-key AT386-keypad-map "C" [right]) + ;; (define-key AT386-keypad-map "D" [left]) + + ;; These would be set up by terminfo, but not termcap + (define-key AT386-keypad-map "H" [home]) + (define-key AT386-keypad-map "Y" [end]) + (define-key AT386-keypad-map "U" [next]) ;; PgDn + (define-key AT386-keypad-map "V" [prior]) ;; PgUp + (define-key AT386-keypad-map "@" [insert]) ;; Ins key + + ;; These are not normally set up by either + (define-key AT386-keypad-map "G" [kp-5]) ;; Unlabeled center key + (define-key AT386-keypad-map "S" [kp-subtract]) + (define-key AT386-keypad-map "T" [kp-add]) + + ;; Arrange for the ALT key to be equivalent to ESC + (define-key local-function-key-map "\eN" [27]) ; ALT map + )) ;;; arch-tag: abec1b03-582f-49f8-b8cb-e2fd52ea4bd7 ;;; AT386.el ends here diff --git a/lisp/term/README b/lisp/term/README index e1cfbf15901..e5fb2da83ad 100644 --- a/lisp/term/README +++ b/lisp/term/README @@ -6,19 +6,43 @@ See the end of the file for license conditions. This directory contains files of elisp that customize Emacs for certain terminal types. - When Emacs starts, it checks the TERM environment variable to see what type -of terminal the user is running on, checks for an elisp file named -"term/${TERM}.el", and if one exists, loads it. If that doesn't yield a file -that exists, the last hyphen and what follows it is stripped. If that doesn't -yield a file that exists, the previous hyphen is stripped, and so on until all -hyphens are gone. For example, if the terminal type is `aaa-48-foo', Emacs -will try first `term/aaa-48-foo.el', then `term/aaa-48.el' and finally -`term/aaa.el'. Each terminal specific file should contain a function -named terminal-init-TERMINALNAME (eg terminal-init-aaa-48 for -term/aaa-48.el) that Emacs will call in order to initialize the -terminal. The terminal files should not contain any top level forms -that are executed when the file is loaded, all the initialization -actions are performed by the terminal-init-TERMINALNAME functions. + When Emacs opens a new terminal, it checks the TERM environment variable to +see what type of terminal the user is running on, searches for an elisp file +named "term/${TERM}.el", and if one exists, loads it. If Emacs finds no +suitable file, then it strips the last hyphen and what follows it from TERM, +and tries again. If that still doesn't yield a file, then the previous hyphen +is stripped, and so on until all hyphens are gone. For example, if the +terminal type is `aaa-48-foo', Emacs will try first `term/aaa-48-foo.el', then +`term/aaa-48.el' and finally `term/aaa.el'. Emacs stops searching at the +first file found, and will not load more than one file for any terminal. Note +that it is not an error if Emacs is unable to find a terminal initialization +file; in that case, it will simply proceed with the next step without loading +any files. + + Once the file has been loaded (or the search failed), Emacs tries to call a +function named `terminal-init-TERMINALNAME' (eg `terminal-init-aaa-48' for the +`aaa-48' terminal) in order to initialize the terminal. Once again, if the +function is not found, Emacs strips the last component of the name and tries +again using the shorter name. This search is independent of the previous file +search, so that you can have terminal initialization functions for a family of +terminals collected in a single file named after the family name, and users +may put terminal initialization functions directly in their .emacs files. + + Note that an individual terminal file is loaded only once in an Emacs +session; if the same terminal type is opened again, Emacs will simply call the +initialization function without reloading the file. Therefore, all the actual +initialization actions should be collected in terminal-init-* functions; the +file should not contain any top-level form that is not a function or variable +declaration. Simply loading the file should not have any side effect. + + Similarly, the terminal initialization function is called only once on any +given terminal, when the first frame is created on it. The function is not +called for subsequent frames on the same terminal. Therefore, terminal-init-* +functions should only modify terminal-local variables (such as +`local-function-key-map') and terminal parameters. For example, it is not +correct to modify frame parameters, since the modifications will only be +applied for the first frame opened on the terminal. + When writing terminal packages, there are some things it is good to keep in mind. diff --git a/lisp/term/apollo.el b/lisp/term/apollo.el index 749ff85a0a6..c47de919b0c 100644 --- a/lisp/term/apollo.el +++ b/lisp/term/apollo.el @@ -1,7 +1,7 @@ ;; -*- no-byte-compile: t -*- (defun terminal-init-apollo () - "Terminal initialization function for apollo." - (load "term/vt100" nil t)) + "Terminal initialization function for apollo." + (tty-run-terminal-initialization (selected-frame) "vt100")) ;;; arch-tag: c72f446f-e6b7-4749-90a4-bd68632adacf ;;; apollo.el ends here diff --git a/lisp/term/bobcat.el b/lisp/term/bobcat.el index 82401f7bf71..974476f6798 100644 --- a/lisp/term/bobcat.el +++ b/lisp/term/bobcat.el @@ -1,7 +1,7 @@ ;; -*- no-byte-compile: t -*- (defun terminal-init-bobcat () - "Terminal initialization function for bobcat." + "Terminal initialization function for bobcat." ;; HP terminals usually encourage using ^H as the rubout character (keyboard-translate ?\177 ?\^h) (keyboard-translate ?\^h ?\177)) diff --git a/lisp/term/cygwin.el b/lisp/term/cygwin.el index 3bdd5d3aa05..df857ba6625 100644 --- a/lisp/term/cygwin.el +++ b/lisp/term/cygwin.el @@ -3,7 +3,7 @@ ;;; The Cygwin terminal can't really display underlines. (defun terminal-init-cygwin () - "Terminal initialization function for cygwin." + "Terminal initialization function for cygwin." (tty-no-underline)) ;; arch-tag: ca81ce67-3c41-4883-a29b-4c3d64a21191 diff --git a/lisp/term/internal.el b/lisp/term/internal.el index 2db2cd93d4d..fb13f48d6ba 100644 --- a/lisp/term/internal.el +++ b/lisp/term/internal.el @@ -29,20 +29,20 @@ ;; --------------------------------------------------------------------------- ;; keyboard setup -- that's simple! (set-input-mode nil nil 0) -(define-key function-key-map [backspace] "\177") ; Normal behaviour for BS -(define-key function-key-map [delete] "\C-d") ; ... and Delete -(define-key function-key-map [tab] [?\t]) -(define-key function-key-map [linefeed] [?\n]) -(define-key function-key-map [clear] [11]) -(define-key function-key-map [return] [13]) -(define-key function-key-map [escape] [?\e]) -(define-key function-key-map [M-backspace] [?\M-\d]) -(define-key function-key-map [M-delete] [?\M-d]) -(define-key function-key-map [M-tab] [?\M-\t]) -(define-key function-key-map [M-linefeed] [?\M-\n]) -(define-key function-key-map [M-clear] [?\M-\013]) -(define-key function-key-map [M-return] [?\M-\015]) -(define-key function-key-map [M-escape] [?\M-\e]) +(define-key local-function-key-map [backspace] "\177") ; Normal behaviour for BS +(define-key local-function-key-map [delete] "\C-d") ; ... and Delete +(define-key local-function-key-map [tab] [?\t]) +(define-key local-function-key-map [linefeed] [?\n]) +(define-key local-function-key-map [clear] [11]) +(define-key local-function-key-map [return] [13]) +(define-key local-function-key-map [escape] [?\e]) +(define-key local-function-key-map [M-backspace] [?\M-\d]) +(define-key local-function-key-map [M-delete] [?\M-d]) +(define-key local-function-key-map [M-tab] [?\M-\t]) +(define-key local-function-key-map [M-linefeed] [?\M-\n]) +(define-key local-function-key-map [M-clear] [?\M-\013]) +(define-key local-function-key-map [M-return] [?\M-\015]) +(define-key local-function-key-map [M-escape] [?\M-\e])) (put 'backspace 'ascii-character 127) (put 'delete 'ascii-character 127) (put 'tab 'ascii-character ?\t) diff --git a/lisp/term/iris-ansi.el b/lisp/term/iris-ansi.el index 2f193007051..a941a0399f3 100644 --- a/lisp/term/iris-ansi.el +++ b/lisp/term/iris-ansi.el @@ -26,306 +26,314 @@ ;;; Code: -(defun iris-ansi-initialize-terminal () - "Terminal initialization function for iris-ansi." - (define-key function-key-map "\e[120q" [S-escape]) - (define-key function-key-map "\e[121q" [C-escape]) +(defvar iris-function-map (make-sparse-keymap) + "Function key definitions for SGI xwsh and winterm apps.") + +(define-key iris-function-map "\e[120q" [S-escape]) +(define-key iris-function-map "\e[121q" [C-escape]) - (define-key function-key-map "\e[001q" [f1]) - (define-key function-key-map "\e[013q" [S-f1]) - (define-key function-key-map "\e[025q" [C-f1]) +(define-key iris-function-map "\e[001q" [f1]) +(define-key iris-function-map "\e[013q" [S-f1]) +(define-key iris-function-map "\e[025q" [C-f1]) - (define-key function-key-map "\e[002q" [f2]) - (define-key function-key-map "\e[014q" [S-f2]) - (define-key function-key-map "\e[026q" [C-f2]) - (define-key function-key-map "\e[038q" [M-f2]) +(define-key iris-function-map "\e[002q" [f2]) +(define-key iris-function-map "\e[014q" [S-f2]) +(define-key iris-function-map "\e[026q" [C-f2]) +(define-key iris-function-map "\e[038q" [M-f2]) - (define-key function-key-map "\e[003q" [f3]) - (define-key function-key-map "\e[015q" [S-f3]) - (define-key function-key-map "\e[027q" [C-f3]) +(define-key iris-function-map "\e[003q" [f3]) +(define-key iris-function-map "\e[015q" [S-f3]) +(define-key iris-function-map "\e[027q" [C-f3]) - (define-key function-key-map "\e[004q" [f4]) - (define-key function-key-map "\e[016q" [S-f4]) - (define-key function-key-map "\e[028q" [C-f4]) +(define-key iris-function-map "\e[004q" [f4]) +(define-key iris-function-map "\e[016q" [S-f4]) +(define-key iris-function-map "\e[028q" [C-f4]) - (define-key function-key-map "\e[005q" [f5]) - (define-key function-key-map "\e[017q" [S-f5]) - (define-key function-key-map "\e[029q" [C-f5]) +(define-key iris-function-map "\e[005q" [f5]) +(define-key iris-function-map "\e[017q" [S-f5]) +(define-key iris-function-map "\e[029q" [C-f5]) - (define-key function-key-map "\e[006q" [f6]) - (define-key function-key-map "\e[018q" [S-f6]) - (define-key function-key-map "\e[030q" [C-f6]) +(define-key iris-function-map "\e[006q" [f6]) +(define-key iris-function-map "\e[018q" [S-f6]) +(define-key iris-function-map "\e[030q" [C-f6]) - (define-key function-key-map "\e[007q" [f7]) - (define-key function-key-map "\e[019q" [S-f7]) - (define-key function-key-map "\e[031q" [C-f7]) +(define-key iris-function-map "\e[007q" [f7]) +(define-key iris-function-map "\e[019q" [S-f7]) +(define-key iris-function-map "\e[031q" [C-f7]) - (define-key function-key-map "\e[008q" [f8]) - (define-key function-key-map "\e[020q" [S-f8]) - (define-key function-key-map "\e[032q" [C-f8]) +(define-key iris-function-map "\e[008q" [f8]) +(define-key iris-function-map "\e[020q" [S-f8]) +(define-key iris-function-map "\e[032q" [C-f8]) - (define-key function-key-map "\e[009q" [f9]) - (define-key function-key-map "\e[021q" [S-f9]) - (define-key function-key-map "\e[033q" [C-f9]) +(define-key iris-function-map "\e[009q" [f9]) +(define-key iris-function-map "\e[021q" [S-f9]) +(define-key iris-function-map "\e[033q" [C-f9]) - (define-key function-key-map "\e[010q" [f10]) - (define-key function-key-map "\e[022q" [S-f10]) - (define-key function-key-map "\e[034q" [C-f10]) +(define-key iris-function-map "\e[010q" [f10]) +(define-key iris-function-map "\e[022q" [S-f10]) +(define-key iris-function-map "\e[034q" [C-f10]) - (define-key function-key-map "\e[011q" [f11]) - (define-key function-key-map "\e[023q" [S-f11]) - (define-key function-key-map "\e[035q" [C-f11]) - (define-key function-key-map "\e[047q" [M-f11]) +(define-key iris-function-map "\e[011q" [f11]) +(define-key iris-function-map "\e[023q" [S-f11]) +(define-key iris-function-map "\e[035q" [C-f11]) +(define-key iris-function-map "\e[047q" [M-f11]) - (define-key function-key-map "\e[012q" [f12]) - (define-key function-key-map "\e[024q" [S-f12]) - (define-key function-key-map "\e[036q" [C-f12]) - (define-key function-key-map "\e[048q" [M-f12]) +(define-key iris-function-map "\e[012q" [f12]) +(define-key iris-function-map "\e[024q" [S-f12]) +(define-key iris-function-map "\e[036q" [C-f12]) +(define-key iris-function-map "\e[048q" [M-f12]) - (define-key function-key-map "\e[057q" [?\C-`]) - (define-key function-key-map "\e[115q" [?\M-`]) +(define-key iris-function-map "\e[057q" [?\C-`]) +(define-key iris-function-map "\e[115q" [?\M-`]) - (define-key function-key-map "\e[049q" [?\C-1]) - (define-key function-key-map "\e[058q" [?\M-1]) +(define-key iris-function-map "\e[049q" [?\C-1]) +(define-key iris-function-map "\e[058q" [?\M-1]) - (define-key function-key-map "\e[059q" [?\M-2]) +(define-key iris-function-map "\e[059q" [?\M-2]) - (define-key function-key-map "\e[050q" [?\C-3]) - (define-key function-key-map "\e[060q" [?\M-3]) +(define-key iris-function-map "\e[050q" [?\C-3]) +(define-key iris-function-map "\e[060q" [?\M-3]) - (define-key function-key-map "\e[051q" [?\C-4]) - (define-key function-key-map "\e[061q" [?\M-4]) +(define-key iris-function-map "\e[051q" [?\C-4]) +(define-key iris-function-map "\e[061q" [?\M-4]) - (define-key function-key-map "\e[052q" [?\C-5]) - (define-key function-key-map "\e[062q" [?\M-5]) +(define-key iris-function-map "\e[052q" [?\C-5]) +(define-key iris-function-map "\e[062q" [?\M-5]) - (define-key function-key-map "\e[063q" [?\M-6]) +(define-key iris-function-map "\e[063q" [?\M-6]) - (define-key function-key-map "\e[053q" [?\C-7]) - (define-key function-key-map "\e[064q" [?\M-7]) +(define-key iris-function-map "\e[053q" [?\C-7]) +(define-key iris-function-map "\e[064q" [?\M-7]) - (define-key function-key-map "\e[054q" [?\C-8]) - (define-key function-key-map "\e[065q" [?\M-8]) +(define-key iris-function-map "\e[054q" [?\C-8]) +(define-key iris-function-map "\e[065q" [?\M-8]) - (define-key function-key-map "\e[055q" [?\C-9]) - (define-key function-key-map "\e[066q" [?\M-9]) +(define-key iris-function-map "\e[055q" [?\C-9]) +(define-key iris-function-map "\e[066q" [?\M-9]) - (define-key function-key-map "\e[056q" [?\C-0]) - (define-key function-key-map "\e[067q" [?\M-0]) +(define-key iris-function-map "\e[056q" [?\C-0]) +(define-key iris-function-map "\e[067q" [?\M-0]) - (define-key function-key-map "\e[068q" [?\M--]) +(define-key iris-function-map "\e[068q" [?\M--]) - (define-key function-key-map "\e[069q" [?\C-=]) - (define-key function-key-map "\e[070q" [?\M-=]) +(define-key iris-function-map "\e[069q" [?\C-=]) +(define-key iris-function-map "\e[070q" [?\M-=]) - ;; I don't know what to do with those. - ;;(define-key function-key-map "^H" [<del>]) - ;;(define-key function-key-map "^H" [S-<del>]) - ;;(define-key function-key-map "\177" [C-<del>]) - ;;(define-key function-key-map "\e[071q" [M-<del>]) +;; I don't know what to do with those. +;;(define-key iris-function-map "^H" [<del>]) +;;(define-key iris-function-map "^H" [S-<del>]) +;;(define-key iris-function-map "\177" [C-<del>]) +;;(define-key iris-function-map "\e[071q" [M-<del>]) - (define-key function-key-map "\e[Z" [?\S-\t]) - (define-key function-key-map "\e[072q" [?\C-\t]) - ;; This only works if you remove the M-TAB keybing from the system.4Dwmrc - ;; our your ~/.4Dwmrc, if you use the 4Dwm window manager. - (define-key function-key-map "\e[073q" [?\M-\t]) +(define-key iris-function-map "\e[Z" [?\S-\t]) +(define-key iris-function-map "\e[072q" [?\C-\t]) +;; This only works if you remove the M-TAB keybing from the system.4Dwmrc +;; our your ~/.4Dwmrc, if you use the 4Dwm window manager. +(define-key iris-function-map "\e[073q" [?\M-\t]) - (define-key function-key-map "\e[074q" [?\M-q]) +(define-key iris-function-map "\e[074q" [?\M-q]) - (define-key function-key-map "\e[075q" [?\M-w]) +(define-key iris-function-map "\e[075q" [?\M-w]) - (define-key function-key-map "\e[076q" [?\M-e]) +(define-key iris-function-map "\e[076q" [?\M-e]) - (define-key function-key-map "\e[077q" [?\M-r]) +(define-key iris-function-map "\e[077q" [?\M-r]) - (define-key function-key-map "\e[078q" [?\M-t]) +(define-key iris-function-map "\e[078q" [?\M-t]) - (define-key function-key-map "\e[079q" [?\M-y]) +(define-key iris-function-map "\e[079q" [?\M-y]) - (define-key function-key-map "\e[080q" [?\M-u]) +(define-key iris-function-map "\e[080q" [?\M-u]) - (define-key function-key-map "\e[081q" [?\M-i]) +(define-key iris-function-map "\e[081q" [?\M-i]) - (define-key function-key-map "\e[082q" [?\M-o]) +(define-key iris-function-map "\e[082q" [?\M-o]) - (define-key function-key-map "\e[083q" [?\M-p]) +(define-key iris-function-map "\e[083q" [?\M-p]) - (define-key function-key-map "\e[084q" [?\M-\[]) +(define-key iris-function-map "\e[084q" [?\M-\[]) - (define-key function-key-map "\e[085q" [?\M-\]]) +(define-key iris-function-map "\e[085q" [?\M-\]]) - (define-key function-key-map "\e[086q" [?\M-\\]) +(define-key iris-function-map "\e[086q" [?\M-\\]) - (define-key function-key-map "\e[087q" [?\M-a]) +(define-key iris-function-map "\e[087q" [?\M-a]) - (define-key function-key-map "\e[088q" [?\M-s]) +(define-key iris-function-map "\e[088q" [?\M-s]) - (define-key function-key-map "\e[089q" [?\M-d]) +(define-key iris-function-map "\e[089q" [?\M-d]) - (define-key function-key-map "\e[090q" [?\M-f]) +(define-key iris-function-map "\e[090q" [?\M-f]) - (define-key function-key-map "\e[091q" [?\M-g]) +(define-key iris-function-map "\e[091q" [?\M-g]) - (define-key function-key-map "\e[092q" [?\M-h]) +(define-key iris-function-map "\e[092q" [?\M-h]) - (define-key function-key-map "\e[093q" [?\M-j]) +(define-key iris-function-map "\e[093q" [?\M-j]) - (define-key function-key-map "\e[094q" [?\M-k]) +(define-key iris-function-map "\e[094q" [?\M-k]) - (define-key function-key-map "\e[095q" [?\M-l]) +(define-key iris-function-map "\e[095q" [?\M-l]) - (define-key function-key-map "\e[096q" [?\C-\;]) - (define-key function-key-map "\e[097q" [?\M-:]) ;; we are cheating - ;; here, this is - ;; realy M-;, but - ;; M-: generates the - ;; same string and - ;; is more usefull. +(define-key iris-function-map "\e[096q" [?\C-\;]) +(define-key iris-function-map "\e[097q" [?\M-:]) ;; we are cheating + ;; here, this is realy + ;; M-;, but M-: + ;; generates the same + ;; string and is more + ;; usefull. - (define-key function-key-map "\e[098q" [?\C-']) - (define-key function-key-map "\e[099q" [?\M-']) +(define-key iris-function-map "\e[098q" [?\C-']) +(define-key iris-function-map "\e[099q" [?\M-']) - (define-key function-key-map "\e[100q" [?\M-\n]) +(define-key iris-function-map "\e[100q" [?\M-\n]) - (define-key function-key-map "\e[101q" [?\M-z]) +(define-key iris-function-map "\e[101q" [?\M-z]) - (define-key function-key-map "\e[102q" [?\M-x]) +(define-key iris-function-map "\e[102q" [?\M-x]) - (define-key function-key-map "\e[103q" [?\M-c]) +(define-key iris-function-map "\e[103q" [?\M-c]) - (define-key function-key-map "\e[104q" [?\M-v]) +(define-key iris-function-map "\e[104q" [?\M-v]) - (define-key function-key-map "\e[105q" [?\M-b]) +(define-key iris-function-map "\e[105q" [?\M-b]) - (define-key function-key-map "\e[106q" [M-n]) +(define-key iris-function-map "\e[106q" [M-n]) - (define-key function-key-map "\e[107q" [M-m]) +(define-key iris-function-map "\e[107q" [M-m]) - (define-key function-key-map "\e[108q" [?\C-,]) - (define-key function-key-map "\e[109q" [?\M-,]) +(define-key iris-function-map "\e[108q" [?\C-,]) +(define-key iris-function-map "\e[109q" [?\M-,]) - (define-key function-key-map "\e[110q" [?\C-.]) - (define-key function-key-map "\e[111q" [?\M-.]) +(define-key iris-function-map "\e[110q" [?\C-.]) +(define-key iris-function-map "\e[111q" [?\M-.]) - (define-key function-key-map "\e[112q" [?\C-/]) - (define-key function-key-map "\e[113q" [?\M-/]) +(define-key iris-function-map "\e[112q" [?\C-/]) +(define-key iris-function-map "\e[113q" [?\M-/]) - (define-key function-key-map "\e[139q" [insert]) - (define-key function-key-map "\e[139q" [S-insert]) - (define-key function-key-map "\e[140q" [C-insert]) - (define-key function-key-map "\e[141q" [M-insert]) +(define-key iris-function-map "\e[139q" [insert]) +(define-key iris-function-map "\e[139q" [S-insert]) +(define-key iris-function-map "\e[140q" [C-insert]) +(define-key iris-function-map "\e[141q" [M-insert]) - (define-key function-key-map "\e[H" [home]) - (define-key function-key-map "\e[143q" [S-home]) - (define-key function-key-map "\e[144q" [C-home]) +(define-key iris-function-map "\e[H" [home]) +(define-key iris-function-map "\e[143q" [S-home]) +(define-key iris-function-map "\e[144q" [C-home]) - (define-key function-key-map "\e[150q" [prior]) - (define-key function-key-map "\e[151q" [S-prior]) ;; those don't - ;; seem to - ;; generate +(define-key iris-function-map "\e[150q" [prior]) +(define-key iris-function-map "\e[151q" [S-prior]) ;; those don't seem + ;; to generate ;; anything - (define-key function-key-map "\e[152q" [C-prior]) +(define-key iris-function-map "\e[152q" [C-prior]) - ;; (define-key function-key-map "^?" [delete]) - (define-key function-key-map "\e[P" [S-delete]) - (define-key function-key-map "\e[142q" [C-delete]) - (define-key function-key-map "\e[M" [M-delete]) +;; (define-key iris-function-map "^?" [delete]) ?? something else seems to take care of this. +(define-key iris-function-map "\e[P" [S-delete]) +(define-key iris-function-map "\e[142q" [C-delete]) +(define-key iris-function-map "\e[M" [M-delete]) - (define-key function-key-map "\e[146q" [end]) - (define-key function-key-map "\e[147q" [S-end]) ;; those don't seem - ;; to generate - ;; anything - (define-key function-key-map "\e[148q" [C-end]) +(define-key iris-function-map "\e[146q" [end]) +(define-key iris-function-map "\e[147q" [S-end]) ;; those don't seem to + ;; generate anything +(define-key iris-function-map "\e[148q" [C-end]) - (define-key function-key-map "\e[154q" [next]) - (define-key function-key-map "\e[155q" [S-next]) - (define-key function-key-map "\e[156q" [C-next]) +(define-key iris-function-map "\e[154q" [next]) +(define-key iris-function-map "\e[155q" [S-next]) +(define-key iris-function-map "\e[156q" [C-next]) - (define-key function-key-map "\e[161q" [S-up]) - (define-key function-key-map "\e[162q" [C-up]) - (define-key function-key-map "\e[163q" [M-up]) +(define-key iris-function-map "\e[161q" [S-up]) +(define-key iris-function-map "\e[162q" [C-up]) +(define-key iris-function-map "\e[163q" [M-up]) - (define-key function-key-map "\e[158q" [S-left]) - (define-key function-key-map "\e[159q" [C-left]) - (define-key function-key-map "\e[160q" [M-left]) +(define-key iris-function-map "\e[158q" [S-left]) +(define-key iris-function-map "\e[159q" [C-left]) +(define-key iris-function-map "\e[160q" [M-left]) - (define-key function-key-map "\e[164q" [S-down]) - (define-key function-key-map "\e[165q" [C-down]) - (define-key function-key-map "\e[166q" [M-down]) +(define-key iris-function-map "\e[164q" [S-down]) +(define-key iris-function-map "\e[165q" [C-down]) +(define-key iris-function-map "\e[166q" [M-down]) - (define-key function-key-map "\e[167q" [S-right]) - (define-key function-key-map "\e[168q" [C-right]) - (define-key function-key-map "\e[169q" [M-right]) +(define-key iris-function-map "\e[167q" [S-right]) +(define-key iris-function-map "\e[168q" [C-right]) +(define-key iris-function-map "\e[169q" [M-right]) - ;; Keypad functions, most of those are untested. - (define-key function-key-map "\e[179q" [?\C-/]) - (define-key function-key-map "\e[180q" [?\M-/]) +;; Keypad functions, most of those are untested. +(define-key iris-function-map "\e[179q" [?\C-/]) +(define-key iris-function-map "\e[180q" [?\M-/]) - (define-key function-key-map "\e[187q" [?\C-*]) - (define-key function-key-map "\e[188q" [?\M-*]) +(define-key iris-function-map "\e[187q" [?\C-*]) +(define-key iris-function-map "\e[188q" [?\M-*]) - (define-key function-key-map "\e[198q" [?\C--]) - (define-key function-key-map "\e[199q" [?\M--]) +(define-key iris-function-map "\e[198q" [?\C--]) +(define-key iris-function-map "\e[199q" [?\M--]) - ;; Something else takes care of home, up, prior, down, left, right, next - ;;(define-key function-key-map "\e[H" [home]) - (define-key function-key-map "\e[172q" [C-home]) +;; Something else takes care of home, up, prior, down, left, right, next +;(define-key iris-function-map "\e[H" [home]) +(define-key iris-function-map "\e[172q" [C-home]) - ;;(define-key function-key-map "\e[A" [up]) - (define-key function-key-map "\e[182q" [C-up]) +;(define-key iris-function-map "\e[A" [up]) +(define-key iris-function-map "\e[182q" [C-up]) - ;;(define-key function-key-map "\e[150q" [prior]) - (define-key function-key-map "\e[190q" [C-prior]) +;(define-key iris-function-map "\e[150q" [prior]) +(define-key iris-function-map "\e[190q" [C-prior]) - (define-key function-key-map "\e[200q" [?\C-+]) - (define-key function-key-map "\e[201q" [?\M-+]) +(define-key iris-function-map "\e[200q" [?\C-+]) +(define-key iris-function-map "\e[201q" [?\M-+]) - ;;(define-key function-key-map "\e[D" [left]) - (define-key function-key-map "\e[174q" [C-left]) +;(define-key iris-function-map "\e[D" [left]) +(define-key iris-function-map "\e[174q" [C-left]) - (define-key function-key-map "\e[000q" [begin]) - (define-key function-key-map "\e[184q" [C-begin]) +(define-key iris-function-map "\e[000q" [begin]) +(define-key iris-function-map "\e[184q" [C-begin]) - ;;(define-key function-key-map "\e[C" [right]) - (define-key function-key-map "\e[192q" [C-right]) +;(define-key iris-function-map "\e[C" [right]) +(define-key iris-function-map "\e[192q" [C-right]) - ;;(define-key function-key-map "\e[146q" [end]) - (define-key function-key-map "\e[176q" [C-end]) +;(define-key iris-function-map "\e[146q" [end]) +(define-key iris-function-map "\e[176q" [C-end]) - ;;(define-key function-key-map "\e[B" [down]) - (define-key function-key-map "\e[186q" [C-down]) +;(define-key iris-function-map "\e[B" [down]) +(define-key iris-function-map "\e[186q" [C-down]) - ;;(define-key function-key-map "\e[154q" [next]) - (define-key function-key-map "\e[194q" [C-next]) +;(define-key iris-function-map "\e[154q" [next]) +(define-key iris-function-map "\e[194q" [C-next]) - (define-key function-key-map "\e[100q" [M-enter]) +(define-key iris-function-map "\e[100q" [M-enter]) - (define-key function-key-map "\e[139q" [insert]) - (define-key function-key-map "\e[178q" [C-inset]) +(define-key iris-function-map "\e[139q" [insert]) +(define-key iris-function-map "\e[178q" [C-inset]) - (define-key function-key-map "\e[P" [delete]) - (define-key function-key-map "\e[196q" [C-delete]) - (define-key function-key-map "\e[197q" [M-delete])) +(define-key iris-function-map "\e[P" [delete]) +(define-key iris-function-map "\e[196q" [C-delete]) +(define-key iris-function-map "\e[197q" [M-delete]) + +(defun terminal-init-iris-ansi () + "Terminal initialization function for iris-ansi." + ;; Use inheritance to let the main keymap override these defaults. + ;; This way we don't override terminfo-derived settings or settings + ;; made in the .emacs file. + (let ((m (copy-keymap iris-function-map))) + (set-keymap-parent m (keymap-parent local-function-key-map)) + (set-keymap-parent local-function-key-map m))) ;;; arch-tag: b1d0e73a-bb7d-47be-9fb2-6fb126469a1b ;;; iris-ansi.el ends here diff --git a/lisp/term/linux.el b/lisp/term/linux.el index 84de5966a88..fdd8e2229ac 100644 --- a/lisp/term/linux.el +++ b/lisp/term/linux.el @@ -16,9 +16,8 @@ ;; Meta will continue to work, because the kernel ;; turns that into Escape. - (let ((value (current-input-mode))) - ;; The third arg only matters in that it is not t or nil. - (set-input-mode (nth 0 value) (nth 1 value) 'iso-latin-1 (nth 3 value)))) + ;; The arg only matters in that it is not t or nil. + (set-input-meta-mode 'iso-latin-1)) ;;; arch-tag: 5d0c4f63-739b-4862-abf3-041fe42adb8f ;;; linux.el ends here diff --git a/lisp/term/lk201.el b/lisp/term/lk201.el index 1f8d9ca77a3..17ac3474ff0 100644 --- a/lisp/term/lk201.el +++ b/lisp/term/lk201.el @@ -1,72 +1,83 @@ ;; -*- no-byte-compile: t -*- ;; Define function key sequences for DEC terminals. +(defvar lk201-function-map (make-sparse-keymap) + "Function key definitions for DEC terminals.") + ;; Termcap or terminfo should set these. -;; (define-key function-key-map "\e[A" [up]) -;; (define-key function-key-map "\e[B" [down]) -;; (define-key function-key-map "\e[C" [right]) -;; (define-key function-key-map "\e[D" [left]) +;; (define-key lk201-function-map "\e[A" [up]) +;; (define-key lk201-function-map "\e[B" [down]) +;; (define-key lk201-function-map "\e[C" [right]) +;; (define-key lk201-function-map "\e[D" [left]) -(define-key function-key-map "\e[1~" [find]) -(define-key function-key-map "\e[2~" [insert]) -(define-key function-key-map "\e[3~" [delete]) -(define-key function-key-map "\e[4~" [select]) -(define-key function-key-map "\e[5~" [prior]) -(define-key function-key-map "\e[6~" [next]) -(define-key function-key-map "\e[11~" [f1]) -(define-key function-key-map "\e[12~" [f2]) -(define-key function-key-map "\e[13~" [f3]) -(define-key function-key-map "\e[14~" [f4]) -(define-key function-key-map "\e[15~" [f5]) -(define-key function-key-map "\e[17~" [f6]) -(define-key function-key-map "\e[18~" [f7]) -(define-key function-key-map "\e[19~" [f8]) -(define-key function-key-map "\e[20~" [f9]) -(define-key function-key-map "\e[21~" [f10]) +(define-key lk201-function-map "\e[1~" [find]) +(define-key lk201-function-map "\e[2~" [insert]) +(define-key lk201-function-map "\e[3~" [delete]) +(define-key lk201-function-map "\e[4~" [select]) +(define-key lk201-function-map "\e[5~" [prior]) +(define-key lk201-function-map "\e[6~" [next]) +(define-key lk201-function-map "\e[11~" [f1]) +(define-key lk201-function-map "\e[12~" [f2]) +(define-key lk201-function-map "\e[13~" [f3]) +(define-key lk201-function-map "\e[14~" [f4]) +(define-key lk201-function-map "\e[15~" [f5]) +(define-key lk201-function-map "\e[17~" [f6]) +(define-key lk201-function-map "\e[18~" [f7]) +(define-key lk201-function-map "\e[19~" [f8]) +(define-key lk201-function-map "\e[20~" [f9]) +(define-key lk201-function-map "\e[21~" [f10]) ;; Customarily F11 is used as the ESC key. ;; The file that includes this one, takes care of that. -(define-key function-key-map "\e[23~" [f11]) -(define-key function-key-map "\e[24~" [f12]) -(define-key function-key-map "\e[25~" [f13]) -(define-key function-key-map "\e[26~" [f14]) -(define-key function-key-map "\e[28~" [help]) -(define-key function-key-map "\e[29~" [menu]) -(define-key function-key-map "\e[31~" [f17]) -(define-key function-key-map "\e[32~" [f18]) -(define-key function-key-map "\e[33~" [f19]) -(define-key function-key-map "\e[34~" [f20]) +(define-key lk201-function-map "\e[23~" [f11]) +(define-key lk201-function-map "\e[24~" [f12]) +(define-key lk201-function-map "\e[25~" [f13]) +(define-key lk201-function-map "\e[26~" [f14]) +(define-key lk201-function-map "\e[28~" [help]) +(define-key lk201-function-map "\e[29~" [menu]) +(define-key lk201-function-map "\e[31~" [f17]) +(define-key lk201-function-map "\e[32~" [f18]) +(define-key lk201-function-map "\e[33~" [f19]) +(define-key lk201-function-map "\e[34~" [f20]) ;; Termcap or terminfo should set these. -;; (define-key function-key-map "\eOA" [up]) -;; (define-key function-key-map "\eOB" [down]) -;; (define-key function-key-map "\eOC" [right]) -;; (define-key function-key-map "\eOD" [left]) +;; (define-key lk201-function-map "\eOA" [up]) +;; (define-key lk201-function-map "\eOB" [down]) +;; (define-key lk201-function-map "\eOC" [right]) +;; (define-key lk201-function-map "\eOD" [left]) ;; Termcap or terminfo should set these, but doesn't properly. ;; Termcap sets these to k1-k4, which get mapped to f1-f4 in term.c -(define-key function-key-map "\eOP" [kp-f1]) -(define-key function-key-map "\eOQ" [kp-f2]) -(define-key function-key-map "\eOR" [kp-f3]) -(define-key function-key-map "\eOS" [kp-f4]) +(define-key lk201-function-map "\eOP" [kp-f1]) +(define-key lk201-function-map "\eOQ" [kp-f2]) +(define-key lk201-function-map "\eOR" [kp-f3]) +(define-key lk201-function-map "\eOS" [kp-f4]) + +(define-key lk201-function-map "\eOI" [kp-tab]) +(define-key lk201-function-map "\eOj" [kp-multiply]) +(define-key lk201-function-map "\eOk" [kp-add]) +(define-key lk201-function-map "\eOl" [kp-separator]) +(define-key lk201-function-map "\eOM" [kp-enter]) +(define-key lk201-function-map "\eOm" [kp-subtract]) +(define-key lk201-function-map "\eOn" [kp-decimal]) +(define-key lk201-function-map "\eOo" [kp-divide]) +(define-key lk201-function-map "\eOp" [kp-0]) +(define-key lk201-function-map "\eOq" [kp-1]) +(define-key lk201-function-map "\eOr" [kp-2]) +(define-key lk201-function-map "\eOs" [kp-3]) +(define-key lk201-function-map "\eOt" [kp-4]) +(define-key lk201-function-map "\eOu" [kp-5]) +(define-key lk201-function-map "\eOv" [kp-6]) +(define-key lk201-function-map "\eOw" [kp-7]) +(define-key lk201-function-map "\eOx" [kp-8]) +(define-key lk201-function-map "\eOy" [kp-9]) -(define-key function-key-map "\eOI" [kp-tab]) -(define-key function-key-map "\eOj" [kp-multiply]) -(define-key function-key-map "\eOk" [kp-add]) -(define-key function-key-map "\eOl" [kp-separator]) -(define-key function-key-map "\eOM" [kp-enter]) -(define-key function-key-map "\eOm" [kp-subtract]) -(define-key function-key-map "\eOn" [kp-decimal]) -(define-key function-key-map "\eOo" [kp-divide]) -(define-key function-key-map "\eOp" [kp-0]) -(define-key function-key-map "\eOq" [kp-1]) -(define-key function-key-map "\eOr" [kp-2]) -(define-key function-key-map "\eOs" [kp-3]) -(define-key function-key-map "\eOt" [kp-4]) -(define-key function-key-map "\eOu" [kp-5]) -(define-key function-key-map "\eOv" [kp-6]) -(define-key function-key-map "\eOw" [kp-7]) -(define-key function-key-map "\eOx" [kp-8]) -(define-key function-key-map "\eOy" [kp-9]) +(defun terminal-init-lk201 () + ;; Use inheritance to let the main keymap override these defaults. + ;; This way we don't override terminfo-derived settings or settings + ;; made in the .emacs file. + (let ((m (copy-keymap lk201-function-map))) + (set-keymap-parent m (keymap-parent local-function-key-map)) + (set-keymap-parent local-function-key-map m))) ;;; arch-tag: 7ffb4444-6a23-43e1-b457-43cf4f673c0d ;;; lk201.el ends here diff --git a/lisp/term/mac-win.el b/lisp/term/mac-win.el index a89d0fe306f..d638f97ede3 100644 --- a/lisp/term/mac-win.el +++ b/lisp/term/mac-win.el @@ -65,8 +65,8 @@ ;; An alist of X options and the function which handles them. See ;; ../startup.el. -(if (not (eq window-system 'mac)) - (error "%s: Loading mac-win.el but not compiled for Mac" (invocation-name))) +;; (if (not (eq window-system 'mac)) +;; (error "%s: Loading mac-win.el but not compiled for Mac" (invocation-name))) (require 'frame) (require 'mouse) @@ -76,7 +76,6 @@ (require 'menu-bar) (require 'fontset) (require 'dnd) -(eval-when-compile (require 'url)) (defvar mac-charset-info-alist) (defvar mac-service-selection) @@ -1062,22 +1061,25 @@ XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp") (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame global-map) +(defun x-setup-function-keys (frame) + "Setup Function Keys for mac." ;; Map certain keypad keys into ASCII characters ;; that people usually expect. -(define-key function-key-map [backspace] [?\d]) -(define-key function-key-map [delete] [?\d]) -(define-key function-key-map [tab] [?\t]) -(define-key function-key-map [linefeed] [?\n]) -(define-key function-key-map [clear] [?\C-l]) -(define-key function-key-map [return] [?\C-m]) -(define-key function-key-map [escape] [?\e]) -(define-key function-key-map [M-backspace] [?\M-\d]) -(define-key function-key-map [M-delete] [?\M-\d]) -(define-key function-key-map [M-tab] [?\M-\t]) -(define-key function-key-map [M-linefeed] [?\M-\n]) -(define-key function-key-map [M-clear] [?\M-\C-l]) -(define-key function-key-map [M-return] [?\M-\C-m]) -(define-key function-key-map [M-escape] [?\M-\e]) +(define-key local-function-key-map [backspace] [?\d]) +(define-key local-function-key-map [delete] [?\d]) +(define-key local-function-key-map [tab] [?\t]) +(define-key local-function-key-map [linefeed] [?\n]) +(define-key local-function-key-map [clear] [?\C-l]) +(define-key local-function-key-map [return] [?\C-m]) +(define-key local-function-key-map [escape] [?\e]) +(define-key local-function-key-map [M-backspace] [?\M-\d]) +(define-key local-function-key-map [M-delete] [?\M-\d]) +(define-key local-function-key-map [M-tab] [?\M-\t]) +(define-key local-function-key-map [M-linefeed] [?\M-\n]) +(define-key local-function-key-map [M-clear] [?\M-\C-l]) +(define-key local-function-key-map [M-return] [?\M-\C-m]) +(define-key local-function-key-map [M-escape] [?\M-\e]) +) ;; These tell read-char how to convert ;; these special chars to ASCII. @@ -2412,6 +2414,88 @@ It returns a name of the created fontset." (new-fontset fontset-name (list (cons 'ascii resolved-font))) (fontset-add-mac-fonts fontset-name base-family))) +(defun x-win-suspend-error () + (error "Suspending an Emacs running under Mac makes no sense")) + +(defalias 'x-cut-buffer-or-selection-value 'x-get-selection-value) + +(defvar mac-initialized nil + "Non-nil if the w32 window system has been initialized.") + +(defun mac-initialize-window-system () + "Initialize Emacs for Mac GUI frames." + +;;; Do the actual Windows setup here; the above code just defines +;;; functions and variables that we use now. + +(setq command-line-args (x-handle-args command-line-args)) + +;;; Make sure we have a valid resource name. +(or (stringp x-resource-name) + (let (i) + (setq x-resource-name (invocation-name)) + + ;; Change any . or * characters in x-resource-name to hyphens, + ;; so as not to choke when we use it in X resource queries. + (while (setq i (string-match "[.*]" x-resource-name)) + (aset x-resource-name i ?-)))) + +(if (x-display-list) + ;; On Mac OS 8/9, Most coding systems used in code conversion for + ;; font names are not ready at the time when the terminal frame is + ;; created. So we reconstruct font name table for the initial + ;; frame. + (mac-clear-font-name-table) + (x-open-connection "Mac" + x-command-line-resources + ;; Exit Emacs with fatal error if this fails. + t)) + +(add-hook 'suspend-hook 'x-win-suspend-error) + +;;; Arrange for the kill and yank functions to set and check the clipboard. +(setq interprogram-cut-function 'x-select-text) +(setq interprogram-paste-function 'x-get-selection-value) + + + + +;;; Turn off window-splitting optimization; Mac is usually fast enough +;;; that this is only annoying. +(setq split-window-keep-point t) + +;; Don't show the frame name; that's redundant. +(setq-default mode-line-frame-identification " ") + +;; Turn on support for mouse wheels. +(mouse-wheel-mode 1) + + +;; Enable CLIPBOARD copy/paste through menu bar commands. +(menu-bar-enable-clipboard) + + +;; Initiate drag and drop + +(define-key special-event-map [drag-n-drop] 'mac-dnd-handle-drag-n-drop-event) + + +;;;; Non-toolkit Scroll bars + +(unless x-toolkit-scroll-bars + +;; for debugging +;; (defun mac-handle-scroll-bar-event (event) (interactive "e") (princ event)) + +;;(global-set-key [vertical-scroll-bar mouse-1] 'mac-handle-scroll-bar-event) + +(global-set-key + [vertical-scroll-bar down-mouse-1] + 'mac-handle-scroll-bar-event) + +(global-unset-key [vertical-scroll-bar drag-mouse-1]) +(global-unset-key [vertical-scroll-bar mouse-1]) + ;; Adjust Courier font specifications in x-fixed-font-alist. (let ((courier-fonts (assoc "Courier" x-fixed-font-alist))) (if courier-fonts @@ -2477,50 +2561,7 @@ It returns a name of the created fontset." (setq default-frame-alist (cons '(reverse . t) default-frame-alist))))) -(defun x-win-suspend-error () - (error "Suspending an Emacs running under Mac makes no sense")) -(add-hook 'suspend-hook 'x-win-suspend-error) - -;;; Arrange for the kill and yank functions to set and check the clipboard. -(setq interprogram-cut-function 'x-select-text) -(setq interprogram-paste-function 'x-get-selection-value) - -(defalias 'x-cut-buffer-or-selection-value 'x-get-selection-value) - -;;; Turn off window-splitting optimization; Mac is usually fast enough -;;; that this is only annoying. -(setq split-window-keep-point t) - -;; Don't show the frame name; that's redundant. -(setq-default mode-line-frame-identification " ") - -;; Turn on support for mouse wheels. -(mouse-wheel-mode 1) - - -;; Enable CLIPBOARD copy/paste through menu bar commands. -(menu-bar-enable-clipboard) - -;; Initiate drag and drop - -(define-key special-event-map [drag-n-drop] 'mac-dnd-handle-drag-n-drop-event) - - -;;;; Non-toolkit Scroll bars - -(unless x-toolkit-scroll-bars - -;; for debugging -;; (defun mac-handle-scroll-bar-event (event) (interactive "e") (princ event)) - -;;(global-set-key [vertical-scroll-bar mouse-1] 'mac-handle-scroll-bar-event) - -(global-set-key - [vertical-scroll-bar down-mouse-1] - 'mac-handle-scroll-bar-event) - -(global-unset-key [vertical-scroll-bar drag-mouse-1]) -(global-unset-key [vertical-scroll-bar mouse-1]) +(setq mac-initialized t))) (defun mac-handle-scroll-bar-event (event) "Handle scroll bar EVENT to emulate Mac Toolbox style scrolling." @@ -2568,7 +2609,6 @@ It returns a name of the created fontset." (mac-scroll-ignore-events) (scroll-up 1))) -) ;;;; Others @@ -2606,5 +2646,11 @@ It returns a name of the created fontset." ;; or bold bitmap versions will not display these variants correctly. (setq scalable-fonts-allowed t) +(add-to-list 'handle-args-function-alist '(mac . x-handle-args)) +(add-to-list 'frame-creation-function-alist '(mac . x-create-frame-with-faces)) +(add-to-list 'window-system-initialization-alist '(mac . mac-initialize-window-system)) + +(provide 'mac-win) + ;; arch-tag: 71dfcd14-cde8-4d66-b05c-85ec94fb23a6 ;;; mac-win.el ends here diff --git a/lisp/term/news.el b/lisp/term/news.el index 57d8fd6cb14..514f363314d 100644 --- a/lisp/term/news.el +++ b/lisp/term/news.el @@ -31,10 +31,8 @@ (defun terminal-init-news () "Terminal initialization function for news." - (if (boundp 'news-fkey-prefix) - nil - ;; The terminal initialization should already have set up some keys - (setq news-fkey-prefix (lookup-key function-key-map "\eO")) + ;; The terminal initialization should already have set up some keys + (let ((news-fkey-prefix (lookup-key local-function-key-map "\eO"))) (if (not (keymapp news-fkey-prefix)) (error "What? Your news termcap/terminfo has no keycaps in it")) diff --git a/lisp/term/rxvt.el b/lisp/term/rxvt.el index 64c09e0e1bd..c96c8a6e290 100644 --- a/lisp/term/rxvt.el +++ b/lisp/term/rxvt.el @@ -26,51 +26,10 @@ ;;; Code: -(defun terminal-init-rxvt () - "Terminal initialization function for rxvt." - ;; The terminal intialization C code file might have initialized - ;; function keys F11->F42 from the termcap/terminfo information. On - ;; a PC-style keyboard these keys correspond to - ;; MODIFIER-FUNCTION_KEY, where modifier is S-, C-, C-S-. The - ;; code here subsitutes the corresponding defintions in - ;; function-key-map. This substitution is needed because if a key - ;; definition if found in function-key-map, there are no further - ;; lookups in other keymaps. - (substitute-key-definition [f11] [S-f1] function-key-map) - (substitute-key-definition [f12] [S-f2] function-key-map) - (substitute-key-definition [f13] [S-f3] function-key-map) - (substitute-key-definition [f14] [S-f4] function-key-map) - (substitute-key-definition [f15] [S-f5] function-key-map) - (substitute-key-definition [f16] [S-f6] function-key-map) - (substitute-key-definition [f17] [S-f7] function-key-map) - (substitute-key-definition [f18] [S-f8] function-key-map) - (substitute-key-definition [f19] [S-f9] function-key-map) - (substitute-key-definition [f20] [S-f10] function-key-map) - - (substitute-key-definition [f23] [C-f1] function-key-map) - (substitute-key-definition [f24] [C-f2] function-key-map) - (substitute-key-definition [f25] [C-f3] function-key-map) - (substitute-key-definition [f26] [C-f4] function-key-map) - (substitute-key-definition [f27] [C-f5] function-key-map) - (substitute-key-definition [f28] [C-f6] function-key-map) - (substitute-key-definition [f29] [C-f7] function-key-map) - (substitute-key-definition [f30] [C-f8] function-key-map) - (substitute-key-definition [f31] [C-f9] function-key-map) - (substitute-key-definition [f32] [C-f10] function-key-map) - - (substitute-key-definition [f33] [C-S-f1] function-key-map) - (substitute-key-definition [f34] [C-S-f2] function-key-map) - (substitute-key-definition [f35] [C-S-f3] function-key-map) - (substitute-key-definition [f36] [C-S-f4] function-key-map) - (substitute-key-definition [f37] [C-S-f5] function-key-map) - (substitute-key-definition [f38] [C-S-f6] function-key-map) - (substitute-key-definition [f39] [C-S-f7] function-key-map) - (substitute-key-definition [f40] [C-S-f8] function-key-map) - (substitute-key-definition [f41] [C-S-f9] function-key-map) - (substitute-key-definition [f42] [C-S-f10] function-key-map) - - ;; Set up function-key-map entries that termcap and terminfo don't know. +(defvar rxvt-function-map (let ((map (make-sparse-keymap))) + + ;; Set up input-decode-map entries that termcap and terminfo don't know. (define-key map "\e[A" [up]) (define-key map "\e[B" [down]) (define-key map "\e[C" [right]) @@ -94,8 +53,8 @@ (define-key map "\e[21~" [f10]) ;; The strings emitted by f11 and f12 are the same as the strings ;; emitted by S-f1 and S-f2, so don't define f11 and f12. - ;; (define-key map "\e[23~" [f11]) - ;; (define-key map "\e[24~" [f12]) + ;; (define-key rxvt-function-map "\e[23~" [f11]) + ;; (define-key rxvt-function-map "\e[24~" [f12]) (define-key map "\e[29~" [print]) (define-key map "\e[11^" [C-f1]) @@ -152,12 +111,67 @@ (define-key map "\e[c" [S-right]) (define-key map "\e[a" [S-up]) (define-key map "\e[b" [S-down]) + map) + "Function key overrides for rxvt.") + +(defvar rxvt-alternatives-map + (let ((map (make-sparse-keymap))) + ;; The terminal intialization C code file might have initialized + ;; function keys F11->F42 from the termcap/terminfo information. On + ;; a PC-style keyboard these keys correspond to + ;; MODIFIER-FUNCTION_KEY, where modifier is S-, C-, C-S-. The + ;; code here subsitutes the corresponding defintions in + ;; function-key-map. This substitution is needed because if a key + ;; definition if found in function-key-map, there are no further + ;; lookups in other keymaps. + (define-key map [f11] [S-f1]) + (define-key map [f12] [S-f2]) + (define-key map [f13] [S-f3]) + (define-key map [f14] [S-f4]) + (define-key map [f15] [S-f5]) + (define-key map [f16] [S-f6]) + (define-key map [f17] [S-f7]) + (define-key map [f18] [S-f8]) + (define-key map [f19] [S-f9]) + (define-key map [f20] [S-f10]) - ;; Use inheritance to let the main keymap override those defaults. - ;; This way we don't override terminfo-derived settings or settings - ;; made in the .emacs file. - (set-keymap-parent map (keymap-parent function-key-map)) - (set-keymap-parent function-key-map map)) + (define-key map [f23] [C-f1]) + (define-key map [f24] [C-f2]) + (define-key map [f25] [C-f3]) + (define-key map [f26] [C-f4]) + (define-key map [f27] [C-f5]) + (define-key map [f28] [C-f6]) + (define-key map [f29] [C-f7]) + (define-key map [f30] [C-f8]) + (define-key map [f31] [C-f9]) + (define-key map [f32] [C-f10]) + + (define-key map [f33] [C-S-f1]) + (define-key map [f34] [C-S-f2]) + (define-key map [f35] [C-S-f3]) + (define-key map [f36] [C-S-f4]) + (define-key map [f37] [C-S-f5]) + (define-key map [f38] [C-S-f6]) + (define-key map [f39] [C-S-f7]) + (define-key map [f40] [C-S-f8]) + (define-key map [f41] [C-S-f9]) + (define-key map [f42] [C-S-f10]) + map) + "Keymap of possible alternative meanings for some keys.") + +(defun terminal-init-rxvt () + "Terminal initialization function for rxvt." + + (let ((map (copy-keymap rxvt-alternatives-map))) + (set-keymap-parent map (keymap-parent local-function-key-map)) + (set-keymap-parent local-function-key-map map)) + + ;; Use inheritance to let the main keymap override those defaults. + ;; This way we don't override terminfo-derived settings or settings + ;; made in the .emacs file. + (let ((m (copy-keymap rxvt-function-map))) + (set-keymap-parent m (keymap-parent input-decode-map)) + (set-keymap-parent input-decode-map m)) ;; Initialize colors and background mode. (rxvt-register-default-colors) @@ -239,7 +253,7 @@ for the currently selected frame." (- 256 ncolors) (list color color color)) (setq ncolors (1- ncolors)))) - + ((= ncolors 72) ; rxvt-unicode ;; 64 non-gray colors (let ((levels '(0 139 205 255)) @@ -282,7 +296,7 @@ for the currently selected frame." "Set background mode as appropriate for the default rxvt colors." (let ((fgbg (getenv "COLORFGBG")) bg rgb) - (setq default-frame-background-mode 'light) + (set-terminal-parameter nil 'background-mode 'light) (when (and fgbg (string-match ".*;\\([0-9][0-9]?\\)\\'" fgbg)) (setq bg (string-to-number (substring fgbg (match-beginning 1)))) @@ -295,8 +309,7 @@ for the currently selected frame." ;; The following line assumes that white is the 15th ;; color in rxvt-standard-colors. (* (apply '+ (car (cddr (nth 15 rxvt-standard-colors)))) 0.6)) - (setq default-frame-background-mode 'dark))) - (frame-set-background-mode (selected-frame)))) + (set-terminal-parameter nil 'background-mode 'dark))))) ;; arch-tag: 20cf2fb6-6318-4bab-9dbf-1d15048f2257 ;;; rxvt.el ends here diff --git a/lisp/term/sun-mouse.el b/lisp/term/sun-mouse.el index 65ebe193c71..d3e85508b03 100644 --- a/lisp/term/sun-mouse.el +++ b/lisp/term/sun-mouse.el @@ -501,7 +501,7 @@ If there is no documentation string, then the string (defun print-mouse-format (binding) (princ (car binding)) (princ ": ") - (mapcar (function + (mapc (function (lambda (mouse-list) (princ mouse-list) (princ " "))) @@ -660,21 +660,6 @@ Insert contents into the current buffer at point." (interactive "r") (sun-set-selection (buffer-substring beg end))) -;;; -;;; Support for emacstool -;;; This closes the window instead of stopping emacs. -;;; -(defun suspend-emacstool (&optional stuffstring) - "Suspend emacstool. -If running under as a detached process emacstool, -you don't want to suspend (there is no way to resume), -just close the window, and wait for reopening." - (interactive) - (run-hooks 'suspend-hook) - (if stuffstring (send-string-to-terminal stuffstring)) - (send-string-to-terminal "\033[2t") ; To close EmacsTool window. - (run-hooks 'suspend-resume-hook)) - (provide 'sun-mouse) (provide 'term/sun-mouse) ; have to (require 'term/sun-mouse) diff --git a/lisp/term/sun.el b/lisp/term/sun.el index c3dc773e26b..b3ee0ec458e 100644 --- a/lisp/term/sun.el +++ b/lisp/term/sun.el @@ -32,12 +32,12 @@ (defun scroll-down-in-place (n) (interactive "p") - (previous-line n) + (forward-line (- n)) (scroll-down n)) (defun scroll-up-in-place (n) (interactive "p") - (next-line n) + (forward-line n) (scroll-up n)) (defun kill-region-and-unmark (beg end) @@ -102,55 +102,10 @@ "List of forms to evaluate after setting sun-raw-prefix.") -;;; This section adds definitions for the emacstool users -;; emacstool event filter converts function keys to C-x*{c}{lrt} -;; -;; for example the Open key (L7) would be encoded as "\C-x*gl" -;; the control, meta, and shift keys modify the character {lrt} -;; note that (unshifted) C-l is ",", C-r is "2", and C-t is "4" -;; -;; {c} is [a-j] for LEFT, [a-i] for TOP, [a-o] for RIGHT. -;; A higher level insists on encoding {h,j,l,n}{r} (the arrow keys) -;; as ANSI escape sequences. Use the shell command -;; % setkeys noarrows -;; if you want these to come through for emacstool. -;; -;; If you are not using EmacsTool, -;; you can also use this by creating a .ttyswrc file to do the conversion. -;; but it won't include the CONTROL, META, or SHIFT keys! -;; -;; Important to define SHIFTed sequence before matching unshifted sequence. -;; (talk about bletcherous old uppercase terminal conventions!*$#@&%*&#$%) -;; this is worse than C-S/C-Q flow control anyday! -;; Do *YOU* run in capslock mode? -;; - -;; Note: al, el and gl are trapped by EmacsTool, so they never make it here. - -(defvar suntool-map (make-sparse-keymap) - "*Keymap for Emacstool bindings.") - - -;; Since .emacs gets loaded before this file, a hook is supplied -;; for you to put your own bindings in. - -(defvar suntool-map-hooks nil - "List of forms to evaluate after setting suntool-map.") - -;; -;; If running under emacstool, arrange to call suspend-emacstool -;; instead of suspend-emacs. -;; -;; First mouse blip is a clue that we are in emacstool. -;; -;; C-x C-@ is the mouse command prefix. - -(autoload 'sun-mouse-handler "sun-mouse" - "Sun Emacstool handler for mouse blips (not loaded)." t) (defun terminal-init-sun () "Terminal initialization function for sun." - (define-key function-key-map "\e[" sun-raw-prefix) + (define-key local-function-key-map "\e[" sun-raw-prefix) (define-key sun-raw-prefix "210z" [r3]) (define-key sun-raw-prefix "213z" [r6]) @@ -207,77 +162,7 @@ (let ((hooks sun-raw-prefix-hooks)) (while hooks (eval (car hooks)) - (setq hooks (cdr hooks))))) - - (define-key suntool-map "gr" 'beginning-of-buffer) ; r7 - (define-key suntool-map "iR" 'backward-page) ; R9 - (define-key suntool-map "ir" 'scroll-down) ; r9 - (define-key suntool-map "kr" 'recenter) ; r11 - (define-key suntool-map "mr" 'end-of-buffer) ; r13 - (define-key suntool-map "oR" 'forward-page) ; R15 - (define-key suntool-map "or" 'scroll-up) ; r15 - (define-key suntool-map "b\M-L" 'rerun-prev-command) ; M-AGAIN - (define-key suntool-map "b\M-l" 'prev-complex-command) ; M-Again - (define-key suntool-map "bl" 'redraw-display) ; Again - (define-key suntool-map "cl" 'list-buffers) ; Props - (define-key suntool-map "dl" 'undo) ; Undo - (define-key suntool-map "el" 'ignore) ; Expose-Open - (define-key suntool-map "fl" 'sun-select-region) ; Put - (define-key suntool-map "f," 'copy-region-as-kill) ; C-Put - (define-key suntool-map "gl" 'ignore) ; Open-Open - (define-key suntool-map "hl" 'sun-yank-selection) ; Get - (define-key suntool-map "h," 'yank) ; C-Get - (define-key suntool-map "il" 'research-forward) ; Find - (define-key suntool-map "i," 're-search-forward) ; C-Find - (define-key suntool-map "i\M-l" 'research-backward) ; M-Find - (define-key suntool-map "i\M-," 're-search-backward) ; C-M-Find - - (define-key suntool-map "jL" 'yank) ; DELETE - (define-key suntool-map "jl" 'kill-region-and-unmark) ; Delete - (define-key suntool-map "j\M-l" 'exchange-point-and-mark) ; M-Delete - (define-key suntool-map "j," - (lambda () (interactive) (pop-mark))) ; C-Delete - - (define-key suntool-map "fT" 'shrink-window-horizontally) ; T6 - (define-key suntool-map "gT" 'enlarge-window-horizontally) ; T7 - (define-key suntool-map "ft" 'shrink-window) ; t6 - (define-key suntool-map "gt" 'enlarge-window) ; t7 - (define-key suntool-map "cT" (lambda (n) (interactive "p") (scroll-down n))) - (define-key suntool-map "dT" (lambda (n) (interactive "p") (scroll-up n))) - (define-key suntool-map "ct" 'scroll-down-in-place) ; t3 - (define-key suntool-map "dt" 'scroll-up-in-place) ; t4 - (define-key ctl-x-map "*" suntool-map) - - (when suntool-map-hooks - (message "suntool-map-hooks is obsolete! Use term-setup-hook instead!") - (let ((hooks suntool-map-hooks)) - (while hooks - (eval (car hooks)) - (setq hooks (cdr hooks))))) - - (define-key ctl-x-map "\C-@" 'sun-mouse-once)) - -(defun emacstool-init () - "Set up Emacstool window, if you know you are in an emacstool." - ;; Make sure sun-mouse and sun-fns are loaded. - (require 'sun-fns) - (define-key ctl-x-map "\C-@" 'sun-mouse-handler) - - ;; FIXME: this function does not seem to exist either. -stef'01 - (if (< (sun-window-init) 0) - (message "Not a Sun Window") - (progn - (substitute-key-definition 'suspend-emacs 'suspend-emacstool global-map) - (substitute-key-definition 'suspend-emacs 'suspend-emacstool esc-map) - (substitute-key-definition 'suspend-emacs 'suspend-emacstool ctl-x-map)) - (send-string-to-terminal - (concat "\033]lEmacstool - GNU Emacs " emacs-version "\033\\")))) - -(defun sun-mouse-once () - "Converts to emacstool and sun-mouse-handler on first mouse hit." - (interactive) - (emacstool-init) - (sun-mouse-handler)) ; Now, execute this mouse blip. + (setq hooks (cdr hooks)))))) ;;; arch-tag: db761d47-fd7d-42b4-aae1-04fa116b6ba6 ;;; sun.el ends here diff --git a/lisp/term/tvi970.el b/lisp/term/tvi970.el index 1c0bda519ac..1898153cf2a 100644 --- a/lisp/term/tvi970.el +++ b/lisp/term/tvi970.el @@ -31,14 +31,14 @@ (defun terminal-init-tvi970 () "Terminal initialization function for tvi970." - (or (lookup-key function-key-map "\e[") - (define-key function-key-map "\e[" (make-keymap))) - ;; (or (lookup-key function-key-map "\eO") - ;; (define-key function-key-map "\eO" (make-keymap))) + (or (lookup-key local-function-key-map "\e[") + (define-key local-function-key-map "\e[" (make-keymap))) + ;; (or (lookup-key local-function-key-map "\eO") + ;; (define-key local-function-key-map "\eO" (make-keymap))) ;; Miscellaneous keys - (mapcar (function (lambda (key-binding) - (define-key function-key-map + (mapc (function (lambda (key-binding) + (define-key local-function-key-map (car key-binding) (nth 1 key-binding)))) '( ;; These are set up by termcap or terminfo @@ -54,7 +54,7 @@ ("\e[@" [insert]) ("\e[L" [insertline]) ("\e[M" [deleteline]) - ("\e[U" [next]) ;; actually the `page' key + ("\e[U" [next]) ;; actually the `page' key ;; These won't be set up by either ("\eOm" [kp-subtract]) @@ -87,22 +87,23 @@ ;; The numeric keypad keys. (let ((i 0)) (while (< i 10) - (define-key function-key-map + (define-key local-function-key-map (format "\eO%c" (+ i ?p)) (vector (intern (format "kp-%d" i)))) (setq i (1+ i)))) ;; The numbered function keys. (let ((i 0)) (while (< i 16) - (define-key function-key-map + (define-key local-function-key-map (format "\e?%c" (+ i ?a)) (vector (intern (format "f%d" (1+ i))))) - (define-key function-key-map + (define-key local-function-key-map (format "\e?%c" (+ i ?A)) (vector (intern (format "S-f%d" (1+ i))))) (setq i (1+ i)))) (tvi970-set-keypad-mode 1)) + ;;; Should keypad numbers send ordinary digits or distinct escape sequences? (defvar tvi970-keypad-numeric nil diff --git a/lisp/term/vt100.el b/lisp/term/vt100.el index b185a7bb02f..17627db8923 100644 --- a/lisp/term/vt100.el +++ b/lisp/term/vt100.el @@ -38,10 +38,9 @@ ;; Set up function-key-map entries that termcap and terminfo don't know. - (defun terminal-init-vt100 () "Terminal initialization function for vt100." - (load "term/lk201" nil t)) + (tty-run-terminal-initialization (selected-frame) "lk201")) ;;; Controlling the screen width. (defvar vt100-wide-mode (= (frame-width) 132) diff --git a/lisp/term/vt102.el b/lisp/term/vt102.el index ad780ed5081..67a90a8242c 100644 --- a/lisp/term/vt102.el +++ b/lisp/term/vt102.el @@ -1,8 +1,8 @@ ;; -*- no-byte-compile: t -*- (defun terminal-init-vt102 () - "Terminal initialization function for vt102." - (load "term/vt100" nil t)) + "Terminal initialization function for vt102." + (tty-run-terminal-initialization (selected-frame) "vt100")) ;;; arch-tag: 6e839cfc-125a-4574-82f1-c23a51f7c50f ;;; vt102.el ends here diff --git a/lisp/term/vt125.el b/lisp/term/vt125.el index 2221e597aed..82a7047fef1 100644 --- a/lisp/term/vt125.el +++ b/lisp/term/vt125.el @@ -1,8 +1,8 @@ ;; -*- no-byte-compile: t -*- (defun terminal-init-vt125 () - "Terminal initialization function for vt125." - (load "term/vt100" nil t)) + "Terminal initialization function for vt125." + (tty-run-terminal-initialization (selected-frame) "vt100")) ;;; arch-tag: 1d92d70f-dd55-4a1d-9088-e215a4883801 ;;; vt125.el ends here diff --git a/lisp/term/vt200.el b/lisp/term/vt200.el index e1215d15023..7e7b3281d92 100644 --- a/lisp/term/vt200.el +++ b/lisp/term/vt200.el @@ -1,12 +1,11 @@ ;; -*- no-byte-compile: t -*- ;; For our purposes we can treat the vt200 and vt100 almost alike. ;; Most differences are handled by the termcap entry. - (defun terminal-init-vt200 () - "Terminal initialization function for vt200." - (load "term/vt100" nil t) + "Terminal initialization function for vt200." + (tty-run-terminal-initialization (selected-frame) "vt100") ;; Make F11 an escape key. - (define-key function-key-map "\e[23~" [?\e])) + (define-key local-function-key-map "\e[23~" [?\e])) ;;; arch-tag: 0f78f583-9f32-4237-b106-28bcfff21d89 ;;; vt200.el ends here diff --git a/lisp/term/vt201.el b/lisp/term/vt201.el index 315030ab687..a63f9561a6d 100644 --- a/lisp/term/vt201.el +++ b/lisp/term/vt201.el @@ -2,10 +2,10 @@ ;; For our purposes we can treat the vt200 and vt100 almost alike. ;; Most differences are handled by the termcap entry. (defun terminal-init-vt201 () - "Terminal initialization function for vt201." - (load "term/vt100" nil t) + "Terminal initialization function for vt201." + (tty-run-terminal-initialization (selected-frame) "vt100") ;; Make F11 an escape key. - (define-key function-key-map "\e[23~" [?\e])) + (define-key local-function-key-map "\e[23~" [?\e])) ;;; arch-tag: a6abb38f-60ea-449e-a9e9-3fb8572c52ae ;;; vt201.el ends here diff --git a/lisp/term/vt220.el b/lisp/term/vt220.el index cccd2a6dfb7..b2b8fc944cf 100644 --- a/lisp/term/vt220.el +++ b/lisp/term/vt220.el @@ -2,10 +2,10 @@ ;; For our purposes we can treat the vt200 and vt100 almost alike. ;; Most differences are handled by the termcap entry. (defun terminal-init-vt220 () - "Terminal initialization function for vt220." - (load "term/vt100" nil t) + "Terminal initialization function for vt220." + (tty-run-terminal-initialization (selected-frame) "vt100") ;; Make F11 an escape key. - (define-key function-key-map "\e[23~" [?\e])) + (define-key local-function-key-map "\e[23~" [?\e])) ;;; arch-tag: 98fc4867-a20d-46a1-a276-d7be31e49871 ;;; vt220.el ends here diff --git a/lisp/term/vt240.el b/lisp/term/vt240.el index bb3931edac8..cb26ebf4069 100644 --- a/lisp/term/vt240.el +++ b/lisp/term/vt240.el @@ -2,10 +2,10 @@ ;; For our purposes we can treat the vt200 and vt100 almost alike. ;; Most differences are handled by the termcap entry. (defun terminal-init-vt240 () - "Terminal initialization function for vt240." - (load "term/vt100" nil t) + "Terminal initialization function for vt240." + (tty-run-terminal-initialization (selected-frame) "vt100") ;; Make F11 an escape key. - (define-key function-key-map "\e[23~" [?\e])) + (define-key local-function-key-map "\e[23~" [?\e])) ;;; arch-tag: d9f88e9c-02dc-49ff-871c-a415f08e4eb7 ;;; vt240.el ends here diff --git a/lisp/term/vt300.el b/lisp/term/vt300.el index ff600f47a1e..9a09ad5e8cb 100644 --- a/lisp/term/vt300.el +++ b/lisp/term/vt300.el @@ -1,9 +1,9 @@ ;; -*- no-byte-compile: t -*- (defun terminal-init-vt300 () - "Terminal initialization function for vt300." - (load "term/vt100" nil t) + "Terminal initialization function for vt300." + (tty-run-terminal-initialization (selected-frame) "vt100") ;; Make F11 an escape key. - (define-key function-key-map "\e[23~" [?\e])) + (define-key local-function-key-map "\e[23~" [?\e])) ;;; arch-tag: 876831c9-a6f2-444a-b033-706e6fbc149f ;;; vt300.el ends here diff --git a/lisp/term/vt320.el b/lisp/term/vt320.el index fb7772c7b5b..803d7286067 100644 --- a/lisp/term/vt320.el +++ b/lisp/term/vt320.el @@ -1,9 +1,9 @@ ;; -*- no-byte-compile: t -*- (defun terminal-init-vt320 () - "Terminal initialization function for vt320." - (load "term/vt100" nil t) + "Terminal initialization function for vt320." + (tty-run-terminal-initialization (selected-frame) "vt100") ;; Make F11 an escape key. - (define-key function-key-map "\e[23~" [?\e])) + (define-key local-function-key-map "\e[23~" [?\e])) ;;; arch-tag: f9f4c954-0b9e-45f9-b450-a320d32abd9c ;;; vt320.el ends here diff --git a/lisp/term/vt400.el b/lisp/term/vt400.el index 97c0c5d7372..f73f4660b94 100644 --- a/lisp/term/vt400.el +++ b/lisp/term/vt400.el @@ -1,9 +1,9 @@ ;; -*- no-byte-compile: t -*- (defun terminal-init-vt400 () - "Terminal initialization function for vt400." - (load "term/vt100" nil t) + "Terminal initialization function for vt400." + (tty-run-terminal-initialization (selected-frame) "vt100") ;; Make F11 an escape key. - (define-key function-key-map "\e[23~" [?\e])) + (define-key local-function-key-map "\e[23~" [?\e])) ;;; arch-tag: a70809c5-6b21-42cc-ba20-536683e5e7d5 ;;; vt400.el ends here diff --git a/lisp/term/vt420.el b/lisp/term/vt420.el index 65ffa759c17..e65ba1a61d5 100644 --- a/lisp/term/vt420.el +++ b/lisp/term/vt420.el @@ -1,9 +1,9 @@ ;; -*- no-byte-compile: t -*- -(defun terminal-init-vt420 () - "Terminal initialization function for vt420." - (load "term/vt100" nil t) +(defun terminal-init-vt420 + "Terminal initialization function for vt420." + (tty-run-terminal-initialization (selected-frame) "vt100") ;; Make F11 an escape key. - (define-key function-key-map "\e[23~" [?\e])) + (define-key local-function-key-map "\e[23~" [?\e])) ;;; arch-tag: df2f897c-3a12-4b3c-9259-df089f96c160 ;;; vt420.el ends here diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 3d17fb370c2..08b57cb6d83 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -68,8 +68,8 @@ ;; An alist of X options and the function which handles them. See ;; ../startup.el. -(if (not (eq window-system 'w32)) - (error "%s: Loading w32-win.el but not compiled for w32" (invocation-name))) +;; (if (not (eq window-system 'w32)) +;; (error "%s: Loading w32-win.el but not compiled for w32" (invocation-name))) (require 'frame) (require 'mouse) @@ -80,6 +80,10 @@ (require 'dnd) (require 'code-pages) +;; Keep an obsolete alias for w32-focus-frame in case it is used by code +;; outside Emacs. +(define-obsolete-function-alias 'w32-focus-frame 'x-focus-frame "23.1") + (defvar xlfd-regexp-registry-subnum) ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles @@ -89,9 +93,6 @@ ;; The following definition is used for debugging scroll bar events. ;(defun w32-handle-scroll-bar-event (event) (interactive "e") (princ event)) -;; Handle mouse-wheel events with mwheel. -(mouse-wheel-mode 1) - (defun w32-drag-n-drop-debug (event) "Print the drag-n-drop EVENT in a readable form." (interactive "e") @@ -111,7 +112,7 @@ Switch to a buffer editing the last file dropped." (y (cdr coords))) (if (and (> x 0) (> y 0)) (set-frame-selected-window nil window)) - (mapcar (lambda (file-name) + (mapc (lambda (file-name) (let ((f (subst-char-in-string ?\\ ?/ file-name)) (coding (or file-name-coding-system default-file-name-coding-system))) @@ -1039,58 +1040,30 @@ XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp") ;;;; Function keys -;;; make f10 activate the real menubar rather than the mini-buffer menu -;;; navigation feature. -(defun menu-bar-open (&optional frame) - "Start key navigation of the menu bar in FRAME. - -This initially activates the first menu-bar item, and you can then navigate -with the arrow keys, select a menu entry with the Return key or cancel with -the Escape key. If FRAME has no menu bar, this function does nothing. - -If FRAME is nil or not given, use the selected frame." - (interactive "i") - (w32-send-sys-command ?\xf100 frame)) -; -(global-set-key [f10] 'menu-bar-open) - -(substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame - global-map) - -(define-key function-key-map [S-tab] [backtab]) - + ;;; make f10 activate the real menubar rather than the mini-buffer menu + ;;; navigation feature. + (defun menu-bar-open (&optional frame) + "Start key navigation of the menu bar in FRAME. + + This initially activates the first menu-bar item, and you can then navigate + with the arrow keys, select a menu entry with the Return key or cancel with + the Escape key. If FRAME has no menu bar, this function does nothing. + + If FRAME is nil or not given, use the selected frame." + (interactive "i") + (w32-send-sys-command ?\xf100 frame)) + +(defun x-setup-function-keys (frame) + "Setup Function Keys for w32." + (with-selected-frame frame + (define-key local-function-key-map [f10] 'menu-bar-open) + + (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame + local-function-key-map global-map) + + (define-key local-function-key-map [S-tab] [backtab])) + (set-terminal-parameter frame 'x-setup-function-keys t)) -;;; Do the actual Windows setup here; the above code just defines -;;; functions and variables that we use now. - -(setq command-line-args (x-handle-args command-line-args)) - -;;; Make sure we have a valid resource name. -(or (stringp x-resource-name) - (setq x-resource-name - ;; Change any . or * characters in x-resource-name to hyphens, - ;; so as not to choke when we use it in X resource queries. - (replace-regexp-in-string "[.*]" "-" (invocation-name)))) - -;; For the benefit of older Emacses (19.27 and earlier) that are sharing -;; the same lisp directory, don't pass the third argument unless we seem -;; to have the multi-display support. -(if (fboundp 'x-close-connection) - (x-open-connection "" - x-command-line-resources - ;; Exit Emacs with fatal error if this fails. - t) - (x-open-connection "" - x-command-line-resources)) - -(setq frame-creation-function 'x-create-frame-with-faces) - -(setq x-cut-buffer-max (min (- (/ (x-server-max-request-size) 2) 100) - x-cut-buffer-max)) - -;; W32 expects the menu bar cut and paste commands to use the clipboard. -;; This has ,? to match both on Sunos and on Solaris. -(menu-bar-enable-clipboard) ;; W32 systems have different fonts than commonly found on X, so ;; we define our own standard fontset here. @@ -1144,45 +1117,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (defun x-win-suspend-error () "Report an error when a suspend is attempted." (error "Suspending an Emacs running under W32 makes no sense")) -(add-hook 'suspend-hook 'x-win-suspend-error) - -;;; Turn off window-splitting optimization; w32 is usually fast enough -;;; that this is only annoying. -(setq split-window-keep-point t) - -;; Don't show the frame name; that's redundant. -(setq-default mode-line-frame-identification " ") - -;;; Set to a system sound if you want a fancy bell. -(set-message-beep 'ok) - -;; Remap some functions to call w32 common dialogs - -(defun internal-face-interactive (what &optional bool) - (let* ((fn (intern (concat "face-" what))) - (prompt (concat "Set " what " of face ")) - (face (read-face-name prompt)) - (default (if (fboundp fn) - (or (funcall fn face (selected-frame)) - (funcall fn 'default (selected-frame))))) - (fn-win (intern (concat (symbol-name window-system) "-select-" what))) - value) - (setq value - (cond ((fboundp fn-win) - (funcall fn-win)) - ((eq bool 'color) - (completing-read (concat prompt " " (symbol-name face) " to: ") - (mapcar (function (lambda (color) - (cons color color))) - x-colors) - nil nil nil nil default)) - (bool - (y-or-n-p (concat "Should face " (symbol-name face) - " be " bool "? "))) - (t - (read-string (concat prompt " " (symbol-name face) " to: ") - nil nil default)))) - (list face (if (equal value "") nil value)))) + ;;; Enable Japanese fonts on Windows to be used by default. ;; (set-fontset-font nil (make-char 'katakana-jisx0201) '("*" . "JISX0208-SJIS")) @@ -1229,7 +1164,120 @@ pop-up menu are unaffected by `w32-list-proportional-fonts')." (png "libpng13d.dll" "libpng13.dll" "libpng12d.dll" "libpng12.dll" "libpng.dll") (jpeg "jpeg62.dll" "libjpeg.dll" "jpeg-62.dll" "jpeg.dll") (tiff "libtiff3.dll" "libtiff.dll") - (gif "giflib4.dll" "libungif4.dll" "libungif.dll"))) + (gif "giflib4.dll" "libungif4.dll" "libungif.dll") + (svg "librsvg-2-2.dll") + (gdk-pixbuf "libgdk_pixbuf-2.0-0.dll") + (glib "libglib-2.0-0.dll"))) + +;;; multi-tty support +(defvar w32-initialized nil + "Non-nil if the w32 window system has been initialized.") + +(defun w32-initialize-window-system () + "Initialize Emacs for W32 GUI frames." + + ;; Do the actual Windows setup here; the above code just defines + ;; functions and variables that we use now. + + (setq command-line-args (x-handle-args command-line-args)) + + ;; Make sure we have a valid resource name. + (or (stringp x-resource-name) + (setq x-resource-name + ;; Change any . or * characters in x-resource-name to hyphens, + ;; so as not to choke when we use it in X resource queries. + (replace-regexp-in-string "[.*]" "-" (invocation-name)))) + + (x-open-connection "" x-command-line-resources + ;; Exit with a fatal error if this fails and we + ;; are the initial display + (eq initial-window-system 'w32)) + + ;; Setup the default fontset. + (setup-default-fontset) + ;; Create the standard fontset. + (create-fontset-from-fontset-spec w32-standard-fontset-spec t) + ;; Create fontset specified in X resources "Fontset-N" (N is 0, 1,...). + (create-fontset-from-x-resource) + ;; Try to create a fontset from a font specification which comes + ;; from initial-frame-alist, default-frame-alist, or X resource. + ;; A font specification in command line argument (i.e. -fn XXXX) + ;; should be already in default-frame-alist as a `font' + ;; parameter. However, any font specifications in site-start + ;; library, user's init file (.emacs), and default.el are not + ;; yet handled here. + + (let ((font (or (cdr (assq 'font initial-frame-alist)) + (cdr (assq 'font default-frame-alist)) + (x-get-resource "font" "Font"))) + xlfd-fields resolved-name) + (if (and font + (not (query-fontset font)) + (setq resolved-name (x-resolve-font-name font)) + (setq xlfd-fields (x-decompose-font-name font))) + (if (string= "fontset" + (aref xlfd-fields xlfd-regexp-registry-subnum)) + (new-fontset font + (x-complement-fontset-spec xlfd-fields nil)) + ;; Create a fontset from FONT. The fontset name is + ;; generated from FONT. + (create-fontset-from-ascii-font font + resolved-name "startup")))) + + ;; Apply a geometry resource to the initial frame. Put it at the end + ;; of the alist, so that anything specified on the command line takes + ;; precedence. + (let* ((res-geometry (x-get-resource "geometry" "Geometry")) + parsed) + (if res-geometry + (progn + (setq parsed (x-parse-geometry res-geometry)) + ;; If the resource specifies a position, + ;; call the position and size "user-specified". + (if (or (assq 'top parsed) (assq 'left parsed)) + (setq parsed (cons '(user-position . t) + (cons '(user-size . t) parsed)))) + ;; All geometry parms apply to the initial frame. + (setq initial-frame-alist (append initial-frame-alist parsed)) + ;; The size parms apply to all frames. + (if (assq 'height parsed) + (push (cons 'height (cdr (assq 'height parsed))) + default-frame-alist)) + (if (assq 'width parsed) + (push (cons 'width (cdr (assq 'width parsed))) + default-frame-alist))))) + + ;; Check the reverseVideo resource. + (let ((case-fold-search t)) + (let ((rv (x-get-resource "reverseVideo" "ReverseVideo"))) + (if (and rv (string-match "^\\(true\\|yes\\|on\\)$" rv)) + (push '(reverse . t) default-frame-alist)))) + + ;; Don't let Emacs suspend under w32 gui + (add-hook 'suspend-hook 'x-win-suspend-error) + + ;; Turn off window-splitting optimization; w32 is usually fast enough + ;; that this is only annoying. + (setq split-window-keep-point t) + + ;; Turn on support for mouse wheels + (mouse-wheel-mode 1) + + ;; W32 expects the menu bar cut and paste commands to use the clipboard. + (menu-bar-enable-clipboard) + + ;; Don't show the frame name; that's redundant. + (setq-default mode-line-frame-identification " ") + + ;; Set to a system sound if you want a fancy bell. + (set-message-beep 'ok) + (setq w32-initialized t)) + +(add-to-list 'handle-args-function-alist '(w32 . x-handle-args)) +(add-to-list 'frame-creation-function-alist '(w32 . x-create-frame-with-faces)) +(add-to-list 'window-system-initialization-alist '(w32 . w32-initialize-window-system)) + +(provide 'w32-win) ;; arch-tag: 69fb1701-28c2-4890-b351-3d1fe4b4f166 ;;; w32-win.el ends here diff --git a/lisp/term/wyse50.el b/lisp/term/wyse50.el index c0e4334f522..e241224c637 100644 --- a/lisp/term/wyse50.el +++ b/lisp/term/wyse50.el @@ -40,9 +40,9 @@ (defun terminal-init-wyse50 () "Terminal initialization function for wyse50." - (define-key function-key-map "\C-a" (make-keymap)) + (define-key local-function-key-map "\C-a" (make-keymap)) (mapcar (function (lambda (key-definition) - (define-key function-key-map + (define-key local-function-key-map (car key-definition) (nth 1 key-definition)))) '( ;; These might be set up by termcap and terminfo @@ -100,11 +100,11 @@ ("\eY" [key-clear]) ;; Not an X keysym ;; These are totally strange :-) - ("\eW" [?\C-?]) ;; Not an X keysym - ("\^a\^k\^m" [funct-up]) ;; Not an X keysym - ("\^a\^j\^m" [funct-down]) ;; Not an X keysym - ("\^a\^l\^m" [funct-right]) ;; Not an X keysym - ("\^a\^h\^m" [funct-left]) ;; Not an X keysym + ("\eW" [?\C-?]) ;; Not an X keysym + ("\^a\^k\^m" [funct-up]) ;; Not an X keysym + ("\^a\^j\^m" [funct-down]) ;; Not an X keysym + ("\^a\^l\^m" [funct-right]) ;; Not an X keysym + ("\^a\^h\^m" [funct-left]) ;; Not an X keysym ("\^a\^m\^m" [funct-return]) ;; Not an X keysym ("\^a\^i\^m" [funct-tab]) ;; Not an X keysym )) diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index 246b38a6c9f..138df0f2da5 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -25,10 +25,16 @@ ;;; Commentary: -;; X-win.el: this file is loaded from ../lisp/startup.el when it recognizes -;; that X windows are to be used. Command line switches are parsed and those -;; pertaining to X are processed and removed from the command line. The -;; X display is opened and hooks are set for popping up the initial window. +;; X-win.el: this file defines functions to initialize the X window +;; system and process X-specific command line parameters before +;; creating the first X frame. + +;; Note that contrary to previous Emacs versions, the act of loading +;; this file should not have the side effect of initializing the +;; window system or processing command line arguments (this file is +;; now loaded in loadup.el). See the variables +;; `handle-args-function-alist' and +;; `window-system-initialization-alist' for more details. ;; startup.el will then examine startup files, and eventually call the hooks ;; which create the first window(s). @@ -65,7 +71,7 @@ ;; An alist of X options and the function which handles them. See ;; ../startup.el. -(if (not (eq window-system 'x)) +(if (not (fboundp 'x-create-frame)) (error "%s: Loading x-win.el but not compiled for X" (invocation-name))) (require 'frame) @@ -395,6 +401,7 @@ exists." (defconst x-pointer-ur-angle 148) (defconst x-pointer-watch 150) (defconst x-pointer-xterm 152) +(defconst x-pointer-invisible 255) ;; ;; Available colors @@ -1170,27 +1177,39 @@ XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp") ;;;; Function keys -(substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame - global-map) - -;; Map certain keypad keys into ASCII characters -;; that people usually expect. -(define-key function-key-map [backspace] [127]) -(define-key function-key-map [delete] [127]) -(define-key function-key-map [tab] [?\t]) -(define-key function-key-map [linefeed] [?\n]) -(define-key function-key-map [clear] [?\C-l]) -(define-key function-key-map [return] [?\C-m]) -(define-key function-key-map [escape] [?\e]) -(define-key function-key-map [M-backspace] [?\M-\d]) -(define-key function-key-map [M-delete] [?\M-\d]) -(define-key function-key-map [M-tab] [?\M-\t]) -(define-key function-key-map [M-linefeed] [?\M-\n]) -(define-key function-key-map [M-clear] [?\M-\C-l]) -(define-key function-key-map [M-return] [?\M-\C-m]) -(define-key function-key-map [M-escape] [?\M-\e]) -(define-key function-key-map [iso-lefttab] [backtab]) -(define-key function-key-map [S-iso-lefttab] [backtab]) +(defvar x-alternatives-map + (let ((map (make-sparse-keymap))) + ;; Map certain keypad keys into ASCII characters that people usually expect. + (define-key map [backspace] [127]) + (define-key map [delete] [127]) + (define-key map [tab] [?\t]) + (define-key map [linefeed] [?\n]) + (define-key map [clear] [?\C-l]) + (define-key map [return] [?\C-m]) + (define-key map [escape] [?\e]) + (define-key map [M-backspace] [?\M-\d]) + (define-key map [M-delete] [?\M-\d]) + (define-key map [M-tab] [?\M-\t]) + (define-key map [M-linefeed] [?\M-\n]) + (define-key map [M-clear] [?\M-\C-l]) + (define-key map [M-return] [?\M-\C-m]) + (define-key map [M-escape] [?\M-\e]) + (define-key map [iso-lefttab] [backtab]) + (define-key map [S-iso-lefttab] [backtab]) + map) + "Keymap of possible alternative meanings for some keys.") + +(defun x-setup-function-keys (frame) + "Set up `function-key-map' on FRAME for the X window system." + ;; Don't do this twice on the same display, or it would break + ;; normal-erase-is-backspace-mode. + (unless (terminal-parameter frame 'x-setup-function-keys) + ;; Map certain keypad keys into ASCII characters that people usually expect. + (with-selected-frame frame + (let ((map (copy-keymap x-alternatives-map))) + (set-keymap-parent map (keymap-parent local-function-key-map)) + (set-keymap-parent local-function-key-map map))) + (set-terminal-parameter frame 'x-setup-function-keys t))) ;; These tell read-char how to convert ;; these special chars to ASCII. @@ -2349,15 +2368,15 @@ order until succeed.") (cond;; check cut buffer ((or (not cut-text) (string= cut-text "")) (setq x-last-selected-text-cut nil)) - ;; This short cut doesn't work because x-get-cut-buffer - ;; always returns a newly created string. - ;; ((eq cut-text x-last-selected-text-cut) nil) + ;; This short cut doesn't work because x-get-cut-buffer + ;; always returns a newly created string. + ;; ((eq cut-text x-last-selected-text-cut) nil) ((and (string= cut-text x-last-selected-text-cut-encoded) (eq x-last-cut-buffer-coding next-coding)) - ;; See the comment above. No need of this recording. - ;; Record the newer string, - ;; so subsequent calls can use the `eq' test. - ;; (setq x-last-selected-text-cut cut-text) + ;; See the comment above. No need of this recording. + ;; Record the newer string, + ;; so subsequent calls can use the `eq' test. + ;; (setq x-last-selected-text-cut cut-text) nil) (t (setq x-last-selected-text-cut-encoded cut-text @@ -2365,7 +2384,7 @@ order until succeed.") x-last-selected-text-cut ;; ICCCM says cut buffer always contain ISO-Latin-1, but ;; use next-selection-coding-system if not nil. - (decode-coding-string + (decode-coding-string cut-text next-coding)))))) ;; As we have done one selection, clear this now. @@ -2394,182 +2413,328 @@ order until succeed.") (or clip-text primary-text cut-text) )) - -;; Do the actual X Windows setup here; the above code just defines -;; functions and variables that we use now. - -(setq command-line-args (x-handle-args command-line-args)) - -;; Make sure we have a valid resource name. -(or (stringp x-resource-name) - (let (i) - (setq x-resource-name (invocation-name)) - - ;; Change any . or * characters in x-resource-name to hyphens, - ;; so as not to choke when we use it in X resource queries. - (while (setq i (string-match "[.*]" x-resource-name)) - (aset x-resource-name i ?-)))) - -(x-open-connection (or x-display-name - (setq x-display-name (getenv "DISPLAY"))) - x-command-line-resources - ;; Exit Emacs with fatal error if this fails. - t) - -(setq frame-creation-function 'x-create-frame-with-faces) - -(setq x-cut-buffer-max (min (- (/ (x-server-max-request-size) 2) 100) - x-cut-buffer-max)) - -;; Setup the default fontset. -(setup-default-fontset) - -;; Create the standard fontset. -(create-fontset-from-fontset-spec standard-fontset-spec t) - -;; Create fontset specified in X resources "Fontset-N" (N is 0, 1, ...). -(create-fontset-from-x-resource) - -;; Apply a geometry resource to the initial frame. Put it at the end -;; of the alist, so that anything specified on the command line takes -;; precedence. -(let* ((res-geometry (x-get-resource "geometry" "Geometry")) - parsed) - (if res-geometry - (progn - (setq parsed (x-parse-geometry res-geometry)) - ;; If the resource specifies a position, - ;; call the position and size "user-specified". - (if (or (assq 'top parsed) (assq 'left parsed)) - (setq parsed (cons '(user-position . t) - (cons '(user-size . t) parsed)))) - ;; All geometry parms apply to the initial frame. - (setq initial-frame-alist (append initial-frame-alist parsed)) - ;; The size parms apply to all frames. Don't set it if there are - ;; sizes there already (from command line). - (if (and (assq 'height parsed) - (not (assq 'height default-frame-alist))) - (setq default-frame-alist - (cons (cons 'height (cdr (assq 'height parsed))) - default-frame-alist))) - (if (and (assq 'width parsed) - (not (assq 'width default-frame-alist))) - (setq default-frame-alist - (cons (cons 'width (cdr (assq 'width parsed))) - default-frame-alist)))))) - -;; Check the reverseVideo resource. -(let ((case-fold-search t)) - (let ((rv (x-get-resource "reverseVideo" "ReverseVideo"))) - (if (and rv - (string-match "^\\(true\\|yes\\|on\\)$" rv)) - (setq default-frame-alist - (cons '(reverse . t) default-frame-alist))))) +(defun x-clipboard-yank () + "Insert the clipboard contents, or the last stretch of killed text." + (interactive "*") + (let ((clipboard-text (x-selection-value 'CLIPBOARD)) + (x-select-enable-clipboard t)) + (if (and clipboard-text (> (length clipboard-text) 0)) + (kill-new clipboard-text)) + (yank))) -;; Set x-selection-timeout, measured in milliseconds. -(let ((res-selection-timeout - (x-get-resource "selectionTimeout" "SelectionTimeout"))) - (setq x-selection-timeout 20000) - (if res-selection-timeout - (setq x-selection-timeout (string-to-number res-selection-timeout)))) +(defun x-menu-bar-open (&optional frame) + "Open the menu bar if `menu-bar-mode' is on. otherwise call `tmm-menubar'." + (interactive "i") + (if menu-bar-mode (accelerate-menu frame) + (tmm-menubar))) -;; Set scroll bar mode to right if set by X resources. Default is left. -(if (equal (x-get-resource "verticalScrollBars" "ScrollBars") "right") - (customize-set-variable 'scroll-bar-mode 'right)) + +;;; Window system initialization. (defun x-win-suspend-error () (error "Suspending an Emacs running under X makes no sense")) -(add-hook 'suspend-hook 'x-win-suspend-error) -;; Arrange for the kill and yank functions to set and check the clipboard. -(setq interprogram-cut-function 'x-select-text) -(setq interprogram-paste-function 'x-cut-buffer-or-selection-value) +(defvar x-initialized nil + "Non-nil if the X window system has been initialized.") + +(defun x-initialize-window-system () + "Initialize Emacs for X frames and open the first connection to an X server." + ;; Make sure we have a valid resource name. + (or (stringp x-resource-name) + (let (i) + (setq x-resource-name (invocation-name)) + + ;; Change any . or * characters in x-resource-name to hyphens, + ;; so as not to choke when we use it in X resource queries. + (while (setq i (string-match "[.*]" x-resource-name)) + (aset x-resource-name i ?-)))) + + (x-open-connection (or x-display-name + (setq x-display-name (or (getenv "DISPLAY" (selected-frame)) + (getenv "DISPLAY")))) + x-command-line-resources + ;; Exit Emacs with fatal error if this fails and we + ;; are the initial display. + (eq initial-window-system 'x)) + + (setq x-cut-buffer-max (min (- (/ (x-server-max-request-size) 2) 100) + x-cut-buffer-max)) + + ;; Setup the default fontset. + (setup-default-fontset) + + ;; Create the standard fontset. + (create-fontset-from-fontset-spec standard-fontset-spec t) + + ;; Create fontset specified in X resources "Fontset-N" (N is 0, 1, ...). + (create-fontset-from-x-resource) + + ;; Try to create a fontset from a font specification which comes + ;; from initial-frame-alist, default-frame-alist, or X resource. + ;; A font specification in command line argument (i.e. -fn XXXX) + ;; should be already in default-frame-alist as a `font' + ;; parameter. However, any font specifications in site-start + ;; library, user's init file (.emacs), and default.el are not + ;; yet handled here. + + (let ((font (or (cdr (assq 'font initial-frame-alist)) + (cdr (assq 'font default-frame-alist)) + (x-get-resource "font" "Font"))) + xlfd-fields resolved-name) + (if (and font + (not (query-fontset font)) + (setq resolved-name (x-resolve-font-name font)) + (setq xlfd-fields (x-decompose-font-name font))) + (if (string= "fontset" (aref xlfd-fields xlfd-regexp-registry-subnum)) + (new-fontset font (x-complement-fontset-spec xlfd-fields nil)) + ;; Create a fontset from FONT. The fontset name is + ;; generated from FONT. + (create-fontset-from-ascii-font font resolved-name "startup")))) + + ;; Set scroll bar mode to right if set by X resources. Default is left. + (if (equal (x-get-resource "verticalScrollBars" "ScrollBars") "right") + (customize-set-variable 'scroll-bar-mode 'right)) + + ;; Apply a geometry resource to the initial frame. Put it at the end + ;; of the alist, so that anything specified on the command line takes + ;; precedence. + (let* ((res-geometry (x-get-resource "geometry" "Geometry")) + parsed) + (if res-geometry + (progn + (setq parsed (x-parse-geometry res-geometry)) + ;; If the resource specifies a position, + ;; call the position and size "user-specified". + (if (or (assq 'top parsed) (assq 'left parsed)) + (setq parsed (cons '(user-position . t) + (cons '(user-size . t) parsed)))) + ;; All geometry parms apply to the initial frame. + (setq initial-frame-alist (append initial-frame-alist parsed)) + ;; The size parms apply to all frames. Don't set it if there are + ;; sizes there already (from command line). + (if (and (assq 'height parsed) + (not (assq 'height default-frame-alist))) + (setq default-frame-alist + (cons (cons 'height (cdr (assq 'height parsed))) + default-frame-alist))) + (if (and (assq 'width parsed) + (not (assq 'width default-frame-alist))) + (setq default-frame-alist + (cons (cons 'width (cdr (assq 'width parsed))) + default-frame-alist)))))) + + ;; Check the reverseVideo resource. + (let ((case-fold-search t)) + (let ((rv (x-get-resource "reverseVideo" "ReverseVideo"))) + (if (and rv + (string-match "^\\(true\\|yes\\|on\\)$" rv)) + (setq default-frame-alist + (cons '(reverse . t) default-frame-alist))))) -;; Turn off window-splitting optimization; X is usually fast enough -;; that this is only annoying. -(setq split-window-keep-point t) + ;; Set x-selection-timeout, measured in milliseconds. + (let ((res-selection-timeout + (x-get-resource "selectionTimeout" "SelectionTimeout"))) + (setq x-selection-timeout 20000) + (if res-selection-timeout + (setq x-selection-timeout (string-to-number res-selection-timeout)))) -;; Don't show the frame name; that's redundant with X. -(setq-default mode-line-frame-identification " ") + ;; Don't let Emacs suspend under X. + (add-hook 'suspend-hook 'x-win-suspend-error) -;; Motif direct handling of f10 wasn't working right, -;; So temporarily we've turned it off in lwlib-Xm.c -;; and turned the Emacs f10 back on. -;; ;; Motif normally handles f10 itself, so don't try to handle it a second time. -;; (if (featurep 'motif) -;; (global-set-key [f10] 'ignore)) + ;; Turn off window-splitting optimization; X is usually fast enough + ;; that this is only annoying. + (setq split-window-keep-point t) -;; Turn on support for mouse wheels. -(mouse-wheel-mode 1) + ;; Motif direct handling of f10 wasn't working right, + ;; So temporarily we've turned it off in lwlib-Xm.c + ;; and turned the Emacs f10 back on. + ;; ;; Motif normally handles f10 itself, so don't try to handle it a second time. + ;; (if (featurep 'motif) + ;; (global-set-key [f10] 'ignore)) + ;; Turn on support for mouse wheels. + (mouse-wheel-mode 1) -;; Enable CLIPBOARD copy/paste through menu bar commands. -(menu-bar-enable-clipboard) + ;; Enable CLIPBOARD copy/paste through menu bar commands. + (menu-bar-enable-clipboard) -;; Override Paste so it looks at CLIPBOARD first. -(defun x-clipboard-yank () - "Insert the clipboard contents, or the last stretch of killed text." - (interactive "*") - (let ((clipboard-text (x-selection-value 'CLIPBOARD)) - (x-select-enable-clipboard t)) - (if (and clipboard-text (> (length clipboard-text) 0)) - (kill-new clipboard-text)) - (yank))) + ;; Override Paste so it looks at CLIPBOARD first. + (define-key menu-bar-edit-menu [paste] + (append '(menu-item "Paste" x-clipboard-yank + :enable (not buffer-read-only) + :help "Paste (yank) text most recently cut/copied") + nil)) -(define-key menu-bar-edit-menu [paste] - '(menu-item "Paste" x-clipboard-yank - :enable (not buffer-read-only) - :help "Paste (yank) text most recently cut/copied")) + (setq x-initialized t)) + +(add-to-list 'handle-args-function-alist '(x . x-handle-args)) +(add-to-list 'frame-creation-function-alist '(x . x-create-frame-with-faces)) +(add-to-list 'window-system-initialization-alist '(x . x-initialize-window-system)) ;; Initiate drag and drop (add-hook 'after-make-frame-functions 'x-dnd-init-frame) (define-key special-event-map [drag-n-drop] 'x-dnd-handle-drag-n-drop-event) -;; Let F10 do menu bar navigation. -(defun x-menu-bar-open (&optional frame) - "Open the menu bar if `menu-bar-mode' is on. otherwise call `tmm-menubar'." - (interactive "i") - (if menu-bar-mode (menu-bar-open frame) - (tmm-menubar))) - -(and (fboundp 'menu-bar-open) - (global-set-key [f10] 'x-menu-bar-open)) +(defcustom x-gtk-stock-map + '( + ("etc/images/new" . "gtk-new") + ("etc/images/open" . "gtk-open") + ("etc/images/diropen" . "n:system-file-manager") + ("etc/images/close" . "gtk-close") + ("etc/images/save" . "gtk-save") + ("etc/images/saveas" . "gtk-save-as") + ("etc/images/undo" . "gtk-undo") + ("etc/images/cut" . "gtk-cut") + ("etc/images/copy" . "gtk-copy") + ("etc/images/paste" . "gtk-paste") + ("etc/images/search" . "gtk-find") + ("etc/images/print" . "gtk-print") + ("etc/images/preferences" . "gtk-preferences") + ("etc/images/help" . "gtk-help") + ("etc/images/left-arrow" . "gtk-go-back") + ("etc/images/right-arrow" . "gtk-go-forward") + ("etc/images/home" . "gtk-home") + ("etc/images/jump-to" . "gtk-jump-to") + ("etc/images/index" . "gtk-index") + ("etc/images/search" . "gtk-find") + ("etc/images/exit" . "gtk-quit") + ;; Used in Gnus and/or MH-E: + ("etc/images/attach.xpm" . "gtk-attach") + ("etc/images/connect.xpm" . "gtk-connect") + ("etc/images/contact.xpm" . "gtk-contact") + ("etc/images/delete.xpm" . "gtk-delete") + ("etc/images/describe.xpm" . "gtk-properties") + ("etc/images/disconnect.xpm" . "gtk-disconnect") + ;; ("etc/images/exit.xpm" . "gtk-exit") + ("etc/images/lock-broken.xpm" . "gtk-lock_broken") + ("etc/images/lock-ok.xpm" . "gtk-lock_ok") + ("etc/images/lock.xpm" . "gtk-lock") + ("etc/images/next-page.xpm" . "gtk-next-page") + ("etc/images/refresh.xpm" . "gtk-refresh") + ("etc/images/sort-ascending.xpm" . "gtk-sort-ascending") + ("etc/images/sort-column-ascending.xpm" . "gtk-sort-column-ascending") + ("etc/images/sort-criteria.xpm" . "gtk-sort-criteria") + ("etc/images/sort-descending.xpm" . "gtk-sort-descending") + ("etc/images/sort-row-ascending.xpm" . "gtk-sort-row-ascending") + ("images/gnus/toggle-subscription.xpm" . "gtk-task-recurring") + ("images/mail/compose.xpm" . "gtk-mail-compose") + ("images/mail/copy.xpm" . "gtk-mail-copy") + ("images/mail/forward.xpm" . "gtk-mail-forward") + ("images/mail/inbox.xpm" . "gtk-inbox") + ("images/mail/move.xpm" . "gtk-mail-move") + ("images/mail/not-spam.xpm" . "gtk-not-spam") + ("images/mail/outbox.xpm" . "gtk-outbox") + ("images/mail/reply-all.xpm" . "gtk-mail-reply-to-all") + ("images/mail/reply.xpm" . "gtk-mail-reply") + ("images/mail/save-draft.xpm" . "gtk-mail-handling") + ("images/mail/send.xpm" . "gtk-mail-send") + ("images/mail/spam.xpm" . "gtk-spam") + ;; No themed versions available: + ;; mail/preview.xpm (combining stock_mail and stock_zoom) + ;; mail/save.xpm (combining stock_mail, stock_save and stock_convert) + ) + "How icons for tool bars are mapped to Gtk+ stock items. +Emacs must be compiled with the Gtk+ toolkit for this to have any effect. +A value that begins with n: denotes a named icon instead of a stock icon." + :version "22.2" + :type '(choice (repeat (choice symbol + (cons (string :tag "Emacs icon") + (string :tag "Stock/named"))))) + :group 'x) + +(defcustom icon-map-list '(x-gtk-stock-map) + "A list of alists that maps icon file names to stock/named icons. +The alists are searched in the order they appear. The first match is used. +The keys in the alists are file names without extension and with two directory +components. For example, to map /usr/share/emacs/22.1.1/etc/images/open.xpm +to stock item gtk-open, use: + + (\"etc/images/open\" . \"gtk-open\") + +Themes also have named icons. To map to one of those, use n: before the name: + + (\"etc/images/diropen\" . \"n:system-file-manager\") + +The list elements are either the symbol name for the alist or the +alist itself. + +If you don't want stock icons, set the variable to nil." + :version "22.2" + :type '(choice (const :tag "Don't use stock icons" nil) + (repeat (choice symbol + (cons (string :tag "Emacs icon") + (string :tag "Stock/named"))))) + :group 'x) + +(defun x-gtk-map-stock (file) + "Map icon with file name FILE to a Gtk+ stock name, using `x-gtk-stock-map'." + (let* ((file-sans (file-name-sans-extension file)) + (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)" file-sans) + (match-string 1 file-sans))) + (value)) + (mapc (lambda (elem) + (let ((assoc (if (symbolp elem) (symbol-value elem) elem))) + (or value (setq value (assoc-string (or key file-sans) assoc))))) + icon-map-list) + (and value (cdr value)))) + +(provide 'x-win) (defcustom x-gtk-stock-map '( - ("new" . "gtk-new") - ("open" . "gtk-open") - ("diropen" . "gtk-directory") - ("close" . "gtk-close") - ("save" . "gtk-save") - ("saveas" . "gtk-save-as") - ("undo" . "gtk-undo") - ("cut" . "gtk-cut") - ("copy" . "gtk-copy") - ("paste" . "gtk-paste") - ("search" . "gtk-find") - ("print" . "gtk-print") - ("preferences" . "gtk-preferences") - ("help" . "gtk-help") - ("left-arrow" . "gtk-go-back") - ("right-arrow" . "gtk-go-forward") - ("home" . "gtk-home") - ("jump-to" . "gtk-jump-to") - ("index" . "gtk-index") - ("search" . "gtk-find") - ("exit" . "gtk-quit")) + ("etc/images/new" . "gtk-new") + ("etc/images/open" . "gtk-open") + ("etc/images/diropen" . "n:system-file-manager") + ("etc/images/close" . "gtk-close") + ("etc/images/save" . "gtk-save") + ("etc/images/saveas" . "gtk-save-as") + ("etc/images/undo" . "gtk-undo") + ("etc/images/cut" . "gtk-cut") + ("etc/images/copy" . "gtk-copy") + ("etc/images/paste" . "gtk-paste") + ("etc/images/search" . "gtk-find") + ("etc/images/print" . "gtk-print") + ("etc/images/preferences" . "gtk-preferences") + ("etc/images/help" . "gtk-help") + ("etc/images/left-arrow" . "gtk-go-back") + ("etc/images/right-arrow" . "gtk-go-forward") + ("etc/images/home" . "gtk-home") + ("etc/images/jump-to" . "gtk-jump-to") + ("etc/images/index" . "gtk-index") + ("etc/images/search" . "gtk-find") + ("etc/images/exit" . "gtk-quit")) "How icons for tool bars are mapped to Gtk+ stock items. -Emacs must be compiled with the Gtk+ toolkit for this to have any effect." - :version "23.0" +Emacs must be compiled with the Gtk+ toolkit for this to have any effect. +A value that begins with n: denotes a named icon instead of a stock icon." + :version "22.2" :type 'alist :group 'x) +(defvar icon-map-list nil + "*A list of alists that maps icon file names to stock/named icons. +The alists are searched in the order they appear. The first match is used. +The keys in the alists are file names without extension and with two directory +components. For example, to map /usr/share/emacs/22.1.1/etc/images/open.xpm +to stock item gtk-open, use: + + (\"etc/images/open\" . \"gtk-open\") + +Themes also have named icons. To map to one of those, use n: before the name: + + (\"etc/images/diropen\" . \"n:system-file-manager\") + +The list elements are either the symbol name for the alist or the alist itself.") + (defun x-gtk-map-stock (file) "Map icon with file name FILE to a Gtk+ stock name, using `x-gtk-stock-map'." - (let ((value (and file - (assoc-string (file-name-sans-extension - (file-name-nondirectory file)) - x-gtk-stock-map)))) + (let* ((file-sans (file-name-sans-extension file)) + (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)" file-sans) + (match-string 1 file-sans))) + (value)) + (mapc (lambda (elem) + (let ((assoc (if (symbolp elem) (symbol-value elem) elem))) + (or value (setq value (assoc-string (or key file-sans) assoc))))) + icon-map-list) (and value (cdr value)))) ;; arch-tag: f1501302-db8b-4d95-88e3-116697d89f78 diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el index 5eb1d8b4c70..8326c920528 100644 --- a/lisp/term/xterm.el +++ b/lisp/term/xterm.el @@ -27,381 +27,452 @@ ;;; Code: +(eval-when-compile (require 'xt-mouse)) + +(defvar xterm-function-map + (let ((map (make-sparse-keymap))) + + ;; xterm from X.org 6.8.2 uses these key definitions. + (define-key map "\eOP" [f1]) + (define-key map "\eOQ" [f2]) + (define-key map "\eOR" [f3]) + (define-key map "\eOS" [f4]) + (define-key map "\e[15~" [f5]) + (define-key map "\e[17~" [f6]) + (define-key map "\e[18~" [f7]) + (define-key map "\e[19~" [f8]) + (define-key map "\e[20~" [f9]) + (define-key map "\e[21~" [f10]) + (define-key map "\e[23~" [f11]) + (define-key map "\e[24~" [f12]) + + (define-key map "\eO2P" [S-f1]) + (define-key map "\eO2Q" [S-f2]) + (define-key map "\eO2R" [S-f3]) + (define-key map "\eO2S" [S-f4]) + (define-key map "\e[1;2P" [S-f1]) + (define-key map "\e[1;2Q" [S-f2]) + (define-key map "\e[1;2R" [S-f3]) + (define-key map "\e[1;2S" [S-f4]) + (define-key map "\e[15;2~" [S-f5]) + (define-key map "\e[17;2~" [S-f6]) + (define-key map "\e[18;2~" [S-f7]) + (define-key map "\e[19;2~" [S-f8]) + (define-key map "\e[20;2~" [S-f9]) + (define-key map "\e[21;2~" [S-f10]) + (define-key map "\e[23;2~" [S-f11]) + (define-key map "\e[24;2~" [S-f12]) + + (define-key map "\eO5P" [C-f1]) + (define-key map "\eO5Q" [C-f2]) + (define-key map "\eO5R" [C-f3]) + (define-key map "\eO5S" [C-f4]) + (define-key map "\e[15;5~" [C-f5]) + (define-key map "\e[17;5~" [C-f6]) + (define-key map "\e[18;5~" [C-f7]) + (define-key map "\e[19;5~" [C-f8]) + (define-key map "\e[20;5~" [C-f9]) + (define-key map "\e[21;5~" [C-f10]) + (define-key map "\e[23;5~" [C-f11]) + (define-key map "\e[24;5~" [C-f12]) + + (define-key map "\eO6P" [C-S-f1]) + (define-key map "\eO6Q" [C-S-f2]) + (define-key map "\eO6R" [C-S-f3]) + (define-key map "\eO6S" [C-S-f4]) + (define-key map "\e[15;6~" [C-S-f5]) + (define-key map "\e[17;6~" [C-S-f6]) + (define-key map "\e[18;6~" [C-S-f7]) + (define-key map "\e[19;6~" [C-S-f8]) + (define-key map "\e[20;6~" [C-S-f9]) + (define-key map "\e[21;6~" [C-S-f10]) + (define-key map "\e[23;6~" [C-S-f11]) + (define-key map "\e[24;6~" [C-S-f12]) + + (define-key map "\eO3P" [A-f1]) + (define-key map "\eO3Q" [A-f2]) + (define-key map "\eO3R" [A-f3]) + (define-key map "\eO3S" [A-f4]) + (define-key map "\e[15;3~" [A-f5]) + (define-key map "\e[17;3~" [A-f6]) + (define-key map "\e[18;3~" [A-f7]) + (define-key map "\e[19;3~" [A-f8]) + (define-key map "\e[20;3~" [A-f9]) + (define-key map "\e[21;3~" [A-f10]) + (define-key map "\e[23;3~" [A-f11]) + (define-key map "\e[24;3~" [A-f12]) + + (define-key map "\eO4P" [M-S-f1]) + (define-key map "\eO4Q" [M-S-f2]) + (define-key map "\eO4R" [M-S-f3]) + (define-key map "\eO4S" [M-S-f4]) + (define-key map "\e[15;4~" [M-S-f5]) + (define-key map "\e[17;4~" [M-S-f6]) + (define-key map "\e[18;4~" [M-S-f7]) + (define-key map "\e[19;4~" [M-S-f8]) + (define-key map "\e[20;4~" [M-S-f9]) + (define-key map "\e[21;4~" [M-S-f10]) + (define-key map "\e[23;4~" [M-S-f11]) + (define-key map "\e[24;4~" [M-S-f12]) + + (define-key map "\eOA" [up]) + (define-key map "\eOB" [down]) + (define-key map "\eOC" [right]) + (define-key map "\eOD" [left]) + (define-key map "\eOF" [end]) + (define-key map "\eOH" [home]) + + (define-key map "\e[1;2A" [S-up]) + (define-key map "\e[1;2B" [S-down]) + (define-key map "\e[1;2C" [S-right]) + (define-key map "\e[1;2D" [S-left]) + (define-key map "\e[1;2F" [S-end]) + (define-key map "\e[1;2H" [S-home]) + + (define-key map "\e[1;4A" [M-S-up]) + (define-key map "\e[1;4B" [M-S-down]) + (define-key map "\e[1;4C" [M-S-right]) + (define-key map "\e[1;4D" [M-S-left]) + (define-key map "\e[1;4F" [M-S-end]) + (define-key map "\e[1;4H" [M-S-home]) + + (define-key map "\e[1;5A" [C-up]) + (define-key map "\e[1;5B" [C-down]) + (define-key map "\e[1;5C" [C-right]) + (define-key map "\e[1;5D" [C-left]) + (define-key map "\e[1;5F" [C-end]) + (define-key map "\e[1;5H" [C-home]) + + (define-key map "\e[1;6A" [C-S-up]) + (define-key map "\e[1;6B" [C-S-down]) + (define-key map "\e[1;6C" [C-S-right]) + (define-key map "\e[1;6D" [C-S-left]) + (define-key map "\e[1;6F" [C-S-end]) + (define-key map "\e[1;6H" [C-S-home]) + + (define-key map "\e[1;7A" [C-M-up]) + (define-key map "\e[1;7B" [C-M-down]) + (define-key map "\e[1;7C" [C-M-right]) + (define-key map "\e[1;7D" [C-M-left]) + (define-key map "\e[1;7F" [C-M-end]) + (define-key map "\e[1;7H" [C-M-home]) + + (define-key map "\e[1;8A" [C-M-S-up]) + (define-key map "\e[1;8B" [C-M-S-down]) + (define-key map "\e[1;8C" [C-M-S-right]) + (define-key map "\e[1;8D" [C-M-S-left]) + (define-key map "\e[1;8F" [C-M-S-end]) + (define-key map "\e[1;8H" [C-M-S-home]) + + (define-key map "\e[1;3A" [A-up]) + (define-key map "\e[1;3B" [A-down]) + (define-key map "\e[1;3C" [A-right]) + (define-key map "\e[1;3D" [A-left]) + (define-key map "\e[1;3F" [A-end]) + (define-key map "\e[1;3H" [A-home]) + + (define-key map "\e[2~" [insert]) + (define-key map "\e[3~" [delete]) + (define-key map "\e[5~" [prior]) + (define-key map "\e[6~" [next]) + + (define-key map "\e[2;2~" [S-insert]) + (define-key map "\e[3;2~" [S-delete]) + (define-key map "\e[5;2~" [S-prior]) + (define-key map "\e[6;2~" [S-next]) + + (define-key map "\e[2;4~" [M-S-insert]) + (define-key map "\e[3;4~" [M-S-delete]) + (define-key map "\e[5;4~" [M-S-prior]) + (define-key map "\e[6;4~" [M-S-next]) + + (define-key map "\e[2;5~" [C-insert]) + (define-key map "\e[3;5~" [C-delete]) + (define-key map "\e[5;5~" [C-prior]) + (define-key map "\e[6;5~" [C-next]) + + (define-key map "\e[2;6~" [C-S-insert]) + (define-key map "\e[3;6~" [C-S-delete]) + (define-key map "\e[5;6~" [C-S-prior]) + (define-key map "\e[6;6~" [C-S-next]) + + (define-key map "\e[2;7~" [C-M-insert]) + (define-key map "\e[3;7~" [C-M-delete]) + (define-key map "\e[5;7~" [C-M-prior]) + (define-key map "\e[6;7~" [C-M-next]) + + (define-key map "\e[2;8~" [C-M-S-insert]) + (define-key map "\e[3;8~" [C-M-S-delete]) + (define-key map "\e[5;8~" [C-M-S-prior]) + (define-key map "\e[6;8~" [C-M-S-next]) + + (define-key map "\e[2;3~" [A-insert]) + (define-key map "\e[3;3~" [A-delete]) + (define-key map "\e[5;3~" [A-prior]) + (define-key map "\e[6;3~" [A-next]) + + (define-key map "\e[4~" [select]) + (define-key map "\e[29~" [print]) + + (define-key map "\eOj" [kp-multiply]) + (define-key map "\eOk" [kp-add]) + (define-key map "\eOl" [kp-separator]) + (define-key map "\eOm" [kp-subtract]) + (define-key map "\eOo" [kp-divide]) + (define-key map "\eOp" [kp-0]) + (define-key map "\eOq" [kp-1]) + (define-key map "\eOr" [kp-2]) + (define-key map "\eOs" [kp-3]) + (define-key map "\eOt" [kp-4]) + (define-key map "\eOu" [kp-5]) + (define-key map "\eOv" [kp-6]) + (define-key map "\eOw" [kp-7]) + (define-key map "\eOx" [kp-8]) + (define-key map "\eOy" [kp-9]) + + ;; These keys are available in xterm starting from version 216 + ;; if the modifyOtherKeys resource is set to 1. + + (define-key map "\e[27;5;9~" [C-tab]) + (define-key map "\e[27;5;13~" [C-return]) + (define-key map "\e[27;5;39~" [?\C-\']) + (define-key map "\e[27;5;44~" [?\C-,]) + (define-key map "\e[27;5;45~" [?\C--]) + (define-key map "\e[27;5;46~" [?\C-.]) + (define-key map "\e[27;5;47~" [?\C-/]) + (define-key map "\e[27;5;48~" [?\C-0]) + (define-key map "\e[27;5;49~" [?\C-1]) + ;; Not all C-DIGIT keys have a distinct binding. + (define-key map "\e[27;5;57~" [?\C-9]) + (define-key map "\e[27;5;59~" [?\C-\;]) + (define-key map "\e[27;5;61~" [?\C-=]) + (define-key map "\e[27;5;92~" [?\C-\\]) + + (define-key map "\e[27;6;33~" [?\C-!]) + (define-key map "\e[27;6;34~" [?\C-\"]) + (define-key map "\e[27;6;35~" [?\C-#]) + (define-key map "\e[27;6;36~" [?\C-$]) + (define-key map "\e[27;6;37~" [?\C-%]) + (define-key map "\e[27;6;38~" [?\C-&]) + (define-key map "\e[27;6;40~" [?\C-(]) + (define-key map "\e[27;6;41~" [?\C-)]) + (define-key map "\e[27;6;42~" [?\C-*]) + (define-key map "\e[27;6;43~" [?\C-+]) + (define-key map "\e[27;6;58~" [?\C-:]) + (define-key map "\e[27;6;60~" [?\C-<]) + (define-key map "\e[27;6;62~" [?\C->]) + (define-key map "\e[27;6;63~" [(control ??)]) + + ;; These are the strings emitted for various C-M- combinations + ;; for keyboards that the Meta and Alt modifiers are on the same + ;; key (usually labeled "Alt"). + (define-key map "\e[27;13;9~" [C-M-tab]) + (define-key map "\e[27;13;13~" [C-M-return]) + + (define-key map "\e[27;13;39~" [?\C-\M-\']) + (define-key map "\e[27;13;44~" [?\C-\M-,]) + (define-key map "\e[27;13;45~" [?\C-\M--]) + (define-key map "\e[27;13;46~" [?\C-\M-.]) + (define-key map "\e[27;13;47~" [?\C-\M-/]) + (define-key map "\e[27;13;48~" [?\C-\M-0]) + (define-key map "\e[27;13;49~" [?\C-\M-1]) + (define-key map "\e[27;13;50~" [?\C-\M-2]) + (define-key map "\e[27;13;51~" [?\C-\M-3]) + (define-key map "\e[27;13;52~" [?\C-\M-4]) + (define-key map "\e[27;13;53~" [?\C-\M-5]) + (define-key map "\e[27;13;54~" [?\C-\M-6]) + (define-key map "\e[27;13;55~" [?\C-\M-7]) + (define-key map "\e[27;13;56~" [?\C-\M-8]) + (define-key map "\e[27;13;57~" [?\C-\M-9]) + (define-key map "\e[27;13;59~" [?\C-\M-\;]) + (define-key map "\e[27;13;61~" [?\C-\M-=]) + (define-key map "\e[27;13;92~" [?\C-\M-\\]) + + (define-key map "\e[27;14;33~" [?\C-\M-!]) + (define-key map "\e[27;14;34~" [?\C-\M-\"]) + (define-key map "\e[27;14;35~" [?\C-\M-#]) + (define-key map "\e[27;14;36~" [?\C-\M-$]) + (define-key map "\e[27;14;37~" [?\C-\M-%]) + (define-key map "\e[27;14;38~" [?\C-\M-&]) + (define-key map "\e[27;14;40~" [?\C-\M-\(]) + (define-key map "\e[27;14;41~" [?\C-\M-\)]) + (define-key map "\e[27;14;42~" [?\C-\M-*]) + (define-key map "\e[27;14;43~" [?\C-\M-+]) + (define-key map "\e[27;14;58~" [?\C-\M-:]) + (define-key map "\e[27;14;60~" [?\C-\M-<]) + (define-key map "\e[27;14;62~" [?\C-\M->]) + (define-key map "\e[27;14;63~" [(control meta ??)]) + + (define-key map "\e[27;7;9~" [C-M-tab]) + (define-key map "\e[27;7;13~" [C-M-return]) + + (define-key map "\e[27;7;32~" [?\C-\M-\s]) + (define-key map "\e[27;7;39~" [?\C-\M-\']) + (define-key map "\e[27;7;44~" [?\C-\M-,]) + (define-key map "\e[27;7;45~" [?\C-\M--]) + (define-key map "\e[27;7;46~" [?\C-\M-.]) + (define-key map "\e[27;7;47~" [?\C-\M-/]) + (define-key map "\e[27;7;48~" [?\C-\M-0]) + (define-key map "\e[27;7;49~" [?\C-\M-1]) + (define-key map "\e[27;7;50~" [?\C-\M-2]) + (define-key map "\e[27;7;51~" [?\C-\M-3]) + (define-key map "\e[27;7;52~" [?\C-\M-4]) + (define-key map "\e[27;7;53~" [?\C-\M-5]) + (define-key map "\e[27;7;54~" [?\C-\M-6]) + (define-key map "\e[27;7;55~" [?\C-\M-7]) + (define-key map "\e[27;7;56~" [?\C-\M-8]) + (define-key map "\e[27;7;57~" [?\C-\M-9]) + (define-key map "\e[27;7;59~" [?\C-\M-\;]) + (define-key map "\e[27;7;61~" [?\C-\M-=]) + (define-key map "\e[27;7;92~" [?\C-\M-\\]) + + (define-key map "\e[27;8;33~" [?\C-\M-!]) + (define-key map "\e[27;8;34~" [?\C-\M-\"]) + (define-key map "\e[27;8;35~" [?\C-\M-#]) + (define-key map "\e[27;8;36~" [?\C-\M-$]) + (define-key map "\e[27;8;37~" [?\C-\M-%]) + (define-key map "\e[27;8;38~" [?\C-\M-&]) + (define-key map "\e[27;8;40~" [?\C-\M-\(]) + (define-key map "\e[27;8;41~" [?\C-\M-\)]) + (define-key map "\e[27;8;42~" [?\C-\M-*]) + (define-key map "\e[27;8;43~" [?\C-\M-+]) + (define-key map "\e[27;8;58~" [?\C-\M-:]) + (define-key map "\e[27;8;60~" [?\C-\M-<]) + (define-key map "\e[27;8;62~" [?\C-\M->]) + (define-key map "\e[27;8;63~" [(control meta ??)]) + + (define-key map "\e[27;2;9~" [S-tab]) + (define-key map "\e[27;2;13~" [S-return]) + + (define-key map "\e[27;6;9~" [C-S-tab]) + (define-key map "\e[27;6;13~" [C-S-return]) + + ;; Other versions of xterm might emit these. + (define-key map "\e[A" [up]) + (define-key map "\e[B" [down]) + (define-key map "\e[C" [right]) + (define-key map "\e[D" [left]) + (define-key map "\e[1~" [home]) + + (define-key map "\eO2A" [S-up]) + (define-key map "\eO2B" [S-down]) + (define-key map "\eO2C" [S-right]) + (define-key map "\eO2D" [S-left]) + (define-key map "\eO2F" [S-end]) + (define-key map "\eO2H" [S-home]) + + (define-key map "\eO5A" [C-up]) + (define-key map "\eO5B" [C-down]) + (define-key map "\eO5C" [C-right]) + (define-key map "\eO5D" [C-left]) + (define-key map "\eO5F" [C-end]) + (define-key map "\eO5H" [C-home]) + + (define-key map "\e[11~" [f1]) + (define-key map "\e[12~" [f2]) + (define-key map "\e[13~" [f3]) + (define-key map "\e[14~" [f4]) + map) + "Function key map overrides for xterm.") + +(defvar xterm-alternatives-map + (let ((map (make-sparse-keymap))) + ;; The terminal initialization C code file might have initialized + ;; function keys F13->F60 from the termcap/terminfo information. + ;; On a PC-style keyboard these keys correspond to + ;; MODIFIER-FUNCTION_KEY, where modifier is S-, C, A-, C-S-. The code + ;; here substitutes the corresponding definitions in function-key-map. + ;; The mapping from escape sequences to Fn is done in input-decode-map + ;; whereas this here mapping is done in local-function-key-map so that + ;; bindings to f45 still work, in case your keyboard really has an f45 + ;; key rather than C-S-f9. + (define-key map [f13] [S-f1]) + (define-key map [f14] [S-f2]) + (define-key map [f15] [S-f3]) + (define-key map [f16] [S-f4]) + (define-key map [f17] [S-f5]) + (define-key map [f18] [S-f6]) + (define-key map [f19] [S-f7]) + (define-key map [f20] [S-f8]) + (define-key map [f21] [S-f9]) + (define-key map [f22] [S-f10]) + (define-key map [f23] [S-f11]) + (define-key map [f24] [S-f12]) + + (define-key map [f25] [C-f1]) + (define-key map [f26] [C-f2]) + (define-key map [f27] [C-f3]) + (define-key map [f28] [C-f4]) + (define-key map [f29] [C-f5]) + (define-key map [f30] [C-f6]) + (define-key map [f31] [C-f7]) + (define-key map [f32] [C-f8]) + (define-key map [f33] [C-f9]) + (define-key map [f34] [C-f10]) + (define-key map [f35] [C-f11]) + (define-key map [f36] [C-f12]) + + (define-key map [f37] [C-S-f1]) + (define-key map [f38] [C-S-f2]) + (define-key map [f39] [C-S-f3]) + (define-key map [f40] [C-S-f4]) + (define-key map [f41] [C-S-f5]) + (define-key map [f42] [C-S-f6]) + (define-key map [f43] [C-S-f7]) + (define-key map [f44] [C-S-f8]) + (define-key map [f45] [C-S-f9]) + (define-key map [f46] [C-S-f10]) + (define-key map [f47] [C-S-f11]) + (define-key map [f48] [C-S-f12]) + + (define-key map [f49] [A-f1]) + (define-key map [f50] [A-f2]) + (define-key map [f51] [A-f3]) + (define-key map [f52] [A-f4]) + (define-key map [f53] [A-f5]) + (define-key map [f54] [A-f6]) + (define-key map [f55] [A-f7]) + (define-key map [f56] [A-f8]) + (define-key map [f57] [A-f9]) + (define-key map [f58] [A-f10]) + (define-key map [f59] [A-f11]) + (define-key map [f60] [A-f12]) + + map) + "Keymap of possible alternative meanings for some keys.") + +;; List of terminals for which modify-other-keys has been turned on. +(defvar xterm-modify-other-keys-terminal-list nil) + (defun terminal-init-xterm () "Terminal initialization function for xterm." ;; rxvt terminals sometimes set the TERM variable to "xterm", but - ;; rxvt's keybindings that are incompatible with xterm's. It is + ;; rxvt's keybindings are incompatible with xterm's. It is ;; better in that case to use rxvt's initializion function. - (if (and (getenv "COLORTERM") - (string-match "\\`rxvt" (getenv "COLORTERM"))) - (progn - (eval-and-compile (load "term/rxvt")) - (terminal-init-rxvt)) - - ;; The terminal intialization C code file might have initialized - ;; function keys F13->F60 from the termcap/terminfo information. On - ;; a PC-style keyboard these keys correspond to - ;; MODIFIER-FUNCTION_KEY, where modifier is S-, C, A-, C-S-. The - ;; code here subsitutes the corresponding defintions in - ;; function-key-map. This substitution is needed because if a key - ;; definition is found in function-key-map, there are no further - ;; lookups in other keymaps. - (substitute-key-definition [f13] [S-f1] function-key-map) - (substitute-key-definition [f14] [S-f2] function-key-map) - (substitute-key-definition [f15] [S-f3] function-key-map) - (substitute-key-definition [f16] [S-f4] function-key-map) - (substitute-key-definition [f17] [S-f5] function-key-map) - (substitute-key-definition [f18] [S-f6] function-key-map) - (substitute-key-definition [f19] [S-f7] function-key-map) - (substitute-key-definition [f20] [S-f8] function-key-map) - (substitute-key-definition [f21] [S-f9] function-key-map) - (substitute-key-definition [f22] [S-f10] function-key-map) - (substitute-key-definition [f23] [S-f11] function-key-map) - (substitute-key-definition [f24] [S-f12] function-key-map) - - (substitute-key-definition [f25] [C-f1] function-key-map) - (substitute-key-definition [f26] [C-f2] function-key-map) - (substitute-key-definition [f27] [C-f3] function-key-map) - (substitute-key-definition [f28] [C-f4] function-key-map) - (substitute-key-definition [f29] [C-f5] function-key-map) - (substitute-key-definition [f30] [C-f6] function-key-map) - (substitute-key-definition [f31] [C-f7] function-key-map) - (substitute-key-definition [f32] [C-f8] function-key-map) - (substitute-key-definition [f33] [C-f9] function-key-map) - (substitute-key-definition [f34] [C-f10] function-key-map) - (substitute-key-definition [f35] [C-f11] function-key-map) - (substitute-key-definition [f36] [C-f12] function-key-map) - - (substitute-key-definition [f37] [C-S-f1] function-key-map) - (substitute-key-definition [f38] [C-S-f2] function-key-map) - (substitute-key-definition [f39] [C-S-f3] function-key-map) - (substitute-key-definition [f40] [C-S-f4] function-key-map) - (substitute-key-definition [f41] [C-S-f5] function-key-map) - (substitute-key-definition [f42] [C-S-f6] function-key-map) - (substitute-key-definition [f43] [C-S-f7] function-key-map) - (substitute-key-definition [f44] [C-S-f8] function-key-map) - (substitute-key-definition [f45] [C-S-f9] function-key-map) - (substitute-key-definition [f46] [C-S-f10] function-key-map) - (substitute-key-definition [f47] [C-S-f11] function-key-map) - (substitute-key-definition [f48] [C-S-f12] function-key-map) - - (substitute-key-definition [f49] [A-f1] function-key-map) - (substitute-key-definition [f50] [A-f2] function-key-map) - (substitute-key-definition [f51] [A-f3] function-key-map) - (substitute-key-definition [f52] [A-f4] function-key-map) - (substitute-key-definition [f53] [A-f5] function-key-map) - (substitute-key-definition [f54] [A-f6] function-key-map) - (substitute-key-definition [f55] [A-f7] function-key-map) - (substitute-key-definition [f56] [A-f8] function-key-map) - (substitute-key-definition [f57] [A-f9] function-key-map) - (substitute-key-definition [f58] [A-f10] function-key-map) - (substitute-key-definition [f59] [A-f11] function-key-map) - (substitute-key-definition [f60] [A-f12] function-key-map) - - (let ((map (make-sparse-keymap))) - ;; xterm from X.org 6.8.2 uses these key definitions. - (define-key map "\eOP" [f1]) - (define-key map "\eOQ" [f2]) - (define-key map "\eOR" [f3]) - (define-key map "\eOS" [f4]) - (define-key map "\e[15~" [f5]) - (define-key map "\e[17~" [f6]) - (define-key map "\e[18~" [f7]) - (define-key map "\e[19~" [f8]) - (define-key map "\e[20~" [f9]) - (define-key map "\e[21~" [f10]) - (define-key map "\e[23~" [f11]) - (define-key map "\e[24~" [f12]) - - (define-key map "\eO2P" [S-f1]) - (define-key map "\eO2Q" [S-f2]) - (define-key map "\eO2R" [S-f3]) - (define-key map "\eO2S" [S-f4]) - (define-key map "\e[1;2P" [S-f1]) - (define-key map "\e[1;2Q" [S-f2]) - (define-key map "\e[1;2R" [S-f3]) - (define-key map "\e[1;2S" [S-f4]) - (define-key map "\e[15;2~" [S-f5]) - (define-key map "\e[17;2~" [S-f6]) - (define-key map "\e[18;2~" [S-f7]) - (define-key map "\e[19;2~" [S-f8]) - (define-key map "\e[20;2~" [S-f9]) - (define-key map "\e[21;2~" [S-f10]) - (define-key map "\e[23;2~" [S-f11]) - (define-key map "\e[24;2~" [S-f12]) - - (define-key map "\eO5P" [C-f1]) - (define-key map "\eO5Q" [C-f2]) - (define-key map "\eO5R" [C-f3]) - (define-key map "\eO5S" [C-f4]) - (define-key map "\e[15;5~" [C-f5]) - (define-key map "\e[17;5~" [C-f6]) - (define-key map "\e[18;5~" [C-f7]) - (define-key map "\e[19;5~" [C-f8]) - (define-key map "\e[20;5~" [C-f9]) - (define-key map "\e[21;5~" [C-f10]) - (define-key map "\e[23;5~" [C-f11]) - (define-key map "\e[24;5~" [C-f12]) - - (define-key map "\eO6P" [C-S-f1]) - (define-key map "\eO6Q" [C-S-f2]) - (define-key map "\eO6R" [C-S-f3]) - (define-key map "\eO6S" [C-S-f4]) - (define-key map "\e[15;6~" [C-S-f5]) - (define-key map "\e[17;6~" [C-S-f6]) - (define-key map "\e[18;6~" [C-S-f7]) - (define-key map "\e[19;6~" [C-S-f8]) - (define-key map "\e[20;6~" [C-S-f9]) - (define-key map "\e[21;6~" [C-S-f10]) - (define-key map "\e[23;6~" [C-S-f11]) - (define-key map "\e[24;6~" [C-S-f12]) - - (define-key map "\eO3P" [A-f1]) - (define-key map "\eO3Q" [A-f2]) - (define-key map "\eO3R" [A-f3]) - (define-key map "\eO3S" [A-f4]) - (define-key map "\e[15;3~" [A-f5]) - (define-key map "\e[17;3~" [A-f6]) - (define-key map "\e[18;3~" [A-f7]) - (define-key map "\e[19;3~" [A-f8]) - (define-key map "\e[20;3~" [A-f9]) - (define-key map "\e[21;3~" [A-f10]) - (define-key map "\e[23;3~" [A-f11]) - (define-key map "\e[24;3~" [A-f12]) - - (define-key map "\eOA" [up]) - (define-key map "\eOB" [down]) - (define-key map "\eOC" [right]) - (define-key map "\eOD" [left]) - (define-key map "\eOF" [end]) - (define-key map "\eOH" [home]) - - (define-key map "\e[1;2A" [S-up]) - (define-key map "\e[1;2B" [S-down]) - (define-key map "\e[1;2C" [S-right]) - (define-key map "\e[1;2D" [S-left]) - (define-key map "\e[1;2F" [S-end]) - (define-key map "\e[1;2H" [S-home]) - - (define-key map "\e[1;5A" [C-up]) - (define-key map "\e[1;5B" [C-down]) - (define-key map "\e[1;5C" [C-right]) - (define-key map "\e[1;5D" [C-left]) - (define-key map "\e[1;5F" [C-end]) - (define-key map "\e[1;5H" [C-home]) - - (define-key map "\e[1;6A" [C-S-up]) - (define-key map "\e[1;6B" [C-S-down]) - (define-key map "\e[1;6C" [C-S-right]) - (define-key map "\e[1;6D" [C-S-left]) - (define-key map "\e[1;6F" [C-S-end]) - (define-key map "\e[1;6H" [C-S-home]) - - (define-key map "\e[1;3A" [A-up]) - (define-key map "\e[1;3B" [A-down]) - (define-key map "\e[1;3C" [A-right]) - (define-key map "\e[1;3D" [A-left]) - (define-key map "\e[1;3F" [A-end]) - (define-key map "\e[1;3H" [A-home]) - - (define-key map "\e[2~" [insert]) - (define-key map "\e[3~" [delete]) - (define-key map "\e[5~" [prior]) - (define-key map "\e[6~" [next]) - - (define-key map "\e[2;2~" [S-insert]) - (define-key map "\e[3;2~" [S-delete]) - (define-key map "\e[5;2~" [S-prior]) - (define-key map "\e[6;2~" [S-next]) - - (define-key map "\e[2;5~" [C-insert]) - (define-key map "\e[3;5~" [C-delete]) - (define-key map "\e[5;5~" [C-prior]) - (define-key map "\e[6;5~" [C-next]) - - (define-key map "\e[2;6~" [C-S-insert]) - (define-key map "\e[3;6~" [C-S-delete]) - (define-key map "\e[5;6~" [C-S-prior]) - (define-key map "\e[6;6~" [C-S-next]) - - (define-key map "\e[2;3~" [A-insert]) - (define-key map "\e[3;3~" [A-delete]) - (define-key map "\e[5;3~" [A-prior]) - (define-key map "\e[6;3~" [A-next]) - - (define-key map "\e[4~" [select]) - (define-key map "\e[29~" [print]) - - (define-key map "\eOj" [kp-multiply]) - (define-key map "\eOk" [kp-add]) - (define-key map "\eOl" [kp-separator]) - (define-key map "\eOm" [kp-subtract]) - (define-key map "\eOo" [kp-divide]) - (define-key map "\eOp" [kp-0]) - (define-key map "\eOq" [kp-1]) - (define-key map "\eOr" [kp-2]) - (define-key map "\eOs" [kp-3]) - (define-key map "\eOt" [kp-4]) - (define-key map "\eOu" [kp-5]) - (define-key map "\eOv" [kp-6]) - (define-key map "\eOw" [kp-7]) - (define-key map "\eOx" [kp-8]) - (define-key map "\eOy" [kp-9]) - - ;; These keys are available in xterm starting from version 216 - ;; if the modifyOtherKeys resource is set to 1. - - (define-key map "\e[27;5;9~" [C-tab]) - (define-key map "\e[27;5;13~" [C-return]) - (define-key map "\e[27;5;39~" [?\C-\']) - (define-key map "\e[27;5;44~" [?\C-,]) - (define-key map "\e[27;5;45~" [?\C--]) - (define-key map "\e[27;5;46~" [?\C-.]) - (define-key map "\e[27;5;47~" [?\C-/]) - (define-key map "\e[27;5;48~" [?\C-0]) - (define-key map "\e[27;5;49~" [?\C-1]) - ;; Not all C-DIGIT keys have a distinct binding. - (define-key map "\e[27;5;57~" [?\C-9]) - (define-key map "\e[27;5;59~" [?\C-\;]) - (define-key map "\e[27;5;61~" [?\C-=]) - (define-key map "\e[27;5;92~" [?\C-\\]) - - (define-key map "\e[27;6;33~" [?\C-!]) - (define-key map "\e[27;6;34~" [?\C-\"]) - (define-key map "\e[27;6;35~" [?\C-#]) - (define-key map "\e[27;6;36~" [?\C-$]) - (define-key map "\e[27;6;37~" [?\C-%]) - (define-key map "\e[27;6;38~" [?\C-&]) - (define-key map "\e[27;6;40~" [?\C-\(]) - (define-key map "\e[27;6;41~" [?\C-\)]) - (define-key map "\e[27;6;42~" [?\C-*]) - (define-key map "\e[27;6;43~" [?\C-+]) - (define-key map "\e[27;6;58~" [?\C-:]) - (define-key map "\e[27;6;60~" [?\C-<]) - (define-key map "\e[27;6;62~" [?\C->]) - (define-key map "\e[27;6;63~" [(control ??)]) - - ;; These are the strings emitted for various C-M- combinations - ;; for keyboards that the Meta and Alt modifiers are on the same - ;; key (usually labeled "Alt"). - (define-key map "\e[27;13;9~" [C-M-tab]) - (define-key map "\e[27;13;13~" [C-M-return]) - - (define-key map "\e[27;13;39~" [?\C-\M-\']) - (define-key map "\e[27;13;44~" [?\C-\M-,]) - (define-key map "\e[27;13;45~" [?\C-\M--]) - (define-key map "\e[27;13;46~" [?\C-\M-.]) - (define-key map "\e[27;13;47~" [?\C-\M-/]) - (define-key map "\e[27;13;48~" [?\C-\M-0]) - (define-key map "\e[27;13;49~" [?\C-\M-1]) - (define-key map "\e[27;13;50~" [?\C-\M-2]) - (define-key map "\e[27;13;51~" [?\C-\M-3]) - (define-key map "\e[27;13;52~" [?\C-\M-4]) - (define-key map "\e[27;13;53~" [?\C-\M-5]) - (define-key map "\e[27;13;54~" [?\C-\M-6]) - (define-key map "\e[27;13;55~" [?\C-\M-7]) - (define-key map "\e[27;13;56~" [?\C-\M-8]) - (define-key map "\e[27;13;57~" [?\C-\M-9]) - (define-key map "\e[27;13;59~" [?\C-\M-\;]) - (define-key map "\e[27;13;61~" [?\C-\M-=]) - (define-key map "\e[27;13;92~" [?\C-\M-\\]) - - (define-key map "\e[27;14;33~" [?\C-\M-!]) - (define-key map "\e[27;14;34~" [?\C-\M-\"]) - (define-key map "\e[27;14;35~" [?\C-\M-#]) - (define-key map "\e[27;14;36~" [?\C-\M-$]) - (define-key map "\e[27;14;37~" [?\C-\M-%]) - (define-key map "\e[27;14;38~" [?\C-\M-&]) - (define-key map "\e[27;14;40~" [?\C-\M-\(]) - (define-key map "\e[27;14;41~" [?\C-\M-\)]) - (define-key map "\e[27;14;42~" [?\C-\M-*]) - (define-key map "\e[27;14;43~" [?\C-\M-+]) - (define-key map "\e[27;14;58~" [?\C-\M-:]) - (define-key map "\e[27;14;60~" [?\C-\M-<]) - (define-key map "\e[27;14;62~" [?\C-\M->]) - (define-key map "\e[27;14;63~" [(control meta ??)]) - - (define-key map "\e[27;7;9~" [C-M-tab]) - (define-key map "\e[27;7;13~" [C-M-return]) - - (define-key map "\e[27;7;32~" [?\C-\M-\s]) - (define-key map "\e[27;7;39~" [?\C-\M-\']) - (define-key map "\e[27;7;44~" [?\C-\M-,]) - (define-key map "\e[27;7;45~" [?\C-\M--]) - (define-key map "\e[27;7;46~" [?\C-\M-.]) - (define-key map "\e[27;7;47~" [?\C-\M-/]) - (define-key map "\e[27;7;48~" [?\C-\M-0]) - (define-key map "\e[27;7;49~" [?\C-\M-1]) - (define-key map "\e[27;7;50~" [?\C-\M-2]) - (define-key map "\e[27;7;51~" [?\C-\M-3]) - (define-key map "\e[27;7;52~" [?\C-\M-4]) - (define-key map "\e[27;7;53~" [?\C-\M-5]) - (define-key map "\e[27;7;54~" [?\C-\M-6]) - (define-key map "\e[27;7;55~" [?\C-\M-7]) - (define-key map "\e[27;7;56~" [?\C-\M-8]) - (define-key map "\e[27;7;57~" [?\C-\M-9]) - (define-key map "\e[27;7;59~" [?\C-\M-\;]) - (define-key map "\e[27;7;61~" [?\C-\M-=]) - (define-key map "\e[27;7;92~" [?\C-\M-\\]) - - (define-key map "\e[27;8;33~" [?\C-\M-!]) - (define-key map "\e[27;8;34~" [?\C-\M-\"]) - (define-key map "\e[27;8;35~" [?\C-\M-#]) - (define-key map "\e[27;8;36~" [?\C-\M-$]) - (define-key map "\e[27;8;37~" [?\C-\M-%]) - (define-key map "\e[27;8;38~" [?\C-\M-&]) - (define-key map "\e[27;8;40~" [?\C-\M-\(]) - (define-key map "\e[27;8;41~" [?\C-\M-\)]) - (define-key map "\e[27;8;42~" [?\C-\M-*]) - (define-key map "\e[27;8;43~" [?\C-\M-+]) - (define-key map "\e[27;8;58~" [?\C-\M-:]) - (define-key map "\e[27;8;60~" [?\C-\M-<]) - (define-key map "\e[27;8;62~" [?\C-\M->]) - (define-key map "\e[27;8;63~" [(control meta ??)]) - - (define-key map "\e[27;2;9~" [S-tab]) - (define-key map "\e[27;2;13~" [S-return]) - - (define-key map "\e[27;6;9~" [C-S-tab]) - (define-key map "\e[27;6;13~" [C-S-return]) - - ;; Other versions of xterm might emit these. - (define-key map "\e[A" [up]) - (define-key map "\e[B" [down]) - (define-key map "\e[C" [right]) - (define-key map "\e[D" [left]) - (define-key map "\e[1~" [home]) - - (define-key map "\eO2A" [S-up]) - (define-key map "\eO2B" [S-down]) - (define-key map "\eO2C" [S-right]) - (define-key map "\eO2D" [S-left]) - (define-key map "\eO2F" [S-end]) - (define-key map "\eO2H" [S-home]) - - (define-key map "\eO5A" [C-up]) - (define-key map "\eO5B" [C-down]) - (define-key map "\eO5C" [C-right]) - (define-key map "\eO5D" [C-left]) - (define-key map "\eO5F" [C-end]) - (define-key map "\eO5H" [C-home]) - - (define-key map "\e[11~" [f1]) - (define-key map "\e[12~" [f2]) - (define-key map "\e[13~" [f3]) - (define-key map "\e[14~" [f4]) + (if (and (getenv "COLORTERM" (selected-frame)) + (string-match "\\`rxvt" (getenv "COLORTERM" (selected-frame)))) + (tty-run-terminal-initialization (selected-frame) "rxvt") + + (let ((map (copy-keymap xterm-alternatives-map))) + (set-keymap-parent map (keymap-parent local-function-key-map)) + (set-keymap-parent local-function-key-map map)) + + (let ((map (copy-keymap xterm-function-map))) ;; Use inheritance to let the main keymap override those defaults. ;; This way we don't override terminfo-derived settings or settings ;; made in the .emacs file. - (set-keymap-parent map (keymap-parent function-key-map)) - (set-keymap-parent function-key-map map)) + (set-keymap-parent map (keymap-parent input-decode-map)) + (set-keymap-parent input-decode-map map))) - ;; Do it! (xterm-register-default-colors) ;; This recomputes all the default faces given the colors we've just set up. (tty-set-up-initial-frame-faces) - + + (when xterm-mouse-mode + (turn-on-xterm-mouse-tracking-on-terminal + (frame-terminal (selected-frame)))) + ;; Try to turn on the modifyOtherKeys feature on modern xterms. ;; When it is turned on much more key bindings work: things like ;; C-. C-, etc. @@ -423,14 +494,19 @@ ;; NUMBER2 is the xterm version number, look for something ;; greater than 216, the version when modifyOtherKeys was ;; introduced. - (when (>= (string-to-number + (when (>= (string-to-number (substring str (match-beginning 1) (match-end 1))) 216) ;; Make sure that the modifyOtherKeys state is restored when ;; suspending, resuming and exiting. (add-hook 'suspend-hook 'xterm-turn-off-modify-other-keys) (add-hook 'suspend-resume-hook 'xterm-turn-on-modify-other-keys) - (add-hook 'kill-emacs-hook 'xterm-turn-off-modify-other-keys) - (xterm-turn-on-modify-other-keys)))))))) + (add-hook 'kill-emacs-hook 'xterm-remove-modify-other-keys) + (add-hook 'delete-frame-hook 'xterm-remove-modify-other-keys) + ;; Add the selected frame to the list of frames that + ;; need to deal with modify-other-keys. + (push (frame-terminal (selected-frame)) + xterm-modify-other-keys-terminal-list) + (xterm-turn-on-modify-other-keys))))))) ;; Set up colors, for those versions of xterm that support it. (defvar xterm-standard-colors @@ -467,7 +543,7 @@ for the currently selected frame. The first 16 colors are taken from `xterm-standard-colors', which see, while the rest are computed assuming either the 88- or 256-color standard color scheme supported by latest versions of xterm." - (let* ((ncolors (display-color-cells)) + (let* ((ncolors (display-color-cells (selected-frame))) (colors xterm-standard-colors) (color (car colors))) (if (> ncolors 0) @@ -550,11 +626,27 @@ versions of xterm." (defun xterm-turn-on-modify-other-keys () "Turn on the modifyOtherKeys feature of xterm." - (send-string-to-terminal "\e[>4;1m")) + (let ((frame (selected-frame))) + (when (and (frame-live-p frame) + (memq frame xterm-modify-other-keys-terminal-list)) + (send-string-to-terminal "\e[>4;1m")))) -(defun xterm-turn-off-modify-other-keys () +(defun xterm-turn-off-modify-other-keys (&optional frame) "Turn off the modifyOtherKeys feature of xterm." - (send-string-to-terminal "\e[>4m")) + (setq frame (and frame (selected-frame))) + (when (and (frame-live-p frame) + (memq frame xterm-modify-other-keys-terminal-list)) + (send-string-to-terminal "\e[>4m"))) + +(defun xterm-remove-modify-other-keys (&optional frame) + "Turn off the modifyOtherKeys feature of xterm and remove frame from consideration." + (setq frame (and frame (selected-frame))) + (when (and (frame-live-p frame) + (memq frame xterm-modify-other-keys-terminal-list)) + (setq xterm-modify-other-keys-terminal-list + (delq (frame-terminal frame) + xterm-modify-other-keys-terminal-list)) + (send-string-to-terminal "\e[>4m"))) ;; arch-tag: 12e7ebdd-1e6c-4b25-b0f9-35ace25e855a ;;; xterm.el ends here |