Merge from gnulib
[emacs.git] / src / w32select.c
blob3c554c622aec87d832dbe21bc552add2c473dadb
1 /* Selection processing for Emacs on the Microsoft Windows API.
3 Copyright (C) 1993-1994, 2001-2015 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 requestor 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 "lisp.h"
77 #include "w32common.h" /* os_subtype */
78 #include "w32term.h" /* for all of the w32 includes */
79 #include "keyboard.h"
80 #include "blockinput.h"
81 #include "charset.h"
82 #include "coding.h"
83 #include "composite.h"
85 #ifdef CYGWIN
86 #include <string.h>
87 #include <stdio.h>
88 #define _memccpy memccpy
89 #endif
91 static HGLOBAL convert_to_handle_as_ascii (void);
92 static HGLOBAL convert_to_handle_as_coded (Lisp_Object coding_system);
93 static Lisp_Object render (Lisp_Object oformat);
94 static Lisp_Object render_locale (void);
95 static Lisp_Object render_all (Lisp_Object ignore);
96 static void run_protected (Lisp_Object (*code) (Lisp_Object), Lisp_Object arg);
97 static Lisp_Object lisp_error_handler (Lisp_Object error);
98 static LRESULT CALLBACK ALIGN_STACK owner_callback (HWND win, UINT msg,
99 WPARAM wp, LPARAM lp);
100 static HWND create_owner (void);
102 static void setup_config (void);
103 static BOOL WINAPI enum_locale_callback (/*const*/ char* loc_string);
104 static UINT cp_from_locale (LCID lcid, UINT format);
105 static Lisp_Object coding_from_cp (UINT codepage);
106 static Lisp_Object validate_coding_system (Lisp_Object coding_system);
107 static void setup_windows_coding_system (Lisp_Object coding_system,
108 struct coding_system * coding);
110 /* Internal pseudo-constants, initialized in globals_of_w32select()
111 based on current system parameters. */
112 static LCID DEFAULT_LCID;
113 static UINT ANSICP, OEMCP;
114 static Lisp_Object QANSICP, QOEMCP;
116 /* A hidden window just for the clipboard management. */
117 static HWND clipboard_owner;
118 /* A flag to tell WM_DESTROYCLIPBOARD who is to blame this time (just
119 checking GetClipboardOwner() doesn't work, sadly). */
120 static int modifying_clipboard = 0;
122 /* Configured transfer parameters, based on the last inspection of
123 selection-coding-system. */
124 static Lisp_Object cfg_coding_system;
125 static UINT cfg_codepage;
126 static LCID cfg_lcid;
127 static UINT cfg_clipboard_type;
129 /* The current state for delayed rendering. */
130 static Lisp_Object current_text;
131 static Lisp_Object current_coding_system;
132 static int current_requires_encoding, current_num_nls;
133 static UINT current_clipboard_type;
134 static LCID current_lcid;
136 #if TRACE
137 #define ONTRACE(stmt) stmt
138 #else
139 #define ONTRACE(stmt) /*stmt*/
140 #endif
143 /* This function assumes that there is no multibyte character in
144 current_text, so we can short-cut encoding. */
146 static HGLOBAL
147 convert_to_handle_as_ascii (void)
149 HGLOBAL htext = NULL;
150 int nbytes;
151 int truelen;
152 unsigned char *src;
153 unsigned char *dst;
155 ONTRACE (fprintf (stderr, "convert_to_handle_as_ascii\n"));
157 nbytes = SBYTES (current_text) + 1;
158 src = SDATA (current_text);
160 /* We need to add to the size the number of LF chars where we have
161 to insert CR chars (the standard CF_TEXT clipboard format uses
162 CRLF line endings, while Emacs uses just LF internally). */
164 truelen = nbytes + current_num_nls;
166 if ((htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, truelen)) == NULL)
167 return NULL;
169 if ((dst = (unsigned char *) GlobalLock (htext)) == NULL)
171 GlobalFree (htext);
172 return NULL;
175 /* convert to CRLF line endings expected by clipboard */
176 while (1)
178 unsigned char *next;
179 /* copy next line or remaining bytes including '\0' */
180 next = _memccpy (dst, src, '\n', nbytes);
181 if (next)
183 /* copied one line ending with '\n' */
184 int copied = next - dst;
185 nbytes -= copied;
186 src += copied;
187 /* insert '\r' before '\n' */
188 next[-1] = '\r';
189 next[0] = '\n';
190 dst = next + 1;
192 else
193 /* copied remaining partial line -> now finished */
194 break;
197 GlobalUnlock (htext);
199 return htext;
202 /* This function assumes that there are multibyte or NUL characters in
203 current_text, or that we need to construct Unicode. It runs the
204 text through the encoding machinery. */
206 static HGLOBAL
207 convert_to_handle_as_coded (Lisp_Object coding_system)
209 HGLOBAL htext;
210 unsigned char *dst = NULL;
211 struct coding_system coding;
213 ONTRACE (fprintf (stderr, "convert_to_handle_as_coded: %s\n",
214 SDATA (SYMBOL_NAME (coding_system))));
216 setup_windows_coding_system (coding_system, &coding);
217 coding.dst_bytes = SBYTES (current_text) * 2;
218 coding.destination = xmalloc (coding.dst_bytes);
219 encode_coding_object (&coding, current_text, 0, 0,
220 SCHARS (current_text), SBYTES (current_text), Qnil);
222 htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, coding.produced +2);
224 if (htext != NULL)
225 dst = (unsigned char *) GlobalLock (htext);
227 if (dst != NULL)
229 memcpy (dst, coding.destination, coding.produced);
230 /* Add the string terminator. Add two NULs in case we are
231 producing Unicode here. */
232 dst[coding.produced] = dst[coding.produced+1] = '\0';
234 GlobalUnlock (htext);
237 xfree (coding.destination);
239 return htext;
242 static Lisp_Object
243 render (Lisp_Object oformat)
245 HGLOBAL htext = NULL;
246 UINT format = XFASTINT (oformat);
248 ONTRACE (fprintf (stderr, "render\n"));
250 if (NILP (current_text))
251 return Qnil;
253 if (current_requires_encoding || format == CF_UNICODETEXT)
255 if (format == current_clipboard_type)
256 htext = convert_to_handle_as_coded (current_coding_system);
257 else
258 switch (format)
260 case CF_UNICODETEXT:
261 htext = convert_to_handle_as_coded (QUNICODE);
262 break;
263 case CF_TEXT:
264 case CF_OEMTEXT:
266 Lisp_Object cs;
267 cs = coding_from_cp (cp_from_locale (current_lcid, format));
268 htext = convert_to_handle_as_coded (cs);
269 break;
273 else
274 htext = convert_to_handle_as_ascii ();
276 ONTRACE (fprintf (stderr, "render: htext = 0x%08X\n", (unsigned) htext));
278 if (htext == NULL)
279 return Qnil;
281 if (SetClipboardData (format, htext) == NULL)
283 GlobalFree (htext);
284 return Qnil;
287 return Qt;
290 static Lisp_Object
291 render_locale (void)
293 HANDLE hlocale = NULL;
294 LCID * lcid_ptr;
296 ONTRACE (fprintf (stderr, "render_locale\n"));
298 if (current_lcid == LOCALE_NEUTRAL || current_lcid == DEFAULT_LCID)
299 return Qt;
301 hlocale = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, sizeof (current_lcid));
302 if (hlocale == NULL)
303 return Qnil;
305 if ((lcid_ptr = (LCID *) GlobalLock (hlocale)) == NULL)
307 GlobalFree (hlocale);
308 return Qnil;
311 *lcid_ptr = current_lcid;
312 GlobalUnlock (hlocale);
314 if (SetClipboardData (CF_LOCALE, hlocale) == NULL)
316 GlobalFree (hlocale);
317 return Qnil;
320 return Qt;
323 /* At the end of the program, we want to ensure that our clipboard
324 data survives us. This code will do that. */
326 static Lisp_Object
327 render_all (Lisp_Object ignore)
329 ONTRACE (fprintf (stderr, "render_all\n"));
331 /* According to the docs we should not call OpenClipboard() here,
332 but testing on W2K and working code in other projects shows that
333 it is actually necessary. */
335 OpenClipboard (NULL);
337 /* There is no useful means to report errors here, there are none
338 expected anyway, and even if there were errors, they wouldn't do
339 any harm. So we just go ahead and do what has to be done without
340 bothering with error handling. */
342 ++modifying_clipboard;
343 EmptyClipboard ();
344 --modifying_clipboard;
346 /* For text formats that we don't render here, the OS can use its
347 own translation rules instead, so we don't really need to offer
348 everything. To minimize memory consumption we cover three
349 possible situations based on our primary format as detected from
350 selection-coding-system (see setup_config()):
352 - Post CF_TEXT only. Let the OS convert to CF_OEMTEXT and the OS
353 (on NT) or the application (on 9x/Me) convert to
354 CF_UNICODETEXT.
356 - Post CF_OEMTEXT only. Similar automatic conversions happen as
357 for CF_TEXT.
359 - Post CF_UNICODETEXT + CF_TEXT. 9x itself ignores
360 CF_UNICODETEXT, even though some applications can still handle
363 Note 1: We render the less capable CF_TEXT *before* the more
364 capable CF_UNICODETEXT, to prevent clobbering through automatic
365 conversions, just in case.
367 Note 2: We could check os_subtype here and only render the
368 additional CF_TEXT on 9x/Me. But OTOH with
369 current_clipboard_type == CF_UNICODETEXT we don't involve the
370 automatic conversions anywhere else, so to get consistent
371 results, we probably don't want to rely on it here either. */
373 render_locale ();
375 if (current_clipboard_type == CF_UNICODETEXT)
376 render (make_number (CF_TEXT));
377 render (make_number (current_clipboard_type));
379 CloseClipboard ();
381 return Qnil;
384 static void
385 run_protected (Lisp_Object (*code) (Lisp_Object), Lisp_Object arg)
387 /* FIXME: This works but it doesn't feel right. Too much fiddling
388 with global variables and calling strange looking functions. Is
389 this really the right way to run Lisp callbacks? */
391 int owfi;
393 block_input ();
395 /* Fsignal calls emacs_abort () if it sees that waiting_for_input is
396 set. */
397 owfi = waiting_for_input;
398 waiting_for_input = 0;
400 internal_condition_case_1 (code, arg, Qt, lisp_error_handler);
402 waiting_for_input = owfi;
404 unblock_input ();
407 static Lisp_Object
408 lisp_error_handler (Lisp_Object error)
410 Vsignaling_function = Qnil;
411 cmd_error_internal (error, "Error in delayed clipboard rendering: ");
412 Vinhibit_quit = Qt;
413 return Qt;
417 static LRESULT CALLBACK ALIGN_STACK
418 owner_callback (HWND win, UINT msg, WPARAM wp, LPARAM lp)
420 switch (msg)
422 case WM_RENDERFORMAT:
423 ONTRACE (fprintf (stderr, "WM_RENDERFORMAT\n"));
424 run_protected (render, make_number (wp));
425 return 0;
427 case WM_RENDERALLFORMATS:
428 ONTRACE (fprintf (stderr, "WM_RENDERALLFORMATS\n"));
429 run_protected (render_all, Qnil);
430 return 0;
432 case WM_DESTROYCLIPBOARD:
433 if (!modifying_clipboard)
435 ONTRACE (fprintf (stderr, "WM_DESTROYCLIPBOARD (other)\n"));
436 current_text = Qnil;
437 current_coding_system = Qnil;
439 else
441 ONTRACE (fprintf (stderr, "WM_DESTROYCLIPBOARD (self)\n"));
443 return 0;
445 case WM_DESTROY:
446 if (win == clipboard_owner)
447 clipboard_owner = NULL;
448 break;
451 return DefWindowProc (win, msg, wp, lp);
454 static HWND
455 create_owner (void)
457 static const char CLASSNAME[] = "Emacs Clipboard";
458 WNDCLASS wc;
460 memset (&wc, 0, sizeof (wc));
461 wc.lpszClassName = CLASSNAME;
462 wc.lpfnWndProc = owner_callback;
463 RegisterClass (&wc);
465 return CreateWindow (CLASSNAME, CLASSNAME, 0, 0, 0, 0, 0, NULL, NULL,
466 NULL, NULL);
469 /* Called on exit by term_ntproc() in w32.c */
471 void
472 term_w32select (void)
474 /* This is needed to trigger WM_RENDERALLFORMATS. */
475 if (clipboard_owner != NULL)
477 DestroyWindow (clipboard_owner);
478 clipboard_owner = NULL;
482 static void
483 setup_config (void)
485 const char *coding_name;
486 const char *cp;
487 char *end;
488 int slen;
489 Lisp_Object coding_system;
490 Lisp_Object dos_coding_system;
492 CHECK_SYMBOL (Vselection_coding_system);
494 coding_system = NILP (Vnext_selection_coding_system) ?
495 Vselection_coding_system : Vnext_selection_coding_system;
497 dos_coding_system = validate_coding_system (coding_system);
498 if (NILP (dos_coding_system))
499 Fsignal (Qerror,
500 list2 (build_string ("Coding system is invalid or doesn't have "
501 "an eol variant for dos line ends"),
502 coding_system));
504 /* Check if we have it cached */
505 if (!NILP (cfg_coding_system)
506 && EQ (cfg_coding_system, dos_coding_system))
507 return;
508 cfg_coding_system = dos_coding_system;
510 /* Set some sensible fallbacks */
511 cfg_codepage = ANSICP;
512 cfg_lcid = LOCALE_NEUTRAL;
513 cfg_clipboard_type = CF_TEXT;
515 /* Interpret the coding system symbol name */
516 coding_name = SDATA (SYMBOL_NAME (cfg_coding_system));
518 /* "(.*-)?utf-16.*" -> CF_UNICODETEXT */
519 cp = strstr (coding_name, "utf-16");
520 if (cp != NULL && (cp == coding_name || cp[-1] == '-'))
522 cfg_clipboard_type = CF_UNICODETEXT;
523 return;
526 /* "cp[0-9]+.*" or "windows-[0-9]+.*" -> CF_TEXT or CF_OEMTEXT */
527 slen = strlen (coding_name);
528 if (slen >= 4 && coding_name[0] == 'c' && coding_name[1] == 'p')
529 cp = coding_name + 2;
530 else if (slen >= 10 && memcmp (coding_name, "windows-", 8) == 0)
531 cp = coding_name + 8;
532 else
533 return;
535 end = (char*)cp;
536 cfg_codepage = strtol (cp, &end, 10);
538 /* Error return from strtol() or number of digits < 2 -> Restore the
539 default and drop it. */
540 if (cfg_codepage == 0 || (end-cp) < 2 )
542 cfg_codepage = ANSICP;
543 return;
546 /* Is it the currently active system default? */
547 if (cfg_codepage == ANSICP)
549 /* cfg_clipboard_type = CF_TEXT; */
550 return;
552 if (cfg_codepage == OEMCP)
554 cfg_clipboard_type = CF_OEMTEXT;
555 return;
558 /* Else determine a suitable locale the hard way. */
559 EnumSystemLocales (enum_locale_callback, LCID_INSTALLED);
562 static BOOL WINAPI
563 enum_locale_callback (/*const*/ char* loc_string)
565 LCID lcid;
566 UINT codepage;
568 lcid = strtoul (loc_string, NULL, 16);
570 /* Is the wanted codepage the "ANSI" codepage for this locale? */
571 codepage = cp_from_locale (lcid, CF_TEXT);
572 if (codepage == cfg_codepage)
574 cfg_lcid = lcid;
575 cfg_clipboard_type = CF_TEXT;
576 return FALSE; /* Stop enumeration */
579 /* Is the wanted codepage the OEM codepage for this locale? */
580 codepage = cp_from_locale (lcid, CF_OEMTEXT);
581 if (codepage == cfg_codepage)
583 cfg_lcid = lcid;
584 cfg_clipboard_type = CF_OEMTEXT;
585 return FALSE; /* Stop enumeration */
588 return TRUE; /* Continue enumeration */
591 static UINT
592 cp_from_locale (LCID lcid, UINT format)
594 char buffer[20] = "";
595 UINT variant, cp;
597 variant =
598 format == CF_TEXT ? LOCALE_IDEFAULTANSICODEPAGE : LOCALE_IDEFAULTCODEPAGE;
600 GetLocaleInfo (lcid, variant, buffer, sizeof (buffer));
601 cp = strtoul (buffer, NULL, 10);
603 if (cp == CP_ACP)
604 return ANSICP;
605 else if (cp == CP_OEMCP)
606 return OEMCP;
607 else
608 return cp;
611 static Lisp_Object
612 coding_from_cp (UINT codepage)
614 char buffer[30];
615 sprintf (buffer, "cp%d-dos", (int) codepage);
616 return intern (buffer);
617 /* We don't need to check that this coding system actually exists
618 right here, because that is done later for all coding systems
619 used, regardless of where they originate. */
622 static Lisp_Object
623 validate_coding_system (Lisp_Object coding_system)
625 Lisp_Object eol_type;
627 /* Make sure the input is valid. */
628 if (NILP (Fcoding_system_p (coding_system)))
629 return Qnil;
631 /* Make sure we use a DOS coding system as mandated by the system
632 specs. */
633 eol_type = Fcoding_system_eol_type (coding_system);
635 /* Already a DOS coding system? */
636 if (EQ (eol_type, make_number (1)))
637 return coding_system;
639 /* Get EOL_TYPE vector of the base of CODING_SYSTEM. */
640 if (!VECTORP (eol_type))
642 eol_type = Fcoding_system_eol_type (Fcoding_system_base (coding_system));
643 if (!VECTORP (eol_type))
644 return Qnil;
647 return AREF (eol_type, 1);
650 static void
651 setup_windows_coding_system (Lisp_Object coding_system,
652 struct coding_system * coding)
654 memset (coding, 0, sizeof (*coding));
655 setup_coding_system (coding_system, coding);
657 /* Unset CODING_ANNOTATE_COMPOSITION_MASK. Previous code had
658 comments about crashes in encode_coding_iso2022 trying to
659 dereference a null pointer when composition was on. Selection
660 data should not contain any composition sequence on Windows.
662 CODING_ANNOTATION_MASK also includes
663 CODING_ANNOTATE_DIRECTION_MASK and CODING_ANNOTATE_CHARSET_MASK,
664 which both apply to ISO6429 only. We don't know if these really
665 need to be unset on Windows, but it probably doesn't hurt
666 either. */
667 coding->common_flags &= ~CODING_ANNOTATION_MASK;
668 coding->mode |= CODING_MODE_LAST_BLOCK | CODING_MODE_SAFE_ENCODING;
673 DEFUN ("w32-set-clipboard-data", Fw32_set_clipboard_data,
674 Sw32_set_clipboard_data, 1, 2, 0,
675 doc: /* This sets the clipboard data to the given text. */)
676 (Lisp_Object string, Lisp_Object ignored)
678 BOOL ok = TRUE;
679 int nbytes;
680 unsigned char *src;
681 unsigned char *dst;
682 unsigned char *end;
684 /* This parameter used to be the current frame, but we don't use
685 that any more. */
686 (void) ignored;
688 CHECK_STRING (string);
690 setup_config ();
692 current_text = string;
693 current_coding_system = cfg_coding_system;
694 current_clipboard_type = cfg_clipboard_type;
695 current_lcid = cfg_lcid;
696 current_num_nls = 0;
697 current_requires_encoding = 0;
699 block_input ();
701 /* Check for non-ASCII characters. While we are at it, count the
702 number of LFs, so we know how many CRs we will have to add later
703 (just in the case where we can use our internal ASCII rendering,
704 see code and comment in convert_to_handle_as_ascii() above). */
705 nbytes = SBYTES (string);
706 src = SDATA (string);
708 for (dst = src, end = src+nbytes; dst < end; dst++)
710 if (*dst == '\n')
711 current_num_nls++;
712 else if (*dst >= 0x80 || *dst == 0)
714 current_requires_encoding = 1;
715 break;
719 if (!current_requires_encoding)
721 /* If all we have is ASCII we don't need to pretend we offer
722 anything fancy. */
723 current_coding_system = Qraw_text;
724 current_clipboard_type = CF_TEXT;
725 current_lcid = LOCALE_NEUTRAL;
728 if (!OpenClipboard (clipboard_owner))
729 goto error;
731 ++modifying_clipboard;
732 ok = EmptyClipboard ();
733 --modifying_clipboard;
735 /* If we have something non-ASCII we may want to set a locale. We
736 do that directly (non-delayed), as it's just a small bit. */
737 if (ok)
738 ok = !NILP (render_locale ());
740 if (ok)
742 if (clipboard_owner == NULL)
744 /* If for some reason we don't have a clipboard_owner, we
745 just set the text format as chosen by the configuration
746 and than forget about the whole thing. */
747 ok = !NILP (render (make_number (current_clipboard_type)));
748 current_text = Qnil;
749 current_coding_system = Qnil;
751 else
753 /* Advertise all supported formats so that whatever the
754 requestor chooses, only one encoding step needs to be
755 made. This is intentionally different from what we do in
756 the handler for WM_RENDERALLFORMATS. */
757 SetClipboardData (CF_UNICODETEXT, NULL);
758 SetClipboardData (CF_TEXT, NULL);
759 SetClipboardData (CF_OEMTEXT, NULL);
763 CloseClipboard ();
765 /* With delayed rendering we haven't really "used" this coding
766 system yet, and it's even unclear if we ever will. But this is a
767 way to tell the upper level what we *would* use under ideal
768 circumstances.
770 We don't signal the actually used coding-system later when we
771 finally render, because that can happen at any time and we don't
772 want to disturb the "foreground" action. */
773 if (ok)
774 Vlast_coding_system_used = current_coding_system;
776 Vnext_selection_coding_system = Qnil;
778 if (ok) goto done;
780 error:
782 ok = FALSE;
783 current_text = Qnil;
784 current_coding_system = Qnil;
786 done:
787 unblock_input ();
789 return (ok ? string : Qnil);
793 DEFUN ("w32-get-clipboard-data", Fw32_get_clipboard_data,
794 Sw32_get_clipboard_data, 0, 1, 0,
795 doc: /* This gets the clipboard data in text format. */)
796 (Lisp_Object ignored)
798 HGLOBAL htext;
799 Lisp_Object ret = Qnil;
800 UINT actual_clipboard_type;
801 int use_configured_coding_system = 1;
803 /* This parameter used to be the current frame, but we don't use
804 that any more. */
805 (void) ignored;
807 /* Don't pass our own text from the clipboard (which might be
808 troublesome if the killed text includes null characters). */
809 if (!NILP (current_text))
810 return ret;
812 setup_config ();
813 actual_clipboard_type = cfg_clipboard_type;
815 block_input ();
817 if (!OpenClipboard (clipboard_owner))
818 goto done;
820 if ((htext = GetClipboardData (actual_clipboard_type)) == NULL)
822 /* If we want CF_UNICODETEXT but can't get it, the current
823 coding system is useless. OTOH we can still try and decode
824 CF_TEXT based on the locale that the system gives us and that
825 we get down below. */
826 if (actual_clipboard_type == CF_UNICODETEXT)
828 htext = GetClipboardData (CF_TEXT);
829 if (htext != NULL)
831 actual_clipboard_type = CF_TEXT;
832 use_configured_coding_system = 0;
836 if (htext == NULL)
837 goto closeclip;
840 unsigned char *src;
841 unsigned char *dst;
842 int nbytes;
843 int truelen;
844 int require_decoding = 0;
846 if ((src = (unsigned char *) GlobalLock (htext)) == NULL)
847 goto closeclip;
849 /* If the clipboard data contains any non-ascii code, we need to
850 decode it with a coding system. */
851 if (actual_clipboard_type == CF_UNICODETEXT)
853 nbytes = lstrlenW ((WCHAR *)src) * 2;
854 require_decoding = 1;
856 else
858 int i;
860 nbytes = strlen (src);
862 for (i = 0; i < nbytes; i++)
864 if (src[i] >= 0x80)
866 require_decoding = 1;
867 break;
872 if (require_decoding)
874 struct coding_system coding;
875 Lisp_Object coding_system = Qnil;
876 Lisp_Object dos_coding_system;
878 /* `next-selection-coding-system' should override everything,
879 even when the locale passed by the system disagrees. The
880 only exception is when `next-selection-coding-system'
881 requested CF_UNICODETEXT and we couldn't get that. */
882 if (use_configured_coding_system
883 && !NILP (Vnext_selection_coding_system))
884 coding_system = Vnext_selection_coding_system;
886 /* If we have CF_TEXT or CF_OEMTEXT, we want to check out
887 CF_LOCALE, too. */
888 else if (actual_clipboard_type != CF_UNICODETEXT)
890 HGLOBAL hlocale;
891 LCID lcid = DEFAULT_LCID;
892 UINT cp;
894 /* Documentation says that the OS always generates
895 CF_LOCALE info automatically, so the locale handle
896 should always be present. Fact is that this is not
897 always true on 9x ;-(. */
898 hlocale = GetClipboardData (CF_LOCALE);
899 if (hlocale != NULL)
901 const LCID * lcid_ptr;
902 lcid_ptr = (const LCID *) GlobalLock (hlocale);
903 if (lcid_ptr != NULL)
905 lcid = *lcid_ptr;
906 GlobalUnlock (hlocale);
909 /* 9x has garbage as the sort order (to be exact there
910 is another instance of the language id in the upper
911 word). We don't care about sort order anyway, so
912 we just filter out the unneeded mis-information to
913 avoid irritations. */
914 lcid = MAKELCID (LANGIDFROMLCID (lcid), SORT_DEFAULT);
917 /* If we are using fallback from CF_UNICODETEXT, we can't
918 use the configured coding system. Also we don't want
919 to use it, if the system has supplied us with a locale
920 and it is not just the system default. */
921 if (!use_configured_coding_system || lcid != DEFAULT_LCID)
923 cp = cp_from_locale (lcid, actual_clipboard_type);
924 /* If it's just our current standard setting anyway,
925 use the coding system that the user has selected.
926 Otherwise create a new spec to match the locale
927 that was specified by the other side or the
928 system. */
929 if (!use_configured_coding_system || cp != cfg_codepage)
930 coding_system = coding_from_cp (cp);
934 if (NILP (coding_system))
935 coding_system = Vselection_coding_system;
936 Vnext_selection_coding_system = Qnil;
938 dos_coding_system = validate_coding_system (coding_system);
939 if (!NILP (dos_coding_system))
941 setup_windows_coding_system (dos_coding_system, &coding);
942 coding.source = src;
943 decode_coding_object (&coding, Qnil, 0, 0, nbytes, nbytes, Qt);
944 ret = coding.dst_object;
946 Vlast_coding_system_used = CODING_ID_NAME (coding.id);
949 else
951 /* FIXME: We may want to repeat the code in this branch for
952 the Unicode case. */
954 /* Need to know final size after CR chars are removed because
955 we can't change the string size manually, and doing an
956 extra copy is silly. We only remove CR when it appears as
957 part of CRLF. */
959 truelen = nbytes;
960 dst = src;
961 /* avoid using strchr because it recomputes the length everytime */
962 while ((dst = memchr (dst, '\r', nbytes - (dst - src))) != NULL)
964 if (dst[1] == '\n') /* safe because of trailing '\0' */
965 truelen--;
966 dst++;
969 ret = make_uninit_string (truelen);
971 /* Convert CRLF line endings (the standard CF_TEXT clipboard
972 format) to LF endings as used internally by Emacs. */
974 dst = SDATA (ret);
975 while (1)
977 unsigned char *next;
978 /* copy next line or remaining bytes excluding '\0' */
979 next = _memccpy (dst, src, '\r', nbytes);
980 if (next)
982 /* copied one line ending with '\r' */
983 int copied = next - dst;
984 nbytes -= copied;
985 dst += copied;
986 src += copied;
987 if (*src == '\n')
988 dst--; /* overwrite '\r' with '\n' */
990 else
991 /* copied remaining partial line -> now finished */
992 break;
995 Vlast_coding_system_used = Qraw_text;
998 GlobalUnlock (htext);
1001 closeclip:
1002 CloseClipboard ();
1004 done:
1005 unblock_input ();
1007 return (ret);
1010 /* Support checking for a clipboard selection. */
1012 DEFUN ("w32-selection-exists-p", Fw32_selection_exists_p, Sw32_selection_exists_p,
1013 0, 2, 0,
1014 doc: /* Whether there is an owner for the given X selection.
1015 SELECTION should be the name of the selection in question, typically
1016 one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'. (X expects
1017 these literal upper-case names.) The symbol nil is the same as
1018 `PRIMARY', and t is the same as `SECONDARY'.
1020 TERMINAL should be a terminal object or a frame specifying the X
1021 server to query. If omitted or nil, that stands for the selected
1022 frame's display, or the first available X display. */)
1023 (Lisp_Object selection, Lisp_Object terminal)
1025 CHECK_SYMBOL (selection);
1027 /* Return nil for PRIMARY and SECONDARY selections; for CLIPBOARD, check
1028 if the clipboard currently has valid text format contents. */
1030 if (EQ (selection, QCLIPBOARD))
1032 Lisp_Object val = Qnil;
1034 setup_config ();
1036 if (OpenClipboard (NULL))
1038 UINT format = 0;
1039 while ((format = EnumClipboardFormats (format)))
1040 /* Check CF_TEXT in addition to cfg_clipboard_type,
1041 because we can fall back on that if CF_UNICODETEXT is
1042 not available. Actually a check for CF_TEXT only
1043 should be enough. */
1044 if (format == cfg_clipboard_type || format == CF_TEXT)
1046 val = Qt;
1047 break;
1049 CloseClipboard ();
1051 return val;
1053 return Qnil;
1056 /* One-time init. Called in the un-dumped Emacs, but not in the
1057 dumped version. */
1059 void
1060 syms_of_w32select (void)
1062 defsubr (&Sw32_set_clipboard_data);
1063 defsubr (&Sw32_get_clipboard_data);
1064 defsubr (&Sw32_selection_exists_p);
1066 DEFVAR_LISP ("selection-coding-system", Vselection_coding_system,
1067 doc: /* Coding system for communicating with other programs.
1069 For MS-Windows and MS-DOS:
1070 When sending or receiving text via selection and clipboard, the text
1071 is encoded or decoded by this coding system. The default value is
1072 the current system default encoding on 9x/Me, `utf-16le-dos'
1073 \(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS.
1075 For X Windows:
1076 When sending text via selection and clipboard, if the target
1077 data-type matches with the type of this coding system, it is used
1078 for encoding the text. Otherwise (including the case that this
1079 variable is nil), a proper coding system is used as below:
1081 data-type coding system
1082 --------- -------------
1083 UTF8_STRING utf-8
1084 COMPOUND_TEXT compound-text-with-extensions
1085 STRING iso-latin-1
1086 C_STRING no-conversion
1088 When receiving text, if this coding system is non-nil, it is used
1089 for decoding regardless of the data-type. If this is nil, a
1090 proper coding system is used according to the data-type as above.
1092 See also the documentation of the variable `x-select-request-type' how
1093 to control which data-type to request for receiving text.
1095 The default value is nil. */);
1096 /* The actual value is set dynamically in the dumped Emacs, see
1097 below. */
1098 Vselection_coding_system = Qnil;
1100 DEFVAR_LISP ("next-selection-coding-system", Vnext_selection_coding_system,
1101 doc: /* Coding system for the next communication with other programs.
1102 Usually, `selection-coding-system' is used for communicating with
1103 other programs (X Windows clients or MS Windows programs). But, if this
1104 variable is set, it is used for the next communication only.
1105 After the communication, this variable is set to nil. */);
1106 Vnext_selection_coding_system = Qnil;
1108 DEFSYM (QCLIPBOARD, "CLIPBOARD");
1110 cfg_coding_system = Qnil; staticpro (&cfg_coding_system);
1111 current_text = Qnil; staticpro (&current_text);
1112 current_coding_system = Qnil; staticpro (&current_coding_system);
1114 DEFSYM (QUNICODE, "utf-16le-dos");
1115 QANSICP = Qnil; staticpro (&QANSICP);
1116 QOEMCP = Qnil; staticpro (&QOEMCP);
1119 /* One-time init. Called in the dumped Emacs, but not in the
1120 un-dumped version. */
1122 void
1123 globals_of_w32select (void)
1125 DEFAULT_LCID = GetUserDefaultLCID ();
1126 /* Drop the sort order from the LCID, so we can compare this with
1127 CF_LOCALE objects that have the same fix on 9x. */
1128 DEFAULT_LCID = MAKELCID (LANGIDFROMLCID (DEFAULT_LCID), SORT_DEFAULT);
1130 ANSICP = GetACP ();
1131 OEMCP = GetOEMCP ();
1133 QANSICP = coding_from_cp (ANSICP);
1134 QOEMCP = coding_from_cp (OEMCP);
1136 if (os_subtype == OS_NT)
1137 Vselection_coding_system = QUNICODE;
1138 else if (inhibit_window_system)
1139 Vselection_coding_system = QOEMCP;
1140 else
1141 Vselection_coding_system = QANSICP;
1143 clipboard_owner = create_owner ();