;;; sgml-mode.el --- SGML- and HTML-editing modes
-;; Copyright (C) 1992,95,96,98,2001,2002 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1995, 1996, 1998, 2001, 2002, 2003, 2004, 2005
+;; Free Software Foundation, Inc.
;; Author: James Clark <jjc@jclark.com>
;; Maintainer: FSF
(eval-when-compile
(require 'skeleton)
- (require 'outline))
+ (require 'outline)
+ (require 'cl))
(defgroup sgml nil
"SGML editing mode"
with comments, so we normally turn it off.")
(defvar sgml-quick-keys nil
- "Use <, >, &, SPC and `sgml-specials' keys \"electrically\" when non-nil.
+ "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 (make-keymap)) ;`sparse' doesn't allow binding to charsets.
(menu-map (make-sparse-keymap "SGML")))
(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)
(when sgml-quick-keys
map)
"Keymap for SGML mode. See also `sgml-specials'.")
-
(defun sgml-make-syntax-table (specials)
(let ((table (make-syntax-table text-mode-syntax-table)))
(modify-syntax-entry ?< "(>" table)
table)
"Syntax table used to parse SGML tags.")
-
(defcustom sgml-name-8bit-mode nil
"*When non-nil, insert non-ASCII characters as named entities."
:type 'boolean
"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.
(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.
(defcustom sgml-slash-distance 1000
:type '(choice (const nil) integer)
:group 'sgml)
+(defconst sgml-namespace-re "[_[:alpha:]][-_.[:alnum:]]*")
(defconst sgml-name-re "[_:[:alpha:]][-_.:[:alnum:]]*")
(defconst sgml-tag-name-re (concat "<\\([!/?]?" sgml-name-re "\\)"))
(defconst sgml-attrs-re "\\(?:[^\"'/><]\\|\"[^\"]*\"\\|'[^']*'\\)*")
"Regular expression that matches a non-empty start tag.
Any terminating `>' or `/' is not matched.")
+(defface sgml-namespace-face
+ '((t (:inherit font-lock-builtin-face)))
+ "`sgml-mode' face used to highlight the namespace part of identifiers.")
+(defvar sgml-namespace-face 'sgml-namespace-face)
;; internal
(defconst sgml-font-lock-keywords-1
`((,(concat "<\\([!?]" sgml-name-re "\\)") 1 font-lock-keyword-face)
- (,(concat "<\\(/?" sgml-name-re"\\)") 1 font-lock-function-name-face)
+ ;; We could use the simpler "\\(" sgml-namespace-re ":\\)?" instead,
+ ;; but it would cause a bit more backtracking in the re-matcher.
+ (,(concat "</?\\(" sgml-namespace-re "\\)\\(?::\\(" sgml-name-re "\\)\\)?")
+ (1 (if (match-end 2) sgml-namespace-face font-lock-function-name-face))
+ (2 font-lock-function-name-face nil t))
;; FIXME: this doesn't cover the variables using a default value.
- (,(concat "\\(" sgml-name-re "\\)=[\"']") 1 font-lock-variable-name-face)
+ (,(concat "\\(" sgml-namespace-re "\\)\\(?::\\("
+ sgml-name-re "\\)\\)?=[\"']")
+ (1 (if (match-end 2) sgml-namespace-face font-lock-variable-name-face))
+ (2 font-lock-variable-name-face nil t))
(,(concat "[&%]" sgml-name-re ";?") . font-lock-variable-name-face)))
(defconst sgml-font-lock-keywords-2
(regexp-opt (mapcar 'car sgml-tag-face-alist) t)
"\\([ \t][^>]*\\)?>\\([^<]+\\)</\\1>")
'(3 (cdr (assoc (downcase (match-string 1))
- sgml-tag-face-alist))))))))
+ sgml-tag-face-alist)) prepend))))))
;; for font-lock, but must be defvar'ed after
;; sgml-font-lock-keywords-1 and sgml-font-lock-keywords-2 above
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)))
Otherwise, it is set to be buffer-local when the file has
a DOCTYPE or an XML declaration."
:type 'boolean
- :version "21.2"
+ :version "22.1"
:group 'sgml)
(defvar sgml-empty-tags nil
(looking-at "\\s-*<\\?xml")
(when (re-search-forward
(eval-when-compile
- (mapconcat 'identity
- '("<!DOCTYPE" "\\(\\w+\\)" "\\(\\w+\\)"
+ (mapconcat 'identity
+ '("<!DOCTYPE" "\\(\\w+\\)" "\\(\\w+\\)"
"\"\\([^\"]+\\)\"" "\"\\([^\"]+\\)\"")
"\\s-+"))
nil 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)))
(progn
(concat "<" face ">"))
(error "Face not configured for %s mode" mode-name)))
+(defun sgml-fill-nobreak ()
+ ;; Don't break between a tag name and its first argument.
+ (save-excursion
+ (skip-chars-backward " \t")
+ (and (not (zerop (skip-syntax-backward "w_")))
+ (skip-chars-backward "/?!")
+ (eq (char-before) ?<))))
;;;###autoload
(define-derived-mode sgml-mode text-mode "SGML"
"Major mode for editing SGML documents.
Makes > match <.
-Keys <, &, SPC within <>, \" and ' can be electric depending on
+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
(set (make-local-variable 'paragraph-separate)
(concat paragraph-start "$"))
(set (make-local-variable 'adaptive-fill-regexp) "[ \t]*")
+ (add-hook 'fill-nobreak-predicate 'sgml-fill-nobreak nil 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)
;; 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 "\\)")))
-
+ ;; This definition has an HTML leaning but probably fits well for other modes.
+ (setq imenu-generic-expression
+ `((nil
+ ,(concat "<!\\(element\\|entity\\)[ \t\n]+%?[ \t\n]*\\("
+ sgml-name-re "\\)")
+ 2)
+ ("Id"
+ ,(concat "<[^>]+[ \t\n]+[Ii][Dd]=\\(['\"]"
+ (if sgml-xml-mode "" "?")
+ "\\)\\(" sgml-name-re "\\)\\1")
+ 2)
+ ("Name"
+ ,(concat "<[^>]+[ \t\n]+[Nn][Aa][Mm][Ee]=\\(['\"]"
+ (if sgml-xml-mode "" "?")
+ "\\)\\(" sgml-name-re "\\)\\1")
+ 2))))
+
+;; Some programs (such as Glade 2) generate XML which has
+;; -*- mode: xml -*-.
+;;;###autoload
+(defalias 'xml-mode 'sgml-mode)
(defun sgml-comment-indent ()
(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."
(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.
(delete-backward-char 1)
(insert char)
(undo-boundary)
- (delete-backward-char 1)
- (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))))
+ (sgml-namify-char))
+
+(defun sgml-namify-char ()
+ "Change the char before point into its `&name;' equivalent.
+Uses `sgml-char-names'."
+ (interactive)
+ (let* ((char (char-before))
+ (name
+ (cond
+ ((null char) (error "No char before point"))
+ ((< char 256) (or (aref sgml-char-names char) char))
+ ((aref sgml-char-names-table char))
+ ((encode-char char 'ucs)))))
+ (if (not name)
+ (error "Don't know the name of `%c'" char)
+ (delete-backward-char 1)
+ (insert (format (if (numberp name) "&#%d;" "&%s;") name)))))
(defun sgml-name-self ()
"Insert a symbolic character name according to `sgml-char-names'."
;; inserted literally, one should obtain it as the return value of a
;; function, e.g. (identity "str").
+(defvar sgml-tag-last nil)
+(defvar sgml-tag-history nil)
(define-skeleton sgml-tag
"Prompt for a tag and insert it, optionally with attributes.
Completion and configuration are done according to `sgml-tag-alist'.
If you like tags and attributes in uppercase do \\[set-variable]
skeleton-transformation RET upcase RET, or put this in your `.emacs':
(setq sgml-transformation 'upcase)"
- (funcall skeleton-transformation
- (completing-read "Tag: " sgml-tag-alist))
+ (funcall (or skeleton-transformation 'identity)
+ (setq sgml-tag-last
+ (completing-read
+ (if (> (length sgml-tag-last) 0)
+ (format "Tag (default %s): " sgml-tag-last)
+ "Tag: ")
+ sgml-tag-alist nil nil nil 'sgml-tag-history sgml-tag-last)))
?< str |
(("") -1 '(undo-boundary) (identity "<")) | ; see comment above
`(("") '(setq v2 (sgml-attributes ,str t)) ?>
(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 (&optional arg)
"Name self unless in position to end a tag or a prefix ARG is given."
(interactive "P")
"Skip to beginning of tag or matching opening tag if present.
With prefix argument ARG, repeat this ARG times."
(interactive "p")
+ ;; FIXME: use sgml-get-context or something similar.
(while (>= arg 1)
(search-backward "<" nil t)
(if (looking-at "</\\([^ \n\t>]+\\)")
;; end tag, skip any nested pairs
(let ((case-fold-search t)
- (re (concat "</?" (regexp-quote (match-string 1)))))
+ (re (concat "</?" (regexp-quote (match-string 1))
+ ;; Ignore empty tags like <foo/>.
+ "\\([^>]*[^/>]\\)?>")))
(while (and (re-search-backward re nil t)
(eq (char-after (1+ (point))) ?/))
(forward-char 1)
(sgml-skip-tag-backward 1))))
(setq arg (1- arg))))
-(defun sgml-skip-tag-forward (arg &optional return)
+(defun sgml-skip-tag-forward (arg)
"Skip to end of tag or matching closing tag if present.
With prefix argument ARG, repeat this ARG times.
Return t iff after a closing tag."
(interactive "p")
- (setq return t)
- (while (>= arg 1)
- (skip-chars-forward "^<>")
- (if (eq (following-char) ?>)
- (up-list -1))
- (if (looking-at "<\\([^/ \n\t>]+\\)")
- ;; start tag, skip any nested same pairs _and_ closing tag
- (let ((case-fold-search t)
- (re (concat "</?" (regexp-quote (match-string 1))))
- point close)
- (forward-list 1)
- (setq point (point))
- (while (and (re-search-forward re nil t)
- (not (setq close
- (eq (char-after (1+ (match-beginning 0))) ?/)))
- (not (up-list -1))
- (sgml-skip-tag-forward 1))
- (setq close nil))
- (if close
- (up-list 1)
- (goto-char point)
- (setq return)))
- (forward-list 1))
- (setq arg (1- arg)))
- return)
+ ;; FIXME: Use sgml-get-context or something similar.
+ ;; It currently might jump to an unrelated </P> if the <P>
+ ;; we're skipping has no matching </P>.
+ (let ((return t))
+ (with-syntax-table sgml-tag-syntax-table
+ (while (>= arg 1)
+ (skip-chars-forward "^<>")
+ (if (eq (following-char) ?>)
+ (up-list -1))
+ (if (looking-at "<\\([^/ \n\t>]+\\)\\([^>]*[^/>]\\)?>")
+ ;; start tag, skip any nested same pairs _and_ closing tag
+ (let ((case-fold-search t)
+ (re (concat "</?" (regexp-quote (match-string 1))
+ ;; Ignore empty tags like <foo/>.
+ "\\([^>]*[^/>]\\)?>"))
+ point close)
+ (forward-list 1)
+ (setq point (point))
+ ;; FIXME: This re-search-forward will mistakenly match
+ ;; tag-like text inside attributes.
+ (while (and (re-search-forward re nil t)
+ (not (setq close
+ (eq (char-after (1+ (match-beginning 0))) ?/)))
+ (goto-char (match-beginning 0))
+ (sgml-skip-tag-forward 1))
+ (setq close nil))
+ (unless close
+ (goto-char point)
+ (setq return nil)))
+ (forward-list 1))
+ (setq arg (1- arg)))
+ return)))
(defun sgml-delete-tag (arg)
+ ;; FIXME: Should be called sgml-kill-tag or should not touch the kill-ring.
"Delete tag on or after cursor, and matching closing or opening tag.
With prefix argument ARG, repeat this ARG times."
(interactive "p")
(goto-char close)
(kill-sexp 1))
(setq open (point))
- (sgml-skip-tag-forward 1)
- (backward-list)
- (forward-char)
- (if (eq (aref (sgml-beginning-of-tag) 0) ?/)
- (kill-sexp 1)))
+ (when (sgml-skip-tag-forward 1)
+ (kill-sexp -1)))
+ ;; Delete any resulting empty line. If we didn't kill-sexp,
+ ;; this *should* do nothing, because we're right after the tag.
+ (if (progn (forward-line 0) (looking-at "\\(?:[ \t]*$\\)\n?"))
+ (delete-region (match-beginning 0) (match-end 0)))
(goto-char open)
- (kill-sexp 1)))
+ (kill-sexp 1)
+ (if (progn (forward-line 0) (looking-at "\\(?:[ \t]*$\\)\n?"))
+ (delete-region (match-beginning 0) (match-end 0)))))
(setq arg (1- arg))))
+
\f
;; Put read-only last to enable setting this even when read-only enabled.
(or (get 'sgml-tag 'invisible)
(setplist 'sgml-tag
(append '(invisible t
- intangible t
point-entered sgml-point-entered
rear-nonsticky t
read-only t)
(eq (preceding-char) ?>)))
(backward-list)
(forward-list)))))))
+
\f
(autoload 'compile-internal "compile")
(save-some-buffers (not compilation-ask-about-save) nil)
(compile-internal command "No more errors"))
+(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)))
(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', ....
-Return nil if we are inside text (i.e. outside of any kind of tag).
+TYPE is one of `string', `comment', `tag', `cdata', or `text'.
-If non-nil LIMIT is a nearby position before point outside of any tag."
- ;; As usual, it's difficult to get a reliable answer without parsing the
- ;; whole buffer. We'll assume that a tag at indentation is outside of
- ;; any string or tag or comment or ...
+Optional argument LIMIT is the position to start parsing from.
+If nil, start from a preceding tag at indentation."
(save-excursion
(let ((pos (point))
- (state nil))
- (if limit (goto-char limit)
- ;; Hopefully this regexp will match something that's not inside
- ;; a tag and also hopefully the match is nearby.
- (re-search-backward "^[ \t]*<[_:[:alpha:]/%!?#]" nil 'move))
+ 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)
- ;; We skipped text and reached a tag. Parse it.
- ;; FIXME: this does not handle CDATA and funny stuff yet.
- (setq state (parse-partial-sexp (point) pos 0)))
- (cond
- ((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 nil))))))
+ (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.
(when (looking-at sgml-tag-name-re)
(match-string-no-properties 1)))
(if top-level nil
- (when context
+ (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.
+ "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 ?\"))))
(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) '((?& . "&")
- (?< . "<")
- (?> . ">"))))))))
+ "Quote SGML text in region START ... END.
+Only &, < and > are quoted, the rest is left untouched.
+With prefix argument UNQUOTEP, unquote the region."
+ (interactive "r\nP")
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (if unquotep
+ ;; FIXME: We should unquote other named character references as well.
+ (while (re-search-forward
+ "\\(&\\(amp\\|\\(l\\|\\(g\\)\\)t\\)\\)[][<>&;\n\t \"%!'(),/=?]"
+ nil t)
+ (replace-match (if (match-end 4) ">" (if (match-end 3) "<" "&")) t t
+ nil (if (eq (char-before (match-end 0)) ?\;) 0 1)))
+ (while (re-search-forward "[&<>]" nil t)
+ (replace-match (cdr (assq (char-before) '((?& . "&")
+ (?< . "<")
+ (?> . ">"))))
+ t t)))))
+
+(defun sgml-pretty-print (beg end)
+ "Simple-minded pretty printer for SGML.
+Re-indents the code and inserts newlines between BEG and END.
+You might want to turn on `auto-fill-mode' to get better results."
+ ;; TODO:
+ ;; - insert newline between some start-tag and text.
+ ;; - don't insert newline in front of some end-tags.
+ (interactive "r")
+ (save-excursion
+ (if (< beg end)
+ (goto-char beg)
+ (goto-char end)
+ (setq end beg)
+ (setq beg (point)))
+ ;; Don't use narrowing because it screws up auto-indent.
+ (setq end (copy-marker end t))
+ (with-syntax-table sgml-tag-syntax-table
+ (while (re-search-forward "<" end t)
+ (goto-char (match-beginning 0))
+ (unless (or ;;(looking-at "</")
+ (progn (skip-chars-backward " \t") (bolp)))
+ (reindent-then-newline-and-indent))
+ (forward-sexp 1)))
+ ;; (indent-region beg end)
+ ))
+
+\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-tag-text-p (start end)
+ "Return non-nil if text between START and END is a tag.
+Checks among other things that the tag does not contain spurious
+unquoted < or > chars inside, which would indicate that it
+really isn't a tag after all."
+ (save-excursion
+ (with-syntax-table sgml-tag-syntax-table
+ (let ((pps (parse-partial-sexp start end 2)))
+ (and (= (nth 0 pps) 0))))))
+
+(defun sgml-parse-tag-backward (&optional limit)
+ "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."
+ (catch 'found
+ (let (tag-type tag-start tag-end name)
+ (or (re-search-backward "[<>]" limit 'move)
+ (error "No tag found"))
+ (when (eq (char-after) ?<)
+ ;; Oops!! Looks like we were not in a textual context after all!.
+ ;; Let's try to recover.
+ (with-syntax-table sgml-tag-syntax-table
+ (let ((pos (point)))
+ (condition-case nil
+ (forward-sexp)
+ (scan-error
+ ;; This < seems to be just a spurious one, let's ignore it.
+ (goto-char pos)
+ (throw 'found (sgml-parse-tag-backward limit))))
+ ;; Check it is really a tag, without any extra < or > inside.
+ (unless (sgml-tag-text-p pos (point))
+ (goto-char pos)
+ (throw 'found (sgml-parse-tag-backward limit)))
+ (forward-char -1))))
+ (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)
+ (condition-case nil
+ (backward-sexp)
+ (scan-error
+ ;; This > isn't really the end of a tag. Skip it.
+ (goto-char (1- tag-end))
+ (throw 'found (sgml-parse-tag-backward limit))))
+ (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 until)
+ "Determine the context of the current position.
+By default, parse until we find a start-tag as the first thing on a line.
+If UNTIL is `empty', return even if the context is empty (i.e.
+we just skipped over some element and got to a beginning of line).
+
+The context is a list of tag-info structures. The last one is the tag
+immediately enclosing the current position.
+
+Point is assumed to be outside of any tag. If we discover that it's
+not the case, the first tag returned is the one inside which we are."
+ (let ((here (point))
+ (stack nil)
+ (ignore nil)
+ (context nil)
+ tag-info)
+ ;; CONTEXT keeps track of the tag-stack
+ ;; STACK keeps track of the end tags we've seen (and thus the start-tags
+ ;; we'll have to ignore) when skipping over matching open..close pairs.
+ ;; IGNORE is a list of tags that can be ignored because they have been
+ ;; closed implicitly.
+ (skip-chars-backward " \t\n") ; Make sure we're not at indentation.
+ (while
+ (and (not (eq until 'now))
+ (or stack
+ (not (if until (eq until '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
+ ((> (sgml-tag-end tag-info) here)
+ ;; Oops!! Looks like we were not outside of any tag, after all.
+ (push tag-info context)
+ (setq until 'now))
+
+ ;; start-tag
+ ((eq (sgml-tag-type tag-info) 'open)
+ (cond
+ ((null stack)
+ (if (member-ignore-case (sgml-tag-name tag-info) ignore)
+ ;; There was an implicit end-tag.
+ nil
+ (push tag-info context)
+ ;; We're changing context so the tags implicitly closed inside
+ ;; the previous context aren't implicitly closed here any more.
+ ;; [ Well, actually it depends, but we don't have the info about
+ ;; when it doesn't and when it does. --Stef ]
+ (setq ignore nil)))
+ ((eq t (compare-strings (sgml-tag-name tag-info) nil nil
+ (car stack) nil nil t))
+ (setq stack (cdr stack)))
+ (t
+ ;; The open and close tags don't match.
+ (if (not sgml-xml-mode)
+ (unless (sgml-unclosed-tag-p (sgml-tag-name tag-info))
+ (message "Unclosed tag <%s>" (sgml-tag-name tag-info))
+ (let ((tmp stack))
+ ;; We could just assume that the tag is simply not closed
+ ;; but it's a bad assumption when tags *are* closed but
+ ;; not properly nested.
+ (while (and (cdr tmp)
+ (not (eq t (compare-strings
+ (sgml-tag-name tag-info) nil nil
+ (cadr tmp) nil nil t))))
+ (setq tmp (cdr tmp)))
+ (if (cdr tmp) (setcdr tmp (cddr tmp)))))
+ (message "Unmatched tags <%s> and </%s>"
+ (sgml-tag-name tag-info) (pop stack)))))
+
+ (if (and (null stack) (sgml-unclosed-tag-p (sgml-tag-name tag-info)))
+ ;; This is a top-level open of an implicitly closed tag, so any
+ ;; occurrence of such an open tag at the same level can be ignored
+ ;; because it's been implicitly closed.
+ (push (sgml-tag-name tag-info) 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) stack)))
+ ))
+
+ ;; 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*"
+ (save-excursion
+ (let ((context (sgml-get-context)))
+ (when full
+ (let ((more nil))
+ (while (setq more (sgml-get-context))
+ (setq context (nconc more context)))))
+ (pp context)))))
+
\f
+;; Editing shortcuts
-(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
+(defun sgml-close-tag ()
+ "Close current element.
+Depending on context, inserts a matching close-tag, or closes
+the current start-tag or the current comment or the current cdata, ..."
+ (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 (&optional lcon)
+ "Calculate the column to which this line should be indented.
+LCON is the lexical context, if any."
+ (unless lcon (setq 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))
- (looking-at "[ \t]*$")))
+ (or (looking-at "[ \t]*$")
+ (if mark (not (looking-at "[ \t]*--"))))))
(if (> (point) (cdr lcon))
- ;; Previous line is inside the string.
- (current-indentation)
+ ;; Previous line is inside the comment.
+ (skip-chars-forward " \t")
(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)))
-
- (tag
+ ;; Skip `<!' to get to the `--' with which we want to align.
+ (search-forward "--")
+ (goto-char (match-beginning 0)))
+ (when (and (not mark) (looking-at "--"))
+ (forward-char 2) (skip-chars-forward " \t"))
+ (current-column)))
+
+ ;; We don't know how to indent it. Let's be honest about it.
+ (cdata nil)
+
+ (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)))
- (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)))
-
- (t
- (while (looking-at "</")
- (forward-sexp 1)
- (skip-chars-forward " \t"))
- (let ((context (xml-lite-get-context)))
- (cond
- ((null context) 0) ; no context
- (t
- (let ((here (point)))
- (goto-char (xml-lite-tag-end (car context)))
- (skip-chars-forward " \t\n")
- (if (and (< (point) here) (xml-lite-at-indentation-p))
- (current-column)
- (goto-char (xml-lite-tag-start (car context)))
- (+ (current-column)
- (* sgml-basic-offset (length context))))))))))))
+ (+ (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.
+ (cond
+ ;; If we were not in a text context after all, let's try again.
+ ((and context (> (sgml-tag-end (car context)) here))
+ (goto-char here)
+ (sgml-calculate-indent
+ (cons (if (memq (sgml-tag-type (car context)) '(comment cdata))
+ (sgml-tag-type (car context)) 'tag)
+ (sgml-tag-start (car context)))))
+ ;; Align on the first element after the nearest open-tag, if any.
+ ((and context
+ (goto-char (sgml-tag-end (car context)))
+ (skip-chars-forward " \t\n")
+ (< (point) here) (sgml-at-indentation-p))
+ (current-column))
+ (t
+ (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."
(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))))
+ (if (null indent-col)
+ 'noindent
+ (if savep
+ (save-excursion (indent-line-to indent-col))
+ (indent-line-to indent-col)))))
+
+(defun sgml-guess-indent ()
+ "Guess an appropriate value for `sgml-basic-offset'.
+Base the guessed identation level on the first indented tag in the buffer.
+Add this to `sgml-mode-hook' for convenience."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward "^\\([ \t]+\\)<" 500 'noerror)
+ (progn
+ (set (make-local-variable 'sgml-basic-offset)
+ (1- (current-column)))
+ (message "Guessed sgml-basic-offset = %d"
+ sgml-basic-offset)
+ ))))
(defun sgml-parse-dtd ()
"Simplistic parse of the current buffer as a DTD.
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
+\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")))
("var" . "Math variable face")
("wbr" . "Enable <br> within <nobr>"))
"*Value of `sgml-tag-help' for HTML mode.")
+
\f
;;;###autoload
(define-derived-mode html-mode sgml-mode "HTML"
;; (make-local-variable 'imenu-sort-function)
;; (setq imenu-sort-function nil) ; sorting the menu defeats the purpose
)
-\f
+
(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.
The third `match-string' will be the used in the menu.")
(defun html-imenu-index ()
- "Return an table of contents for an HTML buffer for use with Imenu."
+ "Return a table of contents for an HTML buffer for use with Imenu."
(let (toc-index)
(save-excursion
(goto-char (point-min))
toc-index))))
(nreverse toc-index)))
-(defun html-autoview-mode (&optional arg)
+(define-minor-mode html-autoview-mode
"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")
- (if (setq arg (if arg
- (< (prefix-numeric-value arg) 0)
- (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))
- (add-hook 'after-save-hook 'browse-url-of-buffer nil t))
- (message "Autoviewing turned %s."
- (if arg "off" "on")))
+ nil nil nil
+ :group 'sgml
+ (if html-autoview-mode
+ (add-hook 'after-save-hook 'browse-url-of-buffer nil t)
+ (remove-hook 'after-save-hook 'browse-url-of-buffer t)))
+
\f
(define-skeleton html-href-anchor
"HTML anchor tag with href attribute."
(provide 'sgml-mode)
+;; arch-tag: 9675da94-b7f9-4bda-ad19-73ed7b4fb401
;;; sgml-mode.el ends here
HCoop / bpt / emacs.git / blobdiff