experimental/muse-split.el

   1 ;;; muse-split.el --- split published Muse files
   2
   3 ;; Copyright (C) 2006 Free Software Foundation, Inc.
   4
   5 ;; Author: Phillip Lord <phillip.lord@newcastle.ac.uk>
   6
   7 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
   8
   9 ;; Emacs Muse is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published
  11 ;; by the Free Software Foundation; either version 2, or (at your
  12 ;; option) any later version.
  13
  14 ;; Emacs Muse is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with Emacs Muse; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23
  24 ;;: Status:
  25
  26 ;; This works now, except that anchors will get broken, as they may
  27 ;; well point to the wrong thing.
  28
  29 ;; Anchors are mostly working, some crashes in caching code. Have
  30 ;; realised that could just circumvent the anchors problem by always
  31 ;; pointing toward the full length entry which all of my split
  32 ;; functions generate now. Given the complexity that this has
  33 ;; introduced taht might not have been a bad idea.
  34
  35 ;; These functions directly over-write the original versions in
  36 ;; muse-publish.
  37
  38 (require 'muse-publish)
  39 (require 'assoc)
  40 (eval-when-compile
  41   (require 'cl))
  42
  43 ;; this code duplicates that in muse-publish-markup-regexps and should
  44 ;; be factored out. I use this style to pull directives from the front
  45 ;; of file.
  46 (defvar muse-publish-presplit-markup-regexps
  47   `(
  48     ;; Handle any leading #directives
  49     (1200 "\\`#\\([a-zA-Z-]+\\)\\s-+\\(.+\\)\n+" 0 directive)
  50     ;; define anchor points
  51     (1500 "^\\(\\W*\\)#\\(\\S-+\\)\\s-*" 0 anchor)))
  52
  53 (defvar muse-publish-presplit-functions
  54   '((directive . muse-publish-presplit-directive)
  55     (anchor . muse-publish-presplit-anchor)))
  56
  57 ;; oh dear, this function used to be so simple and now has got so
  58 ;; nasty. I'm sure I can amalgamate some of the let bindings and
  59 ;; lambda function.
  60 (defun muse-publish-file (file style &optional output-dir force)
  61   "Publish the given file in list FILES.
  62 If the argument FORCE is nil, each file is only published if it is
  63 newer than the published version.  If the argument FORCE is non-nil,
  64 the file is published no matter what."
  65   (interactive (cons (read-file-name "Publish file: ")
  66                      (muse-publish-get-info)))
  67   (setq style (muse-style style))
  68   (let* ((output-path (muse-publish-output-file file output-dir style))
  69          (output-suffix (muse-style-element :osuffix style))
  70          (muse-publishing-current-file file)
  71          (muse-publishing-style-in-use style)
  72          (muse-publish-split-file-split-values nil)
  73          (muse-publish-presplit-directive-store "")
  74          (muse-publish-presplit-anchor-location nil)
  75          (muse-publishing-targets-alist
  76           (muse-publish-split-file file))
  77          (target-list
  78           (mapcar
  79            (lambda(elem)
  80              (if output-suffix
  81                  (concat (file-name-sans-extension
  82                           (cdr (car elem)))
  83                          output-suffix)
  84                output-path))
  85            muse-publishing-targets-alist)))
  86
  87     (when (or force
  88               ;; update if any of the files are out of date.
  89               (let ((outofdate nil))
  90                 (mapc
  91                  (lambda(elem)
  92                    (if (file-newer-than-file-p file
  93                                                (car elem))
  94                        (setq outofdate t)))
  95                  muse-publishing-targets-alist)
  96                 outofdate))
  97
  98       (if (and muse-publish-report-threshhold
  99                (> (nth 7 (file-attributes file))
 100                   muse-publish-report-threshhold))
 101           (message "Publishing %s ..." file)
 102         ;; need to grab the directives.
 103         (muse-publish-presplit-publish file)
 104         ;; start a temp buffer for main data
 105         (muse-with-temp-buffer
 106           (insert-file-contents file)
 107           (let ((mainbuffer (current-buffer))
 108                 (subcontents))
 109             (mapc
 110              (lambda(elem)
 111                (muse-with-temp-buffer
 112                  ;; not handling the directives yet.
 113                  (save-excursion
 114                    (set-buffer mainbuffer)
 115                    (setq subcontents
 116                          (buffer-substring-no-properties
 117                           (cadr elem) (caddr elem))))
 118                  ;; insert the directives afresh.
 119                  (insert muse-publish-presplit-directive-store)
 120                  (insert subcontents)
 121                  (muse-publish-markup-buffer (muse-page-name file) style)
 122                  (let* ((backup-inhibited t))
 123                    (write-file (muse-publish-output-file (car elem)
 124                                                          output-dir style)))
 125                  (muse-style-run-hooks :final style file (car elem))))
 126              muse-publishing-targets-alist)))
 127         t))))
 128
 129 (defun muse-publish-presplit-publish(file)
 130   (muse-with-temp-buffer
 131     (insert-file-contents file)
 132     (let ((muse-publish-markup-regexps muse-publish-presplit-markup-regexps)
 133           (muse-publish-markup-functions muse-publish-presplit-functions)
 134           (muse-publishing-styles)
 135           (muse-publish-presplit-splitting-file file))
 136       ;; great an empty style. The name is just wierd, so that
 137       ;; it won't preexist (which makes muse crash). The let
 138       ;; binding should mean that it disappears.
 139       (muse-define-style "ThePurposeIsNotToDescribeTheWorldButToChangeIt")
 140       (muse-publish-markup-buffer
 141        (muse-page-name "temp")
 142        "ThePurposeIsNotToDescribeTheWorldButToChangeIt"))))
 143
 144 (defun muse-publish-prepare-url (target &rest ignored)
 145   "Transform anchors and get published name, if TARGET is a page."
 146   (save-match-data
 147     (unless (or (string-match muse-url-regexp target)
 148                 (string-match muse-image-regexp target)
 149                 (string-match muse-file-regexp target))
 150       (setq target (if (string-match "#" target)
 151                        ;; is this a simple anchor, we need to check
 152                        ;; where it will be published.
 153                        (if (eq (aref target 0) ?\#)
 154                            (concat
 155                             (muse-publish-link-name
 156                              (muse-publish-split-file-for-anchor
 157                               muse-publishing-current-file
 158                               (substring target 1)))
 159                             target)
 160                          ;; it's not anchor simple anchor, so we need to
 161                          ;; put in the extension
 162                          (let
 163                              ((file (substring target 0 (match-beginning 0)))
 164                               (anchor (substring target (match-end 0))))
 165                            (concat (muse-publish-link-name
 166                                     (muse-publish-split-file-for-anchor
 167                                      (concat (file-name-directory
 168                                               muse-publishing-current-file)
 169                                              file "." muse-file-extension)
 170                                      anchor))
 171                                    "#" anchor)))
 172                      ;; it's not an anchor at all.
 173                      (muse-publish-link-name target))))
 174     target))
 175
 176 ;; these are support functions
 177
 178 ;; we currently have to store a lot of state to get this to work,
 179 ;; which is rather dissatisfying. All of it is let bound from
 180 ;; muse-publish-file. Wey hey for dynamic scoping.
 181 (defvar muse-publish-presplit-directive-store nil
 182   "Stores directives from main file during splitting")
 183
 184 (defvar muse-publish-presplit-anchor-location nil
 185   "Stores anchors during publishing.")
 186
 187 (defvar muse-publish-split-file-split-values nil
 188   "Cache the values of split locations in files, during publish")
 189
 190 (defvar muse-publishing-targets-alist nil
 191   "Stores the targets to be published to.
 192
 193 Changing this will cause bad things to happen. ")
 194
 195 (defvar muse-publishing-style-in-use nil
 196   "Stores the style currently being published")
 197
 198 (defvar muse-publish-presplit-splitting-file nil
 199   "The file that we are current publishing for presplit")
 200
 201
 202 (defun muse-publish-no-split-function (file)
 203   (muse-with-temp-buffer
 204     (insert-file-contents file)
 205     (list `(,(file-name-sans-extension file) . (1 ,(point-max))))))
 206
 207 (defun muse-publish-split-file (file)
 208   "Calculate where to split the FILE.
 209
 210 FILE is the file to be split
 211
 212 This should return an alist of form (position . output-file)
 213 where position is the last position that should appear in output-file"
 214   (let* ((split-function
 215           (muse-get-keyword
 216            :split muse-publishing-style-in-use t))
 217          (split-alist
 218           (if (not split-function)
 219               (muse-publish-no-split-function file)
 220             (funcall split-function file))))
 221     (aput 'muse-publish-split-file-split-values
 222           file split-alist)
 223     split-alist))
 224
 225 (defun muse-publish-presplit-directive (&optional name value)
 226   (unless name (setq name (match-string 1)))
 227   (unless value (setq value (match-string 2)))
 228   ;; store the directives.
 229   (setq muse-publish-presplit-directive-store
 230         (format "%s#%s %s\n"
 231                 muse-publish-presplit-directive-store
 232                 name value)))
 233
 234 (defun muse-publish-presplit-anchor()
 235   "Stores the location and names of anchors"
 236   (let ((alist (aget muse-publish-presplit-anchor-location
 237                      muse-publish-presplit-splitting-file)))
 238
 239     (add-to-list 'alist
 240                  `(,(match-string 2) . ,(match-beginning 2)))
 241     (aput 'muse-publish-presplit-anchor-location
 242           muse-publish-presplit-splitting-file
 243           alist)))
 244
 245
 246 ;; ;;(setq muse-publish-split-file-split-values nil)
 247 ;; (setq muse-publish-split-file-split-values
 248 ;;       '(("d:/home/src/ht/home_website/journal-split/journal.muse"
 249 ;;          ("d:/home/src/ht/home_website/journal-split/journal-20060226" 875 1592)
 250 ;;          ("d:/home/src/ht/home_website/journal-split/journal-20060228" 417 874)
 251 ;;          ("d:/home/src/ht/home_website/journal-split/journal-20060303" 27 416)
 252 ;;          ("d:/home/src/ht/home_website/journal-split/journal-20060220" 1593 2957)
 253 ;;          ("d:/home/src/ht/home_website/journal-split/journal-all" 1 2957)
 254 ;;          ("d:/home/src/ht/home_website/journal-split/journal" 1 2957))))
 255
 256 ;; ;; muse-publish-presplit-anchor-location's value is shown below.
 257 ;; ;; Value:
 258 ;; ;; (setq muse-publish-presplit-anchor-location nil)
 259 ;; (setq muse-publish-presplit-anchor-location
 260 ;;       '(("d:/home/src/ht/home_website/journal-split/journal.muse"
 261 ;;          ("semantic_enrichment" 1642)
 262 ;;          ("title" 2))
 263 ;;         ("d:/home/src/ht/home_website/journal-split/simple.muse"
 264 ;;          ("anchor7" 189)
 265 ;;          ("anchor3" 173)
 266 ;;          ("anchor2" 162)
 267 ;;          ("simple_anchor" 15))))
 268
 269 ;; get the anchor locations
 270 ;;        (muse-publish-presplit-publish file)
 271 ;; get the split locations
 272
 273 ;;          (muse-publish-split-file file))
 274
 275 (defun test1()
 276   (interactive)
 277   (message "%s" (muse-publish-split-file-for-anchor
 278                  "d:/home/src/ht/home_website/journal-split/journal.muse"
 279                  "semantic_enrichment")))
 280
 281 (defun muse-publish-split-file-for-anchor (base-file anchor)
 282   "Given a base file and an anchor, return the file into which
 283 the anchor will be output"
 284   (let* (
 285          ;; this should be an alist, keyed on the anchor, valued on
 286          ;; either numbers, or file-locations
 287          (anchor-alist
 288           (or
 289            (aget muse-publish-presplit-anchor-location
 290                  base-file)
 291            (progn
 292              (muse-publish-presplit-publish base-file)
 293              (aget muse-publish-presplit-anchor-location
 294                    base-file))))
 295
 296          ;; this should be a list of triples: file, start, stop.
 297          (split-list
 298           (or (aget muse-publish-split-file-split-values
 299                     base-file)
 300               (muse-publish-split-file base-file)))
 301          ;; this should be either the position of the anchor in a
 302          ;; buffer as an int, or a output file location
 303          (anchor-position-or-location
 304           (aget anchor-alist anchor))
 305          ;; this should definately be the output file location
 306          (anchor-output
 307           (if (stringp anchor-position-or-location)
 308               anchor-position-or-location
 309             (car
 310              (delete nil
 311                      (mapcar
 312                       (lambda(elem)
 313                         (if (and
 314                              (> anchor-position-or-location
 315                                 (cadr elem))
 316                              (< anchor-position-or-location
 317                                 (caddr elem)))
 318                             (car elem)))
 319                       split-list))))))
 320
 321     ;; ensure that we put the location back into the stored list so
 322     ;; that we don't have to work it out next time
 323     (aput
 324      'anchor-alist anchor anchor-output)
 325
 326     (aput 'muse-publish-presplit-anchor-location
 327           base-file anchor-alist)
 328
 329     (file-name-nondirectory anchor-output)))
 330
 331
 332 ;; this is an example of why I would want to use the code.
 333 (muse-derive-style "journal-html-by-day" "journal-html"
 334                    :split 'muse-journal-split-by-entry)
 335
 336 (muse-derive-style "journal-html-by-month" "journal-html"
 337                    :split 'muse-journal-split-by-month)
 338
 339
 340 (defun muse-journal-split-by-entry (file)
 341   "Split a muse journal file into days"
 342   (muse-with-temp-buffer
 343     (insert-file-contents file)
 344     (let* ((split-alist)
 345            (root-name (file-name-sans-extension file))
 346            (split-regexp "^\\* \\([0-9]\\{8\\}\\)")
 347            (current-position
 348             (if (re-search-forward split-regexp nil t)
 349                 (- (match-beginning 0) 1)))
 350            (entry-name (match-string 1))
 351            (entry-location (match-beginning 0)))
 352       (while (re-search-forward split-regexp nil t)
 353         (setq entry-location (match-beginning 0))
 354         (add-to-list 'split-alist
 355                      `(,(concat root-name "-" entry-name)
 356                        ,current-position
 357                        ,(- entry-location 1)))
 358         (setq current-position entry-location
 359               entry-name (match-string 1)))
 360
 361       (add-to-list 'split-alist
 362                    `(,(concat root-name "-" entry-name)
 363                      ,current-position
 364                      ,(point-max))
 365                    t)
 366
 367       (add-to-list 'split-alist
 368                    `(,root-name
 369                      ,(cadr (car (last split-alist)))
 370                      ,(caddr (car (last split-alist))))
 371                    t)
 372
 373       (add-to-list 'split-alist
 374                    `(,(concat root-name "-all")
 375                      1 ,(point-max))
 376                    t))))
 377
 378 (defun muse-journal-split-by-month (file)
 379   "Split a muse journal file into months.
 380
 381 This function makes the assumption that the entries are sorted. If
 382 it isn't then it some of the entries will appear not to be published."
 383   (muse-with-temp-buffer
 384     (insert-file-contents file)
 385     (let* ((split-alist)
 386            (root-name (file-name-sans-extension file))
 387            (split-regexp (concat "^\\* \\([0-9]\\{4\\}\\)\\([0-9]\\{2\\}\\)"
 388                                  "\\([0-9]\\{2\\}\\)"))
 389            (current-position
 390             (if (re-search-forward split-regexp nil t)
 391                 (- (match-beginning 0) 1)))
 392            (entry-name (muse-journal-split-by-month-name))
 393            (entry-location (match-beginning 0)))
 394
 395       ;; for a new entry, if the name has changed
 396       (while (and (re-search-forward split-regexp nil t)
 397                   (not (equal entry-name
 398                               (muse-journal-split-by-month-name))))
 399         (setq entry-location (match-beginning 0))
 400         (add-to-list 'split-alist
 401                      `(,(concat root-name "-" entry-name)
 402                        ,current-position
 403                        ,(- entry-location 1)))
 404
 405         (setq current-position entry-location
 406               entry-name (muse-journal-split-by-month-name)))
 407
 408       ;; add last entry
 409       (add-to-list 'split-alist
 410                    `(,(concat root-name "-" entry-name)
 411                      ,current-position
 412                      ,(point-max)))
 413
 414       ;; add some duplicate entries in. Add these last, so that
 415       ;; anchors go to one of the others.
 416       ;;
 417
 418       ;; duplicate last entry as current
 419       (add-to-list 'split-alist
 420                    `(,root-name
 421                      ,(cadr (car (last split-alist)))
 422                      ,(caddr (car (last split-alist))))
 423                    t)
 424
 425       ;; add all entry
 426       (add-to-list 'split-alist
 427                    `(,(concat root-name "-all")
 428                      1 ,(point-max))
 429                    t))))
 430
 431 (defun muse-journal-split-by-month-name()
 432   (concat (match-string 1)
 433           (match-string 2)))
 434
 435
 436 (defun test2()
 437   (interactive)
 438   (message "%s" (muse-journal-split-by-entry "journal.muse")))
 439
 440
 441 (provide 'muse-split)
 442 ;; muse-split.el ends here