cgit.sxemacs.org Git - packages/blob - xemacs-packages/psgml/psgml-xemacs.el

   1 ;;;; psgml-xemacs.el --- Part of SGML-editing mode with parsing support
   2 ;; $Id: psgml-xemacs.el,v 2.7 2002/04/25 20:50:27 lenst Exp $
   3
   4 ;; Copyright (C) 1994 Lennart Staflin
   5
   6 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
   7 ;;         William M. Perry <wmperry@indiana.edu>
   8 ;; Synced up with Ben Wing's changes for XEmacs 19.14 by
   9 ;;         Steven L Baur <steve@xemacs.org>
  10
  11 ;;
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License
  14 ;; as published by the Free Software Foundation; either version 2
  15 ;; of the License, or (at your option) any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program; if not, write to the Free Software
  24 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  25
  26 \f
  27 ;;;; Commentary:
  28
  29 ;;; Part of psgml.el
  30
  31 ;; XEmacs note: called psgml-lucid.el upstream.
  32
  33 ;;; Menus for use with XEmacs
  34
  35 \f
  36 ;;;; Code:
  37
  38 (require 'psgml)
  39 ;;(require 'easymenu)
  40
  41 (eval-and-compile
  42   (autoload 'sgml-do-set-option "psgml-edit"))
  43
  44 (defvar sgml-max-menu-size (/ (* (frame-height) 2) 3)
  45   "*Max number of entries in Tags and Entities menus before they are split
  46 into several panes.")
  47 \f
  48 ;;;; Pop Up Menus
  49
  50 (defun sgml-popup-menu (event title entries)
  51   "Display a popup menu."
  52   (setq entries
  53         (loop for ent in entries collect
  54               (vector (car ent)
  55                       (list 'setq 'value (list 'quote (cdr ent)))
  56                       t)))
  57   (cond ((> (length entries) sgml-max-menu-size)
  58          (setq entries
  59                (loop for i from 1 while entries collect
  60                      (let ((submenu
  61                             (subseq entries 0 (min (length entries)
  62                                                    sgml-max-menu-size))))
  63                        (setq entries (nthcdr sgml-max-menu-size
  64                                              entries))
  65                        (cons
  66                         (format "%s '%s'-'%s'"
  67                                 title
  68                                 (sgml-range-indicator (aref (car submenu) 0))
  69                                 (sgml-range-indicator
  70                                  (aref (car (last submenu)) 0)))
  71                         submenu))))))
  72   (let ((response (get-popup-menu-response (cons title entries))))
  73     (if (misc-user-event-p response)
  74         (funcall (event-function response)
  75                  (event-object response))
  76       nil)))
  77
  78
  79 (defun sgml-range-indicator (string)
  80   (substring string
  81              0
  82              (min (length string) sgml-range-indicator-max-length)))
  83
  84
  85 (defun sgml-popup-multi-menu (pos title menudesc)
  86   "Display a popup menu.
  87 MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...).
  88 ITEM should have to form (STRING EXPR) or STRING.  The EXPR gets evaluated
  89 if the item is selected."
  90   (popup-menu
  91    (cons title
  92          (loop for menu in menudesc collect
  93                (cons (car menu)         ; title
  94                      (loop for item in (cdr menu) collect
  95                            (if (stringp item)
  96                                item
  97                              (vector (car item) (cadr item) t))))))))
  98
  99 \f
 100 ;;;; XEmacs menu bar
 101
 102 (defun sgml-make-options-menu (vars)
 103   (loop for var in vars
 104         for type = (sgml-variable-type var)
 105         for desc = (sgml-variable-description var)
 106         collect
 107         (cond
 108          ((eq type 'toggle)
 109           (vector desc (list 'setq var (list 'not var))
 110                   ':style 'toggle ':selected var))
 111          ((consp type)
 112           (cons desc
 113                 (loop for c in type collect
 114                       (if (atom c)
 115                           (vector (prin1-to-string c)
 116                                   (`(setq (, var) (, c)))
 117                                   :style 'toggle
 118                                   :selected (`(eq (, var) '(, c))))
 119                         (vector (car c)
 120                                 (`(setq (, var) '(,(cdr c))))
 121                                 :style 'toggle
 122                                 :selected (`(eq (, var) '(,(cdr c)))))))))
 123          (t
 124           (vector desc
 125                   (`(sgml-do-set-option '(, var)))
 126                   t)))))
 127
 128
 129 (and (boundp 'emacs-major-version)
 130      (boundp 'emacs-minor-version)
 131      (or (> emacs-major-version 19) (> emacs-minor-version 9))
 132      (loop for ent on sgml-main-menu
 133         if (vectorp (car ent))
 134         do (cond
 135             ((equal (aref (car ent) 0) "File Options >")
 136              (setcar ent
 137                      (cons "File Options"
 138                            (sgml-make-options-menu sgml-file-options))))
 139             ((equal (aref (car ent) 0) "User Options >")
 140              (setcar ent
 141                      (cons "User Options"
 142                            (sgml-make-options-menu sgml-user-options)))))))
 143
 144 \f
 145 ;;;; Key definitions
 146
 147 (define-key sgml-mode-map [button3] 'sgml-tags-menu)
 148 ;; XEmacs addition (previously in psgml-debug, upstream: psgml-other)
 149 (define-key sgml-mode-map [(shift button3)] 'sgml-right-menu)
 150
 151 \f
 152 ;;;; Insert with properties
 153
 154 (defun sgml-insert (props format &rest args)
 155   (let ((start (point))
 156         tem)
 157     (insert (apply (function format)
 158                    format
 159                    args))
 160     (remf props 'rear-nonsticky)        ; not useful in XEmacs
 161
 162     ;; Copy face prop from category
 163     (when (setq tem (getf props 'category))
 164       (when (setq tem (get tem 'face))
 165           (set-face-underline-p (make-face 'underline) t)
 166           (setf (getf props 'face) tem)))
 167
 168     (add-text-properties start (point) props)
 169
 170     ;; A read-only value of 1 is used for the text after values
 171     ;; and this should in XEmacs be open at the front.
 172     (if (eq 1 (getf props 'read-only))
 173         (set-extent-property
 174          (extent-at start nil 'read-only)
 175          'start-open t))))
 176
 177 \f
 178 ;;;; Set face of markup
 179
 180 (defun sgml-set-face-for (start end type)
 181   (let ((face (cdr (assq type sgml-markup-faces)))
 182         o)
 183     (loop for e being the extents from start to end
 184           do (when (extent-property e 'sgml-type)
 185                (cond ((and (null o)
 186                            (eq type (extent-property e 'sgml-type)))
 187                       (setq o e))
 188                      (t (delete-extent e)))))
 189
 190     (cond (o
 191            (set-extent-endpoints o start end))
 192           (face
 193            (setq o (make-extent start end))
 194            (set-extent-property o 'sgml-type type)
 195            (set-extent-property o 'face face)
 196            (set-extent-property o 'start-open t)
 197            (set-extent-face o face)))))
 198
 199 (defun sgml-set-face-after-change (start end &optional pre-len)
 200   ;; This should not be needed with start-open t
 201   (when sgml-set-face
 202     (let ((o (extent-at start nil 'sgml-type)))
 203       (cond
 204        ((null o))
 205        ((= start (extent-start-position o))
 206         (set-extent-endpoints o end (extent-end-position o)))
 207        (t (delete-extent o))))))
 208
 209 ;(defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el
 210
 211 (defun sgml-clear-faces ()
 212   (interactive)
 213   (loop for o being the overlays
 214         if (extent-property o 'type)
 215         do (delete-extent o)))
 216
 217 \f
 218 ;;;; Functions not in XEmacs
 219
 220 (unless (fboundp 'frame-width)
 221   (defalias 'frame-width 'screen-width))
 222
 223 (unless (fboundp 'frame-height)
 224   (defalias 'frame-height 'screen-height))
 225
 226 (unless (fboundp 'buffer-substring-no-properties)
 227   (defalias 'buffer-substring-no-properties 'buffer-substring))
 228
 229 \f
 230 (defvar psgml-xemacs-load-hook nil
 231   "Hook run when psgml-xemacs is loaded.")
 232
 233 (run-hooks 'psgml-xemacs-load-hook)
 234
 235 ;;;; Provide
 236
 237 (provide 'psgml-xemacs)
 238
 239 \f
 240 ;;; psgml-xemacs.el ends here