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