1 /* Selection processing for Emacs on the Microsoft Windows API.
2
3 Copyright (C) 1993-1994, 2001-2023 Free Software Foundation, Inc.
4
5 Author: Kevin Gallo
6 Benjamin Riefenstahl
7
8 This file is part of GNU Emacs.
9
10 GNU Emacs is free software: you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation, either version 3 of the License, or (at
13 your option) any later version.
14
15 GNU Emacs is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
22
23 /*
24 * Notes on usage of selection-coding-system and
25 * next-selection-coding-system on MS Windows:
26 *
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).
33 *
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.
39 *
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.
45 *
46 * Scenarios to use the facilities for customizing the selection
47 * coding system are:
48 *
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)
52 *
53 * Or
54 *
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)
63 */
64
65 /*
66 * Ideas for further directions:
67 *
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.
73 */
74
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 "w32select.h"
80 #include "blockinput.h"
81 #include "coding.h"
82
83 #ifdef CYGWIN
84 #include <string.h>
85 #include <stdio.h>
86 #define _memccpy memccpy
87 #endif
88
89 static HGLOBAL convert_to_handle_as_ascii (void);
90 static HGLOBAL convert_to_handle_as_coded (Lisp_Object coding_system);
91 static Lisp_Object render (Lisp_Object oformat);
92 static Lisp_Object render_locale (void);
93 static Lisp_Object render_all (Lisp_Object ignore);
94 static void run_protected (Lisp_Object (*code) (Lisp_Object), Lisp_Object arg);
95 static Lisp_Object lisp_error_handler (Lisp_Object error);
96 static LRESULT CALLBACK ALIGN_STACK owner_callback (HWND win, UINT msg,
97 WPARAM wp, LPARAM lp);
98 static HWND create_owner (void);
99
100 static void setup_config (void);
101 static BOOL WINAPI enum_locale_callback (/*const*/ char* loc_string);
102 static UINT cp_from_locale (LCID lcid, UINT format);
103 static Lisp_Object coding_from_cp (UINT codepage);
104 static Lisp_Object validate_coding_system (Lisp_Object coding_system);
105 static void setup_windows_coding_system (Lisp_Object coding_system,
106 struct coding_system * coding);
107
108 /* Internal pseudo-constants, initialized in globals_of_w32select()
109 based on current system parameters. */
110 static LCID DEFAULT_LCID;
111 static UINT ANSICP, OEMCP;
112 static Lisp_Object QANSICP, QOEMCP;
113
114 /* A hidden window just for the clipboard management. */
115 static HWND clipboard_owner;
116 /* A flag to tell WM_DESTROYCLIPBOARD who is to blame this time (just
117 checking GetClipboardOwner() doesn't work, sadly). */
118 static int modifying_clipboard = 0;
119
120 /* Configured transfer parameters, based on the last inspection of
121 selection-coding-system. */
122 static Lisp_Object cfg_coding_system;
123 static UINT cfg_codepage;
124 static LCID cfg_lcid;
125 static UINT cfg_clipboard_type;
126
127 /* The current state for delayed rendering. */
128 static Lisp_Object current_text;
129 static Lisp_Object current_coding_system;
130 static int current_requires_encoding, current_num_nls;
131 static UINT current_clipboard_type;
132 static LCID current_lcid;
133
134 #if TRACE
135 #define ONTRACE(stmt) stmt
136 #else
137 #define ONTRACE(stmt) /*stmt*/
138 #endif
139
140
141 /* This function assumes that there is no multibyte character in
142 current_text, so we can short-cut encoding. */
143
144 static HGLOBAL
145 convert_to_handle_as_ascii (void)
146 {
147 HGLOBAL htext = NULL;
148 int nbytes;
149 int truelen;
150 unsigned char *src;
151 unsigned char *dst;
152
153 ONTRACE (fprintf (stderr, "convert_to_handle_as_ascii\n"));
154
155 nbytes = SBYTES (current_text) + 1;
156 src = SDATA (current_text);
157
158 /* We need to add to the size the number of LF chars where we have
159 to insert CR chars (the standard CF_TEXT clipboard format uses
160 CRLF line endings, while Emacs uses just LF internally). */
161
162 truelen = nbytes + current_num_nls;
163
164 if ((htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, truelen)) == NULL)
165 return NULL;
166
167 if ((dst = (unsigned char *) GlobalLock (htext)) == NULL)
168 {
169 GlobalFree (htext);
170 return NULL;
171 }
172
173 /* convert to CRLF line endings expected by clipboard */
174 while (1)
175 {
176 unsigned char *next;
177 /* copy next line or remaining bytes including '\0' */
178 next = _memccpy (dst, src, '\n', nbytes);
179 if (next)
180 {
181 /* copied one line ending with '\n' */
182 int copied = next - dst;
183 nbytes -= copied;
184 src += copied;
185 /* insert '\r' before '\n' */
186 next[-1] = '\r';
187 next[0] = '\n';
188 dst = next + 1;
189 }
190 else
191 /* copied remaining partial line -> now finished */
192 break;
193 }
194
195 GlobalUnlock (htext);
196
197 return htext;
198 }
199
200 /* This function assumes that there are multibyte or NUL characters in
201 current_text, or that we need to construct Unicode. It runs the
202 text through the encoding machinery. */
203
204 static HGLOBAL
205 convert_to_handle_as_coded (Lisp_Object coding_system)
206 {
207 HGLOBAL htext;
208 unsigned char *dst = NULL;
209 struct coding_system coding;
210
211 ONTRACE (fprintf (stderr, "convert_to_handle_as_coded: %s\n",
212 SDATA (SYMBOL_NAME (coding_system))));
213
214 setup_windows_coding_system (coding_system, &coding);
215 coding.dst_bytes = SBYTES (current_text) * 2;
216 coding.destination = xmalloc (coding.dst_bytes);
217 encode_coding_object (&coding, current_text, 0, 0,
218 SCHARS (current_text), SBYTES (current_text), Qnil);
219
220 htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, coding.produced +2);
221
222 if (htext != NULL)
223 dst = (unsigned char *) GlobalLock (htext);
224
225 if (dst != NULL)
226 {
227 memcpy (dst, coding.destination, coding.produced);
228 /* Add the string terminator. Add two NULs in case we are
229 producing Unicode here. */
230 dst[coding.produced] = dst[coding.produced+1] = '\0';
231
232 GlobalUnlock (htext);
233 }
234
235 xfree (coding.destination);
236
237 return htext;
238 }
239
240 static Lisp_Object
241 render (Lisp_Object oformat)
242 {
243 HGLOBAL htext = NULL;
244 UINT format = XFIXNAT (oformat);
245
246 ONTRACE (fprintf (stderr, "render\n"));
247
248 if (NILP (current_text))
249 return Qnil;
250
251 if (current_requires_encoding || format == CF_UNICODETEXT)
252 {
253 if (format == current_clipboard_type)
254 htext = convert_to_handle_as_coded (current_coding_system);
255 else
256 switch (format)
257 {
258 case CF_UNICODETEXT:
259 htext = convert_to_handle_as_coded (Qutf_16le_dos);
260 break;
261 case CF_TEXT:
262 case CF_OEMTEXT:
263 {
264 Lisp_Object cs;
265 cs = coding_from_cp (cp_from_locale (current_lcid, format));
266 htext = convert_to_handle_as_coded (cs);
267 break;
268 }
269 }
270 }
271 else
272 htext = convert_to_handle_as_ascii ();
273
274 ONTRACE (fprintf (stderr, "render: htext = 0x%08X\n", (unsigned) htext));
275
276 if (htext == NULL)
277 return Qnil;
278
279 if (SetClipboardData (format, htext) == NULL)
280 {
281 GlobalFree (htext);
282 return Qnil;
283 }
284
285 return Qt;
286 }
287
288 static Lisp_Object
289 render_locale (void)
290 {
291 HANDLE hlocale = NULL;
292 LCID * lcid_ptr;
293
294 ONTRACE (fprintf (stderr, "render_locale\n"));
295
296 if (current_lcid == LOCALE_NEUTRAL || current_lcid == DEFAULT_LCID)
297 return Qt;
298
299 hlocale = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, sizeof (current_lcid));
300 if (hlocale == NULL)
301 return Qnil;
302
303 if ((lcid_ptr = (LCID *) GlobalLock (hlocale)) == NULL)
304 {
305 GlobalFree (hlocale);
306 return Qnil;
307 }
308
309 *lcid_ptr = current_lcid;
310 GlobalUnlock (hlocale);
311
312 if (SetClipboardData (CF_LOCALE, hlocale) == NULL)
313 {
314 GlobalFree (hlocale);
315 return Qnil;
316 }
317
318 return Qt;
319 }
320
321 /* At the end of the program, we want to ensure that our clipboard
322 data survives us. This code will do that. */
323
324 static Lisp_Object
325 render_all (Lisp_Object ignore)
326 {
327 ONTRACE (fprintf (stderr, "render_all\n"));
328
329 /* According to the docs we should not call OpenClipboard() here,
330 but testing on W2K and working code in other projects shows that
331 it is actually necessary. */
332
333 OpenClipboard (NULL);
334
335 /* There is no useful means to report errors here, there are none
336 expected anyway, and even if there were errors, they wouldn't do
337 any harm. So we just go ahead and do what has to be done without
338 bothering with error handling. */
339
340 ++modifying_clipboard;
341 EmptyClipboard ();
342 --modifying_clipboard;
343
344 /* For text formats that we don't render here, the OS can use its
345 own translation rules instead, so we don't really need to offer
346 everything. To minimize memory consumption we cover three
347 possible situations based on our primary format as detected from
348 selection-coding-system (see setup_config()):
349
350 - Post CF_TEXT only. Let the OS convert to CF_OEMTEXT and the OS
351 (on NT) or the application (on 9x/Me) convert to
352 CF_UNICODETEXT.
353
354 - Post CF_OEMTEXT only. Similar automatic conversions happen as
355 for CF_TEXT.
356
357 - Post CF_UNICODETEXT + CF_TEXT. 9x itself ignores
358 CF_UNICODETEXT, even though some applications can still handle
359 it.
360
361 Note 1: We render the less capable CF_TEXT *before* the more
362 capable CF_UNICODETEXT, to prevent clobbering through automatic
363 conversions, just in case.
364
365 Note 2: We could check os_subtype here and only render the
366 additional CF_TEXT on 9x/Me. But OTOH with
367 current_clipboard_type == CF_UNICODETEXT we don't involve the
368 automatic conversions anywhere else, so to get consistent
369 results, we probably don't want to rely on it here either. */
370
371 render_locale ();
372
373 if (current_clipboard_type == CF_UNICODETEXT)
374 render (make_fixnum (CF_TEXT));
375 render (make_fixnum (current_clipboard_type));
376
377 CloseClipboard ();
378
379 return Qnil;
380 }
381
382 static void
383 run_protected (Lisp_Object (*code) (Lisp_Object), Lisp_Object arg)
384 {
385 /* FIXME: This works but it doesn't feel right. Too much fiddling
386 with global variables and calling strange looking functions. Is
387 this really the right way to run Lisp callbacks? */
388
389 int owfi;
390
391 block_input ();
392
393 /* Fsignal calls emacs_abort () if it sees that waiting_for_input is
394 set. */
395 owfi = waiting_for_input;
396 waiting_for_input = 0;
397
398 internal_condition_case_1 (code, arg, Qt, lisp_error_handler);
399
400 waiting_for_input = owfi;
401
402 unblock_input ();
403 }
404
405 static Lisp_Object
406 lisp_error_handler (Lisp_Object error)
407 {
408 Vsignaling_function = Qnil;
409 cmd_error_internal (error, "Error in delayed clipboard rendering: ");
410 Vinhibit_quit = Qt;
411 return Qt;
412 }
413
414
415 static LRESULT CALLBACK ALIGN_STACK
416 owner_callback (HWND win, UINT msg, WPARAM wp, LPARAM lp)
417 {
418 switch (msg)
419 {
420 case WM_RENDERFORMAT:
421 ONTRACE (fprintf (stderr, "WM_RENDERFORMAT\n"));
422 run_protected (render, make_fixnum (wp));
423 return 0;
424
425 case WM_RENDERALLFORMATS:
426 ONTRACE (fprintf (stderr, "WM_RENDERALLFORMATS\n"));
427 run_protected (render_all, Qnil);
428 return 0;
429
430 case WM_DESTROYCLIPBOARD:
431 if (!modifying_clipboard)
432 {
433 ONTRACE (fprintf (stderr, "WM_DESTROYCLIPBOARD (other)\n"));
434 current_text = Qnil;
435 current_coding_system = Qnil;
436 }
437 else
438 {
439 ONTRACE (fprintf (stderr, "WM_DESTROYCLIPBOARD (self)\n"));
440 }
441 return 0;
442
443 case WM_DESTROY:
444 if (win == clipboard_owner)
445 clipboard_owner = NULL;
446 break;
447 }
448
449 return DefWindowProc (win, msg, wp, lp);
450 }
451
452 static HWND
453 create_owner (void)
454 {
455 static const char CLASSNAME[] = "Emacs Clipboard";
456 WNDCLASS wc;
457
458 memset (&wc, 0, sizeof (wc));
459 wc.lpszClassName = CLASSNAME;
460 wc.lpfnWndProc = owner_callback;
461 RegisterClass (&wc);
462
463 return CreateWindow (CLASSNAME, CLASSNAME, 0, 0, 0, 0, 0, NULL, NULL,
464 NULL, NULL);
465 }
466
467 /* Called on exit by term_ntproc() in w32.c */
468
469 void
470 term_w32select (void)
471 {
472 /* This is needed to trigger WM_RENDERALLFORMATS. */
473 if (clipboard_owner != NULL)
474 {
475 DestroyWindow (clipboard_owner);
476 clipboard_owner = NULL;
477 }
478 }
479
480 static void
481 setup_config (void)
482 {
483 const char *coding_name;
484 const char *cp;
485 char *end;
486 int slen;
487 Lisp_Object coding_system;
488 Lisp_Object dos_coding_system;
489
490 CHECK_SYMBOL (Vselection_coding_system);
491
492 coding_system = NILP (Vnext_selection_coding_system) ?
493 Vselection_coding_system : Vnext_selection_coding_system;
494
495 dos_coding_system = validate_coding_system (coding_system);
496 if (NILP (dos_coding_system))
497 Fsignal (Qerror,
498 list2 (build_string ("Coding system is invalid or doesn't have "
499 "an eol variant for dos line ends"),
500 coding_system));
501
502 /* Check if we have it cached */
503 if (!NILP (cfg_coding_system)
504 && EQ (cfg_coding_system, dos_coding_system))
505 return;
506 cfg_coding_system = dos_coding_system;
507
508 /* Set some sensible fallbacks */
509 cfg_codepage = ANSICP;
510 cfg_lcid = LOCALE_NEUTRAL;
511 cfg_clipboard_type = CF_TEXT;
512
513 /* Interpret the coding system symbol name */
514 coding_name = SSDATA (SYMBOL_NAME (cfg_coding_system));
515
516 /* "(.*-)?utf-16.*" -> CF_UNICODETEXT */
517 cp = strstr (coding_name, "utf-16");
518 if (cp != NULL && (cp == coding_name || cp[-1] == '-'))
519 {
520 cfg_clipboard_type = CF_UNICODETEXT;
521 return;
522 }
523
524 /* "cp[0-9]+.*" or "windows-[0-9]+.*" -> CF_TEXT or CF_OEMTEXT */
525 slen = strlen (coding_name);
526 if (slen >= 4 && coding_name[0] == 'c' && coding_name[1] == 'p')
527 cp = coding_name + 2;
528 else if (slen >= 10 && memcmp (coding_name, "windows-", 8) == 0)
529 cp = coding_name + 8;
530 else
531 return;
532
533 end = (char*)cp;
534 cfg_codepage = strtol (cp, &end, 10);
535
536 /* Error return from strtol() or number of digits < 2 -> Restore the
537 default and drop it. */
538 if (cfg_codepage == 0 || (end-cp) < 2 )
539 {
540 cfg_codepage = ANSICP;
541 return;
542 }
543
544 /* Is it the currently active system default? */
545 if (cfg_codepage == ANSICP)
546 {
547 /* cfg_clipboard_type = CF_TEXT; */
548 return;
549 }
550 if (cfg_codepage == OEMCP)
551 {
552 cfg_clipboard_type = CF_OEMTEXT;
553 return;
554 }
555
556 /* Else determine a suitable locale the hard way. */
557 EnumSystemLocales (enum_locale_callback, LCID_INSTALLED);
558 }
559
560 static BOOL WINAPI
561 enum_locale_callback (/*const*/ char* loc_string)
562 {
563 LCID lcid;
564 UINT codepage;
565
566 lcid = strtoul (loc_string, NULL, 16);
567
568 /* Is the wanted codepage the "ANSI" codepage for this locale? */
569 codepage = cp_from_locale (lcid, CF_TEXT);
570 if (codepage == cfg_codepage)
571 {
572 cfg_lcid = lcid;
573 cfg_clipboard_type = CF_TEXT;
574 return FALSE; /* Stop enumeration */
575 }
576
577 /* Is the wanted codepage the OEM codepage for this locale? */
578 codepage = cp_from_locale (lcid, CF_OEMTEXT);
579 if (codepage == cfg_codepage)
580 {
581 cfg_lcid = lcid;
582 cfg_clipboard_type = CF_OEMTEXT;
583 return FALSE; /* Stop enumeration */
584 }
585
586 return TRUE; /* Continue enumeration */
587 }
588
589 static UINT
590 cp_from_locale (LCID lcid, UINT format)
591 {
592 char buffer[20] = "";
593 UINT variant, cp;
594
595 variant =
596 format == CF_TEXT ? LOCALE_IDEFAULTANSICODEPAGE : LOCALE_IDEFAULTCODEPAGE;
597
598 GetLocaleInfo (lcid, variant, buffer, sizeof (buffer));
599 cp = strtoul (buffer, NULL, 10);
600
601 if (cp == CP_ACP)
602 return ANSICP;
603 else if (cp == CP_OEMCP)
604 return OEMCP;
605 else
606 return cp;
607 }
608
609 static Lisp_Object
610 coding_from_cp (UINT codepage)
611 {
612 char buffer[30];
613 sprintf (buffer, "cp%d-dos", (int) codepage);
614 return intern (buffer);
615 /* We don't need to check that this coding system actually exists
616 right here, because that is done later for all coding systems
617 used, regardless of where they originate. */
618 }
619
620 static Lisp_Object
621 validate_coding_system (Lisp_Object coding_system)
622 {
623 Lisp_Object eol_type;
624
625 /* Make sure the input is valid. */
626 if (NILP (Fcoding_system_p (coding_system)))
627 return Qnil;
628
629 /* Make sure we use a DOS coding system as mandated by the system
630 specs. */
631 eol_type = Fcoding_system_eol_type (coding_system);
632
633 /* Already a DOS coding system? */
634 if (BASE_EQ (eol_type, make_fixnum (1)))
635 return coding_system;
636
637 /* Get EOL_TYPE vector of the base of CODING_SYSTEM. */
638 if (!VECTORP (eol_type))
639 {
640 eol_type = Fcoding_system_eol_type (Fcoding_system_base (coding_system));
641 if (!VECTORP (eol_type))
642 return Qnil;
643 }
644
645 return AREF (eol_type, 1);
646 }
647
648 static void
649 setup_windows_coding_system (Lisp_Object coding_system,
650 struct coding_system * coding)
651 {
652 memset (coding, 0, sizeof (*coding));
653 setup_coding_system (coding_system, coding);
654
655 /* Unset CODING_ANNOTATE_COMPOSITION_MASK. Previous code had
656 comments about crashes in encode_coding_iso2022 trying to
657 dereference a null pointer when composition was on. Selection
658 data should not contain any composition sequence on Windows.
659
660 CODING_ANNOTATION_MASK also includes
661 CODING_ANNOTATE_DIRECTION_MASK and CODING_ANNOTATE_CHARSET_MASK,
662 which both apply to ISO6429 only. We don't know if these really
663 need to be unset on Windows, but it probably doesn't hurt
664 either. */
665 coding->common_flags &= ~CODING_ANNOTATION_MASK;
666 coding->mode |= CODING_MODE_LAST_BLOCK | CODING_MODE_SAFE_ENCODING;
667 }
668
669
670
671 DEFUN ("w32-set-clipboard-data", Fw32_set_clipboard_data,
672 Sw32_set_clipboard_data, 1, 2, 0,
673 doc: /* This sets the clipboard data to the given text. */)
674 (Lisp_Object string, Lisp_Object ignored)
675 {
676 BOOL ok = TRUE;
677 int nbytes;
678 unsigned char *src;
679 unsigned char *dst;
680 unsigned char *end;
681
682 /* This parameter used to be the current frame, but we don't use
683 that any more. */
684 (void) ignored;
685
686 CHECK_STRING (string);
687
688 setup_config ();
689
690 current_text = string;
691 current_coding_system = cfg_coding_system;
692 current_clipboard_type = cfg_clipboard_type;
693 current_lcid = cfg_lcid;
694 current_num_nls = 0;
695 current_requires_encoding = 0;
696
697 block_input ();
698
699 /* Check for non-ASCII characters. While we are at it, count the
700 number of LFs, so we know how many CRs we will have to add later
701 (just in the case where we can use our internal ASCII rendering,
702 see code and comment in convert_to_handle_as_ascii() above). */
703 nbytes = SBYTES (string);
704 src = SDATA (string);
705
706 for (dst = src, end = src+nbytes; dst < end; dst++)
707 {
708 if (*dst == '\n')
709 current_num_nls++;
710 else if (*dst >= 0x80 || *dst == 0)
711 {
712 current_requires_encoding = 1;
713 break;
714 }
715 }
716
717 if (!current_requires_encoding)
718 {
719 /* If all we have is ASCII we don't need to pretend we offer
720 anything fancy. */
721 current_coding_system = Qraw_text;
722 current_clipboard_type = CF_TEXT;
723 current_lcid = LOCALE_NEUTRAL;
724 }
725
726 if (!OpenClipboard (clipboard_owner))
727 goto error;
728
729 ++modifying_clipboard;
730 ok = EmptyClipboard ();
731 --modifying_clipboard;
732
733 /* If we have something non-ASCII we may want to set a locale. We
734 do that directly (non-delayed), as it's just a small bit. */
735 if (ok)
736 ok = !NILP (render_locale ());
737
738 if (ok)
739 {
740 if (clipboard_owner == NULL)
741 {
742 /* If for some reason we don't have a clipboard_owner, we
743 just set the text format as chosen by the configuration
744 and than forget about the whole thing. */
745 ok = !NILP (render (make_fixnum (current_clipboard_type)));
746 current_text = Qnil;
747 current_coding_system = Qnil;
748 }
749 else
750 {
751 /* Advertise all supported formats so that whatever the
752 requestor chooses, only one encoding step needs to be
753 made. This is intentionally different from what we do in
754 the handler for WM_RENDERALLFORMATS. */
755 SetClipboardData (CF_UNICODETEXT, NULL);
756 SetClipboardData (CF_TEXT, NULL);
757 SetClipboardData (CF_OEMTEXT, NULL);
758 }
759 }
760
761 CloseClipboard ();
762
763 /* With delayed rendering we haven't really "used" this coding
764 system yet, and it's even unclear if we ever will. But this is a
765 way to tell the upper level what we *would* use under ideal
766 circumstances.
767
768 We don't signal the actually used coding-system later when we
769 finally render, because that can happen at any time and we don't
770 want to disturb the "foreground" action. */
771 if (ok)
772 Vlast_coding_system_used = current_coding_system;
773
774 Vnext_selection_coding_system = Qnil;
775
776 if (ok) goto done;
777
778 error:
779
780 ok = FALSE;
781 current_text = Qnil;
782 current_coding_system = Qnil;
783
784 done:
785 unblock_input ();
786
787 return (ok ? string : Qnil);
788 }
789
790
791 DEFUN ("w32-get-clipboard-data", Fw32_get_clipboard_data,
792 Sw32_get_clipboard_data, 0, 1, 0,
793 doc: /* This gets the clipboard data in text format. */)
794 (Lisp_Object ignored)
795 {
796 HGLOBAL htext;
797 Lisp_Object ret = Qnil;
798 UINT actual_clipboard_type;
799 int use_configured_coding_system = 1;
800
801 /* This parameter used to be the current frame, but we don't use
802 that any more. */
803 (void) ignored;
804
805 /* Don't pass our own text from the clipboard (which might be
806 troublesome if the killed text includes null characters). */
807 if (!NILP (current_text))
808 return ret;
809
810 setup_config ();
811 actual_clipboard_type = cfg_clipboard_type;
812
813 block_input ();
814
815 if (!OpenClipboard (clipboard_owner))
816 goto done;
817
818 if ((htext = GetClipboardData (actual_clipboard_type)) == NULL)
819 {
820 /* If we want CF_UNICODETEXT but can't get it, the current
821 coding system is useless. OTOH we can still try and decode
822 CF_TEXT based on the locale that the system gives us and that
823 we get down below. */
824 if (actual_clipboard_type == CF_UNICODETEXT)
825 {
826 htext = GetClipboardData (CF_TEXT);
827 if (htext != NULL)
828 {
829 actual_clipboard_type = CF_TEXT;
830 use_configured_coding_system = 0;
831 }
832 }
833 }
834 if (htext == NULL)
835 goto closeclip;
836
837 {
838 unsigned char *src;
839 unsigned char *dst;
840 int nbytes;
841 int truelen;
842 int require_decoding = 0;
843
844 if ((src = (unsigned char *) GlobalLock (htext)) == NULL)
845 goto closeclip;
846
847 /* If the clipboard data contains any non-ascii code, we need to
848 decode it with a coding system. */
849 if (actual_clipboard_type == CF_UNICODETEXT)
850 {
851 nbytes = lstrlenW ((WCHAR *)src) * 2;
852 require_decoding = 1;
853 }
854 else
855 {
856 int i;
857
858 nbytes = strlen ((char *)src);
859
860 for (i = 0; i < nbytes; i++)
861 {
862 if (src[i] >= 0x80)
863 {
864 require_decoding = 1;
865 break;
866 }
867 }
868 }
869
870 if (require_decoding)
871 {
872 struct coding_system coding;
873 Lisp_Object coding_system = Qnil;
874 Lisp_Object dos_coding_system;
875
876 /* `next-selection-coding-system' should override everything,
877 even when the locale passed by the system disagrees. The
878 only exception is when `next-selection-coding-system'
879 requested CF_UNICODETEXT and we couldn't get that. */
880 if (use_configured_coding_system
881 && !NILP (Vnext_selection_coding_system))
882 coding_system = Vnext_selection_coding_system;
883
884 /* If we have CF_TEXT or CF_OEMTEXT, we want to check out
885 CF_LOCALE, too. */
886 else if (actual_clipboard_type != CF_UNICODETEXT)
887 {
888 HGLOBAL hlocale;
889 LCID lcid = DEFAULT_LCID;
890 UINT cp;
891
892 /* Documentation says that the OS always generates
893 CF_LOCALE info automatically, so the locale handle
894 should always be present. Fact is that this is not
895 always true on 9x ;-(. */
896 hlocale = GetClipboardData (CF_LOCALE);
897 if (hlocale != NULL)
898 {
899 const LCID * lcid_ptr;
900 lcid_ptr = (const LCID *) GlobalLock (hlocale);
901 if (lcid_ptr != NULL)
902 {
903 lcid = *lcid_ptr;
904 GlobalUnlock (hlocale);
905 }
906
907 /* 9x has garbage as the sort order (to be exact there
908 is another instance of the language id in the upper
909 word). We don't care about sort order anyway, so
910 we just filter out the unneeded mis-information to
911 avoid irritations. */
912 lcid = MAKELCID (LANGIDFROMLCID (lcid), SORT_DEFAULT);
913 }
914
915 /* If we are using fallback from CF_UNICODETEXT, we can't
916 use the configured coding system. Also we don't want
917 to use it, if the system has supplied us with a locale
918 and it is not just the system default. */
919 if (!use_configured_coding_system || lcid != DEFAULT_LCID)
920 {
921 cp = cp_from_locale (lcid, actual_clipboard_type);
922 /* If it's just our current standard setting anyway,
923 use the coding system that the user has selected.
924 Otherwise create a new spec to match the locale
925 that was specified by the other side or the
926 system. */
927 if (!use_configured_coding_system || cp != cfg_codepage)
928 coding_system = coding_from_cp (cp);
929 }
930 }
931
932 if (NILP (coding_system))
933 coding_system = Vselection_coding_system;
934 Vnext_selection_coding_system = Qnil;
935
936 dos_coding_system = validate_coding_system (coding_system);
937 if (!NILP (dos_coding_system))
938 {
939 setup_windows_coding_system (dos_coding_system, &coding);
940 coding.source = src;
941 decode_coding_object (&coding, Qnil, 0, 0, nbytes, nbytes, Qt);
942 ret = coding.dst_object;
943
944 Vlast_coding_system_used = CODING_ID_NAME (coding.id);
945 }
946 }
947 else
948 {
949 /* FIXME: We may want to repeat the code in this branch for
950 the Unicode case. */
951
952 /* Need to know final size after CR chars are removed because
953 we can't change the string size manually, and doing an
954 extra copy is silly. We only remove CR when it appears as
955 part of CRLF. */
956
957 truelen = nbytes;
958 dst = src;
959 /* avoid using strchr because it recomputes the length every time */
960 while ((dst = memchr (dst, '\r', nbytes - (dst - src))) != NULL)
961 {
962 if (dst[1] == '\n') /* safe because of trailing '\0' */
963 truelen--;
964 dst++;
965 }
966
967 ret = make_uninit_string (truelen);
968
969 /* Convert CRLF line endings (the standard CF_TEXT clipboard
970 format) to LF endings as used internally by Emacs. */
971
972 dst = SDATA (ret);
973 while (1)
974 {
975 unsigned char *next;
976 /* copy next line or remaining bytes excluding '\0' */
977 next = _memccpy (dst, src, '\r', nbytes);
978 if (next)
979 {
980 /* copied one line ending with '\r' */
981 int copied = next - dst;
982 nbytes -= copied;
983 dst += copied;
984 src += copied;
985 if (*src == '\n')
986 dst--; /* overwrite '\r' with '\n' */
987 }
988 else
989 /* copied remaining partial line -> now finished */
990 break;
991 }
992
993 Vlast_coding_system_used = Qraw_text;
994 }
995
996 GlobalUnlock (htext);
997 }
998
999 closeclip:
1000 CloseClipboard ();
1001
1002 done:
1003 unblock_input ();
1004
1005 return (ret);
1006 }
1007
1008 /* Support checking for a clipboard selection. */
1009
1010 DEFUN ("w32-selection-exists-p", Fw32_selection_exists_p, Sw32_selection_exists_p,
1011 0, 2, 0,
1012 doc: /* Whether there is an owner for the given X selection.
1013 SELECTION should be the name of the selection in question, typically
1014 one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'. (X expects
1015 these literal upper-case names.) The symbol nil is the same as
1016 `PRIMARY', and t is the same as `SECONDARY'.
1017
1018 TERMINAL should be a terminal object or a frame specifying the X
1019 server to query. If omitted or nil, that stands for the selected
1020 frame's display, or the first available X display. */)
1021 (Lisp_Object selection, Lisp_Object terminal)
1022 {
1023 CHECK_SYMBOL (selection);
1024
1025 /* Return nil for PRIMARY and SECONDARY selections; for CLIPBOARD, check
1026 if the clipboard currently has valid text format contents. */
1027
1028 if (EQ (selection, QCLIPBOARD))
1029 {
1030 Lisp_Object val = Qnil;
1031
1032 setup_config ();
1033
1034 if (OpenClipboard (NULL))
1035 {
1036 UINT format = 0;
1037 while ((format = EnumClipboardFormats (format)))
1038 /* Check CF_TEXT in addition to cfg_clipboard_type,
1039 because we can fall back on that if CF_UNICODETEXT is
1040 not available. Actually a check for CF_TEXT only
1041 should be enough. */
1042 if (format == cfg_clipboard_type || format == CF_TEXT)
1043 {
1044 val = Qt;
1045 break;
1046 }
1047 CloseClipboard ();
1048 }
1049 return val;
1050 }
1051 return Qnil;
1052 }
1053
1054 /* Support enumerating available clipboard selection formats. */
1055
1056 DEFUN ("w32-selection-targets", Fw32_selection_targets, Sw32_selection_targets,
1057 0, 2, 0,
1058 doc: /* Return a vector of data formats available in the specified SELECTION.
1059 SELECTION should be the name of the selection in question, typically
1060 one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
1061 The symbol nil is the same as `PRIMARY', and t is the same as `SECONDARY'.
1062
1063 TERMINAL should be a terminal object or a frame specifying the X
1064 server to query. If omitted or nil, that stands for the selected
1065 frame's display, or the first available X display.
1066
1067 This function currently ignores TERMINAL, and only returns non-nil
1068 for `CLIPBOARD'. The return value is a vector of symbols, each symbol
1069 representing a data format that is currently available in the clipboard. */)
1070 (Lisp_Object selection, Lisp_Object terminal)
1071 {
1072 /* Xlib-like names for standard Windows clipboard data formats.
1073 They are in upper-case to mimic xselect.c. A couple of the names
1074 were changed to be more like their X counterparts. */
1075 static const char *stdfmt_name[] = {
1076 "UNDEFINED",
1077 "STRING",
1078 "BITMAP",
1079 "METAFILE",
1080 "SYMLINK",
1081 "DIF",
1082 "TIFF",
1083 "OEM_STRING",
1084 "DIB",
1085 "PALETTE",
1086 "PENDATA",
1087 "RIFF",
1088 "WAVE",
1089 "UTF8_STRING",
1090 "ENHMETAFILE",
1091 "FILE_NAMES", /* DND */
1092 "LOCALE", /* not used */
1093 "DIBV5"
1094 };
1095 CHECK_SYMBOL (selection);
1096
1097 /* Return nil for PRIMARY and SECONDARY selections; for CLIPBOARD, check
1098 if the clipboard currently has valid text format contents. */
1099
1100 if (EQ (selection, QCLIPBOARD))
1101 {
1102 Lisp_Object val = Qnil;
1103
1104 setup_config ();
1105
1106 if (OpenClipboard (NULL))
1107 {
1108 UINT format = 0;
1109
1110 /* Count how many formats are available. We ignore the
1111 CF_LOCALE format, and don't put it into the vector we
1112 return, because CF_LOCALE is automatically created by
1113 Windows for any text in the clipboard, so its presence in
1114 the value will simply confuse. */
1115 int fmtcount = 0;
1116 while ((format = EnumClipboardFormats (format)))
1117 if (format != CF_LOCALE)
1118 fmtcount++;
1119
1120 if (fmtcount > 0)
1121 {
1122 int i;
1123
1124 /* We generate a vector because that's what xselect.c
1125 does in this case. */
1126 val = Fmake_vector (make_fixnum (fmtcount), Qnil);
1127 /* Note: when stepping with GDB through this code, the
1128 loop below terminates immediately because
1129 EnumClipboardFormats for some reason returns with
1130 "Thread does not have a clipboard open" error. */
1131 for (i = 0, format = 0;
1132 (format = EnumClipboardFormats (format)) != 0; )
1133 {
1134 const char *name;
1135
1136 if (format == CF_LOCALE)
1137 continue;
1138 else if (format < CF_MAX)
1139 name = stdfmt_name[format];
1140 else
1141 {
1142 char fmt_name[256];
1143
1144 if (!GetClipboardFormatName (format, fmt_name,
1145 sizeof (fmt_name)))
1146 continue;
1147 name = fmt_name;
1148 }
1149 ASET (val, i, intern (name));
1150 i++;
1151 }
1152 }
1153 CloseClipboard ();
1154 }
1155 return val;
1156 }
1157 /* For PRIMARY and SECONDARY we cons the values in w32--get-selection. */
1158 return Qnil;
1159 }
1160
1161 /* One-time init. Called in the un-dumped Emacs, but not in the
1162 dumped version. */
1163
1164 void
1165 syms_of_w32select (void)
1166 {
1167 defsubr (&Sw32_set_clipboard_data);
1168 defsubr (&Sw32_get_clipboard_data);
1169 defsubr (&Sw32_selection_exists_p);
1170 defsubr (&Sw32_selection_targets);
1171
1172 DEFVAR_LISP ("selection-coding-system", Vselection_coding_system,
1173 doc: /* SKIP: real doc in select.el. */);
1174 /* The actual value is set dynamically in the dumped Emacs, see
1175 below. */
1176 Vselection_coding_system = Qnil;
1177
1178 DEFVAR_LISP ("next-selection-coding-system", Vnext_selection_coding_system,
1179 doc: /* SKIP: real doc in select.el. */);
1180 Vnext_selection_coding_system = Qnil;
1181
1182 DEFSYM (QCLIPBOARD, "CLIPBOARD");
1183
1184 cfg_coding_system = Qnil; staticpro (&cfg_coding_system);
1185 current_text = Qnil; staticpro (¤t_text);
1186 current_coding_system = Qnil; staticpro (¤t_coding_system);
1187
1188 DEFSYM (Qutf_16le_dos, "utf-16le-dos");
1189 QANSICP = Qnil; staticpro (&QANSICP);
1190 QOEMCP = Qnil; staticpro (&QOEMCP);
1191 }
1192
1193 /* One-time init. Called in the dumped Emacs, but not in the
1194 un-dumped version. */
1195
1196 void
1197 globals_of_w32select (void)
1198 {
1199 DEFAULT_LCID = GetUserDefaultLCID ();
1200 /* Drop the sort order from the LCID, so we can compare this with
1201 CF_LOCALE objects that have the same fix on 9x. */
1202 DEFAULT_LCID = MAKELCID (LANGIDFROMLCID (DEFAULT_LCID), SORT_DEFAULT);
1203
1204 ANSICP = GetACP ();
1205 OEMCP = GetOEMCP ();
1206
1207 QANSICP = coding_from_cp (ANSICP);
1208 QOEMCP = coding_from_cp (OEMCP);
1209
1210 if (os_subtype == OS_SUBTYPE_NT)
1211 Vselection_coding_system = Qutf_16le_dos;
1212 else if (inhibit_window_system)
1213 Vselection_coding_system = QOEMCP;
1214 else
1215 Vselection_coding_system = QANSICP;
1216
1217 clipboard_owner = create_owner ();
1218 }