Mercurial > emacs
annotate src/sunfns.c @ 69892:ec3278dd3d95
(Mail Sending): In send-mail-function @pxref smtpmail, put info and printed
manual names the right way around.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Sun, 09 Apr 2006 18:44:06 +0000 |
parents | 3bd95f4f2941 |
children | 9214bbc95872 c5406394f567 |
rev | line source |
---|---|
19 | 1 /* Functions for Sun Windows menus and selection buffer. |
64770
a0d1312ede66
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64084
diff
changeset
|
2 Copyright (C) 1987, 1999, 2001, 2002, 2003, 2004, |
68651
3bd95f4f2941
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64770
diff
changeset
|
3 2005, 2006 Free Software Foundation, Inc. |
19 | 4 |
4250 | 5 This file is probably totally obsolete. In any case, the FSF is |
6 unwilling to support it. We agreed to include it in our distribution | |
7 only on the understanding that we would spend no time at all on it. | |
8 | |
9 If you have complaints about this file, send them to peck@sun.com. | |
10 If no one at Sun wants to maintain this, then consider it not | |
11 maintained at all. It would be a bad thing for the GNU project if | |
12 this file took our effort away from higher-priority things. | |
13 | |
14 | |
19 | 15 This file is part of GNU Emacs. |
16 | |
38 | 17 GNU Emacs is free software; you can redistribute it and/or modify |
18 it under the terms of the GNU General Public License as published by | |
12244 | 19 the Free Software Foundation; either version 2, or (at your option) |
38 | 20 any later version. |
19 | 21 |
38 | 22 GNU Emacs is distributed in the hope that it will be useful, |
23 but WITHOUT ANY WARRANTY; without even the implied warranty of | |
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
25 GNU General Public License for more details. | |
26 | |
27 You should have received a copy of the GNU General Public License | |
28 along with GNU Emacs; see the file COPYING. If not, write to | |
64084 | 29 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
30 Boston, MA 02110-1301, USA. */ | |
19 | 31 |
4250 | 32 /* Author: Jeff Peck, Sun Microsystems, Inc. <peck@sun.com> |
19 | 33 Original ideas by David Kastan and Eric Negaard, SRI International |
34 Major help from: Steve Greenbaum, Reasoning Systems, Inc. | |
35 <froud@kestrel.arpa> | |
36 who first discovered the Menu_Base_Kludge. | |
37 */ | |
38 | |
39 /* | |
40 * Emacs Lisp-Callable functions for sunwindows | |
41 */ | |
4696
1fc792473491
Include <config.h> instead of "config.h".
Roland McGrath <roland@gnu.org>
parents:
4250
diff
changeset
|
42 #include <config.h> |
19 | 43 |
44 #include <stdio.h> | |
45 #include <errno.h> | |
46 #include <signal.h> | |
47 #include <sunwindow/window_hs.h> | |
48 #include <suntool/selection.h> | |
49 #include <suntool/menu.h> | |
50 #include <suntool/walkmenu.h> | |
51 #include <suntool/frame.h> | |
52 #include <suntool/window.h> | |
53 | |
54 #include <fcntl.h> | |
55 #undef NULL /* We don't need sunview's idea of NULL */ | |
56 #include "lisp.h" | |
57 #include "window.h" | |
58 #include "buffer.h" | |
59 #include "termhooks.h" | |
60 | |
766 | 61 /* conversion to/from character & frame coordinates */ |
19 | 62 /* From Gosling Emacs SunWindow driver by Chris Torek */ |
63 | |
766 | 64 /* Chars to frame coords. Note that we speak in zero origin. */ |
19 | 65 #define CtoSX(cx) ((cx) * Sun_Font_Xsize) |
66 #define CtoSY(cy) ((cy) * Sun_Font_Ysize) | |
67 | |
766 | 68 /* Frame coords to chars */ |
19 | 69 #define StoCX(sx) ((sx) / Sun_Font_Xsize) |
70 #define StoCY(sy) ((sy) / Sun_Font_Ysize) | |
71 | |
72 #define CHECK_GFX(x) if((win_fd<0)&&(Fsun_window_init(),(win_fd<0)))return(x) | |
73 int win_fd = -1; | |
74 struct pixfont *Sun_Font; /* The font */ | |
75 int Sun_Font_Xsize; /* Width of font */ | |
76 int Sun_Font_Ysize; /* Height of font */ | |
77 | |
78 #define Menu_Base_Kludge /* until menu_show_using_fd gets fixed */ | |
79 #ifdef Menu_Base_Kludge | |
80 static Frame Menu_Base_Frame; | |
81 static int Menu_Base_fd; | |
82 static Lisp_Object sm_kludge_string; | |
83 #endif | |
84 struct cursor CurrentCursor; /* The current cursor */ | |
85 | |
86 static short CursorData[16]; /* Build cursor here */ | |
87 static mpr_static(CursorMpr, 16, 16, 1, CursorData); | |
88 static struct cursor NewCursor = {0, 0, PIX_SRC ^ PIX_DST, &CursorMpr}; | |
89 | |
90 #define RIGHT_ARROW_CURSOR /* if you want the right arrow */ | |
91 #ifdef RIGHT_ARROW_CURSOR | |
92 /* The default right-arrow cursor, with XOR drawing. */ | |
93 static short ArrowCursorData[16] = { | |
94 0x0001,0x0003,0x0007,0x000F,0x001F,0x003F,0x007F,0x000F, | |
95 0x001B,0x0019,0x0030,0x0030,0x0060,0x0060,0x00C0,0x00C0}; | |
96 static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData); | |
97 struct cursor DefaultCursor = {15, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr}; | |
98 | |
99 #else | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
1437
diff
changeset
|
100 /* The default left-arrow cursor, with XOR drawing. */ |
19 | 101 static short ArrowCursorData[16] = { |
102 0x8000,0xC000,0xE000,0xF000,0xF800,0xFC00,0xFE00,0xF000, | |
103 0xD800,0x9800,0x0C00,0x0C00,0x0600,0x0600,0x0300,0x0300}; | |
104 static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData); | |
105 struct cursor DefaultCursor = {0, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr}; | |
106 #endif | |
107 | |
108 /* | |
109 * Initialize window | |
110 */ | |
111 DEFUN ("sun-window-init", Fsun_window_init, Ssun_window_init, 0, 1, 0, | |
40123
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
112 doc: /* One time setup for using Sun Windows with mouse. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
113 Unless optional argument FORCE is non-nil, is a noop after its first call. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
114 Returns a number representing the file descriptor of the open Sun Window, |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
115 or -1 if can not open it. */) |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
116 (force) |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
117 Lisp_Object force; |
19 | 118 { |
119 char *cp; | |
120 static int already_initialized = 0; | |
121 | |
485 | 122 if ((! already_initialized) || (!NILP(force))) { |
19 | 123 cp = getenv("WINDOW_GFX"); |
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
parents:
25663
diff
changeset
|
124 if (cp != 0) win_fd = emacs_open (cp, O_RDWR, 0); |
19 | 125 if (win_fd > 0) |
126 { | |
127 Sun_Font = pf_default(); | |
128 Sun_Font_Xsize = Sun_Font->pf_defaultsize.x; | |
129 Sun_Font_Ysize = Sun_Font->pf_defaultsize.y; | |
130 Fsun_change_cursor_icon (Qnil); /* set up the default cursor */ | |
131 already_initialized = 1; | |
132 #ifdef Menu_Base_Kludge | |
133 | |
134 /* Make a frame to use for putting the menu on, and get its fd. */ | |
135 Menu_Base_Frame = window_create(0, FRAME, | |
136 WIN_X, 0, WIN_Y, 0, | |
137 WIN_ROWS, 1, WIN_COLUMNS, 1, | |
138 WIN_SHOW, FALSE, | |
139 FRAME_NO_CONFIRM, 1, | |
140 0); | |
141 Menu_Base_fd = (int) window_get(Menu_Base_Frame, WIN_FD); | |
142 #endif | |
143 } | |
144 } | |
145 return(make_number(win_fd)); | |
146 } | |
147 | |
148 /* | |
149 * Mouse sit-for (allows a shorter interval than the regular sit-for | |
150 * and can be interrupted by the mouse) | |
151 */ | |
152 DEFUN ("sit-for-millisecs", Fsit_for_millisecs, Ssit_for_millisecs, 1, 1, 0, | |
40123
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
153 doc: /* Like sit-for, but ARG is milliseconds. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
154 Perform redisplay, then wait for ARG milliseconds or until |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
155 input is available. Returns t if wait completed with no input. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
156 Redisplay does not happen if input is available before it starts. */) |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
157 (n) |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
158 Lisp_Object n; |
19 | 159 { |
160 struct timeval Timeout; | |
161 int waitmask = 1; | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
162 |
40656
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
163 CHECK_NUMBER (n); |
19 | 164 Timeout.tv_sec = XINT(n) / 1000; |
165 Timeout.tv_usec = (XINT(n) - (Timeout.tv_sec * 1000)) * 1000; | |
166 | |
167 if (detect_input_pending()) return(Qnil); | |
35336
002c02db42d3
Call redisplay_preserve_echo_area with additional arg.
Gerd Moellmann <gerd@gnu.org>
parents:
26088
diff
changeset
|
168 redisplay_preserve_echo_area (16); |
19 | 169 /* |
170 * Check for queued keyboard input/mouse hits again | |
171 * (A bit screen update can take some time!) | |
172 */ | |
173 if (detect_input_pending()) return(Qnil); | |
174 select(1,&waitmask,0,0,&Timeout); | |
175 if (detect_input_pending()) return(Qnil); | |
176 return(Qt); | |
177 } | |
178 | |
179 /* | |
180 * Sun sleep-for (allows a shorter interval than the regular sleep-for) | |
181 */ | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
182 DEFUN ("sleep-for-millisecs", |
40123
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
183 Fsleep_for_millisecs, |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
184 Ssleep_for_millisecs, 1, 1, 0, |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
185 doc: /* Pause, without updating display, for ARG milliseconds. */) |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
186 (n) |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
187 Lisp_Object n; |
19 | 188 { |
189 unsigned useconds; | |
190 | |
40656
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
191 CHECK_NUMBER (n); |
19 | 192 useconds = XINT(n) * 1000; |
193 usleep(useconds); | |
194 return(Qt); | |
195 } | |
196 | |
197 DEFUN ("update-display", Fupdate_display, Supdate_display, 0, 0, 0, | |
40123
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
198 doc: /* Perform redisplay. */) |
19 | 199 () |
200 { | |
35336
002c02db42d3
Call redisplay_preserve_echo_area with additional arg.
Gerd Moellmann <gerd@gnu.org>
parents:
26088
diff
changeset
|
201 redisplay_preserve_echo_area (17); |
19 | 202 return(Qt); |
203 } | |
204 | |
205 | |
206 /* | |
207 * Change the Sun mouse icon | |
208 */ | |
209 DEFUN ("sun-change-cursor-icon", | |
40123
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
210 Fsun_change_cursor_icon, |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
211 Ssun_change_cursor_icon, 1, 1, 0, |
41024
b192e8b73558
(Fsun_change_cursor_icon): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
40656
diff
changeset
|
212 doc: /* Change the Sun mouse cursor icon. |
b192e8b73558
(Fsun_change_cursor_icon): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
40656
diff
changeset
|
213 ICON is a lisp vector whose 1st element |
40123
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
214 is the X offset of the cursor hot-point, whose 2nd element is the Y offset |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
215 of the cursor hot-point and whose 3rd element is the cursor pixel data |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
216 expressed as a string. If ICON is nil then the original arrow cursor is used. */) |
19 | 217 (Icon) |
218 Lisp_Object Icon; | |
219 { | |
220 register unsigned char *cp; | |
221 register short *p; | |
222 register int i; | |
223 Lisp_Object X_Hot, Y_Hot, Data; | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
224 |
19 | 225 CHECK_GFX (Qnil); |
226 /* | |
227 * If the icon is null, we just restore the DefaultCursor | |
228 */ | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
229 if (NILP(Icon)) |
19 | 230 CurrentCursor = DefaultCursor; |
231 else { | |
232 /* | |
233 * extract the data from the vector | |
234 */ | |
40656
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
235 CHECK_VECTOR (Icon); |
19 | 236 if (XVECTOR(Icon)->size < 3) return(Qnil); |
237 X_Hot = XVECTOR(Icon)->contents[0]; | |
238 Y_Hot = XVECTOR(Icon)->contents[1]; | |
239 Data = XVECTOR(Icon)->contents[2]; | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
240 |
40656
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
241 CHECK_NUMBER (X_Hot); |
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
242 CHECK_NUMBER (Y_Hot); |
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
243 CHECK_STRING (Data); |
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
parents:
41024
diff
changeset
|
244 if (SCHARS (Data) != 32) return(Qnil); |
19 | 245 /* |
246 * Setup the new cursor | |
247 */ | |
248 NewCursor.cur_xhot = X_Hot; | |
249 NewCursor.cur_yhot = Y_Hot; | |
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
parents:
41024
diff
changeset
|
250 cp = SDATA (Data); |
19 | 251 p = CursorData; |
252 i = 16; | |
253 while(--i >= 0) | |
254 *p++ = (cp[0] << 8) | cp[1], cp += 2; | |
255 CurrentCursor = NewCursor; | |
256 } | |
257 win_setcursor(win_fd, &CurrentCursor); | |
258 return(Qt); | |
259 } | |
260 | |
261 /* | |
262 * Interface for sunwindows selection | |
263 */ | |
264 static Lisp_Object Current_Selection; | |
265 | |
266 static | |
267 sel_write (sel, file) | |
268 struct selection *sel; | |
269 FILE *file; | |
270 { | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
271 fwrite (SDATA (Current_Selection), sizeof (char), |
19 | 272 sel->sel_items, file); |
273 } | |
274 | |
275 static | |
276 sel_clear (sel, windowfd) | |
277 struct selection *sel; | |
278 int windowfd; | |
279 { | |
280 } | |
281 | |
282 static | |
283 sel_read (sel, file) | |
284 struct selection *sel; | |
285 FILE *file; | |
286 { | |
287 register int i, n; | |
288 register char *cp; | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
289 |
19 | 290 Current_Selection = make_string ("", 0); |
291 if (sel->sel_items <= 0) | |
292 return (0); | |
293 cp = (char *) malloc(sel->sel_items); | |
294 if (cp == (char *)0) { | |
295 error("malloc failed in sel_read"); | |
296 return(-1); | |
297 } | |
298 n = fread(cp, sizeof(char), sel->sel_items, file); | |
299 if (n > sel->sel_items) { | |
300 error("fread botch in sel_read"); | |
301 return(-1); | |
302 } else if (n < 0) { | |
53072
8787289602d1
Remove period at end of error message.
Jan Djärv <jan.h.d@swipnet.se>
parents:
52401
diff
changeset
|
303 error("Error reading selection"); |
19 | 304 return(-1); |
305 } | |
306 /* | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
1437
diff
changeset
|
307 * The shelltool select saves newlines as carriage returns, |
19 | 308 * but emacs wants newlines. |
309 */ | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
310 for (i = 0; i < n; i++) |
19 | 311 if (cp[i] == '\r') cp[i] = '\n'; |
312 | |
313 Current_Selection = make_string (cp, n); | |
314 free (cp); | |
315 return (0); | |
316 } | |
317 | |
318 /* | |
319 * Set the window system "selection" to be the arg STRING | |
320 */ | |
321 DEFUN ("sun-set-selection", Fsun_set_selection, Ssun_set_selection, 1, 1, | |
322 "sSet selection to: ", | |
40123
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
323 doc: /* Set the current sunwindow selection to STRING. */) |
19 | 324 (str) |
325 Lisp_Object str; | |
326 { | |
327 struct selection selection; | |
328 | |
40656
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
329 CHECK_STRING (str); |
19 | 330 Current_Selection = str; |
331 | |
332 CHECK_GFX (Qnil); | |
333 selection.sel_type = SELTYPE_CHAR; | |
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
parents:
41024
diff
changeset
|
334 selection.sel_items = SCHARS (str); |
19 | 335 selection.sel_itembytes = 1; |
336 selection.sel_pubflags = 1; | |
337 selection_set(&selection, sel_write, sel_clear, win_fd); | |
338 return (Qt); | |
339 } | |
340 /* | |
341 * Stuff the current window system selection into the current buffer | |
342 */ | |
343 DEFUN ("sun-get-selection", Fsun_get_selection, Ssun_get_selection, 0, 0, 0, | |
40123
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
344 doc: /* Return the current sunwindows selection as a string. */) |
19 | 345 () |
346 { | |
347 CHECK_GFX (Current_Selection); | |
348 selection_get (sel_read, win_fd); | |
349 return (Current_Selection); | |
350 } | |
351 | |
352 Menu sun_menu_create(); | |
353 | |
354 Menu_item | |
355 sun_item_create (Pair) | |
356 Lisp_Object Pair; | |
357 { | |
358 /* In here, we depend on Lisp supplying zero terminated strings in the data*/ | |
359 /* so we can just pass the pointers, and not recopy anything */ | |
360 | |
361 Menu_item menu_item; | |
362 Menu submenu; | |
363 Lisp_Object String; | |
364 Lisp_Object Value; | |
365 | |
366 if (!CONSP(Pair)) wrong_type_argument(Qlistp, Pair); | |
367 String = Fcar(Pair); | |
40656
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
368 CHECK_STRING(String); |
19 | 369 Value = Fcdr(Pair); |
9112
85182997b9c9
(sun_item_create): Use type test macros.
Karl Heuer <kwzh@gnu.org>
parents:
4696
diff
changeset
|
370 if (SYMBOLP (Value)) |
39584
6145836b795c
Use SYMBOL_VALUE/ SET_SYMBOL_VALUE macros instead of accessing
Gerd Moellmann <gerd@gnu.org>
parents:
35336
diff
changeset
|
371 Value = SYMBOL_VALUE (Value); |
9112
85182997b9c9
(sun_item_create): Use type test macros.
Karl Heuer <kwzh@gnu.org>
parents:
4696
diff
changeset
|
372 if (VECTORP (Value)) { |
19 | 373 submenu = sun_menu_create (Value); |
374 menu_item = menu_create_item | |
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
parents:
41024
diff
changeset
|
375 (MENU_RELEASE, MENU_PULLRIGHT_ITEM, SDATA (String), submenu, 0); |
19 | 376 } else { |
377 menu_item = menu_create_item | |
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
parents:
41024
diff
changeset
|
378 (MENU_RELEASE, MENU_STRING_ITEM, SDATA (String), Value, 0); |
19 | 379 } |
380 return menu_item; | |
381 } | |
382 | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
383 Menu |
19 | 384 sun_menu_create (Vector) |
385 Lisp_Object Vector; | |
386 { | |
387 Menu menu; | |
388 int i; | |
40656
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
389 CHECK_VECTOR(Vector); |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
390 menu=menu_create(0); |
19 | 391 for(i = 0; i < XVECTOR(Vector)->size; i++) { |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
392 menu_set (menu, MENU_APPEND_ITEM, |
19 | 393 sun_item_create(XVECTOR(Vector)->contents[i]), 0); |
394 } | |
395 return menu; | |
396 } | |
397 | |
398 /* | |
399 * If the first item of the menu has nil as its value, then make the | |
400 * item look like a label by inverting it and making it unselectable. | |
401 * Returns 1 if the label was made, 0 otherwise. | |
402 */ | |
403 int | |
404 make_menu_label (menu) | |
405 Menu menu; | |
406 { | |
407 int made_label_p = 0; | |
408 | |
409 if (( menu_get(menu, MENU_NITEMS) > 0 ) && /* At least one item */ | |
410 ((Lisp_Object) menu_get(menu_get(menu, MENU_NTH_ITEM, 1), | |
411 MENU_VALUE) == Qnil )) { | |
412 menu_set(menu_get(menu, MENU_NTH_ITEM, 1), | |
413 MENU_INVERT, TRUE, | |
414 MENU_FEEDBACK, FALSE, | |
415 0); | |
416 made_label_p = 1; | |
417 } | |
418 return made_label_p; | |
419 } | |
420 | |
421 /* | |
422 * Do a pop-up menu and return the selected value | |
423 */ | |
424 DEFUN ("sun-menu-internal", | |
425 Fsun_menu_internal, | |
426 Ssun_menu_internal, 5, 5, 0, | |
40123
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
427 doc: /* Set up a SunView pop-up menu and return the user's choice. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
428 Arguments WINDOW, X, Y, BUTTON, and MENU. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
429 *** User code should generally use sun-menu-evaluate *** |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
430 |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
431 Arguments WINDOW, X, Y, BUTTON, and MENU. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
432 Put MENU up in WINDOW at position X, Y. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
433 The BUTTON argument specifies the button to be released that selects an item: |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
434 1 = LEFT BUTTON |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
435 2 = MIDDLE BUTTON |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
436 4 = RIGHT BUTTON |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
437 The MENU argument is a vector containing (STRING . VALUE) pairs. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
438 The VALUE of the selected item is returned. |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
439 If the VALUE of the first pair is nil, then the first STRING will be used |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
440 as a menu label. */) |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
441 (window, X_Position, Y_Position, Button, MEnu) |
e528f2adeed4
Change doc-string comments to `new style' [w/`doc:' keyword].
Pavel Janík <Pavel@Janik.cz>
parents:
39584
diff
changeset
|
442 Lisp_Object window, X_Position, Y_Position, Button, MEnu; |
19 | 443 { |
444 Menu menu; | |
445 int button, xpos, ypos; | |
446 Event event0; | |
447 Event *event = &event0; | |
448 Lisp_Object Value, Pair; | |
49600
23a1cea22d13
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
46370
diff
changeset
|
449 |
40656
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
450 CHECK_NUMBER(X_Position); |
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
451 CHECK_NUMBER(Y_Position); |
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
452 CHECK_LIVE_WINDOW(window); |
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
453 CHECK_NUMBER(Button); |
cdfd4d09b79a
Update usage of CHECK_ macros (remove unused second argument).
Pavel Janík <Pavel@Janik.cz>
parents:
40123
diff
changeset
|
454 CHECK_VECTOR(MEnu); |
19 | 455 |
456 CHECK_GFX (Qnil); | |
457 | |
51203
f04f396f6f9f
(Fsun_menu_internal): Adapt to per-window fringes and scroll-bars.
Kim F. Storm <storm@cua.dk>
parents:
49600
diff
changeset
|
458 xpos = CtoSX (WINDOW_LEFT_EDGE_COL (XWINDOW (window)) |
f04f396f6f9f
(Fsun_menu_internal): Adapt to per-window fringes and scroll-bars.
Kim F. Storm <storm@cua.dk>
parents:
49600
diff
changeset
|
459 + WINDOW_LEFT_SCROLL_BAR_COLS (XWINDOW (window)) |
f04f396f6f9f
(Fsun_menu_internal): Adapt to per-window fringes and scroll-bars.
Kim F. Storm <storm@cua.dk>
parents:
49600
diff
changeset
|
460 + XINT(X_Position)); |
f04f396f6f9f
(Fsun_menu_internal): Adapt to per-window fringes and scroll-bars.
Kim F. Storm <storm@cua.dk>
parents:
49600
diff
changeset
|
461 ypos = CtoSY (WINDOW_TOP_EDGE_LINE (XWINDOW(window)) + XINT(Y_Position)); |
19 | 462 #ifdef Menu_Base_Kludge |
463 {static Lisp_Object symbol[2]; | |
464 symbol[0] = Fintern (sm_kludge_string, Qnil); | |
465 Pair = Ffuncall (1, symbol); | |
25663
a5eaace0fa01
Use XCAR and XCDR instead of explicit member access.
Ken Raeburn <raeburn@raeburn.org>
parents:
21259
diff
changeset
|
466 xpos += XINT (XCDR (Pair)); |
a5eaace0fa01
Use XCAR and XCDR instead of explicit member access.
Ken Raeburn <raeburn@raeburn.org>
parents:
21259
diff
changeset
|
467 ypos += XINT (XCAR (Pair)); |
19 | 468 } |
469 #endif | |
470 | |
471 button = XINT(Button); | |
472 if(button == 4) button = 3; | |
473 event_set_id (event, BUT(button)); | |
474 event_set_down (event); | |
475 event_set_x (event, xpos); | |
476 event_set_y (event, ypos); | |
477 | |
478 menu = sun_menu_create(MEnu); | |
479 make_menu_label(menu); | |
480 | |
481 #ifdef Menu_Base_Kludge | |
482 Value = (Lisp_Object) menu_show(menu, Menu_Base_Frame, event, 0); | |
483 #else | |
484 /* This confuses the notifier or something: */ | |
485 Value = (Lisp_Object) menu_show_using_fd(menu, win_fd, event, 0); | |
486 /* | |
487 * Right button gets lost, and event sequencing or delivery gets mixed up | |
488 * So, until that gets fixed, we use this <Menu_Base_Frame> kludge: | |
489 */ | |
490 #endif | |
491 menu_destroy (menu); | |
492 | |
493 return ((int)Value ? Value : Qnil); | |
494 } | |
495 | |
496 | |
497 /* | |
498 * Define everything | |
499 */ | |
500 syms_of_sunfns() | |
501 { | |
502 #ifdef Menu_Base_Kludge | |
503 /* i'm just too lazy to re-write this into C code */ | |
504 /* so we will call this elisp function from C */ | |
21259
3abae7d11d07
(syms_of_sunfns): Pass new arg to make_pure_string.
Richard M. Stallman <rms@gnu.org>
parents:
16261
diff
changeset
|
505 sm_kludge_string = make_pure_string ("sm::menu-kludge", 15, 15, 0); |
19 | 506 #endif /* Menu_Base_Kludge */ |
507 | |
508 defsubr(&Ssun_window_init); | |
509 defsubr(&Ssit_for_millisecs); | |
510 defsubr(&Ssleep_for_millisecs); | |
511 defsubr(&Supdate_display); | |
512 defsubr(&Ssun_change_cursor_icon); | |
513 defsubr(&Ssun_set_selection); | |
514 defsubr(&Ssun_get_selection); | |
515 defsubr(&Ssun_menu_internal); | |
516 } | |
52401 | 517 |
518 /* arch-tag: 2d7decb7-58f6-41aa-b45b-077ccfab7158 | |
519 (do not change this comment) */ |