daily pastebin goal
81%
SHARE
TWEET

Untitled

a guest Jul 11th, 2018 60 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. (defun org+-element-container (el &optional type)
  2.   "Return the element of TYPE where element EL is contained.
  3. TYPE defaults to 'headline.
  4. Returns nil if El has no container with type TYPE."
  5.   (unless type (setq type 'headline))
  6.   (while (and el
  7.               (null (eq (org-element-type el) type)))
  8.     (setq el (org-element-property :parent el)))
  9.   el)
  10.  
  11. (defsubst org+-element-set-property (el prop val)
  12.   "Set property PROP of element EL to VAL."
  13.   (setf (nth 1 el) (plist-put (nth 1 el) prop val)))
  14.  
  15. (defsubst org+-element-set-parent (el parent)
  16.   "Set parent of element EL to PARENT."
  17.   (org+-element-set-property el :parent parent))
  18.  
  19. (defun org+-element-add-contents (el item &optional append afterp)
  20.   "Add ITEM to org element EL.
  21. Thereby the :parent property of ITEM is set to EL.
  22. You should create ITEM by `org-element-copy',
  23. `org-element-create', or `org-element-extract'.
  24. Those functions either create a new element or unlink
  25. the element from the parse tree.
  26. That way there is no parent when this function is called.
  27.  
  28. AFTERP is nil or a predicate with an org element
  29. as its only argument.
  30. ITEM is inserted after the first element of EL
  31. for which AFTERP returns non-nil.
  32. The new ITEM is appended to the existing content
  33. if AFTERP is undecisive and APPEND is non-nil
  34. and prepend otherwise."
  35.   (org+-element-set-parent item el)
  36.   (let* ((contents (org-element-contents el))
  37.          (ptr contents)
  38.          found)
  39.     (when afterp
  40.       (while ptr
  41.         (if (funcall afterp (car ptr))
  42.             (progn
  43.               (setcdr ptr (cons item (cdr ptr)))
  44.               (org-element-set-contents el contents) ;; pro forma
  45.               (setq found t
  46.                     ptr nil))
  47.           (setq ptr (cdr ptr)))))
  48.     (unless found
  49.       (org-element-set-contents
  50.        el
  51.        (if append
  52.            (setcdr (last contents) (cons item nil))
  53.          (cons item contents))))))
  54.  
  55. (defcustom org+-copy-id_log-clock-allow-duplicates nil
  56.   "Allow duplicated clock entries in logbooks when copying
  57. clock entries from id_log to id."
  58.   :group 'org
  59.   :type 'boolean)
  60.  
  61. (defsubst org+-element-clocks=-p (clock1 clock2)
  62.   "Test whether clock elements CLOCK1 and CLOCK2 are equivalent."
  63.   (string-equal (org-element-interpret-data clock1)
  64.                 (org-element-interpret-data clock2)))
  65.  
  66. (require 'subr-x)
  67.  
  68. (defmacro with-current-file (filename &rest body)
  69.   "Temporarily visit FILENAME to execute BODY.
  70. If a buffer is already visiting FILENAME re-use that buffer.
  71. Otherwise create a new buffer for visiting FILENAME
  72. and kill that buffer if it is unmodified after executing BODY."
  73.   (declare (indent 1) (debug (form body)))
  74.   (let ((file-buffer (make-symbol "file-buffer"))
  75.     (file-name (make-symbol "file-name"))
  76.     (old-file-buffer (make-symbol "old-file-buffer")))
  77.     `(let* ((,file-name ,filename)
  78.         (,old-file-buffer (find-buffer-visiting ,file-name))
  79.         (,file-buffer (or ,old-file-buffer
  80.                                 (find-file-noselect ,file-name))))
  81.        (with-current-buffer ,file-buffer
  82.          (unwind-protect
  83.          (progn
  84.            ,@body)
  85.        (unless (or ,old-file-buffer
  86.                (buffer-modified-p))
  87.          (kill-buffer)))))))
  88.  
  89. (defun multivalued-alist-insert (alist key val &optional dup key-plist val-keylist)
  90.   "Extend the multivalued alist by the mapping from KEY to VAL.
  91. Allow duplicated values for one KEY if DUP is non-nil.
  92. KEY-PLIST is a keyword-value plist passed to `cl-assert' for testing KEY.
  93. VAL-PLIST is a keyword-vlaue plist passed to `cl-member' for testing membership of VAL."
  94.   (let ((slot (apply #'cl-assoc key alist key-plist)))
  95.     (if slot
  96.         (when (or dup
  97.                   (null (apply #'cl-member val (cdr slot) val-keylist)))
  98.           (setcdr slot (cons val (cdr slot))))
  99.       (setq alist (cons (list key val) alist))))
  100.   alist)
  101. ;; test:
  102. ;; (setq l '((1 a) (2 b c) (3 d e f)))
  103. ;; (multivalued-alist-insert l 2 'b t) ;; duplicated
  104. ;; (multivalued-alist-insert l 2 'b) ;; not duplicated
  105. ;; (multivalued-alist-insert l 4 'g) ;; new key
  106.  
  107. (defun org+-copy-id_log-clock-collect (&optional clock-map hap)
  108.   "Return an alist mapping targets to clock entries.
  109. The clock entries are collected from headers with appropriate ID_LOG properties.
  110. The new clocks are inserted into the alist CLOCK-MAP.
  111. If HAP is non-nil only search current top level header for ID_LOG entries."
  112.   (save-excursion
  113.     (save-restriction
  114.       (when hap
  115.         (org-up-heading-safe)
  116.         (let* ((el (org-element-at-point))
  117.                (b (progn
  118.                     (cl-assert (eq (org-element-type el) 'headline)
  119.                                nil
  120.                                "No headline found.")
  121.                     (org-element-property :begin el)))
  122.                (e (org-element-property :end el)))
  123.           (narrow-to-region b e)))
  124.       (let ((tree (org-element-parse-buffer)))
  125.         (org-element-map
  126.             tree
  127.             'clock
  128.           (lambda (clock)
  129.             (when-let ((headline (org+-element-container clock))
  130.                        (id (org-element-property :ID_LOG headline)))
  131.               (setq clock-map (multivalued-alist-insert
  132.                                clock-map id clock nil
  133.                                '(:test string-equal)
  134.                                '(:test org+-element-clocks=-p))))))
  135.         clock-map))))
  136.  
  137. (defun org+-add-clock-to-log-in-headline (headline clock)
  138.   "Extend org element HEADLINE by CLOCK.
  139. Also creates a logbook if it does not exist yet in HEADLINE.
  140. Return non-nil if HEADLINE has changed."
  141.   (let ((logbook (car
  142.                   (org-element-map
  143.                       headline
  144.                       'drawer
  145.                     (lambda (logbook)
  146.                       (let ((drawer-name (org-element-property :drawer-name logbook)))
  147.                         (when (and (stringp drawer-name)
  148.                                    (string-equal drawer-name "LOGBOOK"))
  149.                           logbook)))
  150.                     nil nil 'no-recursion))))
  151.     (if logbook ;; logbook already existing -- just add CLOCK to it.
  152.         (when (or org+-copy-id_log-clock-allow-duplicates
  153.                   (null (org-element-map logbook
  154.                             'clock
  155.                           (lambda (log-clock)
  156.                             (when (org+-element-clocks=-p log-clock clock)
  157.                               log-clock)))))
  158.           (org+-element-add-contents logbook (org-element-copy clock))
  159.           t)
  160.       ;; logbook missing -- create one with CLOCK as entry
  161.       (let ((section (org-element-map headline 'section #'identity nil t t)))
  162.         (unless section
  163.           (setq section (org-element-create 'section))
  164.           (org+-element-add-contents headline section))
  165.         (setq logbook (org-element-create 'drawer (list :parent clock
  166.                                                         :drawer-name "LOGBOOK")))
  167.         (org+-element-add-contents logbook clock)
  168.         (org+-element-add-contents section logbook nil
  169.                                    (lambda (el)
  170.                                      (eq (org-element-type el) 'property-drawer))))
  171.       t)))
  172.  
  173. (defun org+-copy-id_log-clock (&optional clock-map)
  174.   "Copy all clock entries from ID_LOG headlines to ID headlines.
  175. See option `org+-copy-id_log-clock-allow-duplicates'.
  176. Return non-nil if the buffer has been rewritten."
  177.   (interactive)
  178.   (unless clock-map (setq clock-map (org+-copy-id_log-clock-collect)))
  179.   (let ((tree (org-element-parse-buffer))
  180.         rewrite)
  181.     ;; modify tree and print it out
  182.     (org-element-map
  183.         tree
  184.         'headline
  185.       (lambda (headline)
  186.         (when-let ((id (org-element-property :ID headline))
  187.                    (clocks (cdr (assoc-string id clock-map))))
  188.           (cl-loop for clock in clocks do
  189.                    (setq rewrite (or
  190.                                   (org+-add-clock-to-log-in-headline headline clock)
  191.                                   rewrite))
  192.                    ))))
  193.     (when rewrite
  194.       (delete-region (point-min) (point-max))
  195.       (insert (org-element-interpret-data tree))
  196.       t)))
  197.  
  198. (defun org+-agenda-copy-id_log-clock (&optional hap)
  199.   "Copy all clock entries from ID_LOG headlines to ID headlines in agenda files.
  200. If HAP is non-nil only search the header at point for ID_LOG.
  201. Interactively HAP is the prefix argument."
  202.   (interactive "P")
  203.   (let ((agenda-files (org-agenda-files t))
  204.         clock-map)
  205.     (if hap
  206.         (setq clock-map (org+-copy-id_log-clock-collect clock-map t))
  207.       (dolist (file agenda-files)
  208.         (with-current-file file
  209.           (setq clock-map (org+-copy-id_log-clock-collect clock-map)))))
  210.     (dolist (file agenda-files)
  211.       (with-current-file file
  212.           (org+-copy-id_log-clock clock-map)))))
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top