Mercurial > emacs
diff src/xselect.c @ 2161:533cca1014e1
Initial revision
| author | Richard M. Stallman <rms@gnu.org> |
|---|---|
| date | Sat, 13 Mar 1993 20:12:23 +0000 |
| parents | |
| children | 8ba4fffa6566 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/xselect.c Sat Mar 13 20:12:23 1993 +0000 @@ -0,0 +1,1949 @@ +/* x_handle_selection_notify +x_reply_selection_request +XFree +x_selection_timeout initial value */ + +/* X Selection processing for emacs + Copyright (C) 1990-1993 Free Software Foundation. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + +/* Rewritten by jwz */ + +#include "config.h" +#include "lisp.h" +#include "xterm.h" /* for all of the X includes */ +#include "dispextern.h" /* screen.h seems to want this */ +#include "screen.h" /* Need this to get the X window of selected_screen */ + +#define CUT_BUFFER_SUPPORT + +static Atom Xatom_CLIPBOARD, Xatom_TIMESTAMP, Xatom_TEXT, Xatom_DELETE, + Xatom_MULTIPLE, Xatom_INCR, Xatom_EMACS_TMP, Xatom_TARGETS, Xatom_NULL, + Xatom_ATOM_PAIR; + +Lisp_Object QPRIMARY, QSECONDARY, QSTRING, QINTEGER, QCLIPBOARD, QTIMESTAMP, + QTEXT, QDELETE, QMULTIPLE, QINCR, QEMACS_TMP, QTARGETS, QATOM, QNULL, + QATOM_PAIR; + +#ifdef CUT_BUFFER_SUPPORT +Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3, + QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7; +#endif + +Lisp_Object Vx_lost_selection_hooks; +Lisp_Object Vx_sent_selection_hooks; + +/* If this is a smaller number than the max-request-size of the display, + emacs will use INCR selection transfer when the selection is larger + than this. The max-request-size is usually around 64k, so if you want + emacs to use incremental selection transfers when the selection is + smaller than that, set this. I added this mostly for debugging the + incremental transfer stuff, but it might improve server performance. + */ +#define MAX_SELECTION_QUANTUM 0xFFFFFF + +#define SELECTION_QUANTUM(dpy) ((XMaxRequestSize (dpy) << 2) - 100) + + +/* The time of the last-read mouse or keyboard event. + For selection purposes, we use this as a sleazy way of knowing what the + current time is in server-time. This assumes that the most recently read + mouse or keyboard event has something to do with the assertion of the + selection, which is probably true. + */ +extern Time mouse_timestamp; + + +/* This is an association list whose elements are of the form + ( selection-name selection-value selection-timestamp ) + selection-name is a lisp symbol, whose name is the name of an X Atom. + selection-value is the value that emacs owns for that selection. + It may be any kind of Lisp object. + selection-timestamp is the time at which emacs began owning this selection, + as a cons of two 16-bit numbers (making a 32 bit time.) + If there is an entry in this alist, then it can be assumed that emacs owns + that selection. + The only (eq) parts of this list that are visible from Lisp are the + selection-values. + */ +Lisp_Object Vselection_alist; + +/* This is an alist whose CARs are selection-types (whose names are the same + as the names of X Atoms) and whose CDRs are the names of Lisp functions to + call to convert the given Emacs selection value to a string representing + the given selection type. This is for Lisp-level extension of the emacs + selection handling. + */ +Lisp_Object Vselection_converter_alist; + +/* If the selection owner takes too long to reply to a selection request, + we give up on it. This is in seconds (0 = no timeout.) + */ +int x_selection_timeout; + + +/* Utility functions */ + +static void lisp_data_to_selection_data (); +static Lisp_Object selection_data_to_lisp_data (); +static Lisp_Object x_get_window_property_as_lisp_data (); + +static int expect_property_change (); +static void wait_for_property_change (); +static void unexpect_property_change (); +static int waiting_for_other_props_on_window (); + +/* This converts a Lisp symbol to a server Atom, avoiding a server + roundtrip whenever possible. */ + +static Atom +symbol_to_x_atom (display, sym) + Display *display; + Lisp_Object sym; +{ + Atom val; + if (NILP (sym)) return 0; + if (EQ (sym, QPRIMARY)) return XA_PRIMARY; + if (EQ (sym, QSECONDARY)) return XA_SECONDARY; + if (EQ (sym, QSTRING)) return XA_STRING; + if (EQ (sym, QINTEGER)) return XA_INTEGER; + if (EQ (sym, QATOM)) return XA_ATOM; + if (EQ (sym, QCLIPBOARD)) return Xatom_CLIPBOARD; + if (EQ (sym, QTIMESTAMP)) return Xatom_TIMESTAMP; + if (EQ (sym, QTEXT)) return Xatom_TEXT; + if (EQ (sym, QDELETE)) return Xatom_DELETE; + if (EQ (sym, QMULTIPLE)) return Xatom_MULTIPLE; + if (EQ (sym, QINCR)) return Xatom_INCR; + if (EQ (sym, QEMACS_TMP)) return Xatom_EMACS_TMP; + if (EQ (sym, QTARGETS)) return Xatom_TARGETS; + if (EQ (sym, QNULL)) return Xatom_NULL; +#ifdef CUT_BUFFER_SUPPORT + if (EQ (sym, QCUT_BUFFER0)) return XA_CUT_BUFFER0; + if (EQ (sym, QCUT_BUFFER1)) return XA_CUT_BUFFER1; + if (EQ (sym, QCUT_BUFFER2)) return XA_CUT_BUFFER2; + if (EQ (sym, QCUT_BUFFER3)) return XA_CUT_BUFFER3; + if (EQ (sym, QCUT_BUFFER4)) return XA_CUT_BUFFER4; + if (EQ (sym, QCUT_BUFFER5)) return XA_CUT_BUFFER5; + if (EQ (sym, QCUT_BUFFER6)) return XA_CUT_BUFFER6; + if (EQ (sym, QCUT_BUFFER7)) return XA_CUT_BUFFER7; +#endif + if (!SYMBOLP (sym)) abort (); + +#if 0 + fprintf (stderr, " XInternAtom %s\n", (char *) XSYMBOL (sym)->name->data); +#endif + BLOCK_INPUT; + val = XInternAtom (display, (char *) XSYMBOL (sym)->name->data, False); + UNBLOCK_INPUT; + return val; +} + + +/* This converts a server Atom to a Lisp symbol, avoiding server roundtrips + and calls to intern whenever possible. */ + +static Lisp_Object +x_atom_to_symbol (display, atom) + Display *display; + Atom atom; +{ + char *str; + Lisp_Object val; + if (! atom) return Qnil; + case XA_PRIMARY: + return QPRIMARY; + case XA_SECONDARY: + return QSECONDARY; + case XA_STRING: + return QSTRING; + case XA_INTEGER: + return QINTEGER; + case XA_ATOM: + return QATOM; + case Xatom_CLIPBOARD: + return QCLIPBOARD; + case Xatom_TIMESTAMP: + return QTIMESTAMP; + case Xatom_TEXT: + return QTEXT; + case Xatom_DELETE: + return QDELETE; + case Xatom_MULTIPLE: + return QMULTIPLE; + case Xatom_INCR: + return QINCR; + case Xatom_EMACS_TMP: + return QEMACS_TMP; + case Xatom_TARGETS: + return QTARGETS; + case Xatom_NULL: + return QNULL; +#ifdef CUT_BUFFER_SUPPORT + case XA_CUT_BUFFER0: + return QCUT_BUFFER0; + case XA_CUT_BUFFER1: + return QCUT_BUFFER1; + case XA_CUT_BUFFER2: + return QCUT_BUFFER2; + case XA_CUT_BUFFER3: + return QCUT_BUFFER3; + case XA_CUT_BUFFER4: + return QCUT_BUFFER4; + case XA_CUT_BUFFER5: + return QCUT_BUFFER5; + case XA_CUT_BUFFER6: + return QCUT_BUFFER6; + case XA_CUT_BUFFER7: + return QCUT_BUFFER7; +#endif + + BLOCK_INPUT; + str = XGetAtomName (display, atom); + UNBLOCK_INPUT; +#if 0 + fprintf (stderr, " XGetAtomName --> %s\n", str); +#endif + if (! str) return Qnil; + val = intern (str); + BLOCK_INPUT; + XFree (str); + UNBLOCK_INPUT; + return val; +} + + +static Lisp_Object +long_to_cons (i) + unsigned long i; +{ + unsigned int top = i >> 16; + unsigned int bot = i & 0xFFFF; + if (top == 0) return make_number (bot); + if (top == 0xFFFF) return Fcons (make_number (-1), make_number (bot)); + return Fcons (make_number (top), make_number (bot)); +} + +static unsigned long +cons_to_long (c) + Lisp_Object c; +{ + int top, bot; + if (FIXNUMP (c)) return XINT (c); + top = XCONS (c)->car; + bot = XCONS (c)->cdr; + if (CONSP (bot)) bot = XCONS (bot)->car; + return ((XINT (top) << 16) | XINT (bot)); +} + + + +/* Do protocol to assert ourself as a selection owner. + Update the Vselection_alist so that we can reply to later requests for + our selection. */ + +static void +x_own_selection (selection_name, selection_value) + Lisp_Object selection_name, selection_value; +{ + Display *display = x_current_display; +#ifdef X_TOOLKIT + Window selecting_window = XtWindow (selected_screen->display.x->edit_widget); +#else + Window selecting_window = FRAME_X_WINDOW (selected_frame); +#endif + Time time = mouse_timestamp; + Atom selection_atom; + + CHECK_SYMBOL (selection_name, 0); + selection_atom = symbol_to_x_atom (display, selection_name); + + BLOCK_INPUT; + XSetSelectionOwner (display, selection_atom, selecting_window, time); + UNBLOCK_INPUT; + + /* Now update the local cache */ + { + Lisp_Object selection_time; + Lisp_Object selection_data; + Lisp_Object prev_value; + + selection_time = long_to_cons ((unsigned long) time); + selection_data = Fcons (selection_name, + Fcons (selection_value, + Fcons (selection_time, Qnil))); + prev_value = assq_no_quit (selection_name, Vselection_alist); + + Vselection_alist = Fcons (selection_data, Vselection_alist); + + /* If we already owned the selection, remove the old selection data. + Perhaps we should destructively modify it instead. + Don't use Fdelq as that may QUIT. */ + if (!NILP (prev_value)) + { + Lisp_Object rest; /* we know it's not the CAR, so it's easy. */ + for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest)) + if (EQ (prev_value, Fcar (XCONS (rest)->cdr))) + { + XCONS (rest)->cdr = Fcdr (XCONS (rest)->cdr); + break; + } + } + } +} + +/* Given a selection-name and desired type, look up our local copy of + the selection value and convert it to the type. + The value is nil or a string. + This function is used both for remote requests + and for local x-get-selection-internal. */ + + This calls random Lisp code, and may signal or gc. */ + +static Lisp_Object +x_get_local_selection (selection_symbol, target_type) + Lisp_Object selection_symbol, target_type; +{ + Lisp_Object local_value; + Lisp_Object handler_fn, value, type, check; + int count; + + local_value = assq_no_quit (selection_symbol, Vselection_alist); + + if (NILP (local_value)) return Qnil; + + /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */ + if (EQ (target_type, QTIMESTAMP)) + { + handler_fn = Qnil; + value = XCONS (XCONS (XCONS (local_value)->cdr)->cdr)->car; + } +#if 0 + else if (EQ (target_type, QDELETE)) + { + handler_fn = Qnil; + Fx_disown_selection_internal + (selection_symbol, + XCONS (XCONS (XCONS (local_value)->cdr)->cdr)->car); + value = QNULL; + } +#endif + +#if 0 /* #### MULTIPLE doesn't work yet */ + else if (CONSP (target_type) + && XCONS (target_type)->car == QMULTIPLE) + { + Lisp_Object pairs = XCONS (target_type)->cdr; + int size = XVECTOR (pairs)->size; + int i; + /* If the target is MULTIPLE, then target_type looks like + (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ]) + We modify the second element of each pair in the vector and + return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ] + */ + for (i = 0; i < size; i++) + { + Lisp_Object pair = XVECTOR (pairs)->contents [i]; + XVECTOR (pair)->contents [1] + = x_get_local_selection (XVECTOR (pair)->contents [0], + XVECTOR (pair)->contents [1]); + } + return pairs; + } +#endif + else + { + /* Don't allow a quit within the converter. + When the user types C-g, he would be surprised + if by luck it came during a converter. */ + count = specpdl_ptr - specpdl; + specbind (Qinhibit_quit, Qt); + + CHECK_SYMBOL (target_type, 0); + handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist)); + if (NILP (handler_fn)) return Qnil; + value = call3 (handler_fn, + selection_symbol, target_type, + XCONS (XCONS (local_value)->cdr)->car); + unbind_to (count, Qnil); + } + + /* Make sure this value is of a type that we could transmit + to another X client. */ + check = value; + if (CONSP (value) + && SYMBOLP (XCONS (value)->car)) + type = XCONS (value)->car, + check = XCONS (value)->cdr; + + if (STRINGP (check) + || VECTORP (check) + || SYMBOLP (check) + || FIXNUMP (check) + || NILP (value)) + return value; + else if (CONSP (check) + && FIXNUMP (XCONS (check)->car) + && (FIXNUMP (XCONS (check)->cdr) + || + (CONSP (XCONS (check)->cdr) + && FIXNUMP (XCONS (XCONS (check)->cdr)->car) + && NILP (XCONS (XCONS (check)->cdr)->cdr)))) + return value; + else + return + Fsignal (Qerror, + Fcons (build_string ("unrecognised selection-conversion type"), + Fcons (handler_fn, Fcons (value, Qnil)))); +} + +/* Subroutines of x_reply_selection_request. */ + +/* Send a SelectionNotify event to the requestor with property=None, + meaning we were unable to do what they wanted. */ + +static void +x_decline_selection_request (event) + struct input_event *event; +{ + XSelectionEvent reply; + reply.type = SelectionNotify; + reply.display = SELECTION_EVENT_DISPLAY (event); + reply.requestor = SELECTION_EVENT_REQUESTOR (event); + reply.selection = SELECTION_EVENT_SELECTION (event); + reply.time = SELECTION_EVENT_TIME (event); + reply.target = SELECTION_EVENT_TARGET (event); + reply.property = None; + + BLOCK_INPUT; + (void) XSendEvent (reply.display, reply.requestor, False, 0L, + (XEvent *) &reply); + UNBLOCK_INPUT; +} + +/* This is the selection request currently being processed. + It is set to zero when the request is fully processed. */ +static struct input_event *x_selection_current_request; + +/* Used as an unwind-protect clause so that, if a selection-converter signals + an error, we tell the requestor that we were unable to do what they wanted + before we throw to top-level or go into the debugger or whatever. */ + +static Lisp_Object +x_selection_request_lisp_error (ignore) + Lisp_Object ignore; +{ + if (x_selection_current_request != 0) + x_decline_selection_request (x_selection_current_request); + return Qnil; +} + +/* Send the reply to a selection request event EVENT. + TYPE is the type of selection data requested. + DATA and SIZE describe the data to send, already converted. + FORMAT is the unit-size (in bits) of the data to be transmitted. */ + +static void +x_reply_selection_request (event, format, data, size, type) + struct input_event *event; + int format, size; + unsigned char *data; + Atom type; +{ + XSelectionEvent reply; + Display *display = SELECTION_EVENT_DISPLAY (event); + Window window = SELECTION_EVENT_REQUESTOR (event); + int bytes_remaining; + int format_bytes = format/8; + int max_bytes = SELECTION_QUANTUM (display); + + if (max_bytes > MAX_SELECTION_QUANTUM) + max_bytes = MAX_SELECTION_QUANTUM; + + reply.type = SelectionNotify; + reply.display = display; + reply.requestor = window; + reply.selection = SELECTION_EVENT_SELECTION (event); + reply.time = SELECTION_EVENT_TIME (event); + reply.target = SELECTION_EVENT_TARGET (event); + reply.property = SELECTION_EVENT_PROPERTY (event); + if (reply.property == None) + reply.property = reply.target; + + /* #### XChangeProperty can generate BadAlloc, and we must handle it! */ + + BLOCK_INPUT; + /* Store the data on the requested property. + If the selection is large, only store the first N bytes of it. + */ + bytes_remaining = size * format_bytes; + if (bytes_remaining <= max_bytes) + { + /* Send all the data at once, with minimal handshaking. */ +#if 0 + fprintf (stderr,"\nStoring all %d\n", bytes_remaining); +#endif + XChangeProperty (display, window, reply.property, type, format, + PropModeReplace, data, size); + /* At this point, the selection was successfully stored; ack it. */ + (void) XSendEvent (display, window, False, 0L, (XEvent *) &reply); + } + else + { + /* Send an INCR selection. */ + int prop_id; + + if (x_window_to_screen (window)) /* #### debug */ + error ("attempt to transfer an INCR to ourself!"); +#if 0 + fprintf (stderr, "\nINCR %d\n", bytes_remaining); +#endif + prop_id = expect_property_change (display, window, reply.property, + PropertyDelete); + + XChangeProperty (display, window, reply.property, Xatom_INCR, + 32, PropModeReplace, (unsigned char *) + &bytes_remaining, 1); + XSelectInput (display, window, PropertyChangeMask); + /* Tell 'em the INCR data is there... */ + (void) XSendEvent (display, window, False, 0L, (XEvent *) &reply); + + /* First, wait for the requestor to ack by deleting the property. + This can run random lisp code (process handlers) or signal. */ + wait_for_property_change (prop_id); + + while (bytes_remaining) + { + int i = ((bytes_remaining < max_bytes) + ? bytes_remaining + : max_bytes); + prop_id = expect_property_change (display, window, reply.property, + PropertyDelete); +#if 0 + fprintf (stderr," INCR adding %d\n", i); +#endif + /* Append the next chunk of data to the property. */ + XChangeProperty (display, window, reply.property, type, format, + PropModeAppend, data, i / format_bytes); + bytes_remaining -= i; + data += i; + + /* Now wait for the requestor to ack this chunk by deleting the + property. This can run random lisp code or signal. + */ + wait_for_property_change (prop_id); + } + /* Now write a zero-length chunk to the property to tell the requestor + that we're done. */ +#if 0 + fprintf (stderr," INCR done\n"); +#endif + if (! waiting_for_other_props_on_window (display, window)) + XSelectInput (display, window, 0L); + + XChangeProperty (display, window, reply.property, type, format, + PropModeReplace, data, 0); + } + UNBLOCK_INPUT; +} + +/* Handle a SelectionRequest event EVENT. + This is called from keyboard.c when such an event is found in the queue. */ + +void +x_handle_selection_request (event) + struct input_event *event; +{ + struct gcpro gcpro1, gcpro2, gcpro3; + XSelectionEvent reply; + Lisp_Object local_selection_data = Qnil; + Lisp_Object selection_symbol; + Lisp_Object target_symbol = Qnil; + Lisp_Object converted_selection = Qnil; + Time local_selection_time; + Lisp_Object successful_p = Qnil; + int count; + + GCPRO3 (local_selection_data, converted_selection, target_symbol); + + reply.type = SelectionNotify; /* Construct the reply event */ + reply.display = SELECTION_EVENT_DISPLAY (event); + reply.requestor = SELECTION_EVENT_REQUESTOR (event); + reply.selection = SELECTION_EVENT_SELECTION (event); + reply.time = SELECTION_EVENT_TIME (event); + reply.target = SELECTION_EVENT_TARGET (event); + reply.property = SELECTION_EVENT_PROPERTY (event); + if (reply.property == None) + reply.property = reply.target; + + selection_symbol = x_atom_to_symbol (reply.display, + SELECTION_EVENT_SELECTION (event)); + + local_selection_data = assq_no_quit (selection_symbol, Vselection_alist); + +#if 0 +# define CDR(x) (XCONS (x)->cdr) +# define CAR(x) (XCONS (x)->car) + /* This list isn't user-visible, so it can't "go bad." */ + if (!CONSP (local_selection_data)) abort (); + if (!CONSP (CDR (local_selection_data))) abort (); + if (!CONSP (CDR (CDR (local_selection_data)))) abort (); + if (!NILP (CDR (CDR (CDR (local_selection_data))))) abort (); + if (!CONSP (CAR (CDR (CDR (local_selection_data))))) abort (); + if (!FIXNUMP (CAR (CAR (CDR (CDR (local_selection_data)))))) abort (); + if (!FIXNUMP (CDR (CAR (CDR (CDR (local_selection_data)))))) abort (); +# undef CAR +# undef CDR +#endif + + if (NILP (local_selection_data)) + { + /* Someone asked for the selection, but we don't have it any more. + */ + x_decline_selection_request (event); + goto DONE; + } + + local_selection_time = (Time) + cons_to_long (XCONS (XCONS (XCONS (local_selection_data)->cdr)->cdr)->car); + + if (SELECTION_EVENT_TIME (event) != CurrentTime + && local_selection_time > event->time) + { + /* Someone asked for the selection, and we have one, but not the one + they're looking for. + */ + x_decline_selection_request (event); + goto DONE; + } + + count = specpdl_ptr - specpdl; + x_selection_current_request = event; + record_unwind_protect (x_selection_request_lisp_error, Qnil); + + target_symbol = x_atom_to_symbol (reply.display, + SELECTION_EVENT_TARGET (event)); + +#if 0 /* #### MULTIPLE doesn't work yet */ + if (EQ (target_symbol, QMULTIPLE)) + target_symbol = fetch_multiple_target (event); +#endif + + /* Convert lisp objects back into binary data */ + + converted_selection + = x_get_local_selection (selection_symbol, target_symbol); + + if (! NILP (converted_selection)) + { + unsigned char *data; + unsigned int size; + int format; + Atom type; + lisp_data_to_selection_data (reply.display, converted_selection, + &data, &type, &size, &format); + + x_reply_selection_request (event, format, data, size, type); + successful_p = Qt; + + /* Indicate we have successfully processed this event. */ + x_selection_current_event = 0; + + xfree (data); + } + unbind_to (count, Qnil); + + DONE: + + UNGCPRO; + + /* Let random lisp code notice that the selection has been asked for. */ + { + Lisp_Object rest = Vx_sent_selection_hooks; + if (!EQ (rest, Qunbound)) + for (; CONSP (rest); rest = Fcdr (rest)) + call3 (Fcar (rest), selection_symbol, target_symbol, successful_p); + } +} + +/* Handle a SelectionClear event EVENT, which indicates that some other + client cleared out our previously asserted selection. + This is called from keyboard.c when such an event is found in the queue. */ + +void +x_handle_selection_clear (event) + struct input_event *event; +{ + Display *display = SELECTION_EVENT_DISPLAY (event); + Atom selection = SELECTION_EVENT_SELECTION (event); + Time changed_owner_time = SELECTION_EVENT_TIME (event); + + Lisp_Object selection_symbol, local_selection_data; + Time local_selection_time; + + selection_symbol = x_atom_to_symbol (display, selection); + + local_selection_data = assq_no_quit (selection_symbol, Vselection_alist); + + /* Well, we already believe that we don't own it, so that's just fine. */ + if (NILP (local_selection_data)) return; + + local_selection_time = (Time) + cons_to_long (XCONS (XCONS (XCONS (local_selection_data)->cdr)->cdr)->car); + + /* This SelectionClear is for a selection that we no longer own, so we can + disregard it. (That is, we have reasserted the selection since this + request was generated.) */ + + if (changed_owner_time != CurrentTime + && local_selection_time > changed_owner_time) + return; + + /* Otherwise, we're really honest and truly being told to drop it. + Don't use Fdelq as that may QUIT;. */ + + if (EQ (local_selection_data, Fcar (Vselection_alist))) + Vselection_alist = Fcdr (Vselection_alist); + else + { + Lisp_Object rest; + for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest)) + if (EQ (local_selection_data, Fcar (XCONS (rest)->cdr))) + { + XCONS (rest)->cdr = Fcdr (XCONS (rest)->cdr); + break; + } + } + + /* Let random lisp code notice that the selection has been stolen. */ + + { + Lisp_Object rest = Vx_lost_selection_hooks; + if (!EQ (rest, Qunbound)) + for (; CONSP (rest); rest = Fcdr (rest)) + call1 (Fcar (rest), selection_symbol); + } +} + + +/* This stuff is so that INCR selections are reentrant (that is, so we can + be servicing multiple INCR selection requests simultaneously.) I haven't + actually tested that yet. */ + +static int prop_location_tick; + +static Lisp_Object property_change_reply; +static int property_change_reply_tick; + +/* Keep a list of the property changes that are awaited. */ + +struct prop_location +{ + int tick; + Display *display; + Window window; + Atom property; + int desired_state; + struct prop_location *next; +}; + +static struct prop_location *property_change_wait_list; + +static int +property_deleted_p (tick) + void *tick; +{ + struct prop_location *rest = property_change_wait_list; + while (rest) + if (rest->tick == (int) tick) + return 0; + else + rest = rest->next; + return 1; +} + +/* Nonzero if any properties for DISPLAY and WINDOW + are on the list of what we are waiting for. */ + +static int +waiting_for_other_props_on_window (display, window) + Display *display; + Window window; +{ + struct prop_location *rest = property_change_wait_list; + while (rest) + if (rest->display == display && rest->window == window) + return 1; + else + rest = rest->next; + return 0; +} + +/* Add an entry to the list of property changes we are waiting for. + DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for. + The return value is a number that uniquely identifies + this awaited property change. */ + +static int +expect_property_change (display, window, property, state) + Display *display; + Window window; + Lisp_Object property; + int state; +{ + struct prop_location *pl + = (struct prop_location *) xmalloc (sizeof (struct prop_location)); + pl->tick = ++prop_location_tick; + pl->display = display; + pl->window = window; + pl->property = property; + pl->desired_state = state; + pl->next = property_change_wait_list; + property_change_wait_list = pl; + return pl->tick; +} + +/* Delete an entry from the list of property changes we are waiting for. + TICK is the number that uniquely identifies the entry. */ + +static void +unexpect_property_change (tick) + int tick; +{ + struct prop_location *prev = 0, *rest = property_change_wait_list; + while (rest) + { + if (rest->tick == tick) + { + if (prev) + prev->next = rest->next; + else + property_change_wait_list = rest->next; + xfree (rest); + return; + } + prev = rest; + rest = rest->next; + } +} + +/* Actually wait for a property change. + TICK should be the value that expect_property_change returned. */ + +static void +wait_for_property_change (tick) +{ + XCONS (property_change_reply)->car = Qnil; + property_change_reply_tick = tick; + wait_reading_process_input (0, 0, property_change_reply, 0); +} + +/* Called from XTread_socket in response to a PropertyNotify event. */ + +void +x_handle_property_notify (event) + XPropertyEvent *event; +{ + struct prop_location *prev = 0, *rest = property_change_wait_list; + while (rest) + { + if (rest->property == event->atom + && rest->window == event->window + && rest->display == event->display + && rest->desired_state == event->state) + { +#if 0 + fprintf (stderr, "Saw expected prop-%s on %s\n", + (event->state == PropertyDelete ? "delete" : "change"), + (char *) XSYMBOL (x_atom_to_symbol (event->display, + event->atom)) + ->name->data); +#endif + + /* If this is the one wait_for_property_change is waiting for, + tell it to wake up. */ + if (rest->tick == property_change_reply_tick) + XCONS (property_change_reply)->car = Qt; + + if (prev) + prev->next = rest->next; + else + property_change_wait_list = rest->next; + xfree (rest); + return; + } + prev = rest; + rest = rest->next; + } +#if 0 + fprintf (stderr, "Saw UNexpected prop-%s on %s\n", + (event->state == PropertyDelete ? "delete" : "change"), + (char *) XSYMBOL (x_atom_to_symbol (event->display, event->atom)) + ->name->data); +#endif +} + + + +#if 0 /* #### MULTIPLE doesn't work yet */ + +static Lisp_Object +fetch_multiple_target (event) + XSelectionRequestEvent *event; +{ + Display *display = event->display; + Window window = event->requestor; + Atom target = event->target; + Atom selection_atom = event->selection; + int result; + + return + Fcons (QMULTIPLE, + x_get_window_property_as_lisp_data (display, window, target, + QMULTIPLE, selection_atom)); +} + +static Lisp_Object +copy_multiple_data (obj) + Lisp_Object obj; +{ + Lisp_Object vec; + int i; + int size; + if (CONSP (obj)) + return Fcons (XCONS (obj)->car, copy_multiple_data (XCONS (obj)->cdr)); + + CHECK_VECTOR (obj, 0); + vec = Fmake_vector (size = XVECTOR (obj)->size, Qnil); + for (i = 0; i < size; i++) + { + Lisp_Object vec2 = XVECTOR (obj)->contents [i]; + CHECK_VECTOR (vec2, 0); + if (XVECTOR (vec2)->size != 2) + /* ??? Confusing error message */ + Fsignal (Qerror, Fcons (build_string ("vectors must be of length 2"), + Fcons (vec2, Qnil))); + XVECTOR (vec)->contents [i] = Fmake_vector (2, Qnil); + XVECTOR (XVECTOR (vec)->contents [i])->contents [0] + = XVECTOR (vec2)->contents [0]; + XVECTOR (XVECTOR (vec)->contents [i])->contents [1] + = XVECTOR (vec2)->contents [1]; + } + return vec; +} + +#endif + + +/* Variables for communication with x_handle_selection_notify. */ +static Atom reading_which_selection; +static Lisp_Object reading_selection_reply; +static Window reading_selection_window; + +/* Do protocol to read selection-data from the server. + Converts this to Lisp data and returns it. */ + +static Lisp_Object +x_get_foreign_selection (selection_symbol, target_type) + Lisp_Object selection_symbol, target_type; +{ + Display *display = x_current_display; +#ifdef X_TOOLKIT + Window selecting_window = XtWindow (selected_screen->display.x->edit_widget); +#else + Window selecting_window = FRAME_X_WINDOW (selected_frame); +#endif + Time requestor_time = mouse_timestamp; + Atom target_property = Xatom_EMACS_TMP; + Atom selection_atom = symbol_to_x_atom (display, selection_symbol); + Atom type_atom; + + if (CONSP (target_type)) + type_atom = symbol_to_x_atom (display, XCONS (target_type)->car); + else + type_atom = symbol_to_x_atom (display, target_type); + + BLOCK_INPUT; + XConvertSelection (display, selection_atom, type_atom, target_property, + requestor_window, requestor_time); + + /* Prepare to block until the reply has been read. */ + reading_selection_window = requestor_window; + reading_which_selection = selection_atom; + XCONS (reading_selection_reply)->car = Qnil; + UNBLOCK_INPUT; + + /* This allows quits. */ + wait_reading_process_input (x_selection_timeout, 0, + reading_selection_reply, 0); + + if (NILP (XCONS (reading_selection_reply)->car)) + error ("timed out waiting for reply from selection owner"); + + /* Otherwise, the selection is waiting for us on the requested property. */ + return + x_get_window_property_as_lisp_data (display, requestor_window, + target_property, target_type, + selection_atom); +} + +/* Subroutines of x_get_window_property_as_lisp_data */ + +static void +x_get_window_property (display, window, property, data_ret, bytes_ret, + actual_type_ret, actual_format_ret, actual_size_ret, + delete_p) + Display *display; + Window window; + Atom property; + unsigned char **data_ret; + int *bytes_ret; + Atom *actual_type_ret; + int *actual_format_ret; + unsigned long *actual_size_ret; + int delete_p; +{ + int total_size; + unsigned long bytes_remaining; + int offset = 0; + unsigned char *tmp_data = 0; + int result; + int buffer_size = SELECTION_QUANTUM (display); + if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM; + + BLOCK_INPUT; + /* First probe the thing to find out how big it is. */ + result = XGetWindowProperty (display, window, property, + 0, 0, False, AnyPropertyType, + actual_type_ret, actual_format_ret, + actual_size_ret, + &bytes_remaining, &tmp_data); + UNBLOCK_INPUT; + if (result != Success) + { + *data_ret = 0; + *bytes_ret = 0; + return; + } + BLOCK_INPUT; + XFree ((char *) tmp_data); + UNBLOCK_INPUT; + + if (*actual_type_ret == None || *actual_format_ret == 0) + { + if (delete_p) XDeleteProperty (display, window, property); + return; + } + + total_size = bytes_remaining + 1; + *data_ret = (unsigned char *) xmalloc (total_size); + + /* Now read, until weve gotten it all. */ + BLOCK_INPUT; + while (bytes_remaining) + { +#if 0 + int last = bytes_remaining; +#endif + result + = XGetWindowProperty (display, window, property, + offset/4, buffer_size/4, + (delete_p ? True : False), + AnyPropertyType, + actual_type_ret, actual_format_ret, + actual_size_ret, &bytes_remaining, &tmp_data); +#if 0 + fprintf (stderr, "<< read %d\n", last-bytes_remaining); +#endif + /* If this doesn't return Success at this point, it means that + some clod deleted the selection while we were in the midst of + reading it. Deal with that, I guess.... + */ + if (result != Success) break; + *actual_size_ret *= *actual_format_ret / 8; + bcopy (tmp_data, (*data_ret) + offset, *actual_size_ret); + offset += *actual_size_ret; + XFree ((char *) tmp_data); + } + UNBLOCK_INPUT; + *bytes_ret = offset; +} + +static void +receive_incremental_selection (display, window, property, target_type, + min_size_bytes, data_ret, size_bytes_ret, + type_ret, format_ret, size_ret) + Display *display; + Window window; + Atom property; + Lisp_Object target_type; /* for error messages only */ + unsigned int min_size_bytes; + unsigned char **data_ret; + int *size_bytes_ret; + Atom *type_ret; + unsigned long *size_ret; + int *format_ret; +{ + int offset = 0; + int prop_id; + *size_bytes_ret = min_size_bytes; + *data_ret = (unsigned char *) xmalloc (*size_bytes_ret); +#if 0 + fprintf (stderr, "\nread INCR %d\n", min_size_bytes); +#endif + /* At this point, we have read an INCR property, and deleted it (which + is how we ack its receipt: the sending window will be selecting + PropertyNotify events on our window to notice this.) + + Now, we must loop, waiting for the sending window to put a value on + that property, then reading the property, then deleting it to ack. + We are done when the sender places a property of length 0. + */ + prop_id = expect_property_change (display, window, property, + PropertyNewValue); + while (1) + { + unsigned char *tmp_data; + int tmp_size_bytes; + wait_for_property_change (prop_id); + /* expect it again immediately, because x_get_window_property may + .. no it wont, I dont get it. + .. Ok, I get it now, the Xt code that implements INCR is broken. + */ + prop_id = expect_property_change (display, window, property, + PropertyNewValue); + x_get_window_property (display, window, property, + &tmp_data, &tmp_size_bytes, + type_ret, format_ret, size_ret, 1); + + if (tmp_size_bytes == 0) /* we're done */ + { +#if 0 + fprintf (stderr, " read INCR done\n"); +#endif + unexpect_property_change (prop_id); + if (tmp_data) xfree (tmp_data); + break; + } +#if 0 + fprintf (stderr, " read INCR %d\n", tmp_size_bytes); +#endif + if (*size_bytes_ret < offset + tmp_size_bytes) + { +#if 0 + fprintf (stderr, " read INCR realloc %d -> %d\n", + *size_bytes_ret, offset + tmp_size_bytes); +#endif + *size_bytes_ret = offset + tmp_size_bytes; + *data_ret = (unsigned char *) xrealloc (*data_ret, *size_bytes_ret); + } + memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes); + offset += tmp_size_bytes; + xfree (tmp_data); + } +} + +/* Once a requested selection is "ready" (we got a SelectionNotify event), + fetch value from property PROPERTY of X window WINDOW on display DISPLAY. + TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */ + +static Lisp_Object +x_get_window_property_as_lisp_data (display, window, property, target_type, + selection_atom) + Display *display; + Window window; + Atom property; + Lisp_Object target_type; /* for error messages only */ + Atom selection_atom; /* for error messages only */ +{ + Atom actual_type; + int actual_format; + unsigned long actual_size; + unsigned char *data = 0; + int bytes = 0; + Lisp_Object val; + + x_get_window_property (display, window, property, &data, &bytes, + &actual_type, &actual_format, &actual_size, 1); + if (! data) + { + int there_is_a_selection_owner; + BLOCK_INPUT; + there_is_a_selection_owner + = XGetSelectionOwner (display, selection_atom); + UNBLOCK_INPUT; + while (1) /* Note debugger can no longer return, so this is obsolete */ + Fsignal (Qerror, + there_is_a_selection_owner ? + Fcons (build_string ("selection owner couldn't convert"), + actual_type + ? Fcons (target_type, + Fcons (x_atom_to_symbol (display, actual_type), + Qnil)) + : Fcons (target_type, Qnil)) + : Fcons (build_string ("no selection"), + Fcons (x_atom_to_symbol (display, selection_atom), + Qnil))); + } + + if (actual_type == Xatom_INCR) + { + /* That wasn't really the data, just the beginning. */ + + unsigned int min_size_bytes = * ((unsigned int *) data); + BLOCK_INPUT; + XFree ((char *) data); + UNBLOCK_INPUT; + receive_incremental_selection (display, window, property, target_type, + min_size_bytes, &data, &bytes, + &actual_type, &actual_format, + &actual_size); + } + + /* It's been read. Now convert it to a lisp object in some semi-rational + manner. */ + val = selection_data_to_lisp_data (display, data, bytes, + actual_type, actual_format); + + xfree ((char *) data); + return val; +} + +/* These functions convert from the selection data read from the server into + something that we can use from Lisp, and vice versa. + + Type: Format: Size: Lisp Type: + ----- ------- ----- ----------- + * 8 * String + ATOM 32 1 Symbol + ATOM 32 > 1 Vector of Symbols + * 16 1 Integer + * 16 > 1 Vector of Integers + * 32 1 if <=16 bits: Integer + if > 16 bits: Cons of top16, bot16 + * 32 > 1 Vector of the above + + When converting a Lisp number to C, it is assumed to be of format 16 if + it is an integer, and of format 32 if it is a cons of two integers. + + When converting a vector of numbers from Lisp to C, it is assumed to be + of format 16 if every element in the vector is an integer, and is assumed + to be of format 32 if any element is a cons of two integers. + + When converting an object to C, it may be of the form (SYMBOL . <data>) + where SYMBOL is what we should claim that the type is. Format and + representation are as above. */ + + + +static Lisp_Object +selection_data_to_lisp_data (display, data, size, type, format) + Display *display; + unsigned char *data; + Atom type; + int size, format; +{ + + if (type == Xatom_NULL) + return QNULL; + + /* Convert any 8-bit data to a string, for compactness. */ + else if (format == 8) + return make_string ((char *) data, size); + + /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to + a vector of symbols. + */ + else if (type == XA_ATOM) + { + int i; + if (size == sizeof (Atom)) + return x_atom_to_symbol (display, *((Atom *) data)); + else + { + Lisp_Object v = Fmake_vector (size / sizeof (Atom), 0); + for (i = 0; i < size / sizeof (Atom); i++) + Faset (v, i, x_atom_to_symbol (display, ((Atom *) data) [i])); + return v; + } + } + + /* Convert a single 16 or small 32 bit number to a Lisp_Int. + If the number is > 16 bits, convert it to a cons of integers, + 16 bits in each half. + */ + else if (format == 32 && size == sizeof (long)) + return long_to_cons (((unsigned long *) data) [0]); + else if (format == 16 && size == sizeof (short)) + return make_number ((int) (((unsigned short *) data) [0])); + + /* Convert any other kind of data to a vector of numbers, represented + as above (as an integer, or a cons of two 16 bit integers.) + */ + else if (format == 16) + { + int i; + Lisp_Object v = Fmake_vector (size / 4, 0); + for (i = 0; i < size / 4; i++) + { + int j = (int) ((unsigned short *) data) [i]; + Faset (v, i, make_number (j)); + } + return v; + } + else + { + int i; + Lisp_Object v = Fmake_vector (size / 4, 0); + for (i = 0; i < size / 4; i++) + { + unsigned long j = ((unsigned long *) data) [i]; + Faset (v, i, long_to_cons (j)); + } + return v; + } +} + + +static void +lisp_data_to_selection_data (display, obj, + data_ret, type_ret, size_ret, format_ret) + Display *display; + Lisp_Object obj; + unsigned char **data_ret; + Atom *type_ret; + unsigned int *size_ret; + int *format_ret; +{ + Lisp_Object type = Qnil; + if (CONSP (obj) && SYMBOLP (XCONS (obj)->car)) + { + type = XCONS (obj)->car; + obj = XCONS (obj)->cdr; + if (CONSP (obj) && NILP (XCONS (obj)->cdr)) + obj = XCONS (obj)->car; + } + + if (EQ (obj, QNULL) || (EQ (type, QNULL))) + { /* This is not the same as declining */ + *format_ret = 32; + *size_ret = 0; + *data_ret = 0; + type = QNULL; + } + else if (STRINGP (obj)) + { + *format_ret = 8; + *size_ret = XSTRING (obj)->size; + *data_ret = (unsigned char *) xmalloc (*size_ret); + memcpy (*data_ret, (char *) XSTRING (obj)->data, *size_ret); + if (NILP (type)) type = QSTRING; + } + else if (SYMBOLP (obj)) + { + *format_ret = 32; + *size_ret = 1; + *data_ret = (unsigned char *) xmalloc (sizeof (Atom) + 1); + (*data_ret) [sizeof (Atom)] = 0; + (*(Atom **) data_ret) [0] = symbol_to_x_atom (display, obj); + if (NILP (type)) type = QATOM; + } + else if (FIXNUMP (obj) + && XINT (obj) < 0xFFFF + && XINT (obj) > -0xFFFF) + { + *format_ret = 16; + *size_ret = 1; + *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1); + (*data_ret) [sizeof (short)] = 0; + (*(short **) data_ret) [0] = (short) XINT (obj); + if (NILP (type)) type = QINTEGER; + } + else if (FIXNUMP (obj) || CONSP (obj)) + { + *format_ret = 32; + *size_ret = 1; + *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1); + (*data_ret) [sizeof (long)] = 0; + (*(unsigned long **) data_ret) [0] = cons_to_long (obj); + if (NILP (type)) type = QINTEGER; + } + else if (VECTORP (obj)) + { + /* Lisp_Vectors may represent a set of ATOMs; + a set of 16 or 32 bit INTEGERs; + or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...] + */ + int i; + + if (SYMBOLP (XVECTOR (obj)->contents [0])) + /* This vector is an ATOM set */ + { + if (NILP (type)) type = QATOM; + *size_ret = XVECTOR (obj)->size; + *format_ret = 32; + *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (Atom)); + for (i = 0; i < *size_ret; i++) + if (SYMBOLP (XVECTOR (obj)->contents [i])) + (*(Atom **) data_ret) [i] + = symbol_to_x_atom (display, XVECTOR (obj)->contents [i]); + else + Fsignal (Qerror, /* Qselection_error */ + Fcons (build_string + ("all elements of selection vector must have same type"), + Fcons (obj, Qnil))); + } +#if 0 /* #### MULTIPLE doesn't work yet */ + else if (VECTORP (XVECTOR (obj)->contents [0])) + /* This vector is an ATOM_PAIR set */ + { + if (NILP (type)) type = QATOM_PAIR; + *size_ret = XVECTOR (obj)->size; + *format_ret = 32; + *data_ret = (unsigned char *) + xmalloc ((*size_ret) * sizeof (Atom) * 2); + for (i = 0; i < *size_ret; i++) + if (VECTORP (XVECTOR (obj)->contents [i])) + { + Lisp_Object pair = XVECTOR (obj)->contents [i]; + if (XVECTOR (pair)->size != 2) + Fsignal (Qerror, + Fcons (build_string + ("elements of the vector must be vectors of exactly two elements"), + Fcons (pair, Qnil))); + + (*(Atom **) data_ret) [i * 2] + = symbol_to_x_atom (display, XVECTOR (pair)->contents [0]); + (*(Atom **) data_ret) [(i * 2) + 1] + = symbol_to_x_atom (display, XVECTOR (pair)->contents [1]); + } + else + Fsignal (Qerror, + Fcons (build_string + ("all elements of the vector must be of the same type"), + Fcons (obj, Qnil))); + + } +#endif + else + /* This vector is an INTEGER set, or something like it */ + { + *size_ret = XVECTOR (obj)->size; + if (NILP (type)) type = QINTEGER; + *format_ret = 16; + for (i = 0; i < *size_ret; i++) + if (CONSP (XVECTOR (obj)->contents [i])) + *format_ret = 32; + else if (!FIXNUMP (XVECTOR (obj)->contents [i])) + Fsignal (Qerror, /* Qselection_error */ + Fcons (build_string + ("elements of selection vector must be integers or conses of integers"), + Fcons (obj, Qnil))); + + *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8)); + for (i = 0; i < *size_ret; i++) + if (*format_ret == 32) + (*((unsigned long **) data_ret)) [i] + = cons_to_long (XVECTOR (obj)->contents [i]); + else + (*((unsigned short **) data_ret)) [i] + = (unsigned short) cons_to_long (XVECTOR (obj)->contents [i]); + } + } + else + Fsignal (Qerror, /* Qselection_error */ + Fcons (build_string ("unrecognised selection data"), + Fcons (obj, Qnil))); + + *type_ret = symbol_to_x_atom (display, type); +} + +static Lisp_Object +clean_local_selection_data (obj) + Lisp_Object obj; +{ + if (CONSP (obj) + && FIXNUMP (XCONS (obj)->car) + && CONSP (XCONS (obj)->cdr) + && FIXNUMP (XCONS (XCONS (obj)->cdr)->car) + && NILP (XCONS (XCONS (obj)->cdr)->cdr)) + obj = Fcons (XCONS (obj)->car, XCONS (obj)->cdr); + + if (CONSP (obj) + && FIXNUMP (XCONS (obj)->car) + && FIXNUMP (XCONS (obj)->cdr)) + { + if (XINT (XCONS (obj)->car) == 0) + return XCONS (obj)->cdr; + if (XINT (XCONS (obj)->car) == -1) + return make_number (- XINT (XCONS (obj)->cdr)); + } + if (VECTORP (obj)) + { + int i; + int size = XVECTOR (obj)->size; + Lisp_Object copy; + if (size == 1) + return clean_local_selection_data (XVECTOR (obj)->contents [0]); + copy = Fmake_vector (size, Qnil); + for (i = 0; i < size; i++) + XVECTOR (copy)->contents [i] + = clean_local_selection_data (XVECTOR (obj)->contents [i]); + return copy; + } + return obj; +} + +/* Called from XTread_socket to handle SelectionNotify events. + If it's the selection we are waiting for, stop waiting. */ + +void +x_handle_selection_notify (event) + XSelectionEvent *event; +{ + if (event->requestor != reading_selection_window) + return; + if (event->selection != reading_which_selection) + return; + + XCONS (reading_selection_reply)->car = Qt; +} + + +DEFUN ("x-own-selection-internal", + Fx_own_selection_internal, Sx_own_selection_internal, + 2, 2, 0, + "Assert an X selection of the given TYPE with the given VALUE.\n\ +TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\ +\(Those are literal upper-case symbol names, since that's what X expects.)\n\ +VALUE is typically a string, or a cons of two markers, but may be\n\ +anything that the functions on selection-converter-alist know about.") + (selection_name, selection_value) + Lisp_Object selection_name, selection_value; +{ + CHECK_SYMBOL (selection_name, 0); + if (NILP (selection_value)) error ("selection-value may not be nil."); + x_own_selection (selection_name, selection_value); + return selection_value; +} + + +/* Request the selection value from the owner. If we are the owner, + simply return our selection value. If we are not the owner, this + will block until all of the data has arrived. */ + +DEFUN ("x-get-selection-internal", + Fx_get_selection_internal, Sx_get_selection_internal, 2, 2, 0, + "Return text selected from some X window.\n\ +SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\ +\(Those are literal upper-case symbol names, since that's what X expects.)\n\ +TYPE is the type of data desired, typically STRING.") + (selection_symbol, target_type) + Lisp_Object selection_symbol, target_type; +{ + Lisp_Object val = Qnil; + struct gcpro gcpro1, gcpro2; + GCPRO2 (target_type, val); /* we store newly consed data into these */ + CHECK_SYMBOL (selection_symbol, 0); + +#if 0 /* #### MULTIPLE doesn't work yet */ + if (CONSP (target_type) + && XCONS (target_type)->car == QMULTIPLE) + { + CHECK_VECTOR (XCONS (target_type)->cdr, 0); + /* So we don't destructively modify this... */ + target_type = copy_multiple_data (target_type); + } + else +#endif + CHECK_SYMBOL (target_type, 0); + + val = x_get_local_selection (selection_symbol, target_type); + + if (NILP (val)) + { + val = x_get_foreign_selection (selection_symbol, target_type); + goto DONE; + } + + if (CONSP (val) + && SYMBOLP (XCONS (val)->car)) + { + val = XCONS (val)->cdr; + if (CONSP (val) && NILP (XCONS (val)->cdr)) + val = XCONS (val)->car; + } + val = clean_local_selection_data (val); + DONE: + UNGCPRO; + return val; +} + +DEFUN ("x-disown-selection-internal", + Fx_disown_selection_internal, Sx_disown_selection_internal, 1, 2, 0, + "If we own the named selection, then disown it (make there be no selection).") + (selection, time) + Lisp_Object selection; + Lisp_Object time; +{ + Display *display = x_current_display; + Time timestamp; + Atom selection_atom; + XSelectionClearEvent event; + + CHECK_SYMBOL (selection, 0); + if (NILP (time)) + timestamp = mouse_timestamp; + else + timestamp = cons_to_long (time); + + if (NILP (assq_no_quit (selection, Vselection_alist))) + return Qnil; /* Don't disown the selection when we're not the owner. */ + + selection_atom = symbol_to_x_atom (display, selection); + + BLOCK_INPUT; + XSetSelectionOwner (display, selection_atom, None, timestamp); + UNBLOCK_INPUT; + + /* It doesn't seem to be guarenteed that a SelectionClear event will be + generated for a window which owns the selection when that window sets + the selection owner to None. The NCD server does, the MIT Sun4 server + doesn't. So we synthesize one; this means we might get two, but + that's ok, because the second one won't have any effect. */ + event.display = display; + event.selection = selection_atom; + event.time = timestamp; + x_handle_selection_clear (&event); + + return Qt; +} + + +DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p, + 0, 1, 0, + "Whether the current emacs process owns the given X Selection.\n\ +The arg should be the name of the selection in question, typically one of\n\ +the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\ +\(Those are literal upper-case symbol names, since that's what X expects.)\n\ +For convenience, the symbol nil is the same as `PRIMARY',\n\ +and t is the same as `SECONDARY'.)") + (selection) + Lisp_Object selection; +{ + CHECK_SYMBOL (selection, 0); + if (EQ (selection, Qnil)) selection = QPRIMARY; + if (EQ (selection, Qt)) selection = QSECONDARY; + + if (NILP (Fassq (selection, Vselection_alist))) + return Qnil; + return Qt; +} + +DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p, + 0, 1, 0, + "Whether there is an owner for the given X Selection.\n\ +The arg should be the name of the selection in question, typically one of\n\ +the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\ +\(Those are literal upper-case symbol names, since that's what X expects.)\n\ +For convenience, the symbol nil is the same as `PRIMARY',\n\ +and t is the same as `SECONDARY'.)") + (selection) + Lisp_Object selection; +{ + Window owner; + Display *dpy = x_current_display; + CHECK_SYMBOL (selection, 0); + if (!NILP (Fx_selection_owner_p (selection))) + return Qt; + BLOCK_INPUT; + owner = XGetSelectionOwner (dpy, symbol_to_x_atom (dpy, selection)); + UNBLOCK_INPUT; + return (owner ? Qt : Qnil); +} + + +#ifdef CUT_BUFFER_SUPPORT + +static int cut_buffers_initialized; /* Whether we're sure they all exist */ + +/* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */ +static void +initialize_cut_buffers (display, window) + Display *display; + Window window; +{ + unsigned char *data = (unsigned char *) ""; + BLOCK_INPUT; +#define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \ + PropModeAppend, data, 0) + FROB (XA_CUT_BUFFER0); + FROB (XA_CUT_BUFFER1); + FROB (XA_CUT_BUFFER2); + FROB (XA_CUT_BUFFER3); + FROB (XA_CUT_BUFFER4); + FROB (XA_CUT_BUFFER5); + FROB (XA_CUT_BUFFER6); + FROB (XA_CUT_BUFFER7); +#undef FROB + UNBLOCK_INPUT; + cut_buffers_initialized = 1; +} + + +#define CHECK_CUTBUFFER(symbol,n) \ + { CHECK_SYMBOL ((symbol), (n)); \ + if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \ + && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \ + && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \ + && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \ + Fsignal (Qerror, \ + Fcons (build_string ("doesn't name a cutbuffer"), \ + Fcons ((symbol), Qnil))); \ + } + +DEFUN ("x-get-cutbuffer-internal", Fx_get_cutbuffer_internal, + Sx_get_cutbuffer_internal, 1, 1, 0, + "Returns the value of the named cutbuffer (typically CUT_BUFFER0).") + (buffer) + Lisp_Object buffer; +{ + Display *display = x_current_display; + Window window = RootWindow (display, 0); /* Cutbuffers are on screen 0 */ + Atom buffer_atom; + unsigned char *data; + int bytes; + Atom type; + int format; + unsigned long size; + Lisp_Object ret; + + CHECK_CUTBUFFER (buffer, 0); + buffer_atom = symbol_to_x_atom (display, buffer); + + x_get_window_property (display, window, buffer_atom, &data, &bytes, + &type, &format, &size, 0); + if (!data) return Qnil; + + if (format != 8 || type != XA_STRING) + Fsignal (Qerror, + Fcons (build_string ("cut buffer doesn't contain 8-bit data"), + Fcons (x_atom_to_symbol (display, type), + Fcons (make_number (format), Qnil)))); + + ret = (bytes ? make_string ((char *) data, bytes) : Qnil); + xfree (data); + return ret; +} + + +DEFUN ("x-store-cutbuffer-internal", Fx_store_cutbuffer_internal, + Sx_store_cutbuffer_internal, 2, 2, 0, + "Sets the value of the named cutbuffer (typically CUT_BUFFER0).") + (buffer, string) + Lisp_Object buffer, string; +{ + Display *display = x_current_display; + Window window = RootWindow (display, 0); /* Cutbuffers are on screen 0 */ + Atom buffer_atom; + unsigned char *data; + int bytes; + int bytes_remaining; + int max_bytes = SELECTION_QUANTUM (display); + if (max_bytes > MAX_SELECTION_QUANTUM) max_bytes = MAX_SELECTION_QUANTUM; + + CHECK_CUTBUFFER (buffer, 0); + CHECK_STRING (string, 0); + buffer_atom = symbol_to_x_atom (display, buffer); + data = (unsigned char *) XSTRING (string)->data; + bytes = XSTRING (string)->size; + bytes_remaining = bytes; + + if (! cut_buffers_initialized) initialize_cut_buffers (display, window); + + BLOCK_INPUT; + while (bytes_remaining) + { + int chunk = (bytes_remaining < max_bytes + ? bytes_remaining : max_bytes); + XChangeProperty (display, window, buffer_atom, XA_STRING, 8, + (bytes_remaining == bytes + ? PropModeReplace + : PropModeAppend), + data, chunk); + data += chunk; + bytes_remaining -= chunk; + } + UNBLOCK_INPUT; + return string; +} + + +DEFUN ("x-rotate-cutbuffers-internal", Fx_rotate_cutbuffers_internal, + Sx_rotate_cutbuffers_internal, 1, 1, 0, + "Rotate the values of the cutbuffers by the given number of steps;\n\ +positive means move values forward, negative means backward.") + (n) + Lisp_Object n; +{ + Display *display = x_current_display; + Window window = RootWindow (display, 0); /* Cutbuffers are on screen 0 */ + Atom props [8]; + + CHECK_FIXNUM (n, 0); + if (XINT (n) == 0) return n; + if (! cut_buffers_initialized) initialize_cut_buffers (display, window); + props[0] = XA_CUT_BUFFER0; + props[1] = XA_CUT_BUFFER1; + props[2] = XA_CUT_BUFFER2; + props[3] = XA_CUT_BUFFER3; + props[4] = XA_CUT_BUFFER4; + props[5] = XA_CUT_BUFFER5; + props[6] = XA_CUT_BUFFER6; + props[7] = XA_CUT_BUFFER7; + BLOCK_INPUT; + XRotateWindowProperties (display, window, props, 8, XINT (n)); + UNBLOCK_INPUT; + return n; +} + +#endif + +static void +atoms_of_xselect () +{ +#define ATOM(x) XInternAtom (x_current_display, (x), False) + + BLOCK_INPUT; + /* Non-predefined atoms that we might end up using a lot */ + Xatom_CLIPBOARD = ATOM ("CLIPBOARD"); + Xatom_TIMESTAMP = ATOM ("TIMESTAMP"); + Xatom_TEXT = ATOM ("TEXT"); + Xatom_DELETE = ATOM ("DELETE"); + Xatom_MULTIPLE = ATOM ("MULTIPLE"); + Xatom_INCR = ATOM ("INCR"); + Xatom_EMACS_TMP = ATOM ("_EMACS_TMP_"); + Xatom_TARGETS = ATOM ("TARGETS"); + Xatom_NULL = ATOM ("NULL"); + Xatom_ATOM_PAIR = ATOM ("ATOM_PAIR"); + UNBLOCK_INPUT; +} + +void +syms_of_xselect () +{ + atoms_of_select (); + + defsubr (&Sx_get_selection_internal); + defsubr (&Sx_own_selection_internal); + defsubr (&Sx_disown_selection_internal); + defsubr (&Sx_selection_owner_p); + defsubr (&Sx_selection_exists_p); + +#ifdef CUT_BUFFER_SUPPORT + defsubr (&Sx_get_cutbuffer_internal); + defsubr (&Sx_store_cutbuffer_internal); + defsubr (&Sx_rotate_cutbuffers_internal); + cut_buffers_initialized = 0; +#endif + + reading_selection_reply = Fcons (Qnil, Qnil); + staticpro (&reading_selection_reply); + reading_selection_window = 0; + reading_which_selection = 0; + + property_change_wait_list = 0; + prop_location_tick = 0; + property_change_reply = Fcons (Qnil, Qnil); + staticpro (&property_change_reply); + + Vselection_alist = Qnil; + staticpro (&Vselection_alist); + + DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist, + "An alist associating X Windows selection-types with functions.\n\ +These functions are called to convert the selection, with three args:\n\ +the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\ +a desired type to which the selection should be converted;\n\ +and the local selection value (whatever was given to `x-own-selection').\n\ +\n\ +The function should return the value to send to the X server\n\ +\(typically a string). A return value of nil\n\ +means that the conversion could not be done.\n\ +A return value which is the symbol `NULL'\n\ +means that a side-effect was executed,\n\ +and there is no meaningful selection value."); + Vselection_converter_alist = Qnil; + + DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks, + "A list of functions to be called when Emacs loses an X selection.\n\ +\(This happens when some other X client makes its own selection\n\ +or when a Lisp program explicitly clears the selection.)\n\ +The functions are called with one argument, the selection type\n\ +\(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)"); + Vx_lost_selection_hooks = Qnil; + + DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks, + "A list of functions to be called when Emacs answers a selection request.\n\ +The functions are called with four arguments:\n\ + - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\ + - the selection-type which Emacs was asked to convert the\n\ + selection into before sending (for example, `STRING' or `LENGTH');\n\ + - a flag indicating success or failure for responding to the request.\n\ +We might have failed (and declined the request) for any number of reasons,\n\ +including being asked for a selection that we no longer own, or being asked\n\ +to convert into a type that we don't know about or that is inappropriate.\n\ +This hook doesn't let you change the behavior of Emacs's selection replies,\n\ +it merely informs you that they have happened."); + Vx_sent_selection_hooks = Qnil; + + DEFVAR_INT ("x-selection-timeout", &x_selection_timeout, + "Number of seconds to wait for a selection reply from another X client.\n\ +If the selection owner doens't reply in this many seconds, we give up.\n\ +A value of 0 means wait as long as necessary. This is initialized from the\n\ +\"*selectionTimeout\" resource (which is expressed in milliseconds)."); + x_selection_timeout = 0; + + QPRIMARY = intern ("PRIMARY"); staticpro (&QPRIMARY); + QSECONDARY = intern ("SECONDARY"); staticpro (&QSECONDARY); + QSTRING = intern ("STRING"); staticpro (&QSTRING); + QINTEGER = intern ("INTEGER"); staticpro (&QINTEGER); + QCLIPBOARD = intern ("CLIPBOARD"); staticpro (&QCLIPBOARD); + QTIMESTAMP = intern ("TIMESTAMP"); staticpro (&QTIMESTAMP); + QTEXT = intern ("TEXT"); staticpro (&QTEXT); + QTIMESTAMP = intern ("TIMESTAMP"); staticpro (&QTIMESTAMP); + QDELETE = intern ("DELETE"); staticpro (&QDELETE); + QMULTIPLE = intern ("MULTIPLE"); staticpro (&QMULTIPLE); + QINCR = intern ("INCR"); staticpro (&QINCR); + QEMACS_TMP = intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP); + QTARGETS = intern ("TARGETS"); staticpro (&QTARGETS); + QATOM = intern ("ATOM"); staticpro (&QATOM); + QATOM_PAIR = intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR); + QNULL = intern ("NULL"); staticpro (&QNULL); + +#ifdef CUT_BUFFER_SUPPORT + QCUT_BUFFER0 = intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0); + QCUT_BUFFER1 = intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1); + QCUT_BUFFER2 = intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2); + QCUT_BUFFER3 = intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3); + QCUT_BUFFER4 = intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4); + QCUT_BUFFER5 = intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5); + QCUT_BUFFER6 = intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6); + QCUT_BUFFER7 = intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7); +#endif + +}