summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicolas Goaziou <n.goaziou@gmail.com>2010-12-17 19:54:25 +0100
committerNicolas Goaziou <n.goaziou@gmail.com>2011-02-18 12:45:07 +0100
commit1829aa79b51c462032a270431217e98e63c37ecc (patch)
treeb6f0d7c61b9f2980b9549e25e4e954fd5da77fcd
parent8a3a81c08eec031d8636737024d652a4178cf317 (diff)
downloadorg-mode-1829aa79b51c462032a270431217e98e63c37ecc.tar.gz
org-list: use list structure to update checkboxes and cookies
* lisp/org-list.el (org-toggle-checkbox): use structures to fix checkboxes of a list (org-update-checkbox-count): use structures to update cookies
-rw-r--r--lisp/org-list.el364
1 files changed, 191 insertions, 173 deletions
diff --git a/lisp/org-list.el b/lisp/org-list.el
index 6a2f3ac..5cb494d 100644
--- a/lisp/org-list.el
+++ b/lisp/org-list.el
@@ -1798,77 +1798,91 @@ If the cursor is in a headline, apply this to all checkbox items
in the text below the heading, taking as reference the first item
in subtree, ignoring drawers."
(interactive "P")
- ;; Bounds is a list of type (beg end single-p) where single-p is t
- ;; when `org-toggle-checkbox' is applied to a single item. Only
- ;; toggles on single items will return errors.
- (let* ((bounds
- (cond
- ((org-region-active-p)
- (let ((rbeg (region-beginning))
- (rend (region-end)))
- (save-excursion
- (goto-char rbeg)
- (if (org-search-forward-unenclosed org-item-beginning-re rend 'move)
- (list (point-at-bol) rend nil)
- (error "No item in region")))))
- ((org-on-heading-p)
- ;; In this case, reference line is the first item in
- ;; subtree outside drawers
- (let ((pos (point))
- (limit (save-excursion (outline-next-heading) (point))))
- (save-excursion
- (goto-char limit)
- (org-search-backward-unenclosed ":END:" pos 'move)
- (org-search-forward-unenclosed
- org-item-beginning-re limit 'move)
- (list (point) limit nil))))
- ((org-at-item-p)
- (list (point-at-bol) (1+ (point-at-eol)) t))
- (t (error "Not at an item or heading, and no active region"))))
- (beg (car bounds))
- ;; marker is needed because deleting or inserting checkboxes
- ;; will change bottom point
- (end (copy-marker (nth 1 bounds)))
- (single-p (nth 2 bounds))
- (ref-presence (save-excursion
- (goto-char beg)
- (org-at-item-checkbox-p)))
- (ref-status (equal (match-string 1) "[X]"))
- (act-on-item
- (lambda (ref-pres ref-stat)
- (if (equal toggle-presence '(4))
- (cond
- ((and ref-pres (org-at-item-checkbox-p))
- (replace-match ""))
- ((and (not ref-pres)
- (not (org-at-item-checkbox-p))
- (org-at-item-p))
- (goto-char (match-end 0))
- ;; Ignore counter, if any
- (when (looking-at "\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?")
- (goto-char (match-end 0)))
- (let ((desc-p (and (org-at-item-description-p)
- (cdr (assq 'checkbox org-list-automatic-rules)))))
- (cond
- ((and single-p desc-p)
- (error "Cannot add a checkbox in a description list"))
- ((not desc-p) (insert "[ ] "))))))
- (let ((blocked (org-checkbox-blocked-p)))
- (cond
- ((and blocked single-p)
- (error "Checkbox blocked because of unchecked box in line %d" blocked))
- (blocked nil)
- ((org-at-item-checkbox-p)
- (replace-match
- (cond ((equal toggle-presence '(16)) "[-]")
- (ref-stat "[ ]")
- (t "[X]"))
- t t nil 1))))))))
- (save-excursion
- (goto-char beg)
- (while (< (point) end)
- (funcall act-on-item ref-presence ref-status)
- (org-search-forward-unenclosed org-item-beginning-re end 'move)))
+ (save-excursion
+ (let* (singlep
+ block-item
+ lim-up
+ lim-down
+ (orderedp (ignore-errors (org-entry-get nil "ORDERED")))
+ (bounds
+ ;; In a region, start at first item in region
+ (cond
+ ((org-region-active-p)
+ (let ((limit (region-end)))
+ (goto-char (region-beginning))
+ (if (org-search-forward-unenclosed org-item-beginning-re
+ limit t)
+ (setq lim-up (point-at-bol))
+ (error "No item in region"))
+ (setq lim-down (copy-marker limit))))
+ ((org-on-heading-p)
+ ;; On an heading, start at first item after drawers
+ (let ((limit (save-excursion (outline-next-heading) (point))))
+ (forward-line 1)
+ (when (looking-at org-drawer-regexp)
+ (re-search-forward "^[ \t]*:END:" limit nil))
+ (if (org-search-forward-unenclosed org-item-beginning-re
+ limit t)
+ (setq lim-up (point-at-bol))
+ (error "No item in subtree"))
+ (setq lim-down (copy-marker limit))))
+ ;; Just one item: set singlep flag
+ ((org-at-item-p)
+ (setq singlep t)
+ (setq lim-up (point-at-bol)
+ lim-down (point-at-eol)))
+ (t (error "Not at an item or heading, and no active region"))))
+ ;; determine the checkbox going to be applied to all items
+ ;; within bounds
+ (ref-checkbox
+ (progn
+ (goto-char lim-up)
+ (let ((cbox (and (org-at-item-checkbox-p) (match-string 1))))
+ (cond
+ ((equal toggle-presence '(16)) "[-]")
+ ((equal toggle-presence '(4))
+ (unless cbox "[ ]"))
+ ((equal "[ ]" cbox) "[X]")
+ (t "[ ]"))))))
+ ;; When an item is found within bounds, grab the full list at
+ ;; point structure, then: 1. set checkbox of all its items
+ ;; within bounds to ref-checkbox; 2. fix checkboxes of the whole
+ ;; list; 3. move point after the list.
+ (goto-char lim-up)
+ (while (and (< (point) lim-down)
+ (org-search-forward-unenclosed
+ org-item-beginning-re lim-down 'move))
+ (let* ((struct (org-list-struct))
+ (struct-copy (mapcar (lambda (e) (copy-alist e)) struct))
+ (parents (org-list-struct-parent-alist struct))
+ (bottom (copy-marker (org-list-get-bottom-point struct)))
+ (items-to-toggle (org-remove-if
+ (lambda (e) (or (< e lim-up) (> e lim-down)))
+ (mapcar 'car (cdr struct)))))
+ (mapc (lambda (e) (org-list-set-checkbox
+ e struct
+ ;; if there is no box at item, leave as-is
+ ;; unless function was called with C-u prefix
+ (let ((cur-box (org-list-get-checkbox e struct)))
+ (if (or cur-box (equal toggle-presence '(4)))
+ ref-checkbox
+ cur-box))))
+ items-to-toggle)
+ (setq block-item (org-list-struct-fix-box struct parents orderedp))
+ ;; Report some problems due to ORDERED status of subtree. If
+ ;; only one box was being checked, throw an error, else,
+ ;; only signal problems.
+ (cond
+ ((and singlep block-item (> lim-up block-item))
+ (error
+ "Checkbox blocked because of unchecked box at line %d"
+ (org-current-line block-item)))
+ (block-item
+ (message
+ "Checkboxes were removed due to unchecked box at line %d"
+ (org-current-line block-item))))
+ (goto-char bottom)
+ (org-list-struct-apply-struct struct struct-copy))))
(org-update-checkbox-count-maybe)))
(defun org-reset-checkbox-state-subtree ()
@@ -1901,110 +1915,114 @@ information.")
(defun org-update-checkbox-count (&optional all)
"Update the checkbox statistics in the current section.
-This will find all statistic cookies like [57%] and [6/12] and update them
-with the current numbers. With optional prefix argument ALL, do this for
-the whole buffer."
+This will find all statistic cookies like [57%] and [6/12] and
+update them with the current numbers.
+
+With optional prefix argument ALL, do this for the whole buffer."
(interactive "P")
(save-excursion
- (let ((cstat 0))
- (catch 'exit
- (while t
- (let* ((buffer-invisibility-spec (org-inhibit-invisibility)) ; Emacs 21
- (beg (condition-case nil
- (progn (org-back-to-heading) (point))
- (error (point-min))))
- (end (copy-marker (save-excursion
- (outline-next-heading) (point))))
- (re-cookie "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
- (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)")
- beg-cookie end-cookie is-percent c-on c-off lim new
- curr-ind next-ind continue-from startsearch list-beg list-end
- (recursive
- (or (not org-hierarchical-checkbox-statistics)
- (string-match "\\<recursive\\>"
- (or (ignore-errors
- (org-entry-get nil "COOKIE_DATA"))
- "")))))
- (goto-char end)
- ;; find each statistics cookie
- (while (and (org-search-backward-unenclosed re-cookie beg 'move)
- (not (save-match-data
- (and (org-on-heading-p)
- (string-match "\\<todo\\>"
- (downcase
- (or (org-entry-get
- nil "COOKIE_DATA")
- "")))))))
- (setq beg-cookie (match-beginning 1)
- end-cookie (match-end 1)
- cstat (+ cstat (if end-cookie 1 0))
- startsearch (point-at-eol)
- continue-from (match-beginning 0)
- is-percent (match-beginning 2)
- lim (cond
- ((org-on-heading-p) (outline-next-heading) (point))
- ;; Ensure many cookies in the same list won't imply
- ;; computing list boundaries as many times.
- ((org-at-item-p)
- (unless (and list-beg (>= (point) list-beg))
- (setq list-beg (org-list-top-point)
- list-end (copy-marker
- (org-list-bottom-point))))
- (org-get-end-of-item list-end))
- (t nil))
- c-on 0
- c-off 0)
- (when lim
- ;; find first checkbox for this cookie and gather
- ;; statistics from all that are at this indentation level
- (goto-char startsearch)
- (if (org-search-forward-unenclosed re-box lim t)
- (progn
- (beginning-of-line)
- (setq curr-ind (org-get-indentation))
- (setq next-ind curr-ind)
- (while (and (bolp) (org-at-item-p)
- (if recursive
- (<= curr-ind next-ind)
- (= curr-ind next-ind)))
- (when (org-at-item-checkbox-p)
- (if (member (match-string 1) '("[ ]" "[-]"))
- (setq c-off (1+ c-off))
- (setq c-on (1+ c-on))))
- (if (not recursive)
- ;; org-get-next-item goes through list-enders
- ;; with proper limit.
- (goto-char (or (org-get-next-item (point) lim) lim))
- (end-of-line)
- (when (org-search-forward-unenclosed
- org-item-beginning-re lim t)
- (beginning-of-line)))
- (setq next-ind (org-get-indentation)))))
- (goto-char continue-from)
- ;; update cookie
- (when end-cookie
- (setq new (if is-percent
- (format "[%d%%]" (/ (* 100 c-on)
- (max 1 (+ c-on c-off))))
- (format "[%d/%d]" c-on (+ c-on c-off))))
- (goto-char beg-cookie)
- (insert new)
- (delete-region (point) (+ (point) (- end-cookie beg-cookie))))
- ;; update items checkbox if it has one
- (when (and (org-at-item-checkbox-p)
- (> (+ c-on c-off) 0))
- (setq beg-cookie (match-beginning 1)
- end-cookie (match-end 1))
- (delete-region beg-cookie end-cookie)
- (goto-char beg-cookie)
- (cond ((= c-off 0) (insert "[X]"))
- ((= c-on 0) (insert "[ ]"))
- (t (insert "[-]")))))
- (goto-char continue-from)))
- (unless (and all (outline-next-heading)) (throw 'exit nil))))
- (when (interactive-p)
- (message "Checkbox statistics updated %s (%d places)"
- (if all "in entire file" "in current outline entry") cstat)))))
+ (let ((cookie-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
+ (box-re "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)")
+ (recursivep
+ (or (not org-hierarchical-checkbox-statistics)
+ (string-match "\\<recursive\\>"
+ (or (ignore-errors
+ (org-entry-get nil "COOKIE_DATA"))
+ ""))))
+ (bounds (if all
+ (cons (point-min) (point-max))
+ (cons (or (ignore-errors (org-back-to-heading) (point))
+ (point-min))
+ (save-excursion (outline-next-heading) (point)))))
+ (count-boxes
+ (function
+ ;; add checked boxes and boxes of all types in all
+ ;; structures in STRUCTS to c-on and c-all, respectively.
+ ;; This looks at RECURSIVEP value. If ITEM is nil, count
+ ;; across the whole structure, else count only across
+ ;; subtree whose ancestor is ITEM.
+ (lambda (item structs)
+ (mapc
+ (lambda (s)
+ (let* ((pre (org-list-struct-prev-alist s))
+ (items
+ (if recursivep
+ (or (and item (org-list-get-subtree item s pre))
+ (mapcar 'car s))
+ (or (and item (org-list-get-all-children item s pre))
+ (org-list-get-all-items
+ (org-list-get-top-point s) s pre))))
+ (cookies (delq nil (mapcar
+ (lambda (e)
+ (org-list-get-checkbox e s))
+ items))))
+ (setq c-all (+ (length cookies) c-all)
+ c-on (+ (org-count "[X]" cookies) c-on))))
+ structs))))
+ cookies-list backup-end structs-backup)
+ (goto-char (car bounds))
+ ;; 1. Build an alist for each cookie found within BOUNDS. The
+ ;; key will be position at beginning of cookie and values
+ ;; ending position, format of cookie, number of checked boxes
+ ;; to report, and total number of boxes.
+ (while (re-search-forward cookie-re (cdr bounds) t)
+ (save-excursion
+ (let ((c-on 0) (c-all 0))
+ (save-match-data
+ ;; There are two types of cookies: those at headings and those
+ ;; at list items.
+ (cond
+ ((and (org-on-heading-p)
+ (string-match "\\<todo\\>"
+ (downcase
+ (or (org-entry-get nil "COOKIE_DATA") "")))))
+ ;; This cookie is at an heading, but specifically for
+ ;; todo, not for checkboxes: skip it.
+ ((org-on-heading-p)
+ (setq backup-end (save-excursion
+ (outline-next-heading) (point)))
+ ;; This cookie is at an heading. Grab structure of
+ ;; every list containing a checkbox between point and
+ ;; next headline, and save them in STRUCTS-BACKUP
+ (while (org-search-forward-unenclosed box-re backup-end 'move)
+ (let* ((struct (org-list-struct))
+ (bottom (org-list-get-bottom-point struct)))
+ (setq structs-backup (cons struct structs-backup))
+ (goto-char bottom)))
+ (funcall count-boxes nil structs-backup))
+ ((org-at-item-p)
+ ;; This cookie is at an item. Look in STRUCTS-BACKUP
+ ;; to see if we have the structure of list at point in
+ ;; it. Else compute the structure.
+ (let ((item (point-at-bol)))
+ (if (and backup-end (< item backup-end))
+ (funcall count-boxes item structs-backup)
+ (setq end-entry bottom
+ structs-backup (list (org-list-struct)))
+ (funcall count-boxes item structs-backup))))))
+ ;; Build the cookies list, with appropriate information
+ (setq cookies-list (cons (list (match-beginning 1) ; cookie start
+ (match-end 1) ; cookie end
+ (match-beginning 2) ; percent?
+ c-on ; checked boxes
+ c-all) ; total boxes
+ cookies-list)))))
+ ;; 2. Apply alist to buffer, in reverse order so positions stay
+ ;; unchanged after cookie modifications.
+ (mapc (lambda (cookie)
+ (let* ((beg (car cookie))
+ (end (nth 1 cookie))
+ (percentp (nth 2 cookie))
+ (checked (nth 3 cookie))
+ (total (nth 4 cookie))
+ (new (if percentp
+ (format "[%d%%]" (/ (* 100 checked)
+ (max 1 total)))
+ (format "[%d/%d]" checked total))))
+ (goto-char beg)
+ (insert new)
+ (delete-region (point) (+ (point) (- end beg)))))
+ cookies-list))))
(defun org-get-checkbox-statistics-face ()
"Select the face for checkbox statistics.