--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/psgml/psgml-xemacs.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,363 @@
+;;;; psgml-xemacs.el --- Part of SGML-editing mode with parsing support
+;; $Id: psgml-xemacs.el,v 1.1.1.1 1996/12/18 03:35:23 steve Exp $
+
+;; Copyright (C) 1994 Lennart Staflin
+
+;; Author: Lennart Staflin <lenst@lysator.liu.se>
+;;	   William M. Perry <wmperry@indiana.edu>
+
+;; 
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License
+;; as published by the Free Software Foundation; either version 2
+;; of the License, or (at your option) any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;;; Commentary:
+
+;;; Part of psgml.el
+
+;;; Menus for use with XEmacs
+
+
+;;;; Code:
+
+(require 'psgml)
+;;(require 'easymenu)
+
+(eval-and-compile
+  (autoload 'sgml-do-set-option "psgml-edit"))
+
+(defvar sgml-max-menu-size (/ (* (frame-height) 2) 3)
+  "*Max number of entries in Tags and Entities menus before they are split
+into several panes.")
+
+;;;; Pop Up Menus
+
+(defun sgml-popup-menu (event title entries)
+  "Display a popup menu."
+  (setq entries
+	(loop for ent in entries collect
+	      (vector (car ent)
+		      (list 'setq 'value (list 'quote (cdr ent)))
+		      t)))
+  (cond ((> (length entries) sgml-max-menu-size)
+	 (setq entries
+	       (loop for i from 1 while entries collect
+		     (let ((submenu
+			    (subseq entries 0 (min (length entries)
+						   sgml-max-menu-size))))
+		       (setq entries (nthcdr sgml-max-menu-size
+					     entries))
+		       (cons
+			(format "%s '%s'-'%s'"
+				title
+				(sgml-range-indicator (aref (car submenu) 0))
+				(sgml-range-indicator
+				 (aref (car (last submenu)) 0)))
+			submenu))))))
+  (sgml-xemacs-get-popup-value (cons title entries)))
+
+
+(defun sgml-range-indicator (string)
+  (substring string
+	     0
+	     (min (length string) sgml-range-indicator-max-length)))
+
+
+(defun sgml-xemacs-get-popup-value (menudesc)
+  (let ((value nil)
+	(event nil))
+    (popup-menu menudesc)
+    (while (popup-menu-up-p)
+      (setq event (next-command-event event))
+      (cond ((menu-event-p event)
+	     (cond
+	      ((eq (event-object event) 'abort)
+	       (signal 'quit nil))
+	      ((eq (event-object event) 'menu-no-selection-hook)
+	       nil)
+	      (t
+	       (eval (event-object event)))))
+	    ((button-release-event-p event) ; don't beep twice
+	     nil)
+	    ((and (fboundp 'event-matches-key-specifier-p)
+		  (event-matches-key-specifier-p event (quit-char)))
+	     (signal 'quit nil))
+	    (t
+	     (beep)
+	     (message "please make a choice from the menu."))))
+    value))
+
+(defun sgml-popup-multi-menu (pos title menudesc)
+  "Display a popup menu.
+MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...).
+ITEM should have to form (STRING EXPR) or STRING.  The EXPR gets evaluated
+if the item is selected."
+  (popup-menu
+   (cons title
+	 (loop for menu in menudesc collect
+	       (cons (car menu)		; title
+		     (loop for item in (cdr menu) collect
+			   (if (stringp item)
+			       item
+			     (vector (car item) (cadr item) t))))))))
+
+
+;;;; XEmacs menu bar
+
+(defvar sgml-dtd-menu
+  '("DTD"
+    ["Parse DTD" sgml-parse-prolog t]
+    ("Info"
+	 ["Describe element type"	sgml-describe-element-type	t]
+	 ["Describe entity"		sgml-describe-entity		t]
+	 ["List elements" 		sgml-list-elements 		t]
+	 ["List attributes" 		sgml-list-attributes 		t]
+	 ["List terminals" 		sgml-list-terminals 		t]
+	 ["List content elements" 	sgml-list-content-elements 	t]
+	 ["List occur in elements" 	sgml-list-occur-in-elements 	t]
+	 )
+    "---"
+    ["Load Parsed DTD" sgml-load-dtd t]
+    ["Save Parsed DTD" sgml-save-dtd t]
+    ))
+
+(defvar sgml-fold-menu
+  '("Fold"
+    ["Fold Element" sgml-fold-element t]
+    ["Fold Subelement" sgml-fold-subelement t]
+    ["Fold Region" sgml-fold-region t]
+    ["Unfold Line" sgml-unfold-line t]
+    ["Unfold Element" sgml-unfold-element t]
+    ["Unfold All" sgml-unfold-all t]
+    ["Expand" sgml-expand-element t]
+    ))
+
+(defvar sgml-markup-menu
+  '("Markup"
+    ["Insert Element" (sgml-element-menu last-command-event) t]
+    ["Insert Start-Tag" (sgml-start-tag-menu last-command-event) t]
+    ["Insert End-Tag" (sgml-end-tag-menu last-command-event) t]
+    ["Tag Region" (sgml-tag-region-menu last-command-event) t]
+    ["Insert Attribute" (sgml-attrib-menu last-command-event) t]
+    ["Insert Entity" (sgml-entities-menu last-command-event) t]
+    ))
+
+(defvar
+ sgml-move-menu
+ '("Move"
+   ["Next trouble spot" sgml-next-trouble-spot t]
+   ["Next data field"   sgml-next-data-field   t]
+   ["Forward element"	sgml-forward-element t]
+   ["Backward element"  sgml-backward-element t]
+   ["Up element"	sgml-up-element t]
+   ["Down element"	sgml-down-element t]
+   ["Backward up element" sgml-backward-up-element t]
+   ["Beginning of element" sgml-beginning-of-element t]
+   ["End of element"	sgml-end-of-element t]
+   )
+ "Menu of move commands"
+ )
+
+(defvar
+ sgml-modify-menu
+ '("Modify"
+   ["Normalize"			sgml-normalize	t]
+   ["Expand All Short References"	sgml-expand-all-shortrefs t]
+   ["Expand Entity Reference"	sgml-expand-entity-reference t]
+   ["Normalize Element"		sgml-normalize-element t]
+   ["Make Character Reference"	sgml-make-character-reference t]
+   ["Unmake Character Reference"	(sgml-make-character-reference t) t]
+   ["Fill Element"		sgml-fill-element t]
+   ["Change Element Name..."	sgml-change-element-name t]
+   ["Edit Attributes..."	sgml-edit-attributes t]
+   ["Kill Markup"		sgml-kill-markup t]
+   ["Kill Element"		sgml-kill-element t]
+   ["Untag Element"		sgml-untag-element t]
+   ["Decode Character Entities"  sgml-charent-to-display-char t]
+   ["Encode Characters"		sgml-display-char-to-charent t]
+   )
+ "Menu of modification commands"
+ )
+
+(defun sgml-make-options-menu (vars)
+  (loop for var in vars 
+	for type = (sgml-variable-type var)
+	for desc = (sgml-variable-description var)
+	collect
+	(cond
+	 ((eq type 'toggle)
+	  (vector desc (list 'setq var (list 'not var))
+		  ':style 'toggle ':selected var))
+	 ((consp type)
+	  (cons desc
+		(loop for c in type collect
+		      (if (atom c)
+			  (vector (prin1-to-string c)
+				  (`(setq (, var) (, c)))
+				  :style 'toggle
+				  :selected (`(eq (, var) '(, c))))
+			(vector (car c)
+				(`(setq (, var) '(,(cdr c))))
+				:style 'toggle
+				:selected (`(eq (, var) '(,(cdr c)))))))))
+	 (t
+	  (vector desc
+		  (`(sgml-do-set-option '(, var)))
+		  t)))))
+
+(defvar sgml-sgml-menu
+  (append
+   '("SGML"
+     ["Reset Buffer"  normal-mode t]
+     ["Show Context" sgml-show-context t]
+     ["What Element" sgml-what-element t]
+     ["Show Valid Tags" sgml-list-valid-tags t]
+     ["Show/Hide Warning Log" sgml-show-or-clear-log t]
+     ["Validate" sgml-validate t])
+   (if (or (not (boundp 'emacs-major-version))
+	   (and (boundp 'emacs-minor-version)
+		(< emacs-minor-version 10)))
+       '(
+	 ["File Options" sgml-file-options-menu t]
+	 ["User Options" sgml-user-options-menu t]
+	 )
+     (list
+      (cons "File Options" (sgml-make-options-menu sgml-file-options))
+      (cons "User Options" (sgml-make-options-menu sgml-user-options))))
+   '(["Save File Options" sgml-save-options t]
+     ["Submit Bug Report" sgml-submit-bug-report t]
+     )))
+
+(defun sgml-install-xemacs-menus ()
+  "Install xemacs menus for psgml mode"
+  (set-buffer-menubar (copy-sequence current-menubar))
+  (add-menu nil (car sgml-sgml-menu) (cdr sgml-sgml-menu))
+  (add-menu nil (car sgml-markup-menu) (copy-sequence (cdr sgml-markup-menu)))
+  (add-menu nil (car sgml-modify-menu) (cdr sgml-modify-menu))
+  (add-menu nil (car sgml-move-menu) (cdr sgml-move-menu))
+  (add-menu nil (car sgml-fold-menu) (cdr sgml-fold-menu))
+  (add-menu nil (car sgml-dtd-menu) (cdr sgml-dtd-menu))
+)
+
+
+;;;; Custom menus
+
+(defun sgml-build-custom-menus ()
+  (and sgml-custom-markup (add-menu-item '("Markup") "------------" nil t
+					 "Insert Element"))
+  (mapcar (function
+	   (lambda (x)
+	     (add-menu-item '("Markup") (nth 0 x)
+			    (list 'sgml-insert-markup (nth 1 x))
+			    t
+			    "------------")))
+	  sgml-custom-markup)
+  (and sgml-custom-dtd (add-menu-item '("DTD") "-------------" nil t))
+  (mapcar (function
+	   (lambda (x)
+	     (add-menu-item '("DTD") (nth 0 x)
+			    (list 'apply ''sgml-doctype-insert
+				  (cadr x)
+				  (list 'quote (cddr x)))
+			    t)))
+	  sgml-custom-dtd))
+
+
+;;;; Key definitions
+
+(define-key sgml-mode-map [button3] 'sgml-tags-menu)
+
+
+;;;; Insert with properties
+
+(defun sgml-insert (props format &rest args)
+  (let ((start (point))
+	tem)
+    (insert (apply (function format)
+		   format
+		   args))
+    (remf props 'rear-nonsticky)	; not useful in XEmacs
+
+    ;; Copy face prop from category
+    (when (setq tem (getf props 'category))
+      (when (setq tem (get tem 'face))
+	  (set-face-underline-p (make-face 'underline) t)
+	  (setf (getf props 'face) tem)))
+
+    (add-text-properties start (point) props)
+
+    ;; A read-only value of 1 is used for the text after values
+    ;; and this should in XEmacs be open at the front.
+    (if (eq 1 (getf props 'read-only))
+	(set-extent-property
+	 (extent-at start nil 'read-only)
+	 'start-open t))))
+
+
+;;;; Set face of markup
+
+(defun sgml-set-face-for (start end type)
+  (let ((face (cdr (assq type sgml-markup-faces)))
+	o)
+    (loop for e being the extents from start to end
+	  do (when (extent-property e 'type)
+	       (cond ((and (null o)
+			   (eq type (extent-property e 'type)))
+		      (setq o e))
+		     (t (delete-extent e)))))
+
+    (cond (o
+	   (set-extent-endpoints o start end))
+	  (face
+	   (setq o (make-extent start end))
+	   (set-extent-property o 'type type)
+	   (set-extent-property o 'face face)
+	   (set-extent-face o face)))))
+
+(defun sgml-set-face-after-change (start end &optional pre-len)
+  (when sgml-set-face
+    (let ((o (extent-at start nil 'type)))
+      (cond
+       ((null o))
+       ((= start (extent-start-position o))
+	(set-extent-endpoints o end (extent-end-position o)))
+       (t (delete-extent o))))))
+
+;(defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el
+
+(defun sgml-clear-faces ()
+  (interactive)
+  (loop for o being the overlays
+	if (extent-property o 'type)
+	do (delete-extent o)))
+
+
+;;;; Functions not in XEmacs
+
+(unless (fboundp 'frame-width)
+  (defalias 'frame-width 'screen-width))
+
+(unless (fboundp 'frame-height)
+  (defalias 'frame-height 'screen-height))
+
+(unless (fboundp 'buffer-substring-no-properties)
+  (defalias 'buffer-substring-no-properties 'buffer-substring))
+
+
+;;;; Provide
+
+(provide 'psgml-xemacs)
+
+
+;;; psgml-xemacs.el ends here