;;; sgml-mode.el --- SGML- and HTML-editing modes
-;; Copyright (C) 1992, 1995, 1996, 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1992,95,96,98,2001,2002 Free Software Foundation, Inc.
;; Author: James Clark <jjc@jclark.com>
-;; Adapted-By: ESR; Daniel.Pfeiffer@Informatik.START.dbp.de
+;; Maintainer: FSF
+;; Adapted-By: ESR, Daniel Pfeiffer <occitan@esperanto.org>,
;; F.Potorti@cnuce.cnr.it
;; Keywords: wp, hypermedia, comm, languages
;;; Code:
+(eval-when-compile
+ (require 'skeleton)
+ (require 'outline)
+ (require 'cl))
+
(defgroup sgml nil
"SGML editing mode"
:group 'languages)
+(defcustom sgml-basic-offset 2
+ "*Specifies the basic indentation level for `sgml-indent-line'."
+ :type 'integer
+ :group 'sgml)
+
(defcustom sgml-transformation 'identity
"*Default value for `skeleton-transformation' (which see) in SGML mode."
:type 'function
(put 'sgml-transformation 'variable-interactive
"aTransformation function: ")
+(defcustom sgml-mode-hook nil
+ "Hook run by command `sgml-mode'.
+`text-mode-hook' is run first."
+ :group 'sgml
+ :type 'hook)
+
;; As long as Emacs' syntax can't be complemented with predicates to context
;; sensitively confirm the syntax of characters, we have to live with this
;; kludgy kind of tradeoff.
(defvar sgml-specials '(?\")
"List of characters that have a special meaning for SGML mode.
-This list is used when first loading the sgml-mode library.
+This list is used when first loading the `sgml-mode' library.
The supported characters and potential disadvantages are:
?\\\" Makes \" in text start a string.
with comments, so we normally turn it off.")
(defvar sgml-quick-keys nil
- "Use <, >, &, SPC and `sgml-specials' keys \"electrically\" when non-nil.
-This takes effect when first loading the sgml-mode library.")
-
+ "Use <, >, &, /, SPC and `sgml-specials' keys \"electrically\" when non-nil.
+This takes effect when first loading the `sgml-mode' library.")
(defvar sgml-mode-map
- (let ((map (list 'keymap (make-vector 256 nil)))
+ (let ((map (make-keymap)) ;`sparse' doesn't allow binding to charsets.
(menu-map (make-sparse-keymap "SGML")))
- (define-key map "\t" 'indent-relative-maybe)
(define-key map "\C-c\C-i" 'sgml-tags-invisible)
(define-key map "/" 'sgml-slash)
(define-key map "\C-c\C-n" 'sgml-name-char)
(define-key map "\C-c\C-d" 'sgml-delete-tag)
(define-key map "\C-c\^?" 'sgml-delete-tag)
(define-key map "\C-c?" 'sgml-tag-help)
+ (define-key map "\C-c/" 'sgml-close-tag)
(define-key map "\C-c8" 'sgml-name-8bit-mode)
(define-key map "\C-c\C-v" 'sgml-validate)
- (if sgml-quick-keys
- (progn
- (define-key map "&" 'sgml-name-char)
- (define-key map "<" 'sgml-tag)
- (define-key map " " 'sgml-auto-attributes)
- (define-key map ">" 'sgml-maybe-end-tag)
- (if (memq ?\" sgml-specials)
- (define-key map "\"" 'sgml-name-self))
- (if (memq ?' sgml-specials)
- (define-key map "'" 'sgml-name-self))))
+ (when sgml-quick-keys
+ (define-key map "&" 'sgml-name-char)
+ (define-key map "<" 'sgml-tag)
+ (define-key map " " 'sgml-auto-attributes)
+ (define-key map ">" 'sgml-maybe-end-tag)
+ (when (memq ?\" sgml-specials)
+ (define-key map "\"" 'sgml-name-self))
+ (when (memq ?' sgml-specials)
+ (define-key map "'" 'sgml-name-self)))
+ (define-key map (vector (make-char 'latin-iso8859-1))
+ 'sgml-maybe-name-self)
(let ((c 127)
(map (nth 1 map)))
(while (< (setq c (1+ c)) 256)
map)
"Keymap for SGML mode. See also `sgml-specials'.")
-
-(defvar sgml-mode-syntax-table
- (let ((table (copy-syntax-table text-mode-syntax-table)))
+(defun sgml-make-syntax-table (specials)
+ (let ((table (make-syntax-table text-mode-syntax-table)))
(modify-syntax-entry ?< "(>" table)
(modify-syntax-entry ?> ")<" table)
- (if (memq ?- sgml-specials)
+ (modify-syntax-entry ?: "_" table)
+ (modify-syntax-entry ?_ "_" table)
+ (modify-syntax-entry ?. "_" table)
+ (if (memq ?- specials)
(modify-syntax-entry ?- "_ 1234" table))
- (if (memq ?\" sgml-specials)
+ (if (memq ?\" specials)
(modify-syntax-entry ?\" "\"\"" table))
- (if (memq ?' sgml-specials)
+ (if (memq ?' specials)
(modify-syntax-entry ?\' "\"'" table))
- table)
+ table))
+
+(defvar sgml-mode-syntax-table (sgml-make-syntax-table sgml-specials)
"Syntax table used in SGML mode. See also `sgml-specials'.")
+(defconst sgml-tag-syntax-table
+ (let ((table (sgml-make-syntax-table '(?- ?\" ?\'))))
+ (dolist (char '(?\( ?\) ?\{ ?\} ?\[ ?\] ?$ ?% ?& ?* ?+ ?/))
+ (modify-syntax-entry char "." table))
+ table)
+ "Syntax table used to parse SGML tags.")
(defcustom sgml-name-8bit-mode nil
- "*When non-nil, insert 8 bit characters with their names."
+ "*When non-nil, insert non-ASCII characters as named entities."
:type 'boolean
:group 'sgml)
"nbsp" "iexcl" "cent" "pound" "curren" "yen" "brvbar" "sect"
"uml" "copy" "ordf" "laquo" "not" "shy" "reg" "macr"
"ring" "plusmn" "sup2" "sup3" "acute" "micro" "para" "middot"
- "cedil" "sup1" "ordm" "raquo" "frac14" "half" "frac34" "iquest"
+ "cedil" "sup1" "ordm" "raquo" "frac14" "frac12" "frac34" "iquest"
"Agrave" "Aacute" "Acirc" "Atilde" "Auml" "Aring" "AElig" "Ccedil"
"Egrave" "Eacute" "Ecirc" "Euml" "Igrave" "Iacute" "Icirc" "Iuml"
"ETH" "Ntilde" "Ograve" "Oacute" "Ocirc" "Otilde" "Ouml" nil
"oslash" "ugrave" "uacute" "ucirc" "uuml" "yacute" "thorn" "yuml"]
"Vector of symbolic character names without `&' and `;'.")
+(put 'sgml-table 'char-table-extra-slots 0)
-;; sgmls is a free SGML parser available from
-;; ftp.uu.net:pub/text-processing/sgml
+(defvar sgml-char-names-table
+ (let ((table (make-char-table 'sgml-table))
+ (i 32)
+ elt)
+ (while (< i 256)
+ (setq elt (aref sgml-char-names i))
+ (if elt (aset table (make-char 'latin-iso8859-1 i) elt))
+ (setq i (1+ i)))
+ table)
+ "A table for mapping non-ASCII characters into SGML entity names.
+Currently, only Latin-1 characters are supported.")
+
+;; nsgmls is a free SGML parser in the SP suite available from
+;; ftp.jclark.com and otherwise packaged for GNU systems.
;; Its error messages can be parsed by next-error.
;; The -s option suppresses output.
-(defcustom sgml-validate-command "sgmls -s"
+(defcustom sgml-validate-command "nsgmls -s" ; replaced old `sgmls'
"*The command to validate an SGML document.
The file name of current buffer file name will be appended to this,
separated by a space."
:type 'string
+ :version "21.1"
:group 'sgml)
(defvar sgml-saved-validate-command nil
"The command last used to validate in this buffer.")
-
-;;; I doubt that null end tags are used much for large elements,
-;;; so use a small distance here.
+;; I doubt that null end tags are used much for large elements,
+;; so use a small distance here.
(defcustom sgml-slash-distance 1000
"*If non-nil, is the maximum distance to search for matching `/'."
:type '(choice (const nil) integer)
:group 'sgml)
-(defconst sgml-start-tag-regex
- "<[A-Za-z]\\([-.A-Za-z0-9= \n\t]\\|\"[^\"]*\"\\|'[^']*'\\)*"
+(defconst sgml-name-re "[_:[:alpha:]][-_.:[:alnum:]]*")
+(defconst sgml-tag-name-re (concat "<\\([!/?]?" sgml-name-re "\\)"))
+(defconst sgml-attrs-re "\\(?:[^\"'/><]\\|\"[^\"]*\"\\|'[^']*'\\)*")
+(defconst sgml-start-tag-regex (concat "<" sgml-name-re sgml-attrs-re)
"Regular expression that matches a non-empty start tag.
Any terminating `>' or `/' is not matched.")
;; internal
(defconst sgml-font-lock-keywords-1
- '(("<\\([!?][a-z][-.a-z0-9]+\\)" 1 font-lock-keyword-face)
- ("<\\(/?[a-z][-.a-z0-9]+\\)" 1 font-lock-function-name-face)
- ("[&%][a-z][-.a-z0-9]+;?" . font-lock-variable-name-face)
- ("<! *--.*-- *>" . font-lock-comment-face)))
-
-(defconst sgml-font-lock-keywords-2 ())
+ `((,(concat "<\\([!?]" sgml-name-re "\\)") 1 font-lock-keyword-face)
+ (,(concat "<\\(/?" sgml-name-re"\\)") 1 font-lock-function-name-face)
+ ;; FIXME: this doesn't cover the variables using a default value.
+ (,(concat "\\(" sgml-name-re "\\)=[\"']") 1 font-lock-variable-name-face)
+ (,(concat "[&%]" sgml-name-re ";?") . font-lock-variable-name-face)))
+
+(defconst sgml-font-lock-keywords-2
+ (append
+ sgml-font-lock-keywords-1
+ '((eval
+ . (cons (concat "<"
+ (regexp-opt (mapcar 'car sgml-tag-face-alist) t)
+ "\\([ \t][^>]*\\)?>\\([^<]+\\)</\\1>")
+ '(3 (cdr (assoc (downcase (match-string 1))
+ sgml-tag-face-alist))))))))
;; for font-lock, but must be defvar'ed after
;; sgml-font-lock-keywords-1 and sgml-font-lock-keywords-2 above
(defvar sgml-font-lock-keywords sgml-font-lock-keywords-1
"*Rules for highlighting SGML code. See also `sgml-tag-face-alist'.")
+(defvar sgml-font-lock-syntactic-keywords
+ ;; Use the `b' style of comments to avoid interference with the -- ... --
+ ;; comments recognized when `sgml-specials' includes ?-.
+ ;; FIXME: beware of <!--> blabla <!--> !!
+ '(("\\(<\\)!--" (1 "< b"))
+ ("--[ \t\n]*\\(>\\)" (1 "> b")))
+ "Syntactic keywords for `sgml-mode'.")
+
;; internal
(defvar sgml-face-tag-alist ()
"Alist of face and tag name for facemenu.")
When `font-lock-maximum-decoration' is 1 this is always used for fontifying.
When more these are fontified together with `sgml-font-lock-keywords'.")
-
(defvar sgml-display-text ()
"Tag names as lowercase symbols, and display string when invisible.")
;; internal
(defvar sgml-tags-invisible nil)
-
(defcustom sgml-tag-alist
'(("![" ("ignore" t) ("include" t))
("!attlist")
((\"tag\" . TAGRULE)
...)
-TAGRULE is a list of optionally `t' (no endtag) or `\\n' (separate endtag by
-newlines) or a skeleton with `nil', `t' or `\\n' in place of the interactor
+TAGRULE is a list of optionally t (no endtag) or `\\n' (separate endtag by
+newlines) or a skeleton with nil, t or `\\n' in place of the interactor
followed by an ATTRIBUTERULE (for an always present attribute) or an
attribute alist.
((\"attribute\" . ATTRIBUTERULE)
...)
-ATTRIBUTERULE is a list of optionally `t' (no value when no input) followed by
+ATTRIBUTERULE is a list of optionally t (no value when no input) followed by
an optional alist of possible values."
:type '(repeat (cons (string :tag "Tag Name")
(repeat :tag "Tag Rule" sexp)))
(string :tag "Description")))
:group 'sgml)
-(defun sgml-mode-common (sgml-tag-face-alist sgml-display-text)
- "Common code for setting up `sgml-mode' and derived modes.
-SGML-TAG-FACE-ALIST is used for calculating `sgml-font-lock-keywords-2'.
-SGML-DISPLAY-TEXT sets up alternate text for when tags are invisible (see
-varables of same name)."
- (kill-all-local-variables)
- (setq local-abbrev-table text-mode-abbrev-table)
- (set-syntax-table sgml-mode-syntax-table)
- (make-local-variable 'indent-line-function)
- (make-local-variable 'paragraph-start)
- (make-local-variable 'paragraph-separate)
- (make-local-variable 'adaptive-fill-regexp)
- (make-local-variable 'sgml-saved-validate-command)
- (make-local-variable 'comment-start)
- (make-local-variable 'comment-end)
- (make-local-variable 'comment-indent-function)
- (make-local-variable 'comment-start-skip)
- (make-local-variable 'comment-indent-function)
- (make-local-variable 'sgml-tags-invisible)
- (make-local-variable 'skeleton-transformation)
- (make-local-variable 'skeleton-further-elements)
- (make-local-variable 'skeleton-end-hook)
- (make-local-variable 'font-lock-defaults)
- (make-local-variable 'sgml-font-lock-keywords-1)
- (make-local-variable 'sgml-font-lock-keywords-2)
- (make-local-variable 'facemenu-add-face-function)
- (make-local-variable 'facemenu-end-add-face)
- ;;(make-local-variable 'facemenu-remove-face-function)
- (and sgml-tag-face-alist
- (not (assq 1 sgml-tag-face-alist))
- (nconc sgml-tag-face-alist
- `((1 (,(concat "<\\("
- (mapconcat 'car sgml-tag-face-alist "\\|")
- "\\)\\([ \t].+\\)?>\\(.+\\)</\\1>")
- 3 (cdr (assoc (downcase (match-string 1))
- ',sgml-tag-face-alist)))))))
- (setq indent-line-function 'indent-relative-maybe
- ;; A start or end tag by itself on a line separates a paragraph.
- ;; This is desirable because SGML discards a newline that appears
- ;; immediately after a start tag or immediately before an end tag.
- paragraph-separate "[ \t]*$\\|\
-\[ \t]*</?\\([A-Za-z]\\([-.A-Za-z0-9= \t\n]\\|\"[^\"]*\"\\|'[^']*'\\)*\\)?>$"
- paragraph-start "[ \t]*$\\|\
-\[ \t]*</?\\([A-Za-z]\\([-.A-Za-z0-9= \t\n]\\|\"[^\"]*\"\\|'[^']*'\\)*\\)?>$"
- adaptive-fill-regexp "[ \t]*"
- comment-start "<!-- "
- comment-end " -->"
- comment-indent-function 'sgml-comment-indent
- ;; This will allow existing comments within declarations to be
- ;; recognized.
- comment-start-skip "--[ \t]*"
- skeleton-transformation sgml-transformation
- skeleton-further-elements '((completion-ignore-case t))
- skeleton-end-hook (lambda ()
- (or (eolp)
- (not (or (eq v2 '\n)
- (eq (car-safe v2) '\n)))
- (newline-and-indent)))
- sgml-font-lock-keywords-2 (append
- sgml-font-lock-keywords-1
- (cdr (assq 1 sgml-tag-face-alist)))
- font-lock-defaults '((sgml-font-lock-keywords
- sgml-font-lock-keywords-1
- sgml-font-lock-keywords-2)
- nil
- t)
- facemenu-add-face-function 'sgml-mode-facemenu-add-face-function)
- (while sgml-display-text
- (put (car (car sgml-display-text)) 'before-string
- (cdr (car sgml-display-text)))
- (setq sgml-display-text (cdr sgml-display-text)))
- (run-hooks 'text-mode-hook 'sgml-mode-hook))
+(defcustom sgml-xml-mode nil
+ "*When non-nil, tag insertion functions will be XML-compliant.
+If this variable is customized, the custom value is used always.
+Otherwise, it is set to be buffer-local when the file has
+ a DOCTYPE or an XML declaration."
+ :type 'boolean
+ :version "21.2"
+ :group 'sgml)
+(defvar sgml-empty-tags nil
+ "List of tags whose !ELEMENT definition says EMPTY.")
+
+(defvar sgml-unclosed-tags nil
+ "List of tags whose !ELEMENT definition says the end-tag is optional.")
+
+(defun sgml-xml-guess ()
+ "Guess whether the current buffer is XML."
+ (save-excursion
+ (goto-char (point-min))
+ (when (or (string= "xml" (file-name-extension (or buffer-file-name "")))
+ (looking-at "\\s-*<\\?xml")
+ (when (re-search-forward
+ (eval-when-compile
+ (mapconcat 'identity
+ '("<!DOCTYPE" "\\(\\w+\\)" "\\(\\w+\\)"
+ "\"\\([^\"]+\\)\"" "\"\\([^\"]+\\)\"")
+ "\\s-+"))
+ nil t)
+ (string-match "X\\(HT\\)?ML" (match-string 3))))
+ (set (make-local-variable 'sgml-xml-mode) t))))
+
+(defvar v2) ; free for skeleton
+
+(defun sgml-comment-indent-new-line (&optional soft)
+ (let ((comment-start "-- ")
+ (comment-start-skip "\\(<!\\)?--[ \t]*")
+ (comment-end " --")
+ (comment-style 'plain))
+ (comment-indent-new-line soft)))
(defun sgml-mode-facemenu-add-face-function (face end)
(if (setq face (cdr (assq face sgml-face-tag-alist)))
(setq face (funcall skeleton-transformation face))
(setq facemenu-end-add-face (concat "</" face ">"))
(concat "<" face ">"))
- (error "Face not configured for %s mode." mode-name)))
-
+ (error "Face not configured for %s mode" mode-name)))
;;;###autoload
-(defun sgml-mode (&optional function)
+(define-derived-mode sgml-mode text-mode "SGML"
"Major mode for editing SGML documents.
-Makes > match <. Makes / blink matching /.
-Keys <, &, SPC within <>, \" and ' can be electric depending on
+Makes > match <.
+Keys <, &, SPC within <>, \", / and ' can be electric depending on
`sgml-quick-keys'.
An argument of N to a tag-inserting command means to wrap it around
Do \\[describe-variable] sgml- SPC to see available variables.
Do \\[describe-key] on the following bindings to discover what they do.
\\{sgml-mode-map}"
- (interactive)
- (sgml-mode-common sgml-tag-face-alist sgml-display-text)
- ;; Set imenu-generic-expression here, rather than in sgml-mode-common,
- ;; because this definition probably is not useful in HTML mode.
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression
- "<!\\(element\\|entity\\)[ \t\n]+%?[ \t\n]*\\([A-Za-z][-A-Za-z.0-9]*\\)")
- (use-local-map sgml-mode-map)
- (setq mode-name "SGML"
- major-mode 'sgml-mode))
-
-
+ (make-local-variable 'sgml-saved-validate-command)
+ (make-local-variable 'facemenu-end-add-face)
+ ;;(make-local-variable 'facemenu-remove-face-function)
+ ;; A start or end tag by itself on a line separates a paragraph.
+ ;; This is desirable because SGML discards a newline that appears
+ ;; immediately after a start tag or immediately before an end tag.
+ (set (make-local-variable 'paragraph-start) (concat "[ \t]*$\\|\
+\[ \t]*</?\\(" sgml-name-re sgml-attrs-re "\\)?>"))
+ (set (make-local-variable 'paragraph-separate)
+ (concat paragraph-start "$"))
+ (set (make-local-variable 'adaptive-fill-regexp) "[ \t]*")
+ (set (make-local-variable 'indent-line-function) 'sgml-indent-line)
+ (set (make-local-variable 'comment-start) "<!-- ")
+ (set (make-local-variable 'comment-end) " -->")
+ (set (make-local-variable 'comment-indent-function) 'sgml-comment-indent)
+ (set (make-local-variable 'comment-line-break-function)
+ 'sgml-comment-indent-new-line)
+ (set (make-local-variable 'skeleton-further-elements)
+ '((completion-ignore-case t)))
+ (set (make-local-variable 'skeleton-end-hook)
+ (lambda ()
+ (or (eolp)
+ (not (or (eq v2 '\n) (eq (car-safe v2) '\n)))
+ (newline-and-indent))))
+ (set (make-local-variable 'font-lock-defaults)
+ '((sgml-font-lock-keywords
+ sgml-font-lock-keywords-1
+ sgml-font-lock-keywords-2)
+ nil t nil nil
+ (font-lock-syntactic-keywords
+ . sgml-font-lock-syntactic-keywords)))
+ (set (make-local-variable 'facemenu-add-face-function)
+ 'sgml-mode-facemenu-add-face-function)
+ (sgml-xml-guess)
+ (if sgml-xml-mode
+ (setq mode-name "XML")
+ (set (make-local-variable 'skeleton-transformation) sgml-transformation))
+ ;; This will allow existing comments within declarations to be
+ ;; recognized.
+ (set (make-local-variable 'comment-start-skip) "\\(?:<!\\)?--[ \t]*")
+ (set (make-local-variable 'comment-end-skip) "[ \t]*--\\([ \t\n]*>\\)?")
+ ;; This definition probably is not useful in derived modes.
+ (set (make-local-variable 'imenu-generic-expression)
+ (concat "<!\\(element\\|entity\\)[ \t\n]+%?[ \t\n]*\\("
+ sgml-name-re "\\)")))
(defun sgml-comment-indent ()
- (if (and (looking-at "--")
- (not (and (eq (preceding-char) ?!)
- (eq (char-after (- (point) 2)) ?<))))
- (progn
- (skip-chars-backward " \t")
- (max comment-column (1+ (current-column))))
- 0))
-
-
+ (if (looking-at "--") comment-column 0))
(defun sgml-slash (arg)
+ "Insert ARG slash characters.
+Behaves electrically if `sgml-quick-keys' is non-nil."
+ (interactive "p")
+ (cond
+ ((not (and (eq (char-before) ?<) (= arg 1)))
+ (sgml-slash-matching arg))
+ ((eq sgml-quick-keys 'indent)
+ (insert-char ?/ 1)
+ (indent-according-to-mode))
+ ((eq sgml-quick-keys 'close)
+ (delete-backward-char 1)
+ (sgml-close-tag))
+ (t
+ (sgml-slash-matching arg))))
+
+(defun sgml-slash-matching (arg)
"Insert `/' and display any previous matching `/'.
Two `/'s are treated as matching if the first `/' ends a net-enabling
start tag, and the second `/' is the corresponding null end tag."
(setq blinkpos (point))
(setq level (1- level)))
(setq level (1+ level)))))))
- (if blinkpos
- (progn
- (goto-char blinkpos)
- (if (pos-visible-in-window-p)
- (sit-for 1)
- (message "Matches %s"
- (buffer-substring (progn
- (beginning-of-line)
- (point))
- (1+ blinkpos))))))))))
-
-
+ (when blinkpos
+ (goto-char blinkpos)
+ (if (pos-visible-in-window-p)
+ (sit-for 1)
+ (message "Matches %s"
+ (buffer-substring (line-beginning-position)
+ (1+ blinkpos)))))))))
+
+;; Why doesn't this use the iso-cvt table or, preferably, generate the
+;; inverse of the extensive table in the SGML Quail input method? -- fx
+;; I guess that's moot since it only works with Latin-1 anyhow.
(defun sgml-name-char (&optional char)
"Insert a symbolic character name according to `sgml-char-names'.
-8 bit chars may be inserted with the meta key as in M-SPC for no break space,
-or M-- for a soft hyphen."
+Non-ASCII chars may be inserted either with the meta key, as in M-SPC for
+no-break space or M-- for a soft hyphen; or via an input method or
+encoded keyboard operation."
(interactive "*")
(insert ?&)
(or char
(insert char)
(undo-boundary)
(delete-backward-char 1)
- (insert ?&
- (or (aref sgml-char-names char)
- (format "#%d" char))
- ?\;))
-
+ (cond
+ ((< char 256)
+ (insert ?&
+ (or (aref sgml-char-names char)
+ (format "#%d" char))
+ ?\;))
+ ((aref sgml-char-names-table char)
+ (insert ?& (aref sgml-char-names-table char) ?\;))
+ ((let ((c (encode-char char 'ucs)))
+ (when c
+ (insert (format "&#%d;" c))
+ t)))
+ (t ; should be an error? -- fx
+ (insert char))))
(defun sgml-name-self ()
"Insert a symbolic character name according to `sgml-char-names'."
(interactive "*")
(sgml-name-char last-command-char))
-
(defun sgml-maybe-name-self ()
"Insert a symbolic character name according to `sgml-char-names'."
(interactive "*")
(if sgml-name-8bit-mode
- (sgml-name-char last-command-char)
+ (let ((mc last-command-char))
+ (if (< mc 256)
+ (setq mc (unibyte-char-to-multibyte mc)))
+ (or mc (setq mc last-command-char))
+ (sgml-name-char mc))
(self-insert-command 1)))
-
(defun sgml-name-8bit-mode ()
- "Toggle insertion of 8 bit characters."
+ "Toggle whether to insert named entities instead of non-ASCII characters.
+This only works for Latin-1 input."
(interactive)
(setq sgml-name-8bit-mode (not sgml-name-8bit-mode))
- (message "sgml name 8 bit mode is now %"
+ (message "sgml name entity mode is now %s"
(if sgml-name-8bit-mode "ON" "OFF")))
-
;; When an element of a skeleton is a string "str", it is passed
;; through skeleton-transformation and inserted. If "str" is to be
;; inserted literally, one should obtain it as the return value of a
(setq sgml-transformation 'upcase)"
(funcall skeleton-transformation
(completing-read "Tag: " sgml-tag-alist))
- ?< (setq v1 (eval str)) |
+ ?< str |
(("") -1 '(undo-boundary) (identity "<")) | ; see comment above
- (("") '(setq v2 (sgml-attributes v1 t)) ?>
- (if (string= "![" v1)
- (prog1 '(("") " [ " _ " ]]")
- (backward-char))
- (if (or (eq v2 t)
- (string-match "^[/!?]" v1))
- ()
- (if (symbolp v2)
- '(("") v2 _ v2 "</" v1 ?>)
- (if (eq (car v2) t)
- (cons '("") (cdr v2))
- (append '(("") (car v2))
- (cdr v2)
- '(resume: (car v2) _ "</" v1 ?>))))))))
+ `(("") '(setq v2 (sgml-attributes ,str t)) ?>
+ (cond
+ ((string= "![" ,str)
+ (backward-char)
+ '(("") " [ " _ " ]]"))
+ ((and (eq v2 t) sgml-xml-mode (member ,str sgml-empty-tags))
+ '(("") -1 "/>"))
+ ((or (and (eq v2 t) (not sgml-xml-mode)) (string-match "^[/!?]" ,str))
+ nil)
+ ((symbolp v2)
+ ;; Make sure we don't fall into an infinite loop.
+ ;; For xhtml's `tr' tag, we should maybe use \n instead.
+ (if (eq v2 t) (setq v2 nil))
+ ;; We use `identity' to prevent skeleton from passing
+ ;; `str' through skeleton-transformation a second time.
+ '(("") v2 _ v2 "</" (identity ',str) ?>))
+ ((eq (car v2) t)
+ (cons '("") (cdr v2)))
+ (t
+ (append '(("") (car v2))
+ (cdr v2)
+ '(resume: (car v2) _ "</" (identity ',str) ?>))))))
(autoload 'skeleton-read "skeleton")
(or (> (point) point)
(self-insert-command 1)))))
-
(defun sgml-tag-help (&optional tag)
"Display description of tag TAG. If TAG is omitted, use the tag at point."
(interactive)
(cdr (assoc (downcase (substring tag 1)) sgml-tag-help)))
"No description available")))
-
-(defun sgml-maybe-end-tag ()
- "Name self unless in position to end a tag."
- (interactive)
- (or (condition-case nil
- (save-excursion (up-list -1))
- (error
- (sgml-name-self)
- t))
- (condition-case nil
- (progn
- (save-excursion (up-list 1))
- (sgml-name-self))
- (error (self-insert-command 1)))))
-
+(defun sgml-maybe-end-tag (&optional arg)
+ "Name self unless in position to end a tag or a prefix ARG is given."
+ (interactive "P")
+ (if (or arg (eq (car (sgml-lexical-context)) 'tag))
+ (self-insert-command (prefix-numeric-value arg))
+ (sgml-name-self)))
(defun sgml-skip-tag-backward (arg)
"Skip to beginning of tag or matching opening tag if present.
(goto-char open)
(kill-sexp 1)))
(setq arg (1- arg))))
+
\f
;; Put read-only last to enable setting this even when read-only enabled.
(or (get 'sgml-tag 'invisible)
(interactive "P")
(let ((modified (buffer-modified-p))
(inhibit-read-only t)
+ (inhibit-modification-hooks t)
+ ;; Avoid spurious the `file-locked' checks.
+ (buffer-file-name nil)
;; This is needed in case font lock gets called,
;; since it moves point and might call sgml-point-entered.
+ ;; How could it get called? -stef
(inhibit-point-motion-hooks t)
- symbol)
- (save-excursion
- (goto-char (point-min))
- (if (setq sgml-tags-invisible
- (if arg
- (>= (prefix-numeric-value arg) 0)
- (not sgml-tags-invisible)))
- (while (re-search-forward "<\\([!/?A-Za-z][-A-Za-z0-9]*\\)"
- nil t)
- (setq symbol (intern-soft (downcase (match-string 1))))
- (goto-char (match-beginning 0))
- (and (get symbol 'before-string)
- (not (overlays-at (point)))
- (overlay-put (make-overlay (point)
- (match-beginning 1))
- 'category symbol))
- (put-text-property (point)
- (progn (forward-list) (point))
- 'category 'sgml-tag))
- (let ((pos (point)))
- (while (< (setq pos (next-overlay-change pos)) (point-max))
- (delete-overlay (car (overlays-at pos)))))
- (remove-text-properties (point-min) (point-max)
- '(category sgml-tag intangible t))))
- (set-buffer-modified-p modified)
+ string)
+ (unwind-protect
+ (save-excursion
+ (goto-char (point-min))
+ (if (set (make-local-variable 'sgml-tags-invisible)
+ (if arg
+ (>= (prefix-numeric-value arg) 0)
+ (not sgml-tags-invisible)))
+ (while (re-search-forward sgml-tag-name-re nil t)
+ (setq string
+ (cdr (assq (intern-soft (downcase (match-string 1)))
+ sgml-display-text)))
+ (goto-char (match-beginning 0))
+ (and (stringp string)
+ (not (overlays-at (point)))
+ (let ((ol (make-overlay (point) (match-beginning 1))))
+ (overlay-put ol 'before-string string)
+ (overlay-put ol 'sgml-tag t)))
+ (put-text-property (point)
+ (progn (forward-list) (point))
+ 'category 'sgml-tag))
+ (let ((pos (point-min)))
+ (while (< (setq pos (next-overlay-change pos)) (point-max))
+ (dolist (ol (overlays-at pos))
+ (if (overlay-get ol 'sgml-tag)
+ (delete-overlay ol)))))
+ (remove-text-properties (point-min) (point-max) '(category nil))))
+ (restore-buffer-modified-p modified))
(run-hooks 'sgml-tags-invisible-hook)
(message "")))
(let ((inhibit-point-motion-hooks t))
(save-excursion
(message "Invisible tag: %s"
- (buffer-substring
+ ;; Strip properties, otherwise, the text is invisible.
+ (buffer-substring-no-properties
(point)
(if (or (and (> x y)
(not (eq (following-char) ?<)))
(eq (preceding-char) ?>)))
(backward-list)
(forward-list)))))))
+
\f
(autoload 'compile-internal "compile")
(and name
(file-name-nondirectory name))))))))
(setq sgml-saved-validate-command command)
- (if (or (not compilation-ask-about-save)
- (y-or-n-p (message "Save buffer %s? " (buffer-name))))
- (save-buffer))
+ (save-some-buffers (not compilation-ask-about-save) nil)
(compile-internal command "No more errors"))
+(defun sgml-lexical-context (&optional limit)
+ "Return the lexical context at point as (TYPE . START).
+START is the location of the start of the lexical element.
+TYPE is one of `string', `comment', `tag', `cdata', or `text'.
+
+Optional argument LIMIT is the position to start parsing from.
+If nil, start from a preceding tag at indentation."
+ (save-excursion
+ (let ((pos (point))
+ text-start state)
+ (if limit
+ (goto-char limit)
+ ;; Skip tags backwards until we find one at indentation
+ (while (and (ignore-errors (sgml-parse-tag-backward))
+ (not (sgml-at-indentation-p)))))
+ (with-syntax-table sgml-tag-syntax-table
+ (while (< (point) pos)
+ ;; When entering this loop we're inside text.
+ (setq text-start (point))
+ (skip-chars-forward "^<" pos)
+ (setq state
+ (cond
+ ((= (point) pos)
+ ;; We got to the end without seeing a tag.
+ nil)
+ ((looking-at "<!\\[[A-Z]+\\[")
+ ;; We've found a CDATA section or similar.
+ (let ((cdata-start (point)))
+ (unless (search-forward "]]>" pos 'move)
+ (list 0 nil nil 'cdata nil nil nil nil cdata-start))))
+ (t
+ ;; We've reached a tag. Parse it.
+ ;; FIXME: Handle net-enabling start-tags
+ (parse-partial-sexp (point) pos 0))))))
+ (cond
+ ((eq (nth 3 state) 'cdata) (cons 'cdata (nth 8 state)))
+ ((nth 3 state) (cons 'string (nth 8 state)))
+ ((nth 4 state) (cons 'comment (nth 8 state)))
+ ((and state (> (nth 0 state) 0)) (cons 'tag (nth 1 state)))
+ (t (cons 'text text-start))))))
(defun sgml-beginning-of-tag (&optional top-level)
"Skip to beginning of tag and return its name.
-If this can't be done, return t."
- (or (if top-level
- (condition-case nil
- (up-list -1)
- (error t))
- (>= (point)
- (if (search-backward "<" nil t)
- (save-excursion
- (forward-list)
- (point))
- 0)))
- (if (looking-at "<[!?/]?[[A-Za-z][A-Za-z0-9]*")
- (buffer-substring-no-properties
- (1+ (point))
- (match-end 0))
- t)))
+If this can't be done, return nil."
+ (let ((context (sgml-lexical-context)))
+ (if (eq (car context) 'tag)
+ (progn
+ (goto-char (cdr context))
+ (when (looking-at sgml-tag-name-re)
+ (match-string-no-properties 1)))
+ (if top-level nil
+ (when (not (eq (car context) 'text))
+ (goto-char (cdr context))
+ (sgml-beginning-of-tag t))))))
(defun sgml-value (alist)
- "Interactively insert value taken from attributerule ALIST.
-See `sgml-tag-alist' for info about attributerules.."
+ "Interactively insert value taken from attribute-rule ALIST.
+See `sgml-tag-alist' for info about attribute rules."
(setq alist (cdr alist))
(if (stringp (car alist))
(insert "=\"" (car alist) ?\")
- (if (eq (car alist) t)
- (if (cdr alist)
- (progn
- (insert "=\"")
- (setq alist (skeleton-read '(completing-read
- "Value: " (cdr alist))))
- (if (string< "" alist)
- (insert alist ?\")
- (delete-backward-char 2))))
+ (if (and (eq (car alist) t) (not sgml-xml-mode))
+ (when (cdr alist)
+ (insert "=\"")
+ (setq alist (skeleton-read '(completing-read "Value: " (cdr alist))))
+ (if (string< "" alist)
+ (insert alist ?\")
+ (delete-backward-char 2)))
(insert "=\"")
- (if alist
- (insert (skeleton-read '(completing-read "Value: " alist))))
+ (when alist
+ (insert (skeleton-read '(completing-read "Value: " alist))))
(insert ?\"))))
-(provide 'sgml-mode)
+(defun sgml-quote (start end &optional unquotep)
+ "Quote SGML text in region.
+With prefix argument, unquote the region."
+ (interactive "r\np")
+ (if (< start end)
+ (goto-char start)
+ (goto-char end)
+ (setq end start))
+ (if unquotep
+ (while (re-search-forward "&\\(amp\\|\\(l\\|\\(g\\)\\)t\\)[;\n]" end t)
+ (replace-match (if (match-end 3) ">" (if (match-end 2) "<" "&"))))
+ (while (re-search-forward "[&<>]" end t)
+ (replace-match (cdr (assq (char-before) '((?& . "&")
+ (?< . "<")
+ (?> . ">"))))))))
+
+(defsubst sgml-at-indentation-p ()
+ "Return true if point is at the first non-whitespace character on the line."
+ (save-excursion
+ (skip-chars-backward " \t")
+ (bolp)))
+
\f
+;; Parsing
+
+(defstruct (sgml-tag
+ (:constructor sgml-make-tag (type start end name)))
+ type start end name)
+
+(defsubst sgml-parse-tag-name ()
+ "Skip past a tag-name, and return the name."
+ (buffer-substring-no-properties
+ (point) (progn (skip-syntax-forward "w_") (point))))
+
+(defsubst sgml-looking-back-at (str)
+ "Return t if the test before point matches STR."
+ (let ((start (- (point) (length str))))
+ (and (>= start (point-min))
+ (equal str (buffer-substring-no-properties start (point))))))
+
+(defun sgml-parse-tag-backward ()
+ "Parse an SGML tag backward, and return information about the tag.
+Assume that parsing starts from within a textual context.
+Leave point at the beginning of the tag."
+ (let (tag-type tag-start tag-end name)
+ (search-backward ">")
+ (setq tag-end (1+ (point)))
+ (cond
+ ((sgml-looking-back-at "--") ; comment
+ (setq tag-type 'comment
+ tag-start (search-backward "<!--" nil t)))
+ ((sgml-looking-back-at "]]") ; cdata
+ (setq tag-type 'cdata
+ tag-start (re-search-backward "<!\\[[A-Z]+\\[" nil t)))
+ (t
+ (setq tag-start
+ (with-syntax-table sgml-tag-syntax-table
+ (goto-char tag-end)
+ (backward-sexp)
+ (point)))
+ (goto-char (1+ tag-start))
+ (case (char-after)
+ (?! ; declaration
+ (setq tag-type 'decl))
+ (?? ; processing-instruction
+ (setq tag-type 'pi))
+ (?/ ; close-tag
+ (forward-char 1)
+ (setq tag-type 'close
+ name (sgml-parse-tag-name)))
+ (?% ; JSP tags
+ (setq tag-type 'jsp))
+ (t ; open or empty tag
+ (setq tag-type 'open
+ name (sgml-parse-tag-name))
+ (if (or (eq ?/ (char-before (- tag-end 1)))
+ (sgml-empty-tag-p name))
+ (setq tag-type 'empty))))))
+ (goto-char tag-start)
+ (sgml-make-tag tag-type tag-start tag-end name)))
+
+(defun sgml-get-context (&optional full)
+ "Determine the context of the current position.
+If FULL is `empty', return even if the context is empty (i.e.
+we just skipped over some element and got to a beginning of line).
+If FULL is non-nil, parse back to the beginning of the buffer, otherwise
+parse until we find a start-tag as the first thing on a line.
+
+The context is a list of tag-info structures. The last one is the tag
+immediately enclosing the current position."
+ (let ((here (point))
+ (ignore nil)
+ (context nil)
+ tag-info)
+ ;; CONTEXT keeps track of the tag-stack
+ ;; IGNORE keeps track of the nesting level of point relative to the
+ ;; first (outermost) tag on the context. This is the list of
+ ;; enclosing start-tags we'll have to ignore.
+ (skip-chars-backward " \t\n") ; Make sure we're not at indentation.
+ (while
+ (and (or ignore
+ (not (if full (eq full 'empty) context))
+ (not (sgml-at-indentation-p))
+ (and context
+ (/= (point) (sgml-tag-start (car context)))
+ (sgml-unclosed-tag-p (sgml-tag-name (car context)))))
+ (setq tag-info (ignore-errors (sgml-parse-tag-backward))))
+
+ ;; This tag may enclose things we thought were tags. If so,
+ ;; discard them.
+ (while (and context
+ (> (sgml-tag-end tag-info)
+ (sgml-tag-end (car context))))
+ (setq context (cdr context)))
+
+ (cond
+
+ ;; start-tag
+ ((eq (sgml-tag-type tag-info) 'open)
+ (cond
+ ((null ignore)
+ (if (and context
+ (sgml-unclosed-tag-p (sgml-tag-name tag-info))
+ (eq t (compare-strings
+ (sgml-tag-name tag-info) nil nil
+ (sgml-tag-name (car context)) nil nil t)))
+ ;; There was an implicit end-tag.
+ nil
+ (push tag-info context)))
+ ((eq t (compare-strings (sgml-tag-name tag-info) nil nil
+ (car ignore) nil nil t))
+ (setq ignore (cdr ignore)))
+ (t
+ ;; The open and close tags don't match.
+ (if (not sgml-xml-mode)
+ ;; Assume the open tag is simply not closed.
+ (unless (sgml-unclosed-tag-p (sgml-tag-name tag-info))
+ (message "Unclosed tag <%s>" (sgml-tag-name tag-info)))
+ (message "Unmatched tags <%s> and </%s>"
+ (sgml-tag-name tag-info) (pop ignore))))))
+
+ ;; end-tag
+ ((eq (sgml-tag-type tag-info) 'close)
+ (if (sgml-empty-tag-p (sgml-tag-name tag-info))
+ (message "Spurious </%s>: empty tag" (sgml-tag-name tag-info))
+ (push (sgml-tag-name tag-info) ignore)))
+ ))
+
+ ;; return context
+ context))
+
+(defun sgml-show-context (&optional full)
+ "Display the current context.
+If FULL is non-nil, parse back to the beginning of the buffer."
+ (interactive "P")
+ (with-output-to-temp-buffer "*XML Context*"
+ (pp (save-excursion (sgml-get-context full)))))
+
+\f
+;; Editing shortcuts
+
+(defun sgml-close-tag ()
+ "Insert an close-tag for the current element."
+ (interactive)
+ (case (car (sgml-lexical-context))
+ (comment (insert " -->"))
+ (cdata (insert "]]>"))
+ (pi (insert " ?>"))
+ (jsp (insert " %>"))
+ (tag (insert " />"))
+ (text
+ (let ((context (save-excursion (sgml-get-context))))
+ (if context
+ (progn
+ (insert "</" (sgml-tag-name (car (last context))) ">")
+ (indent-according-to-mode)))))
+ (otherwise
+ (error "Nothing to close"))))
+
+(defun sgml-empty-tag-p (tag-name)
+ "Return non-nil if TAG-NAME is an implicitly empty tag."
+ (and (not sgml-xml-mode)
+ (member-ignore-case tag-name sgml-empty-tags)))
+
+(defun sgml-unclosed-tag-p (tag-name)
+ "Return non-nil if TAG-NAME is a tag for which an end-tag is optional."
+ (and (not sgml-xml-mode)
+ (member-ignore-case tag-name sgml-unclosed-tags)))
+
+(defun sgml-calculate-indent ()
+ "Calculate the column to which this line should be indented."
+ (let ((lcon (sgml-lexical-context)))
+
+ ;; Indent comment-start markers inside <!-- just like comment-end markers.
+ (if (and (eq (car lcon) 'tag)
+ (looking-at "--")
+ (save-excursion (goto-char (cdr lcon)) (looking-at "<!--")))
+ (setq lcon (cons 'comment (+ (cdr lcon) 2))))
+
+ (case (car lcon)
+
+ (string
+ ;; Go back to previous non-empty line.
+ (while (and (> (point) (cdr lcon))
+ (zerop (forward-line -1))
+ (looking-at "[ \t]*$")))
+ (if (> (point) (cdr lcon))
+ ;; Previous line is inside the string.
+ (current-indentation)
+ (goto-char (cdr lcon))
+ (1+ (current-column))))
+
+ (comment
+ (let ((mark (looking-at "--")))
+ ;; Go back to previous non-empty line.
+ (while (and (> (point) (cdr lcon))
+ (zerop (forward-line -1))
+ (or (looking-at "[ \t]*$")
+ (if mark (not (looking-at "[ \t]*--"))))))
+ (if (> (point) (cdr lcon))
+ ;; Previous line is inside the comment.
+ (skip-chars-forward " \t")
+ (goto-char (cdr lcon)))
+ (when (and (not mark) (looking-at "--"))
+ (forward-char 2) (skip-chars-forward " \t"))
+ (current-column)))
+
+ (cdata
+ (current-column))
+
+ (tag
+ (goto-char (1+ (cdr lcon)))
+ (skip-chars-forward "^ \t\n") ;Skip tag name.
+ (skip-chars-forward " \t")
+ (if (not (eolp))
+ (current-column)
+ ;; This is the first attribute: indent.
+ (goto-char (1+ (cdr lcon)))
+ (+ (current-column) sgml-basic-offset)))
+
+ (text
+ (while (looking-at "</")
+ (forward-sexp 1)
+ (skip-chars-forward " \t"))
+ (let* ((here (point))
+ (unclosed (and ;; (not sgml-xml-mode)
+ (looking-at sgml-tag-name-re)
+ (member-ignore-case (match-string 1)
+ sgml-unclosed-tags)
+ (match-string 1)))
+ (context
+ ;; If possible, align on the previous non-empty text line.
+ ;; Otherwise, do a more serious parsing to find the
+ ;; tag(s) relative to which we should be indenting.
+ (if (and (not unclosed) (skip-chars-backward " \t")
+ (< (skip-chars-backward " \t\n") 0)
+ (back-to-indentation)
+ (> (point) (cdr lcon)))
+ nil
+ (goto-char here)
+ (nreverse (sgml-get-context (if unclosed nil 'empty)))))
+ (there (point)))
+ ;; Ignore previous unclosed start-tag in context.
+ (while (and context unclosed
+ (eq t (compare-strings
+ (sgml-tag-name (car context)) nil nil
+ unclosed nil nil t)))
+ (setq context (cdr context)))
+ ;; Indent to reflect nesting.
+ (if (and context
+ (goto-char (sgml-tag-end (car context)))
+ (skip-chars-forward " \t\n")
+ (< (point) here) (sgml-at-indentation-p))
+ (current-column)
+ (goto-char there)
+ (+ (current-column)
+ (* sgml-basic-offset (length context))))))
+
+ (otherwise
+ (error "Unrecognised context %s" (car lcon)))
+
+ )))
+
+(defun sgml-indent-line ()
+ "Indent the current line as SGML."
+ (interactive)
+ (let* ((savep (point))
+ (indent-col
+ (save-excursion
+ (back-to-indentation)
+ (if (>= (point) savep) (setq savep nil))
+ (sgml-calculate-indent))))
+ (if savep
+ (save-excursion (indent-line-to indent-col))
+ (indent-line-to indent-col))))
+
+(defun sgml-parse-dtd ()
+ "Simplistic parse of the current buffer as a DTD.
+Currently just returns (EMPTY-TAGS UNCLOSED-TAGS)."
+ (goto-char (point-min))
+ (let ((empty nil)
+ (unclosed nil))
+ (while (re-search-forward "<!ELEMENT[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+[-O][ \t\n]+\\([-O]\\)[ \t\n]+\\([^ \t\n]+\\)" nil t)
+ (cond
+ ((string= (match-string 3) "EMPTY")
+ (push (match-string-no-properties 1) empty))
+ ((string= (match-string 2) "O")
+ (push (match-string-no-properties 1) unclosed))))
+ (setq empty (sort (mapcar 'downcase empty) 'string<))
+ (setq unclosed (sort (mapcar 'downcase unclosed) 'string<))
+ (list empty unclosed)))
+
+;;; HTML mode
+
+(defcustom html-mode-hook nil
+ "Hook run by command `html-mode'.
+`text-mode-hook' and `sgml-mode-hook' are run first."
+ :group 'sgml
+ :type 'hook
+ :options '(html-autoview-mode))
+
(defvar html-quick-keys sgml-quick-keys
"Use C-c X combinations for quick insertion of frequent tags when non-nil.
This defaults to `sgml-quick-keys'.
This takes effect when first loading the library.")
(defvar html-mode-map
- (let ((map (nconc (make-sparse-keymap) sgml-mode-map))
+ (let ((map (make-sparse-keymap))
(menu-map (make-sparse-keymap "HTML")))
+ (set-keymap-parent map sgml-mode-map)
(define-key map "\C-c6" 'html-headline-6)
(define-key map "\C-c5" 'html-headline-5)
(define-key map "\C-c4" 'html-headline-4)
(define-key map "\C-c\C-ch" 'html-href-anchor)
(define-key map "\C-c\C-cn" 'html-name-anchor)
(define-key map "\C-c\C-ci" 'html-image)
- (if html-quick-keys
- (progn
- (define-key map "\C-c-" 'html-horizontal-rule)
- (define-key map "\C-co" 'html-ordered-list)
- (define-key map "\C-cu" 'html-unordered-list)
- (define-key map "\C-cr" 'html-radio-buttons)
- (define-key map "\C-cc" 'html-checkboxes)
- (define-key map "\C-cl" 'html-list-item)
- (define-key map "\C-ch" 'html-href-anchor)
- (define-key map "\C-cn" 'html-name-anchor)
- (define-key map "\C-ci" 'html-image)))
+ (when html-quick-keys
+ (define-key map "\C-c-" 'html-horizontal-rule)
+ (define-key map "\C-co" 'html-ordered-list)
+ (define-key map "\C-cu" 'html-unordered-list)
+ (define-key map "\C-cr" 'html-radio-buttons)
+ (define-key map "\C-cc" 'html-checkboxes)
+ (define-key map "\C-cl" 'html-list-item)
+ (define-key map "\C-ch" 'html-href-anchor)
+ (define-key map "\C-cn" 'html-name-anchor)
+ (define-key map "\C-ci" 'html-image))
(define-key map "\C-c\C-s" 'html-autoview-mode)
(define-key map "\C-c\C-v" 'browse-url-of-buffer)
(define-key map [menu-bar html] (cons "HTML" menu-map))
map)
"Keymap for commands for use in HTML mode.")
-
(defvar html-face-tag-alist
'((bold . "b")
(italic . "i")
("var" . italic))
"Value of `sgml-tag-face-alist' for HTML mode.")
-
(defvar html-display-text
'((img . "[/]")
(hr . "----------")
(li . "o "))
"Value of `sgml-display-text' for HTML mode.")
+
\f
;; should code exactly HTML 3 here when that is finished
(defvar html-tag-alist
(let* ((1-7 '(("1") ("2") ("3") ("4") ("5") ("6") ("7")))
- (1-9 '(,@1-7 ("8") ("9")))
+ (1-9 `(,@1-7 ("8") ("9")))
(align '(("align" ("left") ("center") ("right"))))
(valign '(("top") ("middle") ("bottom") ("baseline")))
(rel '(("next") ("previous") ("parent") ("subdocument") ("made")))
("rel" ,@rel)
("rev" ,@rel)
("title")))
- (list '((nil \n ( "List item: "
- "<li>" str \n))))
+ (list '((nil \n ("List item: " "<li>" str
+ (if sgml-xml-mode "</li>") \n))))
(cell `(t
- ,align
+ ,@align
("valign" ,@valign)
("colspan" ,@1-9)
("rowspan" ,@1-9)
("base" t ,@href)
("dir" ,@list)
("font" nil "size" ("-1") ("+1") ("-2") ("+2") ,@1-7)
- ("form" (\n _ \n "<input type=\"submit\" value=\"\">")
+ ("form" (\n _ \n "<input type=\"submit\" value=\"\""
+ (if sgml-xml-mode "/>" ">"))
("action" ,@(cdr href)) ("method" ("get") ("post")))
("h1" ,@align)
("h2" ,@align)
("p" t ,@align)
("select" (nil \n
("Text: "
- "<option>" str \n))
+ "<option>" str (if sgml-xml-mode "</option>") \n))
,name ("size" ,@1-9) ("multiple" t))
("table" (nil \n
((completing-read "Cell kind: " '(("td") ("th"))
nil t "t")
- "<tr><" str ?> _ \n))
+ "<tr><" str ?> _
+ (if sgml-xml-mode (concat "<" str "></tr>")) \n))
("border" t ,@1-9) ("width" "10") ("cellpadding"))
("td" ,@cell)
("textarea" ,name ("rows" ,@1-9) ("cols" ,@1-9))
("acronym")
("address")
("array" (nil \n
- ("Item: " "<item>" str \n))
+ ("Item: " "<item>" str (if sgml-xml-mode "</item>") \n))
"align")
("au")
("b")
("blockquote" \n)
("body" \n ("background" ".gif") ("bgcolor" "#") ("text" "#")
("link" "#") ("alink" "#") ("vlink" "#"))
- ("box" (nil _ "<over>" _))
+ ("box" (nil _ "<over>" _ (if sgml-xml-mode "</over>")))
("br" t ("clear" ("left") ("right")))
("caption" ("valign" ("top") ("bottom")))
("center" \n)
("cite")
("code" \n)
- ("dd" t)
+ ("dd" ,(not sgml-xml-mode))
("del")
("dfn")
+ ("div")
("dl" (nil \n
( "Term: "
- "<dt>" str "<dd>" _ \n)))
- ("dt" (t _ "<dd>"))
+ "<dt>" str (if sgml-xml-mode "</dt>")
+ "<dd>" _ (if sgml-xml-mode "</dd>") \n)))
+ ("dt" (t _ (if sgml-xml-mode "</dt>")
+ "<dd>" (if sgml-xml-mode "</dd>") \n))
("em")
;("fn" "id" "fn") ; ???
("head" \n)
("html" (\n
"<head>\n"
"<title>" (setq str (read-input "Title: ")) "</title>\n"
+ "</head>\n"
"<body>\n<h1>" str "</h1>\n" _
"\n<address>\n<a href=\"mailto:"
user-mail-address
- "\">" (user-full-name) "</a>\n</address>"))
+ "\">" (user-full-name) "</a>\n</address>\n"
+ "</body>"
+ ))
("i")
("ins")
("isindex" t ("action") ("prompt"))
("kbd")
("lang")
- ("li" t)
+ ("li" ,(not sgml-xml-mode))
("math" \n)
("nobr")
("option" t ("value") ("label") ("selected" t))
("s")
("samp")
("small")
+ ("span" nil
+ ("class"
+ ("builtin")
+ ("comment")
+ ("constant")
+ ("function-name")
+ ("keyword")
+ ("string")
+ ("type")
+ ("variable-name")
+ ("warning")))
("strong")
("sub")
("sup")
("dir" . "Directory list (obsolete)")
("dl" . "Definition list")
("dt" . "Term to be definined")
- ("em" . "Emphasised")
+ ("em" . "Emphasised")
("embed" . "Embedded data in foreign format")
("fig" . "Figure")
("figa" . "Figure anchor")
("var" . "Math variable face")
("wbr" . "Enable <br> within <nobr>"))
"*Value of `sgml-tag-help' for HTML mode.")
+
\f
;;;###autoload
-(defun html-mode ()
+(define-derived-mode html-mode sgml-mode "HTML"
"Major mode based on SGML mode for editing HTML documents.
-This allows inserting skeleton costructs used in hypertext documents with
+This allows inserting skeleton constructs used in hypertext documents with
completion. See below for an introduction to HTML. Use
\\[browse-url-of-buffer] to see how this comes out. See also `sgml-mode' on
which this is based.
(eval-after-load \"sgml-mode\" '(aset sgml-char-names ?' nil))
\\{html-mode-map}"
- (interactive)
- (sgml-mode-common html-tag-face-alist html-display-text)
- (use-local-map html-mode-map)
+ (set (make-local-variable 'sgml-display-text) html-display-text)
+ (set (make-local-variable 'sgml-tag-face-alist) html-tag-face-alist)
(make-local-variable 'sgml-tag-alist)
(make-local-variable 'sgml-face-tag-alist)
(make-local-variable 'sgml-tag-help)
(make-local-variable 'outline-level)
(make-local-variable 'sentence-end)
(setq sentence-end
- "[.?!][]\"')}]*\\(<[^>]*>\\)*\\($\\| $\\|\t\\| \\)[ \t\n]*")
- (setq mode-name "HTML"
- major-mode 'html-mode
- sgml-tag-alist html-tag-alist
+ (if sentence-end-double-space
+ "[.?!][]\"')}]*\\(<[^>]*>\\)*\\($\\| $\\|\t\\| \\)[ \t\n]*"
+ "[.?!][]\"')}]*\\(<[^>]*>\\)*\\($\\|[ \t]\\)[ \t\n]*"))
+ (setq sgml-tag-alist html-tag-alist
sgml-face-tag-alist html-face-tag-alist
sgml-tag-help html-tag-help
outline-regexp "^.*<[Hh][1-6]\\>"
outline-heading-end-regexp "</[Hh][1-6]>"
outline-level (lambda ()
- (char-after (1- (match-end 0)))))
+ (char-before (match-end 0))))
(setq imenu-create-index-function 'html-imenu-index)
- (make-local-variable 'imenu-sort-function)
- (setq imenu-sort-function nil) ; sorting the menu defeats the purpose
- (run-hooks 'html-mode-hook))
-\f
+ (when sgml-xml-mode (setq mode-name "XHTML"))
+ (set (make-local-variable 'sgml-empty-tags)
+ ;; From HTML-4.01's loose.dtd, parsed with `sgml-parse-dtd',
+ ;; plus manual addition of "wbr".
+ '("area" "base" "basefont" "br" "col" "frame" "hr" "img" "input"
+ "isindex" "link" "meta" "param" "wbr"))
+ (set (make-local-variable 'sgml-unclosed-tags)
+ ;; From HTML-4.01's loose.dtd, parsed with `sgml-parse-dtd'.
+ '("body" "colgroup" "dd" "dt" "head" "html" "li" "option"
+ "p" "tbody" "td" "tfoot" "th" "thead" "tr"))
+ ;; It's for the user to decide if it defeats it or not -stef
+ ;; (make-local-variable 'imenu-sort-function)
+ ;; (setq imenu-sort-function nil) ; sorting the menu defeats the purpose
+ )
+
(defvar html-imenu-regexp
"\\s-*<h\\([1-9]\\)[^\n<>]*>\\(<[^\n<>]*>\\)*\\s-*\\([^\n<>]*\\)"
"*A regular expression matching a head line to be added to the menu.
(* 2 (1- (string-to-number (match-string 1))))
?\ )
(match-string 3))
- (save-excursion (beginning-of-line) (point)))
+ (line-beginning-position))
toc-index))))
(nreverse toc-index)))
(defun html-autoview-mode (&optional arg)
- "Toggle automatic viewing via `html-viewer' upon saving buffer.
+ "Toggle automatic viewing via `browse-url-of-buffer' upon saving buffer.
With positive prefix ARG always turns viewing on, with negative ARG always off.
Can be used as a value for `html-mode-hook'."
(interactive "P")
(and (boundp 'after-save-hook)
(memq 'browse-url-of-buffer after-save-hook))))
(setq after-save-hook (delq 'browse-url-of-buffer after-save-hook))
- (make-local-hook 'after-save-hook)
(add-hook 'after-save-hook 'browse-url-of-buffer nil t))
(message "Autoviewing turned %s."
(if arg "off" "on")))
+
\f
(define-skeleton html-href-anchor
"HTML anchor tag with href attribute."
(define-skeleton html-horizontal-rule
"HTML horizontal rule tag."
nil
- "<hr>" \n)
+ (if sgml-xml-mode "<hr/>" "<hr>") \n)
(define-skeleton html-image
"HTML image tag."
nil
- "<img src=\"" _ "\">")
+ "<img src=\"" _ "\""
+ (if sgml-xml-mode "/>" ">"))
(define-skeleton html-line
"HTML line break tag."
nil
- "<br>" \n)
+ (if sgml-xml-mode "<br/>" "<br>") \n)
(define-skeleton html-ordered-list
"HTML ordered list tags."
nil
"<ol>" \n
- "<li>" _ \n
+ "<li>" _ (if sgml-xml-mode "</li>") \n
"</ol>")
(define-skeleton html-unordered-list
"HTML unordered list tags."
nil
"<ul>" \n
- "<li>" _ \n
+ "<li>" _ (if sgml-xml-mode "</li>") \n
"</ul>")
(define-skeleton html-list-item
"HTML list item tag."
nil
(if (bolp) nil '\n)
- "<li>")
+ "<li>" _ (if sgml-xml-mode "</li>"))
(define-skeleton html-paragraph
"HTML paragraph tag."
nil
(if (bolp) nil ?\n)
- \n "<p>")
+ \n "<p>" _ (if sgml-xml-mode "</p>"))
(define-skeleton html-checkboxes
"Group of connected checkbox inputs."
"<input type=\"" (identity "checkbox") ; see comment above about identity
"\" name=\"" (or v1 (setq v1 (skeleton-read "Name: ")))
"\" value=\"" str ?\"
- (if (y-or-n-p "Set \"checked\" attribute? ")
- (funcall skeleton-transformation " checked")) ">"
+ (when (y-or-n-p "Set \"checked\" attribute? ")
+ (funcall skeleton-transformation " checked"))
+ (if sgml-xml-mode "/>" ">")
(skeleton-read "Text: " (capitalize str))
(or v2 (setq v2 (if (y-or-n-p "Newline after text? ")
- (funcall skeleton-transformation "<br>")
+ (funcall skeleton-transformation
+ (if sgml-xml-mode "<br/>" "<br>"))
"")))
\n))
"<input type=\"" (identity "radio") ; see comment above about identity
"\" name=\"" (or (car v2) (setcar v2 (skeleton-read "Name: ")))
"\" value=\"" str ?\"
- (if (and (not v1) (setq v1 (y-or-n-p "Set \"checked\" attribute? ")))
- (funcall skeleton-transformation " checked") ">")
+ (when (and (not v1) (setq v1 (y-or-n-p "Set \"checked\" attribute? ")))
+ (funcall skeleton-transformation " checked"))
+ (if sgml-xml-mode "/>" ">")
(skeleton-read "Text: " (capitalize str))
(or (cdr v2) (setcdr v2 (if (y-or-n-p "Newline after text? ")
- (funcall skeleton-transformation "<br>")
+ (funcall skeleton-transformation
+ (if sgml-xml-mode "<br/>" "<br>"))
"")))
\n))
+(provide 'sgml-mode)
+
;;; sgml-mode.el ends here