1 |
;;; sgml-mode.el --- SGML- and HTML-editing modes |
;;; sgml-mode.el --- SGML- and HTML-editing modes |
2 |
|
|
3 |
;; Copyright (C) 1992,95,96,98,2001,2002 Free Software Foundation, Inc. |
;; Copyright (C) 1992,95,96,98,2001,2002, 2003 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: James Clark <jjc@jclark.com> |
;; Author: James Clark <jjc@jclark.com> |
6 |
;; Maintainer: FSF |
;; Maintainer: FSF |
263 |
(regexp-opt (mapcar 'car sgml-tag-face-alist) t) |
(regexp-opt (mapcar 'car sgml-tag-face-alist) t) |
264 |
"\\([ \t][^>]*\\)?>\\([^<]+\\)</\\1>") |
"\\([ \t][^>]*\\)?>\\([^<]+\\)</\\1>") |
265 |
'(3 (cdr (assoc (downcase (match-string 1)) |
'(3 (cdr (assoc (downcase (match-string 1)) |
266 |
sgml-tag-face-alist)))))))) |
sgml-tag-face-alist)) prepend)))))) |
267 |
|
|
268 |
;; for font-lock, but must be defvar'ed after |
;; for font-lock, but must be defvar'ed after |
269 |
;; sgml-font-lock-keywords-1 and sgml-font-lock-keywords-2 above |
;; sgml-font-lock-keywords-1 and sgml-font-lock-keywords-2 above |
524 |
(delete-backward-char 1) |
(delete-backward-char 1) |
525 |
(insert char) |
(insert char) |
526 |
(undo-boundary) |
(undo-boundary) |
527 |
(delete-backward-char 1) |
(sgml-namify-char)) |
528 |
(cond |
|
529 |
((< char 256) |
(defun sgml-namify-char () |
530 |
(insert ?& |
"Change the char before point into its `&name;' equivalent. |
531 |
(or (aref sgml-char-names char) |
Uses `sgml-char-names'." |
532 |
(format "#%d" char)) |
(interactive) |
533 |
?\;)) |
(let* ((char (char-before)) |
534 |
((aref sgml-char-names-table char) |
(name |
535 |
(insert ?& (aref sgml-char-names-table char) ?\;)) |
(cond |
536 |
((let ((c (encode-char char 'ucs))) |
((null char) (error "No char before point")) |
537 |
(when c |
((< char 256) (or (aref sgml-char-names char) char)) |
538 |
(insert (format "&#%d;" c)) |
((aref sgml-char-names-table char)) |
539 |
t))) |
((encode-char char 'ucs))))) |
540 |
(t ; should be an error? -- fx |
(if (not name) |
541 |
(insert char)))) |
(error "Don't know the name of `%c'" char) |
542 |
|
(delete-backward-char 1) |
543 |
|
(insert (format (if (numberp name) "&#%d;" "&%s;") name))))) |
544 |
|
|
545 |
(defun sgml-name-self () |
(defun sgml-name-self () |
546 |
"Insert a symbolic character name according to `sgml-char-names'." |
"Insert a symbolic character name according to `sgml-char-names'." |
571 |
;; inserted literally, one should obtain it as the return value of a |
;; inserted literally, one should obtain it as the return value of a |
572 |
;; function, e.g. (identity "str"). |
;; function, e.g. (identity "str"). |
573 |
|
|
574 |
|
(defvar sgml-tag-last nil) |
575 |
|
(defvar sgml-tag-history nil) |
576 |
(define-skeleton sgml-tag |
(define-skeleton sgml-tag |
577 |
"Prompt for a tag and insert it, optionally with attributes. |
"Prompt for a tag and insert it, optionally with attributes. |
578 |
Completion and configuration are done according to `sgml-tag-alist'. |
Completion and configuration are done according to `sgml-tag-alist'. |
580 |
skeleton-transformation RET upcase RET, or put this in your `.emacs': |
skeleton-transformation RET upcase RET, or put this in your `.emacs': |
581 |
(setq sgml-transformation 'upcase)" |
(setq sgml-transformation 'upcase)" |
582 |
(funcall (or skeleton-transformation 'identity) |
(funcall (or skeleton-transformation 'identity) |
583 |
(completing-read "Tag: " sgml-tag-alist)) |
(setq sgml-tag-last |
584 |
|
(completing-read |
585 |
|
(if (> (length sgml-tag-last) 0) |
586 |
|
(format "Tag (default %s): " sgml-tag-last) |
587 |
|
"Tag: ") |
588 |
|
sgml-tag-alist nil nil nil 'sgml-tag-history sgml-tag-last))) |
589 |
?< str | |
?< str | |
590 |
(("") -1 '(undo-boundary) (identity "<")) | ; see comment above |
(("") -1 '(undo-boundary) (identity "<")) | ; see comment above |
591 |
`(("") '(setq v2 (sgml-attributes ,str t)) ?> |
`(("") '(setq v2 (sgml-attributes ,str t)) ?> |
695 |
"Skip to beginning of tag or matching opening tag if present. |
"Skip to beginning of tag or matching opening tag if present. |
696 |
With prefix argument ARG, repeat this ARG times." |
With prefix argument ARG, repeat this ARG times." |
697 |
(interactive "p") |
(interactive "p") |
698 |
|
;; FIXME: use sgml-get-context or something similar. |
699 |
(while (>= arg 1) |
(while (>= arg 1) |
700 |
(search-backward "<" nil t) |
(search-backward "<" nil t) |
701 |
(if (looking-at "</\\([^ \n\t>]+\\)") |
(if (looking-at "</\\([^ \n\t>]+\\)") |
702 |
;; end tag, skip any nested pairs |
;; end tag, skip any nested pairs |
703 |
(let ((case-fold-search t) |
(let ((case-fold-search t) |
704 |
(re (concat "</?" (regexp-quote (match-string 1))))) |
(re (concat "</?" (regexp-quote (match-string 1)) |
705 |
|
;; Ignore empty tags like <foo/>. |
706 |
|
"\\([^>]*[^/>]\\)?>"))) |
707 |
(while (and (re-search-backward re nil t) |
(while (and (re-search-backward re nil t) |
708 |
(eq (char-after (1+ (point))) ?/)) |
(eq (char-after (1+ (point))) ?/)) |
709 |
(forward-char 1) |
(forward-char 1) |
710 |
(sgml-skip-tag-backward 1)))) |
(sgml-skip-tag-backward 1)))) |
711 |
(setq arg (1- arg)))) |
(setq arg (1- arg)))) |
712 |
|
|
713 |
(defun sgml-skip-tag-forward (arg &optional return) |
(defun sgml-skip-tag-forward (arg) |
714 |
"Skip to end of tag or matching closing tag if present. |
"Skip to end of tag or matching closing tag if present. |
715 |
With prefix argument ARG, repeat this ARG times. |
With prefix argument ARG, repeat this ARG times. |
716 |
Return t iff after a closing tag." |
Return t iff after a closing tag." |
717 |
(interactive "p") |
(interactive "p") |
718 |
(setq return t) |
;; FIXME: Use sgml-get-context or something similar. |
719 |
(while (>= arg 1) |
;; It currently might jump to an unrelated </P> if the <P> |
720 |
(skip-chars-forward "^<>") |
;; we're skipping has no matching </P>. |
721 |
(if (eq (following-char) ?>) |
(let ((return t)) |
722 |
(up-list -1)) |
(with-syntax-table sgml-tag-syntax-table |
723 |
(if (looking-at "<\\([^/ \n\t>]+\\)") |
(while (>= arg 1) |
724 |
;; start tag, skip any nested same pairs _and_ closing tag |
(skip-chars-forward "^<>") |
725 |
(let ((case-fold-search t) |
(if (eq (following-char) ?>) |
726 |
(re (concat "</?" (regexp-quote (match-string 1)))) |
(up-list -1)) |
727 |
point close) |
(if (looking-at "<\\([^/ \n\t>]+\\)\\([^>]*[^/>]\\)?>") |
728 |
(forward-list 1) |
;; start tag, skip any nested same pairs _and_ closing tag |
729 |
(setq point (point)) |
(let ((case-fold-search t) |
730 |
(while (and (re-search-forward re nil t) |
(re (concat "</?" (regexp-quote (match-string 1)) |
731 |
(not (setq close |
;; Ignore empty tags like <foo/>. |
732 |
(eq (char-after (1+ (match-beginning 0))) ?/))) |
"\\([^>]*[^/>]\\)?>")) |
733 |
(not (up-list -1)) |
point close) |
734 |
(sgml-skip-tag-forward 1)) |
(forward-list 1) |
735 |
(setq close nil)) |
(setq point (point)) |
736 |
(if close |
;; FIXME: This re-search-forward will mistakenly match |
737 |
(up-list 1) |
;; tag-like text inside attributes. |
738 |
(goto-char point) |
(while (and (re-search-forward re nil t) |
739 |
(setq return))) |
(not (setq close |
740 |
(forward-list 1)) |
(eq (char-after (1+ (match-beginning 0))) ?/))) |
741 |
(setq arg (1- arg))) |
(goto-char (match-beginning 0)) |
742 |
return) |
(sgml-skip-tag-forward 1)) |
743 |
|
(setq close nil)) |
744 |
|
(unless close |
745 |
|
(goto-char point) |
746 |
|
(setq return nil))) |
747 |
|
(forward-list 1)) |
748 |
|
(setq arg (1- arg))) |
749 |
|
return))) |
750 |
|
|
751 |
(defun sgml-delete-tag (arg) |
(defun sgml-delete-tag (arg) |
752 |
|
;; FIXME: Should be called sgml-kill-tag or should not touch the kill-ring. |
753 |
"Delete tag on or after cursor, and matching closing or opening tag. |
"Delete tag on or after cursor, and matching closing or opening tag. |
754 |
With prefix argument ARG, repeat this ARG times." |
With prefix argument ARG, repeat this ARG times." |
755 |
(interactive "p") |
(interactive "p") |
783 |
(goto-char close) |
(goto-char close) |
784 |
(kill-sexp 1)) |
(kill-sexp 1)) |
785 |
(setq open (point)) |
(setq open (point)) |
786 |
(sgml-skip-tag-forward 1) |
(when (sgml-skip-tag-forward 1) |
787 |
(backward-list) |
(kill-sexp -1))) |
788 |
(forward-char) |
;; Delete any resulting empty line. If we didn't kill-sexp, |
789 |
(if (eq (aref (sgml-beginning-of-tag) 0) ?/) |
;; this *should* do nothing, because we're right after the tag. |
790 |
(kill-sexp 1))) |
(if (progn (forward-line 0) (looking-at "\\(?:[ \t]*$\\)\n?")) |
791 |
|
(delete-region (match-beginning 0) (match-end 0))) |
792 |
(goto-char open) |
(goto-char open) |
793 |
(kill-sexp 1))) |
(kill-sexp 1) |
794 |
|
(if (progn (forward-line 0) (looking-at "\\(?:[ \t]*$\\)\n?")) |
795 |
|
(delete-region (match-beginning 0) (match-end 0))))) |
796 |
(setq arg (1- arg)))) |
(setq arg (1- arg)))) |
797 |
|
|
798 |
|
|
800 |
(or (get 'sgml-tag 'invisible) |
(or (get 'sgml-tag 'invisible) |
801 |
(setplist 'sgml-tag |
(setplist 'sgml-tag |
802 |
(append '(invisible t |
(append '(invisible t |
|
intangible t |
|
803 |
point-entered sgml-point-entered |
point-entered sgml-point-entered |
804 |
rear-nonsticky t |
rear-nonsticky t |
805 |
read-only t) |
read-only t) |
964 |
(insert ?\")))) |
(insert ?\")))) |
965 |
|
|
966 |
(defun sgml-quote (start end &optional unquotep) |
(defun sgml-quote (start end &optional unquotep) |
967 |
"Quote SGML text in region. |
"Quote SGML text in region START ... END. |
968 |
With prefix argument, unquote the region." |
Only &, < and > are quoted, the rest is left untouched. |
969 |
(interactive "r\np") |
With prefix argument UNQUOTEP, unquote the region." |
970 |
(if (< start end) |
(interactive "r\nP") |
971 |
(goto-char start) |
(save-restriction |
972 |
(goto-char end) |
(narrow-to-region start end) |
973 |
(setq end start)) |
(goto-char (point-min)) |
974 |
(if unquotep |
(if unquotep |
975 |
(while (re-search-forward "&\\(amp\\|\\(l\\|\\(g\\)\\)t\\)[;\n]" end t) |
;; FIXME: We should unquote other named character references as well. |
976 |
(replace-match (if (match-end 3) ">" (if (match-end 2) "<" "&")))) |
(while (re-search-forward |
977 |
(while (re-search-forward "[&<>]" end t) |
"\\(&\\(amp\\|\\(l\\|\\(g\\)\\)t\\)\\)[][<>&;\n\t \"%!'(),/=?]" |
978 |
(replace-match (cdr (assq (char-before) '((?& . "&") |
nil t) |
979 |
(?< . "<") |
(replace-match (if (match-end 4) ">" (if (match-end 3) "<" "&")) t t |
980 |
(?> . ">")))))))) |
nil (if (eq (char-before (match-end 0)) ?\;) 0 1))) |
981 |
|
(while (re-search-forward "[&<>]" nil t) |
982 |
|
(replace-match (cdr (assq (char-before) '((?& . "&") |
983 |
|
(?< . "<") |
984 |
|
(?> . ">")))) |
985 |
|
t t))))) |
986 |
|
|
987 |
|
(defun sgml-pretty-print (beg end) |
988 |
|
"Simple-minded pretty printer for SGML. |
989 |
|
Re-indents the code and inserts newlines between BEG and END. |
990 |
|
You might want to turn on `auto-fill-mode' to get better results." |
991 |
|
;; TODO: |
992 |
|
;; - insert newline between some start-tag and text. |
993 |
|
;; - don't insert newline in front of some end-tags. |
994 |
|
(interactive "r") |
995 |
|
(save-excursion |
996 |
|
(if (< beg end) |
997 |
|
(goto-char beg) |
998 |
|
(goto-char end) |
999 |
|
(setq end beg) |
1000 |
|
(setq beg (point))) |
1001 |
|
;; Don't use narrowing because it screws up auto-indent. |
1002 |
|
(setq end (copy-marker end t)) |
1003 |
|
(with-syntax-table sgml-tag-syntax-table |
1004 |
|
(while (re-search-forward "<" end t) |
1005 |
|
(goto-char (match-beginning 0)) |
1006 |
|
(unless (or ;;(looking-at "</") |
1007 |
|
(progn (skip-chars-backward " \t") (bolp))) |
1008 |
|
(reindent-then-newline-and-indent)) |
1009 |
|
(forward-sexp 1))) |
1010 |
|
;; (indent-region beg end) |
1011 |
|
)) |
1012 |
|
|
1013 |
|
|
1014 |
;; Parsing |
;; Parsing |
1028 |
(and (>= start (point-min)) |
(and (>= start (point-min)) |
1029 |
(equal str (buffer-substring-no-properties start (point)))))) |
(equal str (buffer-substring-no-properties start (point)))))) |
1030 |
|
|
1031 |
(defun sgml-parse-tag-backward () |
(defun sgml-parse-tag-backward (&optional limit) |
1032 |
"Parse an SGML tag backward, and return information about the tag. |
"Parse an SGML tag backward, and return information about the tag. |
1033 |
Assume that parsing starts from within a textual context. |
Assume that parsing starts from within a textual context. |
1034 |
Leave point at the beginning of the tag." |
Leave point at the beginning of the tag." |
1035 |
(let (tag-type tag-start tag-end name) |
(let (tag-type tag-start tag-end name) |
1036 |
(or (search-backward ">" nil 'move) |
(or (search-backward ">" limit 'move) |
1037 |
(error "No tag found")) |
(error "No tag found")) |
1038 |
(setq tag-end (1+ (point))) |
(setq tag-end (1+ (point))) |
1039 |
(cond |
(cond |
1096 |
(/= (point) (sgml-tag-start (car context))) |
(/= (point) (sgml-tag-start (car context))) |
1097 |
(sgml-unclosed-tag-p (sgml-tag-name (car context))))) |
(sgml-unclosed-tag-p (sgml-tag-name (car context))))) |
1098 |
(setq tag-info (ignore-errors (sgml-parse-tag-backward)))) |
(setq tag-info (ignore-errors (sgml-parse-tag-backward)))) |
1099 |
|
|
1100 |
;; This tag may enclose things we thought were tags. If so, |
;; This tag may enclose things we thought were tags. If so, |
1101 |
;; discard them. |
;; discard them. |
1102 |
(while (and context |
(while (and context |
1103 |
(> (sgml-tag-end tag-info) |
(> (sgml-tag-end tag-info) |
1104 |
(sgml-tag-end (car context)))) |
(sgml-tag-end (car context)))) |
1105 |
(setq context (cdr context))) |
(setq context (cdr context))) |
1106 |
|
|
1107 |
(cond |
(cond |
1108 |
|
|
1109 |
;; start-tag |
;; start-tag |
1124 |
(t |
(t |
1125 |
;; The open and close tags don't match. |
;; The open and close tags don't match. |
1126 |
(if (not sgml-xml-mode) |
(if (not sgml-xml-mode) |
|
;; Assume the open tag is simply not closed. |
|
1127 |
(unless (sgml-unclosed-tag-p (sgml-tag-name tag-info)) |
(unless (sgml-unclosed-tag-p (sgml-tag-name tag-info)) |
1128 |
(message "Unclosed tag <%s>" (sgml-tag-name tag-info))) |
(message "Unclosed tag <%s>" (sgml-tag-name tag-info)) |
1129 |
|
(let ((tmp ignore)) |
1130 |
|
;; We could just assume that the tag is simply not closed |
1131 |
|
;; but it's a bad assumption when tags *are* closed but |
1132 |
|
;; not properly nested. |
1133 |
|
(while (and (cdr tmp) |
1134 |
|
(not (eq t (compare-strings |
1135 |
|
(sgml-tag-name tag-info) nil nil |
1136 |
|
(cadr tmp) nil nil t)))) |
1137 |
|
(setq tmp (cdr tmp))) |
1138 |
|
(if (cdr tmp) (setcdr tmp (cddr tmp))))) |
1139 |
(message "Unmatched tags <%s> and </%s>" |
(message "Unmatched tags <%s> and </%s>" |
1140 |
(sgml-tag-name tag-info) (pop ignore)))))) |
(sgml-tag-name tag-info) (pop ignore)))))) |
1141 |
|
|
1154 |
If FULL is non-nil, parse back to the beginning of the buffer." |
If FULL is non-nil, parse back to the beginning of the buffer." |
1155 |
(interactive "P") |
(interactive "P") |
1156 |
(with-output-to-temp-buffer "*XML Context*" |
(with-output-to-temp-buffer "*XML Context*" |
1157 |
(pp (save-excursion (sgml-get-context full))))) |
(save-excursion |
1158 |
|
(let ((context (sgml-get-context))) |
1159 |
|
(when full |
1160 |
|
(let ((more nil)) |
1161 |
|
(while (setq more (sgml-get-context)) |
1162 |
|
(setq context (nconc more context))))) |
1163 |
|
(pp context))))) |
1164 |
|
|
1165 |
|
|
1166 |
;; Editing shortcuts |
;; Editing shortcuts |
1167 |
|
|
1168 |
(defun sgml-close-tag () |
(defun sgml-close-tag () |
1169 |
"Insert an close-tag for the current element." |
"Close current element. |
1170 |
|
Depending on context, inserts a matching close-tag, or closes |
1171 |
|
the current start-tag or the current comment or the current cdata, ..." |
1172 |
(interactive) |
(interactive) |
1173 |
(case (car (sgml-lexical-context)) |
(case (car (sgml-lexical-context)) |
1174 |
(comment (insert " -->")) |
(comment (insert " -->")) |
1283 |
(goto-char there) |
(goto-char there) |
1284 |
(+ (current-column) |
(+ (current-column) |
1285 |
(* sgml-basic-offset (length context)))))) |
(* sgml-basic-offset (length context)))))) |
1286 |
|
|
1287 |
(otherwise |
(otherwise |
1288 |
(error "Unrecognised context %s" (car lcon))) |
(error "Unrecognised context %s" (car lcon))) |
1289 |
|
|
1312 |
(if (re-search-forward "^\\([ \t]+\\)<" 500 'noerror) |
(if (re-search-forward "^\\([ \t]+\\)<" 500 'noerror) |
1313 |
(progn |
(progn |
1314 |
(set (make-local-variable 'sgml-basic-offset) |
(set (make-local-variable 'sgml-basic-offset) |
1315 |
(length (match-string 1))) |
(1- (current-column))) |
1316 |
(message "Guessed sgml-basic-offset = %d" |
(message "Guessed sgml-basic-offset = %d" |
1317 |
sgml-basic-offset) |
sgml-basic-offset) |
1318 |
)))) |
)))) |
1764 |
The third `match-string' will be the used in the menu.") |
The third `match-string' will be the used in the menu.") |
1765 |
|
|
1766 |
(defun html-imenu-index () |
(defun html-imenu-index () |
1767 |
"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." |
1768 |
(let (toc-index) |
(let (toc-index) |
1769 |
(save-excursion |
(save-excursion |
1770 |
(goto-char (point-min)) |
(goto-char (point-min)) |
1778 |
toc-index)))) |
toc-index)))) |
1779 |
(nreverse toc-index))) |
(nreverse toc-index))) |
1780 |
|
|
1781 |
(defun html-autoview-mode (&optional arg) |
(define-minor-mode html-autoview-mode |
1782 |
"Toggle automatic viewing via `browse-url-of-buffer' upon saving buffer. |
"Toggle automatic viewing via `browse-url-of-buffer' upon saving buffer. |
1783 |
With positive prefix ARG always turns viewing on, with negative ARG always off. |
With positive prefix ARG always turns viewing on, with negative ARG always off. |
1784 |
Can be used as a value for `html-mode-hook'." |
Can be used as a value for `html-mode-hook'." |
1785 |
(interactive "P") |
nil nil nil |
1786 |
(if (setq arg (if arg |
:group 'sgml |
1787 |
(< (prefix-numeric-value arg) 0) |
(if html-autoview-mode |
1788 |
(and (boundp 'after-save-hook) |
(add-hook 'after-save-hook 'browse-url-of-buffer nil t) |
1789 |
(memq 'browse-url-of-buffer after-save-hook)))) |
(remove-hook 'after-save-hook 'browse-url-of-buffer t))) |
|
(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"))) |
|
1790 |
|
|
1791 |
|
|
1792 |
(define-skeleton html-href-anchor |
(define-skeleton html-href-anchor |