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