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