code.delx.au - gnu-emacs/blob - src/sunfns.c

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