lisp/org-fireforg.el

   1 ;;; org-fireforg.el --- provide functionality for interaction of
   2 ;;;                     Fireforg, a Firefox extension, with org mode
   3
   4
   5 ;; Copyright 2009 Andreas Burtzlaff
   6 ;;
   7 ;; Author: Andreas Burtzlaff < andreas at burtzlaff dot de >
   8 ;; Version: 0.1alpha13
   9 ;; Keywords: org-mode firefox annotations
  10 ;;
  11 ;; This file is not part of GNU Emacs.
  12 ;;
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17 ;;
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; if not, write to the Free Software
  25 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;  Protocol:
  30 ;;
  31 ;;    fireforg-show-annotation://<file (encoded)>/<header (encoded)>
  32 ;;    ---
  33 ;;      Opens the given file in emacs and searches for header
  34 ;;
  35 ;;    fireforg-bibtex-entry://<BibTeX entry (encoded)>
  36 ;;    ---
  37 ;;      Sends a BibTeX entry that is formatted according to `org-fireforg-received-bibtex-format'
  38 ;;      and put into the kill ring
  39
  40 (require 'org)
  41
  42 (require 'org-protocol)
  43
  44 (require 'bibtex)
  45
  46 (add-to-list 'org-protocol-protocol-alist
  47              '("Fireforg show annotation: fireforg-show-annotation://<file (encoded)>/<header (encoded)>"
  48               :protocol "fireforg-show-annotation"
  49               :function org-fireforg-show-annotation))
  50
  51 (add-to-list 'org-protocol-protocol-alist
  52              '("Fireforg get bibtex entry: fireforg-bibtex-entry://<bibtex entry (encoded)>"
  53               :protocol "fireforg-bibtex-entry"
  54               :function org-fireforg-receive-bibtex-entry))
  55
  56 (defgroup org-fireforg nil
  57   "Options for the Fireforg extension of Org-mode."
  58   :group 'org)
  59
  60 (defcustom org-fireforg-received-bibtex-format 'heading
  61   "Non-nil means, transform bibtex entries.
  62
  63   If the variable is `headers' the entry is transformed into a
  64   heading with the bibtex entries as properties prefixed with
  65   `BIB_'. The CUSTOM_ID is set to the bibtex key."
  66   :group 'org-fireforg
  67   :type '(choice
  68           (const :tag "Create heading with properties" heading)
  69           (const :tag "BibTex" nil)
  70           (const :tag "Create heading with properties and BibTeX entry as content" headingWithPropsAndBibTeXContent)
  71           (const :tag "Create heading with BibTeX entry as content" headingWithBibTeXContent)))
  72
  73 ;; Searches for header in given file
  74 (defun org-fireforg-show-annotation (data)
  75   (let* ((arguments (org-protocol-split-data data t))
  76          (file (nth 0 arguments))
  77          (heading (nth 1 arguments))
  78          (frameList (or (visible-frame-list) (frame-list) )))
  79         (find-file file)
  80         (goto-char (point-min))
  81         (re-search-forward (regexp-quote heading))
  82         (beginning-of-line)
  83         (org-show-context)
  84         (if frameList (select-frame-set-input-focus (car frameList)))
  85 ))
  86
  87
  88 ;; Renamed functions of rewritten org-registry.el
  89 ;; Temporarily moved here to avoid confusing.
  90 ;; Subject to change.
  91
  92
  93 ;; This needs to be customizable
  94 (defun org-fireforg-registry-file-set () (org-agenda-files))
  95
  96 (defcustom org-fireforg-registry-file
  97   (concat (getenv "HOME") "/.org-fireforg-registry.el")
  98   "The Org registry file."
  99   :group 'org-fireforg-registry
 100   :type 'file)
 101
 102 (defcustom org-fireforg-registry-file-xml
 103   (concat (getenv "HOME") "/.org-fireforg-registry.xml")
 104   "The Org registry file in xml format. Used by fireforg."
 105   :group 'org-fireforg-registry
 106   :type 'file)
 107
 108 (defcustom org-fireforg-registry-find-file 'find-file-other-window
 109   "How to find visit files."
 110   :type 'function
 111   :group 'org-fireforg-registry)
 112
 113 (defvar org-fireforg-registry-alist nil
 114   "An alist containing the Org registry.")
 115
 116
 117 ;;;###autoload
 118 (defun org-fireforg-registry-initialize (&optional from-scratch)
 119   "Initialize `org-fireforg-registry-alist'.
 120 If FROM-SCRATCH is non-nil or the registry does not exist yet,
 121 create a new registry from scratch and eval it. If the registry
 122 exists, eval `org-fireforg-registry-file' and make it the new value for
 123 `org-fireforg-registry-alist'."
 124   (interactive "P")
 125   ;;(message (concat "org-fireforg-registry-initialize: org-agenda-files = " (with-output-to-string (prin1 org-agenda-files)))) ;; DEBUG
 126   (cond ((or from-scratch (not (file-exists-p org-fireforg-registry-file)))
 127           ;; create a new registry
 128           (setq org-fireforg-registry-alist nil)
 129           (mapc
 130            (lambda (file)
 131              (setq org-fireforg-registry-alist (org-fireforg-registry-get-entries (expand-file-name file) org-fireforg-registry-alist)))
 132            (org-fireforg-registry-file-set))
 133
 134 ;;        (when from-scratch
 135             (org-fireforg-registry-create org-fireforg-registry-alist)
 136             (org-fireforg-registry-create-xml org-fireforg-registry-alist))
 137         (t
 138          ;; eval the registry file
 139          (with-temp-buffer
 140            (insert-file-contents org-fireforg-registry-file)
 141 ;;         (eval-buffer) ;; reloading the registry is not working yet. Use (org-fireforg-registry-initialize t) for the time being.
 142            )
 143          (org-fireforg-registry-create-xml org-fireforg-registry-alist))))
 144
 145 ;;;###autoload
 146 (defun org-fireforg-registry-insinuate ()
 147   "Call `org-fireforg-registry-update' after saving in Org-mode.
 148 Use with caution.  This could slow down things a bit."
 149   (interactive)
 150   (add-hook 'org-mode-hook
 151             (lambda() (add-hook 'after-save-hook
 152                                 'org-fireforg-registry-update t t))))
 153
 154 ;; Warning: complex data structure ahead.
 155 (defun org-fireforg-registry-get-entries (currentFile &optional registry)
 156   "Merge all Org links in FILE into the registry."
 157   (let (bufstr
 158         (result registry)
 159         (add-entry-for (function (lambda (link desc)
 160                                    (let* ((point (match-beginning 0))
 161                                           (onHeading (org-on-heading-p))
 162                                           (headingPoint 0)
 163                                           (headingTagsAndDOI
 164                                            (save-excursion
 165                                              (if (org-before-first-heading-p) (cons "" nil)
 166                                                (org-back-to-heading t)
 167                                                (setq headingPoint (point))
 168                                                (let ((ohc (org-heading-components)))
 169                                                  (list (nth 4 ohc) (org-get-tags-at) (org-entry-get headingPoint "BIB_doi"))))))
 170                                           (heading (car headingTagsAndDOI))
 171                                           (tags (nth 1 headingTagsAndDOI))
 172                                           (doi (if (nth 2 headingTagsAndDOI) (org-fireforg-bibtex-trim-string (nth 2 headingTagsAndDOI))))
 173                                           (contentEntry (list point desc onHeading))
 174                                           (headingEntry (list heading headingPoint onHeading tags (list contentEntry) doi))
 175                                           (fileEntry (list (expand-file-name currentFile) (list headingEntry)))
 176                                           (linkEntry (list link (list fileEntry)))
 177                                           (existingLinkEntry (assoc link result))
 178                                           (existingFileEntry (assoc (expand-file-name currentFile) (nth 1 existingLinkEntry)))
 179                                           (existingHeadingEntry (assoc heading (nth 1 existingFileEntry))))
 180
 181                                      (cond (existingLinkEntry
 182                                             (cond (existingFileEntry
 183                                                    (cond (existingHeadingEntry (setf (nth 4 existingHeadingEntry) (cons contentEntry (nth 4 existingHeadingEntry))))
 184                                                          (t (setf (nth 1 existingFileEntry) (cons headingEntry (nth 1 existingFileEntry))))))
 185                                                   (t (setf (nth 1 existingLinkEntry) (cons fileEntry (nth 1 existingLinkEntry))))))
 186                                            (t (add-to-list 'result linkEntry))))))
 187
 188                        ))
 189
 190     (with-temp-buffer
 191       (insert-file-contents currentFile)
 192       ;; Turn on org-mode in order to use org-heading-components and org-get-tags-at
 193       ;; This can have severe impact on performance for large files, so I want to get rid of this requirement.
 194       (org-mode)
 195       (goto-char (point-min))
 196       (while (re-search-forward org-bracket-link-regexp nil t)
 197         (funcall add-entry-for (match-string-no-properties 1) (or (match-string-no-properties 3) "No description")))
 198       (goto-char (point-min))
 199       (while (re-search-forward org-angle-link-re nil t)
 200         (funcall add-entry-for (concat (match-string-no-properties 1) ":" (match-string-no-properties 2)) "" ))
 201       (goto-char (point-min))
 202       (while (re-search-forward org-plain-link-re nil t)
 203         (funcall add-entry-for (match-string-no-properties 0) "" ))
 204       (goto-char (point-min))
 205       ;; add all DOI's in properties as urls with prefix "http://dx.doi.org/"
 206       (org-map-entries
 207        (lambda ()
 208          (let ((doi (org-entry-get (point) "BIB_doi")))
 209            ;;(message (concat "current file:" currentFile))
 210            (if doi
 211                (funcall add-entry-for
 212                         ;; link
 213                         ;; Due to a bug in Zotero it might happen that
 214                         ;; the doi identifier is enclosed in two sets
 215                         ;; of "{}" brackets.
 216                         ;; Therefore the function org-fireforg-bibtex-trim-string is apply two times.
 217                         (org-fireforg-doi-to-url (org-fireforg-bibtex-trim-string (org-fireforg-bibtex-trim-string doi)))
 218                         ;; description
 219                         (nth 4 (org-heading-components)))))))
 220       result)))
 221
 222 ;;;###autoload
 223 (defun org-fireforg-registry-update ()
 224   "Update the registry for the current Org file, if it is in org-fireforg-registry-file-set."
 225   (interactive)
 226   (unless (org-mode-p) (error "Not in org-mode"))
 227   (cond ((not (file-exists-p org-fireforg-registry-file))
 228          ;; registry-file doesn't exist -> create it from scratch
 229          (org-fireforg-registry-initialize t))
 230         (t
 231          ;; update existing registry-file
 232          (let ((from-file (expand-file-name (buffer-file-name))))
 233            (cond ((member from-file (mapcar 'expand-file-name (org-fireforg-registry-file-set)))
 234                   (let ((registryFiltered (org-fireforg-registry-filter-where-filename-not from-file org-fireforg-registry-alist)))
 235                     (setq org-fireforg-registry-alist (org-fireforg-registry-get-entries from-file registryFiltered))
 236                     (org-fireforg-registry-create org-fireforg-registry-alist)
 237                     (org-fireforg-registry-create-xml org-fireforg-registry-alist)
 238                     ;;(message (format "Org registry updated for %s. Found %i entries. Registry contains %i entries." (file-name-nondirectory from-file) (length new-entries) (length org-fireforg-registry-alist)))
 239                     ))
 240                  ;;              (t (message (format "Current file %s is not in org-fireforg-registry-file-set." from-file)))
 241                  )))))
 242
 243 ;; requires expanded filename as argument
 244 (defun org-fireforg-registry-filter-where-filename-not (filename registry)
 245   (cond ((not registry) nil)
 246         ((nlistp registry) (error "org-fireforg-registry-filter-where-filename-not: argument registry is not a list"))
 247         (t
 248          (mapcar (lambda (linkEntry)
 249                    (list (car linkEntry)
 250                          (org-fireforg-registry-filter
 251                           (lambda (fileEntry)
 252                             (not (string= (expand-file-name (car fileEntry)) filename)))
 253                           (nth 1 linkEntry))))
 254                  registry))))
 255
 256
 257 (defun org-fireforg-registry-create (entries)
 258   "Create `org-fireforg-registry-file' with ENTRIES."
 259   (let (entry)
 260     (with-temp-buffer
 261       (find-file org-fireforg-registry-file)
 262       (erase-buffer)
 263       (insert
 264          (concat ";; -*- emacs-lisp -*-\n"
 265                  ";; Org registry\n"
 266                  ";; You shouldn't try to modify this buffer manually\n\n"
 267                  "(setq org-fireforg-registry-alist\n"
 268                  (org-fireforg-registry-to-string-rec org-fireforg-registry-alist) ")"))
 269
 270       (set-buffer-file-coding-system 'utf-8)
 271       (save-buffer)
 272       (kill-buffer (current-buffer))))
 273   (message "Org registry created"))
 274
 275 (defun org-fireforg-registry-to-string-rec (obj)
 276   "Return elisp code that generates an object with identical content as the argument"
 277   (cond ((not obj) "nil")
 278         ((stringp obj) (concat "\"" obj "\""))
 279         ((nlistp obj) (with-output-to-string (prin1 obj)))
 280         (t ;; obj is a list
 281           (concat "(list " (mapconcat 'org-fireforg-registry-to-string-rec obj " ") ")")
 282          )
 283   )
 284 )
 285
 286 (defun org-fireforg-registry-create-xml (entries)
 287   "Create org-fireforg-registry-file-xml with ENTRIES in xml format."
 288   (with-temp-buffer
 289     (insert
 290      (concat "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"yes\" ?>\n<orgregistry>\n"
 291              (reduce 'concat (mapcar (lambda (linkEntry)
 292                                        (concat "<link url=\"" (url-insert-entities-in-string (nth 0 linkEntry)) "\">\n"
 293                                                (reduce 'concat (mapcar (lambda (fileEntry)
 294                                                                          (let ((file (nth 0 fileEntry)))
 295                                                                            (reduce 'concat (mapcar (lambda (headingEntry)
 296                                                                                                      (concat " <heading file=\"" (url-insert-entities-in-string file) "\" "
 297                                                                                                              "text=\""          (url-insert-entities-in-string (nth 0 headingEntry)) "\" "
 298                                                                                                              "point=\""         (number-to-string (nth 1 headingEntry)) "\" "
 299                                                                                                              "linkInHeading=\"" (url-insert-entities-in-string (if (nth 2 headingEntry) "t" "f")) "\" "
 300                                                                                                              "tags=\""          (if (nth 3 headingEntry)
 301                                                                                                                                     (url-insert-entities-in-string (concat ":" (mapconcat 'identity (nth 3 headingEntry) ":") ":"))
 302                                                                                                                                     "") "\" "
 303                                                                                                              (if (nth 5 headingEntry) (concat "doi=\"" (nth 5 headingEntry) "\"  ") "")
 304                                                                                                              ">\n  "
 305                                                                                                              (reduce 'concat (mapcar (lambda (contentEntry)
 306                                                                                                                                        (concat "  <contentEntry point=\"" (number-to-string (nth 0 contentEntry)) "\" "
 307                                                                                                                                                "description=\"" (url-insert-entities-in-string (nth 1 contentEntry)) "\" "
 308                                                                                                                                                "inHeading=\"" (if (nth 2 contentEntry) "t" "f") "\"/>\n"))
 309                                                                                                                                      (nth 4 headingEntry)) :initial-value "")
 310                                                                                                              " </heading>"))
 311                                                                                                    (nth 1 fileEntry)) :initial-value "")
 312                                                                            )
 313                                                                          ) (nth 1 linkEntry)) :initial-value "")
 314                                                "</link>\n")) entries) :initial-value "")
 315              "</orgregistry>"))
 316
 317     (when (file-writable-p org-fireforg-registry-file-xml)
 318       (set-buffer-file-coding-system 'utf-8)
 319       (write-region (point-min)
 320                     (point-max)
 321                     org-fireforg-registry-file-xml))))
 322
 323 (defun org-fireforg-registry-filter (condp lst)
 324   (delq nil
 325           (mapcar (lambda (x) (and (funcall condp x) x)) lst)))
 326
 327 (defun org-fireforg-receive-bibtex-entry (data)
 328   ;;(message "Received bibtex string") ;; DEBUG
 329   (let* ((arguments (org-protocol-split-data data t))
 330          (bibtex (nth 0 arguments))
 331          (bibtexParsed (org-fireforg-parse-bibtex-entry-wrapper bibtex)))
 332     (kill-new (cond ((eq org-fireforg-received-bibtex-format 'heading)
 333                      (concat (org-fireforg-generate-heading bibtexParsed) "\n" (org-fireforg-bibtex-entry-to-properties bibtexParsed)))
 334                     ((eq org-fireforg-received-bibtex-format 'headingWithPropsAndBibTeXContent)
 335                      (concat (org-fireforg-generate-heading bibtexParsed) "\n" (org-fireforg-bibtex-entry-to-properties bibtexParsed) bibtex "\n"))
 336                     ((eq org-fireforg-received-bibtex-format 'headingWithBibTeXContent)
 337                      (concat (org-fireforg-generate-heading bibtexParsed) "\n" bibtex "\n"))
 338                     ((not org-fireforg-received-bibtex-format) bibtex)))
 339     (message "Saved BibTeX entry to kill ring.")
 340     )
 341   nil)
 342
 343 (defun org-fireforg-parse-bibtex-entry-wrapper (bibtexEntryString)
 344   (with-temp-buffer
 345     (insert bibtexEntryString)
 346     (goto-char (point-min))
 347     ;;(bibtex-next-field t)
 348     (re-search-forward "@")
 349     (goto-char (match-beginning 0))
 350     (bibtex-parse-entry)))
 351
 352 (defun org-fireforg-bibtex-trim-string (string)
 353   (replace-regexp-in-string "[\"}] *$" "" (replace-regexp-in-string "^ *[{\"]" "" string)))
 354
 355 (defun org-fireforg-headings-to-bibtex (&optional match)
 356   (reduce 'concat (org-map-entries (lambda () (concat (org-fireforg-heading-to-bibtex-entry) "\n\n")) match )))
 357
 358 (defun org-fireforg-heading-to-bibtex-entry ()
 359   (let* ((properties (org-entry-properties))
 360          (type (cdr (assoc "BIB_entryType" properties)))
 361          (id (cdr (assoc "CUSTOM_ID" properties)))
 362          (properties (rassq-delete-all id (rassq-delete-all type properties))))
 363     (cond ((and type id)
 364            (concat "@" type "{" id
 365                    (reduce 'concat
 366                            (mapcar (lambda (prop) (if (and (> (length (car prop)) 4) (string= (substring (car prop) 0 4) "BIB_")) (concat ",\n  " (substring (car prop) 4) " = " (cdr prop) ))) properties ) :initial-value "") "\n}")))))
 367
 368 (defun org-fireforg-bibtex-entry-to-properties (bibtexEntry)
 369   (concat ":PROPERTIES:\n"
 370    (reduce 'concat (mapcar (lambda (entry)
 371      (concat (cond ((string= (car entry) "=key=") "  :CUSTOM_ID")
 372                    ((string= (car entry) "=type=") "  :BIB_entryType")
 373                    (t (concat "  :BIB_" (car entry) ))) ": " (cdr entry) "\n")) bibtexEntry) :initial-value "")
 374    ":END:\n"))
 375
 376 (defun org-fireforg-generate-heading (bibtexEntry)
 377   (let ((heading (concat "* [[" (org-fireforg-bibtex-trim-string (cdr (assoc "url" bibtexEntry))) "][" (org-fireforg-bibtex-trim-string (cdr (assoc "title" bibtexEntry))) "]]" )))
 378     ;;(with-temp-buffer (insert heading) (goto-char (point-min)) (org-id-get-create) (buffer-substring (point-min) (point-max)))
 379     heading
 380     ))
 381
 382 ;; exports the bibtex properties of the current buffer to selectable file
 383 (defun org-fireforg-export-bibtex-to-file (file)
 384   (interactive "F")
 385   (save-excursion
 386     (cond ((not file) (error "No file supplied"))
 387           ((let ((bibtex (org-fireforg-headings-to-bibtex)))
 388              (with-temp-buffer
 389              (insert bibtex)
 390              (write-file file t)))))))
 391
 392 (defun org-fireforg-export-bibtex-to-new-buffer ()
 393   (interactive)
 394   (let ((bibtex (org-fireforg-headings-to-bibtex))
 395         ;; find nearest bibliography entry before point
 396         (prevId (save-excursion
 397                   (while (and (not (org-before-first-heading-p)) (if (org-at-heading-p) (or (null (org-entry-get (point) "CUSTOM_ID")) (string= (org-entry-get (point) "CUSTOM_ID") "")) 1) (not (bobp)) ) (progn (backward-char) (org-back-to-heading t) ) )
 398                   (if (or (org-before-first-heading-p) (bobp)) nil (org-entry-get (point) "CUSTOM_ID")))))
 399     (switch-to-buffer (generate-new-buffer "*BibTeX export*"))
 400     (insert bibtex)
 401     (goto-char (point-min))
 402     (if prevId (progn (re-search-forward (regexp-quote prevId)) (beginning-of-line)))
 403     (bibtex-mode)))
 404
 405 (defun org-fireforg-doi-to-url (string)
 406        (concat "http://dx.doi.org/"
 407  (replace-regexp-in-string " " "%20"
 408  (replace-regexp-in-string "#" "%23"
 409  (replace-regexp-in-string "\"" "%22"
 410  (replace-regexp-in-string "%" "%25" string))))))
 411
 412 (provide 'org-fireforg)