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