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