emacs/nxhtml/nxhtml/html-site.el

   1 ;;; html-site.el --- Keeping (X)HTML files together
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: Wed Mar 01 17:25:52 2006
   5 (defconst html-site:version "0.3");; Version:
   6 ;; Last-Updated: 2008-03-22T03:32:06+0100 Sat
   7 ;; Keywords:
   8 ;; Compatibility:
   9 ;;
  10 ;; Features that might be required by this library:
  11 ;;
  12 ;;   `cl', `html-site', `html-upl', `ietf-drums', `mail-parse',
  13 ;;   `mail-prsvr', `mailcap', `mm-util', `qp', `rfc2045', `rfc2047',
  14 ;;   `rfc2231', `time-date', `timer', `timezone', `tls', `url',
  15 ;;   `url-auth', `url-c', `url-cookie', `url-expand', `url-gw',
  16 ;;   `url-history', `url-http', `url-methods', `url-parse',
  17 ;;   `url-privacy', `url-proxy', `url-util', `url-vars'.
  18 ;;
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20 ;;
  21 ;;; Commentary:
  22 ;;
  23 ;;
  24 ;;
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;;
  27 ;;; Change log:
  28 ;;
  29 ;;
  30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31 ;;
  32 ;; This program is free software; you can redistribute it and/or modify
  33 ;; it under the terms of the GNU General Public License as published by
  34 ;; the Free Software Foundation; either version 2, or (at your option)
  35 ;; any later version.
  36 ;;
  37 ;; This program is distributed in the hope that it will be useful,
  38 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  39 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  40 ;; GNU General Public License for more details.
  41 ;;
  42 ;; You should have received a copy of the GNU General Public License
  43 ;; along with this program; see the file COPYING.  If not, write to the
  44 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  45 ;; Boston, MA 02111-1307, USA.
  46 ;;
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48 ;;
  49 ;;; Code:
  50
  51 ;; TODO: maybe use browse-url-filename-alist
  52
  53 (eval-when-compile (require 'cl))
  54 (eval-when-compile (require 'compile))
  55 (eval-when-compile (require 'dired))
  56 (eval-when-compile (require 'ffip nil t))
  57 (eval-when-compile (require 'grep))
  58 (eval-when-compile (require 'ourcomments-util nil t))
  59 (eval-when-compile (require 'url-parse))
  60 ;;(defvar html-site-list) ;; Silence compiler
  61 ;;(defvar html-site-current) ;; Silence compiler
  62
  63 ;;;###autoload
  64 (defgroup html-site nil
  65   "Customization group for html-site."
  66   :group 'nxhtml)
  67
  68 ;; Fix-me: Rewrite using directory variables
  69 (defcustom html-site-list nil
  70   "Known site directories and corresponding attributes.
  71 Each element in the list is a list containing:
  72
  73 * Name for the site.
  74 * Site root directory.
  75 * Page list file - Pages for table of contents (TOC). Usually
  76   initially built from the site directory by
  77   `html-toc-create-pages-file'.
  78 * Frames file.
  79 * TOC file for the frames file.
  80 * Output directory - where to put the merged TOC and site
  81   pages.
  82 * Output template file - html template for merging. See `html-wtoc-dir'
  83   for examples.
  84 * Function for additional tasks - for example copying images, style
  85   sheets, scripts etc.
  86 --
  87 "
  88   :type '(repeat
  89           (list
  90            (string :tag "*** Site name ***")
  91            (directory :tag "Site root directory")
  92            (file :tag "Page list file")
  93            (file :tag "Frames file")
  94            (file :tag "Contents file for frames")
  95            (directory :tag "Output directory for pages with TOC" :help-echo "Where to put the merged files")
  96            (file :tag "Template file for pages with TOC" :help-echo "HTML template for merging")
  97            (choice :tag "Extra function for pages with TOC"
  98                    (const nil :tag "Default function")
  99                    (function)
 100                    )
 101            (string :tag "Ftp host address")
 102            (string :tag "Ftp user")
 103            (string :tag "Ftp password")
 104            (string :tag "Ftp directory root")
 105            (string :tag "Ftp directory root for pages with TOC")
 106            (string :tag "Web host address")
 107            (string :tag "Web directory root")
 108            (string :tag "Web directory root for pages with TOC")
 109            ))
 110   :set (lambda (symbol value)
 111          ;;(message "sym=%s, value=%s" symbol value)
 112          (set-default symbol value)
 113          (when (featurep 'html-site)
 114            (let ((ok t))
 115              (dolist (e value)
 116                (let (
 117                      (name     (elt e 0))
 118                      (site-dir (elt e 1))
 119                      (pag-file (elt e 2))
 120                      (frm-file (elt e 3))
 121                      (toc-file (elt e 4))
 122                      (out-dir  (elt e 5))
 123                      (tpl-file (elt e 6))
 124                      (fun      (elt e 7))
 125                      (ftp-host (elt e 8))
 126                      (ftp-user (elt e 9))
 127                      (ftp-pw   (elt e 10))
 128                      (ftp-dir  (elt e 11))
 129                      (ftp-wtoc-dir (elt e 12))
 130                      (web-host (elt e 13))
 131                      (web-dir  (elt e 14))
 132                      (web-wtoc-dir (elt e 15))
 133                      )
 134                  (unless (not (string= "" name))
 135                    (html-site-lwarn '(html-site-list) :error "Empty site name"))
 136                  (if (not (file-directory-p site-dir))
 137                      (progn
 138                        (html-site-lwarn '(html-site-list) :error "Site directory for %s not found: %s" name site-dir)
 139                        (setq ok nil))
 140                    (unless (file-exists-p pag-file)
 141                      (html-site-lwarn '(html-site-list) :warning "Pages list file for %s does not exist: %s" name pag-file))
 142                    (unless (file-exists-p tpl-file)
 143                      (html-site-lwarn '(html-site-list) :warning "Template file for %s does not exist: %s" name tpl-file)))
 144                  (when (< 0 (length out-dir))
 145                    (html-site-chk-wtocdir out-dir site-dir))
 146                  (when fun
 147                    (unless (functionp fun)
 148                      (html-site-lwarn '(html-site-list) :error "Site %s - Unknown function: %s" name fun)
 149                      (setq ok nil)
 150                      ))
 151                  ))
 152              )))
 153   :group 'html-site)
 154
 155 (defcustom html-site-current ""
 156   "Current site name.
 157 Use the entry with this name in `html-site-list'."
 158   :set (lambda (symbol value)
 159          ;;(message "sym=%s, value=%s" symbol value)
 160          (set-default symbol value)
 161          (when (featurep 'html-site)
 162            (or (when (= 0 (length value))
 163                  (message "html-site-current (information): No current site set"))
 164                (let ((site-names))
 165                  (dolist (m html-site-list)
 166                    (setq site-names (cons (elt m 0) site-names)))
 167                  (or
 168                   (unless (member value site-names)
 169                     (html-site-lwarn '(html-site-current) :error "Can't find site: %s" value))
 170                   (let ((site-dir (html-site-site-dir value)))
 171                     (unless (file-directory-p site-dir)
 172                       (html-site-lwarn '(html-site-current) :error "Can't find site directory: %s" value))))))))
 173   :type 'string
 174   :set-after '(html-site-list)
 175   :group 'html-site)
 176
 177 (defun html-site-looks-like-local-url (file)
 178   "Return t if this looks like a local file something url."
 179   (require 'url-parse)
 180   (let ((url-type (url-type (url-generic-parse-url file))))
 181     (not
 182      (and url-type
 183           ;; Test if it really is an url, the is 1 for w32 drive
 184           ;; letters
 185           (or (not (memq system-type '(ms-dos windows-nt)))
 186               (< 1 (length url-type)))))))
 187
 188 (when nil
 189   (assert (not (html-site-looks-like-local-url "http://www.some.where/")))
 190   (assert (html-site-looks-like-local-url "/unix/file"))
 191   (when (memq system-type '(windows-nt))
 192     (assert (html-site-looks-like-local-url "c:/w32/file"))))
 193
 194 (defun html-site-dir-contains (dir file)
 195   ;;(when (= ?~ (string-to-char file)) (setq file (expand-file-name file)))
 196   ;;
 197   ;; It is not possible to unconditionally expand the file name here
 198   ;; since url file names can be involved.
 199   ;; (url-type (url-generic-parse-url "c:/some/file.txt"))
 200   (let* ((file-is-local (html-site-looks-like-local-url file))
 201          (dir-is-local  (html-site-looks-like-local-url dir))
 202          (file-is-dir (and file-is-local
 203                            (file-directory-p file)))
 204          (true-f (if file-is-local
 205                      (if file-is-dir
 206                          (file-name-as-directory
 207                           (file-truename
 208                            (expand-file-name file)))
 209                        (file-truename
 210                         (expand-file-name file)))
 211                    file))
 212          ;; (file-name-as-directory (expand-file-name "~/"))
 213          (true-d (if dir-is-local
 214                      (file-name-as-directory
 215                       (file-truename
 216                        (expand-file-name dir)))
 217                    (if (eq ?/ (car (reverse (append dir nil))))
 218                        dir
 219                      (concat dir "/")))))
 220     (assert (eq file-is-local dir-is-local))
 221     (if (< (length true-d) (length true-f))
 222         (string= true-d
 223                  (substring true-f 0 (length true-d)))
 224       (when file-is-dir
 225         (string= true-d true-f)))))
 226
 227 (defun html-site-lwarn (warn-type level format-string &rest args)
 228   (apply 'message (concat "%s:" format-string) warn-type args)
 229   (apply 'lwarn warn-type level args))
 230
 231 (defun html-site-chk-wtocdir (out-dir site-dir)
 232   (or
 233    (unless (file-name-absolute-p out-dir)
 234      (html-site-lwarn '(html-site) :error "Output directory is not absolute: %s" out-dir))
 235    (if (file-exists-p out-dir)
 236        (unless (file-directory-p out-dir)
 237          (html-site-lwarn '(html-site) :error "File %s for output exists but is not a directory" out-dir))
 238      (unless (string= out-dir (file-name-as-directory out-dir))
 239        (html-site-lwarn '(html-site) :error "File name could not be a directory: %s" out-dir)))
 240    (when (html-site-dir-contains out-dir site-dir)
 241      (html-site-lwarn '(html-site) :error "Ouput directory for pages with TOC must not contain site dir."))
 242    (when (html-site-dir-contains site-dir out-dir)
 243      (html-site-lwarn '(html-site) :error "Site dir must not contain ouput directory for pages with TOC."))))
 244
 245
 246 ;;;###autoload
 247 (defun html-site-buffer-or-dired-file-name ()
 248   "Return buffer file name or file pointed to in dired."
 249   (if (derived-mode-p 'dired-mode)
 250       (dired-get-file-for-visit)
 251     buffer-file-name))
 252
 253 ;;;###autoload
 254 (defun html-site-set-site (name)
 255   (interactive
 256    (let ((site-names)
 257          (must-contain (when (boundp 'must-contain) must-contain))
 258          (file (html-site-buffer-or-dired-file-name))
 259          (use-dialog-box nil))
 260      (unless (< 0 (length html-site-list))
 261        (error "No sites defined yet"))
 262      (when (and file
 263                 ;;(string-match "ml" (symbol-name major-mode))
 264                 )
 265        (when (or must-contain
 266                  (y-or-n-p "Should site contain current file? "))
 267          (setq must-contain file)))
 268      (dolist (m html-site-list)
 269        (let* ((name (elt m 0))
 270               (dir  (html-site-site-dir name)))
 271          (when (or (not must-contain)
 272                    (html-site-dir-contains dir file))
 273            (setq site-names (cons name site-names)))))
 274      (unless site-names
 275        (when must-contain
 276          (error "No sites contains %s" must-contain)))
 277      (list (when site-names
 278              (let ((prompt (if (< 0 (length html-site-current))
 279                                (concat "Current site is \""
 280                                        html-site-current
 281                                        "\". "
 282                                        (if must-contain
 283                                            "New site containing file: "
 284                                          "New site's name: "))
 285                              (if must-contain
 286                                  "Site containing file: "
 287                                "Site name: "))))
 288                (completing-read prompt site-names nil t nil 'site-names))))))
 289   (unless (or (string= name "")
 290               (string= name html-site-current))
 291     (setq html-site-current name)
 292     (customize-save-variable 'html-site-current html-site-current)))
 293
 294 ;;;###autoload
 295 (defun html-site-dired-current ()
 296   "Open `dired' in current site top directory."
 297   (interactive)
 298   (dired (html-site-current-site-dir)))
 299
 300 ;;;###autoload
 301 (defun html-site-find-file ()
 302   "Find file in current site."
 303   (interactive)
 304   ;;(require 'ffip)
 305   (ffip-set-current-project html-site-current
 306                             (html-site-current-site-dir)
 307                             'nxhtml)
 308   (call-interactively 'ffip-find-file-in-project))
 309
 310 ;;;###autoload
 311 (defun html-site-rgrep (regexp files)
 312   "Search current site's files with `rgrep'.
 313 See `rgrep' for the arguments REGEXP and FILES."
 314   (interactive
 315    (progn
 316      (grep-compute-defaults)
 317      (let* ((regexp (grep-read-regexp))
 318             (files (grep-read-files regexp)))
 319        (list regexp files))))
 320   ;; fix-me: ask for site
 321   ;;(when (called-interactively-p) )
 322   (rgrep regexp files (html-site-current-site-dir)))
 323
 324 ;;;###autoload
 325 (defun html-site-query-replace (from to file-regexp delimited)
 326   "Query replace in current site's files."
 327   (interactive
 328    (let ((parameters (dir-replace-read-parameters t t)))
 329      ;; Delete element 3
 330      ;;(length parameters)
 331      (setcdr (nthcdr 2 parameters) (nthcdr 4 parameters))
 332      ;;(length parameters)
 333      parameters))
 334   ;; fix-me: ask for site
 335   ;;(when (called-interactively-p) )
 336   (rdir-query-replace from to file-regexp
 337                       ;;root
 338                       (html-site-current-site-dir)
 339                       delimited)
 340   )
 341
 342 (defun html-site-ensure-site-defined (site-name)
 343   (unless html-site-list
 344     (error "No sites defined. Please customize `html-site-list'."))
 345   (unless (file-directory-p (html-site-site-dir site-name))
 346     (error "Local file web site directory does not exists: %s"
 347            (html-site-site-dir site-name))))
 348 (defun html-site-current-ensure-site-defined ()
 349   (unless (and (< 0 (length html-site-current))
 350                (assoc html-site-current html-site-list))
 351     (error "No current site set"))
 352   (html-site-ensure-site-defined html-site-current))
 353
 354 (defun html-site-remote-contains (site-name url with-toc)
 355   (html-site-dir-contains (html-site-remote-root site-name with-toc) url))
 356 (defun html-site-current-remote-contains (url with-toc)
 357   (html-site-remote-contains html-site-current url with-toc))
 358
 359 (defun html-site-ensure-file-in-site (site-name file-name &optional no-error)
 360   (html-site-ensure-site-defined site-name)
 361   (if (html-site-contains site-name file-name)
 362       t
 363     (if no-error
 364         nil
 365     (error "This file is not in site %s" site-name))))
 366 (defun html-site-current-ensure-file-in-site (file-name)
 367   ;;(html-site-ensure-file-in-site html-site-current file-name))
 368   (let ((in-site (html-site-ensure-file-in-site html-site-current
 369                                                 file-name t)))
 370     (while (not in-site)
 371       (if (not (y-or-n-p
 372                 (format "This file is not in site %s, change site? "
 373                         html-site-current)))
 374           (error "This file is not in site %s" html-site-current)
 375         (let ((must-contain t))
 376           (call-interactively 'html-site-set-site))
 377         (setq in-site (html-site-ensure-file-in-site html-site-current
 378                                                      file-name t))))))
 379
 380 (defun html-site-ensure-buffer-in-site (site-name)
 381   (unless buffer-file-name
 382     (error "This buffer is not visiting a file"))
 383   (html-site-ensure-file-in-site site-name buffer-file-name))
 384 (defun html-site-current-ensure-buffer-in-site ()
 385   (html-site-ensure-buffer-in-site html-site-current))
 386
 387
 388 (defun html-site-site-dir (site-name)
 389   (file-name-as-directory
 390    (nth 1 (assoc site-name html-site-list))))
 391 (defun html-site-current-site-dir () (html-site-site-dir html-site-current))
 392
 393 (defun html-site-contains (site-name file)
 394   (html-site-dir-contains (html-site-site-dir site-name) file))
 395 (defun html-site-current-contains (file)
 396   (html-site-contains html-site-current file))
 397
 398 (defun html-site-page-list (site-name)
 399   (let ((page-list (nth 2 (assoc site-name html-site-list))))
 400     (when (< 0 (length page-list))
 401       page-list)))
 402
 403 (defun html-site-current-page-list () (html-site-page-list html-site-current))
 404
 405 (defun html-site-frames-file (site-name)
 406   (nth 3 (assoc site-name html-site-list)))
 407 (defun html-site-current-frames-file () (html-site-frames-file html-site-current))
 408
 409 (defun html-site-toc-file (site-name)
 410   (nth 4 (assoc site-name html-site-list)))
 411 (defun html-site-current-toc-file () (html-site-toc-file html-site-current))
 412
 413 (defun html-site-merge-dir (site-name)
 414   (let ((dir (nth 5 (assoc site-name html-site-list))))
 415     (when (< 0 (length dir))
 416       dir)))
 417 (defun html-site-current-merge-dir () (html-site-merge-dir html-site-current))
 418
 419 (defun html-site-merge-template (site-name)
 420   (nth 6 (assoc site-name html-site-list)))
 421 (defun html-site-current-merge-template () (html-site-merge-template html-site-current))
 422
 423 (defun html-site-extra-fun (site-name)
 424   (nth 7 (assoc site-name html-site-list)))
 425 (defun html-site-current-extra-fun () (html-site-extra-fun html-site-current))
 426
 427 (defun html-site-ftp-host (site-name)
 428   (nth 8 (assoc site-name html-site-list)))
 429 (defun html-site-current-ftp-host () (html-site-ftp-host html-site-current))
 430
 431 (defun html-site-ftp-user (site-name)
 432   (nth 9 (assoc site-name html-site-list)))
 433 (defun html-site-current-ftp-user () (html-site-ftp-user html-site-current))
 434
 435 (defun html-site-ftp-password (site-name)
 436   (nth 10 (assoc site-name html-site-list)))
 437 (defun html-site-current-ftp-password () (html-site-ftp-password html-site-current))
 438
 439 (defun html-site-ftp-dir (site-name)
 440   (nth 11 (assoc site-name html-site-list)))
 441 (defun html-site-current-ftp-dir () (html-site-ftp-dir html-site-current))
 442
 443 (defun html-site-ftp-wtoc-dir (site-name)
 444   (nth 12 (assoc site-name html-site-list)))
 445 (defun html-site-current-ftp-wtoc-dir () (html-site-ftp-wtoc-dir html-site-current))
 446
 447 (defun html-site-web-host (site-name)
 448   (nth 13 (assoc site-name html-site-list)))
 449 (defun html-site-current-web-host () (html-site-web-host html-site-current))
 450
 451 (defun html-site-web-dir (site-name)
 452   (nth 14 (assoc site-name html-site-list)))
 453 (defun html-site-current-web-dir () (html-site-web-dir html-site-current))
 454
 455 (defun html-site-web-wtoc-dir (site-name)
 456   (nth 15 (assoc site-name html-site-list)))
 457 (defun html-site-current-web-wtoc-dir () (html-site-web-wtoc-dir html-site-current))
 458
 459 (defun html-site-web-full (site-name with-toc)
 460   (let ((host (html-site-web-host site-name)))
 461     (unless (and host
 462                  (< 0 (length host)))
 463       (error "Web site host not known for %s" site-name))
 464     (save-match-data
 465       (unless (string-match "^https?://" host)
 466         (setq host (concat "http://" host))))
 467     (concat host
 468             (if with-toc
 469                 (html-site-web-wtoc-dir site-name)
 470               (html-site-web-dir site-name)))))
 471 (defun html-site-current-web-full (with-toc)
 472   (html-site-web-full html-site-current with-toc))
 473
 474 (defvar html-site-ftp-temporary-passwords nil)
 475 (defun html-site-get-ftp-pw ()
 476   (let ((pw (html-site-current-ftp-password)))
 477     (unless (< 0 (length pw))
 478       (let* ((user-site (concat (html-site-current-ftp-user)
 479                                 "@"
 480                                 (html-site-current-ftp-host)))
 481              (site-pw (assoc user-site html-site-ftp-temporary-passwords)))
 482         (if site-pw
 483             (setq pw (cdr site-pw))
 484           (setq pw (read-string
 485                     (concat "Ftp password for "
 486                             (html-site-current-ftp-user)
 487                             " at "
 488                             (html-site-current-ftp-host)
 489                             " : ")))
 490           (setq html-site-ftp-temporary-passwords
 491                 (cons
 492                  (cons user-site pw)
 493                  html-site-ftp-temporary-passwords)))))
 494     pw))
 495
 496
 497
 498
 499
 500 (defun html-site-path-in-mirror (site-root path-in-site mirror-root)
 501   (assert (html-site-dir-contains site-root path-in-site) t)
 502   (let ((rel-path (file-relative-name path-in-site site-root)))
 503     (if (string= rel-path ".")
 504         (directory-file-name mirror-root)
 505       (concat (file-name-as-directory mirror-root) rel-path))))
 506
 507 ;; Some checks to see if html-site-path-in-mirror works:
 508 (when nil
 509   (require 'cl)
 510   ;; Try to make a non-existent directory name to work around Emacs
 511   ;; bug (which was fixed today in CVS):
 512   (let ((local-file "/temp814354/in/hej.html")
 513         (local-dir  "/temp814354"))
 514     (when (memq system-type '(ms-dos windows-nt))
 515       (setq local-file (concat "c:" local-file))
 516       (setq local-dir  (concat "c:" local-dir )))
 517     (assert (string=
 518              "http://some.site/tempmirror/in/hej.html"
 519              (html-site-path-in-mirror local-dir
 520                                        local-file
 521                                        "http://some.site/tempmirror"))
 522             t)
 523     (assert (string=
 524              local-file
 525              (html-site-path-in-mirror "http://some.site/tempmirror"
 526                                        "http://some.site/tempmirror/in/hej.html"
 527                                        local-dir))
 528             t)
 529     (assert (string=
 530              "in/hej.html"
 531              (file-relative-name "http:/temp/in/hej.html" "http:/temp"))
 532             t)
 533     ))
 534
 535
 536 (defun html-site-local-to-web (site-name local-file with-toc)
 537   (html-site-ensure-file-in-site site-name local-file)
 538   (html-site-path-in-mirror (html-site-site-dir site-name)
 539                             local-file
 540                             (html-site-web-full site-name with-toc)))
 541 (defun html-site-current-local-to-web (local-file with-toc)
 542   (html-site-local-to-web html-site-current local-file with-toc))
 543
 544 (defun html-site-remote-root (site-name with-toc)
 545   (concat "/ftp:"
 546           (html-site-ftp-user site-name)
 547           "@" (html-site-ftp-host site-name)
 548           ":"
 549           (if with-toc
 550               (html-site-ftp-wtoc-dir site-name)
 551             (html-site-ftp-dir site-name))))
 552 (defun html-site-current-remote-root (with-toc)
 553   (html-site-remote-root html-site-current with-toc))
 554
 555 (defun html-site-local-to-remote (site-name local-file with-toc)
 556   (html-site-ensure-file-in-site site-name local-file)
 557   (html-site-path-in-mirror (html-site-site-dir site-name)
 558                             local-file
 559                             (html-site-remote-root site-name with-toc)))
 560 (defun html-site-current-local-to-remote (local-file with-toc)
 561   (html-site-local-to-remote html-site-current local-file with-toc))
 562
 563 (defun html-site-remote-to-local (site-name remote-file with-toc)
 564   ;;(html-site-ensure-file-in-site remote-file)
 565   ;; Fix-me above
 566   (html-site-path-in-mirror (html-site-remote-root site-name with-toc)
 567                             remote-file
 568                             (html-site-site-dir site-name)))
 569 (defun html-site-current-remote-to-local (remote-file with-toc)
 570   (html-site-remote-to-local html-site-current remote-file with-toc))
 571
 572
 573 (defvar html-site-files-re "\.x?html?$")
 574
 575 (defun html-site-edit-pages-file ()
 576   "Edit the list of pages to be used for table of contents."
 577   (interactive)
 578   (html-site-current-ensure-site-defined)
 579   (find-file (html-site-current-page-list))
 580   )
 581
 582 (defun html-site-get-sub-files (dir file-patt)
 583   (let ((sub-files)
 584         (sub-dirs)
 585         (dir-files (directory-files dir t "^[^.]")))
 586     (dolist (f dir-files)
 587       (if (file-directory-p f)
 588           (add-to-list 'sub-dirs f)
 589         (when (string-match file-patt f)
 590           (add-to-list 'sub-files f))))
 591     (dolist (sub-dir sub-dirs)
 592       (setq sub-files (append sub-files (html-site-get-sub-files sub-dir file-patt)))
 593       )
 594     sub-files))
 595
 596 (defun html-site-file-is-local (filename)
 597   "Return t if FILENAME is a local file name.
 598 No check is done that the file exists."
 599   ;;(find-file-name-handler "/ftp:c:/eclean/" 'file-exists-p)
 600   (null (find-file-name-handler filename 'file-exists-p)))
 601
 602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 603 ;;; Put subprocess here at the moment ...
 604
 605 (defconst noshell-procbuf-name "*Noshell process buffer*")
 606
 607 (defvar noshell-proc-name nil)
 608 (defun noshell-procbuf-setup (procbuf-name)
 609   (unless procbuf-name
 610     (setq procbuf-name noshell-procbuf-name))
 611   (with-current-buffer (get-buffer-create procbuf-name)
 612     (unless (get-buffer-window (current-buffer))
 613       (when (one-window-p) (split-window))
 614       (let ((cb (current-buffer)))
 615         (set-window-buffer (other-window 1) cb)))
 616     ;;(setq buffer-read-only t)
 617     (noshell-process-mode)
 618     (compilation-minor-mode 1)
 619 ;;     (let ((inhibit-read-only t)
 620 ;;           (output-buffer (current-buffer)))
 621 ;;       (goto-char (point-max))
 622 ;;       (setq noshell-proc-name name)
 623 ;;       (let ((s (concat
 624 ;;                 "\n\n\n>>>>>>>>>>>>>>>>>> Starting "
 625 ;;                 noshell-proc-name "\n")))
 626 ;;         (put-text-property 0 (length s)
 627 ;;                            'face (list 'bold '(:foreground "green"))
 628 ;;                            s)
 629 ;;         (insert s)))
 630     (sit-for 0.01) ;; Display update
 631     (current-buffer)))
 632
 633 (defun noshell-procbuf-teardown (proc)
 634     (with-current-buffer (process-buffer proc)
 635       (goto-char (point-max))
 636       (let ((inhibit-read-only t)
 637             (s (concat
 638                 "<<<<<<<<<<<<<<<<<<< Finished OK: "
 639                 noshell-proc-name "\n")))
 640         (put-text-property 0 (length s)
 641                            'face (list 'bold '(:foreground "green"))
 642                            s)
 643         (insert s))))
 644
 645 (defun noshell-procbuf-run (buffer prog &rest args)
 646   (with-current-buffer buffer
 647     (let ((inhibit-read-only t)
 648           (proc nil)
 649           )
 650       (unwind-protect
 651           (progn
 652             (setq proc (apply 'start-process "myproc" (current-buffer) prog args))
 653             )
 654         )
 655       (save-excursion
 656         (unless proc
 657           (let ((s "\n\n<<<<<<<<<<<<< There was a process starting error!"))
 658             (put-text-property 0 (length s)
 659                                'face (list 'bold '(:foreground "red"))
 660                                s)
 661             (insert s))
 662           (error "Subprocess terminated with error status")))
 663       (set-process-sentinel proc 'noshell-sentinel)
 664       proc)
 665     )
 666   )
 667 (defun noshell-sentinel (process event)
 668   (with-current-buffer (process-buffer process)
 669     (let ((inhibit-read-only t))
 670       ;;(insert (format "Process: %s recieved %s\n" process event))
 671       (cond ((string-match "abnormally" event)
 672              (let ((s (concat "\n<<<<<< Error: "
 673                               (substring event 0 -1)
 674                               " <<<<<<<<<")))
 675                (put-text-property 0 (length s)
 676                                   'face (list 'bold '(:foreground "red"))
 677                                   s)
 678                (insert s)))
 679             ((string-match "finished" event)
 680              (noshell-procbuf-teardown process))
 681             (t
 682              (insert event))))))
 683
 684 (defun noshell-procbuf-syncrun (prog &rest args)
 685   (with-current-buffer (get-buffer noshell-procbuf-name)
 686     (let ((inhibit-read-only t)
 687           (sts nil))
 688       (unwind-protect
 689           (progn
 690             ;;(setq sts (apply 'call-process prog nil (current-buffer) t args))
 691             (setq sts (apply 'call-process prog nil (list (current-buffer) t) t args))
 692             )
 693         )
 694       (save-excursion
 695         (unless (= 0 sts)
 696           (let ((s (format "\n\n<<<<<<<<<<<<< There was a process error: %s" sts)))
 697             (put-text-property 0 (length s)
 698                                'face (list 'bold '(:foreground "red"))
 699                                s)
 700             (insert s))
 701           (error "Subprocess terminated with error status")))
 702       )
 703     )
 704   )
 705
 706 (defvar noshell-process-mode-map
 707   (let ((map (make-sparse-keymap)))
 708     (define-key map [(control ?c)(control ?k)] 'noshell-kill-subprocess)
 709     (define-key map [(control ?g)] 'noshell-quit)
 710     map))
 711
 712 (define-derived-mode noshell-process-mode fundamental-mode "Subprocess"
 713   nil
 714   (setq buffer-read-only t)
 715   (buffer-disable-undo (current-buffer)))
 716
 717 (defun noshell-quit ()
 718   (interactive)
 719   (noshell-kill-subprocess)
 720   (keyboard-quit))
 721
 722 (defun noshell-kill-subprocess ()
 723   (interactive)
 724   (when (eq major-mode 'noshell-process-mode)
 725     (if (get-buffer-process (current-buffer))
 726         (interrupt-process (get-buffer-process (current-buffer)))
 727       (error "The subprocess is not running"))))
 728
 729
 730
 731 ;; Provide here to be able to load the files in any order
 732 (provide 'html-site)
 733
 734 (eval-when-compile (require 'html-upl nil t))
 735
 736 (defvar html-site-mode-menu-map
 737   (let ((map (make-sparse-keymap "html-site-mode-menu-map")))
 738
 739     (when (featurep 'html-upl)
 740       (let ((upl-map (make-sparse-keymap)))
 741         (define-key map [html-site-upl-map]
 742           (list 'menu-item "File Transfer" upl-map))
 743         ;;(define-key upl-map [html-site-upl-edit-remote-wtoc]
 744         ;;  (list 'menu-item "Edit Remote File With TOC" 'html-upl-edit-remote-file-with-toc))
 745         (define-key upl-map [html-site-upl-edit-remote]
 746           (list 'menu-item "Edit Remote File" 'html-upl-edit-remote-file))
 747         (define-key upl-map [html-site-upl-ediff-buffer]
 748           (list 'menu-item "Ediff Remote/Local Files" 'html-upl-ediff-file))
 749         (define-key upl-map [html-site-upl-sep] (list 'menu-item "--"))
 750         (define-key upl-map [html-site-upl-upload-site-with-toc]
 751           (list 'menu-item "Upload Site with TOC" 'html-upl-upload-site-with-toc))
 752         (define-key upl-map [html-site-upl-upload-site]
 753           (list 'menu-item "Upload Site" 'html-upl-upload-site))
 754         (define-key upl-map [html-site-upl-upload-file]
 755           (list 'menu-item "Upload Single File" 'html-upl-upload-file))
 756       ))
 757
 758     (let ((site-map (make-sparse-keymap)))
 759       (define-key map [html-site-site-map]
 760         (list 'menu-item "Site" site-map))
 761       (define-key site-map [html-site-customize-site-list]
 762         (list 'menu-item "Edit Sites" (lambda () (interactive)
 763                                         (customize-option 'html-site-list))))
 764       (define-key site-map [html-site-set-site]
 765         (list 'menu-item "Set Current Site" 'html-site-set-site))
 766       )
 767
 768     map))
 769
 770
 771 (defvar html-site-mode-map
 772   (let ((map (make-sparse-keymap )))
 773     (define-key map [menu-bar html-site-mode]
 774       (list 'menu-item "Web Site" html-site-mode-menu-map))
 775     map))
 776
 777 (define-minor-mode html-site-mode
 778   "Adds a menu for easy access of setting site, uploading etc."
 779   :init-value nil
 780   :lighter nil
 781   :keymap html-site-mode-map
 782   :group 'html-site)
 783
 784 (defvar html-site-mode-off-list
 785   '(nxhtml-mode))
 786
 787 (define-global-minor-mode html-site-global-mode html-site-mode
 788   (lambda ()
 789     (html-site-mode 1)
 790     (when t ;buffer-file-name
 791       (unless (memq major-mode html-site-mode-off-list)
 792         (html-site-mode 1))))
 793   :group 'html-site)
 794 ;; The problem with global minor modes:
 795 (when (and html-site-global-mode
 796            (not (boundp 'define-global-minor-mode-bug)))
 797   (html-site-global-mode 1))
 798
 799
 800 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 801 ;;; html-site.el ends here