summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ChangeLog39
-rw-r--r--lisp/calc/calc-trail.el28
-rw-r--r--lisp/emacs-lisp/smie.el210
-rw-r--r--lisp/net/secrets.el149
-rw-r--r--lisp/subr.el10
5 files changed, 325 insertions, 111 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index d0fc357c4ea..545311d6530 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -4,6 +4,43 @@
composition-function-table only for combining characters (Mn, Mc,
Me).
+2010-05-18 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-trail.el (calc-trail-isearch-forward)
+ (calc-trail-isearch-backward): Ensure that the new window
+ point is set correctly.
+
+2010-05-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (read-quoted-char): Resolve modifiers after key
+ remapping (bug#6212).
+
+2010-05-18 Michael Albinus <michael.albinus@gmx.de>
+
+ Add visualization code for secrets.
+ * net/secrets.el (secrets-mode): New major mode.
+ (secrets-show-secrets, secrets-show-collections)
+ (secrets-expand-collection, secrets-expand-item)
+ (secrets-tree-widget-after-toggle-function)
+ (secrets-tree-widget-show-password): New defuns.
+
+2010-05-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-next-sexp): Break inf-loop at BOB.
+ (smie-backward-sexp, smie-forward-sexp): Remove boundary condition now
+ handled in smie-next-sexp.
+ (smie-indent-calculate): Provide a starting indentation (so the
+ recursion is well-founded ;-).
+
+ Fix handling of non-associative equal levels.
+ * emacs-lisp/smie.el (smie-prec2-levels): Choose distinct levels even
+ when it's not needed.
+ (smie-op-left, smie-op-right): New functions.
+ (smie-next-sexp): New function, extracted from smie-backward-sexp.
+ Better handle equal levels to distinguish the associative case from
+ the "multi-keyword construct" case.
+ (smie-backward-sexp, smie-forward-sexp): Use it.
+
2010-05-18 Juanma Barranquero <lekktu@gmail.com>
* progmodes/prolog.el (smie-indent-basic): Declare for byte-compiler.
@@ -135,7 +172,7 @@
2010-05-13 Michael Albinus <michael.albinus@gmx.de>
* net/tramp.el (with-progress-reporter): Create reporter object
- only when the message would be displayed. Handled nested calls.
+ only when the message would be displayed. Handle nested calls.
(tramp-handle-load, tramp-handle-file-local-copy)
(tramp-handle-insert-file-contents, tramp-handle-write-region)
(tramp-maybe-send-script, tramp-find-shell):
diff --git a/lisp/calc/calc-trail.el b/lisp/calc/calc-trail.el
index 9bbb4178fd3..20dc1d1b99e 100644
--- a/lisp/calc/calc-trail.el
+++ b/lisp/calc/calc-trail.el
@@ -108,20 +108,28 @@
(defun calc-trail-isearch-forward ()
(interactive)
(calc-with-trail-buffer
- (save-window-excursion
- (select-window (get-buffer-window (current-buffer)))
- (let ((search-exit-char ?\r))
- (isearch-forward)))
- (calc-trail-here)))
+ (let ((win (get-buffer-window (current-buffer)))
+ pos)
+ (save-window-excursion
+ (select-window win)
+ (isearch-forward)
+ (setq pos (point)))
+ (goto-char pos)
+ (set-window-point win pos)
+ (calc-trail-here))))
(defun calc-trail-isearch-backward ()
(interactive)
(calc-with-trail-buffer
- (save-window-excursion
- (select-window (get-buffer-window (current-buffer)))
- (let ((search-exit-char ?\r))
- (isearch-backward)))
- (calc-trail-here)))
+ (let ((win (get-buffer-window (current-buffer)))
+ pos)
+ (save-window-excursion
+ (select-window win)
+ (isearch-backward)
+ (setq pos (point)))
+ (goto-char pos)
+ (set-window-point win pos)
+ (calc-trail-here))))
(defun calc-trail-yank (arg)
(interactive "P")
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el
index 27ddeb762af..9ea2cf56890 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -252,11 +252,23 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or
(dolist (cst csts)
(unless (memq (car cst) rhvs)
(setq progress t)
+ ;; We could give each var in a given iteration the same value,
+ ;; but we can also give them arbitrarily different values.
+ ;; Basically, these are vars between which there is no
+ ;; constraint (neither equality nor inequality), so
+ ;; anything will do.
+ ;; We give them arbitrary values, which means that we
+ ;; replace the "no constraint" case with either > or <
+ ;; but not =. The reason we do that is so as to try and
+ ;; distinguish associative operators (which will have
+ ;; left = right).
+ (unless (caar cst)
(setcar (car cst) i)
+ (incf i))
(setq csts (delq cst csts))))
(unless progress
(error "Can't resolve the precedence table to precedence levels")))
- (incf i))
+ (incf i 10))
;; Propagate equalities back to their source.
(dolist (eq (nreverse eqs))
(assert (null (caar eq)))
@@ -278,6 +290,9 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or
Each element is of the form (TOKEN LEFT-LEVEL RIGHT-LEVEL).
Parsing is done using an operator precedence parser.")
+(defalias 'smie-op-left 'car)
+(defalias 'smie-op-right 'cadr)
+
(defun smie-backward-token ()
;; FIXME: This may be an OK default but probably needs a hook.
(buffer-substring (point)
@@ -292,66 +307,110 @@ Parsing is done using an operator precedence parser.")
(skip-syntax-forward "w_'"))
(point))))
-(defun smie-backward-sexp (&optional halfsexp)
+(defun smie-associative-p (toklevels)
+ ;; in "a + b + c" we want to stop at each +, but in
+ ;; "if a then b else c" we don't want to stop at each keyword.
+ ;; To distinguish the two cases, we made smie-prec2-levels choose
+ ;; different levels for each part of "if a then b else c", so that
+ ;; by checking if the left-level is equal to the right level, we can
+ ;; figure out that it's an associative operator.
+ ;; This is not 100% foolproof, tho, since a grammar like
+ ;; (exp ("A" exp "C") ("A" exp "B" exp "C"))
+ ;; will cause "B" to have equal left and right levels, even though
+ ;; it is not an associative operator.
+ ;; A better check would be the check the actual previous operator
+ ;; against this one to see if it's the same, but we'd have to change
+ ;; `levels' to keep a stack of operators rather than only levels.
+ (eq (smie-op-left toklevels) (smie-op-right toklevels)))
+
+(defun smie-next-sexp (next-token next-sexp op-forw op-back halfsexp)
"Skip over one sexp.
+NEXT-TOKEN is a function of no argument that moves forward by one
+token (after skipping comments if needed) and returns it.
+NEXT-SEXP is a lower-level function to skip one sexp.
+OP-FORW is the accessor to the forward level of the level data.
+OP-BACK is the accessor to the backward level of the level data.
HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the
first token we see is an operator, skip over its left-hand-side argument.
Possible return values:
- (LEFT-LEVEL POS TOKEN): we couldn't skip TOKEN because its right-level
- is too high. LEFT-LEVEL is the left-level of TOKEN,
+ (FORW-LEVEL POS TOKEN): we couldn't skip TOKEN because its back-level
+ is too high. FORW-LEVEL is the forw-level of TOKEN,
POS is its start position in the buffer.
- (t POS TOKEN): same thing but for an open-paren or the beginning of buffer.
+ (t POS TOKEN): same thing when we bump on the wrong side of a paren.
(nil POS TOKEN): we skipped over a paren-like pair.
nil: we skipped over an identifier, matched parentheses, ..."
- (if (bobp) (list t (point))
- (catch 'return
- (let ((levels ()))
- (while
- (let* ((pos (point))
- (token (progn (forward-comment (- (point-max)))
- (smie-backward-token)))
- (toklevels (cdr (assoc token smie-op-levels))))
-
+ (catch 'return
+ (let ((levels ()))
+ (while
+ (let* ((pos (point))
+ (token (funcall next-token))
+ (toklevels (cdr (assoc token smie-op-levels))))
+
+ (cond
+ ((null toklevels)
+ (when (equal token "")
+ (condition-case err
+ (progn (goto-char pos) (funcall next-sexp 1) nil)
+ (scan-error (throw 'return (list t (caddr err)))))
+ (if (eq pos (point))
+ ;; We did not move, so let's abort the loop.
+ (throw 'return (list t (point))))))
+ ((null (funcall op-back toklevels))
+ ;; A token like a paren-close.
+ (assert (funcall op-forw toklevels)) ;Otherwise, why mention it?
+ (push (funcall op-forw toklevels) levels))
+ (t
+ (while (and levels (< (funcall op-back toklevels) (car levels)))
+ (setq levels (cdr levels)))
(cond
- ((null toklevels)
- (if (equal token "")
- (condition-case err
- (progn (goto-char pos) (backward-sexp 1) nil)
- (scan-error (throw 'return (list t (caddr err)))))))
- ((null (nth 1 toklevels))
- ;; A token like a paren-close.
- (assert (nth 0 toklevels)) ;Otherwise, why mention it?
- (push (nth 0 toklevels) levels))
+ ((null levels)
+ (if (and halfsexp (funcall op-forw toklevels))
+ (push (funcall op-forw toklevels) levels)
+ (throw 'return
+ (prog1 (list (or (car toklevels) t) (point) token)
+ (goto-char pos)))))
(t
- (while (and levels (< (nth 1 toklevels) (car levels)))
- (setq levels (cdr levels)))
+ (if (and levels (= (funcall op-back toklevels) (car levels)))
+ (setq levels (cdr levels)))
(cond
((null levels)
- (if (and halfsexp (nth 0 toklevels))
- (push (nth 0 toklevels) levels)
+ (cond
+ ((null (funcall op-forw toklevels))
+ (throw 'return (list nil (point) token)))
+ ((smie-associative-p toklevels)
(throw 'return
(prog1 (list (or (car toklevels) t) (point) token)
- (goto-char pos)))))
+ (goto-char pos))))
+ ;; We just found a match to the previously pending operator
+ ;; but this new operator is still part of a larger RHS.
+ ;; E.g. we're now looking at the "then" in
+ ;; "if a then b else c". So we have to keep parsing the
+ ;; rest of the construct.
+ (t (push (funcall op-forw toklevels) levels))))
(t
- (while (and levels (= (nth 1 toklevels) (car levels)))
- (setq levels (cdr levels)))
- (cond
- ((null levels)
- (cond
- ((null (nth 0 toklevels))
- (throw 'return (list nil (point) token)))
- ((eq (nth 0 toklevels) (nth 1 toklevels))
- (throw 'return
- (prog1 (list (or (car toklevels) t) (point) token)
- (goto-char pos))))
- (t (debug)))) ;Not sure yet what to do here.
- (t
- (if (nth 0 toklevels)
- (push (nth 0 toklevels) levels))))))))
- levels)
- (setq halfsexp nil))))))
-
-;; Mirror image, not used for indentation.
+ (if (funcall op-forw toklevels)
+ (push (funcall op-forw toklevels) levels))))))))
+ levels)
+ (setq halfsexp nil)))))
+
+(defun smie-backward-sexp (&optional halfsexp)
+ "Skip over one sexp.
+HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the
+first token we see is an operator, skip over its left-hand-side argument.
+Possible return values:
+ (LEFT-LEVEL POS TOKEN): we couldn't skip TOKEN because its right-level
+ is too high. LEFT-LEVEL is the left-level of TOKEN,
+ POS is its start position in the buffer.
+ (t POS TOKEN): same thing but for an open-paren or the beginning of buffer.
+ (nil POS TOKEN): we skipped over a paren-like pair.
+ nil: we skipped over an identifier, matched parentheses, ..."
+ (smie-next-sexp
+ (lambda () (forward-comment (- (point-max))) (smie-backward-token))
+ (indirect-function 'backward-sexp)
+ (indirect-function 'smie-op-left)
+ (indirect-function 'smie-op-right)
+ halfsexp))
+
(defun smie-forward-sexp (&optional halfsexp)
"Skip over one sexp.
HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the
@@ -363,53 +422,12 @@ Possible return values:
(t POS TOKEN): same thing but for an open-paren or the beginning of buffer.
(nil POS TOKEN): we skipped over a paren-like pair.
nil: we skipped over an identifier, matched parentheses, ..."
- (if (eobp) (list t (point))
- (catch 'return
- (let ((levels ()))
- (while
- (let* ((pos (point))
- (token (progn (forward-comment (point-max))
- (smie-forward-token)))
- (toklevels (cdr (assoc token smie-op-levels))))
-
- (cond
- ((null toklevels)
- (if (equal token "")
- (condition-case err
- (progn (goto-char pos) (forward-sexp 1) nil)
- (scan-error (throw 'return (list t (caddr err)))))))
- ((null (nth 0 toklevels))
- ;; A token like a paren-close.
- (assert (nth 1 toklevels)) ;Otherwise, why mention it?
- (push (nth 1 toklevels) levels))
- (t
- (while (and levels (< (nth 0 toklevels) (car levels)))
- (setq levels (cdr levels)))
- (cond
- ((null levels)
- (if (and halfsexp (nth 1 toklevels))
- (push (nth 1 toklevels) levels)
- (throw 'return
- (prog1 (list (or (nth 1 toklevels) t) (point) token)
- (goto-char pos)))))
- (t
- (while (and levels (= (nth 0 toklevels) (car levels)))
- (setq levels (cdr levels)))
- (cond
- ((null levels)
- (cond
- ((null (nth 1 toklevels))
- (throw 'return (list nil (point) token)))
- ((eq (nth 1 toklevels) (nth 0 toklevels))
- (throw 'return
- (prog1 (list (or (nth 1 toklevels) t) (point) token)
- (goto-char pos))))
- (t (debug)))) ;Not sure yet what to do here.
- (t
- (if (nth 1 toklevels)
- (push (nth 1 toklevels) levels))))))))
- levels)
- (setq halfsexp nil))))))
+ (smie-next-sexp
+ (lambda () (forward-comment (point-max)) (smie-forward-token))
+ (indirect-function 'forward-sexp)
+ (indirect-function 'smie-op-right)
+ (indirect-function 'smie-op-left)
+ halfsexp))
(defun smie-backward-sexp-command (&optional n)
"Move backward through N logical elements."
@@ -496,6 +514,10 @@ VIRTUAL can take two different non-nil values:
(and virtual
(if (eq virtual :hanging) (not (smie-indent-hanging-p)) (smie-bolp))
(current-column))
+ ;; Start the file at column 0.
+ (save-excursion
+ (forward-comment (- (point-max)))
+ (if (bobp) 0))
;; Align close paren with opening paren.
(save-excursion
;; (forward-comment (point-max))
diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el
index c45f6fbb276..a7225d663e3 100644
--- a/lisp/net/secrets.el
+++ b/lisp/net/secrets.el
@@ -129,6 +129,9 @@
;; (secrets-search-items "session" :user "joe")
;; => ("my item" "another item")
+;; Interactively, collections, items and their attributes could be
+;; inspected by the command `secrets-show-secrets'.
+
;;; Code:
;; It has been tested with GNOME Keyring 2.29.92. An implementation
@@ -148,6 +151,13 @@
(require 'dbus)
+(declare-function tree-widget-set-theme "tree-widget")
+(declare-function widget-create-child-and-convert "wid-edit")
+(declare-function widget-default-value-set "wid-edit")
+(declare-function widget-field-end "wid-edit")
+(declare-function widget-member "wid-edit")
+(defvar tree-widget-after-toggle-functions)
+
(defvar secrets-enabled nil
"Whether there is a daemon offering the Secret Service API.")
@@ -665,6 +675,145 @@ If there is no such item, or the item doesn't own this attribute, return nil."
:session secrets-service item-path
secrets-interface-item "Delete")))))
+;;; Visualization.
+
+(define-derived-mode secrets-mode nil "Secrets"
+ "Major mode for presenting search results of a Xesam search.
+In this mode, widgets represent the search results.
+
+\\{secrets-mode-map}
+Turning on Xesam mode runs the normal hook `xesam-mode-hook'. It
+can be used to set `xesam-notify-function', which must a search
+engine specific, widget :notify function to visualize xesam:url."
+ ;; Keymap.
+ (setq secrets-mode-map (copy-keymap special-mode-map))
+ (set-keymap-parent secrets-mode-map widget-keymap)
+ (define-key secrets-mode-map "z" 'kill-this-buffer)
+
+ ;; When we toggle, we must set temporary widgets.
+ (set (make-local-variable 'tree-widget-after-toggle-functions)
+ '(secrets-tree-widget-after-toggle-function))
+
+ (when (not (called-interactively-p 'interactive))
+ ;; Initialize buffer.
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (erase-buffer))))
+
+;; It doesn't make sense to call it interactively.
+(put 'secrets-mode 'disabled t)
+
+;; The very first buffer created with `secrets-mode' does not have the
+;; keymap etc. So we create a dummy buffer. Stupid.
+(with-temp-buffer (secrets-mode))
+
+;;;###autoload
+(defun secrets-show-secrets ()
+ "Display a list of collections from the Secret Service API.
+The collections are in tree view, that means they can be expanded
+to the corresponding secret items, which could also be expanded
+to their attributes."
+ (interactive)
+ ;; Create the search buffer.
+ (with-current-buffer (get-buffer-create "*Secrets*")
+ (switch-to-buffer-other-window (current-buffer))
+ ;; Inialize buffer with `secrets-mode'.
+ (secrets-mode)
+ (secrets-show-collections)))
+
+(defun secrets-show-collections ()
+ "Show all available collections."
+ (let ((inhibit-read-only t)
+ (alias (secrets-get-alias "default")))
+ (erase-buffer)
+ (tree-widget-set-theme "folder")
+ (dolist (coll (secrets-list-collections))
+ (widget-create
+ `(tree-widget
+ :tag ,coll
+ :collection ,coll
+ :open nil
+ :sample-face bold
+ :expander secrets-expand-collection)))))
+
+(defun secrets-expand-collection (widget)
+ "Expand items of collection shown as WIDGET."
+ (let ((coll (widget-get widget :collection)))
+ (mapcar
+ (lambda (item)
+ `(tree-widget
+ :tag ,item
+ :collection ,coll
+ :item ,item
+ :open nil
+ :sample-face bold
+ :expander secrets-expand-item))
+ (secrets-list-items coll))))
+
+(defun secrets-expand-item (widget)
+ "Expand password and attributes of item shown as WIDGET."
+ (let* ((coll (widget-get widget :collection))
+ (item (widget-get widget :item))
+ (attributes (secrets-get-attributes coll item))
+ ;; padding is needed to format attribute names.
+ (padding
+ (1+
+ (apply
+ 'max
+ (cons
+ (length "password")
+ (mapcar
+ (lambda (attribute) (length (symbol-name (car attribute))))
+ attributes))))))
+ (cons
+ ;; The password widget.
+ `(editable-field :tag "password"
+ :secret ?*
+ :value ,(secrets-get-secret coll item)
+ :sample-face widget-button-pressed
+ ;; We specify :size in order to limit the field.
+ :size 0
+ :format ,(concat
+ "%{%t%}:"
+ (make-string (- padding (length "password")) ? )
+ "%v\n"))
+ (mapcar
+ (lambda (attribute)
+ (let ((name (symbol-name (car attribute)))
+ (value (cdr attribute)))
+ ;; The attribute widget.
+ `(editable-field :tag ,name
+ :value ,value
+ :sample-face widget-documentation
+ ;; We specify :size in order to limit the field.
+ :size 0
+ :format ,(concat
+ "%{%t%}:"
+ (make-string (- padding (length name)) ? )
+ "%v\n"))))
+ attributes))))
+
+(defun secrets-tree-widget-after-toggle-function (widget &rest ignore)
+ "Add a temporary widget to show the password."
+ (dolist (child (widget-get widget :children))
+ (when (widget-member child :secret)
+ (goto-char (widget-field-end child))
+ (widget-insert " ")
+ (widget-create-child-and-convert
+ child 'push-button
+ :notify 'secrets-tree-widget-show-password
+ "Show password")))
+ (widget-setup))
+
+(defun secrets-tree-widget-show-password (widget &rest ignore)
+ "Show password, and remove temporary widget."
+ (let ((parent (widget-get widget :parent)))
+ (widget-put parent :secret nil)
+ (widget-default-value-set parent (widget-get parent :value))
+ (widget-setup)))
+
+;;; Initialization.
+
(when (dbus-ping :session secrets-service 100)
;; We must reset all variables, when there is a new instance of the
diff --git a/lisp/subr.el b/lisp/subr.el
index 1c399f89b9c..fb84f95c805 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1868,16 +1868,14 @@ any other non-digit terminates the character code and is then used as input."))
(if inhibit-quit (setq quit-flag nil)))
;; Translate TAB key into control-I ASCII character, and so on.
;; Note: `read-char' does it using the `ascii-character' property.
- ;; We could try and use read-key-sequence instead, but then C-q ESC
- ;; or C-q C-x might not return immediately since ESC or C-x might be
- ;; bound to some prefix in function-key-map or key-translation-map.
+ ;; We should try and use read-key instead.
+ (let ((translation (lookup-key local-function-key-map (vector char))))
+ (if (arrayp translation)
+ (setq translated (aref translation 0))))
(setq translated
(if (integerp char)
(char-resolve-modifiers char)
char))
- (let ((translation (lookup-key local-function-key-map (vector char))))
- (if (arrayp translation)
- (setq translated (aref translation 0))))
(cond ((null translated))
((not (integerp translated))
(setq unread-command-events (list char)
generated by cgit v1.2.3 (git 2.39.1) at 2025-07-08 09:11:59 +0000