diff options
Diffstat (limited to 'emacs.d/nxhtml/nxhtml/html-site.el')
| -rw-r--r-- | emacs.d/nxhtml/nxhtml/html-site.el | 801 |
1 files changed, 801 insertions, 0 deletions
diff --git a/emacs.d/nxhtml/nxhtml/html-site.el b/emacs.d/nxhtml/nxhtml/html-site.el new file mode 100644 index 0000000..64238fc --- /dev/null +++ b/emacs.d/nxhtml/nxhtml/html-site.el @@ -0,0 +1,801 @@ +;;; html-site.el --- Keeping (X)HTML files together +;; +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Created: Wed Mar 01 17:25:52 2006 +(defconst html-site:version "0.3");; Version: +;; Last-Updated: 2008-03-22T03:32:06+0100 Sat +;; Keywords: +;; Compatibility: +;; +;; Features that might be required by this library: +;; +;; `cl', `html-site', `html-upl', `ietf-drums', `mail-parse', +;; `mail-prsvr', `mailcap', `mm-util', `qp', `rfc2045', `rfc2047', +;; `rfc2231', `time-date', `timer', `timezone', `tls', `url', +;; `url-auth', `url-c', `url-cookie', `url-expand', `url-gw', +;; `url-history', `url-http', `url-methods', `url-parse', +;; `url-privacy', `url-proxy', `url-util', `url-vars'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +;; TODO: maybe use browse-url-filename-alist + +(eval-when-compile (require 'cl)) +(eval-when-compile (require 'compile)) +(eval-when-compile (require 'dired)) +(eval-when-compile (require 'ffip nil t)) +(eval-when-compile (require 'grep)) +(eval-when-compile (require 'ourcomments-util nil t)) +(eval-when-compile (require 'url-parse)) +;;(defvar html-site-list) ;; Silence compiler +;;(defvar html-site-current) ;; Silence compiler + +;;;###autoload +(defgroup html-site nil + "Customization group for html-site." + :group 'nxhtml) + +;; Fix-me: Rewrite using directory variables +(defcustom html-site-list nil + "Known site directories and corresponding attributes. +Each element in the list is a list containing: + +* Name for the site. +* Site root directory. +* Page list file - Pages for table of contents (TOC). Usually + initially built from the site directory by + `html-toc-create-pages-file'. +* Frames file. +* TOC file for the frames file. +* Output directory - where to put the merged TOC and site + pages. +* Output template file - html template for merging. See `html-wtoc-dir' + for examples. +* Function for additional tasks - for example copying images, style + sheets, scripts etc. +-- +" + :type '(repeat + (list + (string :tag "*** Site name ***") + (directory :tag "Site root directory") + (file :tag "Page list file") + (file :tag "Frames file") + (file :tag "Contents file for frames") + (directory :tag "Output directory for pages with TOC" :help-echo "Where to put the merged files") + (file :tag "Template file for pages with TOC" :help-echo "HTML template for merging") + (choice :tag "Extra function for pages with TOC" + (const nil :tag "Default function") + (function) + ) + (string :tag "Ftp host address") + (string :tag "Ftp user") + (string :tag "Ftp password") + (string :tag "Ftp directory root") + (string :tag "Ftp directory root for pages with TOC") + (string :tag "Web host address") + (string :tag "Web directory root") + (string :tag "Web directory root for pages with TOC") + )) + :set (lambda (symbol value) + ;;(message "sym=%s, value=%s" symbol value) + (set-default symbol value) + (when (featurep 'html-site) + (let ((ok t)) + (dolist (e value) + (let ( + (name (elt e 0)) + (site-dir (elt e 1)) + (pag-file (elt e 2)) + (frm-file (elt e 3)) + (toc-file (elt e 4)) + (out-dir (elt e 5)) + (tpl-file (elt e 6)) + (fun (elt e 7)) + (ftp-host (elt e 8)) + (ftp-user (elt e 9)) + (ftp-pw (elt e 10)) + (ftp-dir (elt e 11)) + (ftp-wtoc-dir (elt e 12)) + (web-host (elt e 13)) + (web-dir (elt e 14)) + (web-wtoc-dir (elt e 15)) + ) + (unless (not (string= "" name)) + (html-site-lwarn '(html-site-list) :error "Empty site name")) + (if (not (file-directory-p site-dir)) + (progn + (html-site-lwarn '(html-site-list) :error "Site directory for %s not found: %s" name site-dir) + (setq ok nil)) + (unless (file-exists-p pag-file) + (html-site-lwarn '(html-site-list) :warning "Pages list file for %s does not exist: %s" name pag-file)) + (unless (file-exists-p tpl-file) + (html-site-lwarn '(html-site-list) :warning "Template file for %s does not exist: %s" name tpl-file))) + (when (< 0 (length out-dir)) + (html-site-chk-wtocdir out-dir site-dir)) + (when fun + (unless (functionp fun) + (html-site-lwarn '(html-site-list) :error "Site %s - Unknown function: %s" name fun) + (setq ok nil) + )) + )) + ))) + :group 'html-site) + +(defcustom html-site-current "" + "Current site name. +Use the entry with this name in `html-site-list'." + :set (lambda (symbol value) + ;;(message "sym=%s, value=%s" symbol value) + (set-default symbol value) + (when (featurep 'html-site) + (or (when (= 0 (length value)) + (message "html-site-current (information): No current site set")) + (let ((site-names)) + (dolist (m html-site-list) + (setq site-names (cons (elt m 0) site-names))) + (or + (unless (member value site-names) + (html-site-lwarn '(html-site-current) :error "Can't find site: %s" value)) + (let ((site-dir (html-site-site-dir value))) + (unless (file-directory-p site-dir) + (html-site-lwarn '(html-site-current) :error "Can't find site directory: %s" value)))))))) + :type 'string + :set-after '(html-site-list) + :group 'html-site) + +(defun html-site-looks-like-local-url (file) + "Return t if this looks like a local file something url." + (require 'url-parse) + (let ((url-type (url-type (url-generic-parse-url file)))) + (not + (and url-type + ;; Test if it really is an url, the is 1 for w32 drive + ;; letters + (or (not (memq system-type '(ms-dos windows-nt))) + (< 1 (length url-type))))))) + +(when nil + (assert (not (html-site-looks-like-local-url "http://www.some.where/"))) + (assert (html-site-looks-like-local-url "/unix/file")) + (when (memq system-type '(windows-nt)) + (assert (html-site-looks-like-local-url "c:/w32/file")))) + +(defun html-site-dir-contains (dir file) + ;;(when (= ?~ (string-to-char file)) (setq file (expand-file-name file))) + ;; + ;; It is not possible to unconditionally expand the file name here + ;; since url file names can be involved. + ;; (url-type (url-generic-parse-url "c:/some/file.txt")) + (let* ((file-is-local (html-site-looks-like-local-url file)) + (dir-is-local (html-site-looks-like-local-url dir)) + (file-is-dir (and file-is-local + (file-directory-p file))) + (true-f (if file-is-local + (if file-is-dir + (file-name-as-directory + (file-truename + (expand-file-name file))) + (file-truename + (expand-file-name file))) + file)) + ;; (file-name-as-directory (expand-file-name "~/")) + (true-d (if dir-is-local + (file-name-as-directory + (file-truename + (expand-file-name dir))) + (if (eq ?/ (car (reverse (append dir nil)))) + dir + (concat dir "/"))))) + (assert (eq file-is-local dir-is-local)) + (if (< (length true-d) (length true-f)) + (string= true-d + (substring true-f 0 (length true-d))) + (when file-is-dir + (string= true-d true-f))))) + +(defun html-site-lwarn (warn-type level format-string &rest args) + (apply 'message (concat "%s:" format-string) warn-type args) + (apply 'lwarn warn-type level args)) + +(defun html-site-chk-wtocdir (out-dir site-dir) + (or + (unless (file-name-absolute-p out-dir) + (html-site-lwarn '(html-site) :error "Output directory is not absolute: %s" out-dir)) + (if (file-exists-p out-dir) + (unless (file-directory-p out-dir) + (html-site-lwarn '(html-site) :error "File %s for output exists but is not a directory" out-dir)) + (unless (string= out-dir (file-name-as-directory out-dir)) + (html-site-lwarn '(html-site) :error "File name could not be a directory: %s" out-dir))) + (when (html-site-dir-contains out-dir site-dir) + (html-site-lwarn '(html-site) :error "Ouput directory for pages with TOC must not contain site dir.")) + (when (html-site-dir-contains site-dir out-dir) + (html-site-lwarn '(html-site) :error "Site dir must not contain ouput directory for pages with TOC.")))) + + +;;;###autoload +(defun html-site-buffer-or-dired-file-name () + "Return buffer file name or file pointed to in dired." + (if (derived-mode-p 'dired-mode) + (dired-get-file-for-visit) + buffer-file-name)) + +;;;###autoload +(defun html-site-set-site (name) + (interactive + (let ((site-names) + (must-contain (when (boundp 'must-contain) must-contain)) + (file (html-site-buffer-or-dired-file-name)) + (use-dialog-box nil)) + (unless (< 0 (length html-site-list)) + (error "No sites defined yet")) + (when (and file + ;;(string-match "ml" (symbol-name major-mode)) + ) + (when (or must-contain + (y-or-n-p "Should site contain current file? ")) + (setq must-contain file))) + (dolist (m html-site-list) + (let* ((name (elt m 0)) + (dir (html-site-site-dir name))) + (when (or (not must-contain) + (html-site-dir-contains dir file)) + (setq site-names (cons name site-names))))) + (unless site-names + (when must-contain + (error "No sites contains %s" must-contain))) + (list (when site-names + (let ((prompt (if (< 0 (length html-site-current)) + (concat "Current site is \"" + html-site-current + "\". " + (if must-contain + "New site containing file: " + "New site's name: ")) + (if must-contain + "Site containing file: " + "Site name: ")))) + (completing-read prompt site-names nil t nil 'site-names)))))) + (unless (or (string= name "") + (string= name html-site-current)) + (setq html-site-current name) + (customize-save-variable 'html-site-current html-site-current))) + +;;;###autoload +(defun html-site-dired-current () + "Open `dired' in current site top directory." + (interactive) + (dired (html-site-current-site-dir))) + +;;;###autoload +(defun html-site-find-file () + "Find file in current site." + (interactive) + ;;(require 'ffip) + (ffip-set-current-project html-site-current + (html-site-current-site-dir) + 'nxhtml) + (call-interactively 'ffip-find-file-in-project)) + +;;;###autoload +(defun html-site-rgrep (regexp files) + "Search current site's files with `rgrep'. +See `rgrep' for the arguments REGEXP and FILES." + (interactive + (progn + (grep-compute-defaults) + (let* ((regexp (grep-read-regexp)) + (files (grep-read-files regexp))) + (list regexp files)))) + ;; fix-me: ask for site + ;;(when (called-interactively-p) ) + (rgrep regexp files (html-site-current-site-dir))) + +;;;###autoload +(defun html-site-query-replace (from to file-regexp delimited) + "Query replace in current site's files." + (interactive + (let ((parameters (dir-replace-read-parameters t t))) + ;; Delete element 3 + ;;(length parameters) + (setcdr (nthcdr 2 parameters) (nthcdr 4 parameters)) + ;;(length parameters) + parameters)) + ;; fix-me: ask for site + ;;(when (called-interactively-p) ) + (rdir-query-replace from to file-regexp + ;;root + (html-site-current-site-dir) + delimited) + ) + +(defun html-site-ensure-site-defined (site-name) + (unless html-site-list + (error "No sites defined. Please customize `html-site-list'.")) + (unless (file-directory-p (html-site-site-dir site-name)) + (error "Local file web site directory does not exists: %s" + (html-site-site-dir site-name)))) +(defun html-site-current-ensure-site-defined () + (unless (and (< 0 (length html-site-current)) + (assoc html-site-current html-site-list)) + (error "No current site set")) + (html-site-ensure-site-defined html-site-current)) + +(defun html-site-remote-contains (site-name url with-toc) + (html-site-dir-contains (html-site-remote-root site-name with-toc) url)) +(defun html-site-current-remote-contains (url with-toc) + (html-site-remote-contains html-site-current url with-toc)) + +(defun html-site-ensure-file-in-site (site-name file-name &optional no-error) + (html-site-ensure-site-defined site-name) + (if (html-site-contains site-name file-name) + t + (if no-error + nil + (error "This file is not in site %s" site-name)))) +(defun html-site-current-ensure-file-in-site (file-name) + ;;(html-site-ensure-file-in-site html-site-current file-name)) + (let ((in-site (html-site-ensure-file-in-site html-site-current + file-name t))) + (while (not in-site) + (if (not (y-or-n-p + (format "This file is not in site %s, change site? " + html-site-current))) + (error "This file is not in site %s" html-site-current) + (let ((must-contain t)) + (call-interactively 'html-site-set-site)) + (setq in-site (html-site-ensure-file-in-site html-site-current + file-name t)))))) + +(defun html-site-ensure-buffer-in-site (site-name) + (unless buffer-file-name + (error "This buffer is not visiting a file")) + (html-site-ensure-file-in-site site-name buffer-file-name)) +(defun html-site-current-ensure-buffer-in-site () + (html-site-ensure-buffer-in-site html-site-current)) + + +(defun html-site-site-dir (site-name) + (file-name-as-directory + (nth 1 (assoc site-name html-site-list)))) +(defun html-site-current-site-dir () (html-site-site-dir html-site-current)) + +(defun html-site-contains (site-name file) + (html-site-dir-contains (html-site-site-dir site-name) file)) +(defun html-site-current-contains (file) + (html-site-contains html-site-current file)) + +(defun html-site-page-list (site-name) + (let ((page-list (nth 2 (assoc site-name html-site-list)))) + (when (< 0 (length page-list)) + page-list))) + +(defun html-site-current-page-list () (html-site-page-list html-site-current)) + +(defun html-site-frames-file (site-name) + (nth 3 (assoc site-name html-site-list))) +(defun html-site-current-frames-file () (html-site-frames-file html-site-current)) + +(defun html-site-toc-file (site-name) + (nth 4 (assoc site-name html-site-list))) +(defun html-site-current-toc-file () (html-site-toc-file html-site-current)) + +(defun html-site-merge-dir (site-name) + (let ((dir (nth 5 (assoc site-name html-site-list)))) + (when (< 0 (length dir)) + dir))) +(defun html-site-current-merge-dir () (html-site-merge-dir html-site-current)) + +(defun html-site-merge-template (site-name) + (nth 6 (assoc site-name html-site-list))) +(defun html-site-current-merge-template () (html-site-merge-template html-site-current)) + +(defun html-site-extra-fun (site-name) + (nth 7 (assoc site-name html-site-list))) +(defun html-site-current-extra-fun () (html-site-extra-fun html-site-current)) + +(defun html-site-ftp-host (site-name) + (nth 8 (assoc site-name html-site-list))) +(defun html-site-current-ftp-host () (html-site-ftp-host html-site-current)) + +(defun html-site-ftp-user (site-name) + (nth 9 (assoc site-name html-site-list))) +(defun html-site-current-ftp-user () (html-site-ftp-user html-site-current)) + +(defun html-site-ftp-password (site-name) + (nth 10 (assoc site-name html-site-list))) +(defun html-site-current-ftp-password () (html-site-ftp-password html-site-current)) + +(defun html-site-ftp-dir (site-name) + (nth 11 (assoc site-name html-site-list))) +(defun html-site-current-ftp-dir () (html-site-ftp-dir html-site-current)) + +(defun html-site-ftp-wtoc-dir (site-name) + (nth 12 (assoc site-name html-site-list))) +(defun html-site-current-ftp-wtoc-dir () (html-site-ftp-wtoc-dir html-site-current)) + +(defun html-site-web-host (site-name) + (nth 13 (assoc site-name html-site-list))) +(defun html-site-current-web-host () (html-site-web-host html-site-current)) + +(defun html-site-web-dir (site-name) + (nth 14 (assoc site-name html-site-list))) +(defun html-site-current-web-dir () (html-site-web-dir html-site-current)) + +(defun html-site-web-wtoc-dir (site-name) + (nth 15 (assoc site-name html-site-list))) +(defun html-site-current-web-wtoc-dir () (html-site-web-wtoc-dir html-site-current)) + +(defun html-site-web-full (site-name with-toc) + (let ((host (html-site-web-host site-name))) + (unless (and host + (< 0 (length host))) + (error "Web site host not known for %s" site-name)) + (save-match-data + (unless (string-match "^https?://" host) + (setq host (concat "http://" host)))) + (concat host + (if with-toc + (html-site-web-wtoc-dir site-name) + (html-site-web-dir site-name))))) +(defun html-site-current-web-full (with-toc) + (html-site-web-full html-site-current with-toc)) + +(defvar html-site-ftp-temporary-passwords nil) +(defun html-site-get-ftp-pw () + (let ((pw (html-site-current-ftp-password))) + (unless (< 0 (length pw)) + (let* ((user-site (concat (html-site-current-ftp-user) + "@" + (html-site-current-ftp-host))) + (site-pw (assoc user-site html-site-ftp-temporary-passwords))) + (if site-pw + (setq pw (cdr site-pw)) + (setq pw (read-string + (concat "Ftp password for " + (html-site-current-ftp-user) + " at " + (html-site-current-ftp-host) + " : "))) + (setq html-site-ftp-temporary-passwords + (cons + (cons user-site pw) + html-site-ftp-temporary-passwords))))) + pw)) + + + + + +(defun html-site-path-in-mirror (site-root path-in-site mirror-root) + (assert (html-site-dir-contains site-root path-in-site) t) + (let ((rel-path (file-relative-name path-in-site site-root))) + (if (string= rel-path ".") + (directory-file-name mirror-root) + (concat (file-name-as-directory mirror-root) rel-path)))) + +;; Some checks to see if html-site-path-in-mirror works: +(when nil + (require 'cl) + ;; Try to make a non-existent directory name to work around Emacs + ;; bug (which was fixed today in CVS): + (let ((local-file "/temp814354/in/hej.html") + (local-dir "/temp814354")) + (when (memq system-type '(ms-dos windows-nt)) + (setq local-file (concat "c:" local-file)) + (setq local-dir (concat "c:" local-dir ))) + (assert (string= + "http://some.site/tempmirror/in/hej.html" + (html-site-path-in-mirror local-dir + local-file + "http://some.site/tempmirror")) + t) + (assert (string= + local-file + (html-site-path-in-mirror "http://some.site/tempmirror" + "http://some.site/tempmirror/in/hej.html" + local-dir)) + t) + (assert (string= + "in/hej.html" + (file-relative-name "http:/temp/in/hej.html" "http:/temp")) + t) + )) + + +(defun html-site-local-to-web (site-name local-file with-toc) + (html-site-ensure-file-in-site site-name local-file) + (html-site-path-in-mirror (html-site-site-dir site-name) + local-file + (html-site-web-full site-name with-toc))) +(defun html-site-current-local-to-web (local-file with-toc) + (html-site-local-to-web html-site-current local-file with-toc)) + +(defun html-site-remote-root (site-name with-toc) + (concat "/ftp:" + (html-site-ftp-user site-name) + "@" (html-site-ftp-host site-name) + ":" + (if with-toc + (html-site-ftp-wtoc-dir site-name) + (html-site-ftp-dir site-name)))) +(defun html-site-current-remote-root (with-toc) + (html-site-remote-root html-site-current with-toc)) + +(defun html-site-local-to-remote (site-name local-file with-toc) + (html-site-ensure-file-in-site site-name local-file) + (html-site-path-in-mirror (html-site-site-dir site-name) + local-file + (html-site-remote-root site-name with-toc))) +(defun html-site-current-local-to-remote (local-file with-toc) + (html-site-local-to-remote html-site-current local-file with-toc)) + +(defun html-site-remote-to-local (site-name remote-file with-toc) + ;;(html-site-ensure-file-in-site remote-file) + ;; Fix-me above + (html-site-path-in-mirror (html-site-remote-root site-name with-toc) + remote-file + (html-site-site-dir site-name))) +(defun html-site-current-remote-to-local (remote-file with-toc) + (html-site-remote-to-local html-site-current remote-file with-toc)) + + +(defvar html-site-files-re "\.x?html?$") + +(defun html-site-edit-pages-file () + "Edit the list of pages to be used for table of contents." + (interactive) + (html-site-current-ensure-site-defined) + (find-file (html-site-current-page-list)) + ) + +(defun html-site-get-sub-files (dir file-patt) + (let ((sub-files) + (sub-dirs) + (dir-files (directory-files dir t "^[^.]"))) + (dolist (f dir-files) + (if (file-directory-p f) + (add-to-list 'sub-dirs f) + (when (string-match file-patt f) + (add-to-list 'sub-files f)))) + (dolist (sub-dir sub-dirs) + (setq sub-files (append sub-files (html-site-get-sub-files sub-dir file-patt))) + ) + sub-files)) + +(defun html-site-file-is-local (filename) + "Return t if FILENAME is a local file name. +No check is done that the file exists." + ;;(find-file-name-handler "/ftp:c:/eclean/" 'file-exists-p) + (null (find-file-name-handler filename 'file-exists-p))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Put subprocess here at the moment ... + +(defconst noshell-procbuf-name "*Noshell process buffer*") + +(defvar noshell-proc-name nil) +(defun noshell-procbuf-setup (procbuf-name) + (unless procbuf-name + (setq procbuf-name noshell-procbuf-name)) + (with-current-buffer (get-buffer-create procbuf-name) + (unless (get-buffer-window (current-buffer)) + (when (one-window-p) (split-window)) + (let ((cb (current-buffer))) + (set-window-buffer (other-window 1) cb))) + ;;(setq buffer-read-only t) + (noshell-process-mode) + (compilation-minor-mode 1) +;; (let ((inhibit-read-only t) +;; (output-buffer (current-buffer))) +;; (goto-char (point-max)) +;; (setq noshell-proc-name name) +;; (let ((s (concat +;; "\n\n\n>>>>>>>>>>>>>>>>>> Starting " +;; noshell-proc-name "\n"))) +;; (put-text-property 0 (length s) +;; 'face (list 'bold '(:foreground "green")) +;; s) +;; (insert s))) + (sit-for 0.01) ;; Display update + (current-buffer))) + +(defun noshell-procbuf-teardown (proc) + (with-current-buffer (process-buffer proc) + (goto-char (point-max)) + (let ((inhibit-read-only t) + (s (concat + "<<<<<<<<<<<<<<<<<<< Finished OK: " + noshell-proc-name "\n"))) + (put-text-property 0 (length s) + 'face (list 'bold '(:foreground "green")) + s) + (insert s)))) + +(defun noshell-procbuf-run (buffer prog &rest args) + (with-current-buffer buffer + (let ((inhibit-read-only t) + (proc nil) + ) + (unwind-protect + (progn + (setq proc (apply 'start-process "myproc" (current-buffer) prog args)) + ) + ) + (save-excursion + (unless proc + (let ((s "\n\n<<<<<<<<<<<<< There was a process starting error!")) + (put-text-property 0 (length s) + 'face (list 'bold '(:foreground "red")) + s) + (insert s)) + (error "Subprocess terminated with error status"))) + (set-process-sentinel proc 'noshell-sentinel) + proc) + ) + ) +(defun noshell-sentinel (process event) + (with-current-buffer (process-buffer process) + (let ((inhibit-read-only t)) + ;;(insert (format "Process: %s recieved %s\n" process event)) + (cond ((string-match "abnormally" event) + (let ((s (concat "\n<<<<<< Error: " + (substring event 0 -1) + " <<<<<<<<<"))) + (put-text-property 0 (length s) + 'face (list 'bold '(:foreground "red")) + s) + (insert s))) + ((string-match "finished" event) + (noshell-procbuf-teardown process)) + (t + (insert event)))))) + +(defun noshell-procbuf-syncrun (prog &rest args) + (with-current-buffer (get-buffer noshell-procbuf-name) + (let ((inhibit-read-only t) + (sts nil)) + (unwind-protect + (progn + ;;(setq sts (apply 'call-process prog nil (current-buffer) t args)) + (setq sts (apply 'call-process prog nil (list (current-buffer) t) t args)) + ) + ) + (save-excursion + (unless (= 0 sts) + (let ((s (format "\n\n<<<<<<<<<<<<< There was a process error: %s" sts))) + (put-text-property 0 (length s) + 'face (list 'bold '(:foreground "red")) + s) + (insert s)) + (error "Subprocess terminated with error status"))) + ) + ) + ) + +(defvar noshell-process-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?c)(control ?k)] 'noshell-kill-subprocess) + (define-key map [(control ?g)] 'noshell-quit) + map)) + +(define-derived-mode noshell-process-mode fundamental-mode "Subprocess" + nil + (setq buffer-read-only t) + (buffer-disable-undo (current-buffer))) + +(defun noshell-quit () + (interactive) + (noshell-kill-subprocess) + (keyboard-quit)) + +(defun noshell-kill-subprocess () + (interactive) + (when (eq major-mode 'noshell-process-mode) + (if (get-buffer-process (current-buffer)) + (interrupt-process (get-buffer-process (current-buffer))) + (error "The subprocess is not running")))) + + + +;; Provide here to be able to load the files in any order +(provide 'html-site) + +(eval-when-compile (require 'html-upl nil t)) + +(defvar html-site-mode-menu-map + (let ((map (make-sparse-keymap "html-site-mode-menu-map"))) + + (when (featurep 'html-upl) + (let ((upl-map (make-sparse-keymap))) + (define-key map [html-site-upl-map] + (list 'menu-item "File Transfer" upl-map)) + ;;(define-key upl-map [html-site-upl-edit-remote-wtoc] + ;; (list 'menu-item "Edit Remote File With TOC" 'html-upl-edit-remote-file-with-toc)) + (define-key upl-map [html-site-upl-edit-remote] + (list 'menu-item "Edit Remote File" 'html-upl-edit-remote-file)) + (define-key upl-map [html-site-upl-ediff-buffer] + (list 'menu-item "Ediff Remote/Local Files" 'html-upl-ediff-file)) + (define-key upl-map [html-site-upl-sep] (list 'menu-item "--")) + (define-key upl-map [html-site-upl-upload-site-with-toc] + (list 'menu-item "Upload Site with TOC" 'html-upl-upload-site-with-toc)) + (define-key upl-map [html-site-upl-upload-site] + (list 'menu-item "Upload Site" 'html-upl-upload-site)) + (define-key upl-map [html-site-upl-upload-file] + (list 'menu-item "Upload Single File" 'html-upl-upload-file)) + )) + + (let ((site-map (make-sparse-keymap))) + (define-key map [html-site-site-map] + (list 'menu-item "Site" site-map)) + (define-key site-map [html-site-customize-site-list] + (list 'menu-item "Edit Sites" (lambda () (interactive) + (customize-option 'html-site-list)))) + (define-key site-map [html-site-set-site] + (list 'menu-item "Set Current Site" 'html-site-set-site)) + ) + + map)) + + +(defvar html-site-mode-map + (let ((map (make-sparse-keymap ))) + (define-key map [menu-bar html-site-mode] + (list 'menu-item "Web Site" html-site-mode-menu-map)) + map)) + +(define-minor-mode html-site-mode + "Adds a menu for easy access of setting site, uploading etc." + :init-value nil + :lighter nil + :keymap html-site-mode-map + :group 'html-site) + +(defvar html-site-mode-off-list + '(nxhtml-mode)) + +(define-global-minor-mode html-site-global-mode html-site-mode + (lambda () + (html-site-mode 1) + (when t ;buffer-file-name + (unless (memq major-mode html-site-mode-off-list) + (html-site-mode 1)))) + :group 'html-site) +;; The problem with global minor modes: +(when (and html-site-global-mode + (not (boundp 'define-global-minor-mode-bug))) + (html-site-global-mode 1)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; html-site.el ends here |