xemacs-beta: lisp/psgml/psgml-edit.el comparison

comparison lisp/psgml/psgml-edit.el @ 2:ac2d302a0011 r19-15b2

Import from CVS: tag r19-15b2

author	cvs
date	Mon, 13 Aug 2007 08:46:35 +0200
parents	376386a54a3c
children	ec9a17fef872

comparison

equal deleted inserted replaced

-:c0c6a60d29db
+:ac2d302a0011
 ;;; psgml-edit.el --- Editing commands for SGML-mode with parsing support
-;; $Id: psgml-edit.el,v 1.1.1.1 1996/12/18 03:35:19 steve Exp $
+;;-*-byte-compile-warnings:(free-vars unused-vars unresolved callargs redefine)-*-
+;; $Id: psgml-edit.el,v 1.1.1.2 1996/12/18 03:47:14 steve Exp $
 ;; Copyright (C) 1994, 1995, 1996 Lennart Staflin
 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
 ;;;; Code:
 (provide 'psgml-edit)
 (require 'psgml)
 (require 'psgml-parse)
+(require 'tempo)
 ;;;; Variables
 (defvar sgml-split-level nil
 (defun sgml-down-element ()
 "Move forward and down one level in the element structure."
 (interactive)
 (let ((to
 	 (sgml-find-element-after (point) (sgml-last-element))))
+(when (sgml-strict-epos-p (sgml-element-stag-epos to))
+(error "Sub-element in other entity"))
 (goto-char (sgml-element-stag-end to))
 (sgml-set-last-element (if (sgml-element-empty to)
 			       (sgml-element-parent to)
 			     to))))
 	 (attspec (sgml-element-attribute-specification-list element))
 	 (oldattlist (sgml-element-attlist element)))
 (unless (sgml-element-empty element)
 (goto-char (sgml-element-end element))
 (delete-char (- (sgml-element-etag-len element)))
-(insert (sgml-end-tag-of gi)))
+(tempo-process-and-insert-string (sgml-end-tag-of gi)))
 (goto-char (sgml-element-start element))
 (delete-char (sgml-element-stag-len element))
-(insert (sgml-start-tag-of gi))
+(tempo-process-and-insert-string (sgml-start-tag-of gi))
 (forward-char -1)
 (let* ((newel (sgml-find-element-of (point)))
 	   (newattlist (sgml-element-attlist newel))
 	   (newasl (sgml-translate-attribute-specification-list
 		    attspec oldattlist newattlist)))
 (defun sgml-fold-subelement ()
 "Fold all elements current elements content, leaving the first lines visible.
 This uses the selective display feature."
 (interactive)
 (let* ((el (sgml-find-element-of (point)))
-	 (start (sgml-element-start el))
-	 (end (sgml-element-end el))
 	 (c (sgml-element-content el)))
 (while c
 (sgml-fold-region (sgml-element-start c)
 			(sgml-element-end c))
 (setq c (sgml-element-next c)))))
 	(goto-char here))		; insert normal tab insted)
 (when element
 	(sgml-with-parser-syntax
 	 (let ((stag (sgml-is-start-tag))
 	       (etag (sgml-is-end-tag)))
+	   ;; Wing change
 	   (when (and
 		  (not (member* (sgml-element-gi
 				 (if (or stag etag)
 				     (sgml-element-parent element)
 				   element))
 "Move forward to next point where something is amiss with the structure."
 (interactive)
 (push-mark)
 (sgml-note-change-at (point))		; Prune the parse tree
 (sgml-parse-to (point))
-(let ((sgml-last-trouble-spot (point))
+(let ((sgml-throw-on-warning 'trouble))
-	(sgml-throw-on-warning 'trouble))
 (or (catch sgml-throw-on-warning
 	  (sgml-parse-until-end-of nil t))
 	(message "Ok"))))
 (defun sgml-list-valid-tags ()
 "Display a list of the contextually valid tags."
 (interactive)
 (sgml-parse-to-here)
-(let ((model (sgml-element-model sgml-current-tree)))
+(let ((model (sgml-element-model sgml-current-tree))
+	(smap-name (sgml-lookup-shortref-name
+		    (sgml-dtd-shortmaps sgml-dtd-info)
+		    sgml-current-shortmap)))
 (with-output-to-temp-buffer "*Tags*"
 (princ (format "Current element: %s  %s\n"
 		     (sgml-element-name sgml-current-tree)
 		     (if (sgml-eltype-defined
 			  (sgml-element-eltype sgml-current-tree))
 			    "element")
 			   (t
 			    model))
 		     (if (eq model sgml-any)
 			 "[ANY]" "")))
+(when smap-name
+	(princ (format "Current short reference map: %s\n" smap-name)))
 (cond ((sgml-final-p sgml-current-state)
 	     (princ "Valid end-tags : ")
 	     (loop for e in (sgml-current-list-of-endable-eltypes)
 		   do (princ (sgml-end-tag-of e)) (princ " "))
 		    (sgml-element-context-string el)))))
 (defun sgml-what-element ()
 "Display what element is under the cursor."
 (interactive)
-(let ((el (sgml-find-element-of (point))))
+(let* ((pos (point))
+	 (nobol (eq (point) sgml-rs-ignore-pos))
+	 (sref (sgml-deref-shortmap sgml-current-shortmap nobol))
+	 (el nil))
+(goto-char pos)
+(setq el (sgml-find-element-of pos))
 (assert (not (null el)))
 (message "%s %s"
 	     (cond ((eq el sgml-top-tree)
 		    "outside document element")
 		   ((< (point) (sgml-element-stag-end el))
 		    "start-tag")
 		   ((>= (point) (sgml-element-etag-start el))
 		    "end-tag")
+		   (sref
+		    "shortref")
 		   (t
 		    "content"))
 	     (sgml-element-context-string el))))
 ;;;; SGML mode: keyboard inserting
 (cond ((bolp)
 	   (if (looking-at "^\\s-*$")
 	       (fixup-whitespace)))
 	  (t
 	   (insert "\n"))))
-(insert tag)
+(tempo-process-and-insert-string tag)
 (sgml-indent-line)
 (unless no-nl-after
 (save-excursion
 (unless (sgml-element-data-p (sgml-parse-to-here))
 	(unless (eolp)
 (region-beginning)
 (region-end)))
 (save-excursion
 (when (and element (not (equal element "")))
 (goto-char end)
-(insert (sgml-end-tag-of element))
+(tempo-process-and-insert-string (sgml-end-tag-of element))
 (goto-char start)
 (sgml-insert-tag (sgml-start-tag-of element)))))
 (defun sgml-insert-attributes (avl attlist)
 "Insert the attributes with values AVL and declarations ATTLIST.
 AVL should be a assoc list mapping symbols to strings."
-(let (name val dcl def tem)
+(let (name val dcl def)
 (loop for attspec in attlist do
 	  (setq name (sgml-attspec-name attspec)
 		val (cdr-safe (sgml-lookup-attspec name avl))
 		dcl (sgml-attdecl-declared-value attspec)
 		def (sgml-attdecl-default-value attspec))
 		 (equal val (sgml-default-value-attval def))))
 	   ;; No attribute name for token groups
 	   ((and sgml-minimize-attributes sgml-shorttag
 		 (member (sgml-general-case val)
 			 (sgml-declared-value-token-group dcl)))
-	    (insert " " val))
+	    (tempo-process-and-insert-string (concat " " val)))
 	   (t
-	    (insert " " name "=" (sgml-quote-attribute-value val)))))
+	    (tempo-process-and-insert-string (concat " " name "="))
+	    (insert (sgml-quote-attribute-value val)))))
 (when auto-fill-function
 (funcall auto-fill-function))))
 (defun sgml-quote-attribute-value (value)
 	  (mapcar (function (lambda (x) (cons (sgml-start-tag-of x) x)))
 		  (sgml-current-list-of-valid-eltypes))))
 	(t
 	 (sgml-message "%s" sgml-current-state)
 	 nil)))
+(defun sgml-element-endable-p ()
+(sgml-parse-to-here)
+(and (not (eq sgml-current-tree sgml-top-tree))
+(sgml-final-p sgml-current-state)))
 (defun sgml-insert-end-tag ()
 "Insert end-tag for the current open element."
 (interactive "*")
 (sgml-parse-to-here)
 	       (not (sgml-element-data-p sgml-current-tree)))
 (delete-horizontal-space)
 (unless (bolp)
 	(insert "\n")))
 (when (prog1 (bolp)
-	    (insert (if (eq t (sgml-element-net-enabled sgml-current-tree))
+	    (tempo-process-and-insert-string
-			"/"
+	      (if (eq t (sgml-element-net-enabled sgml-current-tree))
-		      ;; wing change: If there is more than one endable
+		  "/"
-		      ;; tag, we probably want the outermost one rather
+		;; wing change: If there is more than one endable
-		      ;; than the innermost one.  Thus, we end a </ul>
+		;; tag, we probably want the outermost one rather
-		      ;; even when a </li> is possible.
+		;; than the innermost one.  Thus, we end a </ul>
-		      (sgml-end-tag-of
+		;; even when a </li> is possible.
-		       (car (last (sgml-current-list-of-endable-eltypes)))))))
+		(sgml-end-tag-of
+		 (car (last (sgml-current-list-of-endable-eltypes)))))))
 (sgml-indent-line)))))
 (defun sgml-insert-start-tag (name asl attlist &optional net)
-(insert "<" name)
+(tempo-process-and-insert-string (concat "<" name))
 (sgml-insert-attributes asl attlist)
 (insert (if net "/" ">")))
 (defun sgml-change-start-tag (element asl)
 (let ((name (sgml-element-gi element))
 (setq sgml-split-level
 	(if (eq this-command last-command)
 	    (1+ sgml-split-level)
 	  0))
 (let ((u (sgml-find-context-of (point)))
-	(start (point-marker))
+	(start (point-marker)))
-	before)
 (loop repeat sgml-split-level do
 	  (goto-char (sgml-element-start u))
 	  (setq u (sgml-element-parent u)))
 ;; Verify that a new element can be started
 (unless (and (sgml-element-pstate u) ; in case of top element
 (insert "&" choice ";"))))
 (defun sgml-doctype-insert (doctype vars)
 "Insert string DOCTYPE (ignored if nil) and set variables in &rest VARS.
 VARS should be a list of variables and values.
-For backward compatibility a singel string instead of a variable is
+For backward compatibility a single string instead of a variable is
 assigned to sgml-default-dtd-file.
 All variables are made buffer local and are also added to the
 buffers local variables list."
 (when doctype
 (unless (bolp)
 (defun sgml-attrib-menu (event)
 "Pop up a menu of the attributes of the current element
 \(or the element whith start-tag before point)."
 (interactive "e")
-(let* ((el (sgml-find-attribute-element))
+(let ((menu (sgml-make-attrib-menu (sgml-find-attribute-element))))
-	 (attlist (sgml-non-fixed-attributes (sgml-element-attlist el)))
+(sgml-popup-multi-menu event "Attributes" menu)))
-	 tokens menu other)
+(defun sgml-make-attrib-menu (el)
+(let ((attlist (sgml-non-fixed-attributes (sgml-element-attlist el))))
 (or attlist
 	(error "No non-fixed attributes for element"))
-(setq menu
+(loop for attdecl in attlist
-	  (loop for attdecl in attlist
+	  for name = (sgml-attdecl-name attdecl)
-		for name = (sgml-attdecl-name attdecl)
+	  for defval = (sgml-attdecl-default-value attdecl)
-		for defval = (sgml-attdecl-default-value attdecl)
+	  for tokens = (or (sgml-declared-value-token-group
-		for tokens = (or (sgml-declared-value-token-group
+			    (sgml-attdecl-declared-value attdecl))
-				  (sgml-attdecl-declared-value attdecl))
+			   (sgml-declared-value-notation
-				 (sgml-declared-value-notation
+			    (sgml-attdecl-declared-value attdecl)))
-				  (sgml-attdecl-declared-value attdecl)))
+	  collect
-		collect
+	  (cons
-		(cons
+	   (sgml-attdecl-name attdecl)
-		 (sgml-attdecl-name attdecl)
+	   (nconc
-		 (nconc
+	    (if tokens
-		  (if tokens
+		(loop for val in tokens collect
-		      (loop for val in tokens collect
+		      (list val
-			    (list val
+			    (list 'sgml-insert-attribute name val)))
-				  (list 'sgml-insert-attribute name val)))
+	      (list
-		    (list
+	       (list "Set attribute value"
-		     (list "Set attribute value"
+		     (list 'sgml-insert-attribute
-			   (list 'sgml-insert-attribute
+			   (sgml-attdecl-name attdecl)
-				 (sgml-attdecl-name attdecl)
+			   (list 'sgml-read-attribute-value
-				 (list 'sgml-read-attribute-value
+				 (list 'quote attdecl)
-				       (list 'quote attdecl)
+				 (sgml-element-attval el name))))))
-				       (sgml-element-attval el name))))))
+	    (if (sgml-default-value-type-p 'required defval)
-		  (if (sgml-default-value-type-p 'required defval)
+		nil
-		      nil
+	      (list "--"
-		    (list "--"
+		    (list (if (sgml-default-value-type-p nil defval)
-			  (list (if (sgml-default-value-type-p nil defval)
+			      (format "Default: %s"
-				    (format "Default: %s"
+				      (sgml-default-value-attval defval))
-					    (sgml-default-value-attval defval))
+			    "#IMPLIED")
-				  "#IMPLIED")
+			  (list 'sgml-insert-attribute name nil))))))))
-				(list 'sgml-insert-attribute name nil))))))))
+)
-(sgml-popup-multi-menu event "Attributes" menu)))
 ;;;; SGML mode: Fill
 (defun sgml-fill-element (element)
 "Fill bigest enclosing element with mixed content.
 (sgml-with-parser-syntax
 (let ((asl nil)
 	 (al sgml-attlist))
 (while (not (eq ?> (following-char)))
 (sgml-parse-s)
-(let ((name (sgml-check-nametoken)))
+(sgml-check-nametoken)		; attribute name, should match head of al
-	 (forward-char 3)
+(forward-char 3)
-	 (unless (memq (get-text-property (point) 'category)
+(unless (memq (get-text-property (point) 'category)
-		       '(sgml-default sgml-fixed))
+		     '(sgml-default sgml-fixed))
-	   (push
+	 (push
-	    (sgml-make-attspec (sgml-attdecl-name (car al))
+	  (sgml-make-attspec (sgml-attdecl-name (car al))
-			       (sgml-extract-attribute-value
+			     (sgml-extract-attribute-value
-				(sgml-attdecl-declared-value (car al))))
+			      (sgml-attdecl-declared-value (car al))))
-	    asl))
+	  asl))
-	 (while (progn (beginning-of-line 2)
+(while (progn (beginning-of-line 2)
-		       (or (eolp)
+		     (or (eolp)
-			   (not (get-text-property (point) 'read-only))))))
+			 (not (get-text-property (point) 'read-only)))))
-					; was (eq t)
 (forward-line 1)
 (setq al (cdr al)))
 asl)))
 	  (goto-char (point-min))
 	  (while (re-search-forward sgml-tag-regexp nil t)
 	    (cond
 	     ((eq action 'hide)
 	      (let ((tag (downcase
-			  (buffer-substring (1+ (match-beginning 0))
+			  (buffer-substring-no-properties
-					    (match-beginning 1)))))
+			   (1+ (match-beginning 0))
+			   (match-beginning 2)))))
 		(if (or attr-p (not (member tag sgml-exposed-tags)))
 		    (add-text-properties
 		     (match-beginning markup-index) (match-end markup-index)
 		     (list 'invisible tagcount
 			   'rear-nonsticky '(invisible face))))))
 (t
 (delete-region sgml-markup-start (point))
 (sgml-entity-insert-text entity)
 (setq sgml-goal (point-max))	; May have changed size of buffer
 ;; now parse the entity text
-(goto-char (setq sgml-rs-ignore-pos sgml-markup-start))))))
+(setq sgml-rs-ignore-pos sgml-markup-start)
+(goto-char sgml-markup-start)))))
 (defun sgml-expand-shortref-to-entity (name)
 (let ((end (point))
 	(re-found nil)
 	before-change-function)
 (goto-char (min (point) (sgml-element-etag-start element)))
 (if (and (zerop (sgml-element-etag-len element))
 	       sgml-normalize-trims)
 	  (skip-chars-backward " \t\n\r"))
 (delete-char (sgml-tree-etag-len element))
-(save-excursion (insert (sgml-end-tag-of element))))))
+(save-excursion (tempo-process-and-insert-string (sgml-end-tag-of element))))))
 (defun sgml-make-character-reference (&optional invert)
 "Convert character after point into a character reference.
 If called with a numeric argument, convert a character reference back

Mercurial > hg > xemacs-beta

comparison lisp/psgml/psgml-edit.el @ 2:ac2d302a0011 r19-15b2