src/sunfns.c

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