org-fstree.el

   1 ;;; org-fstree.el --- include a filesystem subtree into an org file
   2
   3
   4 ;; Copyright 2009 Andreas Burtzlaff
   5 ;;
   6 ;; Author: Andreas Burtzlaff < andreas at burtz[REMOVE]laff dot de >
   7 ;; Version: 0.4
   8 ;; Keywords: org-mode filesystem tree
   9 ;; X-URL: <http://www.burtzlaff.de/org-fstree/org-fstree.el>
  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 ;; org-fstree inserts the filesystem subtree for a given directory.
  30 ;; Each file/directory is formatted as a headline, provides links back
  31 ;; to all headlines that are associated with it (by containing links to the file)
  32 ;; and is assigned their tags.
  33 ;;
  34 ;; Installation:
  35 ;;   - put this file into your load-path
  36 ;;   - insert "(require 'org-fstree)" into ~/.emacs
  37 ;;
  38 ;; Usage:
  39 ;;   - enter a line containing "#+BEGIN_FSTREE: <dir>" into an org buffer,
  40 ;;     where <dir> is the directory, that is to be inserted.
  41 ;;   - while the cursor is in the line mentioned, press "C-c C-c"
  42 ;;
  43 ;; Options:
  44 ;;   Specify options in the form:
  45 ;;   "#+BEGIN_FSTREE: <dir> :<optionname1> <optionvalue1> :<optionname2> <optionvalue2>  ...
  46 ;;   Options are:
  47 ;;     - :non-recursive t , to suppress recursion into directories
  48 ;;     - :exclude-regexp-name <list of regexp strings> , exclude file/directory names matching either
  49 ;;                                                  of the given regexp expressions
  50 ;;       Examples:
  51 ;;         :exclude-regexp-name (".*\\.pdf$" ".*\\.zip$"), excludes files/directories ending with either ".pdf" or ".zip"
  52 ;;         :exclude-regexp-name ("^\\.git$") , excludes files/directories named ".git"
  53 ;;
  54 ;;     - :exclude-regexp-fullpath <list of regexp strings>, same as :exclude-regexp-name but matches absolute path to file/directory
  55 ;;     - :relative-links t , generates relative instead of absolute links
  56 ;;     - :show-only-matches t , only files that are being linked to show up
  57 ;;     - :dynamic-update t , [EXPERIMENTAL] dynamically update a subtree on visibility cycling.
  58 ;;     - :links-as-properties t, sets the links as properties Link1, Link2,... for use in column view [Does not work with dynamic-update!]
  59 ;;     - :no-annotations t, suppresses the search and display of file annotations
  60 ;;
  61 ;; Limitations and warnings:
  62 ;;
  63 ;;   - when triggering an update (by pressing "C-c C-c" while in the line mentioned above)
  64 ;;     the COMPLETE REGION BETWEEN "#+BEGIN_FSTREE" AND "#+END_FSTREE" IS REPLACED.
  65 ;;   - speed
  66 ;;
  67 ;; Code:
  68
  69 (provide 'org-fstree)
  70
  71 (require 'org)
  72
  73 (defun org-fstree-generate (dir level options)
  74   (interactive)
  75 ;;  (message "org-fstree-generate") ;; DEBUG
  76   (if (file-directory-p dir)
  77      (let (
  78            (non-recursive (plist-get options :non-recursive))
  79            (exclude-regexp-name-list (plist-get options :exclude-regexp-name))
  80            (exclude-regexp-fullpath-list (plist-get options :exclude-regexp-fullpath))
  81            (links-as-properties (plist-get options :links-as-properties))
  82            (dynamic-update (plist-get options :dynamic-update))
  83            (fullFileNames (directory-files dir 1 nil nil) )
  84            (fileNames (directory-files dir nil nil nil) )
  85            fileName
  86            fullFileName
  87            currentHeadline
  88            orgHeadlineInfo
  89            curTags
  90            curPos
  91            (linksList nil)
  92            (retString "")
  93            )
  94        (while fileNames
  95          (setq fullFileName (car fullFileNames))
  96          (setq fullFileNames (cdr fullFileNames))
  97          (setq fileName (car fileNames))
  98          (setq fileNames (cdr fileNames))
  99          (setq linksList nil)
 100          (setq curTags nil)
 101          (cond ((member fileName '("." "..")))
 102                ;; the following two lines are really ugly. I'll be glad if someone with more lisp experience tidies this up.
 103                ((reduce (function (lambda (a b) (or a b)))  (mapcar (function (lambda (regexp) (not (string= fullFileName (replace-regexp-in-string regexp "" fullFileName) )) )) exclude-regexp-fullpath-list ) :initial-value nil))
 104                ((reduce (function (lambda (a b) (or a b)))  (mapcar (function (lambda (regexp) (not (string= fileName (replace-regexp-in-string regexp "" fileName) )) )) exclude-regexp-name-list ) :initial-value nil))
 105                (t
 106                 (save-excursion
 107                 (cond ((plist-get options :no-annotations))
 108                       (t
 109                 ;; Search for links in current buffer
 110                 (goto-char (point-min))
 111                 (setq curPos (point))
 112                 (while (re-search-forward org-bracket-link-regexp nil t)
 113                   (let ((filenameInLink (match-string 1)))
 114                   (cond ( (org-fstree-get-parameters-if-inside-fstree-block) (re-search-forward "#\\+END_FSTREE" nil t) )
 115                         ( (string= fullFileName (expand-file-name (replace-regexp-in-string "^file:" "" filenameInLink ) ":" ) )
 116                           (let ((p (point)))
 117                             (cond ((org-before-first-heading-p))
 118                                   (t
 119                                    ;; go to associated heading
 120                                    (org-back-to-heading t)
 121                                    (setq orgHeadlineInfo (org-heading-components))
 122                                    (setq curTags (concat curTags (nth 5 orgHeadlineInfo) ))
 123                                    (setq currentHeadline (nth 4 orgHeadlineInfo))
 124                                    ;; filter all links from headline, generate link to it and append to linksList
 125                                    (let ((cleanedHeadline (replace-regexp-in-string "\\[\\[.*\\]\\]" "" currentHeadline)))
 126
 127                                      (setq linksList (cons (concat "[[*"  cleanedHeadline "]"
 128                                                                    (cond ( (plist-get options :show-only-matches)
 129                                                                            "[" (replace-regexp-in-string (regexp-quote fullFileName) "" cleanedHeadline) "]" ) )
 130                                                                    "]")
 131                                                            linksList) ) )
 132                                    (goto-char p)
 133                                    )))))))))
 134
 135                 (cond ((or (not (plist-get options :show-only-matches)) (not (null linksList)))
 136                        ;; construct headline for current file/directory
 137                        (let* ((tagString (cond ((not (null curTags)) (concat "  " (replace-regexp-in-string "::" ":" curTags)) ) ))
 138                               (linkCount 0)
 139                               (headingString (format "\n%s |%s| [[file:%s][%s]] "
 140                                                      (make-string level ?*)
 141                                                      (if (file-directory-p fullFileName) "D" " ")
 142                                                      (if (plist-get options :relative-links) (file-relative-name fullFileName) fullFileName) fileName)))
 143                          (cond (links-as-properties
 144                                 (setq retString (concat retString headingString (if tagString tagString "")
 145                                                         (if (not (null linksList))
 146                                                             (concat "\n :PROPERTIES:\n "
 147                                                                     (mapconcat (function (lambda (string) (setq linkCount (1+ linkCount)) (concat ":Link" (number-to-string linkCount) ":" string ))) linksList "\n")
 148                                                                     "\n :END:" ) ))))
 149                                (t
 150                                 (setq retString (concat retString headingString
 151                                                        (make-string (max 0 (- 100 (length headingString))) ? )
 152                                                        (if linksList (concat "{ " (mapconcat 'identity linksList " | ") " }"))
 153                                                        (if tagString tagString)
 154                                                        ))))
 155                          (if (and (not non-recursive) (not dynamic-update) (file-directory-p fullFileName) )
 156                              (setq retString (concat retString (org-fstree-generate fullFileName (1+ level) options) ) )
 157                            ))))))))
 158        retString)
 159     (message "%s is not a directory" dir)))
 160
 161 (defun org-fstree-apply-maybe ()
 162   (interactive)
 163 ;;  (message "org-fstree-apply-maybe") (sit-for 1) ;; DEBUG
 164   (save-excursion
 165      (if (save-excursion (beginning-of-line 1) (looking-at "#\\+END_FSTREE"))
 166          (re-search-backward "#\\+BEGIN_FSTREE" nil t))
 167      (cond
 168       ((save-excursion (beginning-of-line 1) (looking-at "#\\+BEGIN_FSTREE"))
 169        (let* ((params (org-fstree-gather-parameters))
 170               (dir (org-link-expand-abbrev (plist-get params :dir)))
 171               (options (plist-get params :params))
 172               level)
 173          ;; get current level; there is a BUG if "#+BEGIN_FSTREE" is inserted after the last headlines dots, that indicate its folded state.
 174         ;; (let ((p (point)))
 175         (save-excursion
 176           (cond ((org-before-first-heading-p)
 177                  (setq level 1))
 178                 (t (org-back-to-heading)
 179                    (setq level (+ (funcall outline-level) 1))
 180                    ;;               (goto-char p)
 181                    )))
 182            (forward-line)
 183            (let ((beg (point)))
 184              (re-search-forward "#\\+END_FSTREE\\|#\\+BEGIN_FSTREE" nil t)
 185              ;;(let ((generatedString (org-fstree-generate dir level options)))
 186              (cond ( (looking-back "#\\+END_FSTREE")
 187                      (forward-line -1)
 188                      (end-of-line 1)
 189                      (delete-region beg (point) )
 190                      (insert (concat (org-fstree-generate dir level options) "\n\n")))
 191                    (t (goto-char beg)
 192                       (insert (concat (org-fstree-generate dir level options) "\n\n\n#+END_FSTREE"))))
 193              ;; hide all subtrees
 194              (org-map-region (function (lambda () (hide-subtree))) beg (point))
 195
 196              ;;)
 197              ))
 198        1))))
 199
 200
 201 (defun org-fstree-show-entry-maybe (state)
 202   (interactive)
 203 ;;  (message "show-entry-maybe..") (sit-for 1) ;; DEBUG
 204   (let* ( (parameters (save-excursion (org-fstree-get-parameters-if-inside-fstree-block)))
 205           (options (plist-get parameters :params)))
 206
 207     (cond ((and parameters (not (plist-get options :non-recursive)) (plist-get options :dynamic-update) )
 208            ;; we are inside the FSTREE block and have to update
 209            ;; delete existing content
 210            (save-excursion
 211              (let* ((endfstree (save-excursion (re-search-forward "#\\+END_FSTREE" nil t) (beginning-of-line) (point)))
 212                     (end (save-excursion
 213                           ;; go to the end of the subtree, specifically to the beginning of the next headline
 214                           (org-end-of-subtree nil t)
 215                           ;; check whether the end of the fstree block has been trespassed
 216                           (and (> (point) endfstree) (goto-char endfstree))
 217                           ;; got back on character, because editing heading lines in column mode is not possible.
 218                           ;; this line is supposed to be either empty or an entry.
 219                           (forward-char -1)
 220                           (point)
 221                           )))
 222                (beginning-of-line 2)
 223                (if (looking-at " *:PROPERTIES:") (progn (re-search-forward ":END:" nil t) (forward-line 1)))
 224
 225
 226                (when (and (> (count-lines (point) end) 0) (< (point) end))
 227                   (delete-region (point) end)
 228                  )
 229                )
 230              )
 231            (cond ((eq state 'folded))
 232                  (t
 233                   ;; insert new content
 234                   (save-excursion
 235                     (let ((beg (point))
 236                           end
 237                           (level (1+ (funcall outline-level)))
 238                           (dir (org-fstree-extract-path-from-headline))
 239                           (newOptions (plist-put (plist-get parameters :params) ':non-recursive 't)))
 240                       (when (file-directory-p dir)
 241                         ;;(when (plist-get options :links-as-properties) (forward-line 1))
 242                         (if (looking-at " *:PROPERTIES:") (progn (re-search-forward ":END" nil t) (forward-line 1)))
 243                         (end-of-line 1)
 244                         (when (plist-get options :links-as-parameters)
 245                           (org-columns-quit))
 246
 247                         (insert (org-fstree-generate dir level newOptions))
 248
 249                         (when (plist-get options :links-as-parameters)
 250                           (org-columns))
 251                         (setq end (point))
 252                         ;; hide all subtrees
 253                         ;;(if (plist-get options :links-as-properties)
 254                           ;;(progn
 255                           ;; (org-map-region (function (lambda () (hide-subtree))) beg (point)))
 256                           (org-end-of-subtree)
 257                           (hide-subtree)
 258                               ))))
 259                  )))))
 260
 261
 262 (defun org-fstree-extract-path-from-headline ()
 263 ;;  (interactive) ;;DEBUG
 264   (save-excursion
 265     (beginning-of-line 1)
 266     (if (looking-at org-fstree-heading-regexp)
 267         (match-string-no-properties 1))))
 268
 269 (defconst org-fstree-heading-regexp ".*\\[\\[file:\\(.*\\)\\]\\[.*\\]\\]"
 270   "Matches headline in org-fstree section.")
 271 (make-variable-buffer-local 'org-fstree-heading-regexp)
 272
 273 (defun org-fstree-get-parameters-if-inside-fstree-block ()
 274   (interactive)
 275   (and   (save-excursion
 276          (re-search-forward "#\\+END_FSTREE" nil t) )
 277          (save-excursion
 278          (re-search-backward "#\\+BEGIN_FSTREE" nil t)
 279          (org-fstree-gather-parameters))))
 280
 281 (defun org-fstree-gather-parameters ()
 282   (save-excursion
 283     (let (rtn)
 284       (beginning-of-line 1)
 285       (if (looking-at "#\\+BEGIN_FSTREE[: \t][ \t]*\\([^ \t\r\n]+\\)\\( +.*\\)?")
 286         (let ((dir (org-no-properties (match-string 1)))
 287               (params (if (match-end 2)
 288                           (read (concat "(" (match-string 2) ")")))))
 289           (setq rtn (list :dir dir :params params) )
 290   ))
 291
 292        rtn)
 293     )
 294 )
 295
 296 (defun org-fstree-get-current-outline-level ()
 297   (save-excursion
 298     (cond ((org-before-first-heading-p) 1)
 299           (t
 300            (org-back-to-heading)
 301            (+ (funcall outline-level) 1)))))
 302
 303 (add-hook 'org-ctrl-c-ctrl-c-hook 'org-fstree-apply-maybe)
 304 (add-hook 'org-pre-cycle-hook 'org-fstree-show-entry-maybe)