code.delx.au - gnu-emacs-elpa/blob - packages/gnorb/gnorb-org.el

   1 ;;; gnorb-org.el --- The Org-centric functions of gnorb
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Abrahamsen  <eric@ericabrahamsen.net>
   6 ;; Keywords:
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;
  24
  25 ;;; Code:
  26
  27 (require 'gnorb-utils)
  28 (require 'cl-lib)
  29
  30 (defgroup gnorb-org nil
  31   "The Org bits of Gnorb."
  32   :tag "Gnorb Org"
  33   :group 'gnorb)
  34
  35 (defcustom gnorb-org-after-message-setup-hook nil
  36   "Hook run in a message buffer after setting up the message from
  37   `gnorb-org-handle-mail' or `gnorb-org-email-subtree'."
  38   :group 'gnorb-org
  39   :type 'hook)
  40
  41 (defcustom gnorb-org-trigger-actions
  42   '(("todo state" . todo)
  43     ("take note" . note)
  44     ("don't associate" . no-associate)
  45     ("only associate" . associate)
  46     ("capture to child" . cap-child)
  47     ("capture to sibling" . cap-sib))
  48   "List of potential actions that can be taken on headings.
  49
  50 When triggering an Org heading after receiving or sending a
  51 message, this option lists the possible actions to take. Built-in
  52 actions include:
  53
  54 todo state: Associate the message, and change TODO state.
  55 take note: Associate the message, and take a note.
  56 don't associate: Do nothing at all, don't connect the message and TODO.
  57 only associate: Associate the message with this heading, do nothing else.
  58 capture to child: Associate this message with a new child heading.
  59 capture to sibling: Associate this message with a new sibling heading.
  60
  61 You can reorder this list or remove items as suits your workflow.
  62 The two \"capture\" options will use the value of
  63 `gnorb-gnus-new-todo-capture-key' to find the appropriate
  64 template.
  65
  66 You can also add custom actions to the list. Actions should be a
  67 cons of a string tag and a symbol indicating a custom function.
  68 This function will be called on the heading in question, and
  69 passed a plist containing information about the message from
  70 which we're triggering."
  71   :group 'gnorb-org
  72   :type 'list)
  73
  74 (defcustom gnorb-org-msg-id-key "GNORB_MSG_ID"
  75   "The name of the org property used to store the Message-IDs
  76   from relevant messages. This is no longer used, and will be
  77   removed soon."
  78   :group 'gnorb-org
  79   :type 'string)
  80
  81 (defcustom gnorb-org-mail-scan-scope 2
  82   "Number of paragraphs to scan for mail-related links.
  83
  84 When handling a TODO heading with `gnorb-org-handle-mail', Gnorb
  85 will typically reply to the most recent message associated with
  86 this heading. If there are no such messages, or message tracking
  87 is disabled entirely, or `gnorb-org-handle-mail' has been called
  88 with a prefix arg, the heading and body text of the subtree under
  89 point will instead be scanned for gnus:, mailto:, and bbdb:
  90 links. This option controls how many paragraphs of body text to
  91 scan. Set to 0 to only look in the heading.")
  92
  93 (make-obsolete-variable
  94  'gnorb-org-mail-scan-strategies
  95  "This variable has been superseded by `gnorb-org-trigger-actions'"
  96  "September 12, 2014" 'set)
  97
  98 (make-obsolete-variable
  99  'gnorb-org-mail-scan-state-changes
 100  "This variable has been superseded by `gnorb-org-trigger-actions'"
 101  "September 12, 2014" 'set)
 102
 103 (make-obsolete-variable
 104  'gnorb-org-mail-scan-function
 105  "This variable has been superseded by `gnorb-org-trigger-actions'"
 106  "September 12, 2014" 'set)
 107
 108 (defcustom gnorb-org-find-candidates-match nil
 109   "When scanning all org files for heading related to an incoming
 110 message, this option will limit which headings will be offered as
 111 target candidates. Specifically it will be used as the second
 112 argument to `org-map-entries', and syntax is the same as that
 113 used in an agenda tags view."
 114   :group 'gnorb-org
 115   :type 'symbol)
 116
 117 ;;;###autoload
 118 (defun gnorb-org-contact-link (rec)
 119   "Prompt for a BBDB record and insert a link to that record at
 120 point.
 121
 122 There's really no reason to use this instead of regular old
 123 `org-insert-link' with BBDB completion. But there might be in the
 124 future!"
 125   ;; this needs to handle an active region.
 126   (interactive (list (gnorb-prompt-for-bbdb-record)))
 127   (let* ((name (bbdb-record-name rec))
 128          (link (concat "bbdb:" (org-link-escape name))))
 129     (org-store-link-props :type "bbdb" :name name
 130                           :link link :description name)
 131     (if (called-interactively-p 'any)
 132         (insert (format "[[%s][%s]]" link name))
 133       link)))
 134
 135 (defun gnorb-org-restore-after-send ()
 136   "After an email is sent, go through all the org ids that might
 137 have been in the outgoing message's headers and call
 138 `gnorb-trigger-todo-action' on each one, then put us back where
 139 we came from."
 140   (delete-other-windows)
 141   (dolist (id gnorb-message-org-ids)
 142     (org-id-goto id)
 143     (gnorb-trigger-todo-action nil id))
 144   ;; this is a little unnecessary, but it may save grief
 145   (setq gnorb-gnus-message-info nil)
 146   (setq gnorb-message-org-ids nil)
 147   (gnorb-restore-layout))
 148
 149 (defun gnorb-org-extract-links (&optional arg region)
 150   "See if there are viable links in the subtree under point."
 151   ;; We're not currently using the arg. What could we do with it?
 152   (let (strings)
 153     ;; If the region was active, only use the region
 154     (if region
 155         (push (buffer-substring (car region) (cdr region))
 156               strings)
 157       ;; Otherwise collect the heading text, and all the paragraph
 158       ;; text.
 159       (save-restriction
 160         (org-narrow-to-subtree)
 161         (let ((head (org-element-at-point))
 162               (tree (org-element-parse-buffer)))
 163           (push (org-element-property
 164                  :raw-value
 165                  head)
 166                 strings)
 167           (org-element-map tree '(paragraph drawer)
 168             (lambda (p)
 169               (push (org-element-interpret-data p)
 170                     strings))
 171             nil nil 'drawer))))
 172     (when strings
 173       ;; Limit number of paragraphs based on
 174       ;; `gnorb-org-mail-scan-scope'
 175       (setq strings
 176             (cond ((eq gnorb-org-mail-scan-scope 'all)
 177                    strings)
 178                   ((numberp gnorb-org-mail-scan-scope)
 179                    (cl-subseq
 180                     strings 0 (min
 181                                (length strings)
 182                                (1+ gnorb-org-mail-scan-scope))))
 183                   ;; We could provide more options here. 'tree vs
 184                   ;; 'subtree, for instance.
 185                   (t
 186                    strings)))
 187       (with-temp-buffer
 188         (dolist (s strings)
 189           (insert s)
 190           (insert "\n"))
 191         (goto-char (point-min))
 192         (gnorb-scan-links (point-max) 'gnus 'mail 'bbdb)))))
 193
 194 (defun gnorb-org-extract-mail-stuff (&optional arg region)
 195   "Decide how to hande the Org heading under point as an email task.
 196
 197 See the docstring of `gnorb-org-handle-mail' for details."
 198   (if (or (not gnorb-tracking-enabled)
 199           region)
 200       (gnorb-org-extract-links arg region)
 201     ;; Get all the messages associated with the IDS in this subtree.
 202     (let ((assoc-msg-ids
 203            (delete-dups
 204             (cl-mapcan
 205              (lambda (id)
 206                (gnorb-registry-org-id-search id))
 207              (gnorb-collect-ids)))))
 208       (gnorb-org-extract-mail-tracking assoc-msg-ids arg region))))
 209
 210 (defun gnorb-org-extract-mail-tracking (assoc-msg-ids &optional arg region)
 211
 212   (let* ((all-links (gnorb-org-extract-links nil region))
 213          ;; The latest (by the creation-time registry key) of all the
 214          ;; tracked messages that were not sent by our user.
 215          (latest-msg-id
 216           (when assoc-msg-ids
 217             (car
 218              (sort
 219               (cl-remove-if
 220                (lambda (m)
 221                  (let ((from (car (gnus-registry-get-id-key m 'sender))))
 222                    (or (null from)
 223                        (string-match-p
 224                         user-mail-address from)
 225                        (string-match-p
 226                         message-alternative-emails from))))
 227                assoc-msg-ids)
 228               (lambda (r l)
 229                 (time-less-p
 230                  (car (gnus-registry-get-id-key l 'creation-time))
 231                  (car (gnus-registry-get-id-key r 'creation-time))))))))
 232          (msg-id-link
 233           (when latest-msg-id
 234             (gnorb-msg-id-to-link latest-msg-id))))
 235     (cond
 236      ;; If there are no tracked messages, or the user has specifically
 237      ;; requested we ignore them with the prefix arg, just return the
 238      ;; found links in the subtree.
 239      ((or arg
 240           (null msg-id-link))
 241       all-links)
 242      ;; Otherwise ignore the other links in the subtree, and return
 243      ;; the latest message.
 244      (msg-id-link
 245       `(:gnus ,(list msg-id-link))))))
 246
 247 (defvar message-beginning-of-line)
 248
 249 (defun gnorb-org-setup-message
 250     (&optional messages mails from cc bcc attachments text ids)
 251   "Common message setup routine for other gnorb-org commands.
 252 MESSAGES is a list of gnus links pointing to messages -- we
 253 currently only use the first of the list. MAILS is a list of
 254 email address strings suitable for inserting in the To header.
 255 ATTACHMENTS is a list of filenames to attach. TEXT is a string or
 256 buffer, which is inserted in the message body. IDS is one or more
 257 Org heading ids, associating the outgoing message with those
 258 headings."
 259   (require 'gnorb-gnus)
 260   (if (not messages)
 261       ;; Either compose new message...
 262       (compose-mail)
 263     ;; ...or follow link and start reply.
 264     (condition-case err
 265         (gnorb-reply-to-gnus-link (car messages))
 266       (error (gnorb-restore-layout)
 267              (signal (car err) (cdr err)))))
 268   ;; Add MAILS to message To header.
 269   (when mails
 270     (message-goto-to)
 271     (when messages
 272       (insert ", "))
 273     (insert (mapconcat 'identity mails ", ")))
 274   ;; Commenting this out because
 275   ;; `gnorb-gnus-check-outgoing-headers' is set unconditionally in the
 276   ;; `message-send-hook, so this should be redundant.  Also, we've
 277   ;; switched to using message-send-actions.
 278
 279   ;; (add-to-list
 280   ;; 'message-exit-actions 'gnorb-org-restore-after-send t) Set
 281   ;; headers from MAIL_* properties (from, cc, and bcc).
 282   (cl-flet ((sh (h)
 283                 (when (cdr h)
 284                   (funcall (intern (format "message-goto-%s" (car h))))
 285                   (let ((message-beginning-of-line t)
 286                         (show-trailing-whitespace t))
 287                     (message-beginning-of-line)
 288                     (unless (bolp)
 289                       (kill-line))
 290                     (insert (cdr h))))))
 291     (dolist (h `((from . ,from) (cc . ,cc) (bcc . ,bcc)))
 292       (sh h)))
 293   ;; attach ATTACHMENTS
 294   (map-y-or-n-p
 295    (lambda (a) (format "Attach %s to outgoing message? "
 296                        (file-name-nondirectory a)))
 297    (lambda (a)
 298      (mml-attach-file a (mm-default-file-encoding a)
 299                       nil "attachment"))
 300    attachments
 301    '("file" "files" "attach"))
 302   ;; insert text, if any
 303   (when text
 304     (message-goto-body)
 305     (insert"\n")
 306     (if (bufferp text)
 307         (insert-buffer-substring text)
 308       (insert text)))
 309   ;; insert org ids, if any
 310   (when ids
 311     (unless (listp ids)
 312       (setq ids (list ids)))
 313     (save-excursion
 314       (save-restriction
 315         (message-narrow-to-headers)
 316         (dolist (i ids)
 317           (goto-char (point-at-bol))
 318           (open-line 1)
 319           ;; this function hardly does anything
 320           (message-insert-header
 321            (intern gnorb-mail-header) i)))))
 322   ;; put point somewhere reasonable
 323   (if (or mails messages)
 324       (if (not messages)
 325           (message-goto-subject)
 326         (message-goto-body))
 327     (message-goto-to))
 328   (run-hooks 'gnorb-org-after-message-setup-hook))
 329
 330 (defun gnorb-org-attachment-list (&optional id)
 331   "Get a list of files (absolute filenames) attached to the
 332 current heading, or the heading indicated by optional argument ID."
 333   (when (featurep 'org-attach)
 334     (let* ((attach-dir (save-excursion
 335                          (when id
 336                            (org-id-goto id))
 337                          (org-attach-dir t)))
 338            (files
 339             (mapcar
 340              (lambda (f)
 341                (expand-file-name f attach-dir))
 342              (org-attach-file-list attach-dir))))
 343       files)))
 344
 345 (defvar message-mode-hook)
 346
 347 ;;;###autoload
 348 (defun gnorb-org-handle-mail (&optional arg text file)
 349   "Handle current headline as a mail TODO.
 350
 351 How this function behaves depends on whether you're using Gnorb
 352 for email tracking, also on the prefix arg, and on the active
 353 region.
 354
 355 If tracking is enabled and there is no prefix arg, Gnorb will
 356 begin a reply to the newest associated message that wasn't sent
 357 by the user -- ie, the Sender header doesn't match
 358 `user-mail-address' or `message-alternative-emails'.
 359
 360 If tracking is enabled and there is a prefix arg, ignore the
 361 tracked messages and instead scan the subtree for mail-related
 362 links. This means links prefixed with gnus:, mailto:, or bbdb:.
 363 See `gnorb-org-mail-scan-scope' to limit the scope of this scan.
 364 Do something appropriate with the resulting links.
 365
 366 With a double prefix arg, ignore all tracked messages and all
 367 links, and compose a blank new message.
 368
 369 If tracking is enabled and you want to reply to a
 370 specific (earlier) message in the tracking history, use
 371 `gnorb-org-view' to open an nnir *Summary* buffer containing all
 372 the messages, and reply to the one you want. Your reply will be
 373 automatically tracked, as well.
 374
 375 If tracking is not enabled and you want to use a specific link in
 376 the subtree as a basis for the email action, then put the region
 377 around that link before you call this message."
 378   (interactive "P")
 379   (setq gnorb-window-conf (current-window-configuration))
 380   (move-marker gnorb-return-marker (point))
 381   (when (eq major-mode 'org-agenda-mode)
 382     ;; If this is all the different types, we could skip the check.
 383     (org-agenda-check-type t 'agenda 'timeline 'todo 'tags 'search)
 384     (org-agenda-check-no-diary)
 385     (let* ((marker (or (org-get-at-bol 'org-hd-marker)
 386                        (org-agenda-error)))
 387            (buffer (marker-buffer marker))
 388            (pos (marker-position marker)))
 389       (switch-to-buffer buffer)
 390       (widen)
 391       (goto-char pos)))
 392   (let ((region
 393          (when (use-region-p)
 394            (cons (region-beginning) (region-end)))))
 395     (deactivate-mark)
 396     (save-excursion
 397       (unless (org-back-to-heading t)
 398         (error "Not in an org item"))
 399       (cl-flet ((mp (p) (org-entry-get (point) p t)))
 400         ;; Double prefix means ignore everything and compose a blank
 401         ;; mail.
 402         (let* ((links (unless (equal arg '(16))
 403                         (gnorb-org-extract-mail-stuff arg region)))
 404                (attachments (gnorb-org-attachment-list))
 405                (from (mp "MAIL_FROM"))
 406                (cc (mp "MAIL_CC"))
 407                (bcc (mp "MAIL_BCC"))
 408                (org-id (org-id-get-create))
 409                (recs (plist-get links :bbdb))
 410                (message-mode-hook (copy-sequence message-mode-hook))
 411                mails)
 412           (when file
 413             (cons file attachments))
 414           (when recs
 415             (setq recs
 416                   (delq nil
 417                         (mapcar
 418                          (lambda (r)
 419                            (car (bbdb-message-search
 420                                  (org-link-unescape r)
 421                                  nil)))
 422                          recs))))
 423           (when recs
 424             (dolist (r recs)
 425               (push (bbdb-mail-address r) mails)))
 426           (when (and recs
 427                      gnorb-bbdb-posting-styles)
 428             (add-hook 'message-mode-hook
 429                       (lambda ()
 430                         (gnorb-bbdb-configure-posting-styles (cdr recs))
 431                         (gnorb-bbdb-configure-posting-styles (list (car recs))))))
 432           (gnorb-org-setup-message
 433            (plist-get links :gnus)
 434            (append mails (plist-get links :mail))
 435            from cc bcc
 436            attachments text org-id))))))
 437
 438 ;;; Email subtree
 439
 440 (defcustom gnorb-org-email-subtree-text-parameters nil
 441   "A plist of export parameters corresponding to the EXT-PLIST
 442   argument to the export functions, for use when exporting to
 443   text."
 444   :group 'gnorb-org
 445   :type 'boolean)
 446
 447 (defcustom gnorb-org-email-subtree-file-parameters nil
 448   "A plist of export parameters corresponding to the EXT-PLIST
 449   argument to the export functions, for use when exporting to a
 450   file."
 451   :group 'gnorb-org
 452   :type 'boolean)
 453
 454 (defcustom gnorb-org-email-subtree-text-options '(nil t nil t)
 455   "A list of ts and nils corresponding to Org's export options,
 456 to be used when exporting to text. The options, in order, are
 457 async, subtreep, visible-only, and body-only."
 458   :group 'gnorb-org
 459   :type 'list)
 460
 461 (defcustom gnorb-org-email-subtree-file-options '(nil t nil nil)
 462   "A list of ts and nils corresponding to Org's export options,
 463 to be used when exporting to a file. The options, in order, are
 464 async, subtreep, visible-only, and body-only."
 465   :group 'gnorb-org
 466   :type 'list)
 467
 468 (defcustom gnorb-org-export-extensions
 469   '((latex ".tex")
 470     (ascii ".txt")
 471     (html ".html")
 472     (org ".org")
 473     (icalendar ".ics")
 474     (man ".man")
 475     (md ".md")
 476     (odt ".odt") ; not really, though
 477     (texinfo ".texi")
 478     (beamer ".tex"))
 479   "Correspondence between export backends and their
 480 respective (usual) file extensions. Ugly way to do it, but what
 481 the hey..."
 482   :group 'gnorb-org)
 483
 484 (defvar org-export-show-temporary-export-buffer)
 485
 486 ;;;###autoload
 487 (defun gnorb-org-email-subtree (&optional arg)
 488   "Call on a subtree to export it either to a text string or a file,
 489 then compose a mail message either with the exported text
 490 inserted into the message body, or the exported file attached to
 491 the message.
 492
 493 Export options default to the following: When exporting to a
 494 buffer: async = nil, subtreep = t, visible-only = nil, body-only
 495 = t. Options are the same for files, except body-only is set to
 496 nil. Customize `gnorb-org-email-subtree-text-options' and
 497 `gnorb-org-email-subtree-file-options', respectively.
 498
 499 Customize `gnorb-org-email-subtree-parameters' to your preferred
 500 default set of parameters."
 501   ;; I sure would have liked to use the built-in dispatch ui, but it's
 502   ;; got too much hard-coded stuff.
 503   (interactive "P")
 504   (org-back-to-heading t)
 505   (let* ((backend-string
 506           (org-completing-read
 507            "Export backend: "
 508            (mapcar (lambda (b)
 509                      (symbol-name (org-export-backend-name b)))
 510                    org-export--registered-backends)
 511            nil t))
 512          (backend-symbol (intern backend-string))
 513          (f-or-t (org-completing-read "Export as file or text? "
 514                                       '("file" "text") nil t))
 515          (org-export-show-temporary-export-buffer nil)
 516          (opts (if (equal f-or-t "text")
 517                    gnorb-org-email-subtree-text-options
 518                  gnorb-org-email-subtree-file-options))
 519          (result
 520           (if (equal f-or-t "text")
 521               (apply 'org-export-to-buffer
 522                      `(,backend-symbol
 523                        "*Gnorb Export*"
 524                        ,@opts
 525                        ,gnorb-org-email-subtree-text-parameters))
 526             (apply 'org-export-to-file
 527                    `(,backend-symbol
 528                      ,(org-export-output-file-name
 529                        (cl-second (assoc backend-symbol gnorb-org-export-extensions))
 530                        t gnorb-tmp-dir)
 531                      ,@opts
 532                      ,gnorb-org-email-subtree-file-parameters))))
 533          text file)
 534     (setq gnorb-window-conf (current-window-configuration))
 535     (move-marker gnorb-return-marker (point))
 536     (if (bufferp result)
 537         (setq text result)
 538       (setq file result))
 539     (gnorb-org-handle-mail arg text file)))
 540
 541 (defcustom gnorb-org-capture-collect-link-p t
 542   "Should the capture process store a link to the gnus message or
 543   BBDB record under point, even if it's not part of the template?
 544   You'll probably end up needing it, anyway."
 545   :group 'gnorb-org)
 546
 547 (defun gnorb-org-capture-collect-link ()
 548   (when gnorb-org-capture-collect-link-p
 549     (let ((buf (org-capture-get :original-buffer)))
 550       (when buf
 551         (with-current-buffer buf
 552           (when (memq major-mode '(gnus-summary-mode
 553                                    gnus-article-mode
 554                                    bbdb-mode))
 555             (call-interactively 'org-store-link)))))))
 556
 557 (add-hook 'org-capture-mode-hook 'gnorb-org-capture-collect-link)
 558
 559 ;;; Agenda/BBDB popup stuff
 560
 561 (defcustom gnorb-org-agenda-popup-bbdb nil
 562   "Should Agenda tags search pop up a BBDB buffer with matching
 563   records?
 564
 565 Records are considered matching if they have an `org-tags' field
 566 matching the current Agenda search. The name of that field can be
 567 customized with `gnorb-bbdb-org-tag-field'."
 568   :group 'gnorb-org)
 569
 570 (defcustom gnorb-org-bbdb-popup-layout 'pop-up-multi-line
 571   "Default BBDB buffer layout for automatic Org Agenda display."
 572   :group 'gnorb-org
 573   :type '(choice (const one-line)
 574                  (const multi-line)
 575                  (const full-multi-line)
 576                  (symbol)))
 577
 578 ;;;###autoload
 579 (defun gnorb-org-popup-bbdb (&optional str)
 580   "In an `org-tags-view' Agenda buffer, pop up a BBDB buffer
 581 showing records whose `org-tags' field matches the current tags
 582 search."
 583   ;; I was hoping to use `org-make-tags-matcher' directly, then snag
 584   ;; the tagmatcher from the resulting value, but there doesn't seem
 585   ;; to be a reliable way of only getting the tag-related returns. But
 586   ;; I'd still like to use that function. So an ugly hack to first
 587   ;; remove non-tag contents from the query string, and then make a
 588   ;; new call to `org-make-tags-matcher'.
 589   (interactive)
 590   (require 'gnorb-bbdb)
 591   (let (recs)
 592     (cond ((and
 593             (and (eq major-mode 'org-agenda-mode)
 594                  (eq org-agenda-type 'tags))
 595             (or (called-interactively-p 'any)
 596                 gnorb-org-agenda-popup-bbdb))
 597            (let ((todo-only nil)
 598                  (str (or str org-agenda-query-string))
 599                  (re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)\\([0-9]+\\)\\|\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)\\([<>=]\\{1,2\\}\\)\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)\\|[[:alnum:]_@#%]+\\)")
 600                  or-terms term rest out-or acc tag-clause)
 601              (setq or-terms (org-split-string str "|"))
 602              (while (setq term (pop or-terms))
 603                (setq acc nil)
 604                (while (string-match re term)
 605                  (setq rest (substring term (match-end 0)))
 606                  (let ((sub-term (match-string 0 term)))
 607                    (unless (save-match-data ; this isn't a tag, don't want it
 608                              (string-match "\\([<>=]\\)" sub-term))
 609                      (push sub-term acc))
 610                    (setq term rest)))
 611                (push (mapconcat 'identity (nreverse acc) "") out-or))
 612              (setq str (mapconcat 'identity (nreverse out-or) "|"))
 613              (setq tag-clause (cdr (org-make-tags-matcher str)))
 614              (unless (equal str "")
 615                (setq recs
 616                      (cl-remove-if-not
 617                       (lambda (r)
 618                         (let ((rec-tags (bbdb-record-xfield
 619                                          r gnorb-bbdb-org-tag-field)))
 620                           (and rec-tags
 621                                (let ((tags-list (if (stringp rec-tags)
 622                                                     (org-split-string rec-tags ":")
 623                                                   rec-tags))
 624                                      (case-fold-search t)
 625                                      (org-trust-scanner-tags t))
 626                                  (eval tag-clause)))))
 627                       (bbdb-records))))))
 628           ((eq major-mode 'org-mode)
 629            (save-excursion
 630              (org-back-to-heading)
 631              (let ((bound (org-element-property
 632                            :end (org-element-at-point)))
 633                    desc rec)
 634                (while (re-search-forward
 635                        org-bracket-link-analytic-regexp bound t)
 636                  (when (string-match-p "bbdb" (match-string 2))
 637                    (setq desc (match-string 5)
 638                          rec (bbdb-search (bbdb-records) desc desc desc)
 639                          recs (append recs rec))))))))
 640     (if recs
 641         (bbdb-display-records
 642          recs gnorb-org-bbdb-popup-layout)
 643       (when (get-buffer-window bbdb-buffer-name)
 644         (quit-window nil
 645                      (get-buffer-window bbdb-buffer-name)))
 646       (when (called-interactively-p 'any)
 647         (message "No relevant BBDB records")))))
 648
 649 (if (featurep 'gnorb-bbdb)
 650     (add-hook 'org-agenda-finalize-hook 'gnorb-org-popup-bbdb))
 651
 652 ;;; Groups from the gnorb gnus server backend
 653
 654 ;;;###autoload
 655 (defun gnorb-org-view (arg)
 656   "Search the subtree at point for links to gnus messages, and
 657 then show them in an ephemeral group, in Gnus.
 658
 659 With a prefix arg, create a search group that will persist across
 660 Gnus sessions, and can be refreshed.
 661
 662 This won't work unless you've added a \"nngnorb\" server to
 663 your gnus select methods."
 664   ;; this should also work on the active region, if there is one.
 665   (interactive "P")
 666   (require 'gnorb-gnus)
 667   (setq gnorb-window-conf (current-window-configuration))
 668   (move-marker gnorb-return-marker (point))
 669   (when (eq major-mode 'org-agenda-mode)
 670     (org-agenda-check-type t 'agenda 'timeline 'todo 'tags)
 671     (org-agenda-check-no-diary)
 672     (let* ((marker (or (org-get-at-bol 'org-hd-marker)
 673                        (org-agenda-error)))
 674            (buffer (marker-buffer marker))
 675            (pos (marker-position marker)))
 676       (switch-to-buffer buffer)
 677       (goto-char pos)
 678       (org-reveal)))
 679   (let (id)
 680     (save-excursion
 681       (org-back-to-heading)
 682       (setq id (concat "id+" (org-id-get-create)))
 683       (gnorb-gnus-search-messages
 684        id arg
 685        (replace-regexp-in-string
 686         org-bracket-link-regexp "\\3"
 687         (nth 4 (org-heading-components)))
 688        `(when (and (window-configuration-p gnorb-window-conf)
 689                    gnorb-return-marker)
 690           (set-window-configuration gnorb-window-conf)
 691           (goto-char gnorb-return-marker))))))
 692
 693 (provide 'gnorb-org)
 694 ;;; gnorb-org.el ends here