|
0
|
1 ;;;; psgml-other.el --- Part of SGML-editing mode with parsing support
|
|
70
|
2 ;; $Id: psgml-other.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $
|
|
0
|
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
|
|
2
|
26 ;;; Part of psgml.el. Code not compatible with XEmacs.
|
|
0
|
27
|
|
|
28
|
|
|
29 ;;;; Code:
|
|
|
30
|
|
|
31 (require 'psgml)
|
|
|
32 (require 'easymenu)
|
|
|
33
|
|
|
34 (defvar sgml-max-menu-size (/ (* (frame-height) 2) 3)
|
|
|
35 "*Max number of entries in Tags and Entities menus before they are split
|
|
|
36 into several panes.")
|
|
|
37
|
|
|
38
|
|
|
39 ;;;; Key Commands
|
|
|
40
|
|
|
41 ;; Doesn't this work in Lucid? ***
|
|
70
|
42 (define-key sgml-mode-map [?\M-\C-\ ] 'sgml-mark-element)
|
|
0
|
43
|
|
70
|
44 (define-key sgml-mode-map [S-mouse-1] 'sgml-tags-menu)
|
|
0
|
45
|
|
|
46
|
|
|
47 ;;;; Pop Up Menus
|
|
|
48
|
|
|
49 (defun sgml-popup-menu (event title entries)
|
|
|
50 "Display a popup menu.
|
|
|
51 ENTRIES is a list where every element has the form (STRING . VALUE) or
|
|
|
52 STRING."
|
|
|
53 (x-popup-menu
|
|
|
54 event
|
|
|
55 (let ((menus (list (cons title entries))))
|
|
2
|
56 (cond
|
|
|
57 ((> (length entries) sgml-max-menu-size)
|
|
|
58 (setq menus
|
|
|
59 (loop for i from 1 while entries
|
|
|
60 collect
|
|
|
61 (let ((submenu
|
|
|
62 (subseq entries 0 (min (length entries)
|
|
|
63 sgml-max-menu-size))))
|
|
|
64 (setq entries (nthcdr sgml-max-menu-size entries))
|
|
|
65 (cons
|
|
|
66 (format "%s '%s'-'%s'"
|
|
|
67 title
|
|
|
68 (sgml-range-indicator (caar submenu))
|
|
|
69 (sgml-range-indicator (caar (last submenu))))
|
|
|
70 submenu))))))
|
|
0
|
71 (cons title menus))))
|
|
|
72
|
|
|
73 (defun sgml-range-indicator (string)
|
|
|
74 (substring string
|
|
|
75 0
|
|
|
76 (min (length string) sgml-range-indicator-max-length)))
|
|
|
77
|
|
|
78 (defun sgml-popup-multi-menu (event title menus)
|
|
|
79 "Display a popup menu.
|
|
|
80 MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...).
|
|
|
81 ITEM should have to form (STRING EXPR) or STRING. The EXPR gets evaluated
|
|
|
82 if the item is selected."
|
|
|
83 (nconc menus '(("---" "---"))) ; Force x-popup-menu to use two level
|
|
|
84 ; menu even if there is only one entry
|
|
|
85 ; on the first level
|
|
|
86 (eval (car (x-popup-menu event (cons title menus)))))
|
|
|
87
|
|
|
88
|
|
|
89 ;;;; Insert with properties
|
|
|
90
|
|
|
91 (defvar sgml-write-protect-intagible
|
|
|
92 (not (boundp 'emacs-minor-version)))
|
|
|
93
|
|
|
94 (defun sgml-insert (props format &rest args)
|
|
|
95 (let ((start (point)))
|
|
|
96 (insert (apply (function format)
|
|
|
97 format
|
|
|
98 args))
|
|
|
99 (when (and sgml-write-protect-intagible
|
|
|
100 (getf props 'intangible))
|
|
|
101 (setf (getf props 'read-only) t))
|
|
|
102 (add-text-properties start (point) props)))
|
|
|
103
|
|
|
104
|
|
|
105 ;;;; Set face of markup
|
|
|
106
|
|
2
|
107 (defvar sgml-use-text-properties nil)
|
|
|
108
|
|
0
|
109 (defun sgml-set-face-for (start end type)
|
|
2
|
110 (let ((face (cdr (assq type sgml-markup-faces))))
|
|
|
111 (cond
|
|
|
112 (sgml-use-text-properties
|
|
|
113 (let ((inhibit-read-only t)
|
|
70
|
114 (after-change-function nil)
|
|
|
115 (before-change-function nil))
|
|
2
|
116 (put-text-property start end 'face face)))
|
|
|
117 (t
|
|
|
118 (let ((current (overlays-at start))
|
|
|
119 (pos start)
|
|
|
120 old-overlay)
|
|
|
121 (while current
|
|
|
122 (cond ((and (null old-overlay)
|
|
|
123 (eq type (overlay-get (car current) 'sgml-type)))
|
|
|
124 (setq old-overlay (car current)))
|
|
|
125 ((overlay-get (car current) 'sgml-type)
|
|
|
126 (message "delov: %s" (overlay-get (car current) 'sgml-type))
|
|
|
127 (delete-overlay (car current))))
|
|
|
128 (setq current (cdr current)))
|
|
|
129 (while (< (setq pos (next-overlay-change pos))
|
|
|
130 end)
|
|
|
131 (setq current (overlays-at pos))
|
|
|
132 (while current
|
|
|
133 (when (overlay-get (car current) 'sgml-type)
|
|
|
134 (delete-overlay (car current)))
|
|
|
135 (setq current (cdr current))))
|
|
|
136 (cond (old-overlay
|
|
|
137 (move-overlay old-overlay start end)
|
|
|
138 (if (null (overlay-get old-overlay 'face))
|
|
|
139 (overlay-put old-overlay 'face face)))
|
|
|
140 (face
|
|
|
141 (setq old-overlay (make-overlay start end))
|
|
|
142 (overlay-put old-overlay 'sgml-type type)
|
|
|
143 (overlay-put old-overlay 'face face))))))))
|
|
0
|
144
|
|
|
145 (defun sgml-set-face-after-change (start end &optional pre-len)
|
|
2
|
146 ;; If inserting in front of an markup overlay, move that overlay.
|
|
70
|
147 ;; this avoids the overlay beeing deleted and recreated by
|
|
2
|
148 ;; sgml-set-face-for.
|
|
|
149 (when (and sgml-set-face (not sgml-use-text-properties))
|
|
0
|
150 (loop for o in (overlays-at start)
|
|
|
151 do (cond
|
|
|
152 ((not (overlay-get o 'sgml-type)))
|
|
|
153 ((= start (overlay-start o))
|
|
|
154 (move-overlay o end (overlay-end o)))))))
|
|
|
155
|
|
2
|
156 (defun sgml-fix-overlay-after-change (overlay flag start end &optional size)
|
|
|
157 (message "sfix(%s): %d-%d (%s)" flag start end size)
|
|
|
158 (overlay-put overlay 'front-nonsticky t)
|
|
|
159 (when nil
|
|
|
160 (move-overlay overlay end (overlay-end overlay))))
|
|
|
161
|
|
0
|
162 (defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el
|
|
|
163
|
|
|
164 (defun sgml-clear-faces ()
|
|
|
165 (interactive)
|
|
|
166 (loop for o being the overlays
|
|
|
167 if (overlay-get o 'sgml-type)
|
|
|
168 do (delete-overlay o)))
|
|
|
169
|
|
|
170
|
|
2
|
171 ;;;; Emacs before 19.29
|
|
|
172
|
|
|
173 (unless (fboundp 'buffer-substring-no-properties)
|
|
|
174 (defalias 'buffer-substring-no-properties 'buffer-substring))
|
|
|
175
|
|
|
176
|
|
0
|
177 ;;;; Provide
|
|
|
178
|
|
|
179 (provide 'psgml-other)
|
|
|
180
|
|
|
181 ;;; psgml-other.el ends here
|
