X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/257210319f10abebbfd7c12784cf3a8e112c3562..5551acd251f6ca0adea570a3b3781788fdae6a2a:/lisp/allout-widgets.el diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index 962a8fb557..66ec0c333a 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -1,6 +1,6 @@ ;; allout-widgets.el --- Visually highlight allout outline structure. -;; Copyright (C) 2005-2012 Free Software Foundation, Inc. +;; Copyright (C) 2005-2014 Free Software Foundation, Inc. ;; Author: Ken Manheimer ;; Maintainer: Ken Manheimer @@ -90,7 +90,6 @@ ;;;_ : USER CUSTOMIZATION VARIABLES and incidental functions: ;;;_ > defgroup allout-widgets -;;;###autoload (defgroup allout-widgets nil "Allout extension that highlights outline structure graphically. @@ -267,7 +266,7 @@ decreases as obsolete widgets are garbage collected." (defvar allout-widgets-tally nil "Hash-table of existing allout widgets, for debugging. -Table is maintained iff `allout-widgets-maintain-tally' is non-nil. +Table is maintained only if `allout-widgets-maintain-tally' is non-nil. The table contents will be out of sync if any widgets are created or deleted while this variable is nil.") @@ -293,8 +292,8 @@ The number varies according to the evanescence of objects on a "If non-nil, show cursor position of each item decoration. This is for debugging purposes, and generally set at need in a -buffer rather than as a prevailing configuration \(but it's handy -to publicize it by making it a customization variable\)." +buffer rather than as a prevailing configuration (but it's handy +to publicize it by making it a customization variable)." :version "24.1" :type 'boolean :group 'allout-widgets-developer) @@ -346,7 +345,7 @@ to `allout-body-modification-handler', and is always reset by "Cache allout icon images, as an association list. `allout-fetch-icon-image' uses this cache transparently, keying -images with lists containing the name of the icon directory \(as +images with lists containing the name of the icon directory (as found on the `load-path') and the icon name. Set this variable to `nil' to empty the cache, and have it replenish from the @@ -485,7 +484,7 @@ including things like: - encryption '~' - numbering '#' - indirect reference '@' - - distinctive bullets - see `allout-distinctive-bullets-string'.\)") + - distinctive bullets - see `allout-distinctive-bullets-string'.)") ;;;_ = allout-span-to-category (defvar allout-span-to-category '((:guides-span . allout-guides-span-category) @@ -534,7 +533,7 @@ The graphics include: The bullet-icon and guide line graphics provide keybindings and mouse bindings for easy outline navigation and exposure control, extending -outline hot-spot navigation \(see `allout-mode')." +outline hot-spot navigation (see `allout-mode')." :lighter nil :keymap nil @@ -646,11 +645,11 @@ outline hot-spot navigation \(see `allout-mode')." (set-buffer-modified-p was-modified)))) ;;;_ > allout-widgets-mode-off (defun allout-widgets-mode-off () - "Explicitly disable allout-widgets-mode." + "Explicitly disable `allout-widgets-mode'." (allout-widgets-mode -1)) ;;;_ > allout-widgets-mode-off (defun allout-widgets-mode-on () - "Explicitly disable allout-widgets-mode." + "Explicitly enable `allout-widgets-mode'." (allout-widgets-mode 1)) ;;;_ > allout-setup-text-properties () (defun allout-setup-text-properties () @@ -714,23 +713,23 @@ outline hot-spot navigation \(see `allout-mode')." (defvar allout-container-item-widget nil "A widget for the current outline's overarching container as an item. -The item has settings \(of the file/connection\) and maybe a body, but no +The item has settings (of the file/connection) and maybe a body, but no icon/bullet.") (make-variable-buffer-local 'allout-container-item-widget) ;;;_ . Hooks and hook helpers ;;;_ , major command-loop business: ;;;_ > allout-widgets-pre-command-business (&optional recursing) -(defun allout-widgets-pre-command-business (&optional recursing) - "Handle actions pending before allout-mode activity." +(defun allout-widgets-pre-command-business (&optional _recursing) + "Handle actions pending before `allout-mode' activity." ) ;;;_ > allout-widgets-post-command-business (&optional recursing) -(defun allout-widgets-post-command-business (&optional recursing) - "Handle actions pending after any allout-mode commands. +(defun allout-widgets-post-command-business (&optional _recursing) + "Handle actions pending after any `allout-mode' commands. Optional RECURSING is for internal use, to limit recursion." ;; - check changed text for nesting discontinuities and escape anything ;; that's: (1) asterisks at bol or (2) excessively nested. - (condition-case failure + (condition-case nil (when (and (boundp 'allout-mode) allout-mode) @@ -811,7 +810,7 @@ Optional RECURSING is for internal use, to limit recursion." (goto-char (widget-get this-widget :from)) (not (bolp))) (if (not - (condition-case err + (condition-case nil (yes-or-no-p (concat "Misplaced item won't be recognizable " " as part of outline - rectify? ")) @@ -873,7 +872,7 @@ Optional RECURSING is for internal use, to limit recursion." (error (substitute-command-keys allout-structure-unruly-deletion-message))))) ;;;_ > allout-widgets-after-change-handler -(defun allout-widgets-after-change-handler (beg end prelength) +(defun allout-widgets-after-change-handler (_beg _end _prelength) "Reconcile what needs to be reconciled for allout widgets after edits." ) ;;;_ > allout-current-decorated-p () @@ -999,7 +998,6 @@ Generally invoked via `allout-exposure-change-functions'." ;; have to distinguish between concealing and exposing so that, eg, ;; `allout-expose-topic's mix is handled properly. handled-expose - handled-conceal covered deactivate-mark) @@ -1155,14 +1153,14 @@ Dispatched by `allout-widgets-post-command-business' in response to (defun allout-widgets-after-copy-or-kill-function () "Do allout-widgets processing of text just placed in the kill ring. -Intended for use on allout-after-copy-or-kill-hook." +Intended for use on `allout-after-copy-or-kill-hook'." (if (car kill-ring) (setcar kill-ring (allout-widgets-undecorate-text (car kill-ring))))) ;;;_ > allout-widgets-after-undo-function () (defun allout-widgets-after-undo-function () "Do allout-widgets processing of text after an undo. -Intended for use on allout-post-undo-hook." +Intended for use on `allout-post-undo-hook'." (save-excursion (if (allout-goto-prefix) (allout-redecorate-item (allout-get-or-create-item-widget))))) @@ -1188,7 +1186,7 @@ Dispatched by `allout-widgets-post-command-business' in response to (let* ((allout-undo-exposure-in-progress t) ;; inhibit undo recording while twiddling exposure to track undo: (widgets allout-widgets-undo-exposure-record) - widget widget-start-marker widget-end-marker + widget-start-marker widget-end-marker from-state icon-start-point to-state handled covered) (setq allout-widgets-undo-exposure-record nil) @@ -1359,7 +1357,7 @@ FROM and TO must be in increasing order, as must be the pairs in RANGES." (list (if included-from t) new-ranges))) ;;;_ > allout-test-range-overlaps () (defun allout-test-range-overlaps () - "allout-range-overlaps unit tests." + "`allout-range-overlaps' unit tests." (let* (ranges got (try (lambda (from to) @@ -1374,7 +1372,6 @@ FROM and TO must be in increasing order, as must be the pairs in RANGES." ;; (time-trial ;; '(let ((size 10000) ;; doing) -;; (random t) ;; (dotimes (count size) ;; (setq doing (random size)) ;; (funcall try doing (+ doing (random 5))) @@ -1553,12 +1550,12 @@ recursive operation." ;;;_ > allout-decorate-item-and-context (item-widget &optional redecorate ;;; blank-container parent) (defun allout-decorate-item-and-context (item-widget &optional redecorate - blank-container parent) + blank-container _parent) "Create or adjust widget decorations for ITEM-WIDGET and neighbors at point. The neighbors include its siblings and parent. -ITEM-WIDGET can be a created or converted allout-item-widget. +ITEM-WIDGET can be a created or converted `allout-item-widget'. If you're only trying to get or create a widget for an item, use `allout-get-or-create-item-widget'. If you have the item-widget, applying @@ -1566,7 +1563,7 @@ If you're only trying to get or create a widget for an item, use Optional BLANK-CONTAINER is for internal use. It is used to fabricate a container widget for an empty-bodied container, in the course of decorating -a proper \(non-container\) item which starts at the beginning of the file. +a proper (non-container) item which starts at the beginning of the file. Optional REDECORATE causes redecoration of the item-widget and its siblings, even if already decorated in this cycle of the command loop. @@ -1594,12 +1591,8 @@ We return the item-widget corresponding to the item at point." steady-point)) (parent (and (not is-container) (allout-get-or-create-parent-widget))) - parent-flags parent-depth successor-sibling - body doing-item - sub-item-widget - depth reverse-siblings-chart (buffer-undo-list t)) @@ -1616,7 +1609,6 @@ We return the item-widget corresponding to the item at point." ;; `allout-goto-prefix' will go to first non-container item: (allout-goto-prefix) (allout-next-heading)) - (setq depth (allout-recent-depth)) (setq reverse-siblings-chart (list allout-recent-prefix-beginning)) (while (allout-next-sibling) (push allout-recent-prefix-beginning reverse-siblings-chart))) @@ -1703,7 +1695,6 @@ Point is left at the last sibling in the visible subtree." (pending-chart (or chart (allout-chart-subtree nil 'visible))) item-widget previous-sibling-point - previous-sibling recent-sibling-point) (setq pending-chart (nreverse pending-chart)) (dolist (sibling-point pending-chart) @@ -1738,8 +1729,8 @@ If optional AT-BEGINNING is t, then point is assumed to be at the start of the item prefix. If optional BLANK-CONTAINER is true, then the parameters of a container -which has an empty body are set. \(Though the body is blank, the object -may have subitems.\)" +which has an empty body are set. (Though the body is blank, the object +may have subitems.)" ;; Uncomment this sit-for to notice where decoration is happening: ;; (sit-for .1) @@ -1754,9 +1745,7 @@ may have subitems.\)" (icon-start (1- icon-end)) body-start body-end - bullet has-subitems - (contents-depth (1+ depth)) ) (widget-put item-widget :depth depth) (if is-container @@ -1784,7 +1773,7 @@ may have subitems.\)" ;; cue area: (setq body-start icon-end) - (widget-put item-widget :bullet (setq bullet (allout-get-bullet))) + (widget-put item-widget :bullet (allout-get-bullet)) (if (equal (char-after body-start) ? ) (setq body-start (1+ body-start))) (widget-put item-widget :body-start body-start) @@ -1810,7 +1799,7 @@ may have subitems.\)" ;; has a subsequent item: (not (= body-end (point-max))) ;; subsequent item is deeper: - (< depth (setq contents-depth (allout-recent-depth)))))) + (< depth (allout-recent-depth))))) ;; note :expanded - true if widget item's content is currently visible? (widget-put item-widget :expanded (and has-subitems @@ -1819,7 +1808,7 @@ may have subitems.\)" (goto-char allout-recent-prefix-beginning) (not (allout-hidden-p))))))) ;;;_ > allout-set-boundary-marker (boundary position &optional current-marker) -(defun allout-set-boundary-marker (boundary position &optional current-marker) +(defun allout-set-boundary-marker (_boundary position &optional current-marker) "Set or create item widget BOUNDARY type marker at POSITION. Optional CURRENT-MARKER is the marker currently being used for @@ -1858,12 +1847,12 @@ the various element spans." &optional parent-widget has-successor) "Add ITEM-WIDGET guide icon-prefix descender and connector text properties. -Optional arguments provide context for deriving the guides. In -their absence, the current guide column flags are used. +Optional arguments provide context for deriving the guides. +In their absence, the current guide column flags are used. Optional PARENT-WIDGET is the widget for the item's parent item. -Optional HAS-SUCCESSOR is true iff the item is followed by a sibling. +Optional HAS-SUCCESSOR is true if the item is followed by a sibling. We also hide the header-prefix string. @@ -1873,8 +1862,8 @@ reapplying this method will rectify the glyphs." (when (not (widget-get item-widget :is-container)) (let* ((depth (widget-get item-widget :depth)) - (parent-depth (and parent-widget - (widget-get parent-widget :depth))) + ;; (parent-depth (and parent-widget + ;; (widget-get parent-widget :depth))) (parent-flags (and parent-widget (widget-get parent-widget :guide-column-flags))) (parent-flags-depth (length parent-flags)) @@ -1895,7 +1884,7 @@ reapplying this method will rectify the glyphs." (increment (length allout-header-prefix)) reverse-flags guide-name - extenders paint-extenders + extenders (inhibit-read-only t)) (when (not (equal was-flags flags)) @@ -2018,8 +2007,8 @@ reapplying this method will rectify the glyphs." (let* ((cue-start (or (widget-get item-widget :distinctive-end) (widget-get item-widget :icon-end))) (body-start (widget-get item-widget :body-start)) - (expanded (widget-get item-widget :expanded)) - (has-subitems (widget-get item-widget :has-subitems)) + ;(expanded (widget-get item-widget :expanded)) + ;(has-subitems (widget-get item-widget :has-subitems)) (inhibit-read-only t)) (allout-item-element-span-is item-widget :cue-span cue-start body-start) @@ -2033,7 +2022,6 @@ Optional FORCE means force reassignment of the region property." (let* ((allout-inhibit-body-modification-hook t) (body-start (widget-get item-widget :body-start)) (body-end (widget-get item-widget :body-end)) - (body-text-end body-end) (inhibit-read-only t)) (allout-item-element-span-is item-widget :body-span @@ -2136,9 +2124,7 @@ of the current span, if established, or nil if not yet set. When the START and END are passed, return the distance that the start of the item moved. We return 0 if the span was not previously established or is not moved." - (let ((overlay (widget-get item-widget :span-overlay)) - was-start was-end - changed) + (let ((overlay (widget-get item-widget :span-overlay))) (cond ((not overlay) (when start (setq overlay (make-overlay start end nil t nil)) (overlay-put overlay 'button item-widget) @@ -2223,7 +2209,7 @@ and decorate its siblings and parent, as well. Optional BLANK-CONTAINER is for internal use, to fabricate a meta-container item with an empty body when the first proper -\(non-container\) item starts at the beginning of the file. +\(non-container) item starts at the beginning of the file. Optional REDECORATE, if non-nil, means to redecorate the widget if it already exists." @@ -2255,12 +2241,12 @@ Point will wind up positioned on the beginning of the parent or beginning of the buffer." ;; use existing widget, if there, else establish it (if (or (bobp) (and (not (allout-ascend)) - (looking-at allout-regexp))) + (looking-at-p allout-regexp))) (allout-get-or-create-item-widget redecorate 'blank-container) (allout-get-or-create-item-widget redecorate))) ;;;_ : X- Item ancillaries ;;;_ >X allout-body-modification-handler (beg end) -(defun allout-body-modification-handler (beg end) +(defun allout-body-modification-handler (_beg _end) "Do routine processing of body text before and after modification. Operation is inhibited by `allout-inhibit-body-modification-handler'." @@ -2271,7 +2257,7 @@ Operation is inhibited by `allout-inhibit-body-modification-handler'." ;; - removal and replacement of the settings ;; - maintenance of beginning-of-line guide lines ;; -;; ?? Escapes removal \(before changes\) is not done when edits span multiple +;; ?? Escapes removal (before changes) is not done when edits span multiple ;; items, recognizing that item structure is being preserved, including ;; escaping of item-prefix-like text within bodies. See ;; `allout-before-modification-handler' and @@ -2282,10 +2268,10 @@ Operation is inhibited by `allout-inhibit-body-modification-handler'." ;; operation. (cond (allout-inhibit-body-modification-hook nil))) ;;;_ >X allout-graphics-modification-handler (beg end) -(defun allout-graphics-modification-handler (beg end) +(defun allout-graphics-modification-handler (beg _end) "Protect against incoherent deletion of decoration graphics. -Deletes allowed only when inhibit-read-only is t." +Deletes allowed only when `inhibit-read-only' is t." (cond (undo-in-progress (when (eq (get-text-property beg 'category) 'allout-icon-span-category)