unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
blob 138fe853c4d9510c349f6d89435459188902a25f 32498 bytes (raw)
name: src/w32select.c 	 # note: path name is non-authoritative(*)

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
 
/* Selection processing for Emacs on the Microsoft Windows API.

Copyright (C) 1993-1994, 2001-2016 Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */

/* Written by Kevin Gallo, Benjamin Riefenstahl */


/*
 * Notes on usage of selection-coding-system and
 * next-selection-coding-system on MS Windows:
 *
 * The selection coding system variables apply only to the version of
 * the clipboard data that is closest in type, i.e. when a 16-bit
 * Unicode coding system is given, they apply to he Unicode clipboard
 * (CF_UNICODETEXT), when a well-known console codepage is given, they
 * apply to the console version of the clipboard data (CF_OEMTEXT),
 * else they apply to the normal 8-bit text clipboard (CF_TEXT).
 *
 * When pasting (getting data from the OS), the clipboard format that
 * matches the {next-}selection-coding-system is retrieved.  If
 * Unicode is requested, but not available, 8-bit text (CF_TEXT) is
 * used.  In all other cases the OS will transparently convert
 * formats, so no other fallback is needed.
 *
 * When copying or cutting (sending data to the OS), the data is
 * announced and stored internally, but only actually rendered on
 * request.  The requestor determines the format provided.  The
 * {next-}selection-coding-system is only used, when its corresponding
 * clipboard type matches the type requested.
 *
 * Scenarios to use the facilities for customizing the selection
 * coding system are:
 *
 *   ;; Generally use KOI8-R instead of the russian MS codepage for
 *   ;; the 8-bit clipboard.
 *   (set-selection-coding-system 'koi8-r-dos)
 *
 * Or
 *
 *   ;; Create a special clipboard copy function that uses codepage
 *   ;; 1253 (Greek) to copy Greek text to a specific non-Unicode
 *   ;; application.
 *   (defun greek-copy (beg end)
 *     (interactive "r")
 *     (set-next-selection-coding-system 'cp1253-dos)
 *     (copy-region-as-kill beg end))
 *   (global-set-key "\C-c\C-c" 'greek-copy)
 */

/*
 * Ideas for further directions:
 *
 * The encoding and decoding routines could be moved to Lisp code
 * similar to how xselect.c does it (using well-known routine names
 * for the delayed rendering).  If the definition of which clipboard
 * types should be supported is also moved to Lisp, functionality
 * could be expanded to CF_HTML, CF_RTF and maybe other types.
 */

#include <config.h>
#include "lisp.h"
#include "w32common.h"	/* os_subtype */
#include "w32term.h"	/* for all of the w32 includes */
#include "keyboard.h"	/* for waiting_for_input */
#include "blockinput.h"
#include "coding.h"

#ifdef CYGWIN
#include <string.h>
#include <stdio.h>
#define _memccpy memccpy
#endif

static HGLOBAL convert_to_handle_as_ascii (void);
static HGLOBAL convert_to_handle_as_coded (Lisp_Object coding_system);
static Lisp_Object render (Lisp_Object oformat);
static Lisp_Object render_locale (void);
static Lisp_Object render_all (Lisp_Object ignore);
static void run_protected (Lisp_Object (*code) (Lisp_Object), Lisp_Object arg);
static Lisp_Object lisp_error_handler (Lisp_Object error);
static LRESULT CALLBACK ALIGN_STACK owner_callback (HWND win, UINT msg,
						    WPARAM wp, LPARAM lp);
static HWND create_owner (void);

static void setup_config (void);
static BOOL WINAPI enum_locale_callback (/*const*/ char* loc_string);
static UINT cp_from_locale (LCID lcid, UINT format);
static Lisp_Object coding_from_cp (UINT codepage);
static Lisp_Object validate_coding_system (Lisp_Object coding_system);
static void setup_windows_coding_system (Lisp_Object coding_system,
					 struct coding_system * coding);

/* Internal pseudo-constants, initialized in globals_of_w32select()
   based on current system parameters. */
static LCID DEFAULT_LCID;
static UINT ANSICP, OEMCP;
static Lisp_Object QANSICP, QOEMCP;

/* A hidden window just for the clipboard management. */
static HWND clipboard_owner;
/* A flag to tell WM_DESTROYCLIPBOARD who is to blame this time (just
   checking GetClipboardOwner() doesn't work, sadly). */
static int modifying_clipboard = 0;

/* Configured transfer parameters, based on the last inspection of
   selection-coding-system.  */
static Lisp_Object cfg_coding_system;
static UINT cfg_codepage;
static LCID cfg_lcid;
static UINT cfg_clipboard_type;

/* The current state for delayed rendering. */
static Lisp_Object current_text;
static Lisp_Object current_coding_system;
static int current_requires_encoding, current_num_nls;
static UINT current_clipboard_type;
static LCID current_lcid;

#if TRACE
#define ONTRACE(stmt) stmt
#else
#define ONTRACE(stmt) /*stmt*/
#endif


/* This function assumes that there is no multibyte character in
   current_text, so we can short-cut encoding.  */

static HGLOBAL
convert_to_handle_as_ascii (void)
{
  HGLOBAL htext = NULL;
  int nbytes;
  int truelen;
  unsigned char *src;
  unsigned char *dst;

  ONTRACE (fprintf (stderr, "convert_to_handle_as_ascii\n"));

  nbytes = SBYTES (current_text) + 1;
  src = SDATA (current_text);

  /* We need to add to the size the number of LF chars where we have
     to insert CR chars (the standard CF_TEXT clipboard format uses
     CRLF line endings, while Emacs uses just LF internally).  */

  truelen = nbytes + current_num_nls;

  if ((htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, truelen)) == NULL)
    return NULL;

  if ((dst = (unsigned char *) GlobalLock (htext)) == NULL)
    {
      GlobalFree (htext);
      return NULL;
    }

  /* convert to CRLF line endings expected by clipboard */
  while (1)
    {
      unsigned char *next;
      /* copy next line or remaining bytes including '\0' */
      next = _memccpy (dst, src, '\n', nbytes);
      if (next)
	{
	  /* copied one line ending with '\n' */
	  int copied = next - dst;
	  nbytes -= copied;
	  src += copied;
	  /* insert '\r' before '\n' */
	  next[-1] = '\r';
	  next[0] = '\n';
	  dst = next + 1;
	}
      else
	/* copied remaining partial line -> now finished */
	break;
    }

  GlobalUnlock (htext);

  return htext;
}

/* This function assumes that there are multibyte or NUL characters in
   current_text, or that we need to construct Unicode.  It runs the
   text through the encoding machinery.  */

static HGLOBAL
convert_to_handle_as_coded (Lisp_Object coding_system)
{
  HGLOBAL htext;
  unsigned char *dst = NULL;
  struct coding_system coding;

  ONTRACE (fprintf (stderr, "convert_to_handle_as_coded: %s\n",
		    SDATA (SYMBOL_NAME (coding_system))));

  setup_windows_coding_system (coding_system, &coding);
  coding.dst_bytes = SBYTES (current_text) * 2;
  coding.destination = xmalloc (coding.dst_bytes);
  encode_coding_object (&coding, current_text, 0, 0,
			SCHARS (current_text), SBYTES (current_text), Qnil);

  htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, coding.produced +2);

  if (htext != NULL)
    dst = (unsigned char *) GlobalLock (htext);

  if (dst != NULL)
    {
      memcpy (dst, coding.destination, coding.produced);
      /* Add the string terminator.  Add two NULs in case we are
	 producing Unicode here.  */
      dst[coding.produced] = dst[coding.produced+1] = '\0';

      GlobalUnlock (htext);
    }

  xfree (coding.destination);

  return htext;
}

static Lisp_Object
render (Lisp_Object oformat)
{
  HGLOBAL htext = NULL;
  UINT format = XFASTINT (oformat);

  ONTRACE (fprintf (stderr, "render\n"));

  if (NILP (current_text))
    return Qnil;

  if (current_requires_encoding || format == CF_UNICODETEXT)
    {
      if (format == current_clipboard_type)
	htext = convert_to_handle_as_coded (current_coding_system);
      else
	switch (format)
	  {
	  case CF_UNICODETEXT:
	    htext = convert_to_handle_as_coded (QUNICODE);
	    break;
	  case CF_TEXT:
	  case CF_OEMTEXT:
	    {
	      Lisp_Object cs;
	      cs = coding_from_cp (cp_from_locale (current_lcid, format));
	      htext = convert_to_handle_as_coded (cs);
	      break;
	    }
	  }
    }
  else
    htext = convert_to_handle_as_ascii ();

  ONTRACE (fprintf (stderr, "render: htext = 0x%08X\n", (unsigned) htext));

  if (htext == NULL)
    return Qnil;

  if (SetClipboardData (format, htext) == NULL)
    {
      GlobalFree (htext);
      return Qnil;
    }

  return Qt;
}

static Lisp_Object
render_locale (void)
{
  HANDLE hlocale = NULL;
  LCID * lcid_ptr;

  ONTRACE (fprintf (stderr, "render_locale\n"));

  if (current_lcid == LOCALE_NEUTRAL || current_lcid == DEFAULT_LCID)
    return Qt;

  hlocale = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, sizeof (current_lcid));
  if (hlocale == NULL)
    return Qnil;

  if ((lcid_ptr = (LCID *) GlobalLock (hlocale)) == NULL)
    {
      GlobalFree (hlocale);
      return Qnil;
    }

  *lcid_ptr = current_lcid;
  GlobalUnlock (hlocale);

  if (SetClipboardData (CF_LOCALE, hlocale) == NULL)
    {
      GlobalFree (hlocale);
      return Qnil;
    }

  return Qt;
}

/* At the end of the program, we want to ensure that our clipboard
   data survives us.  This code will do that.  */

static Lisp_Object
render_all (Lisp_Object ignore)
{
  ONTRACE (fprintf (stderr, "render_all\n"));

  /* According to the docs we should not call OpenClipboard() here,
     but testing on W2K and working code in other projects shows that
     it is actually necessary.  */

  OpenClipboard (NULL);

  /* There is no useful means to report errors here, there are none
     expected anyway, and even if there were errors, they wouldn't do
     any harm.  So we just go ahead and do what has to be done without
     bothering with error handling.  */

  ++modifying_clipboard;
  EmptyClipboard ();
  --modifying_clipboard;

  /* For text formats that we don't render here, the OS can use its
     own translation rules instead, so we don't really need to offer
     everything.  To minimize memory consumption we cover three
     possible situations based on our primary format as detected from
     selection-coding-system (see setup_config()):

     - Post CF_TEXT only.  Let the OS convert to CF_OEMTEXT and the OS
       (on NT) or the application (on 9x/Me) convert to
       CF_UNICODETEXT.

     - Post CF_OEMTEXT only.  Similar automatic conversions happen as
       for CF_TEXT.

     - Post CF_UNICODETEXT + CF_TEXT.  9x itself ignores
       CF_UNICODETEXT, even though some applications can still handle
       it.

       Note 1: We render the less capable CF_TEXT *before* the more
       capable CF_UNICODETEXT, to prevent clobbering through automatic
       conversions, just in case.

       Note 2: We could check os_subtype here and only render the
       additional CF_TEXT on 9x/Me.  But OTOH with
       current_clipboard_type == CF_UNICODETEXT we don't involve the
       automatic conversions anywhere else, so to get consistent
       results, we probably don't want to rely on it here either.  */

  render_locale ();

  if (current_clipboard_type == CF_UNICODETEXT)
    render (make_number (CF_TEXT));
  render (make_number (current_clipboard_type));

  CloseClipboard ();

  return Qnil;
}

static void
run_protected (Lisp_Object (*code) (Lisp_Object), Lisp_Object arg)
{
  /* FIXME: This works but it doesn't feel right.  Too much fiddling
     with global variables and calling strange looking functions.  Is
     this really the right way to run Lisp callbacks?  */

  int owfi;

  block_input ();

  /* Fsignal calls emacs_abort () if it sees that waiting_for_input is
     set.  */
  owfi = waiting_for_input;
  waiting_for_input = 0;

  internal_condition_case_1 (code, arg, Qt, lisp_error_handler);

  waiting_for_input = owfi;

  unblock_input ();
}

static Lisp_Object
lisp_error_handler (Lisp_Object error)
{
  Vsignaling_function = Qnil;
  cmd_error_internal (error, "Error in delayed clipboard rendering: ");
  Vinhibit_quit = Qt;
  return Qt;
}


static LRESULT CALLBACK ALIGN_STACK
owner_callback (HWND win, UINT msg, WPARAM wp, LPARAM lp)
{
  switch (msg)
    {
    case WM_RENDERFORMAT:
      ONTRACE (fprintf (stderr, "WM_RENDERFORMAT\n"));
      run_protected (render, make_number (wp));
      return 0;

    case WM_RENDERALLFORMATS:
      ONTRACE (fprintf (stderr, "WM_RENDERALLFORMATS\n"));
      run_protected (render_all, Qnil);
      return 0;

    case WM_DESTROYCLIPBOARD:
      if (!modifying_clipboard)
	{
	  ONTRACE (fprintf (stderr, "WM_DESTROYCLIPBOARD (other)\n"));
	  current_text = Qnil;
	  current_coding_system = Qnil;
	}
      else
	{
	  ONTRACE (fprintf (stderr, "WM_DESTROYCLIPBOARD (self)\n"));
	}
      return 0;

    case WM_DESTROY:
      if (win == clipboard_owner)
	clipboard_owner = NULL;
      break;
    }

  return DefWindowProc (win, msg, wp, lp);
}

static HWND
create_owner (void)
{
  static const char CLASSNAME[] = "Emacs Clipboard";
  WNDCLASS wc;

  memset (&wc, 0, sizeof (wc));
  wc.lpszClassName = CLASSNAME;
  wc.lpfnWndProc = owner_callback;
  RegisterClass (&wc);

  return CreateWindow (CLASSNAME, CLASSNAME, 0, 0, 0, 0, 0, NULL, NULL,
		       NULL, NULL);
}

/* Called on exit by term_ntproc() in w32.c */

void
term_w32select (void)
{
  /* This is needed to trigger WM_RENDERALLFORMATS. */
  if (clipboard_owner != NULL)
    {
      DestroyWindow (clipboard_owner);
      clipboard_owner = NULL;
    }
}

static void
setup_config (void)
{
  const char *coding_name;
  const char *cp;
  char *end;
  int slen;
  Lisp_Object coding_system;
  Lisp_Object dos_coding_system;

  CHECK_SYMBOL (Vselection_coding_system);

  coding_system = NILP (Vnext_selection_coding_system) ?
    Vselection_coding_system : Vnext_selection_coding_system;

  dos_coding_system = validate_coding_system (coding_system);
  if (NILP (dos_coding_system))
    Fsignal (Qerror,
	     list2 (build_string ("Coding system is invalid or doesn't have "
				  "an eol variant for dos line ends"),
		    coding_system));

  /* Check if we have it cached */
  if (!NILP (cfg_coding_system)
      && EQ (cfg_coding_system, dos_coding_system))
    return;
  cfg_coding_system = dos_coding_system;

  /* Set some sensible fallbacks */
  cfg_codepage = ANSICP;
  cfg_lcid = LOCALE_NEUTRAL;
  cfg_clipboard_type = CF_TEXT;

  /* Interpret the coding system symbol name */
  coding_name = SSDATA (SYMBOL_NAME (cfg_coding_system));

  /* "(.*-)?utf-16.*" -> CF_UNICODETEXT */
  cp = strstr (coding_name, "utf-16");
  if (cp != NULL && (cp == coding_name || cp[-1] == '-'))
    {
      cfg_clipboard_type = CF_UNICODETEXT;
      return;
    }

  /* "cp[0-9]+.*" or "windows-[0-9]+.*" -> CF_TEXT or CF_OEMTEXT */
  slen = strlen (coding_name);
  if (slen >= 4 && coding_name[0] == 'c' && coding_name[1] == 'p')
    cp = coding_name + 2;
  else if (slen >= 10 && memcmp (coding_name, "windows-", 8) == 0)
    cp = coding_name + 8;
  else
    return;

  end = (char*)cp;
  cfg_codepage = strtol (cp, &end, 10);

  /* Error return from strtol() or number of digits < 2 -> Restore the
     default and drop it. */
  if (cfg_codepage == 0 || (end-cp) < 2 )
    {
      cfg_codepage = ANSICP;
      return;
    }

  /* Is it the currently active system default? */
  if (cfg_codepage == ANSICP)
    {
      /* cfg_clipboard_type = CF_TEXT; */
      return;
    }
  if (cfg_codepage == OEMCP)
    {
      cfg_clipboard_type = CF_OEMTEXT;
      return;
    }

  /* Else determine a suitable locale the hard way. */
  EnumSystemLocales (enum_locale_callback, LCID_INSTALLED);
}

static BOOL WINAPI
enum_locale_callback (/*const*/ char* loc_string)
{
  LCID lcid;
  UINT codepage;

  lcid = strtoul (loc_string, NULL, 16);

  /* Is the wanted codepage the "ANSI" codepage for this locale? */
  codepage = cp_from_locale (lcid, CF_TEXT);
  if (codepage == cfg_codepage)
    {
      cfg_lcid = lcid;
      cfg_clipboard_type = CF_TEXT;
      return FALSE; /* Stop enumeration */
    }

  /* Is the wanted codepage the OEM codepage for this locale? */
  codepage = cp_from_locale (lcid, CF_OEMTEXT);
  if (codepage == cfg_codepage)
    {
      cfg_lcid = lcid;
      cfg_clipboard_type = CF_OEMTEXT;
      return FALSE; /* Stop enumeration */
    }

  return TRUE; /* Continue enumeration */
}

static UINT
cp_from_locale (LCID lcid, UINT format)
{
  char buffer[20] = "";
  UINT variant, cp;

  variant =
    format == CF_TEXT ? LOCALE_IDEFAULTANSICODEPAGE : LOCALE_IDEFAULTCODEPAGE;

  GetLocaleInfo (lcid, variant, buffer, sizeof (buffer));
  cp = strtoul (buffer, NULL, 10);

  if (cp == CP_ACP)
    return ANSICP;
  else if (cp == CP_OEMCP)
    return OEMCP;
  else
    return cp;
}

static Lisp_Object
coding_from_cp (UINT codepage)
{
  char buffer[30];
  sprintf (buffer, "cp%d-dos", (int) codepage);
  return intern (buffer);
  /* We don't need to check that this coding system actually exists
     right here, because that is done later for all coding systems
     used, regardless of where they originate.  */
}

static Lisp_Object
validate_coding_system (Lisp_Object coding_system)
{
  Lisp_Object eol_type;

  /* Make sure the input is valid. */
  if (NILP (Fcoding_system_p (coding_system)))
    return Qnil;

  /* Make sure we use a DOS coding system as mandated by the system
     specs. */
  eol_type = Fcoding_system_eol_type (coding_system);

  /* Already a DOS coding system? */
  if (EQ (eol_type, make_number (1)))
    return coding_system;

  /* Get EOL_TYPE vector of the base of CODING_SYSTEM.  */
  if (!VECTORP (eol_type))
    {
      eol_type = Fcoding_system_eol_type (Fcoding_system_base (coding_system));
      if (!VECTORP (eol_type))
	return Qnil;
    }

  return AREF (eol_type, 1);
}

static void
setup_windows_coding_system (Lisp_Object coding_system,
			     struct coding_system * coding)
{
  memset (coding, 0, sizeof (*coding));
  setup_coding_system (coding_system, coding);

  /* Unset CODING_ANNOTATE_COMPOSITION_MASK.  Previous code had
     comments about crashes in encode_coding_iso2022 trying to
     dereference a null pointer when composition was on.  Selection
     data should not contain any composition sequence on Windows.

     CODING_ANNOTATION_MASK also includes
     CODING_ANNOTATE_DIRECTION_MASK and CODING_ANNOTATE_CHARSET_MASK,
     which both apply to ISO6429 only.  We don't know if these really
     need to be unset on Windows, but it probably doesn't hurt
     either.  */
  coding->common_flags &= ~CODING_ANNOTATION_MASK;
  coding->mode |= CODING_MODE_LAST_BLOCK | CODING_MODE_SAFE_ENCODING;
}



DEFUN ("w32-set-clipboard-data", Fw32_set_clipboard_data,
       Sw32_set_clipboard_data, 1, 2, 0,
       doc: /* This sets the clipboard data to the given text.  */)
  (Lisp_Object string, Lisp_Object ignored)
{
  BOOL ok = TRUE;
  int nbytes;
  unsigned char *src;
  unsigned char *dst;
  unsigned char *end;

  /* This parameter used to be the current frame, but we don't use
     that any more. */
  (void) ignored;

  CHECK_STRING (string);

  setup_config ();

  current_text = string;
  current_coding_system = cfg_coding_system;
  current_clipboard_type = cfg_clipboard_type;
  current_lcid = cfg_lcid;
  current_num_nls = 0;
  current_requires_encoding = 0;

  block_input ();

  /* Check for non-ASCII characters.  While we are at it, count the
     number of LFs, so we know how many CRs we will have to add later
     (just in the case where we can use our internal ASCII rendering,
     see code and comment in convert_to_handle_as_ascii() above).  */
  nbytes = SBYTES (string);
  src = SDATA (string);

  for (dst = src, end = src+nbytes; dst < end; dst++)
    {
      if (*dst == '\n')
	current_num_nls++;
      else if (*dst >= 0x80 || *dst == 0)
	{
	  current_requires_encoding = 1;
	  break;
	}
    }

  if (!current_requires_encoding)
    {
      /* If all we have is ASCII we don't need to pretend we offer
	 anything fancy. */
      current_coding_system = Qraw_text;
      current_clipboard_type = CF_TEXT;
      current_lcid = LOCALE_NEUTRAL;
    }

  if (!OpenClipboard (clipboard_owner))
    goto error;

  ++modifying_clipboard;
  ok = EmptyClipboard ();
  --modifying_clipboard;

  /* If we have something non-ASCII we may want to set a locale.  We
     do that directly (non-delayed), as it's just a small bit.  */
  if (ok)
    ok = !NILP (render_locale ());

  if (ok)
    {
      if (clipboard_owner == NULL)
	{
	  /* If for some reason we don't have a clipboard_owner, we
	     just set the text format as chosen by the configuration
	     and than forget about the whole thing.  */
	  ok = !NILP (render (make_number (current_clipboard_type)));
	  current_text = Qnil;
	  current_coding_system = Qnil;
	}
      else
	{
	  /* Advertise all supported formats so that whatever the
	     requestor chooses, only one encoding step needs to be
	     made.  This is intentionally different from what we do in
	     the handler for WM_RENDERALLFORMATS.  */
	  SetClipboardData (CF_UNICODETEXT, NULL);
	  SetClipboardData (CF_TEXT, NULL);
	  SetClipboardData (CF_OEMTEXT, NULL);
	}
    }

  CloseClipboard ();

  /* With delayed rendering we haven't really "used" this coding
     system yet, and it's even unclear if we ever will.  But this is a
     way to tell the upper level what we *would* use under ideal
     circumstances.

     We don't signal the actually used coding-system later when we
     finally render, because that can happen at any time and we don't
     want to disturb the "foreground" action. */
  if (ok)
    Vlast_coding_system_used = current_coding_system;

  Vnext_selection_coding_system = Qnil;

  if (ok) goto done;

 error:

  ok = FALSE;
  current_text = Qnil;
  current_coding_system = Qnil;

 done:
  unblock_input ();

  return (ok ? string : Qnil);
}


DEFUN ("w32-get-clipboard-data", Fw32_get_clipboard_data,
       Sw32_get_clipboard_data, 0, 1, 0,
       doc: /* This gets the clipboard data in text format.  */)
  (Lisp_Object ignored)
{
  HGLOBAL htext;
  Lisp_Object ret = Qnil;
  UINT actual_clipboard_type;
  int use_configured_coding_system = 1;

  /* This parameter used to be the current frame, but we don't use
     that any more. */
  (void) ignored;

  /* Don't pass our own text from the clipboard (which might be
     troublesome if the killed text includes null characters).  */
  if (!NILP (current_text))
    return ret;

  setup_config ();
  actual_clipboard_type = cfg_clipboard_type;

  block_input ();

  if (!OpenClipboard (clipboard_owner))
    goto done;

  if ((htext = GetClipboardData (actual_clipboard_type)) == NULL)
    {
      /* If we want CF_UNICODETEXT but can't get it, the current
	 coding system is useless.  OTOH we can still try and decode
	 CF_TEXT based on the locale that the system gives us and that
	 we get down below.  */
      if (actual_clipboard_type == CF_UNICODETEXT)
	{
	  htext = GetClipboardData (CF_TEXT);
	  if (htext != NULL)
	    {
	      actual_clipboard_type = CF_TEXT;
	      use_configured_coding_system = 0;
	    }
	}
    }
  if (htext == NULL)
    goto closeclip;

  {
    unsigned char *src;
    unsigned char *dst;
    int nbytes;
    int truelen;
    int require_decoding = 0;

    if ((src = (unsigned char *) GlobalLock (htext)) == NULL)
      goto closeclip;

    /* If the clipboard data contains any non-ascii code, we need to
       decode it with a coding system.  */
    if (actual_clipboard_type == CF_UNICODETEXT)
      {
	nbytes = lstrlenW ((WCHAR *)src) * 2;
	require_decoding = 1;
      }
    else
      {
	int i;

	nbytes = strlen ((char *)src);

	for (i = 0; i < nbytes; i++)
	  {
	    if (src[i] >= 0x80)
	      {
		require_decoding = 1;
		break;
	      }
	  }
      }

    if (require_decoding)
      {
	struct coding_system coding;
	Lisp_Object coding_system = Qnil;
	Lisp_Object dos_coding_system;

	/* `next-selection-coding-system' should override everything,
	   even when the locale passed by the system disagrees.  The
	   only exception is when `next-selection-coding-system'
	   requested CF_UNICODETEXT and we couldn't get that. */
	if (use_configured_coding_system
	    && !NILP (Vnext_selection_coding_system))
	    coding_system = Vnext_selection_coding_system;

	/* If we have CF_TEXT or CF_OEMTEXT, we want to check out
	   CF_LOCALE, too. */
	else if (actual_clipboard_type != CF_UNICODETEXT)
	  {
	    HGLOBAL hlocale;
	    LCID lcid = DEFAULT_LCID;
	    UINT cp;

	    /* Documentation says that the OS always generates
	       CF_LOCALE info automatically, so the locale handle
	       should always be present.  Fact is that this is not
	       always true on 9x ;-(.  */
	    hlocale = GetClipboardData (CF_LOCALE);
	    if (hlocale != NULL)
	      {
		const LCID * lcid_ptr;
		lcid_ptr = (const LCID *) GlobalLock (hlocale);
		if (lcid_ptr != NULL)
		  {
		    lcid = *lcid_ptr;
		    GlobalUnlock (hlocale);
		  }

		/* 9x has garbage as the sort order (to be exact there
		   is another instance of the language id in the upper
		   word).  We don't care about sort order anyway, so
		   we just filter out the unneeded mis-information to
		   avoid irritations. */
		lcid = MAKELCID (LANGIDFROMLCID (lcid), SORT_DEFAULT);
	      }

	    /* If we are using fallback from CF_UNICODETEXT, we can't
	       use the configured coding system.  Also we don't want
	       to use it, if the system has supplied us with a locale
	       and it is not just the system default. */
	    if (!use_configured_coding_system || lcid != DEFAULT_LCID)
	      {
		cp = cp_from_locale (lcid, actual_clipboard_type);
		/* If it's just our current standard setting anyway,
		   use the coding system that the user has selected.
		   Otherwise create a new spec to match the locale
		   that was specified by the other side or the
		   system.  */
		if (!use_configured_coding_system || cp != cfg_codepage)
		  coding_system = coding_from_cp (cp);
	      }
	  }

	if (NILP (coding_system))
	  coding_system = Vselection_coding_system;
	Vnext_selection_coding_system = Qnil;

	dos_coding_system = validate_coding_system (coding_system);
	if (!NILP (dos_coding_system))
	  {
	    setup_windows_coding_system (dos_coding_system, &coding);
	    coding.source = src;
	    decode_coding_object (&coding, Qnil, 0, 0, nbytes, nbytes, Qt);
	    ret = coding.dst_object;

	    Vlast_coding_system_used = CODING_ID_NAME (coding.id);
	  }
      }
    else
      {
	/* FIXME: We may want to repeat the code in this branch for
	   the Unicode case. */

	/* Need to know final size after CR chars are removed because
	   we can't change the string size manually, and doing an
	   extra copy is silly.  We only remove CR when it appears as
	   part of CRLF.  */

	truelen = nbytes;
	dst = src;
	/* avoid using strchr because it recomputes the length everytime */
	while ((dst = memchr (dst, '\r', nbytes - (dst - src))) != NULL)
	  {
	    if (dst[1] == '\n')	/* safe because of trailing '\0' */
	      truelen--;
	    dst++;
	  }

	ret = make_uninit_string (truelen);

	/* Convert CRLF line endings (the standard CF_TEXT clipboard
	   format) to LF endings as used internally by Emacs.  */

	dst = SDATA (ret);
	while (1)
	  {
	    unsigned char *next;
	    /* copy next line or remaining bytes excluding '\0' */
	    next = _memccpy (dst, src, '\r', nbytes);
	    if (next)
	      {
		/* copied one line ending with '\r' */
		int copied = next - dst;
		nbytes -= copied;
		dst += copied;
		src += copied;
		if (*src == '\n')
		  dst--;	/* overwrite '\r' with '\n' */
	      }
	    else
	      /* copied remaining partial line -> now finished */
	      break;
	  }

	Vlast_coding_system_used = Qraw_text;
      }

    GlobalUnlock (htext);
  }

 closeclip:
  CloseClipboard ();

 done:
  unblock_input ();

  return (ret);
}

/* Support checking for a clipboard selection.  */

DEFUN ("w32-selection-exists-p", Fw32_selection_exists_p, Sw32_selection_exists_p,
       0, 2, 0,
       doc: /* Whether there is an owner for the given X selection.
SELECTION should be the name of the selection in question, typically
one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.  (X expects
these literal upper-case names.)  The symbol nil is the same as
`PRIMARY', and t is the same as `SECONDARY'.

TERMINAL should be a terminal object or a frame specifying the X
server to query.  If omitted or nil, that stands for the selected
frame's display, or the first available X display.  */)
  (Lisp_Object selection, Lisp_Object terminal)
{
  CHECK_SYMBOL (selection);

  /* Return nil for PRIMARY and SECONDARY selections; for CLIPBOARD, check
     if the clipboard currently has valid text format contents.  */

  if (EQ (selection, QCLIPBOARD))
    {
      Lisp_Object val = Qnil;

      setup_config ();

      if (OpenClipboard (NULL))
	{
	  UINT format = 0;
	  while ((format = EnumClipboardFormats (format)))
	    /* Check CF_TEXT in addition to cfg_clipboard_type,
	       because we can fall back on that if CF_UNICODETEXT is
	       not available.  Actually a check for CF_TEXT only
	       should be enough.  */
	    if (format == cfg_clipboard_type || format == CF_TEXT)
	      {
		val = Qt;
		break;
	      }
	  CloseClipboard ();
	}
      return val;
    }
  return Qnil;
}

/* One-time init.  Called in the un-dumped Emacs, but not in the
   dumped version.  */

void
syms_of_w32select (void)
{
  defsubr (&Sw32_set_clipboard_data);
  defsubr (&Sw32_get_clipboard_data);
  defsubr (&Sw32_selection_exists_p);

  DEFVAR_LISP ("selection-coding-system", Vselection_coding_system,
	       doc: /* Coding system for communicating with other programs.

For MS-Windows and MS-DOS:
When sending or receiving text via selection and clipboard, the text
is encoded or decoded by this coding system.  The default value is
the current system default encoding on 9x/Me, `utf-16le-dos'
\(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS.

For X Windows:
When sending text via selection and clipboard, if the target
data-type matches with the type of this coding system, it is used
for encoding the text.  Otherwise (including the case that this
variable is nil), a proper coding system is used as below:

data-type	coding system
---------	-------------
UTF8_STRING	utf-8
COMPOUND_TEXT	compound-text-with-extensions
STRING		iso-latin-1
C_STRING	no-conversion

When receiving text, if this coding system is non-nil, it is used
for decoding regardless of the data-type.  If this is nil, a
proper coding system is used according to the data-type as above.

See also the documentation of the variable `x-select-request-type' how
to control which data-type to request for receiving text.

The default value is nil.  */);
  /* The actual value is set dynamically in the dumped Emacs, see
     below. */
  Vselection_coding_system = Qnil;

  DEFVAR_LISP ("next-selection-coding-system", Vnext_selection_coding_system,
	       doc: /* Coding system for the next communication with other programs.
Usually, `selection-coding-system' is used for communicating with
other programs (X Windows clients or MS Windows programs).  But, if this
variable is set, it is used for the next communication only.
After the communication, this variable is set to nil.  */);
  Vnext_selection_coding_system = Qnil;

  DEFSYM (QCLIPBOARD, "CLIPBOARD");

  cfg_coding_system = Qnil;     staticpro (&cfg_coding_system);
  current_text = Qnil;		staticpro (&current_text);
  current_coding_system = Qnil; staticpro (&current_coding_system);

  DEFSYM (QUNICODE, "utf-16le-dos");
  QANSICP = Qnil; staticpro (&QANSICP);
  QOEMCP = Qnil;  staticpro (&QOEMCP);
}

/* One-time init.  Called in the dumped Emacs, but not in the
   un-dumped version. */

void
globals_of_w32select (void)
{
  DEFAULT_LCID = GetUserDefaultLCID ();
  /* Drop the sort order from the LCID, so we can compare this with
     CF_LOCALE objects that have the same fix on 9x.  */
  DEFAULT_LCID = MAKELCID (LANGIDFROMLCID (DEFAULT_LCID), SORT_DEFAULT);

  ANSICP = GetACP ();
  OEMCP = GetOEMCP ();

  QANSICP = coding_from_cp (ANSICP);
  QOEMCP = coding_from_cp (OEMCP);

  if (os_subtype == OS_NT)
    Vselection_coding_system = QUNICODE;
  else if (inhibit_window_system)
    Vselection_coding_system = QOEMCP;
  else
    Vselection_coding_system = QANSICP;

  clipboard_owner = create_owner ();
}

debug log:

solving 138fe85 ...
found 138fe85 in https://git.savannah.gnu.org/cgit/emacs.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).