src/sunfns.c

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