code.delx.au - gnu-emacs/blob - lisp/textmodes/sgml-mode.el

   1 ;;; sgml-mode.el --- SGML- and HTML-editing modes -*- coding: iso-2022-7bit -*-
   2
   3 ;; Copyright (C) 1992, 1995, 1996, 1998, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Author: James Clark <jjc@jclark.com>
   7 ;; Maintainer: FSF
   8 ;; Adapted-By: ESR, Daniel Pfeiffer <occitan@esperanto.org>,
   9 ;;             F.Potorti@cnuce.cnr.it
  10 ;; Keywords: wp, hypermedia, comm, languages
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; Configurable major mode for editing document in the SGML standard general
  32 ;; markup language.  As an example contains a mode for editing the derived
  33 ;; HTML hypertext markup language.
  34
  35 ;;; Code:
  36
  37 (eval-when-compile
  38   (require 'skeleton)
  39   (require 'outline)
  40   (require 'cl))
  41
  42 (defgroup sgml nil
  43   "SGML editing mode."
  44   :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
  45   :group 'languages)
  46
  47 (defcustom sgml-basic-offset 2
  48   "*Specifies the basic indentation level for `sgml-indent-line'."
  49   :type 'integer
  50   :group 'sgml)
  51
  52 (defcustom sgml-transformation 'identity
  53   "*Default value for `skeleton-transformation' (which see) in SGML mode."
  54   :type 'function
  55   :group 'sgml)
  56
  57 (put 'sgml-transformation 'variable-interactive
  58      "aTransformation function: ")
  59
  60 (defcustom sgml-mode-hook nil
  61   "Hook run by command `sgml-mode'.
  62 `text-mode-hook' is run first."
  63   :group 'sgml
  64   :type 'hook)
  65
  66 ;; As long as Emacs' syntax can't be complemented with predicates to context
  67 ;; sensitively confirm the syntax of characters, we have to live with this
  68 ;; kludgy kind of tradeoff.
  69 (defvar sgml-specials '(?\")
  70   "List of characters that have a special meaning for SGML mode.
  71 This list is used when first loading the `sgml-mode' library.
  72 The supported characters and potential disadvantages are:
  73
  74   ?\\\" Makes \" in text start a string.
  75   ?'    Makes ' in text start a string.
  76   ?-    Makes -- in text start a comment.
  77
  78 When only one of ?\\\" or ?' are included, \"'\" or '\"', as can be found in
  79 DTDs, start a string.  To partially avoid this problem this also makes these
  80 self insert as named entities depending on `sgml-quick-keys'.
  81
  82 Including ?- has the problem of affecting dashes that have nothing to do
  83 with comments, so we normally turn it off.")
  84
  85 (defvar sgml-quick-keys nil
  86   "Use <, >, &, /, SPC and `sgml-specials' keys \"electrically\" when non-nil.
  87 This takes effect when first loading the `sgml-mode' library.")
  88
  89 (defvar sgml-mode-map
  90   (let ((map (make-keymap))     ;`sparse' doesn't allow binding to charsets.
  91         (menu-map (make-sparse-keymap "SGML")))
  92     (define-key map "\C-c\C-i" 'sgml-tags-invisible)
  93     (define-key map "/" 'sgml-slash)
  94     (define-key map "\C-c\C-n" 'sgml-name-char)
  95     (define-key map "\C-c\C-t" 'sgml-tag)
  96     (define-key map "\C-c\C-a" 'sgml-attributes)
  97     (define-key map "\C-c\C-b" 'sgml-skip-tag-backward)
  98     (define-key map [?\C-c left] 'sgml-skip-tag-backward)
  99     (define-key map "\C-c\C-f" 'sgml-skip-tag-forward)
 100     (define-key map [?\C-c right] 'sgml-skip-tag-forward)
 101     (define-key map "\C-c\C-d" 'sgml-delete-tag)
 102     (define-key map "\C-c\^?" 'sgml-delete-tag)
 103     (define-key map "\C-c?" 'sgml-tag-help)
 104     (define-key map "\C-c/" 'sgml-close-tag)
 105     (define-key map "\C-c8" 'sgml-name-8bit-mode)
 106     (define-key map "\C-c\C-v" 'sgml-validate)
 107     (when sgml-quick-keys
 108       (define-key map "&" 'sgml-name-char)
 109       (define-key map "<" 'sgml-tag)
 110       (define-key map " " 'sgml-auto-attributes)
 111       (define-key map ">" 'sgml-maybe-end-tag)
 112       (when (memq ?\" sgml-specials)
 113         (define-key map "\"" 'sgml-name-self))
 114       (when (memq ?' sgml-specials)
 115         (define-key map "'" 'sgml-name-self)))
 116     (define-key map (vector (make-char 'latin-iso8859-1))
 117       'sgml-maybe-name-self)
 118     (let ((c 127)
 119           (map (nth 1 map)))
 120       (while (< (setq c (1+ c)) 256)
 121         (aset map c 'sgml-maybe-name-self)))
 122     (define-key map [menu-bar sgml] (cons "SGML" menu-map))
 123     (define-key menu-map [sgml-validate] '("Validate" . sgml-validate))
 124     (define-key menu-map [sgml-name-8bit-mode]
 125       '("Toggle 8 Bit Insertion" . sgml-name-8bit-mode))
 126     (define-key menu-map [sgml-tags-invisible]
 127       '("Toggle Tag Visibility" . sgml-tags-invisible))
 128     (define-key menu-map [sgml-tag-help]
 129       '("Describe Tag" . sgml-tag-help))
 130     (define-key menu-map [sgml-delete-tag]
 131       '("Delete Tag" . sgml-delete-tag))
 132     (define-key menu-map [sgml-skip-tag-forward]
 133       '("Forward Tag" . sgml-skip-tag-forward))
 134     (define-key menu-map [sgml-skip-tag-backward]
 135       '("Backward Tag" . sgml-skip-tag-backward))
 136     (define-key menu-map [sgml-attributes]
 137       '("Insert Attributes" . sgml-attributes))
 138     (define-key menu-map [sgml-tag] '("Insert Tag" . sgml-tag))
 139     map)
 140   "Keymap for SGML mode.  See also `sgml-specials'.")
 141
 142 (defun sgml-make-syntax-table (specials)
 143   (let ((table (make-syntax-table text-mode-syntax-table)))
 144     (modify-syntax-entry ?< "(>" table)
 145     (modify-syntax-entry ?> ")<" table)
 146     (modify-syntax-entry ?: "_" table)
 147     (modify-syntax-entry ?_ "_" table)
 148     (modify-syntax-entry ?. "_" table)
 149     (if (memq ?- specials)
 150         (modify-syntax-entry ?- "_ 1234" table))
 151     (if (memq ?\" specials)
 152         (modify-syntax-entry ?\" "\"\"" table))
 153     (if (memq ?' specials)
 154         (modify-syntax-entry ?\' "\"'" table))
 155     table))
 156
 157 (defvar sgml-mode-syntax-table (sgml-make-syntax-table sgml-specials)
 158   "Syntax table used in SGML mode.  See also `sgml-specials'.")
 159
 160 (defconst sgml-tag-syntax-table
 161   (let ((table (sgml-make-syntax-table '(?- ?\" ?\'))))
 162     (dolist (char '(?\( ?\) ?\{ ?\} ?\[ ?\] ?$ ?% ?& ?* ?+ ?/))
 163       (modify-syntax-entry char "." table))
 164     table)
 165   "Syntax table used to parse SGML tags.")
 166
 167 (defcustom sgml-name-8bit-mode nil
 168   "*When non-nil, insert non-ASCII characters as named entities."
 169   :type 'boolean
 170   :group 'sgml)
 171
 172 (defvar sgml-char-names
 173   [nil nil nil nil nil nil nil nil
 174    nil nil nil nil nil nil nil nil
 175    nil nil nil nil nil nil nil nil
 176    nil nil nil nil nil nil nil nil
 177    "nbsp" "excl" "quot" "num" "dollar" "percnt" "amp" "apos"
 178    "lpar" "rpar" "ast" "plus" "comma" "hyphen" "period" "sol"
 179    nil nil nil nil nil nil nil nil
 180    nil nil "colon" "semi" "lt" "eq" "gt" "quest"
 181    "commat" nil nil nil nil nil nil nil
 182    nil nil nil nil nil nil nil nil
 183    nil nil nil nil nil nil nil nil
 184    nil nil nil "lsqb" nil "rsqb" "uarr" "lowbar"
 185    "lsquo" nil nil nil nil nil nil nil
 186    nil nil nil nil nil nil nil nil
 187    nil nil nil nil nil nil nil nil
 188    nil nil nil "lcub" "verbar" "rcub" "tilde" nil
 189    nil nil nil nil nil nil nil nil
 190    nil nil nil nil nil nil nil nil
 191    nil nil nil nil nil nil nil nil
 192    nil nil nil nil nil nil nil nil
 193    "nbsp" "iexcl" "cent" "pound" "curren" "yen" "brvbar" "sect"
 194    "uml" "copy" "ordf" "laquo" "not" "shy" "reg" "macr"
 195    "ring" "plusmn" "sup2" "sup3" "acute" "micro" "para" "middot"
 196    "cedil" "sup1" "ordm" "raquo" "frac14" "frac12" "frac34" "iquest"
 197    "Agrave" "Aacute" "Acirc" "Atilde" "Auml" "Aring" "AElig" "Ccedil"
 198    "Egrave" "Eacute" "Ecirc" "Euml" "Igrave" "Iacute" "Icirc" "Iuml"
 199    "ETH" "Ntilde" "Ograve" "Oacute" "Ocirc" "Otilde" "Ouml" nil
 200    "Oslash" "Ugrave" "Uacute" "Ucirc" "Uuml" "Yacute" "THORN" "szlig"
 201    "agrave" "aacute" "acirc" "atilde" "auml" "aring" "aelig" "ccedil"
 202    "egrave" "eacute" "ecirc" "euml" "igrave" "iacute" "icirc" "iuml"
 203    "eth" "ntilde" "ograve" "oacute" "ocirc" "otilde" "ouml" "divide"
 204    "oslash" "ugrave" "uacute" "ucirc" "uuml" "yacute" "thorn" "yuml"]
 205   "Vector of symbolic character names without `&' and `;'.")
 206
 207 (put 'sgml-table 'char-table-extra-slots 0)
 208
 209 (defvar sgml-char-names-table
 210   (let ((table (make-char-table 'sgml-table))
 211         (i 32)
 212         elt)
 213     (while (< i 256)
 214       (setq elt (aref sgml-char-names i))
 215       (if elt (aset table (make-char 'latin-iso8859-1 i) elt))
 216       (setq i (1+ i)))
 217     table)
 218   "A table for mapping non-ASCII characters into SGML entity names.
 219 Currently, only Latin-1 characters are supported.")
 220
 221 ;; nsgmls is a free SGML parser in the SP suite available from
 222 ;; ftp.jclark.com and otherwise packaged for GNU systems.
 223 ;; Its error messages can be parsed by next-error.
 224 ;; The -s option suppresses output.
 225
 226 (defcustom sgml-validate-command "nsgmls -s" ; replaced old `sgmls'
 227   "*The command to validate an SGML document.
 228 The file name of current buffer file name will be appended to this,
 229 separated by a space."
 230   :type 'string
 231   :version "21.1"
 232   :group 'sgml)
 233
 234 (defvar sgml-saved-validate-command nil
 235   "The command last used to validate in this buffer.")
 236
 237 ;; I doubt that null end tags are used much for large elements,
 238 ;; so use a small distance here.
 239 (defcustom sgml-slash-distance 1000
 240   "*If non-nil, is the maximum distance to search for matching `/'."
 241   :type '(choice (const nil) integer)
 242   :group 'sgml)
 243
 244 (defconst sgml-namespace-re "[_[:alpha:]][-_.[:alnum:]]*")
 245 (defconst sgml-name-re "[_:[:alpha:]][-_.:[:alnum:]]*")
 246 (defconst sgml-tag-name-re (concat "<\\([!/?]?" sgml-name-re "\\)"))
 247 (defconst sgml-attrs-re "\\(?:[^\"'/><]\\|\"[^\"]*\"\\|'[^']*'\\)*")
 248 (defconst sgml-start-tag-regex (concat "<" sgml-name-re sgml-attrs-re)
 249   "Regular expression that matches a non-empty start tag.
 250 Any terminating `>' or `/' is not matched.")
 251
 252 (defface sgml-namespace
 253   '((t (:inherit font-lock-builtin-face)))
 254   "`sgml-mode' face used to highlight the namespace part of identifiers."
 255   :group 'sgml)
 256 (defvar sgml-namespace-face 'sgml-namespace)
 257
 258 ;; internal
 259 (defconst sgml-font-lock-keywords-1
 260   `((,(concat "<\\([!?]" sgml-name-re "\\)") 1 font-lock-keyword-face)
 261     ;; We could use the simpler "\\(" sgml-namespace-re ":\\)?" instead,
 262     ;; but it would cause a bit more backtracking in the re-matcher.
 263     (,(concat "</?\\(" sgml-namespace-re "\\)\\(?::\\(" sgml-name-re "\\)\\)?")
 264      (1 (if (match-end 2) sgml-namespace-face font-lock-function-name-face))
 265      (2 font-lock-function-name-face nil t))
 266     ;; FIXME: this doesn't cover the variables using a default value.
 267     (,(concat "\\(" sgml-namespace-re "\\)\\(?::\\("
 268               sgml-name-re "\\)\\)?=[\"']")
 269      (1 (if (match-end 2) sgml-namespace-face font-lock-variable-name-face))
 270      (2 font-lock-variable-name-face nil t))
 271     (,(concat "[&%]" sgml-name-re ";?") . font-lock-variable-name-face)))
 272
 273 (defconst sgml-font-lock-keywords-2
 274   (append
 275    sgml-font-lock-keywords-1
 276    '((eval
 277       . (cons (concat "<"
 278                       (regexp-opt (mapcar 'car sgml-tag-face-alist) t)
 279                       "\\([ \t][^>]*\\)?>\\([^<]+\\)</\\1>")
 280               '(3 (cdr (assoc (downcase (match-string 1))
 281                               sgml-tag-face-alist)) prepend))))))
 282
 283 ;; for font-lock, but must be defvar'ed after
 284 ;; sgml-font-lock-keywords-1 and sgml-font-lock-keywords-2 above
 285 (defvar sgml-font-lock-keywords sgml-font-lock-keywords-1
 286   "*Rules for highlighting SGML code.  See also `sgml-tag-face-alist'.")
 287
 288 (defvar sgml-font-lock-syntactic-keywords
 289   ;; Use the `b' style of comments to avoid interference with the -- ... --
 290   ;; comments recognized when `sgml-specials' includes ?-.
 291   ;; FIXME: beware of <!--> blabla <!--> !!
 292   '(("\\(<\\)!--" (1 "< b"))
 293     ("--[ \t\n]*\\(>\\)" (1 "> b")))
 294   "Syntactic keywords for `sgml-mode'.")
 295
 296 ;; internal
 297 (defvar sgml-face-tag-alist ()
 298   "Alist of face and tag name for facemenu.")
 299
 300 (defvar sgml-tag-face-alist ()
 301   "Tag names and face or list of faces to fontify with when invisible.
 302 When `font-lock-maximum-decoration' is 1 this is always used for fontifying.
 303 When more these are fontified together with `sgml-font-lock-keywords'.")
 304
 305 (defvar sgml-display-text ()
 306   "Tag names as lowercase symbols, and display string when invisible.")
 307
 308 ;; internal
 309 (defvar sgml-tags-invisible nil)
 310
 311 (defcustom sgml-tag-alist
 312   '(("![" ("ignore" t) ("include" t))
 313     ("!attlist")
 314     ("!doctype")
 315     ("!element")
 316     ("!entity"))
 317   "*Alist of tag names for completing read and insertion rules.
 318 This alist is made up as
 319
 320   ((\"tag\" . TAGRULE)
 321    ...)
 322
 323 TAGRULE is a list of optionally t (no endtag) or `\\n' (separate endtag by
 324 newlines) or a skeleton with nil, t or `\\n' in place of the interactor
 325 followed by an ATTRIBUTERULE (for an always present attribute) or an
 326 attribute alist.
 327
 328 The attribute alist is made up as
 329
 330   ((\"attribute\" . ATTRIBUTERULE)
 331    ...)
 332
 333 ATTRIBUTERULE is a list of optionally t (no value when no input) followed by
 334 an optional alist of possible values."
 335   :type '(repeat (cons (string :tag "Tag Name")
 336                        (repeat :tag "Tag Rule" sexp)))
 337   :group 'sgml)
 338
 339 (defcustom sgml-tag-help
 340   '(("!" . "Empty declaration for comment")
 341     ("![" . "Embed declarations with parser directive")
 342     ("!attlist" . "Tag attributes declaration")
 343     ("!doctype" . "Document type (DTD) declaration")
 344     ("!element" . "Tag declaration")
 345     ("!entity" . "Entity (macro) declaration"))
 346   "*Alist of tag name and short description."
 347   :type '(repeat (cons (string :tag "Tag Name")
 348                        (string :tag "Description")))
 349   :group 'sgml)
 350
 351 (defcustom sgml-xml-mode nil
 352   "*When non-nil, tag insertion functions will be XML-compliant.
 353 If this variable is customized, the custom value is used always.
 354 Otherwise, it is set to be buffer-local when the file has
 355 a DOCTYPE or an XML declaration."
 356   :type 'boolean
 357   :version "22.1"
 358   :group 'sgml)
 359
 360 (defvar sgml-empty-tags nil
 361   "List of tags whose !ELEMENT definition says EMPTY.")
 362
 363 (defvar sgml-unclosed-tags nil
 364   "List of tags whose !ELEMENT definition says the end-tag is optional.")
 365
 366 (defun sgml-xml-guess ()
 367   "Guess whether the current buffer is XML."
 368   (save-excursion
 369     (goto-char (point-min))
 370     (when (or (string= "xml" (file-name-extension (or buffer-file-name "")))
 371               (looking-at "\\s-*<\\?xml")
 372               (when (re-search-forward
 373                      (eval-when-compile
 374                  (mapconcat 'identity
 375                             '("<!DOCTYPE" "\\(\\w+\\)" "\\(\\w+\\)"
 376                                     "\"\\([^\"]+\\)\"" "\"\\([^\"]+\\)\"")
 377                                   "\\s-+"))
 378                      nil t)
 379                 (string-match "X\\(HT\\)?ML" (match-string 3))))
 380       (set (make-local-variable 'sgml-xml-mode) t))))
 381
 382 (defvar v2)                             ; free for skeleton
 383
 384 (defun sgml-comment-indent-new-line (&optional soft)
 385   (let ((comment-start "-- ")
 386         (comment-start-skip "\\(<!\\)?--[ \t]*")
 387         (comment-end " --")
 388         (comment-style 'plain))
 389     (comment-indent-new-line soft)))
 390
 391 (defun sgml-mode-facemenu-add-face-function (face end)
 392   (if (setq face (cdr (assq face sgml-face-tag-alist)))
 393       (progn
 394         (setq face (funcall skeleton-transformation face))
 395         (setq facemenu-end-add-face (concat "</" face ">"))
 396         (concat "<" face ">"))
 397     (error "Face not configured for %s mode" mode-name)))
 398
 399 (defun sgml-fill-nobreak ()
 400   ;; Don't break between a tag name and its first argument.
 401   (save-excursion
 402     (skip-chars-backward " \t")
 403     (and (not (zerop (skip-syntax-backward "w_")))
 404          (skip-chars-backward "/?!")
 405          (eq (char-before) ?<))))
 406
 407 ;;;###autoload
 408 (define-derived-mode sgml-mode text-mode "SGML"
 409   "Major mode for editing SGML documents.
 410 Makes > match <.
 411 Keys <, &, SPC within <>, \", / and ' can be electric depending on
 412 `sgml-quick-keys'.
 413
 414 An argument of N to a tag-inserting command means to wrap it around
 415 the next N words.  In Transient Mark mode, when the mark is active,
 416 N defaults to -1, which means to wrap it around the current region.
 417
 418 If you like upcased tags, put (setq sgml-transformation 'upcase) in
 419 your `.emacs' file.
 420
 421 Use \\[sgml-validate] to validate your document with an SGML parser.
 422
 423 Do \\[describe-variable] sgml- SPC to see available variables.
 424 Do \\[describe-key] on the following bindings to discover what they do.
 425 \\{sgml-mode-map}"
 426   (make-local-variable 'sgml-saved-validate-command)
 427   (make-local-variable 'facemenu-end-add-face)
 428   ;;(make-local-variable 'facemenu-remove-face-function)
 429   ;; A start or end tag by itself on a line separates a paragraph.
 430   ;; This is desirable because SGML discards a newline that appears
 431   ;; immediately after a start tag or immediately before an end tag.
 432   (set (make-local-variable 'paragraph-start) (concat "[ \t]*$\\|\
 433 \[ \t]*</?\\(" sgml-name-re sgml-attrs-re "\\)?>"))
 434   (set (make-local-variable 'paragraph-separate)
 435        (concat paragraph-start "$"))
 436   (set (make-local-variable 'adaptive-fill-regexp) "[ \t]*")
 437   (add-hook 'fill-nobreak-predicate 'sgml-fill-nobreak nil t)
 438   (set (make-local-variable 'indent-line-function) 'sgml-indent-line)
 439   (set (make-local-variable 'comment-start) "<!-- ")
 440   (set (make-local-variable 'comment-end) " -->")
 441   (set (make-local-variable 'comment-indent-function) 'sgml-comment-indent)
 442   (set (make-local-variable 'comment-line-break-function)
 443        'sgml-comment-indent-new-line)
 444   (set (make-local-variable 'skeleton-further-elements)
 445        '((completion-ignore-case t)))
 446   (set (make-local-variable 'skeleton-end-hook)
 447        (lambda ()
 448          (or (eolp)
 449              (not (or (eq v2 '\n) (eq (car-safe v2) '\n)))
 450              (newline-and-indent))))
 451   (set (make-local-variable 'font-lock-defaults)
 452        '((sgml-font-lock-keywords
 453           sgml-font-lock-keywords-1
 454           sgml-font-lock-keywords-2)
 455          nil t nil nil
 456          (font-lock-syntactic-keywords
 457           . sgml-font-lock-syntactic-keywords)))
 458   (set (make-local-variable 'facemenu-add-face-function)
 459        'sgml-mode-facemenu-add-face-function)
 460   (sgml-xml-guess)
 461   (if sgml-xml-mode
 462       (setq mode-name "XML")
 463     (set (make-local-variable 'skeleton-transformation) sgml-transformation))
 464   ;; This will allow existing comments within declarations to be
 465   ;; recognized.
 466   (set (make-local-variable 'comment-start-skip) "\\(?:<!\\)?--[ \t]*")
 467   (set (make-local-variable 'comment-end-skip) "[ \t]*--\\([ \t\n]*>\\)?")
 468   ;; This definition has an HTML leaning but probably fits well for other modes.
 469   (setq imenu-generic-expression
 470         `((nil
 471            ,(concat "<!\\(element\\|entity\\)[ \t\n]+%?[ \t\n]*\\("
 472                     sgml-name-re "\\)")
 473            2)
 474           ("Id"
 475            ,(concat "<[^>]+[ \t\n]+[Ii][Dd]=\\(['\"]"
 476                     (if sgml-xml-mode "" "?")
 477                     "\\)\\(" sgml-name-re "\\)\\1")
 478            2)
 479           ("Name"
 480            ,(concat "<[^>]+[ \t\n]+[Nn][Aa][Mm][Ee]=\\(['\"]"
 481                     (if sgml-xml-mode "" "?")
 482                     "\\)\\(" sgml-name-re "\\)\\1")
 483            2))))
 484
 485 ;; Some programs (such as Glade 2) generate XML which has
 486 ;; -*- mode: xml -*-.
 487 ;;;###autoload
 488 (defalias 'xml-mode 'sgml-mode)
 489
 490 (defun sgml-comment-indent ()
 491   (if (looking-at "--") comment-column 0))
 492
 493 (defun sgml-slash (arg)
 494   "Insert ARG slash characters.
 495 Behaves electrically if `sgml-quick-keys' is non-nil."
 496   (interactive "p")
 497   (cond
 498    ((not (and (eq (char-before) ?<) (= arg 1)))
 499     (sgml-slash-matching arg))
 500    ((eq sgml-quick-keys 'indent)
 501     (insert-char ?/ 1)
 502     (indent-according-to-mode))
 503    ((eq sgml-quick-keys 'close)
 504     (delete-backward-char 1)
 505     (sgml-close-tag))
 506    (t
 507     (sgml-slash-matching arg))))
 508
 509 (defun sgml-slash-matching (arg)
 510   "Insert `/' and display any previous matching `/'.
 511 Two `/'s are treated as matching if the first `/' ends a net-enabling
 512 start tag, and the second `/' is the corresponding null end tag."
 513   (interactive "p")
 514   (insert-char ?/ arg)
 515   (if (> arg 0)
 516       (let ((oldpos (point))
 517             (blinkpos)
 518             (level 0))
 519         (save-excursion
 520           (save-restriction
 521             (if sgml-slash-distance
 522                 (narrow-to-region (max (point-min)
 523                                        (- (point) sgml-slash-distance))
 524                                   oldpos))
 525             (if (and (re-search-backward sgml-start-tag-regex (point-min) t)
 526                      (eq (match-end 0) (1- oldpos)))
 527                 ()
 528               (goto-char (1- oldpos))
 529               (while (and (not blinkpos)
 530                           (search-backward "/" (point-min) t))
 531                 (let ((tagend (save-excursion
 532                                 (if (re-search-backward sgml-start-tag-regex
 533                                                         (point-min) t)
 534                                     (match-end 0)
 535                                   nil))))
 536                   (if (eq tagend (point))
 537                       (if (eq level 0)
 538                           (setq blinkpos (point))
 539                         (setq level (1- level)))
 540                     (setq level (1+ level)))))))
 541           (when blinkpos
 542             (goto-char blinkpos)
 543             (if (pos-visible-in-window-p)
 544                 (sit-for 1)
 545               (message "Matches %s"
 546                        (buffer-substring (line-beginning-position)
 547                                          (1+ blinkpos)))))))))
 548
 549 ;; Why doesn't this use the iso-cvt table or, preferably, generate the
 550 ;; inverse of the extensive table in the SGML Quail input method?  -- fx
 551 ;; I guess that's moot since it only works with Latin-1 anyhow.
 552 (defun sgml-name-char (&optional char)
 553   "Insert a symbolic character name according to `sgml-char-names'.
 554 Non-ASCII chars may be inserted either with the meta key, as in M-SPC for
 555 no-break space or M-- for a soft hyphen; or via an input method or
 556 encoded keyboard operation."
 557   (interactive "*")
 558   (insert ?&)
 559   (or char
 560       (setq char (read-quoted-char "Enter char or octal number")))
 561   (delete-backward-char 1)
 562   (insert char)
 563   (undo-boundary)
 564   (sgml-namify-char))
 565
 566 (defun sgml-namify-char ()
 567   "Change the char before point into its `&name;' equivalent.
 568 Uses `sgml-char-names'."
 569   (interactive)
 570   (let* ((char (char-before))
 571          (name
 572           (cond
 573            ((null char) (error "No char before point"))
 574            ((< char 256) (or (aref sgml-char-names char) char))
 575            ((aref sgml-char-names-table char))
 576            ((encode-char char 'ucs)))))
 577     (if (not name)
 578         (error "Don't know the name of `%c'" char)
 579       (delete-backward-char 1)
 580       (insert (format (if (numberp name) "&#%d;" "&%s;") name)))))
 581
 582 (defun sgml-name-self ()
 583   "Insert a symbolic character name according to `sgml-char-names'."
 584   (interactive "*")
 585   (sgml-name-char last-command-char))
 586
 587 (defun sgml-maybe-name-self ()
 588   "Insert a symbolic character name according to `sgml-char-names'."
 589   (interactive "*")
 590   (if sgml-name-8bit-mode
 591       (let ((mc last-command-char))
 592         (if (< mc 256)
 593             (setq mc (unibyte-char-to-multibyte mc)))
 594         (or mc (setq mc last-command-char))
 595         (sgml-name-char mc))
 596     (self-insert-command 1)))
 597
 598 (defun sgml-name-8bit-mode ()
 599   "Toggle whether to insert named entities instead of non-ASCII characters.
 600 This only works for Latin-1 input."
 601   (interactive)
 602   (setq sgml-name-8bit-mode (not sgml-name-8bit-mode))
 603   (message "sgml name entity mode is now %s"
 604            (if sgml-name-8bit-mode "ON" "OFF")))
 605
 606 ;; When an element of a skeleton is a string "str", it is passed
 607 ;; through skeleton-transformation and inserted.  If "str" is to be
 608 ;; inserted literally, one should obtain it as the return value of a
 609 ;; function, e.g. (identity "str").
 610
 611 (defvar sgml-tag-last nil)
 612 (defvar sgml-tag-history nil)
 613 (define-skeleton sgml-tag
 614   "Prompt for a tag and insert it, optionally with attributes.
 615 Completion and configuration are done according to `sgml-tag-alist'.
 616 If you like tags and attributes in uppercase do \\[set-variable]
 617 skeleton-transformation RET upcase RET, or put this in your `.emacs':
 618   (setq sgml-transformation 'upcase)"
 619   (funcall (or skeleton-transformation 'identity)
 620            (setq sgml-tag-last
 621                  (completing-read
 622                   (if (> (length sgml-tag-last) 0)
 623                       (format "Tag (default %s): " sgml-tag-last)
 624                     "Tag: ")
 625                   sgml-tag-alist nil nil nil 'sgml-tag-history sgml-tag-last)))
 626   ?< str |
 627   (("") -1 '(undo-boundary) (identity "&lt;")) |        ; see comment above
 628   `(("") '(setq v2 (sgml-attributes ,str t)) ?>
 629     (cond
 630      ((string= "![" ,str)
 631       (backward-char)
 632       '(("") " [ " _ " ]]"))
 633      ((and (eq v2 t) sgml-xml-mode (member ,str sgml-empty-tags))
 634       '(("") -1 " />"))
 635      ((or (and (eq v2 t) (not sgml-xml-mode)) (string-match "^[/!?]" ,str))
 636       nil)
 637      ((symbolp v2)
 638       ;; Make sure we don't fall into an infinite loop.
 639       ;; For xhtml's `tr' tag, we should maybe use \n instead.
 640       (if (eq v2 t) (setq v2 nil))
 641       ;; We use `identity' to prevent skeleton from passing
 642       ;; `str' through skeleton-transformation a second time.
 643       '(("") v2 _ v2 "</" (identity ',str) ?>))
 644      ((eq (car v2) t)
 645       (cons '("") (cdr v2)))
 646      (t
 647       (append '(("") (car v2))
 648               (cdr v2)
 649               '(resume: (car v2) _ "</" (identity ',str) ?>))))))
 650
 651 (autoload 'skeleton-read "skeleton")
 652
 653 (defun sgml-attributes (tag &optional quiet)
 654   "When at top level of a tag, interactively insert attributes.
 655
 656 Completion and configuration of TAG are done according to `sgml-tag-alist'.
 657 If QUIET, do not print a message when there are no attributes for TAG."
 658   (interactive (list (save-excursion (sgml-beginning-of-tag t))))
 659   (or (stringp tag) (error "Wrong context for adding attribute"))
 660   (if tag
 661       (let ((completion-ignore-case t)
 662             (alist (cdr (assoc (downcase tag) sgml-tag-alist)))
 663             car attribute i)
 664         (if (or (symbolp (car alist))
 665                 (symbolp (car (car alist))))
 666             (setq car (car alist)
 667                   alist (cdr alist)))
 668         (or quiet
 669             (message "No attributes configured."))
 670         (if (stringp (car alist))
 671             (progn
 672               (insert (if (eq (preceding-char) ?\s) "" ?\s)
 673                       (funcall skeleton-transformation (car alist)))
 674               (sgml-value alist))
 675           (setq i (length alist))
 676           (while (> i 0)
 677             (insert ?\s)
 678             (insert (funcall skeleton-transformation
 679                              (setq attribute
 680                                    (skeleton-read '(completing-read
 681                                                     "Attribute: "
 682                                                     alist)))))
 683             (if (string= "" attribute)
 684                 (setq i 0)
 685               (sgml-value (assoc (downcase attribute) alist))
 686               (setq i (1- i))))
 687           (if (eq (preceding-char) ?\s)
 688               (delete-backward-char 1)))
 689         car)))
 690
 691 (defun sgml-auto-attributes (arg)
 692   "Self insert the character typed; at top level of tag, prompt for attributes.
 693 With prefix argument, only self insert."
 694   (interactive "*P")
 695   (let ((point (point))
 696         tag)
 697     (if (or arg
 698             (not sgml-tag-alist)        ; no message when nothing configured
 699             (symbolp (setq tag (save-excursion (sgml-beginning-of-tag t))))
 700             (eq (aref tag 0) ?/))
 701         (self-insert-command (prefix-numeric-value arg))
 702       (sgml-attributes tag)
 703       (setq last-command-char ?\s)
 704       (or (> (point) point)
 705           (self-insert-command 1)))))
 706
 707 (defun sgml-tag-help (&optional tag)
 708   "Display description of tag TAG.  If TAG is omitted, use the tag at point."
 709   (interactive)
 710   (or tag
 711       (save-excursion
 712         (if (eq (following-char) ?<)
 713             (forward-char))
 714         (setq tag (sgml-beginning-of-tag))))
 715   (or (stringp tag)
 716       (error "No tag selected"))
 717   (setq tag (downcase tag))
 718   (message "%s"
 719            (or (cdr (assoc (downcase tag) sgml-tag-help))
 720                (and (eq (aref tag 0) ?/)
 721                     (cdr (assoc (downcase (substring tag 1)) sgml-tag-help)))
 722                "No description available")))
 723
 724 (defun sgml-maybe-end-tag (&optional arg)
 725   "Name self unless in position to end a tag or a prefix ARG is given."
 726   (interactive "P")
 727   (if (or arg (eq (car (sgml-lexical-context)) 'tag))
 728       (self-insert-command (prefix-numeric-value arg))
 729     (sgml-name-self)))
 730
 731 (defun sgml-skip-tag-backward (arg)
 732   "Skip to beginning of tag or matching opening tag if present.
 733 With prefix argument ARG, repeat this ARG times."
 734   (interactive "p")
 735   ;; FIXME: use sgml-get-context or something similar.
 736   (while (>= arg 1)
 737     (search-backward "<" nil t)
 738     (if (looking-at "</\\([^ \n\t>]+\\)")
 739         ;; end tag, skip any nested pairs
 740         (let ((case-fold-search t)
 741               (re (concat "</?" (regexp-quote (match-string 1))
 742                           ;; Ignore empty tags like <foo/>.
 743                           "\\([^>]*[^/>]\\)?>")))
 744           (while (and (re-search-backward re nil t)
 745                       (eq (char-after (1+ (point))) ?/))
 746             (forward-char 1)
 747             (sgml-skip-tag-backward 1))))
 748     (setq arg (1- arg))))
 749
 750 (defun sgml-skip-tag-forward (arg)
 751   "Skip to end of tag or matching closing tag if present.
 752 With prefix argument ARG, repeat this ARG times.
 753 Return t iff after a closing tag."
 754   (interactive "p")
 755   ;; FIXME: Use sgml-get-context or something similar.
 756   ;; It currently might jump to an unrelated </P> if the <P>
 757   ;; we're skipping has no matching </P>.
 758   (let ((return t))
 759     (with-syntax-table sgml-tag-syntax-table
 760       (while (>= arg 1)
 761         (skip-chars-forward "^<>")
 762         (if (eq (following-char) ?>)
 763             (up-list -1))
 764         (if (looking-at "<\\([^/ \n\t>]+\\)\\([^>]*[^/>]\\)?>")
 765             ;; start tag, skip any nested same pairs _and_ closing tag
 766             (let ((case-fold-search t)
 767                   (re (concat "</?" (regexp-quote (match-string 1))
 768                               ;; Ignore empty tags like <foo/>.
 769                               "\\([^>]*[^/>]\\)?>"))
 770                   point close)
 771               (forward-list 1)
 772               (setq point (point))
 773               ;; FIXME: This re-search-forward will mistakenly match
 774               ;; tag-like text inside attributes.
 775               (while (and (re-search-forward re nil t)
 776                           (not (setq close
 777                                      (eq (char-after (1+ (match-beginning 0))) ?/)))
 778                           (goto-char (match-beginning 0))
 779                           (sgml-skip-tag-forward 1))
 780                 (setq close nil))
 781               (unless close
 782                 (goto-char point)
 783                 (setq return nil)))
 784           (forward-list 1))
 785         (setq arg (1- arg)))
 786       return)))
 787
 788 (defun sgml-delete-tag (arg)
 789   ;; FIXME: Should be called sgml-kill-tag or should not touch the kill-ring.
 790   "Delete tag on or after cursor, and matching closing or opening tag.
 791 With prefix argument ARG, repeat this ARG times."
 792   (interactive "p")
 793   (while (>= arg 1)
 794     (save-excursion
 795       (let* (close open)
 796         (if (looking-at "[ \t\n]*<")
 797             ;; just before tag
 798             (if (eq (char-after (match-end 0)) ?/)
 799                 ;; closing tag
 800                 (progn
 801                   (setq close (point))
 802                   (goto-char (match-end 0))))
 803           ;; on tag?
 804           (or (save-excursion (setq close (sgml-beginning-of-tag)
 805                                     close (and (stringp close)
 806                                                (eq (aref close 0) ?/)
 807                                                (point))))
 808               ;; not on closing tag
 809               (let ((point (point)))
 810                 (sgml-skip-tag-backward 1)
 811                 (if (or (not (eq (following-char) ?<))
 812                         (save-excursion
 813                           (forward-list 1)
 814                           (<= (point) point)))
 815                     (error "Not on or before tag")))))
 816         (if close
 817             (progn
 818               (sgml-skip-tag-backward 1)
 819               (setq open (point))
 820               (goto-char close)
 821               (kill-sexp 1))
 822           (setq open (point))
 823           (when (and (sgml-skip-tag-forward 1)
 824                      (not (looking-back "/>")))
 825             (kill-sexp -1)))
 826         ;; Delete any resulting empty line.  If we didn't kill-sexp,
 827         ;; this *should* do nothing, because we're right after the tag.
 828         (if (progn (forward-line 0) (looking-at "\\(?:[ \t]*$\\)\n?"))
 829             (delete-region (match-beginning 0) (match-end 0)))
 830         (goto-char open)
 831         (kill-sexp 1)
 832         (if (progn (forward-line 0) (looking-at "\\(?:[ \t]*$\\)\n?"))
 833             (delete-region (match-beginning 0) (match-end 0)))))
 834     (setq arg (1- arg))))
 835
 836 \f
 837 ;; Put read-only last to enable setting this even when read-only enabled.
 838 (or (get 'sgml-tag 'invisible)
 839     (setplist 'sgml-tag
 840               (append '(invisible t
 841                         point-entered sgml-point-entered
 842                         rear-nonsticky t
 843                         read-only t)
 844                       (symbol-plist 'sgml-tag))))
 845
 846 (defun sgml-tags-invisible (arg)
 847   "Toggle visibility of existing tags."
 848   (interactive "P")
 849   (let ((modified (buffer-modified-p))
 850         (inhibit-read-only t)
 851         (inhibit-modification-hooks t)
 852         ;; Avoid spurious the `file-locked' checks.
 853         (buffer-file-name nil)
 854         ;; This is needed in case font lock gets called,
 855         ;; since it moves point and might call sgml-point-entered.
 856         ;; How could it get called?  -stef
 857         (inhibit-point-motion-hooks t)
 858         string)
 859     (unwind-protect
 860         (save-excursion
 861           (goto-char (point-min))
 862           (if (set (make-local-variable 'sgml-tags-invisible)
 863                    (if arg
 864                        (>= (prefix-numeric-value arg) 0)
 865                      (not sgml-tags-invisible)))
 866               (while (re-search-forward sgml-tag-name-re nil t)
 867                 (setq string
 868                       (cdr (assq (intern-soft (downcase (match-string 1)))
 869                                  sgml-display-text)))
 870                 (goto-char (match-beginning 0))
 871                 (and (stringp string)
 872                      (not (overlays-at (point)))
 873                      (let ((ol (make-overlay (point) (match-beginning 1))))
 874                        (overlay-put ol 'before-string string)
 875                        (overlay-put ol 'sgml-tag t)))
 876                 (put-text-property (point)
 877                                    (progn (forward-list) (point))
 878                                    'category 'sgml-tag))
 879             (let ((pos (point-min)))
 880               (while (< (setq pos (next-overlay-change pos)) (point-max))
 881                 (dolist (ol (overlays-at pos))
 882                   (if (overlay-get ol 'sgml-tag)
 883                       (delete-overlay ol)))))
 884             (remove-text-properties (point-min) (point-max) '(category nil))))
 885       (restore-buffer-modified-p modified))
 886     (run-hooks 'sgml-tags-invisible-hook)
 887     (message "")))
 888
 889 (defun sgml-point-entered (x y)
 890   ;; Show preceding or following hidden tag, depending of cursor direction.
 891   (let ((inhibit-point-motion-hooks t))
 892     (save-excursion
 893       (message "Invisible tag: %s"
 894                ;; Strip properties, otherwise, the text is invisible.
 895                (buffer-substring-no-properties
 896                 (point)
 897                 (if (or (and (> x y)
 898                              (not (eq (following-char) ?<)))
 899                         (and (< x y)
 900                              (eq (preceding-char) ?>)))
 901                     (backward-list)
 902                   (forward-list)))))))
 903
 904 \f
 905 (defun sgml-validate (command)
 906   "Validate an SGML document.
 907 Runs COMMAND, a shell command, in a separate process asynchronously
 908 with output going to the buffer `*compilation*'.
 909 You can then use the command \\[next-error] to find the next error message
 910 and move to the line in the SGML document that caused it."
 911   (interactive
 912    (list (read-string "Validate command: "
 913                       (or sgml-saved-validate-command
 914                           (concat sgml-validate-command
 915                                   " "
 916                                   (let ((name (buffer-file-name)))
 917                                     (and name
 918                                          (file-name-nondirectory name))))))))
 919   (setq sgml-saved-validate-command command)
 920   (save-some-buffers (not compilation-ask-about-save) nil)
 921   (compilation-start command))
 922
 923 (defsubst sgml-at-indentation-p ()
 924   "Return true if point is at the first non-whitespace character on the line."
 925   (save-excursion
 926     (skip-chars-backward " \t")
 927     (bolp)))
 928
 929 (defun sgml-lexical-context (&optional limit)
 930   "Return the lexical context at point as (TYPE . START).
 931 START is the location of the start of the lexical element.
 932 TYPE is one of `string', `comment', `tag', `cdata', or `text'.
 933
 934 Optional argument LIMIT is the position to start parsing from.
 935 If nil, start from a preceding tag at indentation."
 936   (save-excursion
 937     (let ((pos (point))
 938           text-start state)
 939       (if limit
 940           (goto-char limit)
 941         ;; Skip tags backwards until we find one at indentation
 942         (while (and (ignore-errors (sgml-parse-tag-backward))
 943                     (not (sgml-at-indentation-p)))))
 944       (with-syntax-table sgml-tag-syntax-table
 945         (while (< (point) pos)
 946           ;; When entering this loop we're inside text.
 947           (setq text-start (point))
 948           (skip-chars-forward "^<" pos)
 949           (setq state
 950                 (cond
 951                  ((= (point) pos)
 952                   ;; We got to the end without seeing a tag.
 953                   nil)
 954                  ((looking-at "<!\\[[A-Z]+\\[")
 955                   ;; We've found a CDATA section or similar.
 956                   (let ((cdata-start (point)))
 957                     (unless (search-forward "]]>" pos 'move)
 958                       (list 0 nil nil 'cdata nil nil nil nil cdata-start))))
 959                  (t
 960                   ;; We've reached a tag.  Parse it.
 961                   ;; FIXME: Handle net-enabling start-tags
 962                   (parse-partial-sexp (point) pos 0))))))
 963       (cond
 964        ((eq (nth 3 state) 'cdata) (cons 'cdata (nth 8 state)))
 965        ((nth 3 state) (cons 'string (nth 8 state)))
 966        ((nth 4 state) (cons 'comment (nth 8 state)))
 967        ((and state (> (nth 0 state) 0)) (cons 'tag (nth 1 state)))
 968        (t (cons 'text text-start))))))
 969
 970 (defun sgml-beginning-of-tag (&optional top-level)
 971   "Skip to beginning of tag and return its name.
 972 If this can't be done, return nil."
 973   (let ((context (sgml-lexical-context)))
 974     (if (eq (car context) 'tag)
 975         (progn
 976           (goto-char (cdr context))
 977           (when (looking-at sgml-tag-name-re)
 978             (match-string-no-properties 1)))
 979       (if top-level nil
 980         (when (not (eq (car context) 'text))
 981           (goto-char (cdr context))
 982           (sgml-beginning-of-tag t))))))
 983
 984 (defun sgml-value (alist)
 985   "Interactively insert value taken from attribute-rule ALIST.
 986 See `sgml-tag-alist' for info about attribute rules."
 987   (setq alist (cdr alist))
 988   (if (stringp (car alist))
 989       (insert "=\"" (car alist) ?\")
 990     (if (and (eq (car alist) t) (not sgml-xml-mode))
 991         (when (cdr alist)
 992           (insert "=\"")
 993           (setq alist (skeleton-read '(completing-read "Value: " (cdr alist))))
 994           (if (string< "" alist)
 995               (insert alist ?\")
 996             (delete-backward-char 2)))
 997       (insert "=\"")
 998       (when alist
 999         (insert (skeleton-read '(completing-read "Value: " alist))))
1000       (insert ?\"))))
1001
1002 (defun sgml-quote (start end &optional unquotep)
1003   "Quote SGML text in region START ... END.
1004 Only &, < and > are quoted, the rest is left untouched.
1005 With prefix argument UNQUOTEP, unquote the region."
1006   (interactive "r\nP")
1007   (save-restriction
1008     (narrow-to-region start end)
1009     (goto-char (point-min))
1010     (if unquotep
1011         ;; FIXME: We should unquote other named character references as well.
1012         (while (re-search-forward
1013                 "\\(&\\(amp\\|\\(l\\|\\(g\\)\\)t\\)\\)[][<>&;\n\t \"%!'(),/=?]"
1014                 nil t)
1015           (replace-match (if (match-end 4) ">" (if (match-end 3) "<" "&")) t t
1016                          nil (if (eq (char-before (match-end 0)) ?\;) 0 1)))
1017       (while (re-search-forward "[&<>]" nil t)
1018         (replace-match (cdr (assq (char-before) '((?& . "&amp;")
1019                                                   (?< . "&lt;")
1020                                                   (?> . "&gt;"))))
1021                        t t)))))
1022
1023 (defun sgml-pretty-print (beg end)
1024   "Simple-minded pretty printer for SGML.
1025 Re-indents the code and inserts newlines between BEG and END.
1026 You might want to turn on `auto-fill-mode' to get better results."
1027   ;; TODO:
1028   ;; - insert newline between some start-tag and text.
1029   ;; - don't insert newline in front of some end-tags.
1030   (interactive "r")
1031   (save-excursion
1032     (if (< beg end)
1033         (goto-char beg)
1034       (goto-char end)
1035       (setq end beg)
1036       (setq beg (point)))
1037     ;; Don't use narrowing because it screws up auto-indent.
1038     (setq end (copy-marker end t))
1039     (with-syntax-table sgml-tag-syntax-table
1040       (while (re-search-forward "<" end t)
1041         (goto-char (match-beginning 0))
1042         (unless (or ;;(looking-at "</")
1043                     (progn (skip-chars-backward " \t") (bolp)))
1044           (reindent-then-newline-and-indent))
1045         (forward-sexp 1)))
1046     ;; (indent-region beg end)
1047     ))
1048
1049 \f
1050 ;; Parsing
1051
1052 (defstruct (sgml-tag
1053             (:constructor sgml-make-tag (type start end name)))
1054   type start end name)
1055
1056 (defsubst sgml-parse-tag-name ()
1057   "Skip past a tag-name, and return the name."
1058   (buffer-substring-no-properties
1059    (point) (progn (skip-syntax-forward "w_") (point))))
1060
1061 (defsubst sgml-looking-back-at (str)
1062   "Return t if the test before point matches STR."
1063   (let ((start (- (point) (length str))))
1064     (and (>= start (point-min))
1065          (equal str (buffer-substring-no-properties start (point))))))
1066
1067 (defun sgml-tag-text-p (start end)
1068   "Return non-nil if text between START and END is a tag.
1069 Checks among other things that the tag does not contain spurious
1070 unquoted < or > chars inside, which would indicate that it
1071 really isn't a tag after all."
1072   (save-excursion
1073     (with-syntax-table sgml-tag-syntax-table
1074       (let ((pps (parse-partial-sexp start end 2)))
1075         (and (= (nth 0 pps) 0))))))
1076
1077 (defun sgml-parse-tag-backward (&optional limit)
1078   "Parse an SGML tag backward, and return information about the tag.
1079 Assume that parsing starts from within a textual context.
1080 Leave point at the beginning of the tag."
1081   (catch 'found
1082     (let (tag-type tag-start tag-end name)
1083       (or (re-search-backward "[<>]" limit 'move)
1084           (error "No tag found"))
1085       (when (eq (char-after) ?<)
1086         ;; Oops!! Looks like we were not in a textual context after all!.
1087         ;; Let's try to recover.
1088         (with-syntax-table sgml-tag-syntax-table
1089           (let ((pos (point)))
1090             (condition-case nil
1091                 (forward-sexp)
1092               (scan-error
1093                ;; This < seems to be just a spurious one, let's ignore it.
1094                (goto-char pos)
1095                (throw 'found (sgml-parse-tag-backward limit))))
1096             ;; Check it is really a tag, without any extra < or > inside.
1097             (unless (sgml-tag-text-p pos (point))
1098               (goto-char pos)
1099               (throw 'found (sgml-parse-tag-backward limit)))
1100             (forward-char -1))))
1101       (setq tag-end (1+ (point)))
1102       (cond
1103        ((sgml-looking-back-at "--")     ; comment
1104         (setq tag-type 'comment
1105               tag-start (search-backward "<!--" nil t)))
1106        ((sgml-looking-back-at "]]")     ; cdata
1107         (setq tag-type 'cdata
1108               tag-start (re-search-backward "<!\\[[A-Z]+\\[" nil t)))
1109        (t
1110         (setq tag-start
1111               (with-syntax-table sgml-tag-syntax-table
1112                 (goto-char tag-end)
1113                 (condition-case nil
1114                     (backward-sexp)
1115                   (scan-error
1116                    ;; This > isn't really the end of a tag. Skip it.
1117                    (goto-char (1- tag-end))
1118                    (throw 'found (sgml-parse-tag-backward limit))))
1119                 (point)))
1120         (goto-char (1+ tag-start))
1121         (case (char-after)
1122           (?!                           ; declaration
1123            (setq tag-type 'decl))
1124           (??                           ; processing-instruction
1125            (setq tag-type 'pi))
1126           (?/                           ; close-tag
1127            (forward-char 1)
1128            (setq tag-type 'close
1129                  name (sgml-parse-tag-name)))
1130           (?%                           ; JSP tags
1131            (setq tag-type 'jsp))
1132           (t                            ; open or empty tag
1133            (setq tag-type 'open
1134                  name (sgml-parse-tag-name))
1135            (if (or (eq ?/ (char-before (- tag-end 1)))
1136                    (sgml-empty-tag-p name))
1137                (setq tag-type 'empty))))))
1138       (goto-char tag-start)
1139       (sgml-make-tag tag-type tag-start tag-end name))))
1140
1141 (defun sgml-get-context (&optional until)
1142   "Determine the context of the current position.
1143 By default, parse until we find a start-tag as the first thing on a line.
1144 If UNTIL is `empty', return even if the context is empty (i.e.
1145 we just skipped over some element and got to a beginning of line).
1146
1147 The context is a list of tag-info structures.  The last one is the tag
1148 immediately enclosing the current position.
1149
1150 Point is assumed to be outside of any tag.  If we discover that it's
1151 not the case, the first tag returned is the one inside which we are."
1152   (let ((here (point))
1153         (stack nil)
1154         (ignore nil)
1155         (context nil)
1156         tag-info)
1157     ;; CONTEXT keeps track of the tag-stack
1158     ;; STACK keeps track of the end tags we've seen (and thus the start-tags
1159     ;;   we'll have to ignore) when skipping over matching open..close pairs.
1160     ;; IGNORE is a list of tags that can be ignored because they have been
1161     ;;   closed implicitly.
1162     (skip-chars-backward " \t\n")      ; Make sure we're not at indentation.
1163     (while
1164         (and (not (eq until 'now))
1165              (or stack
1166                  (not (if until (eq until 'empty) context))
1167                  (not (sgml-at-indentation-p))
1168                  (and context
1169                       (/= (point) (sgml-tag-start (car context)))
1170                       (sgml-unclosed-tag-p (sgml-tag-name (car context)))))
1171              (setq tag-info (ignore-errors (sgml-parse-tag-backward))))
1172
1173       ;; This tag may enclose things we thought were tags.  If so,
1174       ;; discard them.
1175       (while (and context
1176                   (> (sgml-tag-end tag-info)
1177                      (sgml-tag-end (car context))))
1178         (setq context (cdr context)))
1179
1180       (cond
1181        ((> (sgml-tag-end tag-info) here)
1182         ;; Oops!!  Looks like we were not outside of any tag, after all.
1183         (push tag-info context)
1184         (setq until 'now))
1185
1186        ;; start-tag
1187        ((eq (sgml-tag-type tag-info) 'open)
1188         (cond
1189          ((null stack)
1190           (if (member-ignore-case (sgml-tag-name tag-info) ignore)
1191               ;; There was an implicit end-tag.
1192               nil
1193             (push tag-info context)
1194             ;; We're changing context so the tags implicitly closed inside
1195             ;; the previous context aren't implicitly closed here any more.
1196             ;; [ Well, actually it depends, but we don't have the info about
1197             ;; when it doesn't and when it does.   --Stef ]
1198             (setq ignore nil)))
1199          ((eq t (compare-strings (sgml-tag-name tag-info) nil nil
1200                                  (car stack) nil nil t))
1201           (setq stack (cdr stack)))
1202          (t
1203           ;; The open and close tags don't match.
1204           (if (not sgml-xml-mode)
1205               (unless (sgml-unclosed-tag-p (sgml-tag-name tag-info))
1206                 (message "Unclosed tag <%s>" (sgml-tag-name tag-info))
1207                 (let ((tmp stack))
1208                   ;; We could just assume that the tag is simply not closed
1209                   ;; but it's a bad assumption when tags *are* closed but
1210                   ;; not properly nested.
1211                   (while (and (cdr tmp)
1212                               (not (eq t (compare-strings
1213                                           (sgml-tag-name tag-info) nil nil
1214                                           (cadr tmp) nil nil t))))
1215                     (setq tmp (cdr tmp)))
1216                   (if (cdr tmp) (setcdr tmp (cddr tmp)))))
1217             (message "Unmatched tags <%s> and </%s>"
1218                      (sgml-tag-name tag-info) (pop stack)))))
1219
1220         (if (and (null stack) (sgml-unclosed-tag-p (sgml-tag-name tag-info)))
1221             ;; This is a top-level open of an implicitly closed tag, so any
1222             ;; occurrence of such an open tag at the same level can be ignored
1223             ;; because it's been implicitly closed.
1224             (push (sgml-tag-name tag-info) ignore)))
1225
1226        ;; end-tag
1227        ((eq (sgml-tag-type tag-info) 'close)
1228         (if (sgml-empty-tag-p (sgml-tag-name tag-info))
1229             (message "Spurious </%s>: empty tag" (sgml-tag-name tag-info))
1230           (push (sgml-tag-name tag-info) stack)))
1231        ))
1232
1233     ;; return context
1234     context))
1235
1236 (defun sgml-show-context (&optional full)
1237   "Display the current context.
1238 If FULL is non-nil, parse back to the beginning of the buffer."
1239   (interactive "P")
1240   (with-output-to-temp-buffer "*XML Context*"
1241     (save-excursion
1242       (let ((context (sgml-get-context)))
1243         (when full
1244           (let ((more nil))
1245             (while (setq more (sgml-get-context))
1246               (setq context (nconc more context)))))
1247         (pp context)))))
1248
1249 \f
1250 ;; Editing shortcuts
1251
1252 (defun sgml-close-tag ()
1253   "Close current element.
1254 Depending on context, inserts a matching close-tag, or closes
1255 the current start-tag or the current comment or the current cdata, ..."
1256   (interactive)
1257   (case (car (sgml-lexical-context))
1258     (comment    (insert " -->"))
1259     (cdata      (insert "]]>"))
1260     (pi         (insert " ?>"))
1261     (jsp        (insert " %>"))
1262     (tag        (insert " />"))
1263     (text
1264      (let ((context (save-excursion (sgml-get-context))))
1265        (if context
1266            (progn
1267              (insert "</" (sgml-tag-name (car (last context))) ">")
1268              (indent-according-to-mode)))))
1269     (otherwise
1270      (error "Nothing to close"))))
1271
1272 (defun sgml-empty-tag-p (tag-name)
1273   "Return non-nil if TAG-NAME is an implicitly empty tag."
1274   (and (not sgml-xml-mode)
1275        (member-ignore-case tag-name sgml-empty-tags)))
1276
1277 (defun sgml-unclosed-tag-p (tag-name)
1278   "Return non-nil if TAG-NAME is a tag for which an end-tag is optional."
1279   (and (not sgml-xml-mode)
1280        (member-ignore-case tag-name sgml-unclosed-tags)))
1281
1282 (defun sgml-calculate-indent (&optional lcon)
1283   "Calculate the column to which this line should be indented.
1284 LCON is the lexical context, if any."
1285   (unless lcon (setq lcon (sgml-lexical-context)))
1286
1287   ;; Indent comment-start markers inside <!-- just like comment-end markers.
1288   (if (and (eq (car lcon) 'tag)
1289            (looking-at "--")
1290            (save-excursion (goto-char (cdr lcon)) (looking-at "<!--")))
1291       (setq lcon (cons 'comment (+ (cdr lcon) 2))))
1292
1293   (case (car lcon)
1294
1295     (string
1296      ;; Go back to previous non-empty line.
1297      (while (and (> (point) (cdr lcon))
1298                  (zerop (forward-line -1))
1299                  (looking-at "[ \t]*$")))
1300      (if (> (point) (cdr lcon))
1301          ;; Previous line is inside the string.
1302          (current-indentation)
1303        (goto-char (cdr lcon))
1304        (1+ (current-column))))
1305
1306     (comment
1307      (let ((mark (looking-at "--")))
1308        ;; Go back to previous non-empty line.
1309        (while (and (> (point) (cdr lcon))
1310                    (zerop (forward-line -1))
1311                    (or (looking-at "[ \t]*$")
1312                        (if mark (not (looking-at "[ \t]*--"))))))
1313        (if (> (point) (cdr lcon))
1314            ;; Previous line is inside the comment.
1315            (skip-chars-forward " \t")
1316          (goto-char (cdr lcon))
1317          ;; Skip `<!' to get to the `--' with which we want to align.
1318          (search-forward "--")
1319          (goto-char (match-beginning 0)))
1320        (when (and (not mark) (looking-at "--"))
1321          (forward-char 2) (skip-chars-forward " \t"))
1322        (current-column)))
1323
1324     ;; We don't know how to indent it.  Let's be honest about it.
1325     (cdata nil)
1326
1327     (tag
1328      (goto-char (1+ (cdr lcon)))
1329      (skip-chars-forward "^ \t\n")      ;Skip tag name.
1330      (skip-chars-forward " \t")
1331      (if (not (eolp))
1332          (current-column)
1333        ;; This is the first attribute: indent.
1334        (goto-char (1+ (cdr lcon)))
1335        (+ (current-column) sgml-basic-offset)))
1336
1337     (text
1338      (while (looking-at "</")
1339        (forward-sexp 1)
1340        (skip-chars-forward " \t"))
1341      (let* ((here (point))
1342             (unclosed (and ;; (not sgml-xml-mode)
1343                        (looking-at sgml-tag-name-re)
1344                        (member-ignore-case (match-string 1)
1345                                            sgml-unclosed-tags)
1346                        (match-string 1)))
1347             (context
1348              ;; If possible, align on the previous non-empty text line.
1349              ;; Otherwise, do a more serious parsing to find the
1350              ;; tag(s) relative to which we should be indenting.
1351              (if (and (not unclosed) (skip-chars-backward " \t")
1352                       (< (skip-chars-backward " \t\n") 0)
1353                       (back-to-indentation)
1354                       (> (point) (cdr lcon)))
1355                  nil
1356                (goto-char here)
1357                (nreverse (sgml-get-context (if unclosed nil 'empty)))))
1358             (there (point)))
1359        ;; Ignore previous unclosed start-tag in context.
1360        (while (and context unclosed
1361                    (eq t (compare-strings
1362                           (sgml-tag-name (car context)) nil nil
1363                           unclosed nil nil t)))
1364          (setq context (cdr context)))
1365        ;; Indent to reflect nesting.
1366        (cond
1367         ;; If we were not in a text context after all, let's try again.
1368         ((and context (> (sgml-tag-end (car context)) here))
1369          (goto-char here)
1370          (sgml-calculate-indent
1371           (cons (if (memq (sgml-tag-type (car context)) '(comment cdata))
1372                     (sgml-tag-type (car context)) 'tag)
1373                 (sgml-tag-start (car context)))))
1374         ;; Align on the first element after the nearest open-tag, if any.
1375         ((and context
1376               (goto-char (sgml-tag-end (car context)))
1377               (skip-chars-forward " \t\n")
1378               (< (point) here) (sgml-at-indentation-p))
1379          (current-column))
1380         (t
1381          (goto-char there)
1382          (+ (current-column)
1383             (* sgml-basic-offset (length context)))))))
1384
1385     (otherwise
1386      (error "Unrecognized context %s" (car lcon)))
1387
1388     ))
1389
1390 (defun sgml-indent-line ()
1391   "Indent the current line as SGML."
1392   (interactive)
1393   (let* ((savep (point))
1394          (indent-col
1395           (save-excursion
1396             (back-to-indentation)
1397             (if (>= (point) savep) (setq savep nil))
1398             (sgml-calculate-indent))))
1399     (if (null indent-col)
1400         'noindent
1401       (if savep
1402           (save-excursion (indent-line-to indent-col))
1403         (indent-line-to indent-col)))))
1404
1405 (defun sgml-guess-indent ()
1406   "Guess an appropriate value for `sgml-basic-offset'.
1407 Base the guessed identation level on the first indented tag in the buffer.
1408 Add this to `sgml-mode-hook' for convenience."
1409   (interactive)
1410   (save-excursion
1411     (goto-char (point-min))
1412     (if (re-search-forward "^\\([ \t]+\\)<" 500 'noerror)
1413         (progn
1414           (set (make-local-variable 'sgml-basic-offset)
1415                (1- (current-column)))
1416           (message "Guessed sgml-basic-offset = %d"
1417                    sgml-basic-offset)
1418           ))))
1419
1420 (defun sgml-parse-dtd ()
1421   "Simplistic parse of the current buffer as a DTD.
1422 Currently just returns (EMPTY-TAGS UNCLOSED-TAGS)."
1423   (goto-char (point-min))
1424   (let ((empty nil)
1425         (unclosed nil))
1426     (while (re-search-forward "<!ELEMENT[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+[-O][ \t\n]+\\([-O]\\)[ \t\n]+\\([^ \t\n]+\\)" nil t)
1427       (cond
1428        ((string= (match-string 3) "EMPTY")
1429         (push (match-string-no-properties 1) empty))
1430        ((string= (match-string 2) "O")
1431         (push (match-string-no-properties 1) unclosed))))
1432     (setq empty (sort (mapcar 'downcase empty) 'string<))
1433     (setq unclosed (sort (mapcar 'downcase unclosed) 'string<))
1434     (list empty unclosed)))
1435
1436 ;;; HTML mode
1437
1438 (defcustom html-mode-hook nil
1439   "Hook run by command `html-mode'.
1440 `text-mode-hook' and `sgml-mode-hook' are run first."
1441   :group 'sgml
1442   :type 'hook
1443   :options '(html-autoview-mode))
1444
1445 (defvar html-quick-keys sgml-quick-keys
1446   "Use C-c X combinations for quick insertion of frequent tags when non-nil.
1447 This defaults to `sgml-quick-keys'.
1448 This takes effect when first loading the library.")
1449
1450 (defvar html-mode-map
1451   (let ((map (make-sparse-keymap))
1452         (menu-map (make-sparse-keymap "HTML")))
1453     (set-keymap-parent map  sgml-mode-map)
1454     (define-key map "\C-c6" 'html-headline-6)
1455     (define-key map "\C-c5" 'html-headline-5)
1456     (define-key map "\C-c4" 'html-headline-4)
1457     (define-key map "\C-c3" 'html-headline-3)
1458     (define-key map "\C-c2" 'html-headline-2)
1459     (define-key map "\C-c1" 'html-headline-1)
1460     (define-key map "\C-c\r" 'html-paragraph)
1461     (define-key map "\C-c\n" 'html-line)
1462     (define-key map "\C-c\C-c-" 'html-horizontal-rule)
1463     (define-key map "\C-c\C-co" 'html-ordered-list)
1464     (define-key map "\C-c\C-cu" 'html-unordered-list)
1465     (define-key map "\C-c\C-cr" 'html-radio-buttons)
1466     (define-key map "\C-c\C-cc" 'html-checkboxes)
1467     (define-key map "\C-c\C-cl" 'html-list-item)
1468     (define-key map "\C-c\C-ch" 'html-href-anchor)
1469     (define-key map "\C-c\C-cn" 'html-name-anchor)
1470     (define-key map "\C-c\C-ci" 'html-image)
1471     (when html-quick-keys
1472       (define-key map "\C-c-" 'html-horizontal-rule)
1473       (define-key map "\C-co" 'html-ordered-list)
1474       (define-key map "\C-cu" 'html-unordered-list)
1475       (define-key map "\C-cr" 'html-radio-buttons)
1476       (define-key map "\C-cc" 'html-checkboxes)
1477       (define-key map "\C-cl" 'html-list-item)
1478       (define-key map "\C-ch" 'html-href-anchor)
1479       (define-key map "\C-cn" 'html-name-anchor)
1480       (define-key map "\C-ci" 'html-image))
1481     (define-key map "\C-c\C-s" 'html-autoview-mode)
1482     (define-key map "\C-c\C-v" 'browse-url-of-buffer)
1483     (define-key map [menu-bar html] (cons "HTML" menu-map))
1484     (define-key menu-map [html-autoview-mode]
1485       '("Toggle Autoviewing" . html-autoview-mode))
1486     (define-key menu-map [browse-url-of-buffer]
1487       '("View Buffer Contents" . browse-url-of-buffer))
1488     (define-key menu-map [nil] '("--"))
1489     ;;(define-key menu-map "6" '("Heading 6" . html-headline-6))
1490     ;;(define-key menu-map "5" '("Heading 5" . html-headline-5))
1491     ;;(define-key menu-map "4" '("Heading 4" . html-headline-4))
1492     (define-key menu-map "3" '("Heading 3" . html-headline-3))
1493     (define-key menu-map "2" '("Heading 2" . html-headline-2))
1494     (define-key menu-map "1" '("Heading 1" . html-headline-1))
1495     (define-key menu-map "l" '("Radio Buttons" . html-radio-buttons))
1496     (define-key menu-map "c" '("Checkboxes" . html-checkboxes))
1497     (define-key menu-map "l" '("List Item" . html-list-item))
1498     (define-key menu-map "u" '("Unordered List" . html-unordered-list))
1499     (define-key menu-map "o" '("Ordered List" . html-ordered-list))
1500     (define-key menu-map "-" '("Horizontal Rule" . html-horizontal-rule))
1501     (define-key menu-map "\n" '("Line Break" . html-line))
1502     (define-key menu-map "\r" '("Paragraph" . html-paragraph))
1503     (define-key menu-map "i" '("Image" . html-image))
1504     (define-key menu-map "h" '("Href Anchor" . html-href-anchor))
1505     (define-key menu-map "n" '("Name Anchor" . html-name-anchor))
1506     map)
1507   "Keymap for commands for use in HTML mode.")
1508
1509 (defvar html-face-tag-alist
1510   '((bold . "b")
1511     (italic . "i")
1512     (underline . "u")
1513     (modeline . "rev"))
1514   "Value of `sgml-face-tag-alist' for HTML mode.")
1515
1516 (defvar html-tag-face-alist
1517   '(("b" . bold)
1518     ("big" . bold)
1519     ("blink" . highlight)
1520     ("cite" . italic)
1521     ("em" . italic)
1522     ("h1" bold underline)
1523     ("h2" bold-italic underline)
1524     ("h3" italic underline)
1525     ("h4" . underline)
1526     ("h5" . underline)
1527     ("h6" . underline)
1528     ("i" . italic)
1529     ("rev"  . modeline)
1530     ("s" . underline)
1531     ("small" . default)
1532     ("strong" . bold)
1533     ("title" bold underline)
1534     ("tt" . default)
1535     ("u" . underline)
1536     ("var" . italic))
1537   "Value of `sgml-tag-face-alist' for HTML mode.")
1538
1539 (defvar html-display-text
1540   '((img . "[/]")
1541     (hr . "----------")
1542     (li . "o "))
1543   "Value of `sgml-display-text' for HTML mode.")
1544
1545 \f
1546 ;; should code exactly HTML 3 here when that is finished
1547 (defvar html-tag-alist
1548   (let* ((1-7 '(("1") ("2") ("3") ("4") ("5") ("6") ("7")))
1549          (1-9 `(,@1-7 ("8") ("9")))
1550          (align '(("align" ("left") ("center") ("right"))))
1551          (valign '(("top") ("middle") ("bottom") ("baseline")))
1552          (rel '(("next") ("previous") ("parent") ("subdocument") ("made")))
1553          (href '("href" ("ftp:") ("file:") ("finger:") ("gopher:") ("http:")
1554                  ("mailto:") ("news:") ("rlogin:") ("telnet:") ("tn3270:")
1555                  ("wais:") ("/cgi-bin/")))
1556          (name '("name"))
1557          (link `(,href
1558                  ("rel" ,@rel)
1559                  ("rev" ,@rel)
1560                  ("title")))
1561          (list '((nil \n ("List item: " "<li>" str
1562                           (if sgml-xml-mode "</li>") \n))))
1563          (cell `(t
1564                  ,@align
1565                  ("valign" ,@valign)
1566                  ("colspan" ,@1-9)
1567                  ("rowspan" ,@1-9)
1568                  ("nowrap" t))))
1569     ;; put ,-expressions first, else byte-compile chokes (as of V19.29)
1570     ;; and like this it's more efficient anyway
1571     `(("a" ,name ,@link)
1572       ("base" t ,@href)
1573       ("dir" ,@list)
1574       ("font" nil "size" ("-1") ("+1") ("-2") ("+2") ,@1-7)
1575       ("form" (\n _ \n "<input type=\"submit\" value=\"\""
1576                (if sgml-xml-mode " />" ">"))
1577        ("action" ,@(cdr href)) ("method" ("get") ("post")))
1578       ("h1" ,@align)
1579       ("h2" ,@align)
1580       ("h3" ,@align)
1581       ("h4" ,@align)
1582       ("h5" ,@align)
1583       ("h6" ,@align)
1584       ("hr" t ("size" ,@1-9) ("width") ("noshade" t) ,@align)
1585       ("img" t ("align" ,@valign ("texttop") ("absmiddle") ("absbottom"))
1586        ("src") ("alt") ("width" "1") ("height" "1")
1587        ("border" "1") ("vspace" "1") ("hspace" "1") ("ismap" t))
1588       ("input" t ("size" ,@1-9) ("maxlength" ,@1-9) ("checked" t) ,name
1589        ("type" ("text") ("password") ("checkbox") ("radio")
1590         ("submit") ("reset"))
1591        ("value"))
1592       ("link" t ,@link)
1593       ("menu" ,@list)
1594       ("ol" ,@list ("type" ("A") ("a") ("I") ("i") ("1")))
1595       ("p" t ,@align)
1596       ("select" (nil \n
1597                      ("Text: "
1598                       "<option>" str (if sgml-xml-mode "</option>") \n))
1599        ,name ("size" ,@1-9) ("multiple" t))
1600       ("table" (nil \n
1601                     ((completing-read "Cell kind: " '(("td") ("th"))
1602                                       nil t "t")
1603                      "<tr><" str ?> _
1604                      (if sgml-xml-mode (concat "<" str "></tr>")) \n))
1605        ("border" t ,@1-9) ("width" "10") ("cellpadding"))
1606       ("td" ,@cell)
1607       ("textarea" ,name ("rows" ,@1-9) ("cols" ,@1-9))
1608       ("th" ,@cell)
1609       ("ul" ,@list ("type" ("disc") ("circle") ("square")))
1610
1611       ,@sgml-tag-alist
1612
1613       ("abbrev")
1614       ("acronym")
1615       ("address")
1616       ("array" (nil \n
1617                     ("Item: " "<item>" str (if sgml-xml-mode "</item>") \n))
1618        "align")
1619       ("au")
1620       ("b")
1621       ("big")
1622       ("blink")
1623       ("blockquote" \n)
1624       ("body" \n ("background" ".gif") ("bgcolor" "#") ("text" "#")
1625        ("link" "#") ("alink" "#") ("vlink" "#"))
1626       ("box" (nil _ "<over>" _ (if sgml-xml-mode "</over>")))
1627       ("br" t ("clear" ("left") ("right")))
1628       ("caption" ("valign" ("top") ("bottom")))
1629       ("center" \n)
1630       ("cite")
1631       ("code" \n)
1632       ("dd" ,(not sgml-xml-mode))
1633       ("del")
1634       ("dfn")
1635       ("div")
1636       ("dl" (nil \n
1637                  ( "Term: "
1638                    "<dt>" str (if sgml-xml-mode "</dt>")
1639                    "<dd>" _ (if sgml-xml-mode "</dd>") \n)))
1640       ("dt" (t _ (if sgml-xml-mode "</dt>")
1641              "<dd>" (if sgml-xml-mode "</dd>") \n))
1642       ("em")
1643       ;("fn" "id" "fn")  ; ???
1644       ("head" \n)
1645       ("html" (\n
1646                "<head>\n"
1647                "<title>" (setq str (read-input "Title: ")) "</title>\n"
1648                "</head>\n"
1649                "<body>\n<h1>" str "</h1>\n" _
1650                "\n<address>\n<a href=\"mailto:"
1651                user-mail-address
1652                "\">" (user-full-name) "</a>\n</address>\n"
1653                "</body>"
1654                 ))
1655       ("i")
1656       ("ins")
1657       ("isindex" t ("action") ("prompt"))
1658       ("kbd")
1659       ("lang")
1660       ("li" ,(not sgml-xml-mode))
1661       ("math" \n)
1662       ("nobr")
1663       ("option" t ("value") ("label") ("selected" t))
1664       ("over" t)
1665       ("person")
1666       ("pre" \n)
1667       ("q")
1668       ("rev")
1669       ("s")
1670       ("samp")
1671       ("small")
1672       ("span" nil
1673         ("class"
1674          ("builtin")
1675          ("comment")
1676          ("constant")
1677          ("function-name")
1678          ("keyword")
1679          ("string")
1680          ("type")
1681          ("variable-name")
1682          ("warning")))
1683       ("strong")
1684       ("sub")
1685       ("sup")
1686       ("title")
1687       ("tr" t)
1688       ("tt")
1689       ("u")
1690       ("var")
1691       ("wbr" t)))
1692   "*Value of `sgml-tag-alist' for HTML mode.")
1693
1694 (defvar html-tag-help
1695   `(,@sgml-tag-help
1696     ("a" . "Anchor of point or link elsewhere")
1697     ("abbrev" . "?")
1698     ("acronym" . "?")
1699     ("address" . "Formatted mail address")
1700     ("array" . "Math array")
1701     ("au" . "?")
1702     ("b" . "Bold face")
1703     ("base" . "Base address for URLs")
1704     ("big" . "Font size")
1705     ("blink" . "Blinking text")
1706     ("blockquote" . "Indented quotation")
1707     ("body" . "Document body")
1708     ("box" . "Math fraction")
1709     ("br" . "Line break")
1710     ("caption" . "Table caption")
1711     ("center" . "Centered text")
1712     ("changed" . "Change bars")
1713     ("cite" . "Citation of a document")
1714     ("code" . "Formatted source code")
1715     ("dd" . "Definition of term")
1716     ("del" . "?")
1717     ("dfn" . "?")
1718     ("dir" . "Directory list (obsolete)")
1719     ("dl" . "Definition list")
1720     ("dt" . "Term to be definined")
1721     ("em" . "Emphasized")
1722     ("embed" . "Embedded data in foreign format")
1723     ("fig" . "Figure")
1724     ("figa" . "Figure anchor")
1725     ("figd" . "Figure description")
1726     ("figt" . "Figure text")
1727     ;("fn" . "?")  ; ???
1728     ("font" . "Font size")
1729     ("form" . "Form with input fields")
1730     ("group" . "Document grouping")
1731     ("h1" . "Most important section headline")
1732     ("h2" . "Important section headline")
1733     ("h3" . "Section headline")
1734     ("h4" . "Minor section headline")
1735     ("h5" . "Unimportant section headline")
1736     ("h6" . "Least important section headline")
1737     ("head" . "Document header")
1738     ("hr" . "Horizontal rule")
1739     ("html" . "HTML Document")
1740     ("i" . "Italic face")
1741     ("img" . "Graphic image")
1742     ("input" . "Form input field")
1743     ("ins" . "?")
1744     ("isindex" . "Input field for index search")
1745     ("kbd" . "Keybard example face")
1746     ("lang" . "Natural language")
1747     ("li" . "List item")
1748     ("link" . "Link relationship")
1749     ("math" . "Math formula")
1750     ("menu" . "Menu list (obsolete)")
1751     ("mh" . "Form mail header")
1752     ("nextid" . "Allocate new id")
1753     ("nobr" . "Text without line break")
1754     ("ol" . "Ordered list")
1755     ("option" . "Selection list item")
1756     ("over" . "Math fraction rule")
1757     ("p" . "Paragraph start")
1758     ("panel" . "Floating panel")
1759     ("person" . "?")
1760     ("pre" . "Preformatted fixed width text")
1761     ("q" . "?")
1762     ("rev" . "Reverse video")
1763     ("s" . "?")
1764     ("samp" . "Sample text")
1765     ("select" . "Selection list")
1766     ("small" . "Font size")
1767     ("sp" . "Nobreak space")
1768     ("strong" . "Standout text")
1769     ("sub" . "Subscript")
1770     ("sup" . "Superscript")
1771     ("table" . "Table with rows and columns")
1772     ("tb" . "Table vertical break")
1773     ("td" . "Table data cell")
1774     ("textarea" . "Form multiline edit area")
1775     ("th" . "Table header cell")
1776     ("title" . "Document title")
1777     ("tr" . "Table row separator")
1778     ("tt" . "Typewriter face")
1779     ("u" . "Underlined text")
1780     ("ul" . "Unordered list")
1781     ("var" . "Math variable face")
1782     ("wbr" . "Enable <br> within <nobr>"))
1783 "*Value of `sgml-tag-help' for HTML mode.")
1784
1785 \f
1786 ;;;###autoload
1787 (define-derived-mode html-mode sgml-mode "HTML"
1788   "Major mode based on SGML mode for editing HTML documents.
1789 This allows inserting skeleton constructs used in hypertext documents with
1790 completion.  See below for an introduction to HTML.  Use
1791 \\[browse-url-of-buffer] to see how this comes out.  See also `sgml-mode' on
1792 which this is based.
1793
1794 Do \\[describe-variable] html- SPC and \\[describe-variable] sgml- SPC to see available variables.
1795
1796 To write fairly well formatted pages you only need to know few things.  Most
1797 browsers have a function to read the source code of the page being seen, so
1798 you can imitate various tricks.  Here's a very short HTML primer which you
1799 can also view with a browser to see what happens:
1800
1801 <title>A Title Describing Contents</title> should be on every page.  Pages can
1802 have <h1>Very Major Headlines</h1> through <h6>Very Minor Headlines</h6>
1803 <hr> Parts can be separated with horizontal rules.
1804
1805 <p>Paragraphs only need an opening tag.  Line breaks and multiple spaces are
1806 ignored unless the text is <pre>preformatted.</pre>  Text can be marked as
1807 <b>bold</b>, <i>italic</i> or <u>underlined</u> using the normal M-o or
1808 Edit/Text Properties/Face commands.
1809
1810 Pages can have <a name=\"SOMENAME\">named points</a> and can link other points
1811 to them with <a href=\"#SOMENAME\">see also somename</a>.  In the same way <a
1812 href=\"URL\">see also URL</a> where URL is a filename relative to current
1813 directory, or absolute as in `http://www.cs.indiana.edu/elisp/w3/docs.html'.
1814
1815 Images in many formats can be inlined with <img src=\"URL\">.
1816
1817 If you mainly create your own documents, `sgml-specials' might be
1818 interesting.  But note that some HTML 2 browsers can't handle `&apos;'.
1819 To work around that, do:
1820    (eval-after-load \"sgml-mode\" '(aset sgml-char-names ?' nil))
1821
1822 \\{html-mode-map}"
1823   (set (make-local-variable 'sgml-display-text) html-display-text)
1824   (set (make-local-variable 'sgml-tag-face-alist) html-tag-face-alist)
1825   (make-local-variable 'sgml-tag-alist)
1826   (make-local-variable 'sgml-face-tag-alist)
1827   (make-local-variable 'sgml-tag-help)
1828   (make-local-variable 'outline-regexp)
1829   (make-local-variable 'outline-heading-end-regexp)
1830   (make-local-variable 'outline-level)
1831   (make-local-variable 'sentence-end-base)
1832   (setq sentence-end-base "[.?!][]\"'\e$B!I\e$,1r}\e(B)}]*\\(<[^>]*>\\)*"
1833         sgml-tag-alist html-tag-alist
1834         sgml-face-tag-alist html-face-tag-alist
1835         sgml-tag-help html-tag-help
1836         outline-regexp "^.*<[Hh][1-6]\\>"
1837         outline-heading-end-regexp "</[Hh][1-6]>"
1838         outline-level (lambda ()
1839                         (char-before (match-end 0))))
1840   (setq imenu-create-index-function 'html-imenu-index)
1841   (when sgml-xml-mode (setq mode-name "XHTML"))
1842   (set (make-local-variable 'sgml-empty-tags)
1843        ;; From HTML-4.01's loose.dtd, parsed with `sgml-parse-dtd',
1844        ;; plus manual addition of "wbr".
1845        '("area" "base" "basefont" "br" "col" "frame" "hr" "img" "input"
1846          "isindex" "link" "meta" "param" "wbr"))
1847   (set (make-local-variable 'sgml-unclosed-tags)
1848        ;; From HTML-4.01's loose.dtd, parsed with `sgml-parse-dtd'.
1849        '("body" "colgroup" "dd" "dt" "head" "html" "li" "option"
1850          "p" "tbody" "td" "tfoot" "th" "thead" "tr"))
1851   ;; It's for the user to decide if it defeats it or not  -stef
1852   ;; (make-local-variable 'imenu-sort-function)
1853   ;; (setq imenu-sort-function nil) ; sorting the menu defeats the purpose
1854   )
1855
1856 (defvar html-imenu-regexp
1857   "\\s-*<h\\([1-9]\\)[^\n<>]*>\\(<[^\n<>]*>\\)*\\s-*\\([^\n<>]*\\)"
1858   "*A regular expression matching a head line to be added to the menu.
1859 The first `match-string' should be a number from 1-9.
1860 The second `match-string' matches extra tags and is ignored.
1861 The third `match-string' will be the used in the menu.")
1862
1863 (defun html-imenu-index ()
1864   "Return a table of contents for an HTML buffer for use with Imenu."
1865   (let (toc-index)
1866     (save-excursion
1867       (goto-char (point-min))
1868       (while (re-search-forward html-imenu-regexp nil t)
1869         (setq toc-index
1870               (cons (cons (concat (make-string
1871                                    (* 2 (1- (string-to-number (match-string 1))))
1872                                    ?\s)
1873                                   (match-string 3))
1874                           (line-beginning-position))
1875                     toc-index))))
1876     (nreverse toc-index)))
1877
1878 (define-minor-mode html-autoview-mode
1879   "Toggle automatic viewing via `browse-url-of-buffer' upon saving buffer.
1880 With positive prefix ARG always turns viewing on, with negative ARG always off.
1881 Can be used as a value for `html-mode-hook'."
1882   nil nil nil
1883   :group 'sgml
1884   (if html-autoview-mode
1885       (add-hook 'after-save-hook 'browse-url-of-buffer nil t)
1886     (remove-hook 'after-save-hook 'browse-url-of-buffer t)))
1887
1888 \f
1889 (define-skeleton html-href-anchor
1890   "HTML anchor tag with href attribute."
1891   "URL: "
1892   ;; '(setq input "http:")
1893   "<a href=\"" str "\">" _ "</a>")
1894
1895 (define-skeleton html-name-anchor
1896   "HTML anchor tag with name attribute."
1897   "Name: "
1898   "<a name=\"" str "\""
1899   (if sgml-xml-mode (concat " id=\"" str "\""))
1900   ">" _ "</a>")
1901
1902 (define-skeleton html-headline-1
1903   "HTML level 1 headline tags."
1904   nil
1905   "<h1>" _ "</h1>")
1906
1907 (define-skeleton html-headline-2
1908   "HTML level 2 headline tags."
1909   nil
1910   "<h2>" _ "</h2>")
1911
1912 (define-skeleton html-headline-3
1913   "HTML level 3 headline tags."
1914   nil
1915   "<h3>" _ "</h3>")
1916
1917 (define-skeleton html-headline-4
1918   "HTML level 4 headline tags."
1919   nil
1920   "<h4>" _ "</h4>")
1921
1922 (define-skeleton html-headline-5
1923   "HTML level 5 headline tags."
1924   nil
1925   "<h5>" _ "</h5>")
1926
1927 (define-skeleton html-headline-6
1928   "HTML level 6 headline tags."
1929   nil
1930   "<h6>" _ "</h6>")
1931
1932 (define-skeleton html-horizontal-rule
1933   "HTML horizontal rule tag."
1934   nil
1935   (if sgml-xml-mode "<hr />" "<hr>") \n)
1936
1937 (define-skeleton html-image
1938   "HTML image tag."
1939   "Image URL: "
1940   "<img src=\"" str "\" alt=\"" _ "\""
1941   (if sgml-xml-mode " />" ">"))
1942
1943 (define-skeleton html-line
1944   "HTML line break tag."
1945   nil
1946   (if sgml-xml-mode "<br />" "<br>") \n)
1947
1948 (define-skeleton html-ordered-list
1949   "HTML ordered list tags."
1950   nil
1951   "<ol>" \n
1952   "<li>" _ (if sgml-xml-mode "</li>") \n
1953   "</ol>")
1954
1955 (define-skeleton html-unordered-list
1956   "HTML unordered list tags."
1957   nil
1958   "<ul>" \n
1959   "<li>" _ (if sgml-xml-mode "</li>") \n
1960   "</ul>")
1961
1962 (define-skeleton html-list-item
1963   "HTML list item tag."
1964   nil
1965   (if (bolp) nil '\n)
1966   "<li>" _ (if sgml-xml-mode "</li>"))
1967
1968 (define-skeleton html-paragraph
1969   "HTML paragraph tag."
1970   nil
1971   (if (bolp) nil ?\n)
1972   "<p>" _ (if sgml-xml-mode "</p>"))
1973
1974 (define-skeleton html-checkboxes
1975   "Group of connected checkbox inputs."
1976   nil
1977   '(setq v1 nil
1978          v2 nil)
1979   ("Value: "
1980    "<input type=\"" (identity "checkbox") ; see comment above about identity
1981    "\" name=\"" (or v1 (setq v1 (skeleton-read "Name: ")))
1982    "\" value=\"" str ?\"
1983    (when (y-or-n-p "Set \"checked\" attribute? ")
1984      (funcall skeleton-transformation
1985               (if sgml-xml-mode " checked=\"checked\"" " checked")))
1986    (if sgml-xml-mode " />" ">")
1987    (skeleton-read "Text: " (capitalize str))
1988    (or v2 (setq v2 (if (y-or-n-p "Newline after text? ")
1989                        (funcall skeleton-transformation
1990                                 (if sgml-xml-mode "<br />" "<br>"))
1991                      "")))
1992    \n))
1993
1994 (define-skeleton html-radio-buttons
1995   "Group of connected radio button inputs."
1996   nil
1997   '(setq v1 nil
1998          v2 (cons nil nil))
1999   ("Value: "
2000    "<input type=\"" (identity "radio") ; see comment above about identity
2001    "\" name=\"" (or (car v2) (setcar v2 (skeleton-read "Name: ")))
2002    "\" value=\"" str ?\"
2003    (when (and (not v1) (setq v1 (y-or-n-p "Set \"checked\" attribute? ")))
2004      (funcall skeleton-transformation
2005               (if sgml-xml-mode " checked=\"checked\"" " checked")))
2006    (if sgml-xml-mode " />" ">")
2007    (skeleton-read "Text: " (capitalize str))
2008    (or (cdr v2) (setcdr v2 (if (y-or-n-p "Newline after text? ")
2009                                (funcall skeleton-transformation
2010                                         (if sgml-xml-mode "<br />" "<br>"))
2011                              "")))
2012    \n))
2013
2014 (provide 'sgml-mode)
2015
2016 ;; arch-tag: 9675da94-b7f9-4bda-ad19-73ed7b4fb401
2017 ;;; sgml-mode.el ends here