Merge from trunk.
[emacs.git] / src / w32select.c
blobe3225c3f996d349a08ded5c90a0d0468b6011ec8
1 /* Selection processing for Emacs on the Microsoft W32 API.
3 Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
20 /* Written by Kevin Gallo, Benjamin Riefenstahl */
24 * Notes on usage of selection-coding-system and
25 * next-selection-coding-system on MS Windows:
27 * The selection coding system variables apply only to the version of
28 * the clipboard data that is closest in type, i.e. when a 16-bit
29 * Unicode coding system is given, they apply to he Unicode clipboard
30 * (CF_UNICODETEXT), when a well-known console codepage is given, they
31 * apply to the console version of the clipboard data (CF_OEMTEXT),
32 * else they apply to the normal 8-bit text clipboard (CF_TEXT).
34 * When pasting (getting data from the OS), the clipboard format that
35 * matches the {next-}selection-coding-system is retrieved. If
36 * Unicode is requested, but not available, 8-bit text (CF_TEXT) is
37 * used. In all other cases the OS will transparently convert
38 * formats, so no other fallback is needed.
40 * When copying or cutting (sending data to the OS), the data is
41 * announced and stored internally, but only actually rendered on
42 * request. The requester determines the format provided. The
43 * {next-}selection-coding-system is only used, when its corresponding
44 * clipboard type matches the type requested.
46 * Scenarios to use the facilities for customizing the selection
47 * coding system are:
49 * ;; Generally use KOI8-R instead of the russian MS codepage for
50 * ;; the 8-bit clipboard.
51 * (set-selection-coding-system 'koi8-r-dos)
53 * Or
55 * ;; Create a special clipboard copy function that uses codepage
56 * ;; 1253 (Greek) to copy Greek text to a specific non-Unicode
57 * ;; application.
58 * (defun greek-copy (beg end)
59 * (interactive "r")
60 * (set-next-selection-coding-system 'cp1253-dos)
61 * (copy-region-as-kill beg end))
62 * (global-set-key "\C-c\C-c" 'greek-copy)
66 * Ideas for further directions:
68 * The encoding and decoding routines could be moved to Lisp code
69 * similar to how xselect.c does it (using well-known routine names
70 * for the delayed rendering). If the definition of which clipboard
71 * types should be supported is also moved to Lisp, functionality
72 * could be expanded to CF_HTML, CF_RTF and maybe other types.
75 #include <config.h>
76 #include <setjmp.h>
77 #include "lisp.h"
78 #include "w32term.h" /* for all of the w32 includes */
79 #include "w32heap.h" /* os_subtype */
80 #include "blockinput.h"
81 #include "charset.h"
82 #include "coding.h"
83 #include "composite.h"
86 static HGLOBAL convert_to_handle_as_ascii (void);
87 static HGLOBAL convert_to_handle_as_coded (Lisp_Object coding_system);
88 static Lisp_Object render (Lisp_Object oformat);
89 static Lisp_Object render_locale (void);
90 static Lisp_Object render_all (Lisp_Object ignore);
91 static void run_protected (Lisp_Object (*code) (Lisp_Object), Lisp_Object arg);
92 static Lisp_Object lisp_error_handler (Lisp_Object error);
93 static LRESULT CALLBACK owner_callback (HWND win, UINT msg,
94 WPARAM wp, LPARAM lp);
95 static HWND create_owner (void);
97 static void setup_config (void);
98 static BOOL WINAPI enum_locale_callback (/*const*/ char* loc_string);
99 static UINT cp_from_locale (LCID lcid, UINT format);
100 static Lisp_Object coding_from_cp (UINT codepage);
101 static Lisp_Object validate_coding_system (Lisp_Object coding_system);
102 static void setup_windows_coding_system (Lisp_Object coding_system,
103 struct coding_system * coding);
106 /* A remnant from X11: Symbol for the CLIPBORD selection type. Other
107 selections are not used on Windows, so we don't need symbols for
108 PRIMARY and SECONDARY. */
109 Lisp_Object QCLIPBOARD;
111 /* Internal pseudo-constants, initialized in globals_of_w32select()
112 based on current system parameters. */
113 static LCID DEFAULT_LCID;
114 static UINT ANSICP, OEMCP;
115 static Lisp_Object QUNICODE, QANSICP, QOEMCP;
117 /* A hidden window just for the clipboard management. */
118 static HWND clipboard_owner;
119 /* A flag to tell WM_DESTROYCLIPBOARD who is to blame this time (just
120 checking GetClipboardOwner() doesn't work, sadly). */
121 static int modifying_clipboard = 0;
123 /* Configured transfer parameters, based on the last inspection of
124 selection-coding-system. */
125 static Lisp_Object cfg_coding_system;
126 static UINT cfg_codepage;
127 static LCID cfg_lcid;
128 static UINT cfg_clipboard_type;
130 /* The current state for delayed rendering. */
131 static Lisp_Object current_text;
132 static Lisp_Object current_coding_system;
133 static int current_requires_encoding, current_num_nls;
134 static UINT current_clipboard_type;
135 static LCID current_lcid;
137 #if TRACE
138 #define ONTRACE(stmt) stmt
139 #else
140 #define ONTRACE(stmt) /*stmt*/
141 #endif
144 /* This function assumes that there is no multibyte character in
145 current_text, so we can short-cut encoding. */
147 static HGLOBAL
148 convert_to_handle_as_ascii (void)
150 HGLOBAL htext = NULL;
151 int nbytes;
152 int truelen;
153 unsigned char *src;
154 unsigned char *dst;
156 ONTRACE (fprintf (stderr, "convert_to_handle_as_ascii\n"));
158 nbytes = SBYTES (current_text) + 1;
159 src = SDATA (current_text);
161 /* We need to add to the size the number of LF chars where we have
162 to insert CR chars (the standard CF_TEXT clipboard format uses
163 CRLF line endings, while Emacs uses just LF internally). */
165 truelen = nbytes + current_num_nls;
167 if ((htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, truelen)) == NULL)
168 return NULL;
170 if ((dst = (unsigned char *) GlobalLock (htext)) == NULL)
172 GlobalFree (htext);
173 return NULL;
176 /* convert to CRLF line endings expected by clipboard */
177 while (1)
179 unsigned char *next;
180 /* copy next line or remaining bytes including '\0' */
181 next = _memccpy (dst, src, '\n', nbytes);
182 if (next)
184 /* copied one line ending with '\n' */
185 int copied = next - dst;
186 nbytes -= copied;
187 src += copied;
188 /* insert '\r' before '\n' */
189 next[-1] = '\r';
190 next[0] = '\n';
191 dst = next + 1;
193 else
194 /* copied remaining partial line -> now finished */
195 break;
198 GlobalUnlock (htext);
200 return htext;
203 /* This function assumes that there are multibyte or NUL characters in
204 current_text, or that we need to construct Unicode. It runs the
205 text through the encoding machinery. */
207 static HGLOBAL
208 convert_to_handle_as_coded (Lisp_Object coding_system)
210 HGLOBAL htext;
211 unsigned char *dst = NULL;
212 struct coding_system coding;
214 ONTRACE (fprintf (stderr, "convert_to_handle_as_coded: %s\n",
215 SDATA (SYMBOL_NAME (coding_system))));
217 setup_windows_coding_system (coding_system, &coding);
218 coding.dst_bytes = SBYTES (current_text) * 2;
219 coding.destination = (unsigned char *) xmalloc (coding.dst_bytes);
220 encode_coding_object (&coding, current_text, 0, 0,
221 SCHARS (current_text), SBYTES (current_text), Qnil);
223 htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, coding.produced +2);
225 if (htext != NULL)
226 dst = (unsigned char *) GlobalLock (htext);
228 if (dst != NULL)
230 memcpy (dst, coding.destination, coding.produced);
231 /* Add the string terminator. Add two NULs in case we are
232 producing Unicode here. */
233 dst[coding.produced] = dst[coding.produced+1] = '\0';
235 GlobalUnlock (htext);
238 xfree (coding.destination);
240 return htext;
243 static Lisp_Object
244 render (Lisp_Object oformat)
246 HGLOBAL htext = NULL;
247 UINT format = XFASTINT (oformat);
249 ONTRACE (fprintf (stderr, "render\n"));
251 if (NILP (current_text))
252 return Qnil;
254 if (current_requires_encoding || format == CF_UNICODETEXT)
256 if (format == current_clipboard_type)
257 htext = convert_to_handle_as_coded (current_coding_system);
258 else
259 switch (format)
261 case CF_UNICODETEXT:
262 htext = convert_to_handle_as_coded (QUNICODE);
263 break;
264 case CF_TEXT:
265 case CF_OEMTEXT:
267 Lisp_Object cs;
268 cs = coding_from_cp (cp_from_locale (current_lcid, format));
269 htext = convert_to_handle_as_coded (cs);
270 break;
274 else
275 htext = convert_to_handle_as_ascii ();
277 ONTRACE (fprintf (stderr, "render: htext = 0x%08X\n", (unsigned) htext));
279 if (htext == NULL)
280 return Qnil;
282 if (SetClipboardData (format, htext) == NULL)
284 GlobalFree (htext);
285 return Qnil;
288 return Qt;
291 static Lisp_Object
292 render_locale (void)
294 HANDLE hlocale = NULL;
295 LCID * lcid_ptr;
297 ONTRACE (fprintf (stderr, "render_locale\n"));
299 if (current_lcid == LOCALE_NEUTRAL || current_lcid == DEFAULT_LCID)
300 return Qt;
302 hlocale = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, sizeof (current_lcid));
303 if (hlocale == NULL)
304 return Qnil;
306 if ((lcid_ptr = (LCID *) GlobalLock (hlocale)) == NULL)
308 GlobalFree (hlocale);
309 return Qnil;
312 *lcid_ptr = current_lcid;
313 GlobalUnlock (hlocale);
315 if (SetClipboardData (CF_LOCALE, hlocale) == NULL)
317 GlobalFree (hlocale);
318 return Qnil;
321 return Qt;
324 /* At the end of the program, we want to ensure that our clipboard
325 data survives us. This code will do that. */
327 static Lisp_Object
328 render_all (Lisp_Object ignore)
330 ONTRACE (fprintf (stderr, "render_all\n"));
332 /* According to the docs we should not call OpenClipboard() here,
333 but testing on W2K and working code in other projects shows that
334 it is actually necessary. */
336 OpenClipboard (NULL);
338 /* There is no usefull means to report errors here, there are none
339 expected anyway, and even if there were errors, they wouldn't do
340 any harm. So we just go ahead and do what has to be done without
341 bothering with error handling. */
343 ++modifying_clipboard;
344 EmptyClipboard ();
345 --modifying_clipboard;
347 /* For text formats that we don't render here, the OS can use its
348 own translation rules instead, so we don't really need to offer
349 everything. To minimize memory consumption we cover three
350 possible situations based on our primary format as detected from
351 selection-coding-system (see setup_config()):
353 - Post CF_TEXT only. Let the OS convert to CF_OEMTEXT and the OS
354 (on NT) or the application (on 9x/Me) convert to
355 CF_UNICODETEXT.
357 - Post CF_OEMTEXT only. Similar automatic conversions happen as
358 for CF_TEXT.
360 - Post CF_UNICODETEXT + CF_TEXT. 9x itself ignores
361 CF_UNICODETEXT, even though some applications can still handle
364 Note 1: We render the less capable CF_TEXT *before* the more
365 capable CF_UNICODETEXT, to prevent clobbering through automatic
366 conversions, just in case.
368 Note 2: We could check os_subtype here and only render the
369 additional CF_TEXT on 9x/Me. But OTOH with
370 current_clipboard_type == CF_UNICODETEXT we don't involve the
371 automatic conversions anywhere else, so to get consistent
372 results, we probably don't want to rely on it here either. */
374 render_locale ();
376 if (current_clipboard_type == CF_UNICODETEXT)
377 render (make_number (CF_TEXT));
378 render (make_number (current_clipboard_type));
380 CloseClipboard ();
382 return Qnil;
385 static void
386 run_protected (Lisp_Object (*code) (Lisp_Object), Lisp_Object arg)
388 /* FIXME: This works but it doesn't feel right. Too much fiddling
389 with global variables and calling strange looking functions. Is
390 this really the right way to run Lisp callbacks? */
392 extern int waiting_for_input; /* from keyboard.c */
393 int owfi;
395 BLOCK_INPUT;
397 /* Fsignal calls abort() if it sees that waiting_for_input is
398 set. */
399 owfi = waiting_for_input;
400 waiting_for_input = 0;
402 internal_condition_case_1 (code, arg, Qt, lisp_error_handler);
404 waiting_for_input = owfi;
406 UNBLOCK_INPUT;
409 static Lisp_Object
410 lisp_error_handler (Lisp_Object error)
412 Vsignaling_function = Qnil;
413 cmd_error_internal (error, "Error in delayed clipboard rendering: ");
414 Vinhibit_quit = Qt;
415 return Qt;
419 static LRESULT CALLBACK
420 owner_callback (HWND win, UINT msg, WPARAM wp, LPARAM lp)
422 switch (msg)
424 case WM_RENDERFORMAT:
425 ONTRACE (fprintf (stderr, "WM_RENDERFORMAT\n"));
426 run_protected (render, make_number (wp));
427 return 0;
429 case WM_RENDERALLFORMATS:
430 ONTRACE (fprintf (stderr, "WM_RENDERALLFORMATS\n"));
431 run_protected (render_all, Qnil);
432 return 0;
434 case WM_DESTROYCLIPBOARD:
435 if (!modifying_clipboard)
437 ONTRACE (fprintf (stderr, "WM_DESTROYCLIPBOARD (other)\n"));
438 current_text = Qnil;
439 current_coding_system = Qnil;
441 else
443 ONTRACE (fprintf (stderr, "WM_DESTROYCLIPBOARD (self)\n"));
445 return 0;
447 case WM_DESTROY:
448 if (win == clipboard_owner)
449 clipboard_owner = NULL;
450 break;
453 return DefWindowProc (win, msg, wp, lp);
456 static HWND
457 create_owner (void)
459 static const char CLASSNAME[] = "Emacs Clipboard";
460 WNDCLASS wc;
462 memset (&wc, 0, sizeof (wc));
463 wc.lpszClassName = CLASSNAME;
464 wc.lpfnWndProc = owner_callback;
465 RegisterClass (&wc);
467 return CreateWindow (CLASSNAME, CLASSNAME, 0, 0, 0, 0, 0, NULL, NULL,
468 NULL, NULL);
471 /* Called on exit by term_ntproc() in w32.c */
473 void
474 term_w32select (void)
476 /* This is needed to trigger WM_RENDERALLFORMATS. */
477 if (clipboard_owner != NULL)
478 DestroyWindow (clipboard_owner);
481 static void
482 setup_config (void)
484 const char *coding_name;
485 const char *cp;
486 char *end;
487 int slen;
488 Lisp_Object coding_system;
489 Lisp_Object dos_coding_system;
491 CHECK_SYMBOL (Vselection_coding_system);
493 coding_system = NILP (Vnext_selection_coding_system) ?
494 Vselection_coding_system : Vnext_selection_coding_system;
496 dos_coding_system = validate_coding_system (coding_system);
497 if (NILP (dos_coding_system))
498 Fsignal (Qerror,
499 list2 (build_string ("Coding system is invalid or doesn't have "
500 "an eol variant for dos line ends"),
501 coding_system));
503 /* Check if we have it cached */
504 if (!NILP (cfg_coding_system)
505 && EQ (cfg_coding_system, dos_coding_system))
506 return;
507 cfg_coding_system = dos_coding_system;
509 /* Set some sensible fallbacks */
510 cfg_codepage = ANSICP;
511 cfg_lcid = LOCALE_NEUTRAL;
512 cfg_clipboard_type = CF_TEXT;
514 /* Interpret the coding system symbol name */
515 coding_name = SDATA (SYMBOL_NAME (cfg_coding_system));
517 /* "(.*-)?utf-16.*" -> CF_UNICODETEXT */
518 cp = strstr (coding_name, "utf-16");
519 if (cp != NULL && (cp == coding_name || cp[-1] == '-'))
521 cfg_clipboard_type = CF_UNICODETEXT;
522 return;
525 /* "cp[0-9]+.*" or "windows-[0-9]+.*" -> CF_TEXT or CF_OEMTEXT */
526 slen = strlen (coding_name);
527 if (slen >= 4 && coding_name[0] == 'c' && coding_name[1] == 'p')
528 cp = coding_name + 2;
529 else if (slen >= 10 && memcmp (coding_name, "windows-", 8) == 0)
530 cp = coding_name + 8;
531 else
532 return;
534 end = (char*)cp;
535 cfg_codepage = strtol (cp, &end, 10);
537 /* Error return from strtol() or number of digits < 2 -> Restore the
538 default and drop it. */
539 if (cfg_codepage == 0 || (end-cp) < 2 )
541 cfg_codepage = ANSICP;
542 return;
545 /* Is it the currently active system default? */
546 if (cfg_codepage == ANSICP)
548 /* cfg_clipboard_type = CF_TEXT; */
549 return;
551 if (cfg_codepage == OEMCP)
553 cfg_clipboard_type = CF_OEMTEXT;
554 return;
557 /* Else determine a suitable locale the hard way. */
558 EnumSystemLocales (enum_locale_callback, LCID_INSTALLED);
561 static BOOL WINAPI
562 enum_locale_callback (/*const*/ char* loc_string)
564 LCID lcid;
565 UINT codepage;
567 lcid = strtoul (loc_string, NULL, 16);
569 /* Is the wanted codepage the "ANSI" codepage for this locale? */
570 codepage = cp_from_locale (lcid, CF_TEXT);
571 if (codepage == cfg_codepage)
573 cfg_lcid = lcid;
574 cfg_clipboard_type = CF_TEXT;
575 return FALSE; /* Stop enumeration */
578 /* Is the wanted codepage the OEM codepage for this locale? */
579 codepage = cp_from_locale (lcid, CF_OEMTEXT);
580 if (codepage == cfg_codepage)
582 cfg_lcid = lcid;
583 cfg_clipboard_type = CF_OEMTEXT;
584 return FALSE; /* Stop enumeration */
587 return TRUE; /* Continue enumeration */
590 static UINT
591 cp_from_locale (LCID lcid, UINT format)
593 char buffer[20] = "";
594 UINT variant, cp;
596 variant =
597 format == CF_TEXT ? LOCALE_IDEFAULTANSICODEPAGE : LOCALE_IDEFAULTCODEPAGE;
599 GetLocaleInfo (lcid, variant, buffer, sizeof (buffer));
600 cp = strtoul (buffer, NULL, 10);
602 if (cp == CP_ACP)
603 return ANSICP;
604 else if (cp == CP_OEMCP)
605 return OEMCP;
606 else
607 return cp;
610 static Lisp_Object
611 coding_from_cp (UINT codepage)
613 char buffer[30];
614 sprintf (buffer, "cp%d-dos", (int) codepage);
615 return intern (buffer);
616 /* We don't need to check that this coding system actually exists
617 right here, because that is done later for all coding systems
618 used, regardless of where they originate. */
621 static Lisp_Object
622 validate_coding_system (Lisp_Object coding_system)
624 Lisp_Object eol_type;
626 /* Make sure the input is valid. */
627 if (NILP (Fcoding_system_p (coding_system)))
628 return Qnil;
630 /* Make sure we use a DOS coding system as mandated by the system
631 specs. */
632 eol_type = Fcoding_system_eol_type (coding_system);
634 /* Already a DOS coding system? */
635 if (EQ (eol_type, make_number (1)))
636 return coding_system;
638 /* Get EOL_TYPE vector of the base of CODING_SYSTEM. */
639 if (!VECTORP (eol_type))
641 eol_type = Fcoding_system_eol_type (Fcoding_system_base (coding_system));
642 if (!VECTORP (eol_type))
643 return Qnil;
646 return AREF (eol_type, 1);
649 static void
650 setup_windows_coding_system (Lisp_Object coding_system,
651 struct coding_system * coding)
653 memset (coding, 0, sizeof (*coding));
654 setup_coding_system (coding_system, coding);
656 /* Unset CODING_ANNOTATE_COMPOSITION_MASK. Previous code had
657 comments about crashes in encode_coding_iso2022 trying to
658 dereference a null pointer when composition was on. Selection
659 data should not contain any composition sequence on Windows.
661 CODING_ANNOTATION_MASK also includes
662 CODING_ANNOTATE_DIRECTION_MASK and CODING_ANNOTATE_CHARSET_MASK,
663 which both apply to ISO6429 only. We don't know if these really
664 need to be unset on Windows, but it probably doesn't hurt
665 either. */
666 coding->mode &= ~CODING_ANNOTATION_MASK;
667 coding->mode |= CODING_MODE_LAST_BLOCK | CODING_MODE_SAFE_ENCODING;
672 DEFUN ("w32-set-clipboard-data", Fw32_set_clipboard_data,
673 Sw32_set_clipboard_data, 1, 2, 0,
674 doc: /* This sets the clipboard data to the given text. */)
675 (Lisp_Object string, Lisp_Object ignored)
677 BOOL ok = TRUE;
678 int nbytes;
679 unsigned char *src;
680 unsigned char *dst;
681 unsigned char *end;
683 /* This parameter used to be the current frame, but we don't use
684 that any more. */
685 (void) ignored;
687 CHECK_STRING (string);
689 setup_config ();
691 current_text = string;
692 current_coding_system = cfg_coding_system;
693 current_clipboard_type = cfg_clipboard_type;
694 current_lcid = cfg_lcid;
695 current_num_nls = 0;
696 current_requires_encoding = 0;
698 BLOCK_INPUT;
700 /* Check for non-ASCII characters. While we are at it, count the
701 number of LFs, so we know how many CRs we will have to add later
702 (just in the case where we can use our internal ASCII rendering,
703 see code and comment in convert_to_handle_as_ascii() above). */
704 nbytes = SBYTES (string);
705 src = SDATA (string);
707 for (dst = src, end = src+nbytes; dst < end; dst++)
709 if (*dst == '\n')
710 current_num_nls++;
711 else if (*dst >= 0x80 || *dst == 0)
713 current_requires_encoding = 1;
714 break;
718 if (!current_requires_encoding)
720 /* If all we have is ASCII we don't need to pretend we offer
721 anything fancy. */
722 current_coding_system = Qraw_text;
723 current_clipboard_type = CF_TEXT;
724 current_lcid = LOCALE_NEUTRAL;
727 if (!OpenClipboard (clipboard_owner))
728 goto error;
730 ++modifying_clipboard;
731 ok = EmptyClipboard ();
732 --modifying_clipboard;
734 /* If we have something non-ASCII we may want to set a locale. We
735 do that directly (non-delayed), as it's just a small bit. */
736 if (ok)
737 ok = !NILP (render_locale ());
739 if (ok)
741 if (clipboard_owner == NULL)
743 /* If for some reason we don't have a clipboard_owner, we
744 just set the text format as chosen by the configuration
745 and than forget about the whole thing. */
746 ok = !NILP (render (make_number (current_clipboard_type)));
747 current_text = Qnil;
748 current_coding_system = Qnil;
750 else
752 /* Advertise all supported formats so that whatever the
753 requester chooses, only one encoding step needs to be
754 made. This is intentionally different from what we do in
755 the handler for WM_RENDERALLFORMATS. */
756 SetClipboardData (CF_UNICODETEXT, NULL);
757 SetClipboardData (CF_TEXT, NULL);
758 SetClipboardData (CF_OEMTEXT, NULL);
762 CloseClipboard ();
764 /* With delayed rendering we haven't really "used" this coding
765 system yet, and it's even unclear if we ever will. But this is a
766 way to tell the upper level what we *would* use under ideal
767 circumstances.
769 We don't signal the actually used coding-system later when we
770 finally render, because that can happen at any time and we don't
771 want to disturb the "foreground" action. */
772 if (ok)
773 Vlast_coding_system_used = current_coding_system;
775 Vnext_selection_coding_system = Qnil;
777 if (ok) goto done;
779 error:
781 ok = FALSE;
782 current_text = Qnil;
783 current_coding_system = Qnil;
785 done:
786 UNBLOCK_INPUT;
788 return (ok ? string : Qnil);
792 DEFUN ("w32-get-clipboard-data", Fw32_get_clipboard_data,
793 Sw32_get_clipboard_data, 0, 1, 0,
794 doc: /* This gets the clipboard data in text format. */)
795 (Lisp_Object ignored)
797 HGLOBAL htext;
798 Lisp_Object ret = Qnil;
799 UINT actual_clipboard_type;
800 int use_configured_coding_system = 1;
802 /* This parameter used to be the current frame, but we don't use
803 that any more. */
804 (void) ignored;
806 /* Don't pass our own text from the clipboard (which might be
807 troublesome if the killed text includes null characters). */
808 if (!NILP (current_text))
809 return ret;
811 setup_config ();
812 actual_clipboard_type = cfg_clipboard_type;
814 BLOCK_INPUT;
816 if (!OpenClipboard (clipboard_owner))
817 goto done;
819 if ((htext = GetClipboardData (actual_clipboard_type)) == NULL)
821 /* If we want CF_UNICODETEXT but can't get it, the current
822 coding system is useless. OTOH we can still try and decode
823 CF_TEXT based on the locale that the system gives us and that
824 we get down below. */
825 if (actual_clipboard_type == CF_UNICODETEXT)
827 htext = GetClipboardData (CF_TEXT);
828 if (htext != NULL)
830 actual_clipboard_type = CF_TEXT;
831 use_configured_coding_system = 0;
835 if (htext == NULL)
836 goto closeclip;
839 unsigned char *src;
840 unsigned char *dst;
841 int nbytes;
842 int truelen;
843 int require_decoding = 0;
845 if ((src = (unsigned char *) GlobalLock (htext)) == NULL)
846 goto closeclip;
848 /* If the clipboard data contains any non-ascii code, we need to
849 decode it with a coding system. */
850 if (actual_clipboard_type == CF_UNICODETEXT)
852 nbytes = lstrlenW ((WCHAR *)src) * 2;
853 require_decoding = 1;
855 else
857 int i;
859 nbytes = strlen (src);
861 for (i = 0; i < nbytes; i++)
863 if (src[i] >= 0x80)
865 require_decoding = 1;
866 break;
871 if (require_decoding)
873 struct coding_system coding;
874 Lisp_Object coding_system = Qnil;
875 Lisp_Object dos_coding_system;
877 /* `next-selection-coding-system' should override everything,
878 even when the locale passed by the system disagrees. The
879 only exception is when `next-selection-coding-system'
880 requested CF_UNICODETEXT and we couldn't get that. */
881 if (use_configured_coding_system
882 && !NILP (Vnext_selection_coding_system))
883 coding_system = Vnext_selection_coding_system;
885 /* If we have CF_TEXT or CF_OEMTEXT, we want to check out
886 CF_LOCALE, too. */
887 else if (actual_clipboard_type != CF_UNICODETEXT)
889 HGLOBAL hlocale;
890 LCID lcid = DEFAULT_LCID;
891 UINT cp;
893 /* Documentation says that the OS always generates
894 CF_LOCALE info automatically, so the locale handle
895 should always be present. Fact is that this is not
896 always true on 9x ;-(. */
897 hlocale = GetClipboardData (CF_LOCALE);
898 if (hlocale != NULL)
900 const LCID * lcid_ptr;
901 lcid_ptr = (const LCID *) GlobalLock (hlocale);
902 if (lcid_ptr != NULL)
904 lcid = *lcid_ptr;
905 GlobalUnlock (hlocale);
908 /* 9x has garbage as the sort order (to be exact there
909 is another instance of the language id in the upper
910 word). We don't care about sort order anyway, so
911 we just filter out the unneeded mis-information to
912 avoid irritations. */
913 lcid = MAKELCID (LANGIDFROMLCID (lcid), SORT_DEFAULT);
916 /* If we are using fallback from CF_UNICODETEXT, we can't
917 use the configured coding system. Also we don't want
918 to use it, if the system has supplied us with a locale
919 and it is not just the system default. */
920 if (!use_configured_coding_system || lcid != DEFAULT_LCID)
922 cp = cp_from_locale (lcid, actual_clipboard_type);
923 /* If it's just our current standard setting anyway,
924 use the coding system that the user has selected.
925 Otherwise create a new spec to match the locale
926 that was specified by the other side or the
927 system. */
928 if (!use_configured_coding_system || cp != cfg_codepage)
929 coding_system = coding_from_cp (cp);
933 if (NILP (coding_system))
934 coding_system = Vselection_coding_system;
935 Vnext_selection_coding_system = Qnil;
937 dos_coding_system = validate_coding_system (coding_system);
938 if (!NILP (dos_coding_system))
940 setup_windows_coding_system (dos_coding_system, &coding);
941 coding.source = src;
942 decode_coding_object (&coding, Qnil, 0, 0, nbytes, nbytes, Qt);
943 ret = coding.dst_object;
945 Vlast_coding_system_used = CODING_ID_NAME (coding.id);
948 else
950 /* FIXME: We may want to repeat the code in this branch for
951 the Unicode case. */
953 /* Need to know final size after CR chars are removed because
954 we can't change the string size manually, and doing an
955 extra copy is silly. We only remove CR when it appears as
956 part of CRLF. */
958 truelen = nbytes;
959 dst = src;
960 /* avoid using strchr because it recomputes the length everytime */
961 while ((dst = memchr (dst, '\r', nbytes - (dst - src))) != NULL)
963 if (dst[1] == '\n') /* safe because of trailing '\0' */
964 truelen--;
965 dst++;
968 ret = make_uninit_string (truelen);
970 /* Convert CRLF line endings (the standard CF_TEXT clipboard
971 format) to LF endings as used internally by Emacs. */
973 dst = SDATA (ret);
974 while (1)
976 unsigned char *next;
977 /* copy next line or remaining bytes excluding '\0' */
978 next = _memccpy (dst, src, '\r', nbytes);
979 if (next)
981 /* copied one line ending with '\r' */
982 int copied = next - dst;
983 nbytes -= copied;
984 dst += copied;
985 src += copied;
986 if (*src == '\n')
987 dst--; /* overwrite '\r' with '\n' */
989 else
990 /* copied remaining partial line -> now finished */
991 break;
994 Vlast_coding_system_used = Qraw_text;
997 GlobalUnlock (htext);
1000 closeclip:
1001 CloseClipboard ();
1003 done:
1004 UNBLOCK_INPUT;
1006 return (ret);
1009 /* Support checking for a clipboard selection. */
1011 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
1012 0, 1, 0,
1013 doc: /* Whether there is an owner for the given X Selection.
1014 The arg should be the name of the selection in question, typically one of
1015 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
1016 \(Those are literal upper-case symbol names, since that's what X expects.)
1017 For convenience, the symbol nil is the same as `PRIMARY',
1018 and t is the same as `SECONDARY'. */)
1019 (Lisp_Object selection)
1021 CHECK_SYMBOL (selection);
1023 /* Return nil for PRIMARY and SECONDARY selections; for CLIPBOARD, check
1024 if the clipboard currently has valid text format contents. */
1026 if (EQ (selection, QCLIPBOARD))
1028 Lisp_Object val = Qnil;
1030 setup_config ();
1032 if (OpenClipboard (NULL))
1034 UINT format = 0;
1035 while ((format = EnumClipboardFormats (format)))
1036 /* Check CF_TEXT in addition to cfg_clipboard_type,
1037 because we can fall back on that if CF_UNICODETEXT is
1038 not available. Actually a check for CF_TEXT only
1039 should be enough. */
1040 if (format == cfg_clipboard_type || format == CF_TEXT)
1042 val = Qt;
1043 break;
1045 CloseClipboard ();
1047 return val;
1049 return Qnil;
1052 /* One-time init. Called in the un-dumped Emacs, but not in the
1053 dumped version. */
1055 void
1056 syms_of_w32select (void)
1058 defsubr (&Sw32_set_clipboard_data);
1059 defsubr (&Sw32_get_clipboard_data);
1060 defsubr (&Sx_selection_exists_p);
1062 DEFVAR_LISP ("selection-coding-system", Vselection_coding_system,
1063 doc: /* Coding system for communicating with other programs.
1065 For MS-Windows and MS-DOS:
1066 When sending or receiving text via selection and clipboard, the text
1067 is encoded or decoded by this coding system. The default value is
1068 the current system default encoding on 9x/Me, `utf-16le-dos'
1069 \(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS.
1071 For X Windows:
1072 When sending text via selection and clipboard, if the target
1073 data-type matches with the type of this coding system, it is used
1074 for encoding the text. Otherwise (including the case that this
1075 variable is nil), a proper coding system is used as below:
1077 data-type coding system
1078 --------- -------------
1079 UTF8_STRING utf-8
1080 COMPOUND_TEXT compound-text-with-extensions
1081 STRING iso-latin-1
1082 C_STRING no-conversion
1084 When receiving text, if this coding system is non-nil, it is used
1085 for decoding regardless of the data-type. If this is nil, a
1086 proper coding system is used according to the data-type as above.
1088 See also the documentation of the variable `x-select-request-type' how
1089 to control which data-type to request for receiving text.
1091 The default value is nil. */);
1092 /* The actual value is set dynamically in the dumped Emacs, see
1093 below. */
1094 Vselection_coding_system = Qnil;
1096 DEFVAR_LISP ("next-selection-coding-system", Vnext_selection_coding_system,
1097 doc: /* Coding system for the next communication with other programs.
1098 Usually, `selection-coding-system' is used for communicating with
1099 other programs (X Windows clients or MS Windows programs). But, if this
1100 variable is set, it is used for the next communication only.
1101 After the communication, this variable is set to nil. */);
1102 Vnext_selection_coding_system = Qnil;
1104 DEFSYM (QCLIPBOARD, "CLIPBOARD");
1106 cfg_coding_system = Qnil; staticpro (&cfg_coding_system);
1107 current_text = Qnil; staticpro (&current_text);
1108 current_coding_system = Qnil; staticpro (&current_coding_system);
1110 DEFSYM (QUNICODE, "utf-16le-dos");
1111 QANSICP = Qnil; staticpro (&QANSICP);
1112 QOEMCP = Qnil; staticpro (&QOEMCP);
1115 /* One-time init. Called in the dumped Emacs, but not in the
1116 un-dumped version. */
1118 void
1119 globals_of_w32select (void)
1121 DEFAULT_LCID = GetUserDefaultLCID ();
1122 /* Drop the sort order from the LCID, so we can compare this with
1123 CF_LOCALE objects that have the same fix on 9x. */
1124 DEFAULT_LCID = MAKELCID (LANGIDFROMLCID (DEFAULT_LCID), SORT_DEFAULT);
1126 ANSICP = GetACP ();
1127 OEMCP = GetOEMCP ();
1129 QANSICP = coding_from_cp (ANSICP);
1130 QOEMCP = coding_from_cp (OEMCP);
1132 if (os_subtype == OS_NT)
1133 Vselection_coding_system = QUNICODE;
1134 else if (inhibit_window_system)
1135 Vselection_coding_system = QOEMCP;
1136 else
1137 Vselection_coding_system = QANSICP;
1139 clipboard_owner = create_owner ();