psgml / psgml-xemacs.el

Full commit
;;;; psgml-xemacs.el --- Part of SGML-editing mode with parsing support
;; $Id$

;; Copyright (C) 1994 Lennart Staflin

;; Author: Lennart Staflin <>
;;	   William M. Perry <>
;; Synced up with Ben Wing's changes for XEmacs 19.14 by
;;	   Steven L Baur <>

;; 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
;; 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)

  (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)))
  (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)
		       (setq entries (nthcdr sgml-max-menu-size
			(format "%s '%s'-'%s'"
				(sgml-range-indicator (aref (car submenu) 0))
				 (aref (car (last submenu)) 0)))
  (let ((response (get-popup-menu-response (cons title entries))))
    (if (misc-user-event-p response)
	(funcall (event-function response)
		 (event-object response))

(defun sgml-range-indicator (string)
  (substring string
	     (min (length string) sgml-range-indicator-max-length)))

(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."
   (cons title
	 (loop for menu in menudesc collect
	       (cons (car menu)		; title
		     (loop for item in (cdr menu) collect
			   (if (stringp item)
			     (vector (car item) (cadr item) t))))))))

;;;; XEmacs menu bar

(defun sgml-make-options-menu (vars)
  (loop for var in vars 
	for type = (sgml-variable-type var)
	for desc = (sgml-variable-description var)
	 ((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)))))))))
	  (vector desc
		  (`(sgml-do-set-option '(, var)))

(and (boundp 'emacs-major-version)
     (boundp 'emacs-minor-version)
     (or (> emacs-major-version 19) (> emacs-minor-version 9))
     (loop for ent on sgml-main-menu
	if (vectorp (car ent))
	do (cond
	    ((equal (aref (car ent) 0) "File Options >")
	     (setcar ent
		     (cons "File Options"
			   (sgml-make-options-menu sgml-file-options))))
	    ((equal (aref (car ent) 0) "User Options >")
	     (setcar ent
		     (cons "User Options"
			   (sgml-make-options-menu sgml-user-options)))))))

;;;; Key definitions

(define-key sgml-mode-map [button3] 'sgml-tags-menu)

;;;; Insert with properties

(defun sgml-insert (props format &rest args)
  (let ((start (point))
    (insert (apply (function format)
    (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))
	 (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)))
    (loop for e being the extents from start to end
	  do (when (extent-property e 'sgml-type)
	       (cond ((and (null o)
			   (eq type (extent-property e 'sgml-type)))
		      (setq o e))
		     (t (delete-extent e)))))

    (cond (o
	   (set-extent-endpoints o start end))
	   (setq o (make-extent start end))
	   (set-extent-property o 'sgml-type type)
	   (set-extent-property o 'face face)
	   (set-extent-property o 'start-open t)
	   (set-extent-face o face)))))

(defun sgml-set-face-after-change (start end &optional pre-len)
  ;; This should not be needed with start-open t
  (when sgml-set-face
    (let ((o (extent-at start nil 'sgml-type)))
       ((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 ()
  (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))

(defvar psgml-xemacs-load-hook nil
  "Hook run when psgml-xemacs is loaded.")

(run-hooks 'psgml-xemacs-load-hook)

;;;; Provide

(provide 'psgml-xemacs)

;;; psgml-xemacs.el ends here