/[emacs]/emacs/lisp/textmodes/sgml-mode.el
ViewVC logotype

Diff of /emacs/lisp/textmodes/sgml-mode.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.88 by walters, Tue May 28 16:51:06 2002 UTC revision 1.88.2.1 by miles, Fri Apr 4 06:20:40 2003 UTC
# Line 1  Line 1 
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
# Line 263  Any terminating `>' or `/' is not matche Line 263  Any terminating `>' or `/' is not matche
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
# Line 524  encoded keyboard operation." Line 524  encoded keyboard operation."
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'."
# Line 569  This only works for Latin-1 input." Line 571  This only works for Latin-1 input."
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'.
# Line 576  If you like tags and attributes in upper Line 580  If you like tags and attributes in upper
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 "&lt;")) |        ; see comment above    (("") -1 '(undo-boundary) (identity "&lt;")) |        ; see comment above
591    `(("") '(setq v2 (sgml-attributes ,str t)) ?>    `(("") '(setq v2 (sgml-attributes ,str t)) ?>
# Line 686  With prefix argument, only self insert." Line 695  With prefix argument, only self insert."
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")
# Line 763  With prefix argument ARG, repeat this AR Line 783  With prefix argument ARG, repeat this AR
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    
# Line 777  With prefix argument ARG, repeat this AR Line 800  With prefix argument ARG, repeat this AR
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)
# Line 942  See `sgml-tag-alist' for info about attr Line 964  See `sgml-tag-alist' for info about attr
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) '((?& . "&amp;")                  nil t)
979                                                  (?< . "&lt;")            (replace-match (if (match-end 4) ">" (if (match-end 3) "<" "&")) t t
980                                                  (?> . "&gt;"))))))))                           nil (if (eq (char-before (match-end 0)) ?\;) 0 1)))
981          (while (re-search-forward "[&<>]" nil t)
982            (replace-match (cdr (assq (char-before) '((?& . "&amp;")
983                                                      (?< . "&lt;")
984                                                      (?> . "&gt;"))))
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
# Line 975  With prefix argument, unquote the region Line 1028  With prefix argument, unquote the region
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
# Line 1043  immediately enclosing the current positi Line 1096  immediately enclosing the current positi
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
# Line 1071  immediately enclosing the current positi Line 1124  immediately enclosing the current positi
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    
# Line 1092  immediately enclosing the current positi Line 1154  immediately enclosing the current positi
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 " -->"))
# Line 1213  If FULL is non-nil, parse back to the be Line 1283  If FULL is non-nil, parse back to the be
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    
# Line 1242  Add this to `sgml-mode-hook' for conveni Line 1312  Add this to `sgml-mode-hook' for conveni
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            ))))            ))))
# Line 1694  The second `match-string' matches extra Line 1764  The second `match-string' matches extra
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))
# Line 1708  The third `match-string' will be the use Line 1778  The third `match-string' will be the use
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

Legend:
Removed from v.1.88  
changed lines
  Added in v.1.88.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26