/[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.72 by mdub, Mon Apr 1 12:43:47 2002 UTC revision 1.73 by monnier, Mon Apr 1 23:32:15 2002 UTC
# Line 80  Including ?- has the problem of affectin Line 80  Including ?- has the problem of affectin
80  with comments, so we normally turn it off.")  with comments, so we normally turn it off.")
81    
82  (defvar sgml-quick-keys nil  (defvar sgml-quick-keys nil
83    "Use <, >, &, SPC and `sgml-specials' keys \"electrically\" when non-nil.    "Use <, >, &, /, SPC and `sgml-specials' keys \"electrically\" when non-nil.
84  This takes effect when first loading the `sgml-mode' library.")  This takes effect when first loading the `sgml-mode' library.")
85    
86    
# Line 384  Otherwise, it is set to be buffer-local Line 384  Otherwise, it is set to be buffer-local
384  (define-derived-mode sgml-mode text-mode "SGML"  (define-derived-mode sgml-mode text-mode "SGML"
385    "Major mode for editing SGML documents.    "Major mode for editing SGML documents.
386  Makes > match <.  Makes > match <.
387  Keys <, &, SPC within <>, \" and ' can be electric depending on  Keys <, &, SPC within <>, \", / and ' can be electric depending on
388  `sgml-quick-keys'.  `sgml-quick-keys'.
389    
390  An argument of N to a tag-inserting command means to wrap it around  An argument of N to a tag-inserting command means to wrap it around
# Line 450  Do \\[describe-key] on the following bin Line 450  Do \\[describe-key] on the following bin
450    
451    
452  (defun sgml-slash (arg)  (defun sgml-slash (arg)
453      "Insert ARG slash characters.
454    Behaves electrically if `sgml-quick-keys' is non-nil."
455      (interactive "p")
456      (cond
457       ((not (and (eq (char-before) ?<) (= arg 1)))
458        (sgml-slash-matching arg))
459       ((eq sgml-quick-keys 'indent)
460        (insert-char ?/ 1)
461        (indent-according-to-mode))
462       ((eq sgml-quick-keys 'close)
463        (delete-backward-char 1)
464        (sgml-insert-end-tag))
465       (t
466        (sgml-slash-matching arg))))
467    
468    (defun sgml-slash-matching (arg)
469    "Insert `/' and display any previous matching `/'.    "Insert `/' and display any previous matching `/'.
470  Two `/'s are treated as matching if the first `/' ends a net-enabling  Two `/'s are treated as matching if the first `/' ends a net-enabling
471  start tag, and the second `/' is the corresponding null end tag."  start tag, and the second `/' is the corresponding null end tag."
# Line 925  With prefix argument, unquote the region Line 941  With prefix argument, unquote the region
941                                                  (?> . "&gt;"))))))))                                                  (?> . "&gt;"))))))))
942    
943    
944    (defsubst sgml-at-indentation-p ()
945      "Return true if point is at the first non-whitespace character on the line."
946      (save-excursion
947        (skip-chars-backward " \t")
948        (bolp)))
949    
950    
951    ;; Parsing
952    
953    (defstruct (sgml-tag
954                (:constructor sgml-make-tag (type start end name)))
955      type start end name)
956    
957    (defsubst sgml-parse-tag-name ()
958      "Skip past a tag-name, and return the name."
959      (buffer-substring-no-properties
960       (point) (progn (skip-syntax-forward "w_") (point))))
961    
962    (defsubst sgml-looking-back-at (s)
963      (let ((limit (max (- (point) (length s)) (point-min))))
964        (equal s (buffer-substring-no-properties limit (point)))))
965    
966    (defun sgml-parse-tag-backward ()
967      "Parse an SGML tag backward, and return information about the tag.
968    Assume that parsing starts from within a textual context.
969    Leave point at the beginning of the tag."
970      (let (tag-type tag-start tag-end name)
971        (search-backward ">")
972        (setq tag-end (1+ (point)))
973        (cond
974         ((sgml-looking-back-at "--")   ; comment
975          (setq tag-type 'comment
976                tag-start (search-backward "<!--" nil t)))
977         ((sgml-looking-back-at "]]")   ; cdata
978          (setq tag-type 'cdata
979                tag-start (search-backward "<![CDATA[" nil t)))
980         (t
981          (setq tag-start
982                (with-syntax-table sgml-tag-syntax-table
983                  (goto-char tag-end)
984                  (backward-sexp)
985                  (point)))
986          (goto-char (1+ tag-start))
987          (case (char-after)
988            (?!                             ; declaration
989             (setq tag-type 'decl))
990            (??                             ; processing-instruction
991             (setq tag-type 'pi))
992            (?/                             ; close-tag
993             (forward-char 1)
994             (setq tag-type 'close
995                   name (sgml-parse-tag-name)))
996            ((?% ?#)                        ; JSP tags etc
997             (setq tag-type 'unknown))
998            (t                              ; open or empty tag
999             (setq tag-type 'open
1000                   name (sgml-parse-tag-name))
1001             (if (or (eq ?/ (char-before (- tag-end 1)))
1002                     (sgml-empty-tag-p name))
1003                 (setq tag-type 'empty))))))
1004        (goto-char tag-start)
1005        (sgml-make-tag tag-type tag-start tag-end name)))
1006    
1007    (defsubst sgml-inside-tag-p (tag-info &optional point)
1008      "Return true if TAG-INFO contains the POINT."
1009      (let ((end (sgml-tag-end tag-info))
1010            (point (or point (point))))
1011        (or (null end)
1012            (> end point))))
1013    
1014    (defun sgml-get-context (&optional full)
1015      "Determine the context of the current position.
1016    If FULL is `empty', return even if the context is empty (i.e.
1017    we just skipped over some element and got to a beginning of line).
1018    If FULL is non-nil, parse back to the beginning of the buffer, otherwise
1019    parse until we find a start-tag as the first thing on a line.
1020    
1021    The context is a list of tag-info structures.  The last one is the tag
1022    immediately enclosing the current position."
1023      (let ((here (point))
1024            (ignore nil)
1025            (context nil)
1026            tag-info)
1027        ;; CONTEXT keeps track of the tag-stack
1028        ;; IGNORE keeps track of the nesting level of point relative to the
1029        ;;   first (outermost) tag on the context.  This is the list of
1030        ;;   enclosing start-tags we'll have to ignore.
1031        (skip-chars-backward " \t\n")      ; Make sure we're not at indentation.
1032        (while
1033            (and (or ignore
1034                     (not (if full (eq full 'empty) context))
1035                     (not (sgml-at-indentation-p))
1036                     (and context
1037                          (/= (point) (sgml-tag-start (car context)))
1038                          (sgml-unclosed-tag-p (sgml-tag-name (car context)))))
1039                 (setq tag-info (ignore-errors (sgml-parse-tag-backward))))
1040          
1041          ;; This tag may enclose things we thought were tags.  If so,
1042          ;; discard them.
1043          (while (and context
1044                      (> (sgml-tag-end tag-info)
1045                         (sgml-tag-end (car context))))
1046            (setq context (cdr context)))
1047              
1048          (cond
1049    
1050           ;; inside a tag ...
1051           ((sgml-inside-tag-p tag-info here)
1052            (push tag-info context))
1053    
1054           ;; start-tag
1055           ((eq (sgml-tag-type tag-info) 'open)
1056            (cond
1057             ((null ignore)
1058              (if (and context
1059                       (sgml-unclosed-tag-p (sgml-tag-name tag-info))
1060                       (eq t (compare-strings
1061                              (sgml-tag-name tag-info) nil nil
1062                              (sgml-tag-name (car context)) nil nil t)))
1063                  ;; There was an implicit end-tag.
1064                  nil
1065                (push tag-info context)))
1066             ((eq t (compare-strings (sgml-tag-name tag-info) nil nil
1067                                     (car ignore) nil nil t))
1068              (setq ignore (cdr ignore)))
1069             (t
1070              ;; The open and close tags don't match.
1071              (if (not sgml-xml-mode)
1072                  ;; Assume the open tag is simply not closed.
1073                  (unless (sgml-unclosed-tag-p (sgml-tag-name tag-info))
1074                    (message "Unclosed tag <%s>" (sgml-tag-name tag-info)))
1075                (message "Unmatched tags <%s> and </%s>"
1076                         (sgml-tag-name tag-info) (pop ignore))))))
1077    
1078           ;; end-tag
1079           ((eq (sgml-tag-type tag-info) 'close)
1080            (if (sgml-empty-tag-p (sgml-tag-name tag-info))
1081                (message "Spurious </%s>: empty tag" (sgml-tag-name tag-info))
1082              (push (sgml-tag-name tag-info) ignore)))
1083           ))
1084    
1085        ;; return context
1086        context))
1087    
1088    (defun sgml-show-context (&optional full)
1089      "Display the current context.
1090    If FULL is non-nil, parse back to the beginning of the buffer."
1091      (interactive "P")
1092      (with-output-to-temp-buffer "*XML Context*"
1093        (pp (save-excursion (sgml-get-context full)))))
1094    
1095    
1096    ;; Editing shortcuts
1097    
1098    (defun sgml-insert-end-tag ()
1099      "Insert an end-tag for the current element."
1100      (interactive)
1101      (let* ((context (save-excursion (sgml-get-context)))
1102             (tag-info (car (last context)))
1103             (type (and tag-info (sgml-tag-type tag-info))))
1104    
1105        (cond
1106    
1107         ((null context)
1108          (error "Nothing to close"))
1109    
1110         ;; inside a tag
1111         ((sgml-inside-tag-p tag-info)
1112          (insert (cond
1113                   ((eq type 'empty)        " />")
1114                   ((eq type 'comment)      " -->")
1115                   ((eq type 'cdata)        "]]>")
1116                   ((eq type 'jsp)          "%>")
1117                   ((eq type 'pi)           "?>")
1118                   (t                       ">"))))
1119    
1120         ;; inside an element
1121         ((eq type 'open)
1122          (insert "</" (sgml-tag-name tag-info) ">")
1123          (indent-according-to-mode))
1124    
1125         (t
1126          (error "Nothing to close")))))
1127    
1128  (defun sgml-empty-tag-p (tag-name)  (defun sgml-empty-tag-p (tag-name)
1129    "Return non-nil if TAG-NAME is an implicitly empty tag."    "Return non-nil if TAG-NAME is an implicitly empty tag."
1130    (and (not sgml-xml-mode)    (and (not sgml-xml-mode)
# Line 1003  With prefix argument, unquote the region Line 1203  With prefix argument, unquote the region
1203                          (> (point) (cdr lcon)))                          (> (point) (cdr lcon)))
1204                     nil                     nil
1205                   (goto-char here)                   (goto-char here)
1206                   (nreverse (xml-lite-get-context (if unclosed nil 'empty)))))                   (nreverse (sgml-get-context (if unclosed nil 'empty)))))
1207                (there (point)))                (there (point)))
1208           ;; Ignore previous unclosed start-tag in context.           ;; Ignore previous unclosed start-tag in context.
1209           (while (and context unclosed           (while (and context unclosed
1210                       (eq t (compare-strings                       (eq t (compare-strings
1211                              (xml-lite-tag-name (car context)) nil nil                              (sgml-tag-name (car context)) nil nil
1212                              unclosed nil nil t)))                              unclosed nil nil t)))
1213             (setq context (cdr context)))             (setq context (cdr context)))
1214           ;; Indent to reflect nesting.           ;; Indent to reflect nesting.
1215           (if (and context           (if (and context
1216                    (goto-char (xml-lite-tag-end (car context)))                    (goto-char (sgml-tag-end (car context)))
1217                    (skip-chars-forward " \t\n")                    (skip-chars-forward " \t\n")
1218                    (< (point) here) (xml-lite-at-indentation-p))                    (< (point) here) (sgml-at-indentation-p))
1219               (current-column)               (current-column)
1220             (goto-char there)             (goto-char there)
1221             (+ (current-column)             (+ (current-column)

Legend:
Removed from v.1.72  
changed lines
  Added in v.1.73

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