site-lisp/psgml/psgml-debug.el

   1 ;;;;\filename psgml-debug.el
   2 ;;;\Last edited: 2001-03-10 00:32:00 lenst
   3 ;;;\RCS $Id: psgml-debug.el,v 2.26 2001/12/14 10:26:57 lenst Exp $
   4 ;;;\author {Lennart Staflin}
   5 ;;;\maketitle
   6
   7 ;;\begin{codeseg}
   8 (provide 'psgml-debug)
   9 (require 'psgml)
  10 (require 'psgml-parse)
  11 (require 'psgml-edit)
  12 (require 'psgml-dtd)
  13 (autoload 'sgml-translate-model "psgml-dtd" "" nil)
  14 \f
  15 ;;;; Debugging
  16
  17 (define-key sgml-mode-map "\C-c," 'sgml-goto-cache)
  18 (define-key sgml-mode-map "\C-c\C-x" 'sgml-dump-tree)
  19 (define-key sgml-mode-map "\C-c."   'sgml-shortref-identify)
  20
  21 (defun sgml-this-element ()
  22   (interactive)
  23   (let ((tree (sgml-find-element-of (point))))
  24     (sgml-dump-rec tree)))
  25
  26 (defun sgml-goto-cache ()
  27   (interactive)
  28   (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state)
  29         sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state))
  30   (sgml-goto-start-point (point))
  31   (message "%s" (sgml-dump-node sgml-current-tree)))
  32
  33 (defun sgml-dump-tree (arg)
  34   (interactive "P")
  35   (when arg
  36     (sgml-parse-to-here))
  37   (with-output-to-temp-buffer "*Dump*"
  38     (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state))))
  39
  40 (defun sgml-auto-dump ()
  41   (let ((standard-output (get-buffer-create "*Dump*"))
  42         (cb (current-buffer)))
  43
  44     (when sgml-buffer-parse-state
  45       (unwind-protect
  46           (progn (set-buffer standard-output)
  47                  (erase-buffer))
  48         (set-buffer cb))
  49
  50       (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state))
  51
  52       ))
  53   )
  54
  55 (defun sgml-start-auto-dump ()
  56   (interactive)
  57   (add-hook 'post-command-hook
  58             (function sgml-auto-dump)
  59             'append))
  60
  61 (defun sgml-comepos (epos)
  62   (if (sgml-strict-epos-p epos)
  63       (format "%s:%s"
  64               (sgml-entity-name (sgml-eref-entity (sgml-epos-eref epos)))
  65               (sgml-epos-pos epos))
  66     (format "%s" epos)))
  67
  68 (defun sgml-dump-node (u)
  69   (format
  70    "%s%s start:%s(%s) end:%s(%s) epos:%s/%s net:%s\n"
  71    (make-string (sgml-tree-level u) ?. )
  72    (sgml-element-gi u)
  73    (sgml-element-start u) (sgml-tree-stag-len u)
  74    (if (sgml-tree-etag-epos u) (sgml-tree-end u)) (sgml-tree-etag-len u)
  75    (sgml-comepos (sgml-tree-stag-epos u))
  76    (sgml-comepos (sgml-tree-etag-epos u))
  77    (sgml-tree-net-enabled u)))
  78
  79 (defun sgml-dump-rec (u)
  80   (while u
  81     (princ (sgml-dump-node u))
  82     (sgml-dump-rec (sgml-tree-content u))
  83     (setq u (sgml-tree-next u))))
  84
  85 (defun sgml-shortref-identify ()
  86   (interactive)
  87   (sgml-find-context-of (point))
  88   (let* ((nobol (eq (point) sgml-rs-ignore-pos))
  89          (tem (sgml-deref-shortmap sgml-current-shortmap nobol)))
  90     (message "%s (%s)" tem nobol)))
  91
  92 (defun sgml-lookup-shortref-name (table map)
  93   (car (rassq map (cdr table))))
  94
  95 (defun sgml-show-current-map ()
  96   (interactive)
  97   (sgml-find-context-of (point))
  98   (let ((name (sgml-lookup-shortref-name
  99                (sgml-dtd-shortmaps sgml-dtd-info)
 100                sgml-current-shortmap)))
 101     (message "Current map: %s"
 102              (or name "#EMPTY"))))
 103 \f
 104 ;;;; For edebug
 105
 106 ;;(put 'when 'edebug-form-hook t)
 107 ;;(put 'unless 'edebug-form-hook t)
 108 ;;(put 'push 'edebug-form-hook '(form sexp))
 109 ;;(put 'setf 'edebug-form-hook '(sexp form))
 110
 111 (setq edebug-print-level 3
 112       edebug-print-length 5
 113       edebug-print-circle nil
 114 )
 115
 116 (eval-when (load)
 117   (unless sgml-running-lucid
 118     (def-edebug-spec sgml-with-parser-syntax (&rest form))
 119     (def-edebug-spec sgml-with-parser-syntax-ro (&rest form))
 120     (def-edebug-spec sgml-skip-upto (sexp))
 121     (def-edebug-spec sgml-check-delim (sexp &optional sexp))
 122     (def-edebug-spec sgml-parse-delim (sexp &optional sexp))
 123     (def-edebug-spec sgml-is-delim (sexp &optional sexp sexp sexp))))
 124 \f
 125 ;;;; dump
 126
 127 (defun sgml-dump-dtd (&optional dtd)
 128   (interactive )
 129   (unless dtd
 130     (setq dtd (sgml-pstate-dtd sgml-buffer-parse-state)))
 131   (with-output-to-temp-buffer "*DTD dump*"
 132     (princ (format "Dependencies: %S\n"
 133                    (sgml-dtd-dependencies dtd)))
 134     (loop for et being the symbols of (sgml-dtd-eltypes dtd)
 135           do (sgml-dp-element et))))
 136
 137 (defun sgml-dump-element (el-name)
 138   (interactive
 139    (list (completing-read "Element: "
 140                           (sgml-dtd-eltypes
 141                            (sgml-pstate-dtd sgml-buffer-parse-state))
 142                           nil t)))
 143   (with-output-to-temp-buffer "*Element dump*"
 144     (sgml-dp-element (sgml-lookup-eltype el-name))))
 145
 146 (defun sgml-dp-element (el)
 147   (cond
 148    ((sgml-eltype-defined el)
 149     (princ (format "Element %s %s %s%s:\n"
 150                    (sgml-eltype-name el)
 151                    (if (sgml-eltype-stag-optional el) "O" "-")
 152                    (if (sgml-eltype-etag-optional el) "O" "-")
 153                    (if (sgml-eltype-mixed el) " mixed" "")))
 154     (cond
 155      ((sgml-model-group-p (sgml-eltype-model el))
 156       (sgml-dp-model (sgml-eltype-model el)))
 157      (t
 158       (prin1 (sgml-eltype-model el))
 159       (terpri)))
 160     (princ (format "Exeptions: +%S -%S\n"
 161                    (sgml-eltype-includes el)
 162                    (sgml-eltype-excludes el)))
 163     (princ (format "Attlist: %S\n" (sgml-eltype-attlist el)))
 164     (princ (format "Plist: %S\n" (symbol-plist el))))
 165    (t
 166     (princ (format "Undefined element %s\n" (sgml-eltype-name el)))))
 167   (terpri))
 168
 169
 170 (defun sgml-dp-model (model &optional indent)
 171   (or indent (setq indent 0))
 172   (let ((sgml-code-xlate (sgml-translate-model model)))
 173     (loop
 174      for i from 0
 175      for x in sgml-code-xlate do
 176      (cond ((sgml-normal-state-p (car x))
 177             (princ (format "%s%d: opts=%s reqs=%s\n"
 178                            (make-string indent ? ) i
 179                            (sgml-untangel-moves (sgml-state-opts (car x)))
 180                            (sgml-untangel-moves (sgml-state-reqs (car x))))))
 181            (t                           ; and-node
 182             (princ (format "%s%d: and-node next=%d\n"
 183                            (make-string indent ? ) i
 184                            (sgml-code-xlate (sgml-and-node-next (car x)))))
 185             (loop for m in (sgml-and-node-dfas (car x))
 186                   do (sgml-dp-model m (+ indent 2))))))))
 187
 188 (defun sgml-untangel-moves (moves)
 189   (loop for m in moves
 190         collect (list (sgml-move-token m)
 191                       (sgml-code-xlate (sgml-move-dest m)))))
 192
 193 \f
 194 ;;;; Dump state
 195
 196 (defun sgml-dump-state ()
 197   (interactive)
 198   (with-output-to-temp-buffer "*State dump*"
 199     (sgml-dp-state sgml-current-state)))
 200
 201 (defun sgml-dp-state (state &optional indent)
 202   (or indent (setq indent 0))
 203   (cond
 204    ((sgml-normal-state-p state)
 205     (sgml-dp-model state indent))
 206    (t
 207     (princ (format "%sand-state\n" (make-string indent ? )))
 208     (sgml-dp-state (sgml-and-state-substate state) (+ 2 indent))
 209     (princ (format "%s--next\n" (make-string indent ? )))
 210     (sgml-dp-state (sgml-and-state-next state)     (+ 2 indent))
 211     (princ (format "%s--dfas\n" (make-string indent ? )))
 212     (loop for m in (sgml-and-state-dfas state)
 213           do (sgml-dp-model m (+ indent 2))
 214           (princ (format "%s--\n" (make-string indent ? )))))))
 215
 216 \f
 217 ;;;; Build autoloads for all interactive functions in psgml-parse
 218
 219 (defun sgml-build-autoloads ()
 220   (interactive)
 221   (with-output-to-temp-buffer "*autoload*"
 222     (loop
 223      for file in '("psgml-parse" "psgml-edit" "psgml-dtd"
 224                    "psgml-info" "psgml-charent")
 225      do
 226      (set-buffer (find-file-noselect (concat file ".el")))
 227      (goto-char (point-min))
 228      (while (and
 229              (not (eobp))
 230              (re-search-forward "^(defun +\\([^ ]+\\)" nil t))
 231        (let ((name (buffer-substring (match-beginning 1)
 232                                      (match-end 1)))
 233              doc)
 234          (forward-sexp 1)               ; skip argument list
 235          (skip-chars-forward " \n\t")
 236          (when (eq ?\" (following-char)) ; doc string
 237                (setq doc (buffer-substring (point)
 238                                            (progn (forward-sexp 1)
 239                                                   (point)))))
 240          (skip-chars-forward " \n\t")
 241          (when (looking-at "(interactive")
 242                (if (null doc)
 243                    (message "No doc for %s" name))
 244                (princ (format
 245                        "(autoload '%s \"%s\" %s t)\n"
 246                        name file doc))))))))
 247 \f
 248 ;;;; Test psgml with sgmls test cases
 249
 250 (defun test-sgml (start)
 251   (interactive "p")
 252   (let (file
 253         (sgml-show-warnings t))
 254     (with-output-to-temp-buffer "*Testing psgml*"
 255       (while
 256           (progn
 257             (setq file (format "/ni/src/sgmls-1.1/test/test%03d.sgm"
 258                                start))
 259             (file-exists-p file))
 260         (princ (format "*** File test%03d ***\n" start))
 261         (find-file file)
 262         (condition-case errcode
 263             (progn
 264               (sgml-parse-prolog)
 265               ;;(sgml-next-trouble-spot)
 266               (sgml-parse-until-end-of nil))
 267           (error
 268            (princ errcode)
 269            (terpri)))
 270         (if (get-buffer sgml-log-buffer-name)
 271             (princ (save-excursion
 272                      (set-buffer sgml-log-buffer-name)
 273                      (buffer-string))))
 274         (terpri)
 275         (terpri)
 276         (sit-for 0)
 277         (kill-buffer (current-buffer))
 278         (setq start (1+ start))))))
 279
 280 \f
 281 ;;;; Profiling
 282
 283 (defun profile-sgml (&optional file)
 284   (interactive)
 285   (or file (setq file (expand-file-name "~/work/sigmalink/BBB/config/configspec.xml")))
 286   (find-file file)
 287   (sgml-need-dtd)
 288   (sgml-instrument-parser)
 289   (elp-reset-all)
 290   (dotimes (i 5)
 291     (garbage-collect)
 292     (sgml-reparse-buffer (function sgml-handle-shortref)))
 293   (elp-results))
 294
 295 (defun sgml-instrument-parser ()
 296   (interactive)
 297   (require 'elp)
 298   (setq elp-function-list nil)
 299   (elp-restore-all)
 300   (setq elp-function-list
 301         '(
 302           sgml-parse-to
 303           sgml-parser-loop
 304           sgml-parse-markup-declaration
 305           sgml-do-processing-instruction
 306           sgml-pop-entity
 307           sgml-tree-net-enabled
 308           sgml-do-end-tag
 309           sgml-do-data
 310           sgml-deref-shortmap
 311           sgml-handle-shortref
 312           sgml-do-start-tag
 313           sgml-do-general-entity-ref
 314           sgml-set-face-for
 315           sgml-pcdata-move
 316           sgml-shortmap-skipstring
 317           ;;
 318           sgml-parse-attribute-specification-list
 319           sgml-check-tag-close
 320           sgml-do-move
 321           sgml-open-element
 322           sgml-list-implications
 323           sgml-move-current-state
 324           sgml-do-empty-start-tag
 325           sgml-lookup-eltype
 326           sgml-startnm-char-next
 327           sgml-eltype-defined
 328           sgml-execute-implied
 329           sgml-next-sub-and
 330           sgml-get-and-move
 331           format
 332           ))
 333   (elp-instrument-list))
 334
 335
 336 (defun sgml-instrument-dtd-parser ()
 337   (interactive)
 338   (require 'elp)
 339   (setq elp-function-list nil)
 340   (elp-restore-all)
 341   (setq elp-function-list
 342         '(
 343           sgml-parse-prolog
 344           sgml-skip-ds
 345           sgml-parse-markup-declaration
 346           sgml-check-doctype-body
 347           ;;
 348           sgml-check-dtd-subset
 349           sgml-parse-ds
 350           sgml-declare-attlist
 351           sgml-declare-entity
 352           sgml-declare-element
 353           sgml-declare-shortref
 354           ;;
 355           sgml-parse-parameter-literal
 356           sgml-check-element-type
 357           sgml-check-primitive-content-token
 358           sgml-check-model-group
 359           ;; In sgml-check-model-group
 360           sgml-parse-modifier
 361           sgml-make-pcdata
 362           sgml-skip-ts
 363           sgml-make-opt
 364           sgml-make-*
 365           sgml-make-+
 366           sgml-reduce-,
 367           sgml-reduce-|
 368           sgml-make-&
 369           sgml-make-conc
 370           sgml-copy-moves
 371           ;; is ps*
 372           sgml-do-parameter-entity-ref
 373           ;;
 374           sgml-make-primitive-content-token
 375           sgml-push-to-entity
 376           sgml-lookup-entity
 377           sgml-lookup-eltype
 378           sgml-one-final-state
 379           sgml-remove-redundant-states-1
 380           ))
 381   (elp-instrument-list))
 382 \f
 383 ;;;; Structure Viewing and Navigating
 384
 385 (require 'psgml-api)
 386
 387 (defvar show-structure-buffer nil)
 388 (defvar show-structure-positions nil)
 389 (defvar show-structure-source-buffer nil)
 390
 391 (defun show-structure ()
 392   (interactive)
 393   (let* ((source (current-buffer))
 394          (result (get-buffer-create "*Struct*"))
 395          (show-structure-buffer result))
 396     (set-buffer result)
 397     (erase-buffer)
 398     (make-local-variable 'show-structure-positions)
 399     (setq show-structure-positions nil)
 400     (make-local-variable 'show-structure-source-buffer)
 401     (setq show-structure-source-buffer source)
 402     (use-local-map (make-sparse-keymap))
 403     (local-set-key "\C-c\C-c" 'show-structure-goto)
 404     (set-buffer source)
 405     (show-element (sgml-top-element))
 406     (display-buffer result)))
 407
 408
 409 (defun show-structure-goto ()
 410   (interactive)
 411   (beginning-of-line)
 412   (let ((pos-pair (assoc (point) show-structure-positions)))
 413     (when pos-pair
 414       (select-window
 415        (display-buffer show-structure-source-buffer))
 416       (goto-char (cdr pos-pair)))))
 417
 418
 419 (defun show-struct-element-p (element)
 420   (or (and (not (sgml-element-data-p element))
 421            (not (sgml-element-empty element)))
 422       (sgml-element-appdata element 'structure)))
 423
 424
 425 (defun show-element (element)
 426   (cond ((show-struct-element-p element)
 427          (let ((gi (sgml-element-gi element))
 428                (level (sgml-element-level element)))
 429            (save-excursion
 430              (set-buffer show-structure-buffer)
 431              (if (not (bolp))
 432                  (insert "\n"))
 433              (push (cons (point) (sgml-element-start element))
 434                    show-structure-positions)
 435              (insert (format "%s[%15s] " (make-string (- level 1) ? ) gi))))
 436          (catch 'show-data-stop
 437              (show-element-data element))
 438          (sgml-map-content element #'show-element))))
 439
 440 (defun show-element-data (element)
 441   (sgml-map-content element #'show-element-data #'show-data)
 442   (throw 'show-data-stop nil))
 443
 444 (defun show-data (data)
 445   (save-excursion
 446     (set-buffer show-structure-buffer)
 447     (let ((start (point)))
 448       (insert data)
 449       (let ((end (point)))
 450         (subst-char-in-region start end ?\n ? )
 451         (when (> (current-column) fill-column)
 452           (move-to-column fill-column)
 453           (delete-region (point) end)
 454           (throw 'show-data-stop nil))))))
 455 \f
 456 ;;;; Show current element type
 457 ;; Candidate for C-c C-t
 458
 459 (autoload 'sgml-princ-names "psgml-info")
 460 (autoload 'sgml-eltype-refrenced-elements "psgml-info")
 461
 462 (define-key sgml-mode-map "\C-c\C-t" 'sgml-show-current-element-type)
 463
 464 (defun sgml-show-current-element-type ()
 465   (interactive)
 466   (let* ((el (sgml-find-context-of (point)))
 467          (et (sgml-element-eltype el)))
 468     (with-output-to-temp-buffer "*Current Element Type*"
 469       (princ (format "ELEMENT: %s%s\n" (sgml-eltype-name et)
 470                      (let ((help-text (sgml-eltype-appdata et 'help-text)))
 471                        (if help-text
 472                            (format " -- %s" help-text)
 473                            ""))))
 474       (when sgml-omittag
 475         (princ (format "\n Start-tag is %s.\n End-tag is %s.\n"
 476                        (if (sgml-eltype-stag-optional et)
 477                            "optional" "required")
 478                        (if (sgml-eltype-etag-optional et)
 479                            "optional" "required"))))
 480       ;; ----
 481       (princ "\nCONTENT: ")
 482       (cond ((symbolp (sgml-eltype-model et)) (princ (sgml-eltype-model et)))
 483             (t
 484              (princ (if (sgml-eltype-mixed et)
 485                         "mixed\n"
 486                       "element\n"))
 487              (sgml-print-position-in-model el et (point) sgml-current-state)
 488              (princ "\n\n")
 489              (sgml-princ-names
 490               (mapcar #'symbol-name (sgml-eltype-refrenced-elements et))
 491               "All: ")))
 492       (let ((incl (sgml-eltype-includes et))
 493             (excl (sgml-eltype-excludes et)))
 494         (when (or incl excl)
 495           (princ "\n\nEXCEPTIONS:"))
 496         (when incl
 497           (princ "\n + ")
 498           (sgml-princ-names (mapcar #'symbol-name incl)))
 499         (when excl
 500           (princ "\n - ")
 501           (sgml-princ-names (mapcar #'symbol-name excl))))
 502       ;; ----
 503       (princ "\n\nATTRIBUTES:\n")
 504       (sgml-print-attlist et)
 505       ;; ----
 506       (let ((s (sgml-eltype-shortmap et)))
 507         (when s
 508           (princ (format "\nUSEMAP: %s\n" s))))
 509       ;; ----
 510       (princ "\nOCCURS IN:\n")
 511       (let ((occurs-in ()))
 512         (sgml-map-eltypes
 513          (function (lambda (cand)
 514                      (when (memq et (sgml-eltype-refrenced-elements cand))
 515                        (push cand occurs-in))))
 516          (sgml-pstate-dtd sgml-buffer-parse-state))
 517         (sgml-princ-names (mapcar 'sgml-eltype-name
 518                                   (sort occurs-in (function string-lessp))))))))
 519
 520 (defun sgml-print-attlist (et)
 521   (let ((ob (current-buffer)))
 522     (set-buffer standard-output)
 523     (unwind-protect
 524         (loop
 525          for attdecl in (sgml-eltype-attlist et) do
 526          (princ " ")
 527          (princ (sgml-attdecl-name attdecl))
 528          (let ((dval (sgml-attdecl-declared-value attdecl))
 529                (defl (sgml-attdecl-default-value attdecl)))
 530            (when (listp dval)
 531              (setq dval (concat (if (eq (first dval)
 532                                         'NOTATION)
 533                                     "#NOTATION (" "(")
 534                                 (mapconcat (function identity)
 535                                            (second dval)
 536                                            "|")
 537                                 ")")))
 538            (indent-to 15 1)
 539            (princ dval)
 540            (cond ((sgml-default-value-type-p 'FIXED defl)
 541                   (setq defl (format "#FIXED '%s'"
 542                                      (sgml-default-value-attval defl))))
 543                  ((symbolp defl)
 544                   (setq defl (upcase (format "#%s" defl))))
 545                  (t
 546                   (setq defl (format "'%s'"
 547                                      (sgml-default-value-attval defl)))))
 548
 549            (indent-to 48 1)
 550            (princ defl)
 551            (terpri)))
 552       (set-buffer ob))))
 553
 554
 555 (defun sgml-print-position-in-model (element element-type buffer-pos parse-state)
 556   (let ((u (sgml-element-content element))
 557         (names nil))
 558     (while (and u (>= buffer-pos (sgml-element-end u)))
 559       (push (sgml-element-gi u) names)
 560       (setq u (sgml-element-next u)))
 561     (when names
 562       (sgml-princ-names (nreverse names) " " ", ")
 563       (princ "\n")))
 564   (princ " ->")
 565   (let* ((state parse-state)
 566          (required-seq                  ; the seq of req el following point
 567           (loop for required = (sgml-required-tokens state)
 568                 while (and required (null (cdr required)))
 569                 collect (sgml-eltype-name (car required))
 570                 do (setq state (sgml-get-move state (car required)))))
 571          (last-alt
 572           (mapcar 'sgml-eltype-name
 573                   (append (sgml-optional-tokens state)
 574                           (sgml-required-tokens state)))))
 575     (cond
 576      (required-seq
 577       (when last-alt
 578         (nconc required-seq
 579                (list (concat "("
 580                              (mapconcat (lambda (x) x)
 581                                         last-alt " | ")
 582                              (if (sgml-final state)
 583                                  ")?" ")")))))
 584       (sgml-princ-names required-seq " " ", "))
 585
 586      (last-alt
 587       (sgml-princ-names last-alt " (" " | ")
 588       (princ ")")
 589       (when (sgml-final state)
 590         (princ "?"))))))
 591 \f
 592 ;;;; Adding appdata to element types
 593 ;;; Candidate for PI PSGML processing
 594
 595 (defvar sgml-psgml-pi-enable-outside-dtd nil)
 596
 597 (defun sgml-eval-psgml-pi ()
 598   (interactive)
 599   (let ((sgml-psgml-pi-enable-outside-dtd t))
 600     (sgml-parse-to-here)))
 601
 602 (define-key sgml-mode-map "\e\C-x" 'sgml-eval-psgml-pi)
 603
 604 (defun sgml--pi-element-handler ()
 605   (sgml-skip-ps)
 606   (let ((eltype (sgml-lookup-eltype (sgml-parse-name)))
 607         name value)
 608     (sgml-skip-ps)
 609     (while (setq name (sgml-parse-name))
 610       ;; FIXME: check name not reserved
 611       (sgml-skip-ps)
 612       (cond ((sgml-parse-delim "VI")
 613              (sgml-skip-ps)
 614              (setq value
 615                    (if (looking-at "['\"]")
 616                        (sgml-parse-literal)
 617                      (read (current-buffer)))))
 618             (t
 619              (setq value t)))
 620       (message "%s = %S" name value)
 621       (setf (sgml-eltype-appdata eltype (intern (downcase name))) value)
 622       (sgml-skip-ps))))
 623
 624
 625 (defun sgml-do-processing-instruction (in-declaration)
 626   (let ((start (point)))
 627     (when (and (or in-declaration
 628                    sgml-psgml-pi-enable-outside-dtd)
 629                (eq ?P (following-char))
 630                (looking-at "PSGML +\\(\\sw+\\) *"))
 631       (let* ((command (format "%s" (downcase (match-string 1))))
 632              (flag-command (assoc command
 633                                   '(("nofill"      . nofill)
 634                                     ("breakafter"  . break-after-stag)
 635                                     ("breakbefore" . break-before-stag)
 636                                     ("structure"   . structure)))))
 637         (goto-char (match-end 0))
 638         (cond (flag-command
 639                (sgml-parse-set-appflag (cdr flag-command)))
 640               ((equal command "element")
 641                (sgml--pi-element-handler))
 642               (t
 643                (sgml-log-warning "Unknown processing instruction for PSGML: %s"
 644                                  command)))))
 645     (if sgml-xml-p
 646         (sgml-skip-upto "XML-PIC")
 647       (sgml-skip-upto "PIC"))
 648     (when sgml-pi-function
 649       (funcall sgml-pi-function
 650                (buffer-substring-no-properties start (point)))))
 651   (if sgml-xml-p
 652       (sgml-check-delim "XML-PIC")
 653     (sgml-check-delim "PIC"))
 654   (unless in-declaration
 655     (sgml-set-markup-type 'pi))
 656   t)
 657
 658 ;;;; Possible modification to allow setting face on content:
 659
 660 (defun sgml-set-face-for (start end type)
 661   (let ((face (cdr (assq type sgml-markup-faces))))
 662     ;;++
 663     (if (and (null type) sgml-current-tree)
 664         (setq face (sgml-element-appdata sgml-current-tree 'face)))
 665     ;;--
 666     (cond
 667      (sgml-use-text-properties
 668       (let ((inhibit-read-only t)
 669             (after-change-functions nil)
 670             (before-change-functions nil)
 671             (buffer-undo-list t)
 672             (deactivate-mark nil))
 673         (put-text-property start end 'face face)
 674         (when (< start end)
 675           (put-text-property (1- end) end 'rear-nonsticky '(face)))))
 676      (t
 677       (let ((current (overlays-at start))
 678             (pos start)
 679             old-overlay)
 680         (while current
 681           (cond ((and (null old-overlay)
 682                       type
 683                       (eq type (overlay-get (car current) 'sgml-type)))
 684                  (setq old-overlay (car current)))
 685                 ((overlay-get (car current) 'sgml-type)
 686                  ;;(message "delov: %s" (overlay-get (car current) 'sgml-type))
 687                  (delete-overlay (car current))))
 688           (setq current (cdr current)))
 689         (while (< (setq pos (next-overlay-change pos))
 690                   end)
 691           (setq current (overlays-at pos))
 692           (while current
 693             (when (overlay-get (car current) 'sgml-type)
 694               (delete-overlay (car current)))
 695             (setq current (cdr current))))
 696         (cond (old-overlay
 697                (move-overlay old-overlay start end)
 698                (if (null (overlay-get old-overlay 'face))
 699                    (overlay-put old-overlay 'face face)))
 700               (face
 701                (setq old-overlay (make-overlay start end))
 702                (overlay-put old-overlay 'sgml-type type)
 703                (overlay-put old-overlay 'face face))))))))
 704 \f
 705 ;;;; New Right Button Menu
 706
 707 (define-key sgml-mode-map [S-mouse-3] 'sgml-right-menu)
 708
 709 (defun sgml-right-menu (event)
 710   "Pop up a menu with valid tags and insert the choosen tag.
 711 If the variable sgml-balanced-tag-edit is t, also inserts the
 712 corresponding end tag. If sgml-leave-point-after-insert is t, the point
 713 is left after the inserted tag(s), unless the element has som required
 714 content.  If sgml-leave-point-after-insert is nil the point is left
 715 after the first tag inserted."
 716   (interactive "*e")
 717   (let ((end (sgml-mouse-region)))
 718     (sgml-parse-to-here)
 719     (cond
 720      ((eq sgml-markup-type 'start-tag)
 721       (sgml-right-stag-menu event))
 722      (t
 723       (let ((what
 724              (sgml-menu-ask event (if (or end sgml-balanced-tag-edit)
 725                                       'element 'tags))))
 726         (cond
 727          ((null what))
 728          (end
 729           (sgml-tag-region what (point) end))
 730          (sgml-balanced-tag-edit
 731           (sgml-insert-element what))
 732          (t
 733           (sgml-insert-tag what))))))))
 734
 735
 736 (defun sgml-right-stag-menu (event)
 737   (let* ((el (sgml-find-attribute-element))
 738          (attrib-menu (ignore-errors (sgml-make-attrib-menu el))))
 739
 740     (let* ((alt-gi (mapcar (function sgml-eltype-name)
 741                            (progn
 742                              (sgml-find-context-of (sgml-element-start el))
 743                              (sgml-current-list-of-valid-eltypes))))
 744            (change-menu
 745             (cons "Change To"
 746                   (loop for gi in alt-gi
 747                         collect `(,gi (sgml-change-element-name ,gi))))))
 748       (sgml-popup-multi-menu
 749        event "Start Tag"
 750        (list* change-menu
 751              `("Misc"
 752                ("Edit attributes" (sgml-edit-attributes))
 753                ("Normalize" (sgml-normalize-element))
 754                ("Fill" (sgml-fill-element
 755                         (sgml-find-context-of (point))))
 756                ("Splice" (sgml-untag-element))
 757                ("Fold"   (sgml-fold-element)))
 758              `("--" "--")
 759              attrib-menu)))))
 760
 761
 762
 763 \f
 764 (defun sgml--empty-is-nil (s)
 765   (if (equal s "")
 766       nil
 767     s))
 768
 769 (defun sgml-dl-to-table (border table-width first-col-width)
 770   (interactive "sBoder: \nsTab Width: \nsFist Col Width: \n")
 771   (setq border (sgml--empty-is-nil border))
 772   (setq table-width (sgml--empty-is-nil table-width))
 773   (setq first-col-width (sgml--empty-is-nil first-col-width))
 774   (let ((el (sgml-find-element-of (point))))
 775     (goto-char (sgml-element-etag-start el))
 776     (let ((end (point-marker)))
 777       (goto-char (sgml-element-start el))
 778       (sgml-change-element-name "TABLE")
 779       (sgml-insert-attribute "BORDER" border)
 780       (sgml-insert-attribute "WIDTH" table-width)
 781       (while (search-forward "<" end t)
 782         (cond
 783          ((looking-at "dt")
 784           (backward-char 1)
 785           (insert "<tr>")
 786           (sgml-change-element-name "TD")
 787           (sgml-insert-attribute "WIDTH" first-col-width))
 788          ((looking-at "tr>\\s-*<td")
 789           (sgml-down-element)
 790           (sgml-insert-attribute "WIDTH" first-col-width))
 791          ((looking-at "dd")
 792           (sgml-change-element-name "TD")
 793           (sgml-up-element)
 794           (insert "</tr>")))))))
 795
 796 \f
 797 ;¤¤\end{codeseg}