;;;;  -*- mode:emacs-lisp; coding:utf-8 -*-
;;;; ****************************************************************************
;;;; FILE:               html-update.el
;;;; LANGUAGE:           emacs lisp
;;;; SYSTEM:             POSIX
;;;; USER-INTERFACE:     NONE
;;;; DESCRIPTION
;;;;
;;;;     This scripts updates automatically generated parts of my HTML pages.
;;;;
;;;; AUTHORS
;;;;     <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;;; MODIFICATIONS
;;;;     2003-05-22 <PJB> Added this header.
;;;; BUGS
;;;;     Should probably be converted to COMMON-LISP...
;;;; LEGAL
;;;;     GPL
;;;;
;;;;     Copyright Pascal Bourguignon 2003 - 2003
;;;;
;;;;     This program is free software; you can redistribute it and/or
;;;;     modify it under the terms of the GNU General Public License
;;;;     as published by the Free Software Foundation; either version
;;;;     2 of the License, or (at your option) any later version.
;;;;
;;;;     This program is distributed in the hope that it will be
;;;;     useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;     warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;     PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;     You should have received a copy of the GNU General Public
;;;;     License along with this program; if not, write to the Free
;;;;     Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;     Boston, MA 02111-1307 USA
;;;; ****************************************************************************
(require 'cl)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- some general string functions

(defun unsplit-string (string-list &rest separator)
  "Does the inverse than split-string. If no separator is provided then a simple space is used."
  (if (null separator)
      (setq separator " ")
    (if (= 1 (length separator))
        (setq separator (car separator))
      (error "unsplit-string: Too many separator arguments.")))
  (if (not (char-or-string-p separator))
      (error "unsplit-string: separator must be a string or a char."))
  (apply 'concat (list-insert-separator string-list separator)))


(defun string-repeat (num string)
  "Return a string built from the concatenation of num times string."
  (cond ((<= num 0) "")
        ((= 0 (% num 2)) (let ((sub (string-repeat (/ num 2) string)))
                           (concat sub sub)))
        (t (let ((sub (string-repeat (/ (- num 1) 2) string)))
                           (concat sub sub string)))))


;; --- Some buffer content manipulation functions

(defun search-block (begin end &optional include)
  "include=t                => return the range including begin and end.
include=nil (or abscent) => return the range excluding begin and end."
  (let* ((start      (re-search-forward begin nil t))
         (true-start (if include (match-beginning 0) start))
         (stop       (re-search-forward end   nil t))
         (true-stop  (if include stop (match-beginning 0))))
    (if (and start stop)
        (cons true-start true-stop)
      nil)))


;; --- Some list manipulation functions

(defun flatten (tree)
  "
RETURN: A tree containing all the elements of the `tree'.
"
  (do ((result nil)
       (stack  nil))
      ((not (or tree stack)) (nreverse result))
    (cond
     ((null tree)
      (setq tree (pop stack)))
     ((atom tree)
      (push tree result)
      (setq tree (pop stack)))
     ((consp (car tree))
      (push (cdr tree) stack)
      (setq tree (car tree)))
     (t
      (push (car tree) result)
      (setq tree (cdr tree))))))



(defun list-insert-separator (list separator)
  (if (or (null list)
          (null (cdr list)))
      list
    (cons (car list) (cons separator
                           (list-insert-separator (cdr list) separator)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;

(defun get-lang (lang alist)
  (let ((a (assoc lang alist)))
    (if a
      (nth 1 a)
      (nth 1 (flatten
              (mapcar (lambda (lang) (assoc  (intern lang) alist))
                      language-order))))))


(defun html-generate-downloads (language mirrors dldesc)
  (let* ((tag               (nth 0 dldesc))
         (descriptions      (nth 1 dldesc))
         (files             (nth 2 dldesc))
         (additional-urls   (nth 3 dldesc)))
    (setq language (or language 'en))
    (apply
     'concat
     (flatten
      (list

       (format "<!--DOWNLOAD-BEG-%s-->\n" tag)
       "<!-- This section is automatically generated by html-update, -->\n"
       "<!-- from data in 'node.el'.    Please, do not edit it here. -->\n"

       "<H2>"
       (format "<A NAME=\"%s\">" tag)
       (format (get-lang language
                '((fr "Obtenir %s")
                  (es "Descargar %s")
                  (en "Downloading %s"))) tag)
       "</A></H2>\n"
       (let ((desc (get-lang language descriptions)))
         (if (= 0 (length desc))
           ""
           (format "<P>%s</P>\n<p><br></p>\n"  desc)))

       (format "<TABLE BORDER=\"1\" WIDTH=\"95%%\" SUMMARY=\"Download sources\">\n  <TR><TH>%s</TH>\n"
               (get-lang language '((fr "Mirroirs")
                                    (es "Espejos")
                                    (en "Mirrors"))))
       (mapcar (lambda (m)
                 (format "    <TH>%s</TH>\n" (car m))) mirrors)
       "  </TR>\n"

       (mapcar
        (lambda (f)
          (list
           (format "  <TR VALIGN=\"TOP\"><TD><CODE>%s</CODE><BR>%s</TD>\n"
                   (nth 0 f)
                   (format (get-lang language
                                     '((fr "(%d octets)")
                                       (es "(%d octetos)")
                                       (en "(%d bytes)")))
                           (nth 2 f)))
           (mapcar
            (lambda (m)
              (format
                "    <TD><A HREF=\"%s\">\n        %s</A><BR>(%s)</TD>\n"
                (concat (nth 1 m) (nth 1 f))
                ;;(format
                 (get-lang language
                           '((fr "Télécharger")
                             (es "Descargar")
                             (en "Download")))
                 ;;(nth 0 m))
                (upcase (substring (nth 1 m) 0 (search ":" (nth 1 m))))))
            mirrors)

           "  </TR>\n"))
        files)
       (mapcar
        (lambda (u)
          (list
           "  <TR VALIGN=\"TOP\">\n"
           (format "    <TD><CODE>%s</CODE><BR>%s</TD>\n"
                   (nth 1 u)
                   (format (get-lang language
                                     '((fr "(%d octets)")
                                       (es "(%d octetos)")
                                       (en "(%d bytes)")))
                           (nth 3 u)))
           (format (concat
                    "    <TD COLSPAN=\"%d\"><A HREF=\"%s\">\n"
                    "    %s</A><BR>(%s)</TD>\n")
                   (length mirrors)
                   (nth 2 u)
                   ;;(format
                    (get-lang  language
                               '((fr "Télécharger")
                                 (es "Descargar")
                                 (en "Download")))
                    ;;(nth 0 u))
                   (upcase (substring (nth 2 u) 0 (search ":" (nth 2 u)))))
           "  </TR>\n"))
        additional-urls)

       "</TABLE>\n"
       "<!--DOWNLOAD-END-->")))))




;; --- generic html processing function

(defun ascii ()
"
RETURN: A list of string of one character each,
        containing all the ASCII characters.
"
  (let* ((i 0)
         (result (list 'result))
         (last   result))
    (while (< i 128)
      (setcdr last (cons (format "%c" i) nil))
      (setq   last (cdr last)
              i    (+ 1 i)))
    (cdr result)))


(defvar isolatin1)
(setq isolatin1
  (apply 'vector
   (append
    (ascii)
    '(
      "&#128;" "&#129;" "&#130;" "&#131;" "&#132;" "&#133;" "&#134;"
      "&#135;" "&#136;" "&#137;" "&#138;" "&#139;" "&#140;" "&#141;"
      "&#142;" "&#143;" "&#144;" "&#145;" "&#146;" "&#147;" "&#148;"
      "&#149;" "&#150;" "&#151;" "&#152;" "&#153;" "&#154;" "&#155;"
      "&#156;" "&#157;" "&#158;" "&#159;" "&nbsp;" "&#161;" "&#162;"
      "&#163;" "&#164;" "&#165;" "&#166;" "&#167;" "&#168;" "&#169;"
      "&#170;" "&#171;" "&#172;" "&#173;" "&#174;" "&#175;" "&#176;"
      "&#177;" "&#178;" "&#179;" "&#180;" "&#181;" "&#182;" "&#183;"
      "&#184;" "&#185;" "&#186;" "&#187;" "&#188;" "&#189;" "&#190;"
      "&#191;" "&Agrave;" "&Aacute;" "&Acirc;" "&Atilde;" "&Auml;" "&Aring;"
      "&AElig;" "&Ccedil;" "&Egrave;" "&Eacute;" "&Ecirc;" "&Euml;"
      "&Igrave;" "&Iacute;" "&Icirc;" "&Iuml;" "&ETH;" "&Ntilde;" "&Ograve;"
      "&Oacute;" "&Ocirc;" "&Otilde;" "&Ouml;" "&#215;" "&Oslash;"
      "&Ugrave;" "&Uacute;" "&Ucirc;" "&Uuml;" "&Yacute;" "&THORN;"
      "&szlig;" "&agrave;" "&aacute;" "&acirc;" "&atilde;" "&auml;" "&#229;"
      "&aelig;" "&ccedil;" "&egrave;" "&eacute;" "&ecirc;" "&euml;"
      "&igrave;" "&iacute;" "&icirc;" "&iuml;" "&eth;" "&ntilde;" "&ograve;"
      "&oacute;" "&ocirc;" "&otilde;" "&ouml;" "&#247;" "&oslash;"
      "&ugrave;" "&uacute;" "&ucirc;" "&uuml;" "&yacute;" "&thorn;" "&yuml;"
      ))))


(defun html-isolatin1-to-html (string)
  (setq string (string-make-unibyte string))
  (let ((i 0)
        (j 0)
        (length (length string))
        (result ""))
    (while (< i length)
      (while (and (< i length) (< (elt string i) 128))
        (setq i (+ 1 i)))
      (if (< i length)
          (progn
            (setq result (concat result (substring string j i)))
            (setq result (concat result (aref isolatin1 (elt string i))))
            (setq i (+ 1 i))
            (setq j i))))
    (setq result (concat result (substring string j i)))))


(defun get-file-name (file lang)
  (if (and (not (file-readable-p file))
           (not (string= (substring file -5) ".html"))
           (not (string= (substring file -4) ".htm")))
      (let ((language (if lang (cons lang language-order) language-order))
            (localized-file))
        (while language
          (setq localized-file (concat file "."  (car language) ".html"))
          (if (file-readable-p localized-file)
              (setq file localized-file
                    language nil)
              (setq localized-file (concat file "." (car language) ".htm"))
              (if (file-readable-p localized-file)
                  (setq file localized-file
                        language nil)))
          (setq language (cdr language)))))
  file)


(defun html-get-title (html-file lang)
  "Read the file html-file and return the title enclosed in <title> </title>."
  (save-excursion
    (let ((html-file (get-file-name html-file lang)))
      (if (not (file-readable-p  html-file))
          html-file
          (find-file html-file)
          (goto-char 0)
          (let* ((range  (search-block "<[Tt][Ii][Tt][Ll][Ee][^>]*>"
                                       "</[Tt][Ii][Tt][Ll][Ee][^>]*>" nil))
                 (result (if range
                             (buffer-substring-no-properties
                              (car range) (cdr range))
                             html-file)))
            (bury-buffer)
            ;;(html-isolatin1-to-html result)
            result)))))


(defun html-equal-uri-p (base-path new-path)
  (let ((rel-uri (html-make-relative-uri base-path new-path)))
    (or (string= "" rel-uri) (string= "." rel-uri))))


(defun html-make-relative-uri (base-path new-path)
  (let ((result
         (let ((base-list (split-string base-path "/"))
               (new-list  (split-string new-path  "/")))
           (when (string= "" (car base-list)) (pop base-list))
           (while (and (not (null base-list)) (not (null new-list))
                       (string= (car base-list) (car new-list)))
             (setq base-list (cdr base-list)
                   new-list  (cdr new-list)))
           (message "base-list=%S new-list=%S"base-list new-list)
           (setq base-list (butlast base-list))
           (message "base-list=%S new-list=%S"base-list new-list)
           (cond
             ((null base-list)    (unsplit-string new-list "/"))
             ((null new-list)     (string-repeat (length base-list) "../"))
             (t (when (string= "" (car new-list)) (pop new-list))
                (concat (string-repeat (length base-list) "../")
                        (unsplit-string new-list "/")))))))
    (message "(html-make-relative-uri %S %S)-->%S" base-path new-path result)
    result))

;; (dolist (test '(("index.html" "/index.html")
;;                 ("index.html" "/toc.html")
;;                 ("index.html" "lamanga/index.html")))
;;   (html-make-relative-uri (first test) (second test)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Page Tree
;;


;; tree-label           is the "path" of the page.
;; tree-decor           contains the page:
;;    page-curr-path    is the path of the page (same as tree-label)
;;    page-prev-path    is the path of the previous 'string' page.
;;    page-next-path    is the path of the next 'string' page.
;;    page-title        is deprecated, since it depends on the language.
;;    page-children     contains the direct 'string' children.
;; tree-children        contains all the child sub-trees!


(defstruct tree label decor children)
(defstruct page curr-path prev-path next-path parent children)


(defun tree-walk-depth (tree func &optional depth path)
  ;; there's no default value with &optional in emacs lisp!
  (setf depth (or depth 0))
  (push (tree-label tree) path)
  (funcall func tree depth (reverse path))
  (incf depth)
  (dolist (child (tree-children tree))
    (tree-walk-depth child func depth path)))


(defun tree-walk-fix (tree prefix infix suffix &optional depth path)
  ;; there's no default value with &optional in emacs lisp!
  (setf depth (or depth 0))
  (push (tree-label tree) path)
  (let ((rpath (reverse path)))
    (funcall prefix tree depth rpath)
    (do ((children (tree-children tree) (cdr children)))
        ((null children))
      (tree-walk-fix (car children) prefix infix suffix (1+ depth) path)
      (unless (null (cdr children))
        (funcall infix tree depth rpath)))
    (funcall suffix tree depth rpath)))



(defun tree-find-if (tree predicate)
  "Return the first child found for which predicate returns non nil.
Note: walks the tree prefixed depth first."
  (cond ((null tree) nil)
        ((funcall predicate tree) tree)
        (t (block :child
             (dolist (child (tree-children tree))
               (let ((result (funcall predicate child)))
                 (when result (return-from :child result)))
               (let ((result (tree-find-if child predicate)))
                 (when result (return-from :child  result))))
             nil))))


(defun tree-node-with-label (tree label)
  "Return the first child found with same label  (equal)."
  (tree-find-if tree (lambda (tree) (if (equal (tree-label tree) label) tree nil))))



;; (show  (tree-node-with-label tree "develop/emacs/index.html"))

;; (let ((parent  (tree-node-with-label tree "develop/emacs/index.html")))
;;   (tree-find-if tree (lambda (child) (if (eq (tree-parent child) parent) child nil))))





;; An etree is a normalized for of the enode tree given by the user.
;; It's used to build the actual tree data structure to be processed.
;; --------------------
;; etree    ::= ( path . children )
;; children ::= ( etree ... ) | ()

(defstruct etree path children)


(defun etree-flatten-paths (etree)
  "Return: a list of the paths of all the nodes of the etree."
  (cons (etree-path etree)
        (mapcan (function etree-flatten-paths) (etree-children etree))))


(defun etree-search-page-with-path (etree path)
  "Return: the etree node that has (eq) path."
  (cond ((null etree) nil)
        ((eq path (etree-path etree)) etree)
        (t (block :children
             (dolist (child (etree-children etree))
               (let ((result (etree-search-page-with-path child path)))
                 (when result (return-from :children result))))
             nil))))


(defun path-list-to-page-list (paths etree)
  (do ((paths (cddr paths) (cdr paths))
       (prev  nil          curr)
       (curr  (car paths)  next)
       (next  (cadr paths) (car paths))
       (result '()))
      ((null curr) (nreverse result))
    (push (make-page
           :curr-path curr
           :prev-path prev
           :next-path next
           :children (mapcar (function etree-path)
                             (etree-children
                              (etree-search-page-with-path etree curr))))
          result)))


(defun etree-to-tree (etree &optional pages)
  (unless pages
    (setq pages (path-list-to-page-list (etree-flatten-paths etree) etree)))
  (let ((parent (make-tree
                 :label (etree-path etree)
                 :decor (car (member* (etree-path etree) pages
                                      :test (function eq)
                                      :key (function page-curr-path)))
                 :children (mapcar (lambda (child) (etree-to-tree child pages))
                                   (etree-children etree)))))
    (dolist (child (tree-children parent))
      (setf (page-parent (tree-decor child)) parent))
    parent))


;; An enode is list syntax given by the user to describe the page hierarcy.
;; --------------------
;; enode    ::= ( path . children )
;; children ::= ( enode ... )

(defmacro enode-path     (enode) `(car ,enode))
(defmacro enode-children (enode) `(cdr ,enode))

(defun enode-to-etree (enode)
  (make-etree :path (enode-path enode)
              :children (mapcar (function enode-to-etree)
                                (enode-children enode))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Generating HTML.
;;

(defun generate-html-menu (node path lang)
  (let* ((labe         (tree-label node))
         (curr         (page-curr-path (tree-decor node)))
         (next         (page-next-path (tree-decor node)))
         (prev         (page-prev-path (tree-decor node)))
         (parent       (page-parent    (tree-decor node)))
         (curr-title   (html-get-title curr lang)) ;;(page-title node))
         (pare         (and parent (tree-label parent)))
         (pare-title   (and pare (html-get-title pare lang))) ;;(page-title parent)
         (children     (tree-children node)))
    (when nil
      (let* (
             (head-format "<!--MENU-BEGIN-->
<!-- This section is automatically generated by html-update, -->
<!-- from data in 'node.el'.    Please, do not edit it here. -->
<HR>
<TABLE BORDER=\"0\" ALIGN=\"CENTER\" SUMMARY=\"Navigation Menu\">
<TR>
")
             (prev-format
              (let ((title
                     (cond ((string= lang "fr") "Pr&eacute;c&eacute;dent")
                           ((string= lang "es") "Precedente")
                           (t                   "Previous"))))
                (format "
<TD><TABLE BORDER=\"0\" ALIGN=\"CENTER\" SUMMARY=\"%s\">
     <TR><TD BGCOLOR=\"#c0f0e0\">
           <A CLASS=\"button\" HREF=\"%%s\"><SMALL>&lt;&lt; %s &lt;&lt; </SMALL></A></TD>
    </TABLE>
"  title title)))
             (begi-format
              (format
                  "<TD><TABLE BORDER=\"0\" ALIGN=\"CENTER\" SUMMARY=\"%s\">\n"
                (cond ((string= lang "fr") "Liens")
                      ((string= lang "es") "Enlaces")
                      (t                   "Links"))))
             (menu-format "
<TR>
<TD BGCOLOR=\"#c0f0e0\">&#183;</TD>
<TD BGCOLOR=\"#c0f0e0\"> <A HREF=\"%s\"><SMALL>%s</SMALL></A></TD>
<TD BGCOLOR=\"#c0f0e0\">&#183;</TD>
")
             (endm-format "\n</TABLE>\n")
             (next-format
              (let ((title
                     (cond ((string= lang "fr") "Suivant")
                           ((string= lang "es") "Siguiente")
                           (t "Next"))))
                (format "
<TD><TABLE BORDER=\"0\" ALIGN=\"CENTER\" SUMMARY=\"%s\">
     <TR><TD BGCOLOR=\"#c0f0e0\">
         <A CLASS=\"button\" HREF=\"%%s\"><SMALL>&gt;&gt; %s &gt;&gt;</SMALL></A></TD>
    </TABLE>
" title title)))
             (tail-format "
</TABLE>
<HR>
<PRE>&nbsp;
</PRE>
<!--MENU-END-->")
             (menu))
        (setq menu (format head-format))
        (if prev
          (setq menu (concat menu (format prev-format
                                    (html-make-relative-uri curr prev)))))
        (setq menu (concat menu (format begi-format)))
        (if pare-title
          (setq menu (concat menu
                             (format menu-format
                               (html-make-relative-uri curr pare)
                               (concat "<!--parent-->" pare-title)))))
        (while children
          (if (not (eq (tree-label (car children)) node))
            (setq menu
                  (concat menu
                          (format menu-format
                            (html-make-relative-uri
                             curr
                             (page-curr-path (tree-decor (car children))))
                            (html-get-title (tree-label (car children))
                                            lang)))))
          (setq children (cdr children)))
        (setq menu (concat menu (format endm-format)))
        (if next
          (setq menu (concat menu (format next-format
                                    (html-make-relative-uri curr next)))))
        (setq menu (concat menu (format tail-format)))
        ;;(message (format "Menu for (node=%S parent=%S path=%S lang=%S) = %S"
        ;;                 node parent path lang "menu"))
        menu
        ))

    (concatenate 'string
      "<!--MENU-BEGIN-->\n"
      "<!-- This section is automatically generated by html-update, -->\n"
      "<!-- from data in 'node.el'.    Please, do not edit it here. -->\n"
      "<DIV CLASS=\"MENU\">"
      "<HR><P>|\n"
      (format " <A CLASS=\"button\" HREF=\"%s\">Contents</a> |\n"
          (html-make-relative-uri curr "toc.html"))
      (if (not (html-equal-uri-p curr "index.html"))
        (format " <A CLASS=\"button\" HREF=\"%s\">Home</a> |\n"
          (html-make-relative-uri curr "index.html"))
        "")
      (if (and prev (not (html-equal-uri-p curr prev)))
        (format " <A CLASS=\"button\" HREF=\"%s\">Previous</a> |\n"
          (html-make-relative-uri curr prev))
        "")
      (if (and pare (not (html-equal-uri-p curr pare)))
        (format " <A CLASS=\"button\" HREF=\"%s\">Up</a> |\n"
          (html-make-relative-uri curr pare))
        "")
      (let ((child
             (do ((children children (cdr children)))
                 ((or (null children)
                      (not (eq (tree-label(car children)) node))
                      (not (html-equal-uri-p
                            curr (page-curr-path (tree-decor (car children))))))
                  (car children)))))
        (if child
          (format " <A CLASS=\"button\" HREF=\"%s\">Down</a> |\n"
            (html-make-relative-uri curr (page-curr-path (tree-decor child))))
          ""))
      (if (and next (not (html-equal-uri-p curr next)))
        (format " <A CLASS=\"button\" HREF=\"%s\">Next</a> |\n"
          (html-make-relative-uri curr next))
        "")
      "</P><HR></DIV>\n"
      "<!--MENU-END-->")))



(defun generate-html-email (&optional address)
  "
    DO:         Generate an email address as an HTML string with the characters
            written as entities.
"
  (setq address (concat "mailto:" (or address  user-mail-address)))
  (let ((i (1- (length address)))
        (res '()))
    (while (<= 0 i)
      (setq res (cons (format "&#%d;" (aref address i)) res))
      (setq i (1- i)))
    (setq res (apply 'concat res))
    (format "<!--EMAIL-BEGIN-->\n<a href=\"%s\">%s</a>\n<!--EMAIL-END-->\n"
            res res)))



(defun generate-html-top (labe curr lang)
  (format (cond ((string= lang "fr") "<!--TOP-BEGIN-->
<!-- This section is automatically generated by html-update, -->
<!-- from data in 'node.el'.    Please, do not edit it here. -->
<DIV CLASS=\"TOP\">%s</DIV>
<!--TOP-END-->")
                ((string= lang "es") "<!--TOP-BEGIN-->
<!-- This section is automatically generated by html-update, -->
<!-- from data in 'node.el'.    Please, do not edit it here. -->
<DIV CLASS=\"TOP\">%s</DIV>
<!--TOP-END-->")
                (t "<!--TOP-BEGIN-->
<!-- This section is automatically generated by html-update, -->
<!-- from data in 'node.el'.    Please, do not edit it here. -->
<DIV CLASS=\"TOP\">%s</DIV>
<!--TOP-END-->"))
    (site-top labe curr lang)))

;; <BR><SMALL>Derni&egrave;re mise &agrave; jour : <!--MODIFICATION-DATE--> %s
;;      par : <!--MODIFICATION-AUTEUR--> %s
;;     </SMALL>

;; <BR><SMALL>Fecha de ultimos cambios : <!--MODIFICATION-DATE--> %s
;;      por : <!--MODIFICATION-AUTEUR--> %s
;;     </SMALL>

;; <BR><SMALL>Last update : <!--MODIFICATION-DATE--> %s
;;      by : <!--MODIFICATION-AUTEUR--> %s
;;     </SMALL>

(defun generate-html-bottom (labe curr lang)
  (let ((current-date (format-time-string "%Y-%m-%d %H:%M:%S")))
    (format (cond ((string= lang "fr") "<!--BOTTOM-BEGIN-->
<!-- This section is automatically generated by html-update, -->
<!-- from data in 'node.el'.    Please, do not edit it here. -->
<DIV CLASS=\"BOTTOM\">
%s
<BR><SMALL>
    <a href=\"http://validator.w3.org/check?uri=referer\"><img
        src=\"http://www.w3.org/Icons/valid-html401\"
        alt=\"Valid HTML 4.01!\" height=\"31\" width=\"88\"></a>
    </SMALL>
</DIV>
<!--BOTTOM-END-->")
                  ((string= lang "es") "<!--BOTTOM-BEGIN-->
<!-- This section is automatically generated by html-update, -->
<!-- from data in 'node.el'.    Please, do not edit it here. -->
<DIV CLASS=\"BOTTOM\">
%s
<BR><SMALL>
      <a href=\"http://validator.w3.org/check?uri=referer\"><img
          src=\"http://www.w3.org/Icons/valid-html401\"
          alt=\"Valid HTML 4.01!\" height=\"31\" width=\"88\"></a>
    </SMALL>
</DIV>
<!--BOTTOM-END-->")
                  (t "<!--BOTTOM-BEGIN-->
<!-- This section is automatically generated by html-update, -->
<!-- from data in 'node.el'.    Please, do not edit it here. -->
<DIV CLASS=\"BOTTOM\">
%s
<BR><SMALL>
      <a href=\"http://validator.w3.org/check?uri=referer\"><img
          src=\"http://www.w3.org/Icons/valid-html401\"
          alt=\"Valid HTML 4.01!\" height=\"31\" width=\"88\"></a>
   </SMALL>
</DIV>
<!--BOTTOM-END-->"))
      (site-bottom labe curr lang)
      ;; current-date
      ;; (user-full-name)
      )))


;;  <P><img src=\"images/valid-html401.png\" alt=\"Valid HTML4.01\">


(defun ghc-prefix (node depth path)
  "Generate a HTML table of contents."
  (let* ((labe    (tree-label node))
         (curr    (page-curr-path (tree-decor node)))
         (title   (html-get-title labe
                                  ;; (concatenate 'string labe ".html")
                                  "en")))
    (princ (format "<li><a href=\"%s\">%s</a></li>\n"
             (html-make-relative-uri "/contents.html" curr)
             (or title curr)))
    (when (tree-children node)
      (princ "<li><ol>\n"))))


(defun ghc-suffix (node depth path)
  "Generate a HTML table of contents."
  (when (tree-children node)
    (princ "</ol></li>\n")))


(defun generate-html-toc (tree)
  (with-output-to-string
      (tree-walk-fix
       tree (function ghc-prefix) (lambda (n d p)) (function ghc-suffix))))


(defun generate-table-of-content-page (tree path)
  (find-file path)
  (erase-buffer)
  (dolist
      (line
       '(
         "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
         "<HTML>"
         "<HEAD>"
         "<TITLE>Table of Content</TITLE>"
         "<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=iso-8859-1\">"
         "<META NAME=\"author\" CONTENT=\"Pascal J. Bourguignon\">"
         "<META HTTP-EQUIV=\"Description\" NAME=\"description\" CONTENT=\"Table of contents\">"
         "<link rel=\"stylesheet\"    href=\"default.css\"  type=\"text/css\">"
         "</HEAD>"
         "<BODY>"
         "<H1>Table of Contents</H1>"
         "<OL>"
         ))
    (insert line) (insert "\n"))
  (insert (generate-html-toc tree))
    (dolist
      (line
       '(
         "</OL>"
         "</BODY>"
         "</HTML>"))
    (insert line) (insert "\n"))
    (save-buffer)
    (kill-buffer (current-buffer)))


(defun process-html-node (node depth path)
  "Update the html file in the node."
  (let* ((labe    (tree-label node))
         (curr    (page-curr-path (tree-decor node)))
         (next    (page-next-path (tree-decor node)))
         (prev    (page-prev-path (tree-decor node)))
         (parent  (page-parent    (tree-decor node)))
         (pare    (and parent (tree-label parent)))
         (lang)
         (currlist)
         (save)
         (buffer)
         (range))
    (when curr
      (message (format (concat "--------------------\n"
                               "Let's see %S\n"
                               "--------------------\n") curr))
      (setq curr (concat nodes-dir "/" curr))
      (setq currlist (if (file-readable-p curr)
                         (list curr)
                         (if (file-readable-p (concat curr ".html"))
                             (list  (concat curr ".html"))
                             (mapcar (lambda (lang)
                                       (concat curr "." lang ".html"))
                                     language-order))))
      (dolist (curr currlist)
        (setq save     nil)

        (if (not (file-readable-p  curr))
            (message (format "No file %S readable. Skipping." curr))
            (progn
              (message (format "Begin %s" curr))
              (message (format "Paren %s" pare))
              (message (format "Prev  %s" prev))
              (message (format "Next  %s" next))
              (setq lang (substring (substring curr -7) 0 2))
              (if (not (member lang language-order))
                  (setq lang nil))

              (find-file curr)
              (setq buffer (current-buffer))

              (goto-char 0)
              (setq range (search-block "<!--[^>]*DOWNLOAD-BEG\\>-"
                                        "<!--[^>]*DOWNLOAD-END.*-->" t))
              (while range
                (let ((tag)
                      (ass))
                  (setq save t)

                  (setq tag (buffer-substring
                             (+ (car range)
                                (length "<!--DOWNLOAD-BEG\\>-"))
                             (+ (car range) 100)))
                  (setq tag (substring tag 0 (search "-->" tag)))
                  (setq ass (assoc (intern tag) downloads))
                  (message (format "TAG=%s" tag))
                  (if ass
                      (progn
                        (delete-region (car range) (cdr range))
                        (insert (html-generate-downloads (and lang (intern lang))
                                                         mirrors ass))))
                  (setq range (search-block "<!--[^>]*DOWNLOAD-BEG\\>"
                                            "<!--[^>]*DOWNLOAD-END.*-->" t))))


              (goto-char 0)
              (setq range (search-block "<!--[^>]*MENU-BEGIN.*-->"
                                        "<!--[^>]*MENU-END.*-->" t))
              (while range
                (setq save t)
                (delete-region (car range) (cdr range))
                (insert (generate-html-menu node path lang))
                (setq range (search-block "<!--[^>]*MENU-BEGIN.*-->"
                                          "<!--[^>]*MENU-END.*-->" t)))

              (goto-char 0)
              (setq range (search-block "<!--[^>]*TOP-BEGIN.*-->"
                                        "<!--[^>]*TOP-END.*-->" t))
              (while range
                (setq save t)
                (delete-region (car range) (cdr range))
                (insert (generate-html-top labe curr lang))
                (setq range (search-block "<!--[^>]*TOP-BEGIN.*-->"
                                          "<!--[^>]*TOP-END.*-->" t)))


              (goto-char 0)
              (setq range (search-block "<!--[^>]*BOTTOM-BEGIN.*-->"
                                        "<!--[^>]*BOTTOM-END.*-->" t))
              (while range
                (setq save t)
                (delete-region (car range) (cdr range))
                (insert (generate-html-bottom labe curr lang))
                (setq range (search-block "<!--[^>]*BOTTOM-BEGIN.*-->"
                                          "<!--[^>]*BOTTOM-END.*-->" t)))


              (goto-char 0)
              (setq range (search-block "<!--[^>]*EMAIL-BEGIN.*-->"
                                        "<!--[^>]*EMAIL-END.*-->" t))
              (while range
                (setq save t)
                (delete-region (car range) (cdr range))
                (insert (generate-html-email))
                (setq range (search-block "<!--[^>]*EMAIL-BEGIN.*-->"
                                          "<!--[^>]*EMAIL-END.*-->" t)))

              (when save
                (save-buffer nil))
              (kill-buffer buffer)))
        (message "")))))


;; (setq nodes-dir "/home/pascal/public_html/informatimago")
(defun html-update-main ()
  (message (format "Working directory is %S" nodes-dir))
  (setq tree (first (tree-children (etree-to-tree (enode-to-etree (list "." nodes))))))
  (tree-walk-depth tree  'process-html-node)
  (generate-table-of-content-page tree "toc.html"))

(html-update-main)

;; (setq nodes-dir "/home/pjb/public_html/sites/com.informatimago.www/")




;; (html-update-main)

;; (tree-walk-depth
;;  tree
;;  (lambda  (node parent depth path)
;;    (let ((level (make-string (* 2 depth) (character " "))))
;;      (insert (format "\n%snode=%s\n%sparent=%s\n%spath=%s\n\n"
;;                level (tree-label node)
;;                level (and parent (tree-label parent))
;;                level path)))))

;; (tree-walk-depth
;;  (make-tree :label "/"
;;             :children (list (etree-to-tree (enode-to-etree nodes))))
;;  (lambda (tree parent depth path)
;;    (insert(format "%s %S -- %S --%S\n"
;;             (make-string (* 3 depth) ?-)
;;             (tree-label tree)
;;             (and parent (tree-label parent))
;;             path))))


;; (tree-walk-depth
;;  (etree-to-tree (enode-to-etree nodes))
;;  (lambda (tree parent depth path)
;;    (insert(format "%s %S -- %S --%S\n"
;;             (make-string (* 3 depth) ?-)
;;             (tree-label tree)
;;             (and parent (tree-label parent))
;;             path))))


;; (show (setq etree (enode-to-etree nodes))
;;       (eq (aref etree 0)(aref etree 1))
;;       (let ((etree (enode-to-etree nodes)))
;;         (path-list-to-page-list (etree-flatten-paths etree) etree)))
;; (show (setq pages (path-list-to-page-list(etree-flatten-paths etree) etree)))
;; (show (etree-children (first (etree-children (enode-to-etree nodes)))))
;; (show (enode-to-etree nodes) (etree-flatten (enode-to-etree nodes)))


;(message (format "From %S" (buffer-file-name (current-buffer))))
;(not (file-readable-p "lamanga/05_est.fr.html"))
;(insert  (html-generate-downloads 'fr mirrors (assoc 'Abalone downloads)))

(defun pjb-html-insert-top ()
  (interactive)
  (insert "<!--TOP-BEGIN-->
<!--TOP-END-->
<!--MENU-BEGIN-->
<!--MENU-END-->
"))


(defun pjb-html-insert-bottom ()
  (interactive)
  (insert "
<!--MENU-BEGIN-->
<!--MENU-END-->
<!--BOTTOM-BEGIN-->
<!--BOTTOM-END-->
"))


;;;; THE END ;;;;
ViewGit