cgit.sxemacs.org Git - packages/blob - xemacs-packages/psgml/psgml-edit.el

   1 ;;; psgml-edit.el --- Editing commands for SGML-mode with parsing support
   2 ;;
   3 ;; $Id: psgml-edit.el,v 2.73 2005/03/02 19:46:31 lenst Exp $
   4
   5 ;; Copyright (C) 1994, 1995, 1996 Lennart Staflin
   6
   7 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
   8
   9 ;; This program is free software; you can redistribute it and/or
  10 ;; modify it under the terms of the GNU General Public License
  11 ;; as published by the Free Software Foundation; either version 2
  12 ;; of the License, or (at your option) any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, write to the Free Software
  21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 \f
  24 ;;;; Commentary:
  25
  26 ;; Part of major mode for editing the SGML document-markup language.
  27
  28 \f
  29 ;;;; Code:
  30
  31 (provide 'psgml-edit)
  32 (require 'psgml)
  33 (require 'psgml-parse)
  34 (require 'psgml-ids)
  35 (require 'tempo) ;; XEmacs change
  36 (eval-when-compile (require 'cl))
  37
  38 ;; (eval-when-compile
  39 ;;   (setq byte-compile-warnings '(free-vars unresolved callargs redefine)))
  40
  41 \f
  42 ;;;; Variables
  43
  44 (defvar sgml-split-level nil
  45   "Used by sgml-split-element")
  46
  47 \f
  48 ;;;; SGML mode: structure editing
  49
  50 (defun sgml-last-element ()
  51   "Return the element where last command left point.
  52 This either uses the save value in `sgml-last-element' or parses the buffer
  53 to find current open element."
  54   (setq sgml-markup-type nil)
  55   (if (and (not sgml-xml-p)
  56            (memq last-command sgml-users-of-last-element)
  57            sgml-last-element)           ; Don't return nil
  58       sgml-last-element
  59     (setq sgml-last-element (sgml-find-context-of (point))))  )
  60
  61 (defun sgml-set-last-element (&optional el)
  62   (if el (setq sgml-last-element el))
  63   (sgml-show-context sgml-last-element))
  64
  65 (defun sgml-beginning-of-element ()
  66   "Move to after the start-tag of the current element.
  67 If the start-tag is implied, move to the start of the element."
  68   (interactive)
  69   (goto-char (sgml-element-stag-end (sgml-last-element)))
  70   (sgml-set-last-element (if (sgml-element-empty sgml-last-element)
  71                              (sgml-element-parent sgml-last-element))))
  72
  73 (defun sgml-end-of-element ()
  74   "Move to before the end-tag of the current element."
  75   (interactive)
  76   (goto-char (sgml-element-etag-start (sgml-last-element)))
  77   (sgml-set-last-element (if (sgml-element-empty sgml-last-element)
  78                              (sgml-element-parent sgml-last-element))))
  79
  80 (defun sgml-backward-up-element ()
  81   "Move backward out of this element level.
  82 That is move to before the start-tag or where a start-tag is implied."
  83   (interactive)
  84   (goto-char (sgml-element-start (sgml-last-element)))
  85   (sgml-set-last-element (sgml-element-parent sgml-last-element)))
  86
  87 (defun sgml-up-element ()
  88   "Move forward out of this element level.
  89 That is move to after the end-tag or where an end-tag is implied."
  90   (interactive)
  91   (goto-char (sgml-element-end (sgml-last-element)))
  92   (sgml-set-last-element (sgml-element-parent sgml-last-element)))
  93
  94 (defun sgml-forward-element ()
  95   "Move forward over next element."
  96   (interactive)
  97   (let ((next
  98          (sgml-find-element-after (point) (sgml-last-element))))
  99     (goto-char (sgml-element-end next))
 100     (sgml-set-last-element (sgml-element-parent next))))
 101
 102 (defun sgml-backward-element ()
 103   "Move backward over previous element at this level.
 104 With implied tags this is ambiguous."
 105   (interactive)
 106   (let ((prev                           ; previous element
 107          (sgml-find-previous-element (point) (sgml-last-element))))
 108     (goto-char (sgml-element-start prev))
 109     (sgml-set-last-element (sgml-element-parent prev))))
 110
 111 (defun sgml-down-element ()
 112   "Move forward and down one level in the element structure."
 113   (interactive)
 114   (let ((to
 115          (sgml-find-element-after (point) (sgml-last-element))))
 116     (when (sgml-strict-epos-p (sgml-element-stag-epos to))
 117       (error "Sub-element in other entity"))
 118     (goto-char (sgml-element-stag-end to))
 119     (sgml-set-last-element (if (sgml-element-empty to)
 120                                (sgml-element-parent to)
 121                              to))))
 122
 123 (defun sgml-kill-element ()
 124   "Kill the element following the cursor."
 125   (interactive "*")
 126   (sgml-parse-to-here)
 127   (when sgml-markup-type
 128     (error "Point is inside markup"))
 129   (kill-region (point)
 130                (sgml-element-end (sgml-find-element-after (point)))))
 131
 132 (defun sgml-transpose-element ()
 133   "Interchange element before point with element after point, leave point after."
 134   (interactive "*")
 135   (let ((pre (sgml-find-previous-element (point)))
 136         (next (sgml-find-element-after (point)))
 137         s1 s2 m2)
 138     (goto-char (sgml-element-start next))
 139     (setq m2 (point-marker))
 140     (setq s2 (buffer-substring (point)
 141                                (sgml-element-end next)))
 142     (delete-region (point) (sgml-element-end next))
 143     (goto-char (sgml-element-start pre))
 144     (setq s1 (buffer-substring (point) (sgml-element-end pre)))
 145     (delete-region (point) (sgml-element-end pre))
 146     (insert-before-markers s2)
 147     (goto-char m2)
 148     (insert s1)
 149     (sgml-message "")))
 150
 151 (defun sgml-mark-element ()
 152   "Set mark after next element."
 153   (interactive)
 154   (push-mark (sgml-element-end (sgml-find-element-after (point))) nil t))
 155
 156 (defun sgml-mark-current-element ()
 157   "Set mark at end of current element, and leave point before current element."
 158   (interactive)
 159   (let ((el (sgml-find-element-of (point))))
 160     (goto-char (sgml-element-start el))
 161     (push-mark (sgml-element-end el) nil t)))
 162
 163
 164 (defun sgml-change-element-name (gi)
 165   "Replace the name of the current element with a new name.
 166 Eventual attributes of the current element will be translated if
 167 possible."
 168   (interactive
 169    (list (let ((el (sgml-find-element-of (point))))
 170            (goto-char (sgml-element-start el))
 171            (sgml-read-element-name
 172             (format "Change %s to: " (sgml-element-name el))))))
 173   (when (or (null gi) (equal gi ""))
 174     (error "Illegal name"))
 175   (let* ((element (sgml-find-element-of (point)))
 176          (attspec (sgml-element-attribute-specification-list element))
 177          (oldattlist (sgml-element-attlist element))
 178          (tagc (if (and sgml-xml-p (sgml-element-empty element))
 179                 (sgml-delim "XML-TAGCE")
 180               (sgml-delim "TAGC")))
 181          (tagc-len (length tagc)))
 182     (goto-char (sgml-element-end element))
 183     (unless  (sgml-element-empty element)
 184       (delete-char (- (sgml-element-etag-len element))))
 185     ;; XEmacs change: use tempo
 186     (tempo-process-and-insert-string (sgml-end-tag-of gi))
 187     (goto-char (sgml-element-start element))
 188     (delete-char (sgml-element-stag-len element))
 189     ;; XEmacs change: use tempo
 190     (tempo-process-and-insert-string (concat (sgml-delim "STAGO")
 191                                              (sgml-general-insert-case gi)
 192                                              tagc))
 193     (let* ((newel (sgml-find-context-of (point)))
 194            (newattlist (sgml-element-attlist newel))
 195            (newasl (sgml-translate-attribute-specification-list
 196                     attspec oldattlist newattlist)))
 197       (backward-char tagc-len)
 198       (sgml-insert-attributes newasl newattlist)
 199       (forward-char tagc-len))))
 200
 201
 202 (defun sgml-translate-attribute-specification-list (values from to)
 203   "Translate attribute specification from one element type to another.
 204 Input attribute values in VALUES using attlist FROM is translated into
 205 a list using attlist TO."
 206   (let ((new-values nil)
 207         (sgml-show-warnings t)
 208         tem)
 209     (loop for attspec in values
 210           as from-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) from)
 211           as to-decl   = (sgml-lookup-attdecl (sgml-attspec-name attspec) to)
 212           do
 213           (cond
 214            ;; Special case ID attribute
 215            ((and (eq 'ID (sgml-attdecl-declared-value from-decl))
 216                  (setq tem (sgml-attribute-with-declared-value to 'ID)))
 217             (push
 218              (sgml-make-attspec (sgml-attdecl-name tem)
 219                                 (sgml-attspec-attval attspec))
 220              new-values))
 221            ;; Use attribute with same name if compatible type
 222            ((equal (sgml-attdecl-declared-value from-decl)
 223                    (sgml-attdecl-declared-value to-decl))
 224             (push attspec new-values))
 225            (to-decl
 226             (sgml-log-warning
 227              "Attribute %s has new declared-value"
 228              (sgml-attspec-name attspec))
 229             (push attspec new-values))
 230            (t
 231             (sgml-log-warning "Can't translate attribute %s = %s"
 232                               (sgml-attspec-name attspec)
 233                               (sgml-attspec-attval attspec)))))
 234     new-values))
 235
 236 (defun sgml-untag-element ()
 237   "Remove tags from current element."
 238   (interactive "*")
 239   (let ((el (sgml-find-element-of (point))))
 240     (when (or (sgml-strict-epos-p (sgml-element-stag-epos el))
 241               (sgml-strict-epos-p (sgml-element-etag-epos el)))
 242       (error "Current element has some tag inside an entity reference"))
 243     (goto-char (sgml-element-etag-start el))
 244     (delete-char (sgml-element-etag-len el))
 245     (goto-char (sgml-element-start el))
 246     (delete-char (sgml-element-stag-len el))))
 247
 248 (defun sgml-kill-markup ()
 249   "Kill next tag, markup declaration or process instruction."
 250   (interactive "*")
 251   (let ((start (point)))
 252     (sgml-with-parser-syntax
 253      (sgml-parse-s)
 254      (setq sgml-markup-start (point))
 255      (cond ((sgml-parse-markup-declaration 'ignore))
 256            ((sgml-parse-processing-instruction))
 257            ((sgml-skip-tag)))
 258      (kill-region start (point)))))
 259
 260 \f
 261 ;;;; SGML mode: folding
 262
 263 (defun sgml-fold-region (beg end &optional unhide)
 264   "Hide (or if prefixarg unhide) region.
 265 If called from a program first two arguments are start and end of
 266 region. And optional third argument true unhides."
 267   (interactive "r\nP")
 268   (setq selective-display t)
 269   (let ((mp (buffer-modified-p))
 270         (inhibit-read-only t)
 271         (before-change-functions nil)
 272         (after-change-functions nil))
 273     (unwind-protect
 274         (subst-char-in-region beg end
 275                               (if unhide ?\r ?\n)
 276                               (if unhide ?\n ?\r)
 277                               'noundo)
 278       (when sgml-buggy-subst-char-in-region
 279         (set-buffer-modified-p mp)))))
 280
 281 (defun sgml-fold-element ()
 282   "Fold the lines comprising the current element, leaving the first line visible.
 283 This uses the selective display feature."
 284   (interactive)
 285   (sgml-parse-to-here)
 286   (cond ((and (eq sgml-current-tree sgml-top-tree) ; outside document element
 287               sgml-markup-type)
 288          (sgml-fold-region sgml-markup-start
 289                            (save-excursion
 290                              (sgml-parse-to (point))
 291                              (point))))
 292         ((and (eq sgml-current-tree sgml-top-tree) ; outside document element
 293               (looking-at " *<!"))
 294          (sgml-fold-region (point)
 295                            (save-excursion
 296                              (skip-chars-forward " \t")
 297                              (sgml-parse-to (1+ (point)))
 298                              (point))))
 299
 300         (t
 301          (let ((el (sgml-find-element-of (point))))
 302            (when (eq el sgml-top-tree)
 303              (error "No element here"))
 304            (save-excursion
 305              (goto-char (sgml-element-end el))
 306              (when (zerop (sgml-element-etag-len el))
 307                (skip-chars-backward " \t\n"))
 308              (sgml-fold-region (sgml-element-start el)
 309                                (point)))))))
 310
 311 (defun sgml-fold-subelement ()
 312   "Fold all elements current elements content, leaving the first lines visible.
 313 This uses the selective display feature."
 314   (interactive)
 315   (let* ((el (sgml-find-element-of (point)))
 316          (c (sgml-element-content el)))
 317     (while c
 318       (sgml-fold-region (sgml-element-start c)
 319                         (sgml-element-end c))
 320       (setq c (sgml-element-next c)))))
 321
 322 (defun sgml-unfold-line ()
 323   "Show hidden lines in current line."
 324   (interactive)
 325   (let ((op (point)))
 326     (beginning-of-line)
 327     (push-mark)
 328     (end-of-line)
 329     (exchange-point-and-mark)
 330     (sgml-fold-region (point) (mark) 'unhide)
 331     (goto-char op)))
 332
 333 (defun sgml-unfold-element ()
 334   "Show all hidden lines in current element."
 335   (interactive)
 336   (let* ((element (sgml-find-element-of (point))))
 337     (sgml-fold-region (sgml-element-start element)
 338                       (sgml-element-end element)
 339                       'unfold)))
 340
 341 (defun sgml-expand-element ()
 342   "As sgml-fold-subelement, but unfold first."
 343   (interactive)
 344   (sgml-unfold-element)
 345   (sgml-fold-subelement))
 346
 347 (defun sgml-unfold-all ()
 348   "Show all hidden lines in buffer."
 349   (interactive)
 350   (sgml-fold-region (point-min)
 351                     (point-max)
 352                     'unfold))
 353 \f
 354 ;;;; SGML mode: indentation and movement
 355
 356
 357 (defun sgml-indent-according-to-level (element)
 358   (* sgml-indent-step
 359      (sgml-element-level element)))
 360
 361 (defun sgml-indent-according-to-stag (element)
 362   (save-excursion
 363     (goto-char (sgml-element-start element))
 364     (+ (current-column) sgml-indent-step)))
 365
 366 (defun sgml-indent-according-to-stag-end (element)
 367   (save-excursion
 368     (goto-char (sgml-element-start element))
 369     (+
 370      (current-column)
 371      (length (sgml-element-gi element))
 372      2)))
 373
 374
 375 ;;(setq sgml-content-indent-function 'sgml-indent-according-to-stag)
 376
 377 (defun sgml-indent-line (&optional col element)
 378   "Indent line, calling parser to determine level unless COL or ELEMENT
 379 is given.  If COL is given it should be the column to indent to.  If
 380 ELEMENT is given it should be a parse tree node, from which the level
 381 is determined.
 382 Deprecated: ELEMENT"
 383   (sgml-debug "-> sgml-indent-line %s %s"
 384               col (if element (sgml-element-gi element)))
 385   (when sgml-indent-step
 386     (let ((here (point-marker))
 387           ;; Where the indentation goes, i.e., will this be data
 388           element-insert
 389           ;; Where we compute indentation, where the thing we indent is.
 390           ;; Can be different from above if end-tag is omitted.
 391           element-level)
 392       (back-to-indentation)
 393       (unless col
 394         ;; Determine element
 395         (setq element-insert
 396               (let ((sgml-throw-on-error 'parse-error))
 397                 (catch sgml-throw-on-error
 398                   ;; This used to be (sgml-find-element-of (point))
 399                   ;; Why? Possibly to handle omitted end-tags
 400                   (sgml-debug "-- sgml-indent-line find context")
 401                   (sgml-find-context-of (point)))))
 402         (setq element-level element-insert)
 403         (when (and (not (eobp)) element-level)
 404           (setq element-level (sgml-find-element-of (point)))
 405           ;; It would be good if sgml-find-element-of would also tell
 406           ;; us if the character is in the start-tag/end-tag or
 407           ;; content
 408           (when (or (= (point) (sgml-element-start element-level))
 409                     (sgml-with-parser-syntax (sgml-is-end-tag)))
 410             (setq element-level (sgml-element-parent element-level)))))
 411       (when (eq element-level sgml-top-tree)    ; not in a element at all
 412         (setq element-level nil)                ; forget element
 413         (goto-char here))                       ; insert normal tab instead
 414       (when element-level
 415         (cond ((and (> (point) (sgml-element-start element-insert))
 416                     (< (point) (sgml-element-stag-end element-insert))
 417                     (not (sgml-element-data-p
 418                           (sgml-element-parent element-insert))))
 419                (setq col
 420                      (funcall sgml-attribute-indent-function element-insert)))
 421               ((and
 422                 ;; Wing change, adapted by James
 423                 (not (member* (sgml-element-gi
 424                                (if (or (sgml-is-start-tag) (sgml-is-end-tag))
 425                                    (sgml-element-parent element-level)
 426                                  element-level))
 427                               sgml-inhibit-indent-tags :test #'equalp))
 428                 (or sgml-indent-data
 429                     (not (sgml-element-data-p element-insert))))
 430                (setq col
 431                      (funcall sgml-content-indent-function element-level)))))
 432       (when (and col (/= col (current-column)))
 433         (beginning-of-line 1)
 434         (delete-horizontal-space)
 435         (indent-to col))
 436       (when (< (point) here)
 437         (goto-char here))
 438       col)))
 439
 440
 441 (defun sgml-next-data-field ()
 442   "Move forward to next point where data is allowed."
 443   (interactive)
 444   (when (eobp)
 445     (error "End of buffer"))
 446   (let ((sgml-throw-on-warning 'next-data)
 447         (avoid-el (sgml-last-element)))
 448     ;; Avoid stopping in current element, unless point is in the start
 449     ;; tag of the element
 450     (when (< (point) (sgml-element-stag-end avoid-el))
 451       (setq avoid-el nil))
 452     (catch sgml-throw-on-warning
 453       (while (progn
 454                (sgml-parse-to (1+ (point)))
 455                (setq sgml-last-element
 456                      (if (not (eq ?< (following-char)))
 457                          (sgml-find-element-of (point))
 458                        sgml-current-tree))
 459                (or (eq sgml-last-element avoid-el)
 460                    (not (sgml-element-data-p sgml-last-element)))))
 461       (sgml-set-last-element))))
 462
 463
 464 (defun sgml-next-trouble-spot ()
 465   "Move forward to next point where something is amiss with the structure."
 466   (interactive)
 467   (push-mark)
 468   (sgml-note-change-at (point))         ; Prune the parse tree
 469   (sgml-parse-to (point))
 470   (let ((sgml-throw-on-warning 'trouble))
 471     (or (catch sgml-throw-on-warning
 472           (sgml-parse-until-end-of nil t))
 473         (message "Ok"))))
 474
 475
 476 \f
 477 ;;;; SGML mode: information display
 478
 479 (defun sgml-list-valid-tags ()
 480   "Display a list of the contextually valid tags."
 481   (interactive)
 482   (sgml-parse-to-here)
 483   (let ((model (sgml-element-model sgml-current-tree))
 484         (smap-name (sgml-lookup-shortref-name
 485                     (sgml-dtd-shortmaps sgml-dtd-info)
 486                     sgml-current-shortmap)))
 487     (with-output-to-temp-buffer "*Tags*"
 488       (princ (format "Current element: %s  %s\n"
 489                      (sgml-element-name sgml-current-tree)
 490                      (if (sgml-eltype-defined
 491                           (sgml-element-eltype sgml-current-tree))
 492                          ""
 493                        "[UNDEFINED]")))
 494       (princ (format "Element content: %s  %s\n"
 495                      (cond ((or (sgml-current-mixed-p) (eq model sgml-any))
 496                             "mixed")
 497                            ((sgml-model-group-p model)
 498                             "element")
 499                            (t
 500                             model))
 501                      (if (eq model sgml-any)
 502                          "[ANY]" "")))
 503
 504       (when smap-name
 505         (princ (format "Current short reference map: %s\n" smap-name)))
 506
 507       (cond ((sgml-final-p sgml-current-state)
 508              (princ "Valid end-tags : ")
 509              (loop for e in (sgml-current-list-of-endable-eltypes)
 510                    do (princ (sgml-end-tag-of e)) (princ " "))
 511              (terpri))
 512             (t
 513              (princ "Current element can not end here\n")))
 514 ;;;      (let ((s (sgml-tree-shortmap sgml-current-tree)))
 515 ;;;     (when s
 516 ;;;       (princ (format "Current shortref map: %s\n" s))))
 517       (princ "Valid start-tags\n")
 518       (sgml-print-valid-tags "In current element:"
 519                              sgml-current-tree sgml-current-state))))
 520
 521 (defun sgml-print-valid-tags (prompt tree state &optional exclude omitted-stag)
 522   (if (not (sgml-model-group-p state))
 523       (princ (format "%s (in %s)\n" prompt state))
 524     (let* ((req (sgml-required-tokens state))
 525            (elems (nconc req
 526                          (delq sgml-pcdata-token
 527                                (sgml-optional-tokens state))))
 528            (in (sgml-tree-includes tree))
 529            (ex (append exclude (sgml-tree-excludes tree))))
 530       ;; Modify for exceptions
 531       (while in
 532         (unless (memq (car in) elems)
 533           (setq elems (nconc elems (list (car in)))))
 534         (setq in (cdr in)))
 535       (while ex
 536         (setq elems (delq (car ex) elems))
 537         (setq ex (cdr ex)))
 538       ;;
 539       (setq elems (sort elems (function string-lessp)))
 540       (sgml-print-list-of-tags prompt elems)
 541       ;; Check for omissable start-tags
 542       (when (and req (null (cdr req)))
 543         ;; *** Assumes tokens are eltypes
 544         (let ((el (sgml-fake-open-element tree (car req))))
 545           (when (sgml-element-stag-optional el)
 546             (sgml-print-valid-tags
 547              (format "If omitting %s:" (sgml-start-tag-of el))
 548              el
 549              (sgml-element-model el)
 550              (append exclude elems)
 551              'omitted-stag))))
 552       ;; Check for omissable end-tag
 553       (when (and (not omitted-stag)
 554                  (sgml-final-p state)
 555                  (sgml-element-etag-optional tree))
 556         (sgml-print-valid-tags
 557          (format "If omitting %s:" (sgml-end-tag-of tree))
 558          (sgml-element-parent tree)
 559          (sgml-element-pstate tree)
 560          (append exclude elems))))))
 561
 562 (defun sgml-print-list-of-tags (prompt list)
 563   (when list
 564     (princ prompt)
 565     (let ((col (length prompt))
 566           (w   (1- (frame-width))))
 567       (loop for e in list
 568             as str = (sgml-start-tag-of e)
 569             do
 570             (setq col (+ col (length str) 2))
 571             (cond ((>= col w)
 572                    (setq col (+ (length str) 2))
 573                    (terpri)))
 574             (princ "  ")
 575             (princ str))
 576       (terpri))))
 577
 578
 579 (defun sgml-show-context-standard (el &optional markup-type)
 580   (let* ((model (sgml-element-model el)))
 581     (format "%s %s"
 582             (cond (markup-type (format "%s" markup-type))
 583                   ((sgml-element-mixed el)
 584                    "#PCDATA")
 585                   ((not (sgml-model-group-p model))
 586                    model)
 587                   (t ""))
 588             (if (eq el sgml-top-tree)
 589                       "in empty context"
 590                       (sgml-element-context-string el)))))
 591
 592
 593 (defun sgml-show-context-backslash (el &optional markup-type)
 594   (let ((gis nil))
 595     (while (not (sgml-off-top-p el))
 596       (push (sgml-element-gi el) gis)
 597       (setq el (sgml-element-parent el)))
 598     (mapconcat #'sgml-general-insert-case gis "\\")))
 599
 600
 601 (defun sgml-show-context (&optional element)
 602   "Display where the cursor is in the element hierarchy."
 603   (interactive)
 604   (message "%s" (funcall sgml-show-context-function
 605                          (or element (sgml-last-element))
 606                          (if element nil sgml-markup-type))))
 607
 608
 609 (defun sgml-what-element ()
 610   "Display what element is under the cursor."
 611   (interactive)
 612   (let* ((pos (point))
 613          (nobol (eq (point) sgml-rs-ignore-pos))
 614          (sref (and sgml-current-shortmap
 615                     (sgml-deref-shortmap sgml-current-shortmap nobol)))
 616          (el nil))
 617     (goto-char pos)
 618     (setq el (sgml-find-element-of pos))
 619     (assert (not (null el)))
 620     (message "%s %s"
 621              (cond ((eq el sgml-top-tree)
 622                     "outside document element")
 623                    ((< (point) (sgml-element-stag-end el))
 624                     "start-tag")
 625                    ((>= (point) (sgml-element-etag-start el))
 626                     "end-tag")
 627                    (sref
 628                     "shortref")
 629                    (t
 630                     "content"))
 631              (sgml-element-context-string el))))
 632 \f
 633 ;;;; SGML mode: keyboard inserting
 634
 635 (defun sgml-coerce-element-type (obj)
 636   (when (stringp obj)
 637     (setq obj (sgml-lookup-eltype (sgml-general-case obj))))
 638   (when nil                             ;FIXME: need predicate
 639     (setq obj (sgml-tree-eltype obj)))
 640   obj)
 641
 642 (defun sgml-break-brefore-stag-p (element)
 643   (sgml-eltype-appdata (sgml-coerce-element-type element)
 644                        'break-brefore-stag))
 645
 646 (defun sgml-break-after-stag-p (element)
 647   (sgml-eltype-appdata (sgml-coerce-element-type element)
 648                        'break-after-stag))
 649
 650 (defun sgml-insert-break ()
 651   (skip-chars-backward " \t")
 652   (cond ((bolp)
 653          (if (looking-at "^\\s-*$")
 654              (fixup-whitespace)))
 655         (t
 656          ;; FIXME: fixup-whitespace ??
 657          (insert "\n"))))
 658
 659
 660 (defun sgml-insert-tag (tag &optional silent no-nl-after)
 661   "Insert a tag, reading tag name in minibuffer with completion.
 662 If the variable `sgml-balanced-tag-edit' is t, also inserts the
 663 corresponding end tag.  If `sgml-leave-point-after-insert' is t, the point
 664 is left after the inserted tag(s), unless the element has some required
 665 content.  If `sgml-leave-point-after-insert' is nil, the point is left
 666 after the first tag inserted."
 667   (interactive
 668    (list
 669     (let ((completion-ignore-case sgml-namecase-general))
 670       (completing-read "Tag: " (sgml-completion-table) nil t "<" ))))
 671   (sgml-find-context-of (point))
 672   (assert (null sgml-markup-type))
 673   ;; Fix white-space before tag
 674   (unless (sgml-element-data-p (sgml-parse-to-here))
 675     (skip-chars-backward " \t")
 676     (cond ((bolp)
 677            (if (looking-at "^\\s-*$")
 678                (fixup-whitespace)))
 679           (t
 680            (insert "\n"))))
 681   ;; XEmacs change: use tempo
 682   (tempo-process-and-insert-string tag)
 683   (sgml-indent-line)
 684   (unless no-nl-after
 685     (save-excursion
 686       (unless (sgml-element-data-p (sgml-parse-to-here))
 687         (unless (eolp)
 688           (save-excursion (insert "\n"))))))
 689   (or silent (sgml-show-context)))
 690
 691 (defvar sgml-new-attribute-list-function
 692   (function sgml-default-asl))
 693
 694 (defun sgml-insert-element (name &optional after silent)
 695   "Reads element name from minibuffer and inserts start and end tags.
 696 If sgml-leave-point-after-insert is t, the point
 697 is left after the inserted tag(s), unless the element has some required
 698 content.  If sgml-leave-point-after-insert is nil the point is left
 699 after the first tag inserted."
 700   (interactive (list (sgml-read-element-name "Element: ")
 701                      sgml-leave-point-after-insert))
 702   (let (newpos                          ; position to leave cursor at
 703         element                         ; inserted element
 704         (sgml-show-warnings nil))
 705     (when (and name (not (equal name "")))
 706       (when (sgml-break-brefore-stag-p name)
 707         (sgml-insert-break))
 708       (sgml-insert-tag (sgml-start-tag-of name) 'silent)
 709       (if (and sgml-xml-p (sgml-check-empty name))
 710           (forward-char -2)
 711         (forward-char -1))
 712       (setq element (sgml-find-element-of (point)))
 713       (sgml-insert-attributes (funcall sgml-new-attribute-list-function
 714                                        element)
 715                               (sgml-element-attlist element))
 716       ;; Get element with new attributes
 717       (setq element (sgml-find-context-of (point)))
 718       (if (and sgml-xml-p (sgml-check-empty name))
 719           (forward-char 2)
 720         (forward-char 1))
 721       (when (sgml-break-after-stag-p name)
 722         (sgml-insert-break))
 723       (when (not (sgml-element-empty element))
 724         (when (and sgml-auto-insert-required-elements
 725                    (sgml-model-group-p sgml-current-state))
 726           (let (tem)
 727             (while (and (setq tem (sgml-required-tokens sgml-current-state))
 728                         (null (cdr tem)))
 729               (setq tem (sgml-insert-element (car tem) t t))
 730               (setq newpos (or newpos tem))
 731               (sgml-parse-to-here))
 732             (when tem                   ; more than one req elem
 733               (insert "\n")
 734               (when sgml-insert-missing-element-comment
 735                 (insert (format "<!-- one of %s -->" tem))
 736                 (sgml-indent-line)))))
 737         (setq newpos (or newpos (point)))
 738         (when sgml-insert-end-tag-on-new-line
 739           (insert "\n"))
 740         (sgml-insert-tag (sgml-end-tag-of name) 'silent)
 741         (unless after
 742           (goto-char newpos))
 743         (unless silent (sgml-show-context)))
 744       newpos)))
 745
 746 (defun sgml-default-asl (element)
 747   (loop for attdecl in (sgml-element-attlist element)
 748         when (sgml-default-value-type-p (sgml-attdecl-default-value attdecl)
 749                                         'REQUIRED)
 750         collect
 751         (sgml-make-attspec
 752          (sgml-attdecl-name attdecl)
 753          (sgml-read-attribute-value attdecl (sgml-element-name element) nil))))
 754
 755 (defun sgml-tag-region (element start end)
 756   "Reads element name from minibuffer and inserts start and end tags."
 757   (interactive
 758    (list
 759     (save-excursion (goto-char (region-beginning))
 760                     (sgml-read-element-name "Tag region with element: "))
 761     (region-beginning)
 762     (region-end)))
 763   (save-excursion
 764     (when (and element (not (equal element "")))
 765       (goto-char end)
 766       ;; XEmacs change: use tempo
 767       (tempo-process-and-insert-string (sgml-end-tag-of element))
 768       (goto-char start)
 769       (sgml-insert-tag (sgml-start-tag-of element)))))
 770
 771 (defun sgml-insert-attributes (avl attlist)
 772   "Insert the attributes with values AVL and declarations ATTLIST.
 773 AVL should be a assoc list mapping symbols to strings."
 774   (let (name val dcl def)
 775     (loop for attspec in attlist do
 776           (setq name (sgml-attspec-name attspec)
 777                 val (cdr-safe (sgml-lookup-attspec name avl))
 778                 dcl (sgml-attdecl-declared-value attspec)
 779                 def (sgml-attdecl-default-value attspec))
 780           (setq name (sgml-general-insert-case name))
 781           (unless val                   ; no value given
 782             ;; Supply the default value if a value is needed
 783             (cond ((sgml-default-value-type-p 'REQUIRED def)
 784                    (setq val ""))
 785                   ((and (or (not (or sgml-xml-p sgml-omittag sgml-shorttag))
 786                             sgml-insert-defaulted-attributes)
 787                         (consp def))
 788                    (setq val (sgml-default-value-attval def)))))
 789           (when val
 790             (cond ((eq dcl 'CDATA))
 791                   ((eq dcl 'ENTITY) (setq val (sgml-entity-insert-case val)))
 792                   (t (setq val (sgml-general-insert-case val)))))
 793           (cond
 794            ((null val))                 ; Ignore
 795            ;; Ignore attributes with default value
 796            ((and (consp def)
 797                  (eq sgml-minimize-attributes 'max)
 798                  (or sgml-omittag sgml-shorttag)
 799                  (equal val (sgml-default-value-attval def))))
 800            ;; No attribute name for token groups
 801            ((and sgml-minimize-attributes sgml-shorttag
 802                  (member (sgml-general-case val)
 803                          (sgml-declared-value-token-group dcl)))
 804             ;; XEmacs change: use tempo
 805             (tempo-process-and-insert-string (concat " " val)))
 806            (t
 807             ;; XEmacs change: use tempo
 808             (tempo-process-and-insert-string (concat " " name "="))
 809             (insert (sgml-quote-attribute-value val)))))
 810     (when auto-fill-function
 811       (funcall auto-fill-function))))
 812
 813
 814 (defun sgml-quote-attribute-value (value)
 815   "Add quotes to the string VALUE unless minimization is on."
 816   (let ((quote ""))
 817         (cond ((and (not sgml-always-quote-attributes)
 818                     sgml-shorttag
 819                     (string-match "\\`[-.A-Za-z0-9]+\\'" value))
 820                ) ; no need to quote
 821               ((not (string-match "\"" value)) ; can use "" quotes
 822                (setq quote "\""))
 823               (t                        ; use '' quotes
 824                (setq quote "'")))
 825         (concat quote value quote)))
 826
 827 (defun sgml-completion-table (&optional avoid-tags-in-cdata)
 828   (sgml-parse-to-here)
 829   (when sgml-markup-type
 830     (error "No tags allowed"))
 831   (cond ((or (sgml-model-group-p sgml-current-state)
 832              (eq sgml-current-state sgml-any))
 833          (append
 834           (mapcar (function (lambda (x) (cons (sgml-end-tag-of x) x)))
 835                   (sgml-current-list-of-endable-eltypes))
 836           (mapcar (function (lambda (x) (cons (sgml-start-tag-of x) x)))
 837                   (sgml-current-list-of-valid-eltypes))))
 838         (t
 839          (sgml-message "%s" sgml-current-state)
 840          nil)))
 841
 842 (defun sgml-element-endable-p ()
 843   (sgml-parse-to-here)
 844   (and (not (eq sgml-current-tree sgml-top-tree))
 845        (sgml-final-p sgml-current-state)))
 846
 847 (defun sgml-insert-end-tag ()
 848   "Insert end-tag for the current open element."
 849   (interactive "*")
 850   (sgml-parse-to-here)
 851   (cond
 852    ((eq sgml-current-tree sgml-top-tree)
 853     (sgml-error "No open element"))
 854    ((not (sgml-final-p sgml-current-state))
 855     (sgml-error "Can`t end element here"))
 856    (t
 857     (when (and sgml-indent-step
 858                (not (sgml-element-data-p sgml-current-tree)))
 859       (delete-horizontal-space)
 860       (unless (bolp)
 861         (insert "\n")))
 862     (when (prog1 (bolp)
 863             ;; XEmacs change: use tempo
 864             (tempo-process-and-insert-string
 865               (if (eq t (sgml-element-net-enabled sgml-current-tree))
 866                   "/"
 867                 (sgml-end-tag-of sgml-current-tree))))
 868       (sgml-indent-line)))))
 869
 870 (defun sgml-insert-start-tag (name asl attlist &optional net)
 871   ;; Insert a start-tag with attributes
 872   ;; if NET is true end with NESTC unless XML then end with NESTC NET
 873   ;; (aka XML-TAGCE).
 874   ;; XEmacs change: use tempo
 875   (tempo-process-and-insert-string (concat (sgml-delim "STAGO")
 876                                            (sgml-general-insert-case name)))
 877   (sgml-insert-attributes asl attlist)
 878   ;; In XML, force net if element is always empty
 879   (when (and sgml-xml-p (sgml-check-empty name))
 880     (setq net t))
 881   ;; XEmacs change: use tempo
 882   (tempo-process-and-insert-string
 883    (if net (if sgml-xml-p
 884                (sgml-delim "XML-TAGCE")
 885              (sgml-delim "NESTC"))
 886      (sgml-delim "TAGC"))))
 887
 888 (defun sgml-change-start-tag (element asl)
 889   (let ((name (sgml-element-gi element))
 890         (attlist (sgml-element-attlist element)))
 891     ;; Concoct an attribute specification list using the names of the
 892     ;; existing attributes and those ot be changed.
 893     (when (and (not attlist) sgml-dtd-less)
 894       (dolist (elt (mapcar 'car asl))
 895         (unless (assoc elt attlist)     ; avoid duplicates
 896           (push (sgml-make-attdecl elt 'CDATA 'REQUIRED) attlist)))
 897       (setq attlist (nreverse attlist)))
 898     (assert (sgml-bpos-p (sgml-element-stag-epos element)))
 899     (goto-char (sgml-element-start element))
 900     (delete-char (sgml-element-stag-len element))
 901     (sgml-insert-start-tag name asl attlist
 902                            (if sgml-xml-p
 903                                (sgml-element-empty element)
 904                              (eq t (sgml-element-net-enabled element))))))
 905
 906 (defun sgml-read-attribute-value (attdecl element curvalue)
 907   "Return the attribute value read from user.
 908 ATTDECL is the attribute declaration for the attribute to read.
 909 CURVALUE is nil or a string that will be used as default value."
 910   (assert attdecl)
 911   (let* ((name (sgml-attdecl-name attdecl))
 912          (dv (sgml-attdecl-declared-value attdecl))
 913          (tokens (sgml-declared-value-token-group dv))
 914          (notations (sgml-declared-value-notation dv))
 915          ; JDF's addition
 916          (ids (and (memq dv '(IDREF IDREFS)) (sgml-id-list)))
 917          (type (cond (tokens "token")
 918                      (notations "NOTATION")
 919                      (t (symbol-name dv))))
 920          (prompt
 921           (format "Value for %s in %s (%s%s): "
 922                   name element type
 923                   (if (and curvalue (not (eq dv 'IDREFS)))
 924                       (format " Default: %s" curvalue)
 925                     "")))
 926          value)
 927     (setq value
 928           (cond ((or tokens notations)
 929                  (let ((completion-ignore-case sgml-namecase-general))
 930                    (completing-read prompt
 931                                     (mapcar 'list (or tokens notations))
 932                                     nil t)))
 933                 (ids
 934                  (let ((completion-ignore-case sgml-namecase-general)
 935                        (minibuffer-local-completion-map sgml-edit-idrefs-map))
 936                    (completing-read prompt
 937                                     'sgml-idrefs-completer
 938                                     nil nil
 939                                     (and curvalue
 940                                          (cons curvalue (length curvalue))))))
 941                 (t
 942                  (read-string prompt))))
 943     (if (and curvalue (equal value ""))
 944         curvalue value)))
 945
 946 (defun sgml-idrefs-completer (fullstring pred action)
 947   (let* ((start (string-match "\\(\\(:?-\\|\\w\\)*\\)$" fullstring))
 948          (string (match-string 0 fullstring))
 949          (prefix (substring fullstring 0 start)))
 950     ;(message "prefix: %s string: %s" prefix string)
 951     (cond ((null action)
 952            (let ((completion (try-completion string (sgml-id-alist) pred)))
 953              (if (eq completion t)
 954                  t
 955                (concat prefix completion))))
 956           ((eq action t)
 957            (all-completions string (sgml-id-alist) pred))
 958           ((eq action 'lambda)
 959            (member string (sgml-id-alist))))))
 960
 961 (defun sgml-non-fixed-attributes (attlist)
 962   (loop for attdecl in attlist
 963         unless (sgml-default-value-type-p 'FIXED
 964                                           (sgml-attdecl-default-value attdecl))
 965         collect attdecl))
 966
 967 (defun sgml-insert-attribute (name value)
 968   "Read attribute name and value from minibuffer and insert attribute spec."
 969   (interactive
 970    (let* ((el (sgml-find-attribute-element))
 971           (name
 972            (sgml-general-case
 973             (let ((completion-ignore-case sgml-namecase-general))
 974               (completing-read
 975                "Attribute name: "
 976                (mapcar
 977                 (function (lambda (a) (list (sgml-attdecl-name a))))
 978                 (if sgml-dtd-less
 979                     (sgml-tree-asl el)
 980                   (sgml-non-fixed-attributes (sgml-element-attlist el))))
 981                nil (not sgml-dtd-less))))))
 982      (list name
 983            (sgml-read-attribute-value
 984             (if sgml-dtd-less
 985                 (list name)
 986               (sgml-lookup-attdecl name (sgml-element-attlist el)))
 987             (sgml-element-name el)
 988             (sgml-element-attval el name)))))
 989   ;; Body
 990   (assert (stringp name))
 991   (assert (or (null value) (stringp value)))
 992   (let* ((el (sgml-find-attribute-element))
 993          (asl (cons (sgml-make-attspec name value)
 994                     (sgml-element-attribute-specification-list el)))
 995          (in-tag (< (point) (sgml-element-stag-end el))))
 996     (sgml-change-start-tag el asl)
 997     (when in-tag (forward-char -1))))
 998
 999 (defun sgml-split-element ()
1000   "Split the current element at point.
1001 If repeated, the containing element will be split before the beginning
1002 of then current element."
1003   (interactive "*")
1004   (setq sgml-split-level
1005         (if (eq this-command last-command)
1006             (1+ sgml-split-level)
1007           0))
1008   (let ((u (sgml-find-context-of (point)))
1009         (start (point-marker)))
1010     (loop repeat sgml-split-level do
1011           (goto-char (sgml-element-start u))
1012           (setq u (sgml-element-parent u)))
1013     ;; Verify that a new element can be started
1014     (unless (and (sgml-element-pstate u) ; in case of top element
1015                  (sgml-get-move (sgml-element-pstate u)
1016                                 (sgml-element-name u)))
1017
1018       (sgml-error "The %s element can't be split"
1019                   (sgml-element-name u)))
1020     ;; Do the split
1021     (sgml-insert-end-tag)
1022     (insert ?\n)
1023     (sgml-insert-tag (sgml-start-tag-of u) 'silent)
1024     (skip-chars-forward " \t\n")
1025     (sgml-indent-line)
1026     (when (> sgml-split-level 0)
1027       (goto-char start))
1028     (or (eq sgml-top-tree
1029             (setq u (sgml-element-parent u)))
1030         (sgml-message
1031          "Repeat the command to split the containing %s element"
1032          (sgml-element-name u)))))
1033 \f
1034 ;;; David Megginson's custom menus for keys
1035
1036 (defun sgml-custom-dtd (doctype)
1037   "Insert a DTD declaration from the sgml-custom-dtd alist."
1038   (interactive
1039    (list (completing-read "Insert DTD: " sgml-custom-dtd nil t)))
1040   (let ((entry (assoc doctype sgml-custom-dtd)))
1041     (sgml-doctype-insert (second entry) (cddr entry))))
1042
1043 (defun sgml-custom-markup (markup)
1044   "Insert markup from the sgml-custom-markup alist."
1045   (interactive
1046    (let ((completion-ignore-case sgml-namecase-general))
1047      (list (completing-read "Insert Markup: " sgml-custom-markup nil t))))
1048   (sgml-insert-markup (cadr (assoc markup sgml-custom-markup))))
1049
1050 \f
1051 ;;;; SGML mode: Menu inserting
1052
1053 (defun sgml-tags-menu (event)
1054   "Pop up a menu with valid tags and insert the chosen tag.
1055 If the variable sgml-balanced-tag-edit is t, also inserts the
1056 corresponding end tag. If sgml-leave-point-after-insert is t, the point
1057 is left after the inserted tag(s), unless the element has some required
1058 content.  If sgml-leave-point-after-insert is nil the point is left
1059 after the first tag inserted."
1060   (interactive "*e")
1061   (let ((end (sgml-mouse-region)))
1062     (sgml-parse-to-here)
1063     (cond
1064      ((eq sgml-markup-type 'start-tag)
1065       (sgml-attrib-menu event))
1066      (t
1067       (let ((what
1068              (sgml-menu-ask event (if (or end sgml-balanced-tag-edit)
1069                                       'element 'tags))))
1070         (cond
1071          ((null what))
1072          (end
1073           (sgml-tag-region what (point) end))
1074          (sgml-balanced-tag-edit
1075           (sgml-insert-element what))
1076          (t
1077           (sgml-insert-tag what))))))))
1078
1079 (defun sgml-element-menu (event)
1080   "Pop up a menu with valid elements and insert choice.
1081 If sgml-leave-point-after-insert is nil the point is left after the first
1082 tag inserted."
1083   (interactive "*e")
1084   (let ((what (sgml-menu-ask event 'element)))
1085     (and what (sgml-insert-element what))))
1086
1087 (defun sgml-add-element-menu (event)
1088   (interactive "*e")
1089   (let ((what (sgml-menu-ask event 'add-element)))
1090     (and what (sgml-add-element-to-element what nil))))
1091
1092 (defun sgml-start-tag-menu (event)
1093   "Pop up a menu with valid start-tags and insert choice."
1094   (interactive "*e")
1095   (let ((what (sgml-menu-ask event 'start-tag)))
1096     (and what (sgml-insert-tag what))))
1097
1098 (defun sgml-end-tag-menu (event)
1099   "Pop up a menu with valid end-tags and insert choice."
1100   (interactive "*e")
1101   (let ((what (sgml-menu-ask event 'end-tag)))
1102     (and what (sgml-insert-tag what))))
1103
1104 (defun sgml-tag-region-menu (event)
1105   "Pop up a menu with valid elements and tag current region with the choice."
1106   (interactive "*e")
1107   (let ((what (sgml-menu-ask event 'element)))
1108     (and what (sgml-tag-region what
1109                                (region-beginning)
1110                                (region-end)))))
1111
1112 (defun sgml-menu-ask (event type)
1113   (sgml-parse-to-here)
1114   (let (tab
1115         (title (capitalize (symbol-name type))))
1116     (cond
1117      ((eq type 'add-element)
1118       (setq tab
1119             (mapcar #'sgml-eltype-name
1120                     (sgml--all-possible-elements
1121                      (sgml-find-context-of (point))))))
1122      (sgml-markup-type)
1123      ((eq type 'element)
1124       (setq tab
1125             (mapcar (function symbol-name)
1126                     (sgml-current-list-of-valid-eltypes))))
1127      (t
1128       (unless (eq type 'start-tag)
1129         (setq tab
1130               (mapcar (function sgml-end-tag-of)
1131                       (sgml-current-list-of-endable-eltypes))))
1132       (unless (eq type 'end-tag)
1133         (setq tab
1134               (nconc tab
1135                      (mapcar (function sgml-start-tag-of)
1136                              (sgml-current-list-of-valid-eltypes)))))))
1137     (if sgml-dtd-less
1138         ;; The best we can do is assemble a list of elements we've
1139         ;; seen so far.
1140         (dolist (n (append (sgml-dtd-eltypes sgml-dtd-info) '())
1141                    ;; Space avoids possible clash with valid element.
1142                    (setq tab (cons "Any " (cons "--" tab))))
1143           (when (and (symbolp n) (not (memq n tab)))
1144             (push (symbol-name n) tab))))
1145     (or tab
1146         (error "No valid %s at this point" type))
1147     (let ((elt (sgml-popup-menu event
1148                                 title
1149                                 (mapcar (function (lambda (x) (cons x x)))
1150                                         tab))))
1151       (if (equal elt "Any ")
1152           (setq elt (sgml-read-element-name "Element: ")))
1153       (or elt (message nil)))))
1154
1155 (defun sgml-entities-menu (event)
1156   (interactive "*e")
1157   (sgml-need-dtd)
1158   (let ((menu
1159          (mapcar (function (lambda (x) (cons x x)))
1160                  (sort (sgml-map-entities (function sgml-entity-name)
1161                                           (sgml-dtd-entities sgml-dtd-info)
1162                                           t)
1163                        (function string-lessp))))
1164         choice)
1165     (unless menu
1166       (error "No entities defined"))
1167     (setq choice (sgml-popup-menu event "Entities" menu))
1168     (when choice
1169       (insert "&" choice ";"))))
1170
1171 (defun sgml-doctype-insert (doctype vars)
1172   "Insert string DOCTYPE (ignored if nil) and set variables in &rest VARS.
1173 VARS should be a list of variables and values.
1174 For backward compatibility a single string instead of a variable is
1175 assigned to sgml-default-dtd-file.
1176 All variables are made buffer local and are also added to the
1177 buffers local variables list."
1178   (when doctype
1179     (unless (bolp)
1180       (insert "\n"))
1181     (unless (eolp)
1182       (insert "\n")
1183       (forward-char -1))
1184     (sgml-insert-markup doctype))
1185   (while vars
1186     (cond ((stringp (car vars))
1187            (sgml-set-local-variable 'sgml-default-dtd-file (car vars))
1188            (setq vars (cdr vars)))
1189           ((car vars)                   ; Avoid nil
1190            (sgml-set-local-variable (car vars) (cadr vars))
1191            (setq vars (cddr vars)))
1192           (t
1193            (setq vars (cddr vars)))))
1194   (setq sgml-top-tree nil))
1195
1196 (defun sgml-attrib-menu (event)
1197   "Pop up a menu of the attributes of the current element
1198 \(or the element with start-tag before point)."
1199   (interactive "e")
1200     (let ((menu (sgml-make-attrib-menu (sgml-find-attribute-element))))
1201       (sgml-popup-multi-menu event "Attributes" menu)))
1202
1203 (defun sgml-make-attrib-menu (el)
1204   (let ((attlist (sgml-non-fixed-attributes (sgml-element-attlist el))))
1205     (if (and (not attlist) sgml-dtd-less)
1206       (let ((name
1207              (sgml-general-case
1208               (let ((completion-ignore-case sgml-namecase-general))
1209                 (completing-read
1210                  "Attribute name: "
1211                  (mapcar
1212                   (lambda (a) (list (sgml-attdecl-name a)))
1213                   (if sgml-dtd-less
1214                       (sgml-tree-asl el)
1215                     (sgml-non-fixed-attributes (sgml-element-attlist el))))
1216                  nil (not sgml-dtd-less))))))
1217         (if name
1218             (setq attlist (list (sgml-make-attdecl name 'CDATA nil))))))
1219     (or attlist
1220         (error "No non-fixed attributes for element"))
1221     (loop for attdecl in attlist
1222           for name = (sgml-attdecl-name attdecl)
1223           for defval = (sgml-attdecl-default-value attdecl)
1224           for tokens = (or (sgml-declared-value-token-group
1225                             (sgml-attdecl-declared-value attdecl))
1226                            (sgml-declared-value-notation
1227                             (sgml-attdecl-declared-value attdecl)))
1228           collect
1229           (cons
1230            (sgml-attdecl-name attdecl)
1231            (nconc
1232             (if tokens
1233                 (loop for val in tokens collect
1234                       (list val
1235                             (list 'sgml-insert-attribute name val)))
1236               (list
1237                (list "Set attribute value"
1238                      (list 'sgml-insert-attribute
1239                            (sgml-attdecl-name attdecl)
1240                            (list 'sgml-read-attribute-value
1241                                  (list 'quote attdecl)
1242                                  (list 'quote (sgml-element-name el))
1243                                  (sgml-element-attval el name))))))
1244             (if (sgml-default-value-type-p 'REQUIRED defval)
1245                 nil
1246               (list "--"
1247                     (list (if (sgml-default-value-type-p nil defval)
1248                               (format "Default: %s"
1249                                       (sgml-default-value-attval defval))
1250                             "#IMPLIED")
1251                           (list 'sgml-insert-attribute name nil)))))))))
1252
1253 \f
1254 ;;;; New Right Button Menu
1255
1256 (defun sgml-right-menu (event)
1257   "Pop up a menu with valid tags and insert the choosen tag.
1258 If the variable sgml-balanced-tag-edit is t, also inserts the
1259 corresponding end tag. If sgml-leave-point-after-insert is t, the point
1260 is left after the inserted tag(s), unless the element has som required
1261 content.  If sgml-leave-point-after-insert is nil the point is left
1262 after the first tag inserted."
1263   (interactive "*e")
1264   (let ((end (sgml-mouse-region)))
1265     (sgml-parse-to-here)
1266     (cond
1267      ((eq sgml-markup-type 'start-tag)
1268       (sgml-right-stag-menu event))
1269      (t
1270       (let ((what
1271              (sgml-menu-ask event (if (or end sgml-balanced-tag-edit)
1272                                       'element 'tags))))
1273         (cond
1274          ((null what))
1275          (end
1276           (sgml-tag-region what (point) end))
1277          (sgml-balanced-tag-edit
1278           (sgml-insert-element what))
1279          (t
1280           (sgml-insert-tag what))))))))
1281
1282
1283 (defun sgml-right-stag-menu (event)
1284   (let* ((el (sgml-find-attribute-element))
1285          (attrib-menu (ignore-errors (sgml-make-attrib-menu el))))
1286
1287     (let* ((alt-gi (mapcar (function sgml-eltype-name)
1288                            (progn
1289                              (sgml-find-context-of (sgml-element-start el))
1290                              (sgml-current-list-of-valid-eltypes))))
1291            (change-menu
1292             (cons "Change To"
1293                   (loop for gi in alt-gi
1294                         collect `(,gi (sgml-change-element-name ,gi))))))
1295       (sgml-popup-multi-menu
1296        event "Start Tag"
1297        (list* `("Misc"
1298                 ("Edit attributes" (sgml-edit-attributes))
1299                 ("Normalize" (sgml-normalize-element))
1300                 ("Fill" (sgml-fill-element
1301                          (sgml-find-context-of (point))))
1302                 ("Splice" (sgml-untag-element))
1303                 ("Fold"   (sgml-fold-element)))
1304               change-menu
1305               ;;`("--" "--")
1306               attrib-menu)))))
1307
1308
1309 \f
1310 ;;;; SGML mode: Fill
1311
1312 (defun sgml-element-fillable (element)
1313   (and (sgml-element-mixed element)
1314        (not (sgml-element-appdata element 'nofill))))
1315
1316 (defun sgml-fill-element (element)
1317   "Fill biggest enclosing element with mixed content.
1318 If current element has pure element content, recursively fill the
1319 subelements."
1320   (interactive (list (sgml-find-element-of (point))))
1321   ;;
1322   (message "Filling...")
1323   (when (sgml-element-fillable element)
1324     ;; Find biggest enclosing fillable element
1325     (while (sgml-element-fillable (sgml-element-parent element))
1326       (setq element (sgml-element-parent element))))
1327   ;;
1328   (sgml-do-fill element)
1329   (sgml-message "Done"))
1330
1331 (defun sgml-do-fill (element)
1332   (when sgml-debug
1333     (goto-char (sgml-element-start element))
1334     (sit-for 0))
1335   (save-excursion
1336     (cond
1337      ((sgml-element-fillable element)
1338       (let (last-pos
1339             (c (sgml-element-content element))
1340             (agenda nil))               ; regions to fill later
1341         (goto-char (sgml-element-stag-end element))
1342         (when (eolp) (forward-char 1))
1343         (setq last-pos (point))
1344         (while c
1345           (cond
1346            ((sgml-element-fillable c))
1347            (t
1348             ;; Put region before element on agenda.  Can't fill it now
1349             ;; that would mangle the parse tree that is being traversed.
1350             (push (cons last-pos (sgml-element-start c))
1351                   agenda)
1352             (goto-char (sgml-element-start c))
1353             (sgml-do-fill c)
1354             ;; Fill may change parse tree, get a fresh
1355             (setq c (sgml-find-element-of (point)))
1356             (setq last-pos (sgml-element-end c))))
1357           (setq c (sgml-element-next c)))
1358         ;; Fill the last region in content of element,
1359         ;; but get a fresh parse tree, if it has change due to other fills.
1360         (goto-char last-pos)
1361         (when (bolp) (sgml-indent-line))
1362         (sgml-fill-region last-pos
1363                           (sgml-element-etag-start
1364                            (sgml-find-element-of
1365                             (sgml-element-start element))))
1366         (while agenda
1367           (sgml-fill-region (caar agenda) (cdar agenda))
1368           (setq agenda (cdr agenda)))))
1369      (t
1370       ;; If element is not mixed, fill subelements recursively
1371       (let ((c (sgml-element-content element)))
1372         (while c
1373           (goto-char (sgml-element-etag-start c))
1374           (sgml-indent-line)
1375           (goto-char (sgml-element-start c))
1376           (sgml-indent-line)
1377           (setq c (sgml-find-element-of (point)))
1378           (sgml-do-fill c)
1379           (setq c (sgml-element-next (sgml-find-element-of (point))))))))))
1380
1381 (defun sgml-fill-region (start end)
1382   (sgml-message "Filling...")
1383   (save-excursion
1384     (goto-char end)
1385     (skip-chars-backward " \t\n")
1386     (while (progn (beginning-of-line 1)
1387                   (< start (point)))
1388       (delete-char -1)
1389       (delete-horizontal-space)
1390       (insert " "))
1391     (end-of-line 1)
1392     (let (give-up prev-column opoint oopoint)
1393       (while (and (not give-up) (> (current-column) fill-column))
1394         (setq prev-column (current-column))
1395         (setq oopoint (point))
1396         (move-to-column (1+ fill-column))
1397         (skip-chars-backward "^ \t\n")
1398         (setq opoint (point))
1399         (skip-chars-backward " \t")
1400         (if (bolp)
1401             (progn
1402               (goto-char opoint)
1403               (if (re-search-forward "[ \t]" oopoint t)
1404                   (save-excursion
1405                     (skip-chars-forward " \t")
1406                     (setq opoint (point)))
1407                 (setq give-up t))))
1408         (if (not give-up)
1409             (progn
1410               (delete-region (point) opoint)
1411               (newline)
1412               (sgml-indent-line)
1413               (end-of-line 1)
1414               (setq give-up (>= (current-column) prev-column))))))))
1415 \f
1416 ;;;; SGML mode: Attribute editing
1417
1418 (defvar sgml-start-attributes nil)
1419 (defvar sgml-main-buffer nil)
1420 (defvar sgml-attlist nil)
1421
1422 (defun sgml-edit-attributes ()
1423   "Edit attributes of current element.
1424 Editing is done in a separate window."
1425   (interactive)
1426   (let ((element (sgml-find-attribute-element)))
1427     (unless (sgml-bpos-p (sgml-element-stag-epos element))
1428       (error "Element's start-tag is not in the buffer"))
1429     (push-mark)
1430     (goto-char (sgml-element-start element))
1431     (let* ((start (point-marker))
1432            (asl (sgml-element-attribute-specification-list element))
1433            (cb (current-buffer))
1434            (quote sgml-always-quote-attributes)
1435            (xml-p sgml-xml-p))
1436       (switch-to-buffer-other-window
1437        (sgml-attribute-buffer element asl))
1438       (make-local-variable 'sgml-start-attributes)
1439       (setq sgml-start-attributes start)
1440       (make-local-variable 'sgml-always-quote-attributes)
1441       (setq sgml-always-quote-attributes quote)
1442       (make-local-variable 'sgml-main-buffer)
1443       (setq sgml-main-buffer cb)
1444       (make-local-variable 'sgml-xml-p)
1445       (setq sgml-xml-p xml-p))))
1446
1447
1448 (defun sgml-effective-attlist (eltype)
1449   (let ((effective-attlist nil)
1450         (attlist (sgml-eltype-attlist eltype))
1451         (attnames (or (sgml-eltype-appdata eltype 'attnames)
1452                       '(*))))
1453     (while (and attnames (not (eq '* (car attnames))))
1454       (let ((attdecl (sgml-lookup-attdecl (car attnames) attlist)))
1455         (if attdecl
1456             (push attdecl effective-attlist)
1457           (message "Attnames specefication error: no %s attribute in %s"
1458                    (car attnames) eltype)))
1459       (setq attnames (cdr attnames)))
1460     (when (eq '* (car attnames))
1461       (while attlist
1462         (let ((attdecl (sgml-lookup-attdecl (sgml-attdecl-name (car attlist))
1463                                             effective-attlist)))
1464           (unless attdecl
1465             (push (car attlist) effective-attlist)))
1466         (setq attlist (cdr attlist))))
1467     (nreverse effective-attlist)))
1468
1469
1470 (defun sgml-attribute-buffer (element asl)
1471   (let ((bname "*Edit attributes*")
1472         (buf nil)
1473         (inhibit-read-only t))
1474     (save-excursion
1475       (when (setq buf (get-buffer bname))
1476         (kill-buffer buf))
1477       (setq buf (get-buffer-create bname))
1478       (set-buffer buf)
1479       (erase-buffer)
1480       (sgml-edit-attrib-mode)
1481       (make-local-variable 'sgml-attlist)
1482       (setq sgml-attlist (sgml-effective-attlist
1483                           (sgml-element-eltype element)))
1484       (sgml-insert '(read-only t)
1485                    (substitute-command-keys
1486                     "<%s  -- Edit values and finish with \
1487 \\[sgml-edit-attrib-finish], abort with \\[sgml-edit-attrib-abort] --\n")
1488                    (sgml-element-name element))
1489       (loop
1490        for attr in sgml-attlist do
1491        ;; Produce text like
1492        ;;  name = value
1493        ;;  -- declaration : default --
1494        (let* ((aname (sgml-attdecl-name attr))
1495               (dcl-value (sgml-attdecl-declared-value attr))
1496               (def-value (sgml-attdecl-default-value attr))
1497               (cur-value (sgml-lookup-attspec aname asl)))
1498          (sgml-insert                   ; atribute name
1499           '(read-only t category sgml-form) " %s =" aname)
1500          (cond                          ; attribute value
1501           ((sgml-default-value-type-p 'FIXED def-value)
1502            (sgml-insert '(read-only t category sgml-fixed)
1503                         " #FIXED %s"
1504                         (sgml-default-value-attval def-value)))
1505           ((and (null cur-value)
1506                 (or (memq def-value '(IMPLIED CONREF CURRENT))
1507                     (sgml-default-value-attval def-value)))
1508            (sgml-insert '(read-only t category sgml-form
1509                                     rear-nonsticky (read-only category))
1510                         " ")
1511            (sgml-insert '(category sgml-default rear-nonsticky (category))
1512                         "#DEFAULT"))
1513           (t
1514            (sgml-insert '(read-only t category sgml-form
1515                                     rear-nonsticky (read-only category))
1516                         " ")
1517            (when (not (null cur-value))
1518              (sgml-insert nil "%s" (sgml-attspec-attval cur-value)))))
1519          (sgml-insert
1520           '(read-only 1)
1521           "\n\t-- %s: %s --\n"
1522           (cond ((sgml-declared-value-token-group dcl-value))
1523                 ((sgml-declared-value-notation dcl-value)
1524                  (format "NOTATION %s"
1525                          (sgml-declared-value-notation dcl-value)))
1526                 (t
1527                  dcl-value))
1528           (cond ((sgml-default-value-attval def-value))
1529                 (t
1530                  (concat "#" (upcase (symbol-name def-value))))))))
1531       (sgml-insert '(read-only t) ">")
1532       (goto-char (point-min))
1533       (sgml-edit-attrib-next))
1534     buf))
1535
1536
1537 (defvar sgml-edit-attrib-mode-map (make-sparse-keymap))
1538
1539 ;; used as only for #DEFAULT in attribute editing. Binds all normally inserting
1540 ;; keys to a command that will clear the #DEFAULT before doing self-insert.
1541 (defvar sgml-attr-default-keymap
1542   (let ((map (make-sparse-keymap)))
1543     (set-keymap-parent map sgml-edit-attrib-mode-map)
1544     (substitute-key-definition 'self-insert-command
1545                                'sgml-attr-clean-and-insert
1546                                map
1547                                global-map)
1548     (put 'sgml-default 'local-map map)))
1549
1550 (define-key sgml-edit-attrib-mode-map "\C-c\C-c" 'sgml-edit-attrib-finish)
1551 (define-key sgml-edit-attrib-mode-map "\C-c\C-d" 'sgml-edit-attrib-default)
1552 (define-key sgml-edit-attrib-mode-map "\C-c\C-k" 'sgml-edit-attrib-abort)
1553
1554 (define-key sgml-edit-attrib-mode-map "\C-a"  'sgml-edit-attrib-field-start)
1555 (define-key sgml-edit-attrib-mode-map "\C-e"  'sgml-edit-attrib-field-end)
1556 (define-key sgml-edit-attrib-mode-map "\t"  'sgml-edit-attrib-next)
1557
1558 (defun sgml-edit-attrib-mode ()
1559   "Major mode to edit attribute specification list.\\<sgml-edit-attrib-mode-map>
1560 Use \\[sgml-edit-attrib-next] to move between input fields.  Use
1561 \\[sgml-edit-attrib-default] to make an attribute have its default
1562 value.  To abort edit kill buffer (\\[kill-buffer]) and remove window
1563 \(\\[delete-window]).  To finish edit use \\[sgml-edit-attrib-finish].
1564
1565 \\{sgml-edit-attrib-mode-map}"
1566   (setq mode-name "SGML edit attributes"
1567         major-mode 'sgml-edit-attrib-mode)
1568   (use-local-map sgml-edit-attrib-mode-map)
1569   (run-hooks 'text-mode-hook 'sgml-edit-attrib-mode-hook))
1570
1571 (defun sgml-edit-attrib-abort ()
1572   "Abort the attribute editor, removing the window."
1573   (interactive)
1574   (let ((cb (current-buffer))
1575         (start sgml-start-attributes))
1576     (delete-windows-on cb)
1577     (kill-buffer cb)
1578     (when (markerp start)
1579       (switch-to-buffer (marker-buffer start))
1580       (goto-char start))))
1581
1582 (defun sgml-edit-attrib-finish ()
1583   "Finish editing and insert attribute values in original buffer."
1584   (interactive)
1585   (let ((cb (current-buffer))
1586         (asl (sgml-edit-attrib-specification-list))
1587         ;; save buffer local variables
1588         (start sgml-start-attributes))
1589     (when (markerp start)
1590       (delete-windows-on cb)
1591       (switch-to-buffer (marker-buffer start))
1592       (kill-buffer cb)
1593       (goto-char start)
1594       (let ((element (sgml-find-element-of start)))
1595         ;; *** Should the it be verified that this element
1596         ;; is the one edited?
1597         (sgml-change-start-tag element asl)))))
1598
1599
1600 (defun sgml-edit-attrib-specification-list ()
1601   (goto-char (point-min))
1602   (forward-line 1)
1603   (sgml-with-parser-syntax
1604    (let ((asl nil)
1605          (al sgml-attlist))
1606      (while (not (eq ?> (following-char)))
1607        (sgml-parse-s)
1608        (sgml-check-nametoken)           ; attribute name, should match head of al
1609        (forward-char 3)
1610        (unless (memq (get-text-property (point) 'category)
1611                      '(sgml-default sgml-fixed))
1612          (push
1613           (sgml-make-attspec (sgml-attdecl-name (car al))
1614                              (sgml-extract-attribute-value
1615                               (sgml-attdecl-declared-value (car al))))
1616           asl))
1617        (while (progn (beginning-of-line 2)
1618                      (or (eolp)
1619                          (not (get-text-property (point) 'read-only)))))
1620
1621        (forward-line 1)
1622        (setq al (cdr al)))
1623      asl)))
1624
1625
1626 (defun sgml-extract-attribute-value (type)
1627   (save-excursion
1628     (save-restriction
1629       (narrow-to-region (point)
1630                         (progn (sgml-edit-attrib-field-end)
1631                                (point)))
1632       (goto-char (point-min))
1633       (while (not (eobp))
1634         (if (eq 'sgml-default (get-text-property (point) 'category))
1635             (delete-char 1)
1636           (forward-char 1)))
1637       (unless (eq type 'CDATA)
1638         (subst-char-in-region (point-min) (point-max) ?\n ? )
1639         (goto-char (point-min))
1640         (delete-horizontal-space))
1641       (goto-char (point-min))
1642       (when (search-forward "\"" nil t) ; don't allow both " and '
1643         (goto-char (point-min))
1644         (while (search-forward "'" nil t) ; replace ' with char ref
1645           (replace-match "&#39;")))
1646       (buffer-string))))
1647
1648 (defun sgml-edit-attrib-default ()
1649   "Set current attribute value to default."
1650   (interactive)
1651   (sgml-edit-attrib-clear)
1652   (save-excursion
1653     (sgml-insert '(category sgml-default rear-nonsticky (category))
1654                  "#DEFAULT")))
1655
1656 (defun sgml-edit-attrib-clear ()
1657   "Kill the value of current attribute."
1658   (interactive)
1659   (let ((inhibit-read-only '(sgml-default)))
1660     (sgml-edit-attrib-field-start)
1661     (let ((end (save-excursion (sgml-edit-attrib-field-end) (point))))
1662       (put-text-property (point) end 'read-only nil)
1663       (let ((inhibit-read-only t))
1664         (put-text-property (1- (point)) (point)
1665                            'rear-nonsticky '(read-only category)))
1666       (kill-region (point) end))))
1667
1668
1669 (defun sgml-attr-clean-and-insert (n)
1670   "Insert the character you type, after clearing the current attribute."
1671   (interactive "p")
1672   (sgml-edit-attrib-clear)
1673   (self-insert-command n))
1674
1675
1676 (defun sgml-edit-attrib-field-start ()
1677   "Go to the start of the attribute value field."
1678   (interactive)
1679   (let (start)
1680     (beginning-of-line 1)
1681     (while (not (eq t (get-text-property (point) 'read-only)))
1682       (beginning-of-line 0))
1683     (while (eq 'sgml-form (get-text-property (point) 'category))
1684       (setq start (next-single-property-change (point) 'category))
1685       (unless start (error "No attribute value here"))
1686       (assert (number-or-marker-p start))
1687       (goto-char start))))
1688
1689 (defun sgml-edit-attrib-field-end ()
1690   "Go to the end of the attribute value field."
1691   (interactive)
1692   (sgml-edit-attrib-field-start)
1693   (let ((end (if (and (eolp)
1694                       (get-text-property (1+ (point)) 'read-only))
1695                  (point)
1696                (next-single-property-change (point) 'read-only))))
1697     (assert (number-or-marker-p end))
1698     (goto-char end)))
1699
1700 (defun sgml-edit-attrib-next ()
1701   "Move to next attribute value."
1702   (interactive)
1703   (if (eq t (get-text-property (point) 'read-only))
1704       (beginning-of-line 1))
1705   (or (search-forward-regexp (if sgml-have-re-char-clases
1706                                  "^ *[-_.:[:alnum:]]+ *= ?"
1707                                "^ *[-_.:A-Za-z0-9]+ *= ?") nil t)
1708       (goto-char (point-min))))
1709
1710 \f
1711 ;;;; SGML mode: Hiding tags/attributes
1712
1713 (defconst sgml-tag-regexp
1714   (if sgml-have-re-char-clases
1715       "\\(</?>\\|</?[_[:alpha:]][-_:[:alnum:].]*\\(\\([^'\"></]\\|'[^']*'\\|\"[^\"]*\"\\)*\\)/?>?\\)"
1716     "\\(</?>\\|</?[_A-Za-z][-_:A-Za-z0-9.]*\\(\\([^'\"></]\\|'[^']*'\\|\"[^\"]*\"\\)*\\)/?>?\\)"))
1717
1718 (defun sgml-operate-on-tags (action &optional attr-p)
1719   (let ((buffer-modified-p (buffer-modified-p))
1720         (inhibit-read-only t)
1721         (buffer-read-only nil)
1722         (before-change-functions nil)
1723         (markup-index                   ; match-data index in tag regexp
1724          (if attr-p 2 1))
1725         (tagcount                       ; number tags to give them uniq
1726                                         ; invisible properties
1727          1))
1728     (unwind-protect
1729         (save-excursion
1730           (goto-char (point-min))
1731           (while (re-search-forward sgml-tag-regexp nil t)
1732             (cond
1733              ((eq action 'hide)
1734               (let ((tag (downcase
1735                           (buffer-substring-no-properties
1736                            (1+ (match-beginning 0))
1737                            (match-beginning 2)))))
1738                 (if (or attr-p (not (member tag sgml-exposed-tags)))
1739                     (add-text-properties
1740                      (match-beginning markup-index) (match-end markup-index)
1741                      (list 'invisible tagcount
1742                            'rear-nonsticky '(invisible face))))))
1743              ((eq action 'show)         ; ignore markup-index
1744               (remove-text-properties (match-beginning 0) (match-end 0)
1745                                       '(invisible nil)))
1746              (t (error "Invalid action: %s" action)))
1747             (incf tagcount)))
1748       (sgml-restore-buffer-modified-p buffer-modified-p))))
1749
1750 (defun sgml-hide-tags ()
1751   "Hide all tags in buffer."
1752   (interactive)
1753   (sgml-operate-on-tags 'hide))
1754
1755 (defun sgml-show-tags ()
1756   "Show hidden tags in buffer."
1757   (interactive)
1758   (sgml-operate-on-tags 'show))
1759
1760 (defun sgml-hide-attributes ()
1761   "Hide all attribute specifications in the buffer."
1762   (interactive)
1763   (sgml-operate-on-tags 'hide 'attributes))
1764
1765 (defun sgml-show-attributes ()
1766   "Show all attribute specifications in the buffer."
1767   (interactive)
1768   (sgml-operate-on-tags 'show 'attributes))
1769
1770 \f
1771 ;;;; SGML mode: Normalize (and misc manipulations)
1772
1773 (defun sgml-expand-shortref-to-text (name)
1774   (let (before-change-functions
1775         (entity (sgml-lookup-entity name (sgml-dtd-entities sgml-dtd-info))))
1776     (cond
1777      ((null entity) (sgml-error "Undefined entity %s" name))
1778      ((sgml-entity-data-p entity)
1779       (sgml-expand-shortref-to-entity name))
1780      (t
1781       (delete-region sgml-markup-start (point))
1782       (sgml-entity-insert-text entity)
1783       (setq sgml-goal (point-max))      ; May have changed size of buffer
1784       ;; now parse the entity text
1785       (setq sgml-rs-ignore-pos sgml-markup-start)
1786       (goto-char sgml-markup-start)))))
1787
1788 (defun sgml-expand-shortref-to-entity (name)
1789   (let ((end (point))
1790         (re-found nil)
1791         before-change-functions)
1792     (goto-char sgml-markup-start)
1793     (setq re-found (search-forward "\n" end t))
1794     (delete-region sgml-markup-start end)
1795     (insert "&" name (if re-found "\n" ";"))
1796     (setq sgml-goal (point-max))        ; May have changed size of buffer
1797     (goto-char (setq sgml-rs-ignore-pos sgml-markup-start))))
1798
1799 (defun sgml-expand-all-shortrefs (to-entity)
1800   "Expand all short references in the buffer.
1801 Short references to text entities are expanded to the replacement text
1802 of the entity; other short references are expanded into general entity
1803 references.  If argument TO-ENTITY is non-nil, or if called
1804 interactively with a numeric prefix argument, all short references are
1805 replaced by general entity references."
1806   (interactive "*P")
1807   (sgml-reparse-buffer
1808    (if to-entity
1809        (function sgml-expand-shortref-to-entity)
1810      (function sgml-expand-shortref-to-text))))
1811
1812 (defun sgml-normalize (to-entity &optional element)
1813   "Normalize buffer by filling in omitted tags and expanding empty tags.
1814 Argument TO-ENTITY controls how short references are expanded as with
1815 `sgml-expand-all-shortrefs'.  An optional argument ELEMENT can be the
1816 element to normalize instead of the whole buffer, if used no short
1817 references will be expanded."
1818   (interactive "*P")
1819   (unless element
1820     (sgml-expand-all-shortrefs to-entity))
1821   (let ((only-one (not (null element))))
1822     (setq element (or element (sgml-top-element)))
1823     (goto-char (sgml-element-end element))
1824     ;; FIXME: actually the sgml-note-change-at called by the
1825     ;; before-change-functions need to be delayed to after the normalize
1826     ;; to avoid destroying the tree wile traversing it.
1827     (let ((before-change-functions nil))
1828       (sgml-normalize-content element only-one)))
1829   (sgml-note-change-at (sgml-element-start element))
1830   (sgml-message "Done"))
1831
1832 (defun sgml-normalize-element ()
1833   (interactive "*")
1834   (sgml-normalize nil (sgml-find-element-of (point))))
1835
1836 (defun sgml-normalize-content (element only-first)
1837   "Normalize all elements in a content where ELEMENT is first element.
1838 If sgml-normalize-trims is non-nil, trim off white space from ends of
1839 elements with omitted end-tags."
1840   (let ((content nil))
1841     (while element                      ; Build list of content elements
1842       (push element content)
1843       (setq element (if only-first
1844                         nil
1845                       (sgml-element-next element))))
1846     (while content
1847       (setq element (car content))
1848       ;; Progress report
1849       (sgml-lazy-message "Normalizing %d%% left"
1850                          (/ (point) (/ (+ (point-max) 100) 100)))
1851       ;; Fix the end-tag
1852       (sgml-normalize-end-tag element)
1853       ;; Fix tags of content
1854       (sgml-normalize-content (sgml-tree-content element) nil)
1855       ;; Fix the start-tag
1856       (sgml-normalize-start-tag element)
1857       ;; Next content element
1858       (setq content (cdr content)))))
1859
1860 (defun sgml-normalize-start-tag (element)
1861   (when (sgml-bpos-p (sgml-element-stag-epos element))
1862     (goto-char (min (point) (sgml-element-start element)))
1863     (let ((name (sgml-element-gi element))
1864           (attlist (sgml-element-attlist element))
1865           (asl (sgml-element-attribute-specification-list element)))
1866       (save-excursion
1867         (assert (or (zerop (sgml-element-stag-len element))
1868                     (= (point) (sgml-element-start element))))
1869         (delete-char (sgml-element-stag-len element))
1870         (sgml-insert-start-tag name asl attlist nil)))))
1871
1872 (defun sgml-normalize-end-tag (element)
1873   (unless (sgml-element-empty element)
1874     (when (sgml-bpos-p (sgml-element-etag-epos element))
1875       (goto-char (min (point) (sgml-element-etag-start element)))
1876       (if (and (zerop (sgml-element-etag-len element))
1877                sgml-normalize-trims)
1878           (skip-chars-backward " \t\n\r"))
1879       (delete-char (sgml-tree-etag-len element))
1880       ;; XEmacs change: use tempo
1881       (save-excursion (tempo-process-and-insert-string (sgml-end-tag-of element))))))
1882
1883
1884 (defun sgml-make-character-reference (&optional invert)
1885   "Convert character after point into a character reference.
1886 If called with a numeric argument, convert a character reference back
1887 to a normal character.  If called from a program, set optional
1888 argument INVERT to non-nil.  If the function `decode-char' is defined,
1889 convert to and from Unicode.  Otherwise will only work for ASCII or 8-bit
1890 characters in the current coding system."
1891   (interactive "*P")
1892   (cond
1893    (invert
1894     (or (looking-at "&#\\([0-9]+\\)[;\n]?")
1895         (error "No character reference after point"))
1896     (let ((c (string-to-int (buffer-substring (match-beginning 1)
1897                                               (match-end 1)))))
1898       (delete-region (match-beginning 0)
1899                      (match-end 0))
1900       (if (fboundp 'decode-char)        ; Emacs 21, Mule-UCS
1901           (setq c (decode-char 'ucs c))
1902         ;; Else have to assume 8-bit character.
1903         (if (fboundp 'unibyte-char-to-multibyte) ; Emacs 20
1904             (setq c (unibyte-char-to-multibyte c))))
1905       (insert c)))
1906    ;; Convert character to &#nn;
1907    (t
1908     (let ((c (following-char)))
1909       (delete-char 1)
1910       (if (fboundp 'encode-char)
1911           (setq c (encode-char c 'ucs))
1912         (if (fboundp 'multibyte-char-to-unibyte)
1913             (setq c (multibyte-char-to-unibyte c))))
1914       (insert (format "&#%d;" c))))))
1915
1916 (defun sgml-expand-entity-reference ()
1917   "Insert the text of the entity referenced at point."
1918   (interactive)
1919   (save-excursion
1920     (sgml-with-parser-syntax
1921      (setq sgml-markup-start (point))
1922      (or (sgml-parse-delim "ERO")
1923          (progn
1924            (skip-syntax-backward "w_")
1925            (forward-char -1)            ; @@ Really length of ERO
1926            (setq sgml-markup-start (point))
1927            (sgml-check-delim "ERO")))
1928      (let* ((ename (sgml-check-name t))
1929             (entity (sgml-lookup-entity ename
1930                                         (sgml-dtd-entities
1931                                          (sgml-pstate-dtd
1932                                           sgml-buffer-parse-state)))))
1933        (unless entity
1934          (error "Undefined entity %s" ename))
1935        (or (sgml-parse-delim "REFC")
1936            (sgml-parse-RE))
1937        (delete-region sgml-markup-start (point))
1938        (sgml-entity-insert-text entity)))))
1939
1940
1941
1942 (defun sgml-trim-and-leave-element ()
1943   "Remove blanks at end of current element and move point to after element."
1944   (interactive)
1945   (goto-char (sgml-element-etag-start (sgml-last-element)))
1946   (while (progn (forward-char -1)
1947                 (looking-at "\\s-"))
1948     (delete-char 1))
1949   (sgml-up-element))
1950
1951
1952 (defvar sgml-notation-handlers
1953   '((gif . "xv")
1954     (jpeg . "xv"))
1955   "*An alist mapping notations to programs handling them")
1956
1957 ;; Function contributed by Matthias Clasen <clasen@netzservice.de>
1958 (defun sgml-edit-external-entity ()
1959   "Open a new window and display the external entity at the point."
1960   (interactive)
1961   (sgml-need-dtd)
1962   (save-excursion
1963     (sgml-with-parser-syntax
1964      (setq sgml-markup-start (point))
1965      (unless (sgml-parse-delim "ERO")
1966        (search-backward-regexp "[&>;]")
1967        (setq sgml-markup-start (point))
1968        (sgml-check-delim "ERO"))
1969      (sgml-parse-to-here)               ; get an up-to-date parse tree
1970      (let* ( (parent (buffer-file-name)) ; used to be (sgml-file)
1971              (ename (sgml-check-name t))
1972              (entity (sgml-lookup-entity ename
1973                                          (sgml-dtd-entities
1974                                           (sgml-pstate-dtd
1975                                            sgml-buffer-parse-state))))
1976              (buffer nil)
1977              (ppos nil))
1978        (unless entity
1979          (error "Undefined entity %s" ename))
1980
1981        (let* ((type (sgml-entity-type entity))
1982               (notation (sgml-entity-notation entity))
1983               (handler (cdr (assoc notation sgml-notation-handlers))))
1984          (case type
1985            (ndata
1986             (if handler
1987                 (progn
1988                   (message (format "Using '%s' to handle notation '%s'."
1989                                    handler notation))
1990                   (save-excursion
1991                     (set-buffer (get-buffer-create "*SGML background*"))
1992                     (erase-buffer)
1993                     (let* ((file (sgml-external-file
1994                                   (sgml-entity-text entity)
1995                                   type
1996                                   (sgml-entity-name entity)))
1997                            (process (start-process
1998                                      (format "%s background" handler)
1999                                      nil handler file)))
2000                       (process-kill-without-query process))))
2001               (error "Don't know how to handle notation '%s'." notation)))
2002            (text (progn
2003
2004             ;; here I try to construct a useful value for
2005             ;; `sgml-parent-element'.
2006
2007             ;; find sensible values for the HAS-SEEN-ELEMENT part
2008             (let ((seen nil)
2009                   (child (sgml-tree-content sgml-current-tree)))
2010               (while (and child
2011                           (sgml-tree-etag-epos child)
2012                           (<= (sgml-tree-end child) (point)))
2013                 (push (sgml-element-gi child) seen)
2014                 (setq child (sgml-tree-next child)))
2015               (push (nreverse seen) ppos))
2016
2017             ;; find ancestors
2018             (let ((rover sgml-current-tree))
2019               (while (not (eq rover sgml-top-tree))
2020                 (push (sgml-element-gi rover) ppos)
2021                 (setq rover (sgml-tree-parent rover))))
2022
2023             (find-file-other-window
2024              (sgml-external-file (sgml-entity-text entity)
2025                                  (sgml-entity-type entity)
2026                                  (sgml-entity-name entity)))
2027             (goto-char (point-min))
2028             (sgml-mode)
2029             (setq sgml-parent-document (cons parent ppos))
2030             ;; update the live element indicator of the new window
2031             (sgml-parse-to-here)))
2032            (t (error "Can't edit entities of type '%s'." type))))))))
2033 \f
2034 ;;;; SGML mode: TAB completion
2035
2036 (defun sgml-complete ()
2037   "Complete the word/tag/entity before point.
2038 If it is a tag (starts with < or </) complete with valid tags.
2039 If it is an entity (starts with &) complete with declared entities.
2040 If it is a markup declaration (starts with <!) complete with markup
2041 declaration names. If it is a reserved word starting with # complete
2042 reserved words.
2043 If it is something else complete with ispell-complete-word."
2044   (interactive "*")
2045   (let ((tab                            ; The completion table
2046          nil)
2047         (ignore-case                    ; If ignore case in matching completion
2048          sgml-namecase-general)
2049         (insert-case
2050          'sgml-general-insert-case)
2051         (pattern nil)
2052         (c nil)
2053         (here (point)))
2054     (skip-chars-backward "^ \n\t</!&%#")
2055     (setq pattern (buffer-substring (point) here))
2056     (setq c (char-after (1- (point))))
2057     (cond
2058      ;; entitiy
2059      ((eq c ?&)
2060       (sgml-need-dtd)
2061       (setq insert-case 'sgml-entity-insert-case)
2062       (setq tab
2063             (sgml-entity-completion-table
2064              (sgml-dtd-entities (sgml-pstate-dtd sgml-buffer-parse-state)))))
2065      ;; start-tag
2066      ((eq c ?<)
2067       (save-excursion
2068         (backward-char 1)
2069         (sgml-parse-to-here)
2070         (setq tab (sgml-eltype-completion-table
2071                    (sgml-current-list-of-valid-eltypes)))))
2072      ;; end-tag
2073      ((eq c ?/)
2074       (save-excursion
2075         (backward-char 2)
2076         (sgml-parse-to-here)
2077         (setq tab (sgml-eltype-completion-table
2078                    (sgml-current-list-of-endable-eltypes)))))
2079      ;; markup declaration
2080      ((eq c ?!)
2081       (setq tab sgml-markup-declaration-table
2082             ignore-case t))
2083      ;; Reserved words with '#' prefix
2084      ((eq c ?#)
2085       (setq tab '(("PCDATA") ("NOTATION") ("IMPLIED") ("REQUIRED")
2086                   ("FIXED") ("EMPTY"))
2087             ignore-case t))
2088      (t
2089       (goto-char here)
2090       (ispell-complete-word)))
2091     (when tab
2092       (let* ((completion-ignore-case ignore-case)
2093              (completion (try-completion pattern tab)))
2094         (cond ((null completion)
2095                (goto-char here)
2096                (message "Can't find completion for \"%s\"" pattern)
2097                (ding))
2098               ((eq completion t)
2099                (goto-char here)
2100                (message "[Complete]"))
2101               ((not (string= pattern completion))
2102                (delete-char (length pattern))
2103                (insert (funcall insert-case completion)))
2104               (t
2105                (goto-char here)
2106                (message "Making completion list...")
2107                (let ((list (all-completions pattern tab)))
2108                  (with-output-to-temp-buffer " *Completions*"
2109                    (display-completion-list list)))
2110                (message "Making completion list...%s" "done")))))))
2111
2112 \f
2113 ;;;; SGML mode: Options menu
2114
2115 (defun sgml-file-options-menu (&optional event)
2116   (interactive "e")
2117   (sgml-options-menu event sgml-file-options))
2118
2119 (defun sgml-user-options-menu (&optional event)
2120   (interactive "e")
2121   (sgml-options-menu event sgml-user-options))
2122
2123 (defun sgml-options-menu (event vars)
2124   (let ((var
2125          (let ((maxlen
2126                 (loop for var in vars
2127                       maximize (length (sgml-variable-description var)))))
2128            (sgml-popup-menu
2129             event "Options"
2130             (loop for var in vars
2131                   for desc = (sgml-variable-description var)
2132                   collect
2133                   (cons
2134                    (format "%s%s [%s]"
2135                            desc
2136                            (make-string (- maxlen (length desc)) ? )
2137                            (sgml-option-value-indicator var))
2138                    var))))))
2139     (when var
2140       (sgml-do-set-option var event))))
2141
2142 ;; Fixme: Use Customize for this.
2143 (defun sgml-do-set-option (var &optional event)
2144   (let ((type (sgml-variable-type var))
2145         (val (symbol-value var)))
2146     (cond
2147      ((eq 'toggle type)
2148       (message "%s set to %s" var (not val))
2149       (set var (not val)))
2150      ((eq 'string type)
2151       (describe-variable var)
2152       (setq val (read-string (concat (sgml-variable-description var) ": ")))
2153       (when (stringp val)
2154         (set var val)))
2155      ((eq 'file-list  type)
2156       (describe-variable var)
2157       (sgml-append-to-help-buffer "\
2158 Enter as many filenames as you want. Entering a directory
2159 or non-existing filename will exit the loop.")
2160       (setq val nil)
2161       (while (let ((next
2162                     (expand-file-name
2163                      (read-file-name
2164                       (concat (sgml-variable-description var) ": ")
2165                       nil "" nil nil))))
2166                (if (and (file-exists-p next) (not (file-directory-p next)))
2167                    (setq val (cons next val)))))
2168       (set var val))
2169      ((eq 'file-or-nil type)
2170       (describe-variable var)
2171       (sgml-append-to-help-buffer "\
2172 Entering a directory or non-existing filename here
2173 will reset the variable.")
2174       (setq val (expand-file-name
2175                  (read-file-name
2176                   (concat (sgml-variable-description var) ": ")
2177                   nil (if (stringp val) (file-name-nondirectory val))
2178                   nil (if (stringp val) (file-name-nondirectory val)) )))
2179       (if (and (file-exists-p val) (not (file-directory-p val)))
2180           (set var val)
2181         (set var nil)))
2182      ((consp type)
2183       (let ((val
2184              (sgml-popup-menu event
2185                               (sgml-variable-description var)
2186                               (loop for c in type collect
2187                                     (cons
2188                                      (if (consp c) (car c) (format "%s" c))
2189                                      (if (consp c) (cdr c) c))))))
2190         (set var val)
2191         (message "%s set to %s" var val)))
2192      (t
2193       (describe-variable var)
2194       (setq val (read-string (concat (sgml-variable-description var)
2195                                      " (sexp): ")))
2196       (when (stringp val)
2197         (set var (car (read-from-string val)))))))
2198   (force-mode-line-update))
2199
2200 (defun sgml-append-to-help-buffer (string)
2201   (save-excursion
2202     (set-buffer "*Help*")
2203     (let ((inhibit-read-only t))
2204       (goto-char (point-max))
2205       (insert "\n" string))))
2206 \f
2207 ;;;; SGML mode: insert element where valid
2208
2209 (defun sgml--add-before-p (tok state child)
2210   ;; Can TOK be added in STATE followed by CHILD
2211   (let ((snext (sgml-get-move state tok))
2212         (c child))
2213     (when snext
2214       (while c
2215         (setq snext (sgml-get-move snext
2216                                    (sgml-eltype-token
2217                                     (sgml-element-eltype c))))
2218         (setq c (and snext (sgml-element-next c)))))
2219     ;; If snext is still non nill it can be inserted
2220     snext))
2221
2222 (defun sgml--all-possible-elements (el)
2223   (let ((c (sgml-element-content el))
2224         (s (sgml-element-model el))
2225         (found nil))
2226     (loop do
2227           ;; Fixme: this test avoids an error when DTD-less, but it's
2228           ;; probably an inappropriate kludge.  -- fx
2229           (when (not (eq s 'ANY))
2230             (dolist (tok (nconc (sgml-optional-tokens s)
2231                                 (sgml-required-tokens s)))
2232               (unless (memq tok found)
2233                 ;; tok is optional here and not already found -- check that
2234                 ;; it would not make the content invalid
2235                 (when (sgml--add-before-p tok s c)
2236                   (push tok found)))))
2237           while c do
2238           (setq s (sgml-element-pstate c))
2239           (setq c (sgml-element-next c)))
2240     (mapcar #'sgml-token-eltype found)))
2241
2242
2243 (defun sgml-add-element-to-element (gi first)
2244   "Add an element of type GI to the current element.
2245 The element will be added at the last legal position if FIRST is `nil',
2246 otherwise it will be added at the first legal position."
2247   (interactive
2248    (let ((tab
2249           (mapcar (lambda (et) (cons (sgml-eltype-name et) nil))
2250                   (sgml--all-possible-elements
2251                    (sgml-find-context-of (point))))))
2252      (cond ((null tab)
2253             (error "No element possible"))
2254            (t
2255             (let ((completion-ignore-case sgml-namecase-general))
2256               (list (completing-read "Element: " tab nil t
2257                                      (and (null (cdr tab)) (caar tab)))
2258                     current-prefix-arg))))))
2259   (let ((el (sgml-find-context-of (point)))
2260         (et (sgml-lookup-eltype (sgml-general-case gi))))
2261     ;; First expand empty tag
2262     (when (and sgml-xml-p (sgml-element-empty el))
2263       (save-excursion
2264         (goto-char (sgml-element-stag-end el))
2265         (delete-char -2)
2266         (insert ">\n" (sgml-end-tag-of sgml-current-tree))
2267         (sgml-indent-line))
2268       (setq el (sgml-find-context-of (point))))
2269     (let ((c (sgml-element-content el))
2270           (s (sgml-element-model el))
2271           (tok (sgml-eltype-token et))
2272           (last nil))
2273       ;; Find legal position for new element
2274       (while (and (not (cond
2275                         ((sgml--add-before-p tok s c)
2276                          (setq last (if c (sgml-element-start c)
2277                                       (sgml-element-etag-start el)))
2278                          first)))
2279                   (cond
2280                    (c (setq s (sgml-element-pstate c))
2281                       (setq c (sgml-element-next c))
2282                       t))))
2283       (cond (last
2284              (goto-char last)
2285              (sgml-insert-element gi))
2286             (t
2287              (error "A %s element is not valid in current element" gi))))))
2288 \f
2289 ;;;; Show current element type
2290 ;; Candidate for C-c C-t
2291
2292 (autoload 'sgml-princ-names "psgml-info")
2293 (autoload 'sgml-eltype-refrenced-elements "psgml-info")
2294
2295 (defun sgml-show-current-element-type ()
2296   "Show information about the current element and its type."
2297   (interactive)
2298   (let* ((el (sgml-find-context-of (point)))
2299          (et (sgml-element-eltype el)))
2300     (with-output-to-temp-buffer "*Current Element Type*"
2301       (princ (format "ELEMENT: %s%s\n" (sgml-eltype-name et)
2302                      (let ((help-text (sgml-eltype-appdata et 'help-text)))
2303                        (if help-text
2304                            (format " -- %s" help-text)
2305                            ""))))
2306       (when sgml-omittag
2307         (princ (format "\n Start-tag is %s.\n End-tag is %s.\n"
2308                        (if (sgml-eltype-stag-optional et)
2309                            "optional" "required")
2310                        (if (sgml-eltype-etag-optional et)
2311                            "optional" "required"))))
2312       ;; ----
2313       (princ "\nCONTENT: ")
2314       (cond ((symbolp (sgml-eltype-model et)) (princ (sgml-eltype-model et)))
2315             (t
2316              (princ (if (sgml-eltype-mixed et)
2317                         "mixed\n"
2318                       "element\n"))
2319              (sgml-print-position-in-model el et (point) sgml-current-state)
2320              (princ "\n\n")
2321              (sgml-princ-names
2322               (mapcar #'symbol-name (sgml-eltype-refrenced-elements et))
2323               "All: ")))
2324       (let ((incl (sgml-eltype-includes et))
2325             (excl (sgml-eltype-excludes et)))
2326         (when (or incl excl)
2327           (princ "\n\nEXCEPTIONS:"))
2328         (when incl
2329           (princ "\n + ")
2330           (sgml-princ-names (mapcar #'symbol-name incl)))
2331         (when excl
2332           (princ "\n - ")
2333           (sgml-princ-names (mapcar #'symbol-name excl))))
2334       ;; ----
2335       (princ "\n\nATTRIBUTES:\n")
2336       (sgml-print-attlist et)
2337       ;; ----
2338       (let ((s (sgml-eltype-shortmap et)))
2339         (when s
2340           (princ (format "\nUSEMAP: %s\n" s))))
2341       ;; ----
2342       (princ "\nOCCURS IN:\n")
2343       (let ((occurs-in ()))
2344         (sgml-map-eltypes
2345          (function (lambda (cand)
2346                      (when (memq et (sgml-eltype-refrenced-elements cand))
2347                        (push cand occurs-in))))
2348          (sgml-pstate-dtd sgml-buffer-parse-state))
2349         (sgml-princ-names (mapcar 'sgml-eltype-name
2350                                   (sort occurs-in (function string-lessp))))))))
2351
2352 (defun sgml-print-attlist (et)
2353   (let ((ob (current-buffer)))
2354     (set-buffer standard-output)
2355     (unwind-protect
2356         (loop
2357          for attdecl in (sgml-eltype-attlist et) do
2358          (princ " ")
2359          (princ (sgml-attdecl-name attdecl))
2360          (let ((dval (sgml-attdecl-declared-value attdecl))
2361                (defl (sgml-attdecl-default-value attdecl)))
2362            (when (listp dval)
2363              (setq dval (concat (if (eq (first dval)
2364                                         'NOTATION)
2365                                     "#NOTATION (" "(")
2366                                 (mapconcat (function identity)
2367                                            (second dval)
2368                                            "|")
2369                                 ")")))
2370            (indent-to 15 1)
2371            (princ dval)
2372            (cond ((sgml-default-value-type-p 'FIXED defl)
2373                   (setq defl (format "#FIXED '%s'"
2374                                      (sgml-default-value-attval defl))))
2375                  ((symbolp defl)
2376                   (setq defl (upcase (format "#%s" defl))))
2377                  (t
2378                   (setq defl (format "'%s'"
2379                                      (sgml-default-value-attval defl)))))
2380
2381            (indent-to 48 1)
2382            (princ defl)
2383            (terpri)))
2384       (set-buffer ob))))
2385
2386
2387 (defun sgml-print-position-in-model (element element-type buffer-pos parse-state)
2388   (let ((u (sgml-element-content element))
2389         (names nil))
2390     (while (and u (>= buffer-pos (sgml-element-end u)))
2391       (push (sgml-element-gi u) names)
2392       (setq u (sgml-element-next u)))
2393     (when names
2394       (sgml-princ-names (nreverse names) " " ", ")
2395       (princ "\n")))
2396   (princ " ->")
2397   (let* ((state parse-state)
2398          (required-seq                  ; the seq of req el following point
2399           (loop for required = (sgml-required-tokens state)
2400                 while (and required (null (cdr required)))
2401                 collect (sgml-eltype-name (car required))
2402                 do (setq state (sgml-get-move state (car required)))))
2403          (last-alt
2404           (mapcar 'sgml-eltype-name
2405                   (append (sgml-optional-tokens state)
2406                           (sgml-required-tokens state)))))
2407     (cond
2408      (required-seq
2409       (when last-alt
2410         (nconc required-seq
2411                (list (concat "("
2412                              (mapconcat (lambda (x) x)
2413                                         last-alt " | ")
2414                              (if (sgml-final state)
2415                                  ")?" ")")))))
2416       (sgml-princ-names required-seq " " ", "))
2417
2418      (last-alt
2419       (sgml-princ-names last-alt " (" " | ")
2420       (princ ")")
2421       (when (sgml-final state)
2422         (princ "?"))))))
2423
2424 \f
2425 ;;;; Structure Viewing and Navigating
2426
2427
2428 (defun sgml-show-structure ()
2429   "Show the document structure in a separate buffer."
2430   (interactive)
2431   (let ((source (current-buffer))
2432         (result (get-buffer-create "*Document structure*")))
2433     (set-buffer result)
2434     (occur-mode)
2435     (erase-buffer)
2436     (let ((structure
2437            (save-excursion
2438              (set-buffer source)
2439              (sgml-structure-elements (sgml-top-element)))))
2440       (sgml-show-structure-insert structure))
2441     (goto-char (point-min))
2442     (display-buffer result)))
2443
2444
2445 (defun sgml-show-structure-insert (structure)
2446   (loop for (gi level marker title) in structure do
2447        (let ((start (point)))
2448          (insert (make-string (* 2 level) ? ))
2449          (sgml-insert `(face match mouse-face highlight) gi)
2450          (sgml-insert `(mouse-face highlight) " %s" title)
2451          (insert "\n")
2452          (add-text-properties
2453           start (point)
2454           `(occur-target ,marker help-echo "mouse-2: go to this occurrence")))))
2455
2456
2457 (defun sgml-show-struct-element-p (element)
2458   (let ((configured (sgml-element-appdata element 'structure)))
2459     (unless (eql configured 'ignore)
2460       (or configured
2461           (and (not (sgml-element-data-p element))
2462                (not (sgml-element-empty element)))))))
2463
2464
2465 (defun sgml-structure-elements (element)
2466   (when (sgml-show-struct-element-p element)
2467     (let ((gi (sgml-element-gi element))
2468           (level (sgml-element-level element))
2469           (child1 (sgml-element-content element))
2470           (marker nil)
2471           (title ""))
2472       (goto-char (sgml-element-start element))
2473       (setq marker (copy-marker (point-marker)))
2474       (when (and child1
2475                  (not (sgml-show-struct-element-p child1))
2476                  (sgml-element-data-p child1))
2477         (let ((start-epos (sgml-element-stag-epos child1))
2478               (end-epos (sgml-element-etag-epos child1)))
2479           (when (and (sgml-bpos-p start-epos)
2480                      (sgml-bpos-p end-epos))
2481             (goto-char start-epos)
2482             (forward-char (sgml-element-stag-len child1))
2483             (when (looking-at "\\s-*$")
2484               (forward-line 1))
2485             (when (< (point) end-epos)
2486               (setq title
2487                     (buffer-substring (point)
2488                                       ;; XEmacs: point-at-eol for < 21.4.20
2489                                       (min (point-at-eol)
2490                                            end-epos)))))))
2491       (cons (list (sgml-general-insert-case gi)
2492                   level marker title)
2493             (loop for child = child1 then (sgml-element-next child)
2494                while child
2495                nconc (sgml-structure-elements child))))))
2496
2497 \f
2498 ;;; psgml-edit.el ends here