emacs / src / sunfns.c

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
/* Functions for Sun Windows menus and selection buffer.
   Copyright (C) 1987 Free Software Foundation, Inc.

This file is probably totally obsolete.  In any case, the FSF is
unwilling to support it.  We agreed to include it in our distribution
only on the understanding that we would spend no time at all on it.

If you have complaints about this file, send them to peck@sun.com.
If no one at Sun wants to maintain this, then consider it not
maintained at all.  It would be a bad thing for the GNU project if
this file took our effort away from higher-priority things.


This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

/* Author: Jeff Peck, Sun Microsystems, Inc. <peck@sun.com>
Original ideas by David Kastan and Eric Negaard, SRI International
Major help from: Steve Greenbaum, Reasoning Systems, Inc.
 		    <froud@kestrel.arpa>
who first discovered the Menu_Base_Kludge.
 */

/*
 *	Emacs Lisp-Callable functions for sunwindows
 */
#include <config.h>

#include <stdio.h>
#include <errno.h>
#include <signal.h>
#include <sunwindow/window_hs.h>
#include <suntool/selection.h>
#include <suntool/menu.h>
#include <suntool/walkmenu.h>
#include <suntool/frame.h>
#include <suntool/window.h>

#include <fcntl.h>
#undef NULL /* We don't need sunview's idea of NULL */
#include "lisp.h"
#include "window.h"
#include "buffer.h"
#include "termhooks.h"

/* conversion to/from character & frame coordinates */
/* From Gosling Emacs SunWindow driver by Chris Torek */

/* Chars to frame coords.  Note that we speak in zero origin. */
#define CtoSX(cx) ((cx) * Sun_Font_Xsize)
#define CtoSY(cy) ((cy) * Sun_Font_Ysize)

/* Frame coords to chars */
#define StoCX(sx) ((sx) / Sun_Font_Xsize)
#define StoCY(sy) ((sy) / Sun_Font_Ysize)

#define CHECK_GFX(x) if((win_fd<0)&&(Fsun_window_init(),(win_fd<0)))return(x)
int win_fd = -1;
struct pixfont *Sun_Font;	/* The font */
int Sun_Font_Xsize;		/* Width of font  */
int Sun_Font_Ysize;		/* Height of font */

#define Menu_Base_Kludge	/* until menu_show_using_fd gets fixed */
#ifdef  Menu_Base_Kludge
static Frame Menu_Base_Frame;
static int Menu_Base_fd;
static Lisp_Object sm_kludge_string;
#endif
struct cursor CurrentCursor;	/* The current cursor */

static short CursorData[16];	/* Build cursor here */
static mpr_static(CursorMpr, 16, 16, 1, CursorData);
static struct cursor NewCursor = {0, 0, PIX_SRC ^ PIX_DST, &CursorMpr};

#define RIGHT_ARROW_CURSOR	/* if you want the right arrow */
#ifdef RIGHT_ARROW_CURSOR
/* The default right-arrow cursor, with XOR drawing. */
static short ArrowCursorData[16] = {
  0x0001,0x0003,0x0007,0x000F,0x001F,0x003F,0x007F,0x000F,
  0x001B,0x0019,0x0030,0x0030,0x0060,0x0060,0x00C0,0x00C0};
static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData);
struct cursor DefaultCursor = {15, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr};

#else
/* The default left-arrow cursor, with XOR drawing. */
static short ArrowCursorData[16] = {
	0x8000,0xC000,0xE000,0xF000,0xF800,0xFC00,0xFE00,0xF000,
	0xD800,0x9800,0x0C00,0x0C00,0x0600,0x0600,0x0300,0x0300};
static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData);
struct cursor DefaultCursor = {0, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr};
#endif

/*
 *	Initialize window
 */
DEFUN ("sun-window-init", Fsun_window_init, Ssun_window_init, 0, 1, 0,
       "One time setup for using Sun Windows with mouse.\n\
Unless optional argument FORCE is non-nil, is a noop after its first call.\n\
Returns a number representing the file descriptor of the open Sun Window,\n\
or -1 if can not open it.")
      (force)
      Lisp_Object force;
{
  char *cp;
  static int already_initialized = 0;

  if ((! already_initialized) || (!NILP(force))) {
    cp = getenv("WINDOW_GFX");
    if (cp != 0) win_fd = open(cp, 2);
    if (win_fd > 0)
      {
	Sun_Font = pf_default();
	Sun_Font_Xsize = Sun_Font->pf_defaultsize.x;
	Sun_Font_Ysize = Sun_Font->pf_defaultsize.y;
	Fsun_change_cursor_icon (Qnil);	/* set up the default cursor */
	already_initialized = 1;
#ifdef  Menu_Base_Kludge

	/* Make a frame to use for putting the menu on, and get its fd. */
	Menu_Base_Frame = window_create(0, FRAME,
					WIN_X, 0, WIN_Y, 0,
					WIN_ROWS, 1, WIN_COLUMNS, 1,
					WIN_SHOW, FALSE,
					FRAME_NO_CONFIRM, 1,
					0);
	Menu_Base_fd = (int) window_get(Menu_Base_Frame, WIN_FD);
#endif
      }
  }
  return(make_number(win_fd));
}

/*
 *	Mouse sit-for (allows a shorter interval than the regular sit-for
 *	and can be interrupted by the mouse)
 */
DEFUN ("sit-for-millisecs", Fsit_for_millisecs, Ssit_for_millisecs, 1, 1, 0,
   "Like sit-for, but ARG is milliseconds. \n\
Perform redisplay, then wait for ARG milliseconds or until\n\
input is available.  Returns t if wait completed with no input.\n\
Redisplay does not happen if input is available before it starts.")
	(n)
	Lisp_Object n;
{
  struct timeval Timeout;
  int waitmask = 1;
  
  CHECK_NUMBER (n, 0);
  Timeout.tv_sec = XINT(n) / 1000;
  Timeout.tv_usec = (XINT(n) - (Timeout.tv_sec * 1000)) * 1000;

  if (detect_input_pending()) return(Qnil);
  redisplay_preserve_echo_area ();
  /*
   *	Check for queued keyboard input/mouse hits again
   *	(A bit screen update can take some time!)
   */
  if (detect_input_pending()) return(Qnil);
  select(1,&waitmask,0,0,&Timeout);
  if (detect_input_pending()) return(Qnil);
  return(Qt);
}

/*
 *   Sun sleep-for (allows a shorter interval than the regular sleep-for)
 */
DEFUN ("sleep-for-millisecs", 
	Fsleep_for_millisecs,
	Ssleep_for_millisecs, 1, 1, 0,
   "Pause, without updating display, for ARG milliseconds.")
	(n)
	Lisp_Object n;
{
  unsigned useconds;

  CHECK_NUMBER (n, 0);
  useconds = XINT(n) * 1000;
  usleep(useconds);
  return(Qt);
}

DEFUN ("update-display", Fupdate_display, Supdate_display, 0, 0, 0,
       "Perform redisplay.")
     ()
{
  redisplay_preserve_echo_area ();
  return(Qt);
}


/*
 *	Change the Sun mouse icon
 */
DEFUN ("sun-change-cursor-icon",
	Fsun_change_cursor_icon,
	Ssun_change_cursor_icon, 1, 1, 0,
  "Change the Sun mouse cursor icon.  ICON is a lisp vector whose 1st element\n\
is the X offset of the cursor hot-point, whose 2nd element is the Y offset\n\
of the cursor hot-point and whose 3rd element is the cursor pixel data\n\
expressed as a string.  If ICON is nil then the original arrow cursor is used")
     (Icon)
     Lisp_Object Icon;
{
  register unsigned char *cp;
  register short *p;
  register int i;
  Lisp_Object X_Hot, Y_Hot, Data;
  
  CHECK_GFX (Qnil);
  /*
   *	If the icon is null, we just restore the DefaultCursor
   */
  if (NILP(Icon)) 
    CurrentCursor = DefaultCursor;
  else {
    /*
     *	extract the data from the vector
     */
    CHECK_VECTOR (Icon, 0);
    if (XVECTOR(Icon)->size < 3) return(Qnil);
    X_Hot = XVECTOR(Icon)->contents[0];
    Y_Hot = XVECTOR(Icon)->contents[1];
    Data = XVECTOR(Icon)->contents[2];
    
    CHECK_NUMBER (X_Hot, 0);
    CHECK_NUMBER (Y_Hot, 0);
    CHECK_STRING (Data, 0);
    if (XSTRING(Data)->size != 32) return(Qnil);
    /*
     *	Setup the new cursor
     */
    NewCursor.cur_xhot = X_Hot;
    NewCursor.cur_yhot = Y_Hot;
    cp = XSTRING(Data)->data;
    p = CursorData;
    i = 16;
    while(--i >= 0)
      *p++ = (cp[0] << 8) | cp[1], cp += 2;
    CurrentCursor = NewCursor;
  }
  win_setcursor(win_fd, &CurrentCursor);
  return(Qt);
}

/*
 *	Interface for sunwindows selection
 */
static Lisp_Object Current_Selection;

static
sel_write (sel, file)
     struct selection *sel;
     FILE *file;
{
  fwrite (XSTRING (Current_Selection)->data, sizeof (char), 
	  sel->sel_items, file);
}

static
sel_clear (sel, windowfd)
     struct selection *sel;
     int windowfd;
{
}

static
sel_read (sel, file)
     struct selection *sel;
     FILE *file;
{
  register int i, n;
  register char *cp;
  
  Current_Selection = make_string ("", 0);
  if (sel->sel_items <= 0)
    return (0);
  cp = (char *) malloc(sel->sel_items);
  if (cp == (char *)0) {
    error("malloc failed in sel_read");
    return(-1);
  }
  n = fread(cp, sizeof(char), sel->sel_items, file);
  if (n > sel->sel_items) {
    error("fread botch in sel_read");
    return(-1);
  } else if (n < 0) {
    error("Error reading selection.");
    return(-1);
  }
  /*
   * The shelltool select saves newlines as carriage returns,
   * but emacs wants newlines.
   */
  for (i = 0; i < n; i++) 
    if (cp[i] == '\r') cp[i] = '\n';

  Current_Selection = make_string (cp, n);
  free (cp);
  return (0);
}

/*
 *	Set the window system "selection" to be the arg STRING
 */
DEFUN ("sun-set-selection", Fsun_set_selection, Ssun_set_selection, 1, 1,
       "sSet selection to: ",
  "Set the current sunwindow selection to STRING.")
     (str)
     Lisp_Object str;
{
  struct selection selection;

  CHECK_STRING (str, 0);
  Current_Selection = str;

  CHECK_GFX (Qnil);
  selection.sel_type = SELTYPE_CHAR;
  selection.sel_items = XSTRING (str)->size;
  selection.sel_itembytes = 1;
  selection.sel_pubflags = 1;
  selection_set(&selection, sel_write, sel_clear, win_fd);
  return (Qt);
}
/*
 *	Stuff the current window system selection into the current buffer
 */
DEFUN ("sun-get-selection", Fsun_get_selection, Ssun_get_selection, 0, 0, 0,
       "Return the current sunwindows selection as a string.")
     ()
{
  CHECK_GFX (Current_Selection);
  selection_get (sel_read, win_fd);
  return (Current_Selection);
}

Menu sun_menu_create();

Menu_item
sun_item_create (Pair)
     Lisp_Object Pair;
{
  /* In here, we depend on Lisp supplying zero terminated strings in the data*/
  /* so we can just pass the pointers, and not recopy anything */

  Menu_item menu_item;
  Menu submenu;
  Lisp_Object String;
  Lisp_Object Value;

  if (!CONSP(Pair)) wrong_type_argument(Qlistp, Pair);
  String = Fcar(Pair);
  CHECK_STRING(String, 0);
  Value = Fcdr(Pair);
  if (SYMBOLP (Value))
    Value = XSYMBOL(Value)->value;
  if (VECTORP (Value)) {
    submenu = sun_menu_create (Value);
    menu_item = menu_create_item
      (MENU_RELEASE, MENU_PULLRIGHT_ITEM, XSTRING(String)->data, submenu, 0);
  } else {
    menu_item = menu_create_item
      (MENU_RELEASE, MENU_STRING_ITEM, XSTRING(String)->data, Value, 0);
  }
  return menu_item;
}

Menu 
sun_menu_create (Vector)
     Lisp_Object Vector;
{
  Menu menu;
  int i;
  CHECK_VECTOR(Vector,0);
  menu=menu_create(0); 
  for(i = 0; i < XVECTOR(Vector)->size; i++) {
    menu_set (menu, MENU_APPEND_ITEM, 
	      sun_item_create(XVECTOR(Vector)->contents[i]), 0);
  }
  return menu;
}

/*
 *  If the first item of the menu has nil as its value, then make the
 *  item look like a label by inverting it and making it unselectable.
 *  Returns 1 if the label was made, 0 otherwise.
 */
int
make_menu_label (menu)
     Menu menu;
{
  int made_label_p = 0;

  if (( menu_get(menu, MENU_NITEMS) > 0 ) && /* At least one item */
      ((Lisp_Object) menu_get(menu_get(menu, MENU_NTH_ITEM, 1),
			      MENU_VALUE) == Qnil )) {
      menu_set(menu_get(menu, MENU_NTH_ITEM, 1),
	       MENU_INVERT, TRUE,
	       MENU_FEEDBACK, FALSE,
	       0);
      made_label_p = 1;
    }
  return made_label_p;
}

/*
 *	Do a pop-up menu and return the selected value
 */
DEFUN ("sun-menu-internal",
       Fsun_menu_internal,
       Ssun_menu_internal, 5, 5, 0,
       "Set up a SunView pop-up menu and return the user's choice.\n\
Arguments WINDOW, X, Y, BUTTON, and MENU.\n\
*** User code should generally use sun-menu-evaluate ***\n\
\n\
Arguments WINDOW, X, Y, BUTTON, and MENU.\n\
Put MENU up in WINDOW at position X, Y.\n\
The BUTTON argument specifies the button to be released that selects an item:\n\
   1 = LEFT BUTTON\n\
   2 = MIDDLE BUTTON\n\
   4 = RIGHT BUTTON\n\
The MENU argument is a vector containing (STRING . VALUE) pairs.\n\
The VALUE of the selected item is returned.\n\
If the VALUE of the first pair is nil, then the first STRING will be used\n\
as a menu label.")
      (window, X_Position, Y_Position, Button, MEnu)
      Lisp_Object window, X_Position, Y_Position, Button, MEnu;
{
  Menu menu;
  int button, xpos, ypos;
  Event event0;
  Event *event = &event0;
  Lisp_Object Value, Pair;
  
  CHECK_NUMBER(X_Position, 0);
  CHECK_NUMBER(Y_Position, 1);
  CHECK_LIVE_WINDOW(window, 2);
  CHECK_NUMBER(Button, 3);
  CHECK_VECTOR(MEnu, 4);

  CHECK_GFX (Qnil);

  xpos = CtoSX (WINDOW_LEFT_MARGIN (XWINDOW (window)) + XINT(X_Position));
  ypos = CtoSY (XWINDOW(window)->top  + XINT(Y_Position));
#ifdef  Menu_Base_Kludge
  {static Lisp_Object symbol[2];
   symbol[0] = Fintern (sm_kludge_string, Qnil);
   Pair = Ffuncall (1, symbol);
   xpos += XINT (XCONS (Pair)->cdr);
   ypos += XINT (XCONS (Pair)->car);
 }
#endif

  button = XINT(Button);
  if(button == 4) button = 3;
  event_set_id   (event, BUT(button));
  event_set_down (event);
  event_set_x    (event, xpos);
  event_set_y    (event, ypos);

  menu = sun_menu_create(MEnu);
  make_menu_label(menu);

#ifdef  Menu_Base_Kludge
  Value = (Lisp_Object) menu_show(menu, Menu_Base_Frame, event, 0);
#else
/* This confuses the notifier or something: */
  Value = (Lisp_Object) menu_show_using_fd(menu, win_fd, event, 0);
/*
 * Right button gets lost, and event sequencing or delivery gets mixed up
 * So, until that gets fixed, we use this <Menu_Base_Frame> kludge:
 */
#endif
  menu_destroy (menu);

  return ((int)Value ? Value : Qnil);
}


/*
 *	Define everything
 */
syms_of_sunfns()
{
#ifdef  Menu_Base_Kludge
  /* i'm just too lazy to re-write this into C code */
  /* so we will call this elisp function from C */
  sm_kludge_string = make_pure_string ("sm::menu-kludge", 15, 15, 0);
#endif /* Menu_Base_Kludge */

  defsubr(&Ssun_window_init);
  defsubr(&Ssit_for_millisecs);
  defsubr(&Ssleep_for_millisecs);
  defsubr(&Supdate_display);
  defsubr(&Ssun_change_cursor_icon);
  defsubr(&Ssun_set_selection);
  defsubr(&Ssun_get_selection);
  defsubr(&Ssun_menu_internal);
}
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.