Mercurial > hg > xemacs-beta
comparison lisp/psgml/psgml-edit.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; psgml-edit.el --- Editing commands for SGML-mode with parsing support | |
| 2 ;; $Id: psgml-edit.el,v 1.1.1.1 1996/12/18 03:35:19 steve Exp $ | |
| 3 | |
| 4 ;; Copyright (C) 1994, 1995, 1996 Lennart Staflin | |
| 5 | |
| 6 ;; Author: Lennart Staflin <lenst@lysator.liu.se> | |
| 7 | |
| 8 ;; This program is free software; you can redistribute it and/or | |
| 9 ;; modify it under the terms of the GNU General Public License | |
| 10 ;; as published by the Free Software Foundation; either version 2 | |
| 11 ;; of the License, or (at your option) any later version. | |
| 12 ;; | |
| 13 ;; This program is distributed in the hope that it will be useful, | |
| 14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 16 ;; GNU General Public License for more details. | |
| 17 ;; | |
| 18 ;; You should have received a copy of the GNU General Public License | |
| 19 ;; along with this program; if not, write to the Free Software | |
| 20 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 21 | |
| 22 | |
| 23 ;;;; Commentary: | |
| 24 | |
| 25 ;; Part of major mode for editing the SGML document-markup language. | |
| 26 | |
| 27 | |
| 28 ;;;; Code: | |
| 29 | |
| 30 (provide 'psgml-edit) | |
| 31 (require 'psgml) | |
| 32 (require 'psgml-parse) | |
| 33 | |
| 34 | |
| 35 ;;;; Variables | |
| 36 | |
| 37 (defvar sgml-split-level nil | |
| 38 "Used by sgml-split-element") | |
| 39 | |
| 40 | |
| 41 ;;;; SGML mode: structure editing | |
| 42 | |
| 43 (defun sgml-last-element () | |
| 44 "Return the element where last command left point. | |
| 45 This either uses the save value in `sgml-last-element' or parses the buffer | |
| 46 to find current open element." | |
| 47 (setq sgml-markup-type nil) | |
| 48 (if (and (memq last-command sgml-users-of-last-element) | |
| 49 sgml-last-element) ; Don't return nil | |
| 50 sgml-last-element | |
| 51 (setq sgml-last-element (sgml-find-context-of (point)))) ) | |
| 52 | |
| 53 (defun sgml-set-last-element (&optional el) | |
| 54 (if el (setq sgml-last-element el)) | |
| 55 (sgml-show-context sgml-last-element)) | |
| 56 | |
| 57 (defun sgml-beginning-of-element () | |
| 58 "Move to after the start-tag of the current element. | |
| 59 If the start-tag is implied, move to the start of the element." | |
| 60 (interactive) | |
| 61 (goto-char (sgml-element-stag-end (sgml-last-element))) | |
| 62 (sgml-set-last-element (if (sgml-element-empty sgml-last-element) | |
| 63 (sgml-element-parent sgml-last-element)))) | |
| 64 | |
| 65 (defun sgml-end-of-element () | |
| 66 "Move to before the end-tag of the current element." | |
| 67 (interactive) | |
| 68 (goto-char (sgml-element-etag-start (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-backward-up-element () | |
| 73 "Move backward out of this element level. | |
| 74 That is move to before the start-tag or where a start-tag is implied." | |
| 75 (interactive) | |
| 76 (goto-char (sgml-element-start (sgml-last-element))) | |
| 77 (sgml-set-last-element (sgml-element-parent sgml-last-element))) | |
| 78 | |
| 79 (defun sgml-up-element () | |
| 80 "Move forward out of this element level. | |
| 81 That is move to after the end-tag or where an end-tag is implied." | |
| 82 (interactive) | |
| 83 (goto-char (sgml-element-end (sgml-last-element))) | |
| 84 (sgml-set-last-element (sgml-element-parent sgml-last-element))) | |
| 85 | |
| 86 (defun sgml-forward-element () | |
| 87 "Move forward over next element." | |
| 88 (interactive) | |
| 89 (let ((next | |
| 90 (sgml-find-element-after (point) (sgml-last-element)))) | |
| 91 (goto-char (sgml-element-end next)) | |
| 92 (sgml-set-last-element (sgml-element-parent next)))) | |
| 93 | |
| 94 (defun sgml-backward-element () | |
| 95 "Move backward over previous element at this level. | |
| 96 With implied tags this is ambigous." | |
| 97 (interactive) | |
| 98 (let ((prev ; previous element | |
| 99 (sgml-find-previous-element (point) (sgml-last-element)))) | |
| 100 (goto-char (sgml-element-start prev)) | |
| 101 (sgml-set-last-element (sgml-element-parent prev)))) | |
| 102 | |
| 103 (defun sgml-down-element () | |
| 104 "Move forward and down one level in the element structure." | |
| 105 (interactive) | |
| 106 (let ((to | |
| 107 (sgml-find-element-after (point) (sgml-last-element)))) | |
| 108 (goto-char (sgml-element-stag-end to)) | |
| 109 (sgml-set-last-element (if (sgml-element-empty to) | |
| 110 (sgml-element-parent to) | |
| 111 to)))) | |
| 112 | |
| 113 | |
| 114 (defun sgml-kill-element () | |
| 115 "Kill the element following the cursor." | |
| 116 (interactive "*") | |
| 117 (sgml-parse-to-here) | |
| 118 (when sgml-markup-type | |
| 119 (error "Point is inside markup")) | |
| 120 (kill-region (point) | |
| 121 (sgml-element-end (sgml-find-element-after (point))))) | |
| 122 | |
| 123 (defun sgml-transpose-element () | |
| 124 "Interchange element before point with element after point, leave point after." | |
| 125 (interactive "*") | |
| 126 (let ((pre (sgml-find-previous-element (point))) | |
| 127 (next (sgml-find-element-after (point))) | |
| 128 s1 s2 m2) | |
| 129 (goto-char (sgml-element-start next)) | |
| 130 (setq m2 (point-marker)) | |
| 131 (setq s2 (buffer-substring (point) | |
| 132 (sgml-element-end next))) | |
| 133 (delete-region (point) (sgml-element-end next)) | |
| 134 (goto-char (sgml-element-start pre)) | |
| 135 (setq s1 (buffer-substring (point) (sgml-element-end pre))) | |
| 136 (delete-region (point) (sgml-element-end pre)) | |
| 137 (insert-before-markers s2) | |
| 138 (goto-char m2) | |
| 139 (insert s1) | |
| 140 (sgml-message ""))) | |
| 141 | |
| 142 (defun sgml-mark-element () | |
| 143 "Set mark after next element." | |
| 144 (interactive) | |
| 145 (push-mark (sgml-element-end (sgml-find-element-after (point))) nil t)) | |
| 146 | |
| 147 (defun sgml-mark-current-element () | |
| 148 "Set mark at end of current element, and leave point before current element." | |
| 149 (interactive) | |
| 150 (let ((el (sgml-find-element-of (point)))) | |
| 151 (goto-char (sgml-element-start el)) | |
| 152 (push-mark (sgml-element-end el) nil t))) | |
| 153 | |
| 154 | |
| 155 (defun sgml-change-element-name (gi) | |
| 156 "Replace the name of the current element with a new name. | |
| 157 Eventual attributes of the current element will be translated if | |
| 158 possible." | |
| 159 (interactive | |
| 160 (list (let ((el (sgml-find-element-of (point)))) | |
| 161 (goto-char (sgml-element-start el)) | |
| 162 (sgml-read-element-name | |
| 163 (format "Change %s to: " (sgml-element-name el)))))) | |
| 164 (when (or (null gi) (equal gi "")) | |
| 165 (error "Illegal name")) | |
| 166 (let* ((element (sgml-find-element-of (point))) | |
| 167 (attspec (sgml-element-attribute-specification-list element)) | |
| 168 (oldattlist (sgml-element-attlist element))) | |
| 169 (unless (sgml-element-empty element) | |
| 170 (goto-char (sgml-element-end element)) | |
| 171 (delete-char (- (sgml-element-etag-len element))) | |
| 172 (insert (sgml-end-tag-of gi))) | |
| 173 (goto-char (sgml-element-start element)) | |
| 174 (delete-char (sgml-element-stag-len element)) | |
| 175 (insert (sgml-start-tag-of gi)) | |
| 176 (forward-char -1) | |
| 177 (let* ((newel (sgml-find-element-of (point))) | |
| 178 (newattlist (sgml-element-attlist newel)) | |
| 179 (newasl (sgml-translate-attribute-specification-list | |
| 180 attspec oldattlist newattlist))) | |
| 181 (sgml-insert-attributes newasl newattlist)))) | |
| 182 | |
| 183 (defun sgml-translate-attribute-specification-list (values from to) | |
| 184 "Translate attribute specification from one element type to another. | |
| 185 Input attribute values in VALUES using attlist FROM is translated into | |
| 186 a list using attlist TO." | |
| 187 (let ((new-values nil) | |
| 188 (sgml-show-warnings t) | |
| 189 tem) | |
| 190 (loop for attspec in values | |
| 191 as from-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) from) | |
| 192 as to-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) to) | |
| 193 do | |
| 194 (cond | |
| 195 ;; Special case ID attribute | |
| 196 ((and (eq 'id (sgml-attdecl-declared-value from-decl)) | |
| 197 (setq tem (sgml-attribute-with-declared-value to 'id))) | |
| 198 (push | |
| 199 (sgml-make-attspec (sgml-attdecl-name tem) | |
| 200 (sgml-attspec-attval attspec)) | |
| 201 new-values)) | |
| 202 ;; Use attribute with same name if compatible type | |
| 203 ((equal (sgml-attdecl-declared-value from-decl) | |
| 204 (sgml-attdecl-declared-value to-decl)) | |
| 205 (push attspec new-values)) | |
| 206 (to-decl | |
| 207 (sgml-log-warning | |
| 208 "Attribute %s has new declared-value" | |
| 209 (sgml-attspec-name attspec)) | |
| 210 (push attspec new-values)) | |
| 211 (t | |
| 212 (sgml-log-warning "Can't translate attribute %s = %s" | |
| 213 (sgml-attspec-name attspec) | |
| 214 (sgml-attspec-attval attspec))))) | |
| 215 new-values)) | |
| 216 | |
| 217 (defun sgml-untag-element () | |
| 218 "Remove tags from current element." | |
| 219 (interactive "*") | |
| 220 (let ((el (sgml-find-element-of (point)))) | |
| 221 (when (or (sgml-strict-epos-p (sgml-element-stag-epos el)) | |
| 222 (sgml-strict-epos-p (sgml-element-etag-epos el))) | |
| 223 (error "Current element has some tag inside an entity reference")) | |
| 224 (goto-char (sgml-element-etag-start el)) | |
| 225 (delete-char (sgml-element-etag-len el)) | |
| 226 (goto-char (sgml-element-start el)) | |
| 227 (delete-char (sgml-element-stag-len el)))) | |
| 228 | |
| 229 (defun sgml-kill-markup () | |
| 230 "Kill next tag, markup declaration or process instruction." | |
| 231 (interactive "*") | |
| 232 (let ((start (point))) | |
| 233 (sgml-with-parser-syntax | |
| 234 (sgml-parse-s) | |
| 235 (setq sgml-markup-start (point)) | |
| 236 (cond ((sgml-parse-markup-declaration 'ignore)) | |
| 237 ((sgml-parse-processing-instruction)) | |
| 238 ((sgml-skip-tag))) | |
| 239 (kill-region start (point))))) | |
| 240 | |
| 241 | |
| 242 ;;;; SGML mode: folding | |
| 243 | |
| 244 (defun sgml-fold-region (beg end &optional unhide) | |
| 245 "Hide (or if prefixarg unhide) region. | |
| 246 If called from a program first two arguments are start and end of | |
| 247 region. And optional third argument true unhides." | |
| 248 (interactive "r\nP") | |
| 249 (let ((mp (buffer-modified-p)) | |
| 250 (inhibit-read-only t) ; | |
| 251 (buffer-read-only nil) ; should not need this, but | |
| 252 ; perhaps some old version of | |
| 253 ; emacs does not understand | |
| 254 ; inhibit-read-only | |
| 255 (before-change-function nil) | |
| 256 (after-change-function nil)) | |
| 257 (setq selective-display t) | |
| 258 (unwind-protect | |
| 259 (subst-char-in-region beg end | |
| 260 (if unhide ?\r ?\n) | |
| 261 (if unhide ?\n ?\r) | |
| 262 'noundo) | |
| 263 (when sgml-buggy-subst-char-in-region | |
| 264 (set-buffer-modified-p mp))))) | |
| 265 | |
| 266 (defun sgml-fold-element () | |
| 267 "Fold the lines comprising the current element, leaving the first line visible. | |
| 268 This uses the selective display feature." | |
| 269 (interactive) | |
| 270 (sgml-parse-to-here) | |
| 271 (cond ((and (eq sgml-current-tree sgml-top-tree) ; outside document element | |
| 272 sgml-markup-type) | |
| 273 (sgml-fold-region sgml-markup-start | |
| 274 (save-excursion | |
| 275 (sgml-parse-to (point)) | |
| 276 (point)))) | |
| 277 ((and (eq sgml-current-tree sgml-top-tree) ; outside document element | |
| 278 (looking-at " *<!")) | |
| 279 (sgml-fold-region (point) | |
| 280 (save-excursion | |
| 281 (skip-chars-forward " \t") | |
| 282 (sgml-parse-to (1+ (point))) | |
| 283 (point)))) | |
| 284 | |
| 285 (t | |
| 286 (let ((el (sgml-find-element-of (point)))) | |
| 287 (when (eq el sgml-top-tree) | |
| 288 (error "No element here")) | |
| 289 (save-excursion | |
| 290 (goto-char (sgml-element-end el)) | |
| 291 (when (zerop (sgml-element-etag-len el)) | |
| 292 (skip-chars-backward " \t\n")) | |
| 293 (sgml-fold-region (sgml-element-start el) | |
| 294 (point))))))) | |
| 295 | |
| 296 (defun sgml-fold-subelement () | |
| 297 "Fold all elements current elements content, leaving the first lines visible. | |
| 298 This uses the selective display feature." | |
| 299 (interactive) | |
| 300 (let* ((el (sgml-find-element-of (point))) | |
| 301 (start (sgml-element-start el)) | |
| 302 (end (sgml-element-end el)) | |
| 303 (c (sgml-element-content el))) | |
| 304 (while c | |
| 305 (sgml-fold-region (sgml-element-start c) | |
| 306 (sgml-element-end c)) | |
| 307 (setq c (sgml-element-next c))))) | |
| 308 | |
| 309 (defun sgml-unfold-line () | |
| 310 "Show hidden lines in current line." | |
| 311 (interactive) | |
| 312 (let ((op (point))) | |
| 313 (beginning-of-line) | |
| 314 (push-mark) | |
| 315 (end-of-line) | |
| 316 (exchange-point-and-mark) | |
| 317 (sgml-fold-region (point) (mark) 'unhide) | |
| 318 (goto-char op))) | |
| 319 | |
| 320 (defun sgml-unfold-element () | |
| 321 "Show all hidden lines in current element." | |
| 322 (interactive) | |
| 323 (let* ((element (sgml-find-element-of (point)))) | |
| 324 (sgml-fold-region (sgml-element-start element) | |
| 325 (sgml-element-end element) | |
| 326 'unfold))) | |
| 327 | |
| 328 (defun sgml-expand-element () | |
| 329 "As sgml-fold-subelement, but unfold first." | |
| 330 (interactive) | |
| 331 (sgml-unfold-element) | |
| 332 (sgml-fold-subelement)) | |
| 333 | |
| 334 (defun sgml-unfold-all () | |
| 335 "Show all hidden lines in buffer." | |
| 336 (interactive) | |
| 337 (sgml-fold-region (point-min) | |
| 338 (point-max) | |
| 339 'unfold)) | |
| 340 | |
| 341 ;;;; SGML mode: indentation and movement | |
| 342 | |
| 343 (defun sgml-indent-line (&optional col element) | |
| 344 "Indent line, calling parser to determine level unless COL or ELEMENT | |
| 345 is given. If COL is given it should be the column to indent to. If | |
| 346 ELEMENT is given it should be a parse tree node, from which the level | |
| 347 is determined." | |
| 348 (when sgml-indent-step | |
| 349 (let ((here (point-marker))) | |
| 350 (back-to-indentation) | |
| 351 (unless (or col element) | |
| 352 ;; Determine element | |
| 353 (setq element | |
| 354 (let ((sgml-throw-on-error 'parse-error)) | |
| 355 (catch sgml-throw-on-error | |
| 356 (if (eobp) | |
| 357 (sgml-find-context-of (point)) | |
| 358 (sgml-find-element-of (point))))))) | |
| 359 (when (eq element sgml-top-tree) ; not in a element at all | |
| 360 (setq element nil) ; forget element | |
| 361 (goto-char here)) ; insert normal tab insted) | |
| 362 (when element | |
| 363 (sgml-with-parser-syntax | |
| 364 (let ((stag (sgml-is-start-tag)) | |
| 365 (etag (sgml-is-end-tag))) | |
| 366 (when (and | |
| 367 (not (member* (sgml-element-gi | |
| 368 (if (or stag etag) | |
| 369 (sgml-element-parent element) | |
| 370 element)) | |
| 371 sgml-inhibit-indent-tags | |
| 372 :test #'equalp)) | |
| 373 (or sgml-indent-data | |
| 374 (not (sgml-element-data-p | |
| 375 (if stag | |
| 376 (sgml-element-parent element) | |
| 377 element))))) | |
| 378 (setq col | |
| 379 (* sgml-indent-step | |
| 380 (+ (if (or stag etag) -1 0) | |
| 381 (sgml-element-level element)))))))) | |
| 382 (when (and col (/= col (current-column))) | |
| 383 (beginning-of-line 1) | |
| 384 (delete-horizontal-space) | |
| 385 (indent-to col)) | |
| 386 (when (< (point) here) | |
| 387 (goto-char here)) | |
| 388 col))) | |
| 389 | |
| 390 (defun sgml-next-data-field () | |
| 391 "Move forward to next point where data is allowed." | |
| 392 (interactive) | |
| 393 (when (eobp) | |
| 394 (error "End of buffer")) | |
| 395 (let ((sgml-throw-on-warning 'next-data) | |
| 396 (avoid-el (sgml-last-element))) | |
| 397 ;; Avoid stopping in current element, unless point is in the start | |
| 398 ;; tag of the element | |
| 399 (when (< (point) (sgml-element-stag-end avoid-el)) | |
| 400 (setq avoid-el nil)) | |
| 401 (catch sgml-throw-on-warning | |
| 402 (while (progn | |
| 403 (sgml-parse-to (1+ (point))) | |
| 404 (setq sgml-last-element | |
| 405 (if (not (eq ?< (following-char))) | |
| 406 (sgml-find-element-of (point)) | |
| 407 sgml-current-tree)) | |
| 408 (or (eq sgml-last-element avoid-el) | |
| 409 (not (sgml-element-data-p sgml-last-element))))) | |
| 410 (sgml-set-last-element)))) | |
| 411 | |
| 412 (defun sgml-next-trouble-spot () | |
| 413 "Move forward to next point where something is amiss with the structure." | |
| 414 (interactive) | |
| 415 (push-mark) | |
| 416 (sgml-note-change-at (point)) ; Prune the parse tree | |
| 417 (sgml-parse-to (point)) | |
| 418 (let ((sgml-last-trouble-spot (point)) | |
| 419 (sgml-throw-on-warning 'trouble)) | |
| 420 (or (catch sgml-throw-on-warning | |
| 421 (sgml-parse-until-end-of nil t)) | |
| 422 (message "Ok")))) | |
| 423 | |
| 424 | |
| 425 | |
| 426 ;;;; SGML mode: information display | |
| 427 | |
| 428 (defun sgml-list-valid-tags () | |
| 429 "Display a list of the contextually valid tags." | |
| 430 (interactive) | |
| 431 (sgml-parse-to-here) | |
| 432 (let ((model (sgml-element-model sgml-current-tree))) | |
| 433 (with-output-to-temp-buffer "*Tags*" | |
| 434 (princ (format "Current element: %s %s\n" | |
| 435 (sgml-element-name sgml-current-tree) | |
| 436 (if (sgml-eltype-defined | |
| 437 (sgml-element-eltype sgml-current-tree)) | |
| 438 "" | |
| 439 "[UNDEFINED]"))) | |
| 440 (princ (format "Element content: %s %s\n" | |
| 441 (cond ((or (sgml-current-mixed-p) (eq model sgml-any)) | |
| 442 "mixed") | |
| 443 ((sgml-model-group-p model) | |
| 444 "element") | |
| 445 (t | |
| 446 model)) | |
| 447 (if (eq model sgml-any) | |
| 448 "[ANY]" ""))) | |
| 449 | |
| 450 (cond ((sgml-final-p sgml-current-state) | |
| 451 (princ "Valid end-tags : ") | |
| 452 (loop for e in (sgml-current-list-of-endable-eltypes) | |
| 453 do (princ (sgml-end-tag-of e)) (princ " ")) | |
| 454 (terpri)) | |
| 455 (t | |
| 456 (princ "Current element can not end here\n"))) | |
| 457 ;;; (let ((s (sgml-tree-shortmap sgml-current-tree))) | |
| 458 ;;; (when s | |
| 459 ;;; (princ (format "Current shortref map: %s\n" s)))) | |
| 460 (princ "Valid start-tags\n") | |
| 461 (sgml-print-valid-tags "In current element:" | |
| 462 sgml-current-tree sgml-current-state)))) | |
| 463 | |
| 464 (defun sgml-print-valid-tags (prompt tree state &optional exclude omitted-stag) | |
| 465 (if (not (sgml-model-group-p state)) | |
| 466 (princ (format "%s (in %s)\n" prompt state)) | |
| 467 (let* ((req (sgml-required-tokens state)) | |
| 468 (elems (nconc req | |
| 469 (delq sgml-pcdata-token | |
| 470 (sgml-optional-tokens state)))) | |
| 471 (in (sgml-tree-includes tree)) | |
| 472 (ex (append exclude (sgml-tree-excludes tree)))) | |
| 473 ;; Modify for exceptions | |
| 474 (while in | |
| 475 (unless (memq (car in) elems) | |
| 476 (setq elems (nconc elems (list (car in))))) | |
| 477 (setq in (cdr in))) | |
| 478 (while ex | |
| 479 (setq elems (delq (car ex) elems)) | |
| 480 (setq ex (cdr ex))) | |
| 481 ;; | |
| 482 (setq elems (sort elems (function string-lessp))) | |
| 483 (sgml-print-list-of-tags prompt elems) | |
| 484 ;; Check for omissable start-tags | |
| 485 (when (and req (null (cdr req))) | |
| 486 ;; *** Assumes tokens are eltypes | |
| 487 (let ((el (sgml-fake-open-element tree (car req)))) | |
| 488 (when (sgml-element-stag-optional el) | |
| 489 (sgml-print-valid-tags | |
| 490 (format "If omitting %s:" (sgml-start-tag-of el)) | |
| 491 el | |
| 492 (sgml-element-model el) | |
| 493 (append exclude elems) | |
| 494 'omitted-stag)))) | |
| 495 ;; Check for omissable end-tag | |
| 496 (when (and (not omitted-stag) | |
| 497 (sgml-final-p state) | |
| 498 (sgml-element-etag-optional tree)) | |
| 499 (sgml-print-valid-tags | |
| 500 (format "If omitting %s:" (sgml-end-tag-of tree)) | |
| 501 (sgml-element-parent tree) | |
| 502 (sgml-element-pstate tree) | |
| 503 (append exclude elems)))))) | |
| 504 | |
| 505 (defun sgml-print-list-of-tags (prompt list) | |
| 506 (when list | |
| 507 (princ prompt) | |
| 508 (let ((col (length prompt)) | |
| 509 (w (1- (frame-width)))) | |
| 510 (loop for e in list | |
| 511 as str = (sgml-start-tag-of e) | |
| 512 do | |
| 513 (setq col (+ col (length str) 2)) | |
| 514 (cond ((>= col w) | |
| 515 (setq col (+ (length str) 2)) | |
| 516 (terpri))) | |
| 517 (princ " ") | |
| 518 (princ str)) | |
| 519 (terpri)))) | |
| 520 | |
| 521 (defun sgml-show-context (&optional element) | |
| 522 "Display where the cursor is in the element hierarchy." | |
| 523 (interactive) | |
| 524 (let* ((el (or element (sgml-last-element))) | |
| 525 (model (sgml-element-model el))) | |
| 526 (sgml-message "%s %s" | |
| 527 (cond | |
| 528 ((and (null element) ; Don't trust sgml-markup-type if | |
| 529 ; explicit element is given as argument | |
| 530 sgml-markup-type)) | |
| 531 ((sgml-element-mixed el) | |
| 532 "#PCDATA") | |
| 533 ((not (sgml-model-group-p model)) | |
| 534 model) | |
| 535 (t "")) | |
| 536 (if (eq el sgml-top-tree) | |
| 537 "in empty context" | |
| 538 (sgml-element-context-string el))))) | |
| 539 | |
| 540 (defun sgml-what-element () | |
| 541 "Display what element is under the cursor." | |
| 542 (interactive) | |
| 543 (let ((el (sgml-find-element-of (point)))) | |
| 544 (assert (not (null el))) | |
| 545 (message "%s %s" | |
| 546 (cond ((eq el sgml-top-tree) | |
| 547 "outside document element") | |
| 548 ((< (point) (sgml-element-stag-end el)) | |
| 549 "start-tag") | |
| 550 ((>= (point) (sgml-element-etag-start el)) | |
| 551 "end-tag") | |
| 552 (t | |
| 553 "content")) | |
| 554 (sgml-element-context-string el)))) | |
| 555 | |
| 556 ;;;; SGML mode: keyboard inserting | |
| 557 | |
| 558 (defun sgml-insert-tag (tag &optional silent no-nl-after) | |
| 559 "Insert a tag, reading tag name in minibuffer with completion. | |
| 560 If the variable sgml-balanced-tag-edit is t, also inserts the | |
| 561 corresponding end tag. If sgml-leave-point-after-insert is t, the point | |
| 562 is left after the inserted tag(s), unless the element has som required | |
| 563 content. If sgml-leave-point-after-insert is nil the point is left | |
| 564 after the first tag inserted." | |
| 565 (interactive | |
| 566 (list | |
| 567 (completing-read "Tag: " (sgml-completion-table) nil t "<" ))) | |
| 568 (sgml-find-context-of (point)) | |
| 569 (assert (null sgml-markup-type)) | |
| 570 ;; Fix white-space before tag | |
| 571 (unless (sgml-element-data-p (sgml-parse-to-here)) | |
| 572 (skip-chars-backward " \t") | |
| 573 (cond ((bolp) | |
| 574 (if (looking-at "^\\s-*$") | |
| 575 (fixup-whitespace))) | |
| 576 (t | |
| 577 (insert "\n")))) | |
| 578 (insert tag) | |
| 579 (sgml-indent-line) | |
| 580 (unless no-nl-after | |
| 581 (save-excursion | |
| 582 (unless (sgml-element-data-p (sgml-parse-to-here)) | |
| 583 (unless (eolp) | |
| 584 (save-excursion (insert "\n")))))) | |
| 585 (or silent (sgml-show-context))) | |
| 586 | |
| 587 (defvar sgml-new-attribute-list-function | |
| 588 (function sgml-default-asl)) | |
| 589 | |
| 590 (defun sgml-insert-element (name &optional after silent) | |
| 591 "Reads element name from minibuffer and inserts start and end tags." | |
| 592 (interactive (list (sgml-read-element-name "Element: ") | |
| 593 sgml-leave-point-after-insert)) | |
| 594 (let (newpos ; position to leave cursor at | |
| 595 element ; inserted element | |
| 596 (sgml-show-warnings nil)) | |
| 597 (when (and name (not (equal name ""))) | |
| 598 (sgml-insert-tag (sgml-start-tag-of name) 'silent) | |
| 599 (forward-char -1) | |
| 600 (setq element (sgml-find-element-of (point))) | |
| 601 (sgml-insert-attributes (funcall sgml-new-attribute-list-function | |
| 602 element) | |
| 603 (sgml-element-attlist element)) | |
| 604 (forward-char 1) | |
| 605 (when (not (sgml-element-empty element)) | |
| 606 (when (and sgml-auto-insert-required-elements | |
| 607 (sgml-model-group-p sgml-current-state)) | |
| 608 (let (tem) | |
| 609 (while (and (setq tem (sgml-required-tokens sgml-current-state)) | |
| 610 (null (cdr tem))) | |
| 611 (setq tem (sgml-insert-element (car tem) t t)) | |
| 612 (setq newpos (or newpos tem)) | |
| 613 (sgml-parse-to-here)) | |
| 614 (when tem ; more than one req elem | |
| 615 (insert "\n") | |
| 616 (when sgml-insert-missing-element-comment | |
| 617 (insert (format "<!-- one of %s -->" tem)) | |
| 618 (sgml-indent-line nil element))))) | |
| 619 (setq newpos (or newpos (point))) | |
| 620 (when sgml-insert-end-tag-on-new-line | |
| 621 (insert "\n")) | |
| 622 (sgml-insert-tag (sgml-end-tag-of name) 'silent) | |
| 623 (unless after | |
| 624 (goto-char newpos)) | |
| 625 (unless silent (sgml-show-context))) | |
| 626 newpos))) | |
| 627 | |
| 628 (defun sgml-default-asl (element) | |
| 629 (loop for attdecl in (sgml-element-attlist element) | |
| 630 when (sgml-default-value-type-p (sgml-attdecl-default-value attdecl) | |
| 631 'required) | |
| 632 collect | |
| 633 (sgml-make-attspec | |
| 634 (sgml-attdecl-name attdecl) | |
| 635 (sgml-read-attribute-value attdecl nil)))) | |
| 636 | |
| 637 (defun sgml-tag-region (element start end) | |
| 638 "Reads element name from minibuffer and inserts start and end tags." | |
| 639 (interactive | |
| 640 (list | |
| 641 (save-excursion (goto-char (region-beginning)) | |
| 642 (sgml-read-element-name "Tag region with element: ")) | |
| 643 (region-beginning) | |
| 644 (region-end))) | |
| 645 (save-excursion | |
| 646 (when (and element (not (equal element ""))) | |
| 647 (goto-char end) | |
| 648 (insert (sgml-end-tag-of element)) | |
| 649 (goto-char start) | |
| 650 (sgml-insert-tag (sgml-start-tag-of element))))) | |
| 651 | |
| 652 (defun sgml-insert-attributes (avl attlist) | |
| 653 "Insert the attributes with values AVL and declarations ATTLIST. | |
| 654 AVL should be a assoc list mapping symbols to strings." | |
| 655 (let (name val dcl def tem) | |
| 656 (loop for attspec in attlist do | |
| 657 (setq name (sgml-attspec-name attspec) | |
| 658 val (cdr-safe (sgml-lookup-attspec name avl)) | |
| 659 dcl (sgml-attdecl-declared-value attspec) | |
| 660 def (sgml-attdecl-default-value attspec)) | |
| 661 (unless val ; no value given | |
| 662 ;; Supply the default value if a value is needed | |
| 663 (cond ((sgml-default-value-type-p 'required def) | |
| 664 (setq val "")) | |
| 665 ((and (not (or sgml-omittag sgml-shorttag)) | |
| 666 (consp def)) | |
| 667 (setq val (sgml-default-value-attval def))))) | |
| 668 (cond | |
| 669 ((null val)) ; Ignore | |
| 670 ;; Ignore attributes with default value | |
| 671 ((and (consp def) | |
| 672 (eq sgml-minimize-attributes 'max) | |
| 673 (or sgml-omittag sgml-shorttag) | |
| 674 (equal val (sgml-default-value-attval def)))) | |
| 675 ;; No attribute name for token groups | |
| 676 ((and sgml-minimize-attributes sgml-shorttag | |
| 677 (member (sgml-general-case val) | |
| 678 (sgml-declared-value-token-group dcl))) | |
| 679 (insert " " val)) | |
| 680 (t | |
| 681 (insert " " name "=" (sgml-quote-attribute-value val))))) | |
| 682 (when auto-fill-function | |
| 683 (funcall auto-fill-function)))) | |
| 684 | |
| 685 | |
| 686 (defun sgml-quote-attribute-value (value) | |
| 687 "Add quotes to the string VALUE unless minimization is on." | |
| 688 (let ((quote "")) | |
| 689 (cond ((and (not sgml-always-quote-attributes) | |
| 690 sgml-shorttag | |
| 691 (string-match "\\`[.A-Za-z0-9---]+\\'" value)) | |
| 692 ) ; no need to quote | |
| 693 ((not (string-match "\"" value)) ; can use "" quotes | |
| 694 (setq quote "\"")) | |
| 695 (t ; use '' quotes | |
| 696 (setq quote "'"))) | |
| 697 (concat quote value quote))) | |
| 698 | |
| 699 (defun sgml-completion-table (&optional avoid-tags-in-cdata) | |
| 700 (sgml-parse-to-here) | |
| 701 (when sgml-markup-type | |
| 702 (error "No tags allowed")) | |
| 703 (cond ((or (sgml-model-group-p sgml-current-state) | |
| 704 (eq sgml-current-state sgml-any)) | |
| 705 (append | |
| 706 (mapcar (function (lambda (x) (cons (sgml-end-tag-of x) x))) | |
| 707 (sgml-current-list-of-endable-eltypes)) | |
| 708 (mapcar (function (lambda (x) (cons (sgml-start-tag-of x) x))) | |
| 709 (sgml-current-list-of-valid-eltypes)))) | |
| 710 (t | |
| 711 (sgml-message "%s" sgml-current-state) | |
| 712 nil))) | |
| 713 | |
| 714 (defun sgml-insert-end-tag () | |
| 715 "Insert end-tag for the current open element." | |
| 716 (interactive "*") | |
| 717 (sgml-parse-to-here) | |
| 718 (cond | |
| 719 ((eq sgml-current-tree sgml-top-tree) | |
| 720 (sgml-error "No open element")) | |
| 721 ((not (sgml-final-p sgml-current-state)) | |
| 722 (sgml-error "Can`t end element here")) | |
| 723 (t | |
| 724 (when (and sgml-indent-step | |
| 725 (not (sgml-element-data-p sgml-current-tree))) | |
| 726 (delete-horizontal-space) | |
| 727 (unless (bolp) | |
| 728 (insert "\n"))) | |
| 729 (when (prog1 (bolp) | |
| 730 (insert (if (eq t (sgml-element-net-enabled sgml-current-tree)) | |
| 731 "/" | |
| 732 ;; wing change: If there is more than one endable | |
| 733 ;; tag, we probably want the outermost one rather | |
| 734 ;; than the innermost one. Thus, we end a </ul> | |
| 735 ;; even when a </li> is possible. | |
| 736 (sgml-end-tag-of | |
| 737 (car (last (sgml-current-list-of-endable-eltypes))))))) | |
| 738 (sgml-indent-line))))) | |
| 739 | |
| 740 (defun sgml-insert-start-tag (name asl attlist &optional net) | |
| 741 (insert "<" name) | |
| 742 (sgml-insert-attributes asl attlist) | |
| 743 (insert (if net "/" ">"))) | |
| 744 | |
| 745 (defun sgml-change-start-tag (element asl) | |
| 746 (let ((name (sgml-element-gi element)) | |
| 747 (attlist (sgml-element-attlist element))) | |
| 748 (assert (sgml-bpos-p (sgml-element-stag-epos element))) | |
| 749 (goto-char (sgml-element-start element)) | |
| 750 (delete-char (sgml-element-stag-len element)) | |
| 751 (sgml-insert-start-tag name asl attlist | |
| 752 (eq t (sgml-element-net-enabled element))))) | |
| 753 | |
| 754 (defun sgml-read-attribute-value (attdecl curvalue) | |
| 755 "Return the attribute value read from user. | |
| 756 ATTDECL is the attribute declaration for the attribute to read. | |
| 757 CURVALUE is nil or a string that will be used as default value." | |
| 758 (assert attdecl) | |
| 759 (let* ((name (sgml-attdecl-name attdecl)) | |
| 760 (dv (sgml-attdecl-declared-value attdecl)) | |
| 761 (tokens (sgml-declared-value-token-group dv)) | |
| 762 (notations (sgml-declared-value-notation dv)) | |
| 763 (type (cond (tokens "token") | |
| 764 (notations "notation") | |
| 765 (t (symbol-name dv)))) | |
| 766 (prompt | |
| 767 (format "Value for %s (%s%s): " | |
| 768 name type | |
| 769 (if curvalue | |
| 770 (format " Default: %s" curvalue) | |
| 771 ""))) | |
| 772 value) | |
| 773 (setq value | |
| 774 (if (or tokens notations) | |
| 775 (completing-read prompt | |
| 776 (mapcar 'list (or tokens notations)) | |
| 777 nil t) | |
| 778 (read-string prompt))) | |
| 779 (if (and curvalue (equal value "")) | |
| 780 curvalue value))) | |
| 781 | |
| 782 (defun sgml-non-fixed-attributes (attlist) | |
| 783 (loop for attdecl in attlist | |
| 784 unless (sgml-default-value-type-p 'fixed | |
| 785 (sgml-attdecl-default-value attdecl)) | |
| 786 collect attdecl)) | |
| 787 | |
| 788 (defun sgml-insert-attribute (name value) | |
| 789 "Read attribute name and value from minibuffer and insert attribute spec." | |
| 790 (interactive | |
| 791 (let* ((el (sgml-find-attribute-element)) | |
| 792 (name | |
| 793 (completing-read | |
| 794 "Attribute name: " | |
| 795 (mapcar (function (lambda (a) (list (sgml-attdecl-name a)))) | |
| 796 (sgml-non-fixed-attributes (sgml-element-attlist el))) | |
| 797 nil t))) | |
| 798 (list name | |
| 799 (sgml-read-attribute-value | |
| 800 (sgml-lookup-attdecl name (sgml-element-attlist el)) | |
| 801 (sgml-element-attval el name))))) | |
| 802 ;; Body | |
| 803 (assert (stringp name)) | |
| 804 (assert (or (null value) (stringp value))) | |
| 805 (let* ((el (sgml-find-attribute-element)) | |
| 806 (asl (cons (sgml-make-attspec name value) | |
| 807 (sgml-element-attribute-specification-list el))) | |
| 808 (in-tag (< (point) (sgml-element-stag-end el)))) | |
| 809 (sgml-change-start-tag el asl) | |
| 810 (when in-tag (forward-char -1)))) | |
| 811 | |
| 812 (defun sgml-split-element () | |
| 813 "Split the current element at point. | |
| 814 If repeated, the containing element will be split before the beginning | |
| 815 of then current element." | |
| 816 (interactive "*") | |
| 817 (setq sgml-split-level | |
| 818 (if (eq this-command last-command) | |
| 819 (1+ sgml-split-level) | |
| 820 0)) | |
| 821 (let ((u (sgml-find-context-of (point))) | |
| 822 (start (point-marker)) | |
| 823 before) | |
| 824 (loop repeat sgml-split-level do | |
| 825 (goto-char (sgml-element-start u)) | |
| 826 (setq u (sgml-element-parent u))) | |
| 827 ;; Verify that a new element can be started | |
| 828 (unless (and (sgml-element-pstate u) ; in case of top element | |
| 829 (sgml-get-move (sgml-element-pstate u) | |
| 830 (sgml-element-name u))) | |
| 831 | |
| 832 (sgml-error "The %s element can't be split" | |
| 833 (sgml-element-name u))) | |
| 834 ;; Do the split | |
| 835 (sgml-insert-end-tag) | |
| 836 (sgml-insert-tag (sgml-start-tag-of u) 'silent) | |
| 837 (skip-chars-forward " \t\n") | |
| 838 (sgml-indent-line) | |
| 839 (when (> sgml-split-level 0) | |
| 840 (goto-char start)) | |
| 841 (or (eq sgml-top-tree | |
| 842 (setq u (sgml-element-parent u))) | |
| 843 (sgml-message | |
| 844 "Repeat the command to split the containing %s element" | |
| 845 (sgml-element-name u))))) | |
| 846 | |
| 847 ;;; David Megginson's custom menus for keys | |
| 848 | |
| 849 (defun sgml-custom-dtd (doctype) | |
| 850 "Insert a DTD declaration from the sgml-custom-dtd alist." | |
| 851 (interactive | |
| 852 (list (completing-read "Insert DTD: " sgml-custom-dtd nil t))) | |
| 853 (let ((entry (assoc doctype sgml-custom-dtd))) | |
| 854 (sgml-doctype-insert (second entry) (cddr entry)))) | |
| 855 | |
| 856 (defun sgml-custom-markup (markup) | |
| 857 "Insert markup from the sgml-custom-markup alist." | |
| 858 (interactive | |
| 859 (list (completing-read "Insert Markup: " sgml-custom-markup nil t))) | |
| 860 (sgml-insert-markup (cadr (assoc markup sgml-custom-markup)))) | |
| 861 | |
| 862 | |
| 863 ;;;; SGML mode: Menu inserting | |
| 864 | |
| 865 (defun sgml-tags-menu (event) | |
| 866 "Pop up a menu with valid tags and insert the choosen tag. | |
| 867 If the variable sgml-balanced-tag-edit is t, also inserts the | |
| 868 corresponding end tag. If sgml-leave-point-after-insert is t, the point | |
| 869 is left after the inserted tag(s), unless the element has som required | |
| 870 content. If sgml-leave-point-after-insert is nil the point is left | |
| 871 after the first tag inserted." | |
| 872 (interactive "*e") | |
| 873 (let ((end (sgml-mouse-region))) | |
| 874 (sgml-parse-to-here) | |
| 875 (cond | |
| 876 ((eq sgml-markup-type 'start-tag) | |
| 877 (sgml-attrib-menu event)) | |
| 878 (t | |
| 879 (let ((what | |
| 880 (sgml-menu-ask event (if (or end sgml-balanced-tag-edit) | |
| 881 'element 'tags)))) | |
| 882 (cond | |
| 883 ((null what)) | |
| 884 (end | |
| 885 (sgml-tag-region what (point) end)) | |
| 886 (sgml-balanced-tag-edit | |
| 887 (sgml-insert-element what)) | |
| 888 (t | |
| 889 (sgml-insert-tag what)))))))) | |
| 890 | |
| 891 (defun sgml-element-menu (event) | |
| 892 "Pop up a menu with valid elements and insert choice. | |
| 893 If sgml-leave-point-after-insert is nil the point is left after the first | |
| 894 tag inserted." | |
| 895 (interactive "*e") | |
| 896 (let ((what (sgml-menu-ask event 'element))) | |
| 897 (and what (sgml-insert-element what)))) | |
| 898 | |
| 899 (defun sgml-start-tag-menu (event) | |
| 900 "Pop up a menu with valid start-tags and insert choice." | |
| 901 (interactive "*e") | |
| 902 (let ((what (sgml-menu-ask event 'start-tag))) | |
| 903 (and what (sgml-insert-tag what)))) | |
| 904 | |
| 905 (defun sgml-end-tag-menu (event) | |
| 906 "Pop up a menu with valid end-tags and insert choice." | |
| 907 (interactive "*e") | |
| 908 (let ((what (sgml-menu-ask event 'end-tag))) | |
| 909 (and what (sgml-insert-tag what)))) | |
| 910 | |
| 911 (defun sgml-tag-region-menu (event) | |
| 912 "Pop up a menu with valid elements and tag current region with the choice." | |
| 913 (interactive "*e") | |
| 914 (let ((what (sgml-menu-ask event 'element))) | |
| 915 (and what (sgml-tag-region what | |
| 916 (region-beginning) | |
| 917 (region-end))))) | |
| 918 | |
| 919 (defun sgml-menu-ask (event type) | |
| 920 (sgml-parse-to-here) | |
| 921 (let (tab | |
| 922 (title (capitalize (symbol-name type)))) | |
| 923 (cond | |
| 924 (sgml-markup-type) | |
| 925 ((eq type 'element) | |
| 926 (setq tab | |
| 927 (mapcar (function symbol-name) | |
| 928 (sgml-current-list-of-valid-eltypes)))) | |
| 929 (t | |
| 930 (unless (eq type 'start-tag) | |
| 931 (setq tab | |
| 932 (mapcar (function sgml-end-tag-of) | |
| 933 (sgml-current-list-of-endable-eltypes)))) | |
| 934 (unless (eq type 'end-tag) | |
| 935 (setq tab | |
| 936 (nconc tab | |
| 937 (mapcar (function sgml-start-tag-of) | |
| 938 (sgml-current-list-of-valid-eltypes))))))) | |
| 939 (or tab | |
| 940 (error "No valid %s at this point" type)) | |
| 941 (or | |
| 942 (sgml-popup-menu event | |
| 943 title | |
| 944 (mapcar (function (lambda (x) (cons x x))) | |
| 945 tab)) | |
| 946 (message nil)))) | |
| 947 | |
| 948 (defun sgml-entities-menu (event) | |
| 949 (interactive "*e") | |
| 950 (sgml-need-dtd) | |
| 951 (let ((menu | |
| 952 (mapcar (function (lambda (x) (cons x x))) | |
| 953 (sort (sgml-map-entities (function sgml-entity-name) | |
| 954 (sgml-dtd-entities sgml-dtd-info) | |
| 955 t) | |
| 956 (function string-lessp)))) | |
| 957 choice) | |
| 958 (unless menu | |
| 959 (error "No entities defined")) | |
| 960 (setq choice (sgml-popup-menu event "Entities" menu)) | |
| 961 (when choice | |
| 962 (insert "&" choice ";")))) | |
| 963 | |
| 964 (defun sgml-doctype-insert (doctype vars) | |
| 965 "Insert string DOCTYPE (ignored if nil) and set variables in &rest VARS. | |
| 966 VARS should be a list of variables and values. | |
| 967 For backward compatibility a singel string instead of a variable is | |
| 968 assigned to sgml-default-dtd-file. | |
| 969 All variables are made buffer local and are also added to the | |
| 970 buffers local variables list." | |
| 971 (when doctype | |
| 972 (unless (bolp) | |
| 973 (insert "\n")) | |
| 974 (unless (eolp) | |
| 975 (insert "\n") | |
| 976 (forward-char -1)) | |
| 977 (sgml-insert-markup doctype)) | |
| 978 (while vars | |
| 979 (cond ((stringp (car vars)) | |
| 980 (sgml-set-local-variable 'sgml-default-dtd-file (car vars)) | |
| 981 (setq vars (cdr vars))) | |
| 982 ((car vars) ; Avoid nil | |
| 983 (sgml-set-local-variable (car vars) (cadr vars)) | |
| 984 (setq vars (cddr vars))))) | |
| 985 (setq sgml-top-tree nil)) | |
| 986 | |
| 987 (defun sgml-attrib-menu (event) | |
| 988 "Pop up a menu of the attributes of the current element | |
| 989 \(or the element whith start-tag before point)." | |
| 990 (interactive "e") | |
| 991 (let* ((el (sgml-find-attribute-element)) | |
| 992 (attlist (sgml-non-fixed-attributes (sgml-element-attlist el))) | |
| 993 tokens menu other) | |
| 994 (or attlist | |
| 995 (error "No non-fixed attributes for element")) | |
| 996 (setq menu | |
| 997 (loop for attdecl in attlist | |
| 998 for name = (sgml-attdecl-name attdecl) | |
| 999 for defval = (sgml-attdecl-default-value attdecl) | |
| 1000 for tokens = (or (sgml-declared-value-token-group | |
| 1001 (sgml-attdecl-declared-value attdecl)) | |
| 1002 (sgml-declared-value-notation | |
| 1003 (sgml-attdecl-declared-value attdecl))) | |
| 1004 collect | |
| 1005 (cons | |
| 1006 (sgml-attdecl-name attdecl) | |
| 1007 (nconc | |
| 1008 (if tokens | |
| 1009 (loop for val in tokens collect | |
| 1010 (list val | |
| 1011 (list 'sgml-insert-attribute name val))) | |
| 1012 (list | |
| 1013 (list "Set attribute value" | |
| 1014 (list 'sgml-insert-attribute | |
| 1015 (sgml-attdecl-name attdecl) | |
| 1016 (list 'sgml-read-attribute-value | |
| 1017 (list 'quote attdecl) | |
| 1018 (sgml-element-attval el name)))))) | |
| 1019 (if (sgml-default-value-type-p 'required defval) | |
| 1020 nil | |
| 1021 (list "--" | |
| 1022 (list (if (sgml-default-value-type-p nil defval) | |
| 1023 (format "Default: %s" | |
| 1024 (sgml-default-value-attval defval)) | |
| 1025 "#IMPLIED") | |
| 1026 (list 'sgml-insert-attribute name nil)))))))) | |
| 1027 (sgml-popup-multi-menu event "Attributes" menu))) | |
| 1028 | |
| 1029 ;;;; SGML mode: Fill | |
| 1030 | |
| 1031 (defun sgml-fill-element (element) | |
| 1032 "Fill bigest enclosing element with mixed content. | |
| 1033 If current element has pure element content, recursively fill the | |
| 1034 subelements." | |
| 1035 (interactive (list (sgml-find-element-of (point)))) | |
| 1036 ;; | |
| 1037 (message "Filling...") | |
| 1038 (when (sgml-element-mixed element) | |
| 1039 ;; Find bigest enclosing element with mixed content | |
| 1040 (while (sgml-element-mixed (sgml-element-parent element)) | |
| 1041 (setq element (sgml-element-parent element)))) | |
| 1042 ;; | |
| 1043 (sgml-do-fill element) | |
| 1044 (sgml-message "Done")) | |
| 1045 | |
| 1046 (defun sgml-do-fill (element) | |
| 1047 (when sgml-debug | |
| 1048 (goto-char (sgml-element-start element)) | |
| 1049 (sit-for 0)) | |
| 1050 (save-excursion | |
| 1051 (cond | |
| 1052 ((sgml-element-mixed element) | |
| 1053 (let (last-pos | |
| 1054 (c (sgml-element-content element)) | |
| 1055 (agenda nil)) ; regions to fill later | |
| 1056 (goto-char (sgml-element-stag-end element)) | |
| 1057 (when (eolp) (forward-char 1)) | |
| 1058 (setq last-pos (point)) | |
| 1059 (while c | |
| 1060 (cond | |
| 1061 ((sgml-element-mixed c)) | |
| 1062 (t | |
| 1063 ;; Put region before element on agenda. Can't fill it now | |
| 1064 ;; that would mangel the parse tree that is beeing traversed. | |
| 1065 (push (cons last-pos (sgml-element-start c)) | |
| 1066 agenda) | |
| 1067 (goto-char (sgml-element-start c)) | |
| 1068 (sgml-do-fill c) | |
| 1069 ;; Fill may change parse tree, get a fresh | |
| 1070 (setq c (sgml-find-element-of (point))) | |
| 1071 (setq last-pos (sgml-element-end c)))) | |
| 1072 (setq c (sgml-element-next c))) | |
| 1073 ;; Fill the last region in content of element, | |
| 1074 ;; but get a fresh parse tree, if it has change due to other fills. | |
| 1075 (sgml-fill-region last-pos | |
| 1076 (sgml-element-etag-start | |
| 1077 (sgml-find-element-of | |
| 1078 (sgml-element-start element)))) | |
| 1079 (while agenda | |
| 1080 (sgml-fill-region (caar agenda) (cdar agenda)) | |
| 1081 (setq agenda (cdr agenda))))) | |
| 1082 (t | |
| 1083 ;; If element is not mixed, fill subelements recursively | |
| 1084 (let ((c (sgml-element-content element))) | |
| 1085 (while c | |
| 1086 (goto-char (sgml-element-start c)) | |
| 1087 (sgml-do-fill c) | |
| 1088 (setq c (sgml-element-next (sgml-find-element-of (point)))))))))) | |
| 1089 | |
| 1090 (defun sgml-fill-region (start end) | |
| 1091 (sgml-message "Filling...") | |
| 1092 (save-excursion | |
| 1093 (goto-char end) | |
| 1094 (skip-chars-backward " \t\n") | |
| 1095 (while (progn (beginning-of-line 1) | |
| 1096 (< start (point))) | |
| 1097 (delete-horizontal-space) | |
| 1098 (delete-char -1) | |
| 1099 (insert " ")) | |
| 1100 (end-of-line 1) | |
| 1101 (let (give-up prev-column opoint) | |
| 1102 (while (and (not give-up) (> (current-column) fill-column)) | |
| 1103 (setq prev-column (current-column)) | |
| 1104 (setq opoint (point)) | |
| 1105 (move-to-column (1+ fill-column)) | |
| 1106 (skip-chars-backward "^ \t\n") | |
| 1107 (if (bolp) | |
| 1108 (re-search-forward "[ \t]" opoint t)) | |
| 1109 (setq opoint (point)) | |
| 1110 (skip-chars-backward " \t") | |
| 1111 (if (bolp) | |
| 1112 (setq give-up t) | |
| 1113 (delete-region (point) opoint) | |
| 1114 (newline) | |
| 1115 (sgml-indent-line) | |
| 1116 (end-of-line 1) | |
| 1117 (setq give-up (>= (current-column) prev-column))))))) | |
| 1118 | |
| 1119 ;;;; SGML mode: Attribute editing | |
| 1120 | |
| 1121 (defvar sgml-start-attributes nil) | |
| 1122 (defvar sgml-main-buffer nil) | |
| 1123 (defvar sgml-attlist nil) | |
| 1124 | |
| 1125 (defun sgml-edit-attributes () | |
| 1126 "Edit attributes of current element. | |
| 1127 Editing is done in a separate window." | |
| 1128 (interactive) | |
| 1129 (let ((element (sgml-find-attribute-element))) | |
| 1130 (unless (sgml-bpos-p (sgml-element-stag-epos element)) | |
| 1131 (error "Element's start-tag is not in the buffer")) | |
| 1132 (push-mark) | |
| 1133 (goto-char (sgml-element-start element)) | |
| 1134 (let* ((start (point-marker)) | |
| 1135 (asl (sgml-element-attribute-specification-list element)) | |
| 1136 (cb (current-buffer)) | |
| 1137 (quote sgml-always-quote-attributes)) | |
| 1138 (switch-to-buffer-other-window | |
| 1139 (sgml-attribute-buffer element asl)) | |
| 1140 (sgml-edit-attrib-mode) | |
| 1141 (make-local-variable 'sgml-attlist) | |
| 1142 (setq sgml-attlist (sgml-element-attlist element)) | |
| 1143 (make-local-variable 'sgml-start-attributes) | |
| 1144 (setq sgml-start-attributes start) | |
| 1145 (make-local-variable 'sgml-always-quote-attributes) | |
| 1146 (setq sgml-always-quote-attributes quote) | |
| 1147 (make-local-variable 'sgml-main-buffer) | |
| 1148 (setq sgml-main-buffer cb)))) | |
| 1149 | |
| 1150 (defun sgml-attribute-buffer (element asl) | |
| 1151 (let ((bname "*Edit attributes*") | |
| 1152 (buf nil) | |
| 1153 (inhibit-read-only t)) | |
| 1154 (save-excursion | |
| 1155 (when (setq buf (get-buffer bname)) | |
| 1156 (kill-buffer buf)) | |
| 1157 (setq buf (get-buffer-create bname)) | |
| 1158 (set-buffer buf) | |
| 1159 (erase-buffer) | |
| 1160 (sgml-insert '(read-only t rear-nonsticky (read-only)) | |
| 1161 "<%s -- Edit values and finish with C-c C-c --\n" | |
| 1162 (sgml-element-name element)) | |
| 1163 (loop | |
| 1164 for attr in (sgml-element-attlist element) do | |
| 1165 ;; Produce text like | |
| 1166 ;; name = value | |
| 1167 ;; -- declaration : default -- | |
| 1168 (let* ((aname (sgml-attdecl-name attr)) | |
| 1169 (dcl-value (sgml-attdecl-declared-value attr)) | |
| 1170 (def-value (sgml-attdecl-default-value attr)) | |
| 1171 (cur-value (sgml-lookup-attspec aname asl))) | |
| 1172 (sgml-insert ; atribute name | |
| 1173 '(read-only t rear-nonsticky (read-only)) | |
| 1174 " %s = " aname) | |
| 1175 (cond ; attribute value | |
| 1176 ((sgml-default-value-type-p 'fixed def-value) | |
| 1177 (sgml-insert '(read-only t category sgml-fixed | |
| 1178 rear-nonsticky (category)) | |
| 1179 "#FIXED %s" | |
| 1180 (sgml-default-value-attval def-value))) | |
| 1181 ((and (null cur-value) | |
| 1182 (or (memq def-value '(implied conref current)) | |
| 1183 (sgml-default-value-attval def-value))) | |
| 1184 (sgml-insert '(category sgml-default rear-nonsticky (category)) | |
| 1185 "#DEFAULT")) | |
| 1186 ((not (null cur-value)) | |
| 1187 (sgml-insert nil "%s" (sgml-attspec-attval cur-value)))) | |
| 1188 (sgml-insert | |
| 1189 '(read-only 1) | |
| 1190 "\n\t-- %s: %s --\n" | |
| 1191 (cond ((sgml-declared-value-token-group dcl-value)) | |
| 1192 ((sgml-declared-value-notation dcl-value) | |
| 1193 (format "NOTATION %s" | |
| 1194 (sgml-declared-value-notation dcl-value))) | |
| 1195 (t | |
| 1196 dcl-value)) | |
| 1197 (cond ((sgml-default-value-attval def-value)) | |
| 1198 (t | |
| 1199 (concat "#" (upcase (symbol-name def-value)))))))) | |
| 1200 (sgml-insert '(read-only t) ">") | |
| 1201 (goto-char (point-min)) | |
| 1202 (sgml-edit-attrib-next)) | |
| 1203 buf)) | |
| 1204 | |
| 1205 (defvar sgml-edit-attrib-mode-map (make-sparse-keymap)) | |
| 1206 (define-key sgml-edit-attrib-mode-map "\C-c\C-c" 'sgml-edit-attrib-finish) | |
| 1207 (define-key sgml-edit-attrib-mode-map "\C-c\C-d" 'sgml-edit-attrib-default) | |
| 1208 (define-key sgml-edit-attrib-mode-map "\C-c\C-k" 'sgml-edit-attrib-clear) | |
| 1209 | |
| 1210 (define-key sgml-edit-attrib-mode-map "\C-a" 'sgml-edit-attrib-field-start) | |
| 1211 (define-key sgml-edit-attrib-mode-map "\C-e" 'sgml-edit-attrib-field-end) | |
| 1212 (define-key sgml-edit-attrib-mode-map "\t" 'sgml-edit-attrib-next) | |
| 1213 | |
| 1214 (defun sgml-edit-attrib-mode () | |
| 1215 "Major mode to edit attribute specification list.\\<sgml-edit-attrib-mode-map> | |
| 1216 Use \\[sgml-edit-attrib-next] to move between input fields. Use | |
| 1217 \\[sgml-edit-attrib-default] to make an attribute have its default | |
| 1218 value. To abort edit kill buffer (\\[kill-buffer]) and remove window | |
| 1219 (\\[delete-window]). To finsh edit use \\[sgml-edit-attrib-finish]. | |
| 1220 | |
| 1221 \\{sgml-edit-attrib-mode-map}" | |
| 1222 (kill-all-local-variables) | |
| 1223 (setq mode-name "SGML edit attributes" | |
| 1224 major-mode 'sgml-edit-attrib-mode) | |
| 1225 (use-local-map sgml-edit-attrib-mode-map) | |
| 1226 (run-hooks 'text-mode-hook 'sgml-edit-attrib-mode-hook)) | |
| 1227 | |
| 1228 (defun sgml-edit-attrib-finish () | |
| 1229 "Finish editing and insert attribute values in original buffer." | |
| 1230 (interactive) | |
| 1231 (let ((cb (current-buffer)) | |
| 1232 (asl (sgml-edit-attrib-specification-list)) | |
| 1233 ;; save buffer local variables | |
| 1234 (start sgml-start-attributes)) | |
| 1235 (when (markerp start) | |
| 1236 (delete-windows-on cb) | |
| 1237 (switch-to-buffer (marker-buffer start)) | |
| 1238 (kill-buffer cb) | |
| 1239 (goto-char start) | |
| 1240 (let ((element (sgml-find-element-of start))) | |
| 1241 ;; *** Should the it be verified that this element | |
| 1242 ;; is the one edited? | |
| 1243 (sgml-change-start-tag element asl))))) | |
| 1244 | |
| 1245 | |
| 1246 (defun sgml-edit-attrib-specification-list () | |
| 1247 (goto-char (point-min)) | |
| 1248 (forward-line 1) | |
| 1249 (sgml-with-parser-syntax | |
| 1250 (let ((asl nil) | |
| 1251 (al sgml-attlist)) | |
| 1252 (while (not (eq ?> (following-char))) | |
| 1253 (sgml-parse-s) | |
| 1254 (let ((name (sgml-check-nametoken))) | |
| 1255 (forward-char 3) | |
| 1256 (unless (memq (get-text-property (point) 'category) | |
| 1257 '(sgml-default sgml-fixed)) | |
| 1258 (push | |
| 1259 (sgml-make-attspec (sgml-attdecl-name (car al)) | |
| 1260 (sgml-extract-attribute-value | |
| 1261 (sgml-attdecl-declared-value (car al)))) | |
| 1262 asl)) | |
| 1263 (while (progn (beginning-of-line 2) | |
| 1264 (or (eolp) | |
| 1265 (not (get-text-property (point) 'read-only)))))) | |
| 1266 ; was (eq t) | |
| 1267 (forward-line 1) | |
| 1268 (setq al (cdr al))) | |
| 1269 asl))) | |
| 1270 | |
| 1271 | |
| 1272 (defun sgml-extract-attribute-value (type) | |
| 1273 (save-excursion | |
| 1274 (save-restriction | |
| 1275 (narrow-to-region (point) | |
| 1276 (progn (sgml-edit-attrib-field-end) | |
| 1277 (point))) | |
| 1278 (unless (eq type 'cdata) | |
| 1279 (subst-char-in-region (point-min) (point-max) ?\n ? ) | |
| 1280 (goto-char (point-min)) | |
| 1281 (delete-horizontal-space)) | |
| 1282 (goto-char (point-min)) | |
| 1283 (when (search-forward "\"" nil t) ; don't allow both " and ' | |
| 1284 (goto-char (point-min)) | |
| 1285 (while (search-forward "'" nil t) ; replace ' with char ref | |
| 1286 (replace-match "'"))) | |
| 1287 (buffer-string)))) | |
| 1288 | |
| 1289 (defun sgml-edit-attrib-default () | |
| 1290 "Set current attribute value to default." | |
| 1291 (interactive) | |
| 1292 (sgml-edit-attrib-clear) | |
| 1293 (save-excursion | |
| 1294 (sgml-insert '(category sgml-default) | |
| 1295 "#DEFAULT"))) | |
| 1296 | |
| 1297 (defun sgml-edit-attrib-clear () | |
| 1298 "Kill the value of current attribute." | |
| 1299 (interactive) | |
| 1300 (kill-region | |
| 1301 (progn (sgml-edit-attrib-field-start) (point)) | |
| 1302 (progn (sgml-edit-attrib-field-end) (point)))) | |
| 1303 | |
| 1304 (defun sgml-edit-attrib-field-start () | |
| 1305 "Go to the start of the attribute value field." | |
| 1306 (interactive) | |
| 1307 (let (start) | |
| 1308 (beginning-of-line 1) | |
| 1309 (while (not (eq t (get-text-property (point) 'read-only))) | |
| 1310 (beginning-of-line 0)) | |
| 1311 (setq start (next-single-property-change (point) 'read-only)) | |
| 1312 (unless start (error "No attribute value here")) | |
| 1313 (assert (number-or-marker-p start)) | |
| 1314 (goto-char start))) | |
| 1315 | |
| 1316 (defun sgml-edit-attrib-field-end () | |
| 1317 "Go to the end of the attribute value field." | |
| 1318 (interactive) | |
| 1319 (sgml-edit-attrib-field-start) | |
| 1320 (let ((end (if (and (eolp) | |
| 1321 (get-text-property (1+ (point)) 'read-only)) | |
| 1322 (point) | |
| 1323 (next-single-property-change (point) 'read-only)))) | |
| 1324 (assert (number-or-marker-p end)) | |
| 1325 (goto-char end))) | |
| 1326 | |
| 1327 (defun sgml-edit-attrib-next () | |
| 1328 "Move to next attribute value." | |
| 1329 (interactive) | |
| 1330 (or (search-forward-regexp "^ *[.A-Za-z0-9---]+ *= ?" nil t) | |
| 1331 (goto-char (point-min)))) | |
| 1332 | |
| 1333 | |
| 1334 ;;;; SGML mode: Hiding tags/attributes | |
| 1335 | |
| 1336 (defconst sgml-tag-regexp | |
| 1337 "\\(</?>\\|</?[A-Za-z][---A-Za-z0-9.]*\\(\\([^'\"></]\\|'[^']*'\\|\"[^\"]*\"\\)*\\)>?\\)") | |
| 1338 | |
| 1339 (defun sgml-operate-on-tags (action &optional attr-p) | |
| 1340 (let ((buffer-modified-p (buffer-modified-p)) | |
| 1341 (inhibit-read-only t) | |
| 1342 (buffer-read-only nil) | |
| 1343 (before-change-function nil) | |
| 1344 (markup-index ; match-data index in tag regexp | |
| 1345 (if attr-p 2 1)) | |
| 1346 (tagcount ; number tags to give them uniq | |
| 1347 ; invisible properties | |
| 1348 1)) | |
| 1349 (unwind-protect | |
| 1350 (save-excursion | |
| 1351 (goto-char (point-min)) | |
| 1352 (while (re-search-forward sgml-tag-regexp nil t) | |
| 1353 (cond | |
| 1354 ((eq action 'hide) | |
| 1355 (let ((tag (downcase | |
| 1356 (buffer-substring (1+ (match-beginning 0)) | |
| 1357 (match-beginning 1))))) | |
| 1358 (if (or attr-p (not (member tag sgml-exposed-tags))) | |
| 1359 (add-text-properties | |
| 1360 (match-beginning markup-index) (match-end markup-index) | |
| 1361 (list 'invisible tagcount | |
| 1362 'rear-nonsticky '(invisible face)))))) | |
| 1363 ((eq action 'show) ; ignore markup-index | |
| 1364 (remove-text-properties (match-beginning 0) (match-end 0) | |
| 1365 '(invisible nil))) | |
| 1366 (t (error "Invalid action: %s" action))) | |
| 1367 (incf tagcount))) | |
| 1368 (set-buffer-modified-p buffer-modified-p)))) | |
| 1369 | |
| 1370 (defun sgml-hide-tags () | |
| 1371 "Hide all tags in buffer." | |
| 1372 (interactive) | |
| 1373 (sgml-operate-on-tags 'hide)) | |
| 1374 | |
| 1375 (defun sgml-show-tags () | |
| 1376 "Show hidden tags in buffer." | |
| 1377 (interactive) | |
| 1378 (sgml-operate-on-tags 'show)) | |
| 1379 | |
| 1380 (defun sgml-hide-attributes () | |
| 1381 "Hide all attribute specifications in the buffer." | |
| 1382 (interactive) | |
| 1383 (sgml-operate-on-tags 'hide 'attributes)) | |
| 1384 | |
| 1385 (defun sgml-show-attributes () | |
| 1386 "Show all attribute specifications in the buffer." | |
| 1387 (interactive) | |
| 1388 (sgml-operate-on-tags 'show 'attributes)) | |
| 1389 | |
| 1390 | |
| 1391 ;;;; SGML mode: Normalize (and misc manipulations) | |
| 1392 | |
| 1393 (defun sgml-expand-shortref-to-text (name) | |
| 1394 (let (before-change-function | |
| 1395 (entity (sgml-lookup-entity name (sgml-dtd-entities sgml-dtd-info)))) | |
| 1396 (cond | |
| 1397 ((null entity) (sgml-error "Undefined entity %s" name)) | |
| 1398 ((sgml-entity-data-p entity) | |
| 1399 (sgml-expand-shortref-to-entity name)) | |
| 1400 (t | |
| 1401 (delete-region sgml-markup-start (point)) | |
| 1402 (sgml-entity-insert-text entity) | |
| 1403 (setq sgml-goal (point-max)) ; May have changed size of buffer | |
| 1404 ;; now parse the entity text | |
| 1405 (goto-char (setq sgml-rs-ignore-pos sgml-markup-start)))))) | |
| 1406 | |
| 1407 (defun sgml-expand-shortref-to-entity (name) | |
| 1408 (let ((end (point)) | |
| 1409 (re-found nil) | |
| 1410 before-change-function) | |
| 1411 (goto-char sgml-markup-start) | |
| 1412 (setq re-found (search-forward "\n" end t)) | |
| 1413 (delete-region sgml-markup-start end) | |
| 1414 (insert "&" name (if re-found "\n" ";")) | |
| 1415 (setq sgml-goal (point-max)) ; May have changed size of buffer | |
| 1416 (goto-char (setq sgml-rs-ignore-pos sgml-markup-start)))) | |
| 1417 | |
| 1418 (defun sgml-expand-all-shortrefs (to-entity) | |
| 1419 "Expand all short references in the buffer. | |
| 1420 Short references to text entities are expanded to the replacement text | |
| 1421 of the entity other short references are expanded into general entity | |
| 1422 references. If argument, TO-ENTITY, is non-nil, or if called | |
| 1423 interactive with numeric prefix argument, all short references are | |
| 1424 replaced by generaly entity references." | |
| 1425 (interactive "*P") | |
| 1426 (sgml-reparse-buffer | |
| 1427 (if to-entity | |
| 1428 (function sgml-expand-shortref-to-entity) | |
| 1429 (function sgml-expand-shortref-to-text)))) | |
| 1430 | |
| 1431 (defun sgml-normalize (to-entity &optional element) | |
| 1432 "Normalize buffer by filling in omitted tags and expanding empty tags. | |
| 1433 Argument TO-ENTITY controls how short references are expanded as with | |
| 1434 `sgml-expand-all-shortrefs'. An optional argument ELEMENT can be the | |
| 1435 element to normalize insted of the whole buffer, if used no short | |
| 1436 references will be expanded." | |
| 1437 (interactive "*P") | |
| 1438 (unless element | |
| 1439 (sgml-expand-all-shortrefs to-entity)) | |
| 1440 (let ((only-one (not (null element)))) | |
| 1441 (setq element (or element (sgml-top-element))) | |
| 1442 (goto-char (sgml-element-end element)) | |
| 1443 (let ((before-change-function nil)) | |
| 1444 (sgml-normalize-content element only-one))) | |
| 1445 (sgml-note-change-at (sgml-element-start element)) | |
| 1446 (sgml-message "Done")) | |
| 1447 | |
| 1448 (defun sgml-normalize-element () | |
| 1449 (interactive "*") | |
| 1450 (sgml-normalize nil (sgml-find-element-of (point)))) | |
| 1451 | |
| 1452 (defun sgml-normalize-content (element only-first) | |
| 1453 "Normalize all elements in a content where ELEMENT is first element. | |
| 1454 If sgml-normalize-trims is non-nil, trim off white space from ends of | |
| 1455 elements with omitted end-tags." | |
| 1456 (let ((content nil)) | |
| 1457 (while element ; Build list of content elements | |
| 1458 (push element content) | |
| 1459 (setq element (if only-first | |
| 1460 nil | |
| 1461 (sgml-element-next element)))) | |
| 1462 (while content | |
| 1463 (setq element (car content)) | |
| 1464 ;; Progress report | |
| 1465 (sgml-lazy-message "Normalizing %d%% left" | |
| 1466 (/ (point) (/ (+ (point-max) 100) 100))) | |
| 1467 ;; Fix the end-tag | |
| 1468 (sgml-normalize-end-tag element) | |
| 1469 ;; Fix tags of content | |
| 1470 (sgml-normalize-content (sgml-tree-content element) nil) | |
| 1471 ;; Fix the start-tag | |
| 1472 (sgml-normalize-start-tag element) | |
| 1473 ;; Next content element | |
| 1474 (setq content (cdr content))))) | |
| 1475 | |
| 1476 (defun sgml-normalize-start-tag (element) | |
| 1477 (when (sgml-bpos-p (sgml-element-stag-epos element)) | |
| 1478 (goto-char (min (point) (sgml-element-start element))) | |
| 1479 (let ((name (sgml-element-gi element)) | |
| 1480 (attlist (sgml-element-attlist element)) | |
| 1481 (asl (sgml-element-attribute-specification-list element))) | |
| 1482 (save-excursion | |
| 1483 (assert (or (zerop (sgml-element-stag-len element)) | |
| 1484 (= (point) (sgml-element-start element)))) | |
| 1485 (delete-char (sgml-element-stag-len element)) | |
| 1486 (sgml-insert-start-tag name asl attlist nil))))) | |
| 1487 | |
| 1488 (defun sgml-normalize-end-tag (element) | |
| 1489 (unless (sgml-element-empty element) | |
| 1490 (when (sgml-bpos-p (sgml-element-etag-epos element)) | |
| 1491 (goto-char (min (point) (sgml-element-etag-start element))) | |
| 1492 (if (and (zerop (sgml-element-etag-len element)) | |
| 1493 sgml-normalize-trims) | |
| 1494 (skip-chars-backward " \t\n\r")) | |
| 1495 (delete-char (sgml-tree-etag-len element)) | |
| 1496 (save-excursion (insert (sgml-end-tag-of element)))))) | |
| 1497 | |
| 1498 | |
| 1499 (defun sgml-make-character-reference (&optional invert) | |
| 1500 "Convert character after point into a character reference. | |
| 1501 If called with a numeric argument, convert a character reference back | |
| 1502 to a normal character. If called from a program, set optional | |
| 1503 argument INVERT to non-nil." | |
| 1504 (interactive "*P") | |
| 1505 (cond | |
| 1506 (invert | |
| 1507 (or (looking-at "&#\\([0-9]+\\)[;\n]?") | |
| 1508 (error "No character reference after point")) | |
| 1509 (let ((c (string-to-int (buffer-substring (match-beginning 1) | |
| 1510 (match-end 1))))) | |
| 1511 (delete-region (match-beginning 0) | |
| 1512 (match-end 0)) | |
| 1513 (insert c))) | |
| 1514 ;; Convert character to &#nn; | |
| 1515 (t | |
| 1516 (let ((c (following-char))) | |
| 1517 (delete-char 1) | |
| 1518 (insert (format "&#%d;" c)))))) | |
| 1519 | |
| 1520 (defun sgml-expand-entity-reference () | |
| 1521 "Insert the text of the entity referenced at point." | |
| 1522 (interactive) | |
| 1523 (sgml-with-parser-syntax | |
| 1524 (setq sgml-markup-start (point)) | |
| 1525 (sgml-check-delim "ERO") | |
| 1526 (let* ((ename (sgml-check-name t)) | |
| 1527 (entity (sgml-lookup-entity ename | |
| 1528 (sgml-dtd-entities | |
| 1529 (sgml-pstate-dtd | |
| 1530 sgml-buffer-parse-state))))) | |
| 1531 (unless entity | |
| 1532 (error "Undefined entity %s" ename)) | |
| 1533 (or (sgml-parse-delim "REFC") | |
| 1534 (sgml-parse-RE)) | |
| 1535 (delete-region sgml-markup-start (point)) | |
| 1536 (sgml-entity-insert-text entity)))) | |
| 1537 | |
| 1538 | |
| 1539 ;;;; SGML mode: TAB completion | |
| 1540 | |
| 1541 (defun sgml-complete () | |
| 1542 "Complete the word/tag/entity before point. | |
| 1543 If it is a tag (starts with < or </) complete with valid tags. | |
| 1544 If it is an entity (starts with &) complete with declared entities. | |
| 1545 If it is a markup declaration (starts with <!) complete with markup | |
| 1546 declaration names. | |
| 1547 If it is something else complete with ispell-complete-word." | |
| 1548 (interactive "*") | |
| 1549 (let ((tab ; The completion table | |
| 1550 nil) | |
| 1551 (pattern nil) | |
| 1552 (c nil) | |
| 1553 (here (point))) | |
| 1554 (skip-chars-backward "^ \n\t</!&%") | |
| 1555 (setq pattern (buffer-substring (point) here)) | |
| 1556 (setq c (char-after (1- (point)))) | |
| 1557 (cond | |
| 1558 ;; entitiy | |
| 1559 ((eq c ?&) | |
| 1560 (sgml-need-dtd) | |
| 1561 (setq tab | |
| 1562 (sgml-entity-completion-table | |
| 1563 (sgml-dtd-entities (sgml-pstate-dtd sgml-buffer-parse-state))))) | |
| 1564 ;; start-tag | |
| 1565 ((eq c ?<) | |
| 1566 (save-excursion | |
| 1567 (backward-char 1) | |
| 1568 (sgml-parse-to-here) | |
| 1569 (setq tab (sgml-eltype-completion-table | |
| 1570 (sgml-current-list-of-valid-eltypes))))) | |
| 1571 ;; end-tag | |
| 1572 ((eq c ?/) | |
| 1573 (save-excursion | |
| 1574 (backward-char 2) | |
| 1575 (sgml-parse-to-here) | |
| 1576 (setq tab (sgml-eltype-completion-table | |
| 1577 (sgml-current-list-of-endable-eltypes))))) | |
| 1578 ;; markup declaration | |
| 1579 ((eq c ?!) | |
| 1580 (setq tab sgml-markup-declaration-table)) | |
| 1581 (t | |
| 1582 (goto-char here) | |
| 1583 (ispell-complete-word))) | |
| 1584 (when tab | |
| 1585 (let ((completion (try-completion pattern tab))) | |
| 1586 (cond ((null completion) | |
| 1587 (goto-char here) | |
| 1588 (message "Can't find completion for \"%s\"" pattern) | |
| 1589 (ding)) | |
| 1590 ((eq completion t) | |
| 1591 (goto-char here) | |
| 1592 (message "[Complete]")) | |
| 1593 ((not (string= pattern completion)) | |
| 1594 (delete-char (length pattern)) | |
| 1595 (insert completion)) | |
| 1596 (t | |
| 1597 (goto-char here) | |
| 1598 (message "Making completion list...") | |
| 1599 (let ((list (all-completions pattern tab))) | |
| 1600 (with-output-to-temp-buffer " *Completions*" | |
| 1601 (display-completion-list list))) | |
| 1602 (message "Making completion list...%s" "done"))))))) | |
| 1603 | |
| 1604 | |
| 1605 ;;;; SGML mode: Options menu | |
| 1606 | |
| 1607 (defun sgml-file-options-menu (&optional event) | |
| 1608 (interactive "e") | |
| 1609 (sgml-options-menu event sgml-file-options)) | |
| 1610 | |
| 1611 (defun sgml-user-options-menu (&optional event) | |
| 1612 (interactive "e") | |
| 1613 (sgml-options-menu event sgml-user-options)) | |
| 1614 | |
| 1615 (defun sgml-options-menu (event vars) | |
| 1616 (let ((var | |
| 1617 (let ((maxlen | |
| 1618 (loop for var in vars | |
| 1619 maximize (length (sgml-variable-description var))))) | |
| 1620 (sgml-popup-menu | |
| 1621 event "Options" | |
| 1622 (loop for var in vars | |
| 1623 for desc = (sgml-variable-description var) | |
| 1624 collect | |
| 1625 (cons | |
| 1626 (format "%s%s [%s]" | |
| 1627 desc | |
| 1628 (make-string (- maxlen (length desc)) ? ) | |
| 1629 (sgml-option-value-indicator var)) | |
| 1630 var)))))) | |
| 1631 (when var | |
| 1632 (sgml-do-set-option var event)))) | |
| 1633 | |
| 1634 (defun sgml-do-set-option (var &optional event) | |
| 1635 (let ((type (sgml-variable-type var)) | |
| 1636 (val (symbol-value var))) | |
| 1637 (cond | |
| 1638 ((eq 'toggle type) | |
| 1639 (message "%s set to %s" var (not val)) | |
| 1640 (set var (not val))) | |
| 1641 ((eq 'string type) | |
| 1642 (describe-variable var) | |
| 1643 (setq val (read-string (concat (sgml-variable-description var) ": "))) | |
| 1644 (when (stringp val) | |
| 1645 (set var val))) | |
| 1646 ((consp type) | |
| 1647 (let ((val | |
| 1648 (sgml-popup-menu event | |
| 1649 (sgml-variable-description var) | |
| 1650 (loop for c in type collect | |
| 1651 (cons | |
| 1652 (if (consp c) (car c) (format "%s" c)) | |
| 1653 (if (consp c) (cdr c) c)))))) | |
| 1654 (set var val) | |
| 1655 (message "%s set to %s" var val))) | |
| 1656 (t | |
| 1657 (describe-variable var) | |
| 1658 (setq val (read-string (concat (sgml-variable-description var) | |
| 1659 " (sexp): "))) | |
| 1660 (when (stringp val) | |
| 1661 (set var (car (read-from-string val))))))) | |
| 1662 (force-mode-line-update)) | |
| 1663 | |
| 1664 (defun sgml-option-value-indicator (var) | |
| 1665 (let ((type (sgml-variable-type var)) | |
| 1666 (val (symbol-value var))) | |
| 1667 (cond | |
| 1668 ((eq type 'toggle) | |
| 1669 (if val "Yes" "No")) | |
| 1670 ((eq type 'string) | |
| 1671 (if (stringp val) | |
| 1672 (substring val 0 4) | |
| 1673 "-")) | |
| 1674 ((and (atom type) val) | |
| 1675 "...") | |
| 1676 ((consp type) | |
| 1677 (or (car (rassq val type)) | |
| 1678 val)) | |
| 1679 (t | |
| 1680 "-")))) | |
| 1681 | |
| 1682 ;;;; NEW | |
| 1683 | |
| 1684 (defun sgml-trim-and-leave-element () | |
| 1685 (interactive) | |
| 1686 (goto-char (sgml-element-etag-start (sgml-last-element))) | |
| 1687 (while (progn (forward-char -1) | |
| 1688 (looking-at "\\s-")) | |
| 1689 (delete-char 1)) | |
| 1690 (sgml-up-element)) | |
| 1691 | |
| 1692 | |
| 1693 ;;; psgml-edit.el ends here |