Function: org-update-parent-todo-statistics

org-update-parent-todo-statistics is a byte-compiled function defined in org.el.gz.

Signature

(org-update-parent-todo-statistics)

Documentation

Update any statistics cookie in the parent of the current headline.

When org-hierarchical-todo-statistics is nil, statistics will cover the entire subtree and this will travel up the hierarchy and update statistics everywhere.

Source Code

;; Defined in /usr/src/emacs/lisp/org/org.el.gz
(defvar org-entry-property-inherited-from) ;; defined below
(defun org-update-parent-todo-statistics ()
  "Update any statistics cookie in the parent of the current headline.
When `org-hierarchical-todo-statistics' is nil, statistics will cover
the entire subtree and this will travel up the hierarchy and update
statistics everywhere."
  (let* ((prop (save-excursion
                 (org-up-heading-safe)
		 (org-entry-get nil "COOKIE_DATA" 'inherit)))
	 (recursive (or (not org-hierarchical-todo-statistics)
			(and prop (string-match "\\<recursive\\>" prop))))
	 (lim (or (and prop (marker-position org-entry-property-inherited-from))
		  0))
	 (first t)
	 (box-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
	 level ltoggle l1 new ndel
	 (cnt-all 0) (cnt-done 0) is-percent kwd
	 checkbox-beg cookie-present)
    (catch 'exit
      (save-excursion
	(beginning-of-line 1)
	(setq ltoggle (funcall outline-level))
	;; Three situations are to consider:

	;; 1. if `org-hierarchical-todo-statistics' is nil, repeat up
	;;    to the top-level ancestor on the headline;

	;; 2. If parent has "recursive" property, repeat up to the
	;;    headline setting that property, taking inheritance into
	;;    account;

	;; 3. Else, move up to direct parent and proceed only once.
	(while (and (setq level (org-up-heading-safe))
		    (or recursive first)
		    (>= (point) lim))
	  (setq first nil cookie-present nil)
	  (unless (and level
		       (not (string-match
			   "\\<checkbox\\>"
			   (downcase (or (org-entry-get nil "COOKIE_DATA")
					 "")))))
	    (throw 'exit nil))
          (while (re-search-forward box-re (line-end-position) t)
	    (setq cnt-all 0 cnt-done 0 cookie-present t)
	    (setq is-percent (match-end 2) checkbox-beg (match-beginning 0))
	    (save-match-data
	      (unless (outline-next-heading) (throw 'exit nil))
	      (while (and (looking-at org-complex-heading-regexp)
	                  (> (setq l1 (length (match-string 1))) level))
	        (setq kwd (and (or recursive (= l1 ltoggle))
	                       (match-string 2)))
	        (if (or (eq org-provide-todo-statistics 'all-headlines)
			(and (eq org-provide-todo-statistics t)
			     (or (member kwd org-done-keywords)))
	                (and (listp org-provide-todo-statistics)
			     (stringp (car org-provide-todo-statistics))
	                     (or (member kwd org-provide-todo-statistics)
				 (member kwd org-done-keywords)))
			(and (listp org-provide-todo-statistics)
			     (listp (car org-provide-todo-statistics))
			     (or (member kwd (car org-provide-todo-statistics))
				 (and (member kwd org-done-keywords)
				      (member kwd (cadr org-provide-todo-statistics))))))
	            (setq cnt-all (1+ cnt-all))
		  (and (eq org-provide-todo-statistics t)
		       kwd
		       (setq cnt-all (1+ cnt-all))))
		(when (or (and (member org-provide-todo-statistics '(t all-headlines))
			       (member kwd org-done-keywords))
			  (and (listp org-provide-todo-statistics)
			       (listp (car org-provide-todo-statistics))
			       (member kwd org-done-keywords)
			       (member kwd (cadr org-provide-todo-statistics)))
			  (and (listp org-provide-todo-statistics)
			       (stringp (car org-provide-todo-statistics))
			       (member kwd org-done-keywords)))
		  (setq cnt-done (1+ cnt-done)))
	        (outline-next-heading)))
	    (setq new
	          (if is-percent
		      (format "[%d%%]" (floor (* 100.0 cnt-done)
					      (max 1 cnt-all)))
	            (format "[%d/%d]" cnt-done cnt-all))
	          ndel (- (match-end 0) checkbox-beg))
	    (goto-char checkbox-beg)
	    (insert new)
	    (delete-region (point) (+ (point) ndel))
	    (when org-auto-align-tags (org-fix-tags-on-the-fly)))
	  (when cookie-present
	    (run-hook-with-args 'org-after-todo-statistics-hook
				cnt-done (- cnt-all cnt-done))))))
    (run-hooks 'org-todo-statistics-hook)))