nxhtml/nxhtml/html-wtoc.el

   1 ;;; html-wtoc.el --- Creating pages with site TOC
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: Sat Feb 11 00:06:14 2006
   5 (defconst html-wtoc:version "0.2") ;; Version:
   6 ;; Last-Updated: Sun Nov 04 21:49:34 2007 (3600 +0100)
   7 ;; Keywords:
   8 ;; Compatibility:
   9 ;;
  10 ;; Features that might be required by this library:
  11 ;;
  12 ;;   None
  13 ;;
  14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15 ;;
  16 ;;; Commentary:
  17 ;;
  18 ;;
  19 ;;
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;;
  22 ;;; Change log:
  23 ;;
  24 ;;
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;;
  27 ;; This program is free software; you can redistribute it and/or modify
  28 ;; it under the terms of the GNU General Public License as published by
  29 ;; the Free Software Foundation; either version 2, or (at your option)
  30 ;; any later version.
  31 ;;
  32 ;; This program is distributed in the hope that it will be useful,
  33 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  34 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  35 ;; GNU General Public License for more details.
  36 ;;
  37 ;; You should have received a copy of the GNU General Public License
  38 ;; along with this program; see the file COPYING.  If not, write to the
  39 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  40 ;; Boston, MA 02111-1307, USA.
  41 ;;
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 ;;
  44 ;;; Code:
  45
  46 (eval-when-compile (add-to-list 'load-path default-directory load-path))
  47 (eval-when-compile (require 'html-site nil t))
  48
  49 ;;;###autoload
  50 (defgroup html-wtoc nil
  51   "Customization group for html-wtoc."
  52   :group 'nxhtml)
  53
  54 (defcustom html-wtoc-dir
  55   (file-name-as-directory
  56    (expand-file-name
  57     "html-wtoc"
  58     (file-name-directory
  59      (if load-file-name load-file-name buffer-file-name))))
  60
  61   "Directory where the tools needed are located.
  62 The tools for html-wtoc includes:
  63
  64 - html-wtoc.pl
  65 - html-wtoc.js
  66 - html-wtoc.css
  67 - html-wtoc-template.htm
  68 - html-wtoc-template.js
  69 - html-wtoc-template.css
  70 - img/
  71
  72 "
  73   :type 'directory
  74   :group 'html-wtoc)
  75
  76 ;; (defun html-wtoc-get-parsed-html-toc ()
  77 ;;   (save-excursion
  78 ;;     (let ((toc-file (html-toc-file)))
  79 ;;       (unless (file-exists-p toc-file)
  80 ;;         (html-toc-write-toc-file))
  81 ;;       (with-current-buffer (find-file-noselect toc-file)
  82 ;;         (goto-char (point-min))
  83 ;;         (let ((toc-begin  (search-forward html-toc-mark-begin nil t))
  84 ;;               (toc-middle (search-forward html-toc-mark-middle nil t))
  85 ;;               toc-parsed)
  86 ;;           (unless (and toc-begin toc-middle)
  87 ;;             (error "Can't find table of contents in %s" toc-file))
  88 ;;           (setq toc-parsed (html-toc-parse-toc
  89 ;;                             (buffer-substring-no-properties
  90 ;;                              toc-begin toc-middle))))))))
  91
  92 ;; (defun html-wtoc-get-atags (parsed-ul level)
  93 ;;   (assert (eq 'ul (car parsed-ul)))
  94 ;;   (let (atags)
  95 ;;     (dolist (l parsed-ul)
  96 ;;       (when (and (listp l)
  97 ;;                  (eq 'li (car l)))
  98 ;;         (dolist (ll l)
  99 ;;           (when (listp ll)
 100 ;;             (when (eq 'a (car ll))
 101 ;;               (setq atags
 102 ;;                     (cons
 103 ;;                      (list level
 104 ;;                            (caddr ll)
 105 ;;                            (cdaadr ll))
 106 ;;                      atags)))
 107 ;;             (when (eq 'ul (car ll))
 108 ;;               (let ((subs (html-wtoc-get-atags ll (1+ level))))
 109 ;;                 (dolist (s subs)
 110 ;;                   (setq atags (cons s atags)))))))))
 111 ;;     (reverse atags)))
 112
 113 ;; (defcustom html-wtoc-pages-default-name "html-wtoc-pages.txt"
 114 ;;   "Default file name sans directory for list of pages file.
 115 ;; This file is located in the same directory as `html-toc-file'."
 116 ;;   :type 'string)
 117
 118 ;; (defun html-wtoc-pages-file ()
 119 ;;   (expand-file-name html-wtoc-pages-default-name
 120 ;;                     (file-name-directory (html-toc-file))))
 121
 122 (defun html-wtoc-browse-page-with-toc ()
 123   (interactive)
 124   (unless buffer-file-name
 125     (error "This buffer is not visiting a file"))
 126   (html-site-current-ensure-site-defined)
 127   (let ((merge-dir (html-site-current-merge-dir))
 128         merged-file
 129         (in-site (html-site-dir-contains
 130                   (html-site-current-site-dir)
 131                   buffer-file-name)))
 132     (unless merge-dir
 133       (error "There is no output dir for pages with TOC defined for the site %s"
 134              html-site-current))
 135     (unless in-site
 136       (error "This buffer's file is not in %s" (html-site-current-site-dir)))
 137     (setq merged-file
 138           (expand-file-name
 139            (file-relative-name buffer-file-name
 140                                (html-site-current-site-dir))
 141            (html-site-current-merge-dir)))
 142     (unless (file-exists-p merged-file)
 143       (error "The file %s does not yet exist.\nPlease do use `html-wtoc-write-merged' to create it."
 144              merged-file))
 145     (browse-url-of-file merged-file)))
 146
 147
 148 (defun html-wtoc-write-pages-with-toc (allow-overwrite)
 149   "Merge the TOC with the pages.
 150
 151 If an entry with the name MERGE-NAME exists in `html-wtoc-merges'
 152 then this is chosen.  Otherwise a new entry is created and added
 153 to `html-wtoc-merges'.  The entry has all necessary information to
 154 do the merge.
 155
 156 If `html-move-site-directory' has a non-nil value then the list
 157 of completions when prompting for MERGE-NAME contains only those
 158 merge names from `html-wtoc-merges' where the site directory has
 159 the same value.  Otherwise the completion list contains all merge
 160 names and `html-move-site-directory' will be set to the chosen
 161 merge's site directory.
 162
 163 The merging of the pages and the table of contents is done in a
 164 subprocess using a Perl script named html-wtoc.pl the directory
 165 `html-wtoc-dir'.
 166 "
 167   (interactive (list (y-or-n-p "Allow overwrite? ")))
 168   (html-site-current-ensure-site-defined)
 169   (let ((pag-file (html-site-current-page-list))
 170         (out-dir  (html-site-current-merge-dir))
 171         (tpl-file (html-site-current-merge-template))
 172         (html-wtoc-pl (expand-file-name "html-wtoc.pl" html-wtoc-dir))
 173         )
 174     (unless (< 0 (length pag-file))
 175       (error "Page list file not defined for site %s" html-site-current))
 176     (unless (file-exists-p pag-file)
 177       (error "Can't find page file for site %s.\nHave you done M-x html-toc-create-pages-file?"
 178              html-site-current))
 179     (unless (< 0 (length tpl-file))
 180       ;;(error "Template file not defined for site %s.\nPlease use customize to add this in `html-site-list'." html-site-current)
 181       (setq tpl-file (expand-file-name "html-wtoc-template.html" html-wtoc-dir))
 182       )
 183     (let (
 184           (buffer (noshell-procbuf-setup "*Merging pages and TOC*"))
 185           (opt (list
 186                 (concat "pages=" pag-file)
 187                 (concat "outroot=" out-dir)
 188                 (concat "template=" tpl-file))))
 189       (when allow-overwrite
 190         (setq opt (cons "update=1" opt)))
 191       (apply 'noshell-procbuf-run
 192              buffer
 193              "perl" "-w"
 194              html-wtoc-pl "merge"
 195              opt
 196              ))))
 197
 198 (provide 'html-wtoc)
 199 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 200 ;;; html-wtoc.el ends here