*** empty log message ***
[emacs.git] / src / sunfns.c
blob336f02221cf868ff25740066b005401873806ac3
1 /* Functions for Sun Windows menus and selection buffer.
2 Copyright (C) 1987, 1999, 2001, 2002, 2003, 2004,
3 2005, 2006 Free Software Foundation, Inc.
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.
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.
15 This file is part of GNU Emacs.
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
19 the Free Software Foundation; either version 2, or (at your option)
20 any later version.
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.
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
29 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
32 /* Author: Jeff Peck, Sun Microsystems, Inc. <peck@sun.com>
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.
40 * Emacs Lisp-Callable functions for sunwindows
42 #include <config.h>
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>
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"
61 /* conversion to/from character & frame coordinates */
62 /* From Gosling Emacs SunWindow driver by Chris Torek */
64 /* Chars to frame coords. Note that we speak in zero origin. */
65 #define CtoSX(cx) ((cx) * Sun_Font_Xsize)
66 #define CtoSY(cy) ((cy) * Sun_Font_Ysize)
68 /* Frame coords to chars */
69 #define StoCX(sx) ((sx) / Sun_Font_Xsize)
70 #define StoCY(sy) ((sy) / Sun_Font_Ysize)
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 */
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 */
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};
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};
99 #else
100 /* The default left-arrow cursor, with XOR drawing. */
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
109 * Initialize window
111 DEFUN ("sun-window-init", Fsun_window_init, Ssun_window_init, 0, 1, 0,
112 doc: /* One time setup for using Sun Windows with mouse.
113 Unless optional argument FORCE is non-nil, is a noop after its first call.
114 Returns a number representing the file descriptor of the open Sun Window,
115 or -1 if can not open it. */)
116 (force)
117 Lisp_Object force;
119 char *cp;
120 static int already_initialized = 0;
122 if ((! already_initialized) || (!NILP(force))) {
123 cp = getenv("WINDOW_GFX");
124 if (cp != 0) win_fd = emacs_open (cp, O_RDWR, 0);
125 if (win_fd > 0)
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
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,
141 Menu_Base_fd = (int) window_get(Menu_Base_Frame, WIN_FD);
142 #endif
145 return(make_number(win_fd));
149 * Mouse sit-for (allows a shorter interval than the regular sit-for
150 * and can be interrupted by the mouse)
152 DEFUN ("sit-for-millisecs", Fsit_for_millisecs, Ssit_for_millisecs, 1, 1, 0,
153 doc: /* Like sit-for, but ARG is milliseconds.
154 Perform redisplay, then wait for ARG milliseconds or until
155 input is available. Returns t if wait completed with no input.
156 Redisplay does not happen if input is available before it starts. */)
158 Lisp_Object n;
160 struct timeval Timeout;
161 int waitmask = 1;
163 CHECK_NUMBER (n);
164 Timeout.tv_sec = XINT(n) / 1000;
165 Timeout.tv_usec = (XINT(n) - (Timeout.tv_sec * 1000)) * 1000;
167 if (detect_input_pending()) return(Qnil);
168 redisplay_preserve_echo_area (16);
170 * Check for queued keyboard input/mouse hits again
171 * (A bit screen update can take some time!)
173 if (detect_input_pending()) return(Qnil);
174 select(1,&waitmask,0,0,&Timeout);
175 if (detect_input_pending()) return(Qnil);
176 return(Qt);
180 * Sun sleep-for (allows a shorter interval than the regular sleep-for)
182 DEFUN ("sleep-for-millisecs",
183 Fsleep_for_millisecs,
184 Ssleep_for_millisecs, 1, 1, 0,
185 doc: /* Pause, without updating display, for ARG milliseconds. */)
187 Lisp_Object n;
189 unsigned useconds;
191 CHECK_NUMBER (n);
192 useconds = XINT(n) * 1000;
193 usleep(useconds);
194 return(Qt);
197 DEFUN ("update-display", Fupdate_display, Supdate_display, 0, 0, 0,
198 doc: /* Perform redisplay. */)
201 redisplay_preserve_echo_area (17);
202 return(Qt);
207 * Change the Sun mouse icon
209 DEFUN ("sun-change-cursor-icon",
210 Fsun_change_cursor_icon,
211 Ssun_change_cursor_icon, 1, 1, 0,
212 doc: /* Change the Sun mouse cursor icon.
213 ICON is a lisp vector whose 1st element
214 is the X offset of the cursor hot-point, whose 2nd element is the Y offset
215 of the cursor hot-point and whose 3rd element is the cursor pixel data
216 expressed as a string. If ICON is nil then the original arrow cursor is used. */)
217 (Icon)
218 Lisp_Object Icon;
220 register unsigned char *cp;
221 register short *p;
222 register int i;
223 Lisp_Object X_Hot, Y_Hot, Data;
225 CHECK_GFX (Qnil);
227 * If the icon is null, we just restore the DefaultCursor
229 if (NILP(Icon))
230 CurrentCursor = DefaultCursor;
231 else {
233 * extract the data from the vector
235 CHECK_VECTOR (Icon);
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];
241 CHECK_NUMBER (X_Hot);
242 CHECK_NUMBER (Y_Hot);
243 CHECK_STRING (Data);
244 if (SCHARS (Data) != 32) return(Qnil);
246 * Setup the new cursor
248 NewCursor.cur_xhot = X_Hot;
249 NewCursor.cur_yhot = Y_Hot;
250 cp = SDATA (Data);
251 p = CursorData;
252 i = 16;
253 while(--i >= 0)
254 *p++ = (cp[0] << 8) | cp[1], cp += 2;
255 CurrentCursor = NewCursor;
257 win_setcursor(win_fd, &CurrentCursor);
258 return(Qt);
262 * Interface for sunwindows selection
264 static Lisp_Object Current_Selection;
266 static
267 sel_write (sel, file)
268 struct selection *sel;
269 FILE *file;
271 fwrite (SDATA (Current_Selection), sizeof (char),
272 sel->sel_items, file);
275 static
276 sel_clear (sel, windowfd)
277 struct selection *sel;
278 int windowfd;
282 static
283 sel_read (sel, file)
284 struct selection *sel;
285 FILE *file;
287 register int i, n;
288 register char *cp;
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);
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) {
303 error("Error reading selection");
304 return(-1);
307 * The shelltool select saves newlines as carriage returns,
308 * but emacs wants newlines.
310 for (i = 0; i < n; i++)
311 if (cp[i] == '\r') cp[i] = '\n';
313 Current_Selection = make_string (cp, n);
314 free (cp);
315 return (0);
319 * Set the window system "selection" to be the arg STRING
321 DEFUN ("sun-set-selection", Fsun_set_selection, Ssun_set_selection, 1, 1,
322 "sSet selection to: ",
323 doc: /* Set the current sunwindow selection to STRING. */)
324 (str)
325 Lisp_Object str;
327 struct selection selection;
329 CHECK_STRING (str);
330 Current_Selection = str;
332 CHECK_GFX (Qnil);
333 selection.sel_type = SELTYPE_CHAR;
334 selection.sel_items = SCHARS (str);
335 selection.sel_itembytes = 1;
336 selection.sel_pubflags = 1;
337 selection_set(&selection, sel_write, sel_clear, win_fd);
338 return (Qt);
341 * Stuff the current window system selection into the current buffer
343 DEFUN ("sun-get-selection", Fsun_get_selection, Ssun_get_selection, 0, 0, 0,
344 doc: /* Return the current sunwindows selection as a string. */)
347 CHECK_GFX (Current_Selection);
348 selection_get (sel_read, win_fd);
349 return (Current_Selection);
352 Menu sun_menu_create();
354 Menu_item
355 sun_item_create (Pair)
356 Lisp_Object Pair;
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 */
361 Menu_item menu_item;
362 Menu submenu;
363 Lisp_Object String;
364 Lisp_Object Value;
366 CHECK_LIST_CONS (Pair, Pair);
367 String = Fcar(Pair);
368 CHECK_STRING(String);
369 Value = Fcdr(Pair);
370 if (SYMBOLP (Value))
371 Value = SYMBOL_VALUE (Value);
372 if (VECTORP (Value)) {
373 submenu = sun_menu_create (Value);
374 menu_item = menu_create_item
375 (MENU_RELEASE, MENU_PULLRIGHT_ITEM, SDATA (String), submenu, 0);
376 } else {
377 menu_item = menu_create_item
378 (MENU_RELEASE, MENU_STRING_ITEM, SDATA (String), Value, 0);
380 return menu_item;
383 Menu
384 sun_menu_create (Vector)
385 Lisp_Object Vector;
387 Menu menu;
388 int i;
389 CHECK_VECTOR(Vector);
390 menu=menu_create(0);
391 for(i = 0; i < XVECTOR(Vector)->size; i++) {
392 menu_set (menu, MENU_APPEND_ITEM,
393 sun_item_create(XVECTOR(Vector)->contents[i]), 0);
395 return menu;
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.
404 make_menu_label (menu)
405 Menu menu;
407 int made_label_p = 0;
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,
416 made_label_p = 1;
418 return made_label_p;
422 * Do a pop-up menu and return the selected value
424 DEFUN ("sun-menu-internal",
425 Fsun_menu_internal,
426 Ssun_menu_internal, 5, 5, 0,
427 doc: /* Set up a SunView pop-up menu and return the user's choice.
428 Arguments WINDOW, X, Y, BUTTON, and MENU.
429 *** User code should generally use sun-menu-evaluate ***
431 Arguments WINDOW, X, Y, BUTTON, and MENU.
432 Put MENU up in WINDOW at position X, Y.
433 The BUTTON argument specifies the button to be released that selects an item:
434 1 = LEFT BUTTON
435 2 = MIDDLE BUTTON
436 4 = RIGHT BUTTON
437 The MENU argument is a vector containing (STRING . VALUE) pairs.
438 The VALUE of the selected item is returned.
439 If the VALUE of the first pair is nil, then the first STRING will be used
440 as a menu label. */)
441 (window, X_Position, Y_Position, Button, MEnu)
442 Lisp_Object window, X_Position, Y_Position, Button, MEnu;
444 Menu menu;
445 int button, xpos, ypos;
446 Event event0;
447 Event *event = &event0;
448 Lisp_Object Value, Pair;
450 CHECK_NUMBER(X_Position);
451 CHECK_NUMBER(Y_Position);
452 CHECK_LIVE_WINDOW(window);
453 CHECK_NUMBER(Button);
454 CHECK_VECTOR(MEnu);
456 CHECK_GFX (Qnil);
458 xpos = CtoSX (WINDOW_LEFT_EDGE_COL (XWINDOW (window))
459 + WINDOW_LEFT_SCROLL_BAR_COLS (XWINDOW (window))
460 + XINT(X_Position));
461 ypos = CtoSY (WINDOW_TOP_EDGE_LINE (XWINDOW(window)) + XINT(Y_Position));
462 #ifdef Menu_Base_Kludge
463 {static Lisp_Object symbol[2];
464 symbol[0] = Fintern (sm_kludge_string, Qnil);
465 Pair = Ffuncall (1, symbol);
466 xpos += XINT (XCDR (Pair));
467 ypos += XINT (XCAR (Pair));
469 #endif
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);
478 menu = sun_menu_create(MEnu);
479 make_menu_label(menu);
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);
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:
490 #endif
491 menu_destroy (menu);
493 return ((int)Value ? Value : Qnil);
498 * Define everything
500 syms_of_sunfns()
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 */
505 sm_kludge_string = make_pure_string ("sm::menu-kludge", 15, 15, 0);
506 #endif /* Menu_Base_Kludge */
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);
518 /* arch-tag: 2d7decb7-58f6-41aa-b45b-077ccfab7158
519 (do not change this comment) */