src/sunfns.c

   1 /* Functions for Sun Windows menus and selection buffer.
   2    Copyright (C) 1987, 1999 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        "One time setup for using Sun Windows with mouse.\n\
 112 Unless optional argument FORCE is non-nil, is a noop after its first call.\n\
 113 Returns a number representing the file descriptor of the open Sun Window,\n\
 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    "Like sit-for, but ARG is milliseconds. \n\
 153 Perform redisplay, then wait for ARG milliseconds or until\n\
 154 input is available.  Returns t if wait completed with no input.\n\
 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, 0);
 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 ();
 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    "Pause, without updating display, for ARG milliseconds.")
 185         (n)
 186         Lisp_Object n;
 187 {
 188   unsigned useconds;
 189
 190   CHECK_NUMBER (n, 0);
 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        "Perform redisplay.")
 198      ()
 199 {
 200   redisplay_preserve_echo_area ();
 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   "Change the Sun mouse cursor icon.  ICON is a lisp vector whose 1st element\n\
 212 is the X offset of the cursor hot-point, whose 2nd element is the Y offset\n\
 213 of the cursor hot-point and whose 3rd element is the cursor pixel data\n\
 214 expressed as a string.  If ICON is nil then the original arrow cursor is used")
 215      (Icon)
 216      Lisp_Object Icon;
 217 {
 218   register unsigned char *cp;
 219   register short *p;
 220   register int i;
 221   Lisp_Object X_Hot, Y_Hot, Data;
 222
 223   CHECK_GFX (Qnil);
 224   /*
 225    *    If the icon is null, we just restore the DefaultCursor
 226    */
 227   if (NILP(Icon))
 228     CurrentCursor = DefaultCursor;
 229   else {
 230     /*
 231      *  extract the data from the vector
 232      */
 233     CHECK_VECTOR (Icon, 0);
 234     if (XVECTOR(Icon)->size < 3) return(Qnil);
 235     X_Hot = XVECTOR(Icon)->contents[0];
 236     Y_Hot = XVECTOR(Icon)->contents[1];
 237     Data = XVECTOR(Icon)->contents[2];
 238
 239     CHECK_NUMBER (X_Hot, 0);
 240     CHECK_NUMBER (Y_Hot, 0);
 241     CHECK_STRING (Data, 0);
 242     if (XSTRING(Data)->size != 32) return(Qnil);
 243     /*
 244      *  Setup the new cursor
 245      */
 246     NewCursor.cur_xhot = X_Hot;
 247     NewCursor.cur_yhot = Y_Hot;
 248     cp = XSTRING(Data)->data;
 249     p = CursorData;
 250     i = 16;
 251     while(--i >= 0)
 252       *p++ = (cp[0] << 8) | cp[1], cp += 2;
 253     CurrentCursor = NewCursor;
 254   }
 255   win_setcursor(win_fd, &CurrentCursor);
 256   return(Qt);
 257 }
 258 \f
 259 /*
 260  *      Interface for sunwindows selection
 261  */
 262 static Lisp_Object Current_Selection;
 263
 264 static
 265 sel_write (sel, file)
 266      struct selection *sel;
 267      FILE *file;
 268 {
 269   fwrite (XSTRING (Current_Selection)->data, sizeof (char),
 270           sel->sel_items, file);
 271 }
 272
 273 static
 274 sel_clear (sel, windowfd)
 275      struct selection *sel;
 276      int windowfd;
 277 {
 278 }
 279
 280 static
 281 sel_read (sel, file)
 282      struct selection *sel;
 283      FILE *file;
 284 {
 285   register int i, n;
 286   register char *cp;
 287
 288   Current_Selection = make_string ("", 0);
 289   if (sel->sel_items <= 0)
 290     return (0);
 291   cp = (char *) malloc(sel->sel_items);
 292   if (cp == (char *)0) {
 293     error("malloc failed in sel_read");
 294     return(-1);
 295   }
 296   n = fread(cp, sizeof(char), sel->sel_items, file);
 297   if (n > sel->sel_items) {
 298     error("fread botch in sel_read");
 299     return(-1);
 300   } else if (n < 0) {
 301     error("Error reading selection.");
 302     return(-1);
 303   }
 304   /*
 305    * The shelltool select saves newlines as carriage returns,
 306    * but emacs wants newlines.
 307    */
 308   for (i = 0; i < n; i++)
 309     if (cp[i] == '\r') cp[i] = '\n';
 310
 311   Current_Selection = make_string (cp, n);
 312   free (cp);
 313   return (0);
 314 }
 315 \f
 316 /*
 317  *      Set the window system "selection" to be the arg STRING
 318  */
 319 DEFUN ("sun-set-selection", Fsun_set_selection, Ssun_set_selection, 1, 1,
 320        "sSet selection to: ",
 321   "Set the current sunwindow selection to STRING.")
 322      (str)
 323      Lisp_Object str;
 324 {
 325   struct selection selection;
 326
 327   CHECK_STRING (str, 0);
 328   Current_Selection = str;
 329
 330   CHECK_GFX (Qnil);
 331   selection.sel_type = SELTYPE_CHAR;
 332   selection.sel_items = XSTRING (str)->size;
 333   selection.sel_itembytes = 1;
 334   selection.sel_pubflags = 1;
 335   selection_set(&selection, sel_write, sel_clear, win_fd);
 336   return (Qt);
 337 }
 338 /*
 339  *      Stuff the current window system selection into the current buffer
 340  */
 341 DEFUN ("sun-get-selection", Fsun_get_selection, Ssun_get_selection, 0, 0, 0,
 342        "Return the current sunwindows selection as a string.")
 343      ()
 344 {
 345   CHECK_GFX (Current_Selection);
 346   selection_get (sel_read, win_fd);
 347   return (Current_Selection);
 348 }
 349 \f
 350 Menu sun_menu_create();
 351
 352 Menu_item
 353 sun_item_create (Pair)
 354      Lisp_Object Pair;
 355 {
 356   /* In here, we depend on Lisp supplying zero terminated strings in the data*/
 357   /* so we can just pass the pointers, and not recopy anything */
 358
 359   Menu_item menu_item;
 360   Menu submenu;
 361   Lisp_Object String;
 362   Lisp_Object Value;
 363
 364   if (!CONSP(Pair)) wrong_type_argument(Qlistp, Pair);
 365   String = Fcar(Pair);
 366   CHECK_STRING(String, 0);
 367   Value = Fcdr(Pair);
 368   if (SYMBOLP (Value))
 369     Value = XSYMBOL(Value)->value;
 370   if (VECTORP (Value)) {
 371     submenu = sun_menu_create (Value);
 372     menu_item = menu_create_item
 373       (MENU_RELEASE, MENU_PULLRIGHT_ITEM, XSTRING(String)->data, submenu, 0);
 374   } else {
 375     menu_item = menu_create_item
 376       (MENU_RELEASE, MENU_STRING_ITEM, XSTRING(String)->data, Value, 0);
 377   }
 378   return menu_item;
 379 }
 380
 381 Menu
 382 sun_menu_create (Vector)
 383      Lisp_Object Vector;
 384 {
 385   Menu menu;
 386   int i;
 387   CHECK_VECTOR(Vector,0);
 388   menu=menu_create(0);
 389   for(i = 0; i < XVECTOR(Vector)->size; i++) {
 390     menu_set (menu, MENU_APPEND_ITEM,
 391               sun_item_create(XVECTOR(Vector)->contents[i]), 0);
 392   }
 393   return menu;
 394 }
 395
 396 /*
 397  *  If the first item of the menu has nil as its value, then make the
 398  *  item look like a label by inverting it and making it unselectable.
 399  *  Returns 1 if the label was made, 0 otherwise.
 400  */
 401 int
 402 make_menu_label (menu)
 403      Menu menu;
 404 {
 405   int made_label_p = 0;
 406
 407   if (( menu_get(menu, MENU_NITEMS) > 0 ) && /* At least one item */
 408       ((Lisp_Object) menu_get(menu_get(menu, MENU_NTH_ITEM, 1),
 409                               MENU_VALUE) == Qnil )) {
 410       menu_set(menu_get(menu, MENU_NTH_ITEM, 1),
 411                MENU_INVERT, TRUE,
 412                MENU_FEEDBACK, FALSE,
 413                0);
 414       made_label_p = 1;
 415     }
 416   return made_label_p;
 417 }
 418 \f
 419 /*
 420  *      Do a pop-up menu and return the selected value
 421  */
 422 DEFUN ("sun-menu-internal",
 423        Fsun_menu_internal,
 424        Ssun_menu_internal, 5, 5, 0,
 425        "Set up a SunView pop-up menu and return the user's choice.\n\
 426 Arguments WINDOW, X, Y, BUTTON, and MENU.\n\
 427 *** User code should generally use sun-menu-evaluate ***\n\
 428 \n\
 429 Arguments WINDOW, X, Y, BUTTON, and MENU.\n\
 430 Put MENU up in WINDOW at position X, Y.\n\
 431 The BUTTON argument specifies the button to be released that selects an item:\n\
 432    1 = LEFT BUTTON\n\
 433    2 = MIDDLE BUTTON\n\
 434    4 = RIGHT BUTTON\n\
 435 The MENU argument is a vector containing (STRING . VALUE) pairs.\n\
 436 The VALUE of the selected item is returned.\n\
 437 If the VALUE of the first pair is nil, then the first STRING will be used\n\
 438 as a menu label.")
 439       (window, X_Position, Y_Position, Button, MEnu)
 440       Lisp_Object window, X_Position, Y_Position, Button, MEnu;
 441 {
 442   Menu menu;
 443   int button, xpos, ypos;
 444   Event event0;
 445   Event *event = &event0;
 446   Lisp_Object Value, Pair;
 447
 448   CHECK_NUMBER(X_Position, 0);
 449   CHECK_NUMBER(Y_Position, 1);
 450   CHECK_LIVE_WINDOW(window, 2);
 451   CHECK_NUMBER(Button, 3);
 452   CHECK_VECTOR(MEnu, 4);
 453
 454   CHECK_GFX (Qnil);
 455
 456   xpos = CtoSX (WINDOW_LEFT_MARGIN (XWINDOW (window)) + XINT(X_Position));
 457   ypos = CtoSY (XWINDOW(window)->top  + XINT(Y_Position));
 458 #ifdef  Menu_Base_Kludge
 459   {static Lisp_Object symbol[2];
 460    symbol[0] = Fintern (sm_kludge_string, Qnil);
 461    Pair = Ffuncall (1, symbol);
 462    xpos += XINT (XCDR (Pair));
 463    ypos += XINT (XCAR (Pair));
 464  }
 465 #endif
 466
 467   button = XINT(Button);
 468   if(button == 4) button = 3;
 469   event_set_id   (event, BUT(button));
 470   event_set_down (event);
 471   event_set_x    (event, xpos);
 472   event_set_y    (event, ypos);
 473
 474   menu = sun_menu_create(MEnu);
 475   make_menu_label(menu);
 476
 477 #ifdef  Menu_Base_Kludge
 478   Value = (Lisp_Object) menu_show(menu, Menu_Base_Frame, event, 0);
 479 #else
 480 /* This confuses the notifier or something: */
 481   Value = (Lisp_Object) menu_show_using_fd(menu, win_fd, event, 0);
 482 /*
 483  * Right button gets lost, and event sequencing or delivery gets mixed up
 484  * So, until that gets fixed, we use this <Menu_Base_Frame> kludge:
 485  */
 486 #endif
 487   menu_destroy (menu);
 488
 489   return ((int)Value ? Value : Qnil);
 490 }
 491
 492 \f
 493 /*
 494  *      Define everything
 495  */
 496 syms_of_sunfns()
 497 {
 498 #ifdef  Menu_Base_Kludge
 499   /* i'm just too lazy to re-write this into C code */
 500   /* so we will call this elisp function from C */
 501   sm_kludge_string = make_pure_string ("sm::menu-kludge", 15, 15, 0);
 502 #endif /* Menu_Base_Kludge */
 503
 504   defsubr(&Ssun_window_init);
 505   defsubr(&Ssit_for_millisecs);
 506   defsubr(&Ssleep_for_millisecs);
 507   defsubr(&Supdate_display);
 508   defsubr(&Ssun_change_cursor_icon);
 509   defsubr(&Ssun_set_selection);
 510   defsubr(&Ssun_get_selection);
 511   defsubr(&Ssun_menu_internal);
 512 }