РЕДАКТИРОВАТЬ (12 декабря 2013 г.): Первый рабочий проект.
РЕДАКТИРОВАТЬ (6 января 2014 г.): см. Эту связанную ветку для примера сопоставления любого элемента от звездочек в начале до многострочных заметок в конце задачи - https://stackoverflow.com/questions/20942168/ как к игре-синтаксический-на-нот-в-в-отслуживших а-задачи-в-орг-режиме
(defalias 'org-tags-view 'tag)
(defun tag (&optional todo-only match)
"Show all headlines (plus deadlines) for all `org-agenda-files' matching a TAGS criterion.
The prefix arg TODO-ONLY limits the search to TODO entries."
(interactive "P")
(if org-agenda-overriding-arguments
(setq todo-only (car org-agenda-overriding-arguments)
match (nth 1 org-agenda-overriding-arguments)))
(let* (
(org-tags-match-list-sublevels org-tags-match-list-sublevels)
(completion-ignore-case t)
rtn
rtnall
files
file
pos
matcher
buffer)
(when (and (stringp match) (not (string-match "\\S-" match)))
(setq match nil))
(setq matcher (org-make-tags-matcher match)
match (car matcher) matcher (cdr matcher))
(catch 'exit
(if org-agenda-sticky
(setq org-agenda-buffer-name
(if (stringp match)
(format "*Org Agenda(%s:%s)*"
(or org-keys (or (and todo-only "M") "m")) match)
(format "*Org Agenda(%s)*" (or (and todo-only "M") "m")))))
(org-agenda-prepare (concat "TAGS " match))
(org-compile-prefix-format 'tags)
(org-set-sorting-strategy 'tags)
(setq org-agenda-query-string match)
(setq org-agenda-redo-command
(list 'org-tags-view `(quote ,todo-only)
(list 'if 'current-prefix-arg nil `(quote ,org-agenda-query-string))))
(setq files (org-agenda-files nil 'ifmode)
rtnall nil)
(while (setq file (pop files))
(catch 'nextfile
(org-check-agenda-file file)
(setq buffer (if (file-exists-p file)
(org-get-agenda-file-buffer file)
(error "No such file %s" file)))
(if (not buffer)
(setq rtn (list
(format "ORG-AGENDA-ERROR: No such org-file %s" file))
rtnall (append rtnall rtn))
(with-current-buffer buffer
(unless (derived-mode-p 'org-mode)
(error "Agenda file %s is not in `org-mode'" file))
(save-excursion
(save-restriction
(if org-agenda-restrict
(narrow-to-region org-agenda-restrict-begin
org-agenda-restrict-end)
(widen))
(setq rtn (lawlist-scan-tags 'agenda matcher todo-only))
(setq rtnall (append rtnall rtn))))))))
(if org-agenda-overriding-header
(insert (org-add-props (copy-sequence org-agenda-overriding-header)
nil 'face 'org-agenda-structure) "\n")
(insert "TAGS: " match "\n") )
(org-agenda-mark-header-line (point-min))
(when rtnall
(insert (org-agenda-finalize-entries rtnall) "\n"))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(org-agenda-finalize)
(setq buffer-read-only t)
(font-lock-mode 1))))
(defun lawlist-scan-tags (action matcher todo-only &optional start-level)
(require 'org-agenda)
(let* ((re (concat "^"
(if start-level
(concat "\\*\\{" (number-to-string start-level) "\\} ")
org-outline-regexp)
" *\\(\\<\\("
(mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
(org-re "\\)\\>\\)? *\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$") ))
(props (list 'face 'default
'done-face 'org-agenda-done
'undone-face 'default
'mouse-face 'highlight
'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp
'help-echo
(format "mouse-2 or RET jump to org file %s"
(abbreviate-file-name
(or (buffer-file-name (buffer-base-buffer))
(buffer-name (buffer-base-buffer)))))))
(case-fold-search nil)
(org-map-continue-from nil)
lspos tags tags-list
(tags-alist (list (cons 0 org-file-tags)))
(llast 0) rtn rtn1 level category i txt
todo marker entry priority)
(when (not (or (member action '(agenda sparse-tree)) (functionp action)))
(setq action (list 'lambda nil action)))
(save-excursion
(goto-char (point-min))
(when (eq action 'sparse-tree)
(org-overview)
(org-remove-occur-highlights))
(while (re-search-forward re nil t)
(setq org-map-continue-from nil)
(catch :skip
(setq todo (if (match-end 1) (org-match-string-no-properties 2))
tags (if (match-end 4) (org-match-string-no-properties 4)))
(goto-char (setq lspos (match-beginning 0)))
(setq level (org-reduced-level (funcall outline-level))
category (org-get-category))
(setq i llast llast level)
(while (>= i level)
(when (setq entry (assoc i tags-alist))
(setq tags-alist (delete entry tags-alist)))
(setq i (1- i)))
(when tags
(setq tags (org-split-string tags ":")
tags-alist
(cons (cons level tags) tags-alist)))
(setq tags-list
(if org-use-tag-inheritance
(apply 'append (mapcar 'cdr (reverse tags-alist)))
tags)
org-scanner-tags tags-list)
(when org-use-tag-inheritance
(setcdr (car tags-alist)
(mapcar (lambda (x)
(setq x (copy-sequence x))
(org-add-prop-inherited x))
(cdar tags-alist))))
(when (and tags org-use-tag-inheritance
(or (not (eq t org-use-tag-inheritance))
org-tags-exclude-from-inheritance))
(setcdr (car tags-alist)
(org-remove-uninherited-tags (cdar tags-alist))))
(when (and
(and (or (not todo-only) (member todo org-not-done-keywords))
(let ((case-fold-search t) (org-trust-scanner-tags t))
(eval matcher)))
(progn
(unless (eq action 'sparse-tree) (org-agenda-skip))
t)
(or (not todo-only)
(and (member todo org-not-done-keywords)
(or (not org-agenda-tags-todo-honor-ignore-options)
(not (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item))))))
(cond
((eq action 'sparse-tree)
(and org-highlight-sparse-tree-matches
(org-get-heading) (match-end 0)
(org-highlight-new-match
(match-beginning 1) (match-end 1)))
(org-show-context 'tags-tree))
((eq action 'agenda)
(setq txt (lawlist-org-get-heading))
(goto-char lspos)
(setq marker (org-agenda-new-marker))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker 'org-category category
'todo-state todo
'priority priority 'type "tagsmatch")
(push txt rtn))
((functionp action)
(setq org-map-continue-from nil)
(save-excursion
(setq rtn1 (funcall action))
(push rtn1 rtn)))
(t (error "Invalid action")))
(unless org-tags-match-list-sublevels
(org-end-of-subtree t)
(backward-char 1))))
(if org-map-continue-from
(goto-char org-map-continue-from)
(and (= (point) lspos) (end-of-line 1)))))
(when (and (eq action 'sparse-tree)
(not org-sparse-tree-open-archived-trees))
(org-hide-archived-subtrees (point-min) (point-max)))
(nreverse rtn)))
(defun lawlist-org-get-heading (&optional no-tags no-todo)
"Return the heading of the current entry, without the stars.
When NO-TAGS is non-nil, don't include tags.
When NO-TODO is non-nil, don't include TODO keywords."
(save-excursion
(org-back-to-heading t)
(cond
((and no-tags no-todo)
(looking-at org-complex-heading-regexp)
(match-string 4))
(no-tags
(looking-at (concat org-outline-regexp
"\\(.*?\\)"
"\\(?:[ \t]+:[[:alnum:]:_@#%]+:\\)?[ \t]*$"))
(match-string 1))
(no-todo
(looking-at org-todo-line-regexp)
(match-string 3))
(t (looking-at org-heading-regexp)
(concat
(match-string 1)
" "
(match-string 2)
(if (and (looking-at lawlist-org-heading-regexp) (match-string 3))
(match-string 3)) )))))
(defvar lawlist-org-heading-regexp "^\\(\\*+\\)\\(?: +\\(.*?\\)\\)?[ \t]*\\(\n.*DEADLINE.*$\\)"
"Custom match org headline, plus the second line with a deadline.")