site-lisp/psgml/psgml-other.el

   1 ;;;; psgml-other.el --- Part of SGML-editing mode with parsing support
   2 ;; $Id: psgml-other.el,v 2.22 2001/11/04 23:49:02 lenst Exp $
   3
   4 ;; Copyright (C) 1994 Lennart Staflin
   5
   6 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
   7
   8 ;;
   9 ;; This program is free software; you can redistribute it and/or
  10 ;; modify it under the terms of the GNU General Public License
  11 ;; as published by the Free Software Foundation; either version 2
  12 ;; of the License, or (at your option) any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, write to the Free Software
  21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 \f
  24 ;;;; Commentary:
  25
  26 ;;; Part of psgml.el. Code not compatible with XEmacs.
  27
  28 \f
  29 ;;;; Code:
  30
  31 (require 'psgml)
  32 (require 'easymenu)
  33 (eval-when-compile (require 'cl))
  34
  35 (defvar sgml-max-menu-size (/ (* (frame-height) 2) 3)
  36   "*Max number of entries in Tags and Entities menus before they are split
  37 into several panes.")
  38
  39 \f
  40 ;;;; Key Commands
  41
  42 ;; Doesn't this work in Lucid? ***
  43 (define-key sgml-mode-map [?\M-\C-\ ] 'sgml-mark-element)
  44
  45 (define-key sgml-mode-map [S-mouse-3] 'sgml-tags-menu)
  46
  47 \f
  48 ;;;; Pop Up Menus
  49
  50 (defun sgml-popup-menu (event title entries)
  51   "Display a popup menu.
  52 ENTRIES is a list where every element has the form (STRING . VALUE) or
  53 STRING."
  54   (let ((menus (sgml-split-long-menus (list (cons title entries)))))
  55     (x-popup-menu event (cons title menus))))
  56
  57
  58 (defun sgml-range-indicator (string)
  59   (substring string
  60              0
  61              (min (length string) sgml-range-indicator-max-length)))
  62
  63
  64 (defun sgml-split-long-menus (menus)
  65   (loop
  66    for (title . entries) in menus
  67    nconc
  68    (cond
  69     ((> (length entries) sgml-max-menu-size)
  70      (loop for i from 1 while entries
  71            collect
  72            (let ((submenu (copy-sequence entries)))
  73              (setcdr (nthcdr (1- (min (length entries) sgml-max-menu-size))
  74                              submenu)
  75                      nil)
  76              (setq entries (nthcdr sgml-max-menu-size entries))
  77              (cons
  78               (format "%s '%s'.."
  79                       title
  80                       (sgml-range-indicator (caar submenu)))
  81               submenu))))
  82     (t
  83      (list (cons title entries))))))
  84
  85
  86
  87 (defun sgml-popup-multi-menu (event title menus)
  88   "Display a popup menu.
  89 MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...).
  90 ITEM should have to form (STRING EXPR) or STRING.  The EXPR gets evaluated
  91 if the item is selected."
  92   (setq menus (sgml-split-long-menus menus))
  93   (unless (cdr menus)
  94     (setq menus (list (car menus) '("---" "---"))))
  95   (eval (car (x-popup-menu event (cons title menus)))))
  96
  97 \f
  98 ;;;; Insert with properties
  99
 100 (defvar sgml-write-protect-intagible
 101   (not (boundp 'emacs-minor-version)))
 102
 103 (defun sgml-insert (props format &rest args)
 104   (let ((start (point)))
 105     (insert (apply (function format)
 106                    format
 107                    args))
 108     (when (and sgml-write-protect-intagible
 109                (getf props 'intangible))
 110           (setf (getf props 'read-only) t))
 111     (add-text-properties start (point) props)))
 112
 113 \f
 114 ;;;; Set face of markup
 115
 116 (defvar sgml-use-text-properties nil)
 117
 118 (defun sgml-set-face-for (start end type)
 119   (let ((face (cdr (assq type sgml-markup-faces))))
 120     (cond
 121      (sgml-use-text-properties
 122       (let ((inhibit-read-only t)
 123             (after-change-functions nil)
 124             (before-change-functions nil)
 125             (buffer-undo-list t)
 126             (deactivate-mark nil))
 127         (put-text-property start end 'face face)
 128         (when (< start end)
 129           (put-text-property (1- end) end 'rear-nonsticky '(face)))))
 130      (t
 131       (let ((current (overlays-at start))
 132             (pos start)
 133             old-overlay)
 134         (while current
 135           (cond ((and (null old-overlay)
 136                       type
 137                       (eq type (overlay-get (car current) 'sgml-type)))
 138                  (setq old-overlay (car current)))
 139                 ((overlay-get (car current) 'sgml-type)
 140                  ;;(message "delov: %s" (overlay-get (car current) 'sgml-type))
 141                  (delete-overlay (car current))))
 142           (setq current (cdr current)))
 143         (while (< (setq pos (next-overlay-change pos))
 144                   end)
 145           (setq current (overlays-at pos))
 146           (while current
 147             (when (overlay-get (car current) 'sgml-type)
 148               (delete-overlay (car current)))
 149             (setq current (cdr current))))
 150         (cond (old-overlay
 151                (move-overlay old-overlay start end)
 152                (if (null (overlay-get old-overlay 'face))
 153                    (overlay-put old-overlay 'face face)))
 154               (face
 155                (setq old-overlay (make-overlay start end))
 156                (overlay-put old-overlay 'sgml-type type)
 157                (overlay-put old-overlay 'face face))))))))
 158
 159 (defun sgml-set-face-after-change (start end &optional pre-len)
 160   ;; If inserting in front of an markup overlay, move that overlay.
 161   ;; this avoids the overlay beeing deleted and recreated by
 162   ;; sgml-set-face-for.
 163   (when (and sgml-set-face (not sgml-use-text-properties))
 164     (loop for o in (overlays-at start)
 165           do (cond
 166               ((not (overlay-get o 'sgml-type)))
 167               ((= start (overlay-start o))
 168                (move-overlay o end (overlay-end o)))))))
 169
 170 (defun sgml-fix-overlay-after-change (overlay flag start end &optional size)
 171   (message "sfix(%s): %d-%d (%s)" flag start end size)
 172   (overlay-put overlay 'front-nonsticky t)
 173   (when nil
 174     (move-overlay overlay end (overlay-end overlay))))
 175
 176 (defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el
 177
 178 (defun sgml-clear-faces ()
 179   (interactive)
 180   (loop for o being the overlays
 181         if (overlay-get o 'sgml-type)
 182         do (delete-overlay o)))
 183
 184 \f
 185 ;;;; Emacs before 19.29
 186
 187 (unless (fboundp 'buffer-substring-no-properties)
 188   (defalias 'buffer-substring-no-properties 'buffer-substring))
 189
 190 \f
 191 ;;;; Provide
 192
 193 (provide 'psgml-other)
 194 \f
 195 ;;; psgml-other.el ends here