lisp/org-mobile.el

   1 ;;; org-mobile.el --- Code for asymmetric sync with a mobile device
   2 ;; Copyright (C) 2009 Free Software Foundation, Inc.
   3 ;;
   4 ;; Author: Carsten Dominik <carsten at orgmode dot org>
   5 ;; Keywords: outlines, hypermedia, calendar, wp
   6 ;; Homepage: http://orgmode.org
   7 ;; Version: 6.34trans
   8 ;;
   9 ;; This file is part of GNU Emacs.
  10 ;;
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15 ;;
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23 ;;
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25 ;;
  26 ;;; Commentary:
  27 ;;
  28 ;; This file contains the code to interact with Richard Moreland's iPhone
  29 ;; application MobileOrg.  This code is documented in Appendix B of the
  30 ;; Org-mode manual.  The code is not specific for the iPhone, however.
  31 ;; Any external viewer/flagging/editing application that uses the same
  32 ;; conventions could be used.
  33
  34 (require 'org)
  35 (require 'org-agenda)
  36 (eval-when-compile (require 'cl))
  37
  38 (defgroup org-mobile nil
  39   "Options concerning support for a viewer/editor on a mobile device."
  40   :tag "Org Mobile"
  41   :group 'org)
  42
  43 (defcustom org-mobile-files '(org-agenda-files)
  44   "Files to be staged for MobileOrg.
  45 This is basically a list of files and directories.  Files will be staged
  46 directly.  Directories will be search for files with the extension `.org'.
  47 In addition to this, the list may also contain the following symbols:
  48
  49 org-agenda-files
  50      This means include the complete, unrestricted list of files given in
  51      the variable `org-agenda-files'.
  52 org-agenda-text-search-extra-files
  53      Include the files given in the variable
  54      `org-agenda-text-search-extra-files'"
  55   :group 'org-mobile
  56   :type '(list :greedy t
  57                (option (const :tag "org-agenda-files" org-agenda-files))
  58                (option (const :tag "org-agenda-text-search-extra-files"
  59                               org-agenda-text-search-extra-files))
  60                (repeat :inline t :tag "Additional files"
  61                        (file))))
  62
  63 (defcustom org-mobile-directory ""
  64   "The WebDAV directory where the interaction with the mobile takes place."
  65   :group 'org-mobile
  66   :type 'directory)
  67
  68 (defcustom org-mobile-inbox-for-pull "~/org/from-mobile.org"
  69   "The file where captured notes and flags will be appended to.
  70 During the execution of `org-mobile-pull', the file
  71 `org-mobile-capture-file' will be emptied it's contents have
  72 been appended to the file given here.  This file should be in
  73 `org-directory', and not in the staging area or on the web server."
  74   :group 'org-mobile
  75   :type 'file)
  76
  77 (defconst org-mobile-capture-file "mobileorg.org"
  78   "The capture file where the mobile stores captured notes and flags.
  79 This should not be changed, because MobileOrg assumes this name.")
  80
  81 (defcustom org-mobile-index-file "index.org"
  82   "The index file with inks to all Org files that should be loaded by MobileOrg.
  83 Relative to `org-mobile-directory'.  The Address field in the MobileOrg setup
  84 should point to this file."
  85   :group 'org-mobile
  86   :type 'file)
  87
  88 (defcustom org-mobile-agendas 'all
  89   "The agendas that should be pushed to MobileOrg.
  90 Allowed values:
  91
  92 default  the weekly agenda and the global TODO list
  93 custom   all custom agendas defined by the user
  94 all      the custom agendas and the default ones
  95 list     a list of selection key(s) as string."
  96   :group 'org-mobile
  97   :type '(choice
  98           (const :tag "Default Agendas" default)
  99           (const :tag "Custom Agendas" custom)
 100           (const :tag "Default and Custom Agendas" all)
 101           (repeat :tag "Selected"
 102                   (string :tag "Selection Keys"))))
 103
 104 (defcustom org-mobile-force-id-on-agenda-items t
 105   "Non-nil means make all agenda items carry and ID."
 106   :group 'org-mobile
 107   :type 'boolean)
 108
 109 (defcustom org-mobile-force-mobile-change nil
 110   "Non-nil means force the change made on the mobile device.
 111 So even if there have been changes to the computer version of the entry,
 112 force the new value set on the mobile.
 113 When nil, mark the entry from the mobile with an error message.
 114 Instead of nil or t, this variable can also be a list of symbols, indicating
 115 the editing types for which the mobile version should always dominate."
 116   :group 'org-mobile
 117   :type '(choice
 118           (const :tag "Always" t)
 119           (const :tag "Never" nil)
 120           (set :greedy t :tag "Specify"
 121                (const todo)
 122                (const tags)
 123                (const priority)
 124                (const heading)
 125                (const body))))
 126
 127 (defcustom org-mobile-action-alist
 128   '(("edit" . (org-mobile-edit data old new)))
 129   "Alist with flags and actions for mobile sync.
 130 When flagging an entry, MobileOrg will create entries that look like
 131
 132   * F(action:data)  [[id:entry-id][entry title]]
 133
 134 This alist defines that the ACTION in the parentheses of F() should mean,
 135 i.e. what action should be taken.  The :data part in the parenthesis is
 136 optional.  If present, the string after the colon will be passed to the
 137 action form as the `data' variable.
 138 The car of each elements of the alist is an actions string.  The cdr is
 139 an Emacs Lisp form that will be evaluated with the cursor on the headline
 140 of that entry.
 141
 142 For now, it is not recommended to change this variable."
 143   :group 'org-mobile
 144   :type '(repeat
 145           (cons (string :tag "Action flag")
 146                 (sexp   :tag "Action form"))))
 147
 148 (defcustom org-mobile-checksum-binary (or (executable-find "shasum")
 149                                           (executable-find "sha1sum")
 150                                           (executable-find "md5sum")
 151                                           (executable-find "md5"))
 152   "Executable used for computing checksums of agenda files."
 153   :group 'org-mobile
 154   :type 'string)
 155
 156 (defvar org-mobile-pre-push-hook nil
 157   "Hook run before running `org-mobile-push'.
 158 This could be used to clean up `org-mobile-directory', for example to
 159 remove files that used to be included in the agenda but no longer are.
 160 The presence of such files would not really be a problem, but after time
 161 they may accumulate.")
 162
 163 (defvar org-mobile-post-push-hook nil
 164   "Hook run after running `org-mobile-push'.
 165 If Emacs does not have direct write access to the WebDAV directory used
 166 by the mobile device, this hook should be used to copy all files from the
 167 local staging directory `org-mobile-directory' to the WebDAV directory,
 168 for example using `rsync' or `scp'.")
 169
 170 (defvar org-mobile-pre-pull-hook nil
 171   "Hook run before executing `org-mobile-pull'.
 172 If Emacs does not have direct write access to the WebDAV directory used
 173 by the mobile device, this hook should be used to copy the capture file
 174 `mobileorg.org' from the WebDAV location to the local staging
 175 directory `org-mobile-directory'.")
 176
 177 (defvar org-mobile-post-pull-hook nil
 178   "Hook run after running `org-mobile-pull'.
 179 If Emacs does not have direct write access to the WebDAV directory used
 180 by the mobile device, this hook should be used to copy the emptied
 181 capture file `mobileorg.org' back to the WebDAV directory, for example
 182 using `rsync' or `scp'.")
 183
 184 (defvar org-mobile-last-flagged-files nil
 185   "List of files containing entries flagged in the latest pull.")
 186
 187 (defvar org-mobile-files-alist nil)
 188 (defvar org-mobile-checksum-files nil)
 189
 190 (defun org-mobile-prepare-file-lists ()
 191   (setq org-mobile-files-alist (org-mobile-files-alist))
 192   (setq org-mobile-checksum-files nil))
 193
 194 (defun org-mobile-files-alist ()
 195   "Expand the list in `org-mobile-files' to a list of existing files."
 196   (let* ((include-archives
 197           (and (member 'org-agenda-text-search-extra-files org-mobile-files)
 198                (member 'agenda-archives org-agenda-text-search-extra-files)
 199                t))
 200          (files
 201           (apply 'append
 202                  (mapcar
 203                   (lambda (f)
 204                     (cond
 205                      ((eq f 'org-agenda-files)
 206                       (org-agenda-files t include-archives))
 207                      ((eq f 'org-agenda-text-search-extra-files)
 208                       (delq 'agenda-archives
 209                             (copy-sequence
 210                              org-agenda-text-search-extra-files)))
 211                      ((and (stringp f) (file-directory-p f))
 212                       (directory-files f 'full "\\.org\\'"))
 213                      ((and (stringp f) (file-exists-p f))
 214                       (list f))
 215                      (t nil)))
 216                   org-mobile-files)))
 217          (orgdir-uname (file-name-as-directory (file-truename org-directory)))
 218          (orgdir-re (concat "\\`" (regexp-quote orgdir-uname)))
 219          uname seen rtn file link-name)
 220     ;; Make the files unique, and determine the name under which they will
 221     ;; be listed.
 222     (while (setq file (pop files))
 223       (if (not (file-name-absolute-p file))
 224           (setq file (expand-file-name file org-directory)))
 225       (setq uname (file-truename file))
 226       (unless (member uname seen)
 227         (push uname seen)
 228         (if (string-match orgdir-re uname)
 229             (setq link-name (substring uname (match-end 0)))
 230           (setq link-name (file-name-nondirectory uname)))
 231         (push (cons file link-name) rtn)))
 232     (nreverse rtn)))
 233
 234 ;;;###autoload
 235 (defun org-mobile-push ()
 236   "Push the current state of Org affairs to the WebDAV directory.
 237 This will create the index file, copy all agenda files there, and also
 238 create all custom agenda views, for upload to the mobile phone."
 239   (interactive)
 240   (let ((a-buffer (get-buffer org-agenda-buffer-name)))
 241     (let ((org-agenda-buffer-name "*SUMO*")
 242           (org-agenda-filter org-agenda-filter)
 243           (org-agenda-redo-command org-agenda-redo-command))
 244       (save-excursion
 245         (save-window-excursion
 246           (org-mobile-check-setup)
 247           (org-mobile-prepare-file-lists)
 248           (run-hooks 'org-mobile-pre-push-hook)
 249           (message "Creating agendas...")
 250           (let ((inhibit-redisplay t)) (org-mobile-create-sumo-agenda))
 251           (message "Creating agendas...done")
 252           (org-save-all-org-buffers) ; to save any IDs created by this process
 253           (message "Copying files...")
 254           (org-mobile-copy-agenda-files)
 255           (message "Writing index file...")
 256           (org-mobile-create-index-file)
 257           (message "Writing checksums...")
 258           (org-mobile-write-checksums)
 259           (run-hooks 'org-mobile-post-push-hook))))
 260     (redraw-display)
 261     (when (and a-buffer (buffer-live-p a-buffer))
 262       (if (not (get-buffer-window a-buffer))
 263           (kill-buffer a-buffer)
 264         (let ((cw (selected-window)))
 265           (select-window (get-buffer-window a-buffer))
 266           (org-agenda-redo)
 267           (select-window cw)))))
 268   (message "Files for mobile viewer staged"))
 269
 270 (defvar org-mobile-before-process-capture-hook nil
 271   "Hook that is run after content was moved to `org-mobile-inbox-for-pull'.
 272 The inbox file is visited by the current buffer, and the buffer is
 273 narrowed to the newly captured data.")
 274
 275 ;;;###autoload
 276 (defun org-mobile-pull ()
 277   "Pull the contents of `org-mobile-capture-file' and integrate them.
 278 Apply all flagged actions, flag entries to be flagged and then call an
 279 agenda view showing the flagged items."
 280   (interactive)
 281   (org-mobile-check-setup)
 282   (run-hooks 'org-mobile-pre-pull-hook)
 283   (let ((insertion-marker (org-mobile-move-capture)))
 284     (if (not (markerp insertion-marker))
 285         (message "No new items")
 286       (org-with-point-at insertion-marker
 287         (save-restriction
 288           (narrow-to-region (point) (point-max))
 289           (run-hooks 'org-mobile-before-process-capture-hook)))
 290       (org-with-point-at insertion-marker
 291         (org-mobile-apply (point) (point-max)))
 292       (move-marker insertion-marker nil)
 293       (run-hooks 'org-mobile-post-pull-hook)
 294       (when org-mobile-last-flagged-files
 295         ;; Make an agenda view of flagged entries, but only in the files
 296         ;; where stuff has been added.
 297         (put 'org-agenda-files 'org-restrict org-mobile-last-flagged-files)
 298         (let ((org-agenda-keep-restricted-file-list t))
 299           (org-agenda nil "?"))))))
 300
 301 (defun org-mobile-check-setup ()
 302   "Check if org-mobile-directory has been set up."
 303   (unless (and org-directory
 304                (stringp org-directory)
 305                (string-match "\\S-" org-directory)
 306                (file-exists-p org-directory)
 307                (file-directory-p org-directory))
 308     (error
 309      "Please set `org-directory' to the directory where your org files live"))
 310   (unless (and org-mobile-directory
 311                (stringp org-mobile-directory)
 312                (string-match "\\S-" org-mobile-directory)
 313                (file-exists-p org-mobile-directory)
 314                (file-directory-p org-mobile-directory))
 315     (error
 316      "Variable `org-mobile-directory' must point to an existing directory"))
 317   (unless (and org-mobile-inbox-for-pull
 318                (stringp org-mobile-inbox-for-pull)
 319                (string-match "\\S-" org-mobile-inbox-for-pull)
 320                (file-exists-p
 321                 (file-name-directory org-mobile-inbox-for-pull)))
 322     (error
 323      "Variable `org-mobile-inbox-for-pull' must point to a file in an existing directory")))
 324
 325 (defun org-mobile-create-index-file ()
 326   "Write the index file in the WebDAV directory."
 327   (let ((files-alist (sort (copy-sequence org-mobile-files-alist)
 328                            (lambda (a b) (string< (cdr a) (cdr b)))))
 329         (def-todo (default-value 'org-todo-keywords))
 330         (def-tags (default-value 'org-tag-alist))
 331         file link-name todo-kwds done-kwds tags drawers entry kwds dwds twds)
 332
 333     (org-prepare-agenda-buffers (mapcar 'car files-alist))
 334     (setq done-kwds (org-uniquify org-done-keywords-for-agenda))
 335     (setq todo-kwds (org-delete-all
 336                      done-kwds
 337                      (org-uniquify org-todo-keywords-for-agenda)))
 338     (setq drawers (org-uniquify org-drawers-for-agenda))
 339     (setq tags (org-uniquify
 340                 (delq nil
 341                       (mapcar
 342                        (lambda (e)
 343                          (cond ((stringp e) e)
 344                                ((listp e)
 345                                 (if (stringp (car e)) (car e) nil))
 346                                (t nil)))
 347                        org-tag-alist-for-agenda))))
 348     (with-temp-file
 349         (expand-file-name org-mobile-index-file org-mobile-directory)
 350       (while (setq entry (pop def-todo))
 351         (insert "#+READONLY\n")
 352         (setq kwds (mapcar (lambda (x) (if (string-match "(" x)
 353                                            (substring x 0 (match-beginning 0))
 354                                          x))
 355                            (cdr entry)))
 356         (insert "#+TODO: " (mapconcat 'identity kwds " ") "\n")
 357         (setq dwds (member "|" kwds)
 358               twds (org-delete-all dwds kwds)
 359               todo-kwds (org-delete-all twds todo-kwds)
 360               done-kwds (org-delete-all dwds done-kwds)))
 361       (when (or todo-kwds done-kwds)
 362         (insert "#+TODO: " (mapconcat 'identity todo-kwds " ") " | "
 363                 (mapconcat 'identity done-kwds " ") "\n"))
 364       (setq def-tags (mapcar
 365                       (lambda (x)
 366                         (cond ((null x) nil)
 367                               ((stringp x) x)
 368                               ((eq (car x) :startgroup) "{")
 369                               ((eq (car x) :endgroup) "}")
 370                               ((eq (car x) :newline) nil)
 371                               ((listp x) (car x))
 372                               (t nil)))
 373                       def-tags))
 374       (setq def-tags (delq nil def-tags))
 375       (setq tags (org-delete-all def-tags tags))
 376       (setq tags (sort tags (lambda (a b) (string< (downcase a) (downcase b)))))
 377       (setq tags (append def-tags tags nil))
 378       (insert "#+TAGS: " (mapconcat 'identity tags " ") "\n")
 379       (insert "#+DRAWERS: " (mapconcat 'identity drawers " ") "\n")
 380       (insert "#+ALLPRIORITIES: A B C" "\n")
 381       (when (file-exists-p (expand-file-name
 382                             org-mobile-directory "agendas.org"))
 383         (insert "* [[file:agendas.org][Agenda Views]]\n"))
 384       (while (setq entry (pop files-alist))
 385         (setq file (car entry)
 386               link-name (cdr entry))
 387         (insert (format "* [[file:%s][%s]]\n"
 388                         link-name link-name)))
 389       (push (cons org-mobile-index-file (md5 (buffer-string)))
 390             org-mobile-checksum-files))))
 391
 392 (defun org-mobile-copy-agenda-files ()
 393   "Copy all agenda files to the stage or WebDAV directory."
 394   (let ((files-alist org-mobile-files-alist)
 395         file buf entry link-name target-path target-dir check)
 396     (while (setq entry (pop files-alist))
 397       (setq file (car entry) link-name (cdr entry))
 398       (when (file-exists-p file)
 399         (setq target-path (expand-file-name link-name org-mobile-directory)
 400               target-dir (file-name-directory target-path))
 401         (unless (file-directory-p target-dir)
 402           (make-directory target-dir 'parents))
 403         (copy-file file target-path 'ok-if-exists)
 404         (setq check (shell-command-to-string
 405                      (concat org-mobile-checksum-binary " "
 406                              (shell-quote-argument (expand-file-name file)))))
 407         (when (string-match "[a-fA-F0-9]\\{30,40\\}" check)
 408           (push (cons link-name (match-string 0 check))
 409                 org-mobile-checksum-files))))
 410     (setq file (expand-file-name org-mobile-capture-file
 411                                  org-mobile-directory))
 412     (save-excursion
 413       (setq buf (find-file file))
 414       (and (= (point-min) (point-max)) (insert "\n"))
 415       (save-buffer)
 416       (push (cons org-mobile-capture-file (md5 (buffer-string)))
 417             org-mobile-checksum-files))
 418     (kill-buffer buf)))
 419
 420 (defun org-mobile-write-checksums ()
 421   "Create checksums for all files in `org-mobile-directory'.
 422 The table of checksums is written to the file mobile-checksums."
 423   (let ((sumfile (expand-file-name "checksums.dat" org-mobile-directory))
 424         (files org-mobile-checksum-files)
 425         entry file sum)
 426     (with-temp-file sumfile
 427       (set-buffer-file-coding-system 'undecided-unix nil)
 428       (while (setq entry (pop files))
 429         (setq file (car entry) sum (cdr entry))
 430         (insert (format "%s  %s\n" sum file))))))
 431
 432 (defun org-mobile-sumo-agenda-command ()
 433   "Return an agenda custom command that comprises all custom commands."
 434   (let ((custom-list
 435          ;; normalize different versions
 436          (delq nil
 437                (mapcar
 438                 (lambda (x)
 439                   (cond ((stringp (cdr x)) nil)
 440                         ((stringp (nth 1 x)) x)
 441                         ((not (nth 1 x)) (cons (car x) (cons "" (cddr x))))
 442                         (t (cons (car x) (cons "" (cdr x))))))
 443                 org-agenda-custom-commands)))
 444         (default-list '(("a" "Agenda" agenda) ("t" "All TODO" alltodo)))
 445         thelist new e key desc type match settings cmds gkey gdesc gsettings cnt)
 446     (cond
 447      ((eq org-mobile-agendas 'custom)
 448       (setq thelist custom-list))
 449      ((eq org-mobile-agendas 'default)
 450       (setq thelist default-list))
 451      ((eq org-mobile-agendas 'all)
 452       (setq thelist custom-list)
 453       (unless (assoc "t" thelist) (push '("t" "ALL TODO" alltodo) thelist))
 454       (unless (assoc "a" thelist) (push '("a" "Agenda" agenda) thelist)))
 455      ((listp org-mobile-agendas)
 456       (setq thelist (append custom-list default-list))
 457       (setq thelist (delq nil (mapcar (lambda (k) (assoc k thelist))
 458                                       org-mobile-agendas)))))
 459     (while (setq e (pop thelist))
 460       (cond
 461        ((stringp (cdr e))
 462         ;; this is a description entry - skip it
 463         )
 464        ((eq (nth 2 e) 'search)
 465         ;; Search view is interactive, skip
 466         )
 467        ((memq (nth 2 e) '(todo-tree tags-tree occur-tree))
 468         ;; These are trees, not really agenda commands
 469         )
 470        ((memq (nth 2 e) '(agenda alltodo todo tags tags-todo))
 471         ;; a normal command
 472         (setq key (car e) desc (nth 1 e) type (nth 2 e) match (nth 3 e)
 473               settings (nth 4 e))
 474         (setq settings
 475               (cons (list 'org-agenda-title-append
 476                           (concat "<after>KEYS=" key " TITLE: "
 477                                   (if (and (stringp desc) (> (length desc) 0))
 478                                       desc (symbol-name type))
 479                                   " " match "</after>"))
 480                     settings))
 481         (push (list type match settings) new))
 482        ((symbolp (nth 2 e))
 483         ;; A user-defined function, not sure how to handle that yet
 484         )
 485        (t
 486         ;; a block agenda
 487         (setq gkey (car e) gdesc (nth 1 e) gsettings (nth 3 e) cmds (nth 2 e))
 488         (setq cnt 0)
 489         (while (setq e (pop cmds))
 490           (setq type (car e) match (nth 1 e) settings (nth 2 e))
 491           (setq settings (append gsettings settings))
 492           (setq settings
 493                 (cons (list 'org-agenda-title-append
 494                             (concat "<after>KEYS=" gkey "#" (number-to-string
 495                                                       (setq cnt (1+ cnt)))
 496                                     " TITLE: " gdesc " " match "</after>"))
 497                       settings))
 498           (push (list type match settings) new)))))
 499     (and new (list "X" "SUMO" (reverse new)
 500                    '((org-agenda-compact-blocks nil))))))
 501
 502 (defvar org-mobile-creating-agendas nil)
 503 (defun org-mobile-write-agenda-for-mobile (file)
 504   (let ((all (buffer-string)) in-date id pl prefix line app short m sexp)
 505     (with-temp-file file
 506       (org-mode)
 507       (insert "#+READONLY\n")
 508       (insert all)
 509       (goto-char (point-min))
 510       (while (not (eobp))
 511         (cond
 512          ((looking-at "[ \t]*$")) ; keep empty lines
 513          ((looking-at "=+$")
 514           ;; remove underlining
 515           (delete-region (point) (point-at-eol)))
 516          ((get-text-property (point) 'org-agenda-structural-header)
 517           (setq in-date nil)
 518           (setq app (get-text-property (point)
 519                                        'org-agenda-title-append))
 520           (setq short (get-text-property (point)
 521                                          'short-heading))
 522           (when (and short (looking-at ".+"))
 523             (replace-match short)
 524             (beginning-of-line 1))
 525           (when app
 526             (end-of-line 1)
 527             (insert app)
 528             (beginning-of-line 1))
 529           (insert "* "))
 530          ((get-text-property (point) 'org-agenda-date-header)
 531           (setq in-date t)
 532           (insert "** "))
 533          ((setq m (or (get-text-property (point) 'org-hd-marker)
 534                       (get-text-property (point) 'org-marker)))
 535           (setq sexp (member (get-text-property (point) 'type)
 536                              '("diary" "sexp")))
 537           (if (setq pl (get-text-property (point) 'prefix-length))
 538               (progn
 539                 (setq prefix (org-trim (buffer-substring
 540                                         (point) (+ (point) pl)))
 541                       line (org-trim (buffer-substring
 542                                       (+ (point) pl)
 543                                       (point-at-eol))))
 544                 (delete-region (point-at-bol) (point-at-eol))
 545                 (insert line "<before>" prefix "</before>")
 546                 (beginning-of-line 1))
 547             (and (looking-at "[ \t]+") (replace-match "")))
 548           (insert (if in-date "***  " "**  "))
 549           (end-of-line 1)
 550           (insert "\n")
 551           (unless sexp
 552             (insert (org-agenda-get-some-entry-text
 553                      m 10 "   " 'planning)
 554                     "\n")
 555             (when (setq id
 556                         (if (org-bound-and-true-p
 557                              org-mobile-force-id-on-agenda-items)
 558                             (org-id-get m 'create)
 559                           (org-entry-get m "ID")))
 560               (insert "   :PROPERTIES:\n   :ORIGINAL_ID: " id
 561                       "\n   :END:\n")))))
 562         (beginning-of-line 2))
 563       (push (cons (file-name-nondirectory file) (md5 (buffer-string)))
 564             org-mobile-checksum-files))
 565     (message "Agenda written to Org file %s" file)))
 566
 567 ;;;###autoload
 568 (defun org-mobile-create-sumo-agenda ()
 569   "Create a file that contains all custom agenda views."
 570   (interactive)
 571   (let* ((file (expand-file-name "agendas.org"
 572                                  org-mobile-directory))
 573          (sumo (org-mobile-sumo-agenda-command))
 574          (org-agenda-custom-commands
 575           (list (append sumo (list (list file)))))
 576          (org-mobile-creating-agendas t))
 577     (unless (file-writable-p file)
 578       (error "Cannot write to file %s" file))
 579     (when sumo
 580       (org-store-agenda-views))))
 581
 582 (defun org-mobile-move-capture ()
 583   "Move the contents of the capture file to the inbox file.
 584 Return a marker to the location where the new content has been added.
 585 If nothing new has been added, return nil."
 586   (interactive)
 587   (let ((inbox-buffer (find-file-noselect org-mobile-inbox-for-pull))
 588         (capture-buffer (find-file-noselect
 589                          (expand-file-name org-mobile-capture-file
 590                                            org-mobile-directory)))
 591         (insertion-point (make-marker))
 592         not-empty content)
 593     (with-current-buffer capture-buffer
 594       (setq content (buffer-string))
 595       (setq not-empty (string-match "\\S-" content))
 596       (when not-empty
 597         (set-buffer inbox-buffer)
 598         (widen)
 599         (goto-char (point-max))
 600         (or (bolp) (newline))
 601         (move-marker insertion-point
 602                      (prog1 (point) (insert content)))
 603         (save-buffer)
 604         (set-buffer capture-buffer)
 605         (erase-buffer)
 606         (save-buffer)
 607         (org-mobile-update-checksum-for-capture-file (buffer-string))))
 608     (kill-buffer capture-buffer)
 609     (if not-empty insertion-point)))
 610
 611 (defun org-mobile-update-checksum-for-capture-file (buffer-string)
 612   (let* ((file (expand-file-name "checksums.dat" org-mobile-directory))
 613          (buffer (find-file-noselect file)))
 614     (when buffer
 615       (with-current-buffer buffer
 616         (when (re-search-forward (concat "\\([0-9a-fA-F]\\{30,\\}\\).*?"
 617                                          (regexp-quote org-mobile-capture-file)
 618                                          "[ \t]*$") nil t)
 619           (goto-char (match-beginning 1))
 620           (delete-region (match-beginning 1) (match-end 1))
 621           (insert (md5 buffer-string))
 622           (save-buffer)))
 623       (kill-buffer buffer))))
 624
 625 (defun org-mobile-apply (&optional beg end)
 626   "Apply all change requests in the current buffer.
 627 If BEG and END are given, only do this in that region."
 628   (interactive)
 629   (require 'org-archive)
 630   (setq org-mobile-last-flagged-files nil)
 631   (setq beg (or beg (point-min)) end (or end (point-max)))
 632
 633   ;; Remove all Note IDs
 634   (goto-char beg)
 635   (while (re-search-forward "^\\*\\* Note ID: [-0-9A-F]+[ \t]*\n" end t)
 636     (replace-match ""))
 637
 638   ;; Find all the referenced entries, without making any changes yet
 639   (let ((marker (make-marker))
 640         (bos-marker (make-marker))
 641         (end (move-marker (make-marker) end))
 642         (cnt-new 0)
 643         (cnt-edit 0)
 644         (cnt-flag 0)
 645         (cnt-error 0)
 646         buf-list
 647         id-pos org-mobile-error)
 648
 649     ;; Count the new captures
 650     (goto-char beg)
 651     (while (re-search-forward "^\\* \\(.*\\)" end t)
 652       (and (>= (- (match-end 1) (match-beginning 1)) 2)
 653            (not (equal (downcase (substring (match-string 1) 0 2)) "f("))
 654            (incf cnt-new)))
 655
 656     (goto-char beg)
 657     (while (re-search-forward
 658             "^\\*+[ \t]+F(\\([^():\n]*\\)\\(:\\([^()\n]*\\)\\)?)[ \t]+\\[\\[\\(\\(id\\|olp\\):\\([^]\n]+\\)\\)" end t)
 659       (setq id-pos (condition-case msg
 660                        (org-mobile-locate-entry (match-string 4))
 661                      (error (nth 1 msg))))
 662       (when (and (markerp id-pos)
 663                  (not (member (marker-buffer id-pos) buf-list)))
 664         (org-mobile-timestamp-buffer (marker-buffer id-pos))
 665         (push (marker-buffer id-pos) buf-list))
 666
 667       (if (or (not id-pos) (stringp id-pos))
 668           (progn
 669             (goto-char (+ 2 (point-at-bol)))
 670             (insert id-pos " ")
 671             (incf cnt-error))
 672         (add-text-properties (point-at-bol) (point-at-eol)
 673                              (list 'org-mobile-marker
 674                                    (or id-pos "Linked entry not found")))))
 675
 676     ;; OK, now go back and start applying
 677     (goto-char beg)
 678     (while (re-search-forward "^\\*+[ \t]+F(\\([^():\n]*\\)\\(:\\([^()\n]*\\)\\)?)" end t)
 679       (catch 'next
 680         (setq id-pos (get-text-property (point-at-bol) 'org-mobile-marker))
 681         (if (not (markerp id-pos))
 682             (progn
 683               (incf cnt-error)
 684               (insert "UNKNOWN PROBLEM"))
 685           (let* ((action (match-string 1))
 686                  (data (and (match-end 3) (match-string 3)))
 687                  (bos (point-at-bol))
 688                  (eos (save-excursion (org-end-of-subtree t t)))
 689                  (cmd (if (equal action "")
 690                           '(progn
 691                              (incf cnt-flag)
 692                              (org-toggle-tag "FLAGGED" 'on)
 693                              (and note
 694                                   (org-entry-put nil "THEFLAGGINGNOTE" note)))
 695                         (incf cnt-edit)
 696                         (cdr (assoc action org-mobile-action-alist))))
 697                  (note (and (equal action "")
 698                             (buffer-substring (1+ (point-at-eol)) eos)))
 699                  (org-inhibit-logging 'note) ;; Do not take notes interactively
 700                  old new)
 701             (goto-char bos)
 702             (move-marker bos-marker (point))
 703             (if (re-search-forward "^** Old value[ \t]*$" eos t)
 704                 (setq old (buffer-substring
 705                            (1+ (match-end 0))
 706                            (progn (outline-next-heading) (point)))))
 707             (if (re-search-forward "^** New value[ \t]*$" eos t)
 708                 (setq new (buffer-substring
 709                            (1+ (match-end 0))
 710                            (progn (outline-next-heading)
 711                                   (if (eobp) (org-back-over-empty-lines))
 712                                   (point)))))
 713             (setq old (and old (if (string-match "\\S-" old) old nil)))
 714             (setq new (and new (if (string-match "\\S-" new) new nil)))
 715             (if (and note (> (length note) 0))
 716                 ;; Make Note into a single line, to fit into a property
 717                 (setq note (mapconcat 'identity
 718                                       (org-split-string (org-trim note) "\n")
 719                                       "\\n")))
 720             (unless (equal data "body")
 721               (setq new (and new (org-trim new))
 722                     old (and old (org-trim old))))
 723             (goto-char (+ 2 bos-marker))
 724             (unless (markerp id-pos)
 725               (insert "BAD REFERENCE ")
 726               (incf cnt-error)
 727               (throw 'next t))
 728             (unless cmd
 729               (insert "BAD FLAG ")
 730               (incf cnt-error)
 731               (throw 'next t))
 732             ;; Remember this place so that we can return
 733             (move-marker marker (point))
 734             (setq org-mobile-error nil)
 735             (save-excursion
 736               (condition-case msg
 737                   (org-with-point-at id-pos
 738                     (progn
 739                   (eval cmd)
 740                   (if (member "FLAGGED" (org-get-tags))
 741                       (add-to-list 'org-mobile-last-flagged-files
 742                                    (buffer-file-name (current-buffer))))))
 743                 (error (setq org-mobile-error msg))))
 744             (when org-mobile-error
 745               (switch-to-buffer (marker-buffer marker))
 746               (goto-char marker)
 747               (incf cnt-error)
 748               (insert (if (stringp (nth 1 org-mobile-error))
 749                           (nth 1 org-mobile-error)
 750                         "EXECUTION FAILED")
 751                       " ")
 752               (throw 'next t))
 753             ;; If we get here, the action has been applied successfully
 754             ;; So remove the entry
 755             (goto-char bos-marker)
 756             (delete-region (point) (org-end-of-subtree t t))))))
 757     (save-buffer)
 758     (move-marker marker nil)
 759     (move-marker end nil)
 760     (message "%d new, %d edits, %d flags, %d errors" cnt-new
 761              cnt-edit cnt-flag cnt-error)
 762     (sit-for 1)))
 763
 764 (defun org-mobile-timestamp-buffer (buf)
 765   "Time stamp buffer BUF, just to make sure its checksum will change."
 766   (with-current-buffer buf
 767     (save-excursion
 768       (save-restriction
 769         (widen)
 770         (goto-char (point-min))
 771         (if (re-search-forward
 772              "^\\([ \t]*\\)#\\+LAST_MOBILE_CHANGE:.*\n?" nil t)
 773             (progn
 774               (goto-char (match-end 1))
 775               (delete-region (point) (match-end 0)))
 776           (if (looking-at ".*?-\\*-.*-\\*-")
 777               (forward-line 1)))
 778         (insert "#+LAST_MOBILE_CHANGE: "
 779                 (format-time-string "%Y-%m-%d %T") "\n")))))
 780
 781 (defun org-mobile-smart-read ()
 782   "Parse the entry at point for shortcuts and expand them.
 783 These shortcuts are meant for fast and easy typing on the limited
 784 keyboards of a mobile device.  Below we show a list of the shortcuts
 785 currently implemented.
 786
 787 The entry is expected to contain an inactive time stamp indicating when
 788 the entry was created.  When setting dates and
 789 times (for example for deadlines), the time strings are interpreted
 790 relative to that creation date.
 791 Abbreviations are expected to take up entire lines, just because it is so
 792 easy to type RET on a mobile device.  Abbreviations start with one or two
 793 letters, followed immediately by a dot and then additional information.
 794 Generally the entire shortcut line is removed after action have been taken.
 795 Time stamps will be constructed using `org-read-date'.  So for example a
 796 line \"dd. 2tue\" will set a deadline on the second Tuesday after the
 797 creation date.
 798
 799 Here are the shortcuts currently implemented:
 800
 801 dd. string             set deadline
 802 ss. string             set scheduling
 803 tt. string             set time tamp, here.
 804 ti. string             set inactive time
 805
 806 tg. tag1 tag2 tag3     set all these tags, change case where necessary
 807 td. kwd                set this todo keyword, change case where necessary
 808
 809 FIXME: Hmmm, not sure if we can make his work against the
 810 auto-correction feature.  Needs a bit more thinking.  So this function
 811 is currently a noop.")
 812
 813
 814 (defun org-find-olp (path)
 815   "Return  a marker pointing to the entry at outline path OLP.
 816 If anything goes wrong, the return value will instead an error message,
 817 as a string."
 818   (let* ((file (pop path))
 819          (buffer (find-file-noselect file))
 820          (level 1)
 821          (lmin 1)
 822          (lmax 1)
 823          limit re end found pos heading cnt)
 824     (unless buffer (error "File not found :%s" file))
 825     (with-current-buffer buffer
 826       (save-excursion
 827         (save-restriction
 828           (widen)
 829           (setq limit (point-max))
 830           (goto-char (point-min))
 831           (while (setq heading (pop path))
 832             (setq re (format org-complex-heading-regexp-format
 833                              (regexp-quote heading)))
 834             (setq cnt 0 pos (point))
 835             (while (re-search-forward re end t)
 836               (setq level (- (match-end 1) (match-beginning 1)))
 837               (if (and (>= level lmin) (<= level lmax))
 838                   (setq found (match-beginning 0) cnt (1+ cnt))))
 839             (when (= cnt 0) (error "Heading not found on level %d: %s"
 840                                    lmax heading))
 841             (when (> cnt 1) (error "Heading not unique on level %d: %s"
 842                                    lmax heading))
 843             (goto-char found)
 844             (setq lmin (1+ level) lmax (+ lmin (if org-odd-levels-only 1 0)))
 845             (setq end (save-excursion (org-end-of-subtree t t))))
 846           (when (org-on-heading-p)
 847             (move-marker (make-marker) (point))))))))
 848
 849 (defun org-mobile-locate-entry (link)
 850   (if (string-match "\\`id:\\(.*\\)$" link)
 851       (org-id-find (match-string 1 link) 'marker)
 852     (if (not (string-match "\\`olp:\\(.*?\\):\\(.*\\)$" link))
 853         nil
 854       (let ((file (match-string 1 link))
 855             (path (match-string 2 link))
 856             (table '((?: . "%3a") (?\[ . "%5b") (?\] . "%5d") (?/ . "%2f"))))
 857         (setq file (org-link-unescape file table))
 858         (setq file (expand-file-name file org-directory))
 859         (setq path (mapcar (lambda (x) (org-link-unescape x table))
 860                            (org-split-string path "/")))
 861         (org-find-olp (cons file path))))))
 862
 863 (defun org-mobile-edit (what old new)
 864   "Edit item WHAT in the current entry by replacing OLD with NEW.
 865 WHAT can be \"heading\", \"todo\", \"tags\", \"priority\", or \"body\".
 866 The edit only takes place if the current value is equal (except for
 867 white space) the OLD.  If this is so, OLD will be replace by NEW
 868 and the command will return t.  If something goes wrong, a string will
 869 be returned that indicates what went wrong."
 870   (let (current old1 new1)
 871     (if (stringp what) (setq what (intern what)))
 872
 873     (cond
 874
 875      ((memq what '(todo todostate))
 876       (setq current (org-get-todo-state))
 877       (cond
 878        ((equal new "DONEARCHIVE")
 879         (org-todo 'done)
 880         (org-archive-subtree-default))
 881        ((equal new current) t) ; nothing needs to be done
 882        ((or (equal current old)
 883             (eq org-mobile-force-mobile-change t)
 884             (memq 'todo org-mobile-force-mobile-change))
 885         (org-todo (or new 'none)) t)
 886        (t (error "State before change was expected as \"%s\", but is \"%s\""
 887                  old current))))
 888
 889      ((eq what 'tags)
 890       (setq current (org-get-tags)
 891             new1 (and new (org-split-string new ":+"))
 892             old1 (and old (org-split-string old ":+")))
 893       (cond
 894        ((org-mobile-tags-same-p current new1) t) ; no change needed
 895        ((or (org-mobile-tags-same-p current old1)
 896             (eq org-mobile-force-mobile-change t)
 897             (memq 'tags org-mobile-force-mobile-change))
 898         (org-set-tags-to new1) t)
 899        (t (error "Tags before change were expected as \"%s\", but are \"%s\""
 900                  (or old "") (or current "")))))
 901
 902      ((eq what 'priority)
 903       (when (looking-at org-complex-heading-regexp)
 904         (setq current (and (match-end 3) (substring (match-string 3) 2 3)))
 905         (cond
 906          ((equal current new) t) ; no action required
 907          ((or (equal current old)
 908               (eq org-mobile-force-mobile-change t)
 909               (memq 'tags org-mobile-force-mobile-change))
 910           (org-priority (and new (string-to-char new))))
 911          (t (error "Priority was expected to be %s, but is %s"
 912                    old current)))))
 913
 914      ((eq what 'heading)
 915       (when (looking-at org-complex-heading-regexp)
 916         (setq current (match-string 4))
 917         (cond
 918          ((equal current new) t) ; no action required
 919          ((or (equal current old)
 920               (eq org-mobile-force-mobile-change t)
 921               (memq 'heading org-mobile-force-mobile-change))
 922           (goto-char (match-beginning 4))
 923           (insert new)
 924           (delete-region (point) (+ (point) (length current)))
 925           (org-set-tags nil 'align))
 926          (t (error "Heading changed in MobileOrg and on the computer")))))
 927
 928      ((eq what 'body)
 929       (setq current (buffer-substring (min (1+ (point-at-eol)) (point-max))
 930                                       (save-excursion (outline-next-heading)
 931                                                       (point))))
 932       (if (not (string-match "\\S-" current)) (setq current nil))
 933       (cond
 934        ((org-mobile-bodies-same-p current new) t) ; no action necessary
 935        ((or (org-mobile-bodies-same-p current old)
 936             (eq org-mobile-force-mobile-change t)
 937             (memq 'body org-mobile-force-mobile-change))
 938         (save-excursion
 939           (end-of-line 1)
 940           (insert "\n" new)
 941           (or (bolp) (insert "\n"))
 942           (delete-region (point) (progn (org-back-to-heading t)
 943                                         (outline-next-heading)
 944                                         (point))))
 945         t)
 946        (t (error "Body was changed in MobileOrg and on the computer")))))))
 947
 948
 949 (defun org-mobile-tags-same-p (list1 list2)
 950   "Are the two tag lists the same?"
 951   (not (or (org-delete-all list1 list2)
 952            (org-delete-all list2 list1))))
 953
 954 (defun org-mobile-bodies-same-p (a b)
 955   "Compare if A and B are visually equal strings.
 956 We first remove leading and trailing white space from the entire strings.
 957 Then we split the strings into lines and remove leading/trailing whitespace
 958 from each line.  Then we compare.
 959 A and B must be strings or nil."
 960   (cond
 961    ((and (not a) (not b)) t)
 962    ((or (not a) (not b)) nil)
 963    (t (setq a (org-trim a) b (org-trim b))
 964       (setq a (mapconcat 'identity (org-split-string a "[ \t]*\n[ \t]*") "\n"))
 965       (setq b (mapconcat 'identity (org-split-string b "[ \t]*\n[ \t]*") "\n"))
 966       (equal a b))))
 967
 968 (provide 'org-mobile)
 969
 970 ;; arch-tag: ace0e26c-58f2-4309-8a61-05ec1535f658
 971
 972 ;;; org-mobile.el ends here
 973