1/* Functions for Sun Windows menus and selection buffer.
2   Copyright (C) 1987, 1999, 2001, 2002, 2003, 2004,
3                 2005, 2006, 2007 Free Software Foundation, Inc.
4
5This file is probably totally obsolete.  In any case, the FSF is
6unwilling to support it.  We agreed to include it in our distribution
7only on the understanding that we would spend no time at all on it.
8
9If you have complaints about this file, send them to peck@sun.com.
10If no one at Sun wants to maintain this, then consider it not
11maintained at all.  It would be a bad thing for the GNU project if
12this file took our effort away from higher-priority things.
13
14
15This file is part of GNU Emacs.
16
17GNU Emacs is free software; you can redistribute it and/or modify
18it under the terms of the GNU General Public License as published by
19the Free Software Foundation; either version 2, or (at your option)
20any later version.
21
22GNU Emacs is distributed in the hope that it will be useful,
23but WITHOUT ANY WARRANTY; without even the implied warranty of
24MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
25GNU General Public License for more details.
26
27You should have received a copy of the GNU General Public License
28along with GNU Emacs; see the file COPYING.  If not, write to
29the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
30Boston, MA 02110-1301, USA.  */
31
32/* Author: Jeff Peck, Sun Microsystems, Inc. <peck@sun.com>
33Original ideas by David Kastan and Eric Negaard, SRI International
34Major help from: Steve Greenbaum, Reasoning Systems, Inc.
35 		    <froud@kestrel.arpa>
36who first discovered the Menu_Base_Kludge.
37 */
38
39/*
40 *	Emacs Lisp-Callable functions for sunwindows
41 */
42#include <config.h>
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
61/* conversion to/from character & frame coordinates */
62/* From Gosling Emacs SunWindow driver by Chris Torek */
63
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)
67
68/* Frame coords to chars */
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)
73int win_fd = -1;
74struct pixfont *Sun_Font;	/* The font */
75int Sun_Font_Xsize;		/* Width of font  */
76int Sun_Font_Ysize;		/* Height of font */
77
78#define Menu_Base_Kludge	/* until menu_show_using_fd gets fixed */
79#ifdef  Menu_Base_Kludge
80static Frame Menu_Base_Frame;
81static int Menu_Base_fd;
82static Lisp_Object sm_kludge_string;
83#endif
84struct cursor CurrentCursor;	/* The current cursor */
85
86static short CursorData[16];	/* Build cursor here */
87static mpr_static(CursorMpr, 16, 16, 1, CursorData);
88static 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. */
93static short ArrowCursorData[16] = {
94  0x0001,0x0003,0x0007,0x000F,0x001F,0x003F,0x007F,0x000F,
95  0x001B,0x0019,0x0030,0x0030,0x0060,0x0060,0x00C0,0x00C0};
96static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData);
97struct cursor DefaultCursor = {15, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr};
98
99#else
100/* The default left-arrow cursor, with XOR drawing. */
101static short ArrowCursorData[16] = {
102	0x8000,0xC000,0xE000,0xF000,0xF800,0xFC00,0xFE00,0xF000,
103	0xD800,0x9800,0x0C00,0x0C00,0x0600,0x0600,0x0300,0x0300};
104static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData);
105struct cursor DefaultCursor = {0, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr};
106#endif
107
108/*
109 *	Initialize window
110 */
111DEFUN ("sun-window-init", Fsun_window_init, Ssun_window_init, 0, 1, 0,
112       doc: /* One time setup for using Sun Windows with mouse.
113Unless optional argument FORCE is non-nil, is a noop after its first call.
114Returns a number representing the file descriptor of the open Sun Window,
115or -1 if can not open it.  */)
116     (force)
117     Lisp_Object force;
118{
119  char *cp;
120  static int already_initialized = 0;
121
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)
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 */
152DEFUN ("sit-for-millisecs", Fsit_for_millisecs, Ssit_for_millisecs, 1, 1, 0,
153       doc: /* Like sit-for, but ARG is milliseconds.
154Perform redisplay, then wait for ARG milliseconds or until
155input is available.  Returns t if wait completed with no input.
156Redisplay does not happen if input is available before it starts.  */)
157     (n)
158     Lisp_Object n;
159{
160  struct timeval Timeout;
161  int waitmask = 1;
162
163  CHECK_NUMBER (n);
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);
168  redisplay_preserve_echo_area (16);
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 */
182DEFUN ("sleep-for-millisecs",
183       Fsleep_for_millisecs,
184       Ssleep_for_millisecs, 1, 1, 0,
185       doc: /* Pause, without updating display, for ARG milliseconds.  */)
186     (n)
187     Lisp_Object n;
188{
189  unsigned useconds;
190
191  CHECK_NUMBER (n);
192  useconds = XINT(n) * 1000;
193  usleep(useconds);
194  return(Qt);
195}
196
197DEFUN ("update-display", Fupdate_display, Supdate_display, 0, 0, 0,
198       doc: /* Perform redisplay.  */)
199     ()
200{
201  redisplay_preserve_echo_area (17);
202  return(Qt);
203}
204
205
206/*
207 *	Change the Sun mouse icon
208 */
209DEFUN ("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.
213ICON is a lisp vector whose 1st element
214is the X offset of the cursor hot-point, whose 2nd element is the Y offset
215of the cursor hot-point and whose 3rd element is the cursor pixel data
216expressed as a string.  If ICON is nil then the original arrow cursor is used.  */)
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;
224
225  CHECK_GFX (Qnil);
226  /*
227   *	If the icon is null, we just restore the DefaultCursor
228   */
229  if (NILP(Icon))
230    CurrentCursor = DefaultCursor;
231  else {
232    /*
233     *	extract the data from the vector
234     */
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];
240
241    CHECK_NUMBER (X_Hot);
242    CHECK_NUMBER (Y_Hot);
243    CHECK_STRING (Data);
244    if (SCHARS (Data) != 32) return(Qnil);
245    /*
246     *	Setup the new cursor
247     */
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;
256  }
257  win_setcursor(win_fd, &CurrentCursor);
258  return(Qt);
259}
260
261/*
262 *	Interface for sunwindows selection
263 */
264static Lisp_Object Current_Selection;
265
266static
267sel_write (sel, file)
268     struct selection *sel;
269     FILE *file;
270{
271  fwrite (SDATA (Current_Selection), sizeof (char),
272	  sel->sel_items, file);
273}
274
275static
276sel_clear (sel, windowfd)
277     struct selection *sel;
278     int windowfd;
279{
280}
281
282static
283sel_read (sel, file)
284     struct selection *sel;
285     FILE *file;
286{
287  register int i, n;
288  register char *cp;
289
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) {
303    error("Error reading selection");
304    return(-1);
305  }
306  /*
307   * The shelltool select saves newlines as carriage returns,
308   * but emacs wants newlines.
309   */
310  for (i = 0; i < n; i++)
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 */
321DEFUN ("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;
326{
327  struct selection selection;
328
329  CHECK_STRING (str);
330  Current_Selection = str;
331
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);
339}
340/*
341 *	Stuff the current window system selection into the current buffer
342 */
343DEFUN ("sun-get-selection", Fsun_get_selection, Ssun_get_selection, 0, 0, 0,
344       doc: /* Return the current sunwindows selection as a string.  */)
345     ()
346{
347  CHECK_GFX (Current_Selection);
348  selection_get (sel_read, win_fd);
349  return (Current_Selection);
350}
351
352Menu sun_menu_create();
353
354Menu_item
355sun_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  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);
379  }
380  return menu_item;
381}
382
383Menu
384sun_menu_create (Vector)
385     Lisp_Object Vector;
386{
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);
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 */
403int
404make_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 */
424DEFUN ("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.
428Arguments WINDOW, X, Y, BUTTON, and MENU.
429*** User code should generally use sun-menu-evaluate ***
430
431Arguments WINDOW, X, Y, BUTTON, and MENU.
432Put MENU up in WINDOW at position X, Y.
433The BUTTON argument specifies the button to be released that selects an item:
434   1 = LEFT BUTTON
435   2 = MIDDLE BUTTON
436   4 = RIGHT BUTTON
437The MENU argument is a vector containing (STRING . VALUE) pairs.
438The VALUE of the selected item is returned.
439If the VALUE of the first pair is nil, then the first STRING will be used
440as a menu label.  */)
441     (window, X_Position, Y_Position, Button, MEnu)
442     Lisp_Object window, X_Position, Y_Position, Button, MEnu;
443{
444  Menu menu;
445  int button, xpos, ypos;
446  Event event0;
447  Event *event = &event0;
448  Lisp_Object Value, Pair;
449
450  CHECK_NUMBER(X_Position);
451  CHECK_NUMBER(Y_Position);
452  CHECK_LIVE_WINDOW(window);
453  CHECK_NUMBER(Button);
454  CHECK_VECTOR(MEnu);
455
456  CHECK_GFX (Qnil);
457
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));
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 */
500syms_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 */
505  sm_kludge_string = make_pure_string ("sm::menu-kludge", 15, 15, 0);
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}
517
518/* arch-tag: 2d7decb7-58f6-41aa-b45b-077ccfab7158
519   (do not change this comment) */
520