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