1;;;; psgml-other.el --- Part of SGML-editing mode with parsing support
2;; $Id: psgml-other.el,v 2.25 2005/02/27 17:13:20 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
24;;;; Commentary:
25
26;;; Part of psgml.el. Code not compatible with XEmacs.
27
28
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
37into several panes.")
38
39
40;;;; Key Commands
41
42;; Doesn't this work in Lucid? ***
43(define-key psgml-mode-map [?\M-\C-\ ] 'sgml-mark-element)
44
45;;(define-key psgml-mode-map [S-mouse-3] 'sgml-tags-menu)
46(define-key psgml-mode-map [S-mouse-3] 'sgml-right-menu)
47
48
49;;;; Pop Up Menus
50
51(defun sgml-popup-menu (event title entries)
52  "Display a popup menu.
53ENTRIES is a list where every element has the form (STRING . VALUE) or
54STRING."
55  (let ((menus (sgml-split-long-menus (list (cons title entries)))))
56    (x-popup-menu event (cons title menus))))
57
58
59(defun sgml-range-indicator (string)
60  (substring string
61	     0
62	     (min (length string) sgml-range-indicator-max-length)))
63
64
65(defun sgml-split-long-menus (menus)
66  (loop
67   for (title . entries) in menus
68   nconc
69   (cond
70    ((> (length entries) sgml-max-menu-size)
71     (loop for i from 1 while entries
72           collect
73           (let ((submenu (copy-sequence entries)))
74             (setcdr (nthcdr (1- (min (length entries) sgml-max-menu-size))
75                             submenu)
76                     nil)
77             (setq entries (nthcdr sgml-max-menu-size entries))
78             (cons
79              (format "%s '%s'.."
80                      title
81                      (sgml-range-indicator (caar submenu)))
82              submenu))))
83    (t
84     (list (cons title entries))))))
85
86
87
88(defun sgml-popup-multi-menu (event title menus)
89  "Display a popup menu.
90MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...).
91ITEM should have to form (STRING EXPR) or STRING.  The EXPR gets evaluated
92if the item is selected."
93  (setq menus (sgml-split-long-menus menus))
94  (unless (cdr menus)
95    (setq menus (list (car menus) '("---" "---"))))
96  (eval (car (x-popup-menu event (cons title menus)))))
97
98
99;;;; Insert with properties
100
101(defvar sgml-write-protect-intagible
102  (not (boundp 'emacs-minor-version)))
103
104(defun sgml-insert (props format &rest args)
105  (let ((start (point)))
106    (insert (apply (function format)
107		   format
108		   args))
109    (when (and sgml-write-protect-intagible
110	       (plist-get props 'intangible))
111	  (plist-put props 'read-only t))
112    (add-text-properties start (point) props)))
113
114
115;;;; Set face of markup
116
117(defvar sgml-use-text-properties t
118  "Non-nil means use text properties for highlighting, not overlays.
119Overlays are significantly less efficient in large buffers.")
120
121(eval-and-compile
122  (if (boundp 'inhibit-modification-hooks) ; Emacs 21
123      (defmacro sgml-with-modification-state (&rest body)
124	`(let ((modified (buffer-modified-p))
125	       (inhibit-read-only t)
126	       (inhibit-modification-hooks t)
127	       (buffer-undo-list t)
128	       (deactivate-mark nil))
129	   ,@body
130	   (when (not modified)
131	     (sgml-restore-buffer-modified-p nil))))
132    (defmacro sgml-with-modification-state (&rest body)
133      `(let ((modified (buffer-modified-p))
134	     (inhibit-read-only t)
135	     (after-change-functions nil)
136	     (before-change-functions nil)
137	     (buffer-undo-list t)
138	     (deactivate-mark nil))
139	 ,@body
140	 (when (not modified)
141	   (sgml-restore-buffer-modified-p nil))))))
142
143(defun sgml-set-face-for (start end type)
144  (let ((face (cdr (assq type sgml-markup-faces))))
145    (if (and (null type) sgml-current-tree)
146        (setq face (sgml-element-appdata sgml-current-tree 'face)))
147    (cond
148     (sgml-use-text-properties
149      (sgml-with-modification-state
150	(put-text-property start end 'face face)
151         (when (and (not modified) (buffer-modified-p))
152 	  (set-buffer-modified-p nil))))
153     (t
154      (let ((current (overlays-at start))
155	    (pos start)
156	    old-overlay)
157	(while current
158	  (cond ((and (null old-overlay)
159                      type
160		      (eq type (overlay-get (car current) 'sgml-type)))
161		 (setq old-overlay (car current)))
162		((overlay-get (car current) 'sgml-type)
163		 ;;(message "delov: %s" (overlay-get (car current) 'sgml-type))
164		 (delete-overlay (car current))))
165	  (setq current (cdr current)))
166	(while (< (setq pos (next-overlay-change pos))
167		  end)
168	  (setq current (overlays-at pos))
169	  (while current
170	    (when (overlay-get (car current) 'sgml-type)
171	      (delete-overlay (car current)))
172	    (setq current (cdr current))))
173	(cond (old-overlay
174	       (move-overlay old-overlay start end)
175	       (if (null (overlay-get old-overlay 'face))
176		   (overlay-put old-overlay 'face face)))
177	      (face
178	       (setq old-overlay (make-overlay start end))
179	       (overlay-put old-overlay 'sgml-type type)
180	       (overlay-put old-overlay 'face face))))))))
181
182(defun sgml-set-face-after-change (start end &optional pre-len)
183  ;; If inserting in front of an markup overlay, move that overlay.
184  ;; this avoids the overlay beeing deleted and recreated by
185  ;; sgml-set-face-for.
186  (when (and sgml-set-face (not sgml-use-text-properties))
187    (loop for o in (overlays-at start)
188	  do (cond
189	      ((not (overlay-get o 'sgml-type)))
190	      ((= start (overlay-start o))
191	       (move-overlay o end (overlay-end o)))))))
192
193(defun sgml-fix-overlay-after-change (overlay flag start end &optional size)
194  (message "sfix(%s): %d-%d (%s)" flag start end size)
195  (overlay-put overlay 'front-nonsticky t)
196  (when nil
197    (move-overlay overlay end (overlay-end overlay))))
198
199(defun sgml-clear-faces ()
200  (interactive)
201  (dolist (o (overlays-in (point-min) (point-max)))
202    (if (overlay-get o 'sgml-type)
203	(delete-overlay o))))
204
205
206;;;; Emacs before 19.29
207
208(unless (fboundp 'buffer-substring-no-properties)
209  (defalias 'buffer-substring-no-properties 'buffer-substring))
210
211
212;;;; Provide
213
214(provide 'psgml-other)
215
216;;; psgml-other.el ends here
217