Source/TntSystem.pas

   1
   2 {*****************************************************************************}
   3 {                                                                             }
   4 {    Tnt Delphi Unicode Controls                                              }
   5 {      http://www.tntware.com/delphicontrols/unicode/                         }
   6 {        Version: 2.3.0                                                       }
   7 {                                                                             }
   8 {    Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com)       }
   9 {                                                                             }
  10 {*****************************************************************************}
  11
  12 unit TntSystem;
  13
  14 {$INCLUDE TntCompilers.inc}
  15
  16 {*****************************************************************************}
  17 {  Special thanks go to Francisco Leong for originating the design for        }
  18 {    WideString-enabled resourcestrings.                                      }
  19 {*****************************************************************************}
  20
  21 interface
  22
  23 uses
  24   Windows;
  25
  26 // These functions should not be used by Delphi code since conversions are implicit.
  27 {TNT-WARN WideCharToString}
  28 {TNT-WARN WideCharLenToString}
  29 {TNT-WARN WideCharToStrVar}
  30 {TNT-WARN WideCharLenToStrVar}
  31 {TNT-WARN StringToWideChar}
  32
  33 // ................ ANSI TYPES ................
  34 {TNT-WARN Char}
  35 {TNT-WARN PChar}
  36 {TNT-WARN String}
  37
  38 {TNT-WARN CP_ACP} // <-- use DefaultSystemCodePage
  39 function DefaultSystemCodePage: Cardinal; // implicitly used when converting AnsiString <--> WideString.
  40
  41 var
  42   WideCustomLoadResString: function(ResStringRec: PResStringRec; var Value: WideString): Boolean;
  43
  44 {TNT-WARN LoadResString}
  45 function WideLoadResString(ResStringRec: PResStringRec): WideString;
  46 {TNT-WARN ParamCount}
  47 function WideParamCount: Integer;
  48 {TNT-WARN ParamStr}
  49 function WideParamStr(Index: Integer): WideString;
  50
  51 // ......... introduced .........
  52
  53 const
  54   { Each Unicode stream should begin with the code U+FEFF,  }
  55   {   which the standard defines as the *byte order mark*.  }
  56   UNICODE_BOM = WideChar($FEFF);
  57   UNICODE_BOM_SWAPPED = WideChar($FFFE);
  58   UTF8_BOM = AnsiString(#$EF#$BB#$BF);
  59
  60 function WideStringToUTF8(const S: WideString): AnsiString;
  61 function UTF8ToWideString(const S: AnsiString): WideString;
  62
  63 function WideStringToUTF7(const W: WideString): AnsiString;
  64 function UTF7ToWideString(const S: AnsiString): WideString;
  65
  66 function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString;
  67 function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString;
  68
  69 function UCS2ToWideString(const Value: AnsiString): WideString;
  70 function WideStringToUCS2(const Value: WideString): AnsiString;
  71
  72 function CharSetToCodePage(ciCharset: UINT): Cardinal;
  73 function LCIDToCodePage(ALcid: LCID): Cardinal;
  74 function KeyboardCodePage: Cardinal;
  75 function KeyUnicode(CharCode: Word): WideChar;
  76
  77 procedure StrSwapByteOrder(Str: PWideChar);
  78
  79 type
  80   TTntSystemUpdate =
  81     (tsWideResourceStrings,
  82      {$IFNDEF COMPILER_9_UP}tsFixImplicitCodePage, tsFixWideStrConcat, tsFixWideFormat, {$ENDIF}
  83      tsWideExceptions
  84     );
  85   TTntSystemUpdateSet = set of TTntSystemUpdate;
  86
  87 const
  88   AllTntSystemUpdates = [Low(TTntSystemUpdate)..High(TTntSystemUpdate)];
  89
  90 procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates);
  91
  92 implementation
  93
  94 uses
  95   SysUtils, Variants, Forms, TntWindows, TntSysUtils, TntForms;
  96
  97 var
  98   GDefaultSystemCodePage: Cardinal;
  99
 100 function DefaultSystemCodePage: Cardinal;
 101 begin
 102   Result := GDefaultSystemCodePage;
 103 end;
 104
 105 var
 106   IsDebugging: Boolean;
 107
 108 function WideLoadResString(ResStringRec: PResStringRec): WideString;
 109 const
 110   MAX_RES_STRING_SIZE = 4097; { MSDN documents this as the maximum size of a string in table. }
 111 var
 112   Buffer: array [0..MAX_RES_STRING_SIZE] of WideChar; { Buffer leaves room for null terminator. }
 113   PCustom: PAnsiChar;
 114 begin
 115   if Assigned(WideCustomLoadResString) and WideCustomLoadResString(ResStringRec, Result) then
 116     exit; { a custom resourcestring has been loaded. }
 117
 118   if ResStringRec = nil then
 119     Result := ''
 120   else if ResStringRec.Identifier < 64*1024 then
 121     SetString(Result, Buffer,
 122       Tnt_LoadStringW(FindResourceHInstance(ResStringRec.Module^),
 123         ResStringRec.Identifier, Buffer, MAX_RES_STRING_SIZE))
 124   else begin
 125     // custom string pointer
 126     PCustom := PAnsiChar(ResStringRec.Identifier); { I would like to use PWideChar, but this would break legacy code. }
 127     if  (StrLen{TNT-ALLOW StrLen}(PCustom) > Cardinal(Length(UTF8_BOM)))
 128     and CompareMem(PCustom, PAnsiChar(UTF8_BOM), Length(UTF8_BOM)) then
 129       // detected UTF8
 130       Result := UTF8ToWideString(PAnsiChar(PCustom + Length(UTF8_BOM)))
 131     else
 132       // normal
 133       Result := PCustom;
 134   end;
 135 end;
 136
 137 function WideGetParamStr(P: PWideChar; var Param: WideString): PWideChar;
 138 var
 139   i, Len: Integer;
 140   Start, S, Q: PWideChar;
 141 begin
 142   while True do
 143   begin
 144     while (P[0] <> #0) and (P[0] <= ' ') do
 145       Inc(P);
 146     if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
 147   end;
 148   Len := 0;
 149   Start := P;
 150   while P[0] > ' ' do
 151   begin
 152     if P[0] = '"' then
 153     begin
 154       Inc(P);
 155       while (P[0] <> #0) and (P[0] <> '"') do
 156       begin
 157         Q := P + 1;
 158         Inc(Len, Q - P);
 159         P := Q;
 160       end;
 161       if P[0] <> #0 then
 162         Inc(P);
 163     end
 164     else
 165     begin
 166       Q := P + 1;
 167       Inc(Len, Q - P);
 168       P := Q;
 169     end;
 170   end;
 171
 172   SetLength(Param, Len);
 173
 174   P := Start;
 175   S := PWideChar(Param);
 176   i := 0;
 177   while P[0] > ' ' do
 178   begin
 179     if P[0] = '"' then
 180     begin
 181       Inc(P);
 182       while (P[0] <> #0) and (P[0] <> '"') do
 183       begin
 184         Q := P + 1;
 185         while P < Q do
 186         begin
 187           S[i] := P^;
 188           Inc(P);
 189           Inc(i);
 190         end;
 191       end;
 192       if P[0] <> #0 then Inc(P);
 193     end
 194     else
 195     begin
 196       Q := P + 1;
 197       while P < Q do
 198       begin
 199         S[i] := P^;
 200         Inc(P);
 201         Inc(i);
 202       end;
 203     end;
 204   end;
 205
 206   Result := P;
 207 end;
 208
 209 function WideParamCount: Integer;
 210 var
 211   P: PWideChar;
 212   S: WideString;
 213 begin
 214   P := WideGetParamStr(GetCommandLineW, S);
 215   Result := 0;
 216   while True do
 217   begin
 218     P := WideGetParamStr(P, S);
 219     if S = '' then Break;
 220     Inc(Result);
 221   end;
 222 end;
 223
 224 function WideParamStr(Index: Integer): WideString;
 225 var
 226   P: PWideChar;
 227 begin
 228   if Index = 0 then
 229     Result := WideGetModuleFileName(0)
 230   else
 231   begin
 232     P := GetCommandLineW;
 233     while True do
 234     begin
 235       P := WideGetParamStr(P, Result);
 236       if (Index = 0) or (Result = '') then Break;
 237       Dec(Index);
 238     end;
 239   end;
 240 end;
 241
 242 function WideStringToUTF8(const S: WideString): AnsiString;
 243 begin
 244   Result := UTF8Encode(S);
 245 end;
 246
 247 function UTF8ToWideString(const S: AnsiString): WideString;
 248 begin
 249   Result := UTF8Decode(S);
 250 end;
 251
 252   { ======================================================================= }
 253   { Original File:   ConvertUTF7.c                                          }
 254   { Author: David B. Goldsmith                                              }
 255   { Copyright (C) 1994, 1996 Taligent, Inc. All rights reserved.            }
 256   {                                                                         }
 257   { This code is copyrighted. Under the copyright laws, this code may not   }
 258   { be copied, in whole or part, without prior written consent of Taligent. }
 259   {                                                                         }
 260   { Taligent grants the right to use this code as long as this ENTIRE       }
 261   { copyright notice is reproduced in the code.  The code is provided       }
 262   { AS-IS, AND TALIGENT DISCLAIMS ALL WARRANTIES, EITHER EXPRESS OR         }
 263   { IMPLIED, INCLUDING, BUT NOT LIMITED TO IMPLIED WARRANTIES OF            }
 264   { MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  IN NO EVENT      }
 265   { WILL TALIGENT BE LIABLE FOR ANY DAMAGES WHATSOEVER (INCLUDING,          }
 266   { WITHOUT LIMITATION, DAMAGES FOR LOSS OF BUSINESS PROFITS, BUSINESS      }
 267   { INTERRUPTION, LOSS OF BUSINESS INFORMATION, OR OTHER PECUNIARY          }
 268   { LOSS) ARISING OUT OF THE USE OR INABILITY TO USE THIS CODE, EVEN        }
 269   { IF TALIGENT HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.        }
 270   { BECAUSE SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF         }
 271   { LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES, THE ABOVE            }
 272   { LIMITATION MAY NOT APPLY TO YOU.                                        }
 273   {                                                                         }
 274   { RESTRICTED RIGHTS LEGEND: Use, duplication, or disclosure by the        }
 275   { government is subject to restrictions as set forth in subparagraph      }
 276   { (c)(l)(ii) of the Rights in Technical Data and Computer Software        }
 277   { clause at DFARS 252.227-7013 and FAR 52.227-19.                         }
 278   {                                                                         }
 279   { This code may be protected by one or more U.S. and International        }
 280   { Patents.                                                                }
 281   {                                                                         }
 282   { TRADEMARKS: Taligent and the Taligent Design Mark are registered        }
 283   { trademarks of Taligent, Inc.                                            }
 284   { ======================================================================= }
 285
 286 type UCS2 = Word;
 287
 288 const
 289   _base64: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
 290   _direct: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789''(),-./:?';
 291   _optional: AnsiString = '!"#$%&*;<=>@[]^_`{|}';
 292   _spaces: AnsiString = #9#13#10#32;
 293
 294 var
 295   base64: PAnsiChar;
 296   invbase64: array[0..127] of SmallInt;
 297   direct: PAnsiChar;
 298   optional: PAnsiChar;
 299   spaces: PAnsiChar;
 300   mustshiftsafe: array[0..127] of AnsiChar;
 301   mustshiftopt: array[0..127] of AnsiChar;
 302
 303 var
 304   needtables: Boolean = True;
 305
 306 procedure Initialize_UTF7_Data;
 307 begin
 308   base64 := PAnsiChar(_base64);
 309   direct := PAnsiChar(_direct);
 310   optional := PAnsiChar(_optional);
 311   spaces := PAnsiChar(_spaces);
 312 end;
 313
 314 procedure tabinit;
 315 var
 316   i: Integer;
 317   limit: Integer;
 318 begin
 319   i := 0;
 320   while (i < 128) do
 321   begin
 322     mustshiftopt[i] := #1;
 323     mustshiftsafe[i] := #1;
 324     invbase64[i] := -1;
 325     Inc(i);
 326   end { For };
 327   limit := Length(_Direct);
 328   i := 0;
 329   while (i < limit) do
 330   begin
 331     mustshiftopt[Integer(direct[i])] := #0;
 332     mustshiftsafe[Integer(direct[i])] := #0;
 333     Inc(i);
 334   end { For };
 335   limit := Length(_Spaces);
 336   i := 0;
 337   while (i < limit) do
 338   begin
 339     mustshiftopt[Integer(spaces[i])] := #0;
 340     mustshiftsafe[Integer(spaces[i])] := #0;
 341     Inc(i);
 342   end { For };
 343   limit := Length(_Optional);
 344   i := 0;
 345   while (i < limit) do
 346   begin
 347     mustshiftopt[Integer(optional[i])] := #0;
 348     Inc(i);
 349   end { For };
 350   limit := Length(_Base64);
 351   i := 0;
 352   while (i < limit) do
 353   begin
 354     invbase64[Integer(base64[i])] := i;
 355     Inc(i);
 356   end { For };
 357   needtables := False;
 358 end; { tabinit }
 359
 360 function WRITE_N_BITS(x: UCS2; n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): Integer;
 361 begin
 362   BITbuffer := BITbuffer or (x and (not (-1 shl n))) shl (32 - n - bufferbits);
 363   bufferbits := bufferbits + n;
 364   Result := bufferbits;
 365 end; { WRITE_N_BITS }
 366
 367 function READ_N_BITS(n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): UCS2;
 368 var
 369   buffertemp: Cardinal;
 370 begin
 371   buffertemp := BITbuffer shr (32 - n);
 372   BITbuffer := BITbuffer shl n;
 373   bufferbits := bufferbits - n;
 374   Result := UCS2(buffertemp);
 375 end; { READ_N_BITS }
 376
 377 function ConvertUCS2toUTF7(var sourceStart: PWideChar; sourceEnd: PWideChar;
 378   var targetStart: PAnsiChar; targetEnd: PAnsiChar; optional: Boolean;
 379     verbose: Boolean): Integer;
 380 var
 381   r: UCS2;
 382   target: PAnsiChar;
 383   source: PWideChar;
 384   BITbuffer: Cardinal;
 385   bufferbits: Integer;
 386   shifted: Boolean;
 387   needshift: Boolean;
 388   done: Boolean;
 389   mustshift: PAnsiChar;
 390 begin
 391   Initialize_UTF7_Data;
 392   Result := 0;
 393   BITbuffer := 0;
 394   bufferbits := 0;
 395   shifted := False;
 396   source := sourceStart;
 397   target := targetStart;
 398   r := 0;
 399   if needtables then
 400     tabinit;
 401   if optional then
 402     mustshift := @mustshiftopt[0]
 403   else
 404     mustshift := @mustshiftsafe[0];
 405   repeat
 406     done := source >= sourceEnd;
 407     if not Done then
 408     begin
 409       r := Word(source^);
 410       Inc(Source);
 411     end { If };
 412     needshift := (not done) and ((r > $7F) or (mustshift[r] <> #0));
 413     if needshift and (not shifted) then
 414     begin
 415       if (Target >= TargetEnd) then
 416       begin
 417         Result := 2;
 418         break;
 419       end { If };
 420       target^ := '+';
 421       Inc(target);
 422       { Special case handling of the SHIFT_IN character }
 423       if (r = UCS2('+')) then
 424       begin
 425         if (target >= targetEnd) then
 426         begin
 427           Result := 2;
 428           break;
 429         end;
 430         target^ := '-';
 431         Inc(target);
 432       end
 433       else
 434         shifted := True;
 435     end { If };
 436     if shifted then
 437     begin
 438       { Either write the character to the bit buffer, or pad }
 439       { the bit buffer out to a full base64 character. }
 440       { }
 441       if needshift then
 442         WRITE_N_BITS(r, 16, BITbuffer, bufferbits)
 443       else
 444         WRITE_N_BITS(0, (6 - (bufferbits mod 6)) mod 6, BITbuffer,
 445           bufferbits);
 446       { Flush out as many full base64 characters as possible }
 447       { from the bit buffer. }
 448       { }
 449       while (target < targetEnd) and (bufferbits >= 6) do
 450       begin
 451         Target^ := base64[READ_N_BITS(6, BITbuffer, bufferbits)];
 452         Inc(Target);
 453       end { While };
 454       if (bufferbits >= 6) then
 455       begin
 456         if (target >= targetEnd) then
 457         begin
 458           Result := 2;
 459           break;
 460         end { If };
 461       end { If };
 462       if (not needshift) then
 463       begin
 464         { Write the explicit shift out character if }
 465         { 1) The caller has requested we always do it, or }
 466         { 2) The directly encoded character is in the }
 467         { base64 set, or }
 468         { 3) The directly encoded character is SHIFT_OUT. }
 469         { }
 470         if verbose or ((not done) and ((invbase64[r] >= 0) or (r =
 471           Integer('-')))) then
 472         begin
 473           if (target >= targetEnd) then
 474           begin
 475             Result := 2;
 476             Break;
 477           end { If };
 478           Target^ := '-';
 479           Inc(Target);
 480         end { If };
 481         shifted := False;
 482       end { If };
 483       { The character can be directly encoded as ASCII. }
 484     end { If };
 485     if (not needshift) and (not done) then
 486     begin
 487       if (target >= targetEnd) then
 488       begin
 489         Result := 2;
 490         break;
 491       end { If };
 492       Target^ := AnsiChar(r);
 493       Inc(Target);
 494     end { If };
 495   until (done);
 496   sourceStart := source;
 497   targetStart := target;
 498 end; { ConvertUCS2toUTF7 }
 499
 500 function ConvertUTF7toUCS2(var sourceStart: PAnsiChar; sourceEnd: PAnsiChar;
 501   var targetStart: PWideChar; targetEnd: PWideChar): Integer;
 502 var
 503   target: PWideChar { Register };
 504   source: PAnsiChar { Register };
 505   BITbuffer: Cardinal { & "Address Of" Used };
 506   bufferbits: Integer { & "Address Of" Used };
 507   shifted: Boolean { Used In Boolean Context };
 508   first: Boolean { Used In Boolean Context };
 509   wroteone: Boolean;
 510   base64EOF: Boolean;
 511   base64value: Integer;
 512   done: Boolean;
 513   c: UCS2;
 514   prevc: UCS2;
 515   junk: UCS2 { Used In Boolean Context };
 516 begin
 517   Initialize_UTF7_Data;
 518   Result := 0;
 519   BITbuffer := 0;
 520   bufferbits := 0;
 521   shifted := False;
 522   first := False;
 523   wroteone := False;
 524   source := sourceStart;
 525   target := targetStart;
 526   c := 0;
 527   if needtables then
 528     tabinit;
 529   repeat
 530     { read an ASCII character c }
 531     done := Source >= SourceEnd;
 532     if (not done) then
 533     begin
 534       c := Word(Source^);
 535       Inc(Source);
 536     end { If };
 537     if shifted then
 538     begin
 539       { We're done with a base64 string if we hit EOF, it's not a valid }
 540       { ASCII character, or it's not in the base64 set. }
 541       { }
 542       base64value := invbase64[c];
 543       base64EOF := (done or (c > $7F)) or (base64value < 0);
 544       if base64EOF then
 545       begin
 546         shifted := False;
 547         { If the character causing us to drop out was SHIFT_IN or }
 548         { SHIFT_OUT, it may be a special escape for SHIFT_IN. The }
 549         { test for SHIFT_IN is not necessary, but allows an alternate }
 550         { form of UTF-7 where SHIFT_IN is escaped by SHIFT_IN. This }
 551         { only works for some values of SHIFT_IN. }
 552         { }
 553         if ((not done) and ((c = Integer('+')) or (c = Integer('-')))) then
 554         begin
 555           { get another character c }
 556           prevc := c;
 557           Done := Source >= SourceEnd;
 558           if (not Done) then
 559           begin
 560             c := Word(Source^);
 561             Inc(Source);
 562             { If no base64 characters were encountered, and the }
 563             { character terminating the shift sequence was }
 564             { SHIFT_OUT, then it's a special escape for SHIFT_IN. }
 565             { }
 566           end;
 567           if first and (prevc = Integer('-')) then
 568           begin
 569             { write SHIFT_IN unicode }
 570             if (target >= targetEnd) then
 571             begin
 572               Result := 2;
 573               break;
 574             end { If };
 575             Target^ := WideChar('+');
 576             Inc(Target);
 577           end
 578           else
 579           begin
 580             if (not wroteone) then
 581             begin
 582               Result := 1;
 583             end { If };
 584           end { Else };
 585           ;
 586         end { If }
 587         else
 588         begin
 589           if (not wroteone) then
 590           begin
 591             Result := 1;
 592           end { If };
 593         end { Else };
 594       end { If }
 595       else
 596       begin
 597         { Add another 6 bits of base64 to the bit buffer. }
 598         WRITE_N_BITS(base64value, 6, BITbuffer,
 599           bufferbits);
 600         first := False;
 601       end { Else };
 602       { Extract as many full 16 bit characters as possible from the }
 603       { bit buffer. }
 604       { }
 605       while (bufferbits >= 16) and (target < targetEnd) do
 606       begin
 607         { write a unicode }
 608         Target^ := WideChar(READ_N_BITS(16, BITbuffer, bufferbits));
 609         Inc(Target);
 610         wroteone := True;
 611       end { While };
 612       if (bufferbits >= 16) then
 613       begin
 614         if (target >= targetEnd) then
 615         begin
 616           Result := 2;
 617           Break;
 618         end;
 619       end { If };
 620       if (base64EOF) then
 621       begin
 622         junk := READ_N_BITS(bufferbits, BITbuffer, bufferbits);
 623         if (junk <> 0) then
 624         begin
 625           Result := 1;
 626         end { If };
 627       end { If };
 628     end { If };
 629     if (not shifted) and (not done) then
 630     begin
 631       if (c = Integer('+')) then
 632       begin
 633         shifted := True;
 634         first := True;
 635         wroteone := False;
 636       end { If }
 637       else
 638       begin
 639         { It must be a directly encoded character. }
 640         if (c > $7F) then
 641         begin
 642           Result := 1;
 643         end { If };
 644         if (target >= targetEnd) then
 645         begin
 646           Result := 2;
 647           break;
 648         end { If };
 649         Target^ := WideChar(c);
 650         Inc(Target);
 651       end { Else };
 652     end { If };
 653   until (done);
 654   sourceStart := source;
 655   targetStart := target;
 656 end; { ConvertUTF7toUCS2 }
 657
 658   {*****************************************************************************}
 659   { Thanks to Francisco Leong for providing the Pascal conversion of            }
 660   {   ConvertUTF7.c (by David B. Goldsmith)                                     }
 661   {*****************************************************************************}
 662
 663 resourcestring
 664   SBufferOverflow = 'Buffer overflow';
 665   SInvalidUTF7 = 'Invalid UTF7';
 666
 667 function WideStringToUTF7(const W: WideString): AnsiString;
 668 var
 669   SourceStart, SourceEnd: PWideChar;
 670   TargetStart, TargetEnd: PAnsiChar;
 671 begin
 672   if W = '' then
 673     Result := ''
 674   else
 675   begin
 676     SetLength(Result, Length(W) * 7); // Assume worst case
 677     SourceStart := PWideChar(@W[1]);
 678     SourceEnd := PWideChar(@W[Length(W)]) + 1;
 679     TargetStart := PAnsiChar(@Result[1]);
 680     TargetEnd := PAnsiChar(@Result[Length(Result)]) + 1;
 681     if ConvertUCS2toUTF7(SourceStart, SourceEnd, TargetStart,
 682       TargetEnd, True, False) <> 0
 683     then
 684       raise ETntInternalError.Create(SBufferOverflow);
 685     SetLength(Result, TargetStart - PAnsiChar(@Result[1]));
 686   end;
 687 end;
 688
 689 function UTF7ToWideString(const S: AnsiString): WideString;
 690 var
 691   SourceStart, SourceEnd: PAnsiChar;
 692   TargetStart, TargetEnd: PWideChar;
 693 begin
 694   if (S = '') then
 695     Result := ''
 696   else
 697   begin
 698     SetLength(Result, Length(S)); // Assume Worst case
 699     SourceStart := PAnsiChar(@S[1]);
 700     SourceEnd := PAnsiChar(@S[Length(S)]) + 1;
 701     TargetStart := PWideChar(@Result[1]);
 702     TargetEnd := PWideChar(@Result[Length(Result)]) + 1;
 703     case ConvertUTF7toUCS2(SourceStart, SourceEnd, TargetStart,
 704       TargetEnd) of
 705       1: raise ETntGeneralError.Create(SInvalidUTF7);
 706       2: raise ETntInternalError.Create(SBufferOverflow);
 707     end;
 708     SetLength(Result, TargetStart - PWideChar(@Result[1]));
 709   end;
 710 end;
 711
 712 function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString;
 713 var
 714   InputLength,
 715   OutputLength: Integer;
 716 begin
 717   if CodePage = CP_UTF7 then
 718     Result := UTF7ToWideString(S) // CP_UTF7 not supported on Windows 95
 719   else if CodePage = CP_UTF8 then
 720     Result := UTF8ToWideString(S) // CP_UTF8 not supported on Windows 95
 721   else begin
 722     InputLength := Length(S);
 723     OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, nil, 0);
 724     SetLength(Result, OutputLength);
 725     MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result), OutputLength);
 726   end;
 727 end;
 728
 729 function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString;
 730 var
 731   InputLength,
 732   OutputLength: Integer;
 733 begin
 734   if CodePage = CP_UTF7 then
 735     Result := WideStringToUTF7(WS) // CP_UTF7 not supported on Windows 95
 736   else if CodePage = CP_UTF8 then
 737     Result := WideStringToUTF8(WS) // CP_UTF8 not supported on Windows 95
 738   else begin
 739     InputLength := Length(WS);
 740     OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, nil, 0, nil, nil);
 741     SetLength(Result, OutputLength);
 742     WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result), OutputLength, nil, nil);
 743   end;
 744 end;
 745
 746 function UCS2ToWideString(const Value: AnsiString): WideString;
 747 begin
 748   if Length(Value) = 0 then
 749     Result := ''
 750   else
 751     SetString(Result, PWideChar(@Value[1]), Length(Value) div SizeOf(WideChar))
 752 end;
 753
 754 function WideStringToUCS2(const Value: WideString): AnsiString;
 755 begin
 756   if Length(Value) = 0 then
 757     Result := ''
 758   else
 759     SetString(Result, PAnsiChar(@Value[1]), Length(Value) * SizeOf(WideChar))
 760 end;
 761
 762 { Windows.pas doesn't declare TranslateCharsetInfo() correctly. }
 763 function TranslateCharsetInfo(lpSrc: PDWORD; var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall; external gdi32 name 'TranslateCharsetInfo';
 764
 765 function CharSetToCodePage(ciCharset: UINT): Cardinal;
 766 var
 767   C: TCharsetInfo;
 768 begin
 769   Win32Check(TranslateCharsetInfo(PDWORD(ciCharset), C, TCI_SRCCHARSET));
 770   Result := C.ciACP
 771 end;
 772
 773 function LCIDToCodePage(ALcid: LCID): Cardinal;
 774 var
 775   Buf: array[0..6] of AnsiChar;
 776 begin
 777   GetLocaleInfo(ALcid, LOCALE_IDefaultAnsiCodePage, Buf, 6);
 778   Result := StrToIntDef(Buf, GetACP);
 779 end;
 780
 781 function KeyboardCodePage: Cardinal;
 782 begin
 783   Result := LCIDToCodePage(GetKeyboardLayout(0) and $FFFF);
 784 end;
 785
 786 function KeyUnicode(CharCode: Word): WideChar;
 787 var
 788   AChar: AnsiChar;
 789 begin
 790   // converts the given character (as it comes with a WM_CHAR message) into its
 791   // corresponding Unicode character depending on the active keyboard layout
 792   if CharCode <= Word(High(AnsiChar)) then begin
 793     AChar := AnsiChar(CharCode);
 794     MultiByteToWideChar(KeyboardCodePage, MB_USEGLYPHCHARS, @AChar, 1, @Result, 1);
 795   end else
 796     Result := WideChar(CharCode);
 797 end;
 798
 799 procedure StrSwapByteOrder(Str: PWideChar);
 800 var
 801   P: PWord;
 802 begin
 803   P := PWord(Str);
 804   While (P^ <> 0) do begin
 805     P^ := MakeWord(HiByte(P^), LoByte(P^));
 806     Inc(P);
 807   end;
 808 end;
 809
 810 //--------------------------------------------------------------------
 811 //                LoadResString()
 812 //
 813 //  This system function is used to retrieve a resourcestring and
 814 //   return the result as an AnsiString.  If we believe that the result
 815 //    is only a temporary value, and that it will be immediately
 816 //     assigned to a WideString or a Variant, then we will save the
 817 //      Unicode result as well as a reference to the original Ansi string.
 818 //       WStrFromPCharLen() or VarFromLStr() will return this saved
 819 //        Unicode string if it appears to receive the most recent result
 820 //         of LoadResString.
 821 //--------------------------------------------------------------------
 822
 823
 824   //===========================================================================================
 825   //
 826   //    function CodeMatchesPatternForUnicode(...);
 827   //
 828   //    GIVEN:  SomeWideString := SSomeResString;  { WideString := resourcestring }
 829   //
 830   //    Delphi will compile this statement into the following:
 831   //    -------------------------------------------------
 832   //    TempAnsiString := LoadResString(@SSomeResString);
 833   //      LINE 1:  lea edx,[SomeTempAnsiString]
 834   //      LINE 2:  mov eax,[@SomeResString]
 835   //      LINE 3:  call LoadResString
 836   //
 837   //    WStrFromLStr(SomeWideString, TempAnsiString);  { SomeWideString := TempAnsiString }
 838   //      LINE 4:  mov edx,[SomeTempAnsiString]
 839   //      LINE 5:  mov/lea eax [@SomeWideString]
 840   //      LINE 6:  call @WStrFromLStr
 841   //    -------------------------------------------------
 842   //
 843   //    The order in which the parameters are prepared for WStrFromLStr (ie LINE 4 & 5) is
 844   //      reversed when assigning a non-temporary AnsiString to a WideString.
 845   //
 846   //    This code, for example, results in LINE 4 and LINE 5 being swapped.
 847   //
 848   //      SomeAnsiString := SSomeResString;
 849   //      SomeWideString := SomeAnsiString;
 850   //
 851   //    Since we know the "signature" used by the compiler, we can detect this pattern.
 852   //     If we believe it is only temporary, we can save the Unicode results for later
 853   //      retrieval from WStrFromLStr.
 854   //
 855   //    One final note:  When assigning a resourcestring to a Variant, the same patterns exist.
 856   //===========================================================================================
 857
 858 function CodeMatchesPatternForUnicode(PLine4: PAnsiChar): Boolean;
 859 const
 860   SIZEOF_OPCODE = 1 {byte};
 861   MOV_16_OPCODE = AnsiChar($8B); { we'll assume operand size is 16 bits }
 862   MOV_32_OPCODE = AnsiChar($B8); { we'll assume operand size is 32 bits }
 863   LEA_OPCODE    = AnsiChar($8D); { operand size can be 16 or 40 bits }
 864   CALL_OPCODE   = AnsiChar($E8); { assumed operand size is 32 bits }
 865   BREAK_OPCODE  = AnsiChar($CC); {in a breakpoint}
 866 var
 867   PLine1: PAnsiChar;
 868   PLine2: PAnsiChar;
 869   PLine3: PAnsiChar;
 870   DataSize: Integer; // bytes in first LEA operand
 871 begin
 872   Result := False;
 873
 874   PLine3 := PLine4 - SizeOf(CALL_OPCODE) - 4;
 875   PLine2 := PLine3 - SizeOf(MOV_32_OPCODE) - 4;
 876
 877   // figure PLine1 and operand size
 878   DataSize := 2; { try 16 bit operand for line 1 }
 879   PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE);
 880   if (PLine1^ <> LEA_OPCODE) and (not (IsDebugging and (PLine1^ = BREAK_OPCODE))) then
 881   begin
 882     DataSize := 5; { try 40 bit operand for line 1 }
 883     PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE);
 884   end;
 885   if (PLine1^ = LEA_OPCODE) or (IsDebugging and (PLine1^ = BREAK_OPCODE)) then
 886   begin
 887     if CompareMem(PLine1 + SIZEOF_OPCODE, PLine4 + SIZEOF_OPCODE, DataSize) then
 888     begin
 889       // After this check, it seems to match the WideString <- (temp) AnsiString pattern
 890       Result := True; // It is probably OK. (The side effects of being wrong aren't very bad.)
 891     end;
 892   end;
 893 end;
 894
 895 threadvar
 896   PLastResString: PAnsiChar;
 897   LastResStringValue: AnsiString;
 898   LastWideResString: WideString;
 899
 900 procedure FreeTntSystemThreadVars;
 901 begin
 902   LastResStringValue := '';
 903   LastWideResString := '';
 904 end;
 905
 906 procedure Custom_System_EndThread(ExitCode: Integer);
 907 begin
 908   FreeTntSystemThreadVars;
 909   {$IFDEF COMPILER_10_UP}
 910   if Assigned(SystemThreadEndProc) then
 911     SystemThreadEndProc(ExitCode);
 912   {$ENDIF}
 913   ExitThread(ExitCode);
 914 end;
 915
 916 function Custom_System_LoadResString(ResStringRec: PResStringRec): AnsiString;
 917 var
 918   ReturnAddr: Pointer;
 919 begin
 920   // get return address
 921   asm
 922     PUSH   ECX
 923     MOV    ECX, [EBP + 4]
 924     MOV    ReturnAddr, ECX
 925     POP    ECX
 926   end;
 927   // check calling code pattern
 928   if CodeMatchesPatternForUnicode(ReturnAddr) then begin
 929     // result will probably be assigned to an intermediate AnsiString
 930     //   on its way to either a WideString or Variant.
 931     LastWideResString := WideLoadResString(ResStringRec);
 932     Result := LastWideResString;
 933     LastResStringValue := Result;
 934     if Result = '' then
 935       PLastResString := nil
 936     else
 937       PLastResString := PAnsiChar(Result);
 938   end else begin
 939     // result will probably be assigned to an actual AnsiString variable.
 940     PLastResString := nil;
 941     Result := WideLoadResString(ResStringRec);
 942   end;
 943 end;
 944
 945 //--------------------------------------------------------------------
 946 //                WStrFromPCharLen()
 947 //
 948 //  This system function is used to assign an AnsiString to a WideString.
 949 //   It has been modified to assign Unicode results from LoadResString.
 950 //     Another purpose of this function is to specify the code page.
 951 //--------------------------------------------------------------------
 952
 953 procedure Custom_System_WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
 954 var
 955   DestLen: Integer;
 956   Buffer: array[0..2047] of WideChar;
 957   Local_PLastResString: Pointer;
 958 begin
 959   Local_PLastResString := PLastResString;
 960   if  (Local_PLastResString <> nil)
 961   and (Local_PLastResString = Source)
 962   and (System.Length(LastResStringValue) = Length)
 963   and (LastResStringValue = Source) then begin
 964     // use last unicode resource string
 965     PLastResString := nil; { clear for further use }
 966     Dest := LastWideResString;
 967   end else begin
 968     if Local_PLastResString <> nil then
 969       PLastResString := nil; { clear for further use }
 970     if Length <= 0 then
 971     begin
 972       Dest := '';
 973       Exit;
 974     end;
 975     if Length + 1 < High(Buffer) then
 976     begin
 977       DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Buffer,
 978         High(Buffer));
 979       if DestLen > 0 then
 980       begin
 981         SetLength(Dest, DestLen);
 982         Move(Pointer(@Buffer[0])^, Pointer(Dest)^, DestLen * SizeOf(WideChar));
 983         Exit;
 984       end;
 985     end;
 986     DestLen := (Length + 1);
 987     SetLength(Dest, DestLen); // overallocate, trim later
 988     DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest),
 989       DestLen);
 990     if DestLen < 0 then
 991       DestLen := 0;
 992     SetLength(Dest, DestLen);
 993   end;
 994 end;
 995
 996 {$IFNDEF COMPILER_9_UP}
 997
 998 //--------------------------------------------------------------------
 999 //                LStrFromPWCharLen()
1000 //
1001 //  This system function is used to assign an WideString to an AnsiString.
1002 //   It has not been modified from its original purpose other than to specify the code page.
1003 //--------------------------------------------------------------------
1004
1005 procedure Custom_System_LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
1006 var
1007   DestLen: Integer;
1008   Buffer: array[0..4095] of AnsiChar;
1009 begin
1010   if Length <= 0 then
1011   begin
1012     Dest := '';
1013     Exit;
1014   end;
1015   if Length + 1 < (High(Buffer) div sizeof(WideChar)) then
1016   begin
1017     DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source,
1018       Length, Buffer, High(Buffer),
1019       nil, nil);
1020     if DestLen >= 0 then
1021     begin
1022       SetLength(Dest, DestLen);
1023       Move(Pointer(@Buffer[0])^, PAnsiChar(Dest)^, DestLen);
1024       Exit;
1025     end;
1026   end;
1027
1028   DestLen := (Length + 1) * sizeof(WideChar);
1029   SetLength(Dest, DestLen); // overallocate, trim later
1030   DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), DestLen,
1031     nil, nil);
1032   if DestLen < 0 then
1033     DestLen := 0;
1034   SetLength(Dest, DestLen);
1035 end;
1036
1037 //--------------------------------------------------------------------
1038 //                WStrToString()
1039 //
1040 //  This system function is used to assign an WideString to an short string.
1041 //   It has not been modified from its original purpose other than to specify the code page.
1042 //--------------------------------------------------------------------
1043
1044 procedure Custom_System_WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
1045 var
1046   SourceLen, DestLen: Integer;
1047   Buffer: array[0..511] of AnsiChar;
1048 begin
1049   if MaxLen > 255 then MaxLen := 255;
1050   SourceLen := Length(Source);
1051   if SourceLen >= MaxLen then SourceLen := MaxLen;
1052   if SourceLen = 0 then
1053     DestLen := 0
1054   else begin
1055     DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Pointer(Source), SourceLen,
1056       Buffer, SizeOf(Buffer), nil, nil);
1057     if DestLen > MaxLen then DestLen := MaxLen;
1058   end;
1059   Dest^[0] := Chr(DestLen);
1060   if DestLen > 0 then Move(Buffer, Dest^[1], DestLen);
1061 end;
1062
1063 {$ENDIF}
1064
1065 //--------------------------------------------------------------------
1066 //                VarFromLStr()
1067 //
1068 //  This system function is used to assign an AnsiString to a Variant.
1069 //   It has been modified to assign Unicode results from LoadResString.
1070 //--------------------------------------------------------------------
1071
1072 procedure Custom_System_VarFromLStr(var V: TVarData; const Value: AnsiString);
1073 const
1074   varDeepData = $BFE8;
1075 var
1076   Local_PLastResString: Pointer;
1077 begin
1078   if (V.VType and varDeepData) <> 0 then
1079     VarClear(PVariant(@V)^);
1080
1081   Local_PLastResString := PLastResString;
1082   if  (Local_PLastResString <> nil)
1083   and (Local_PLastResString = PAnsiChar(Value))
1084   and (LastResStringValue = Value) then begin
1085     // use last unicode resource string
1086     PLastResString := nil; { clear for further use }
1087     V.VOleStr := nil;
1088     V.VType := varOleStr;
1089     WideString(Pointer(V.VOleStr)) := Copy(LastWideResString, 1, MaxInt);
1090   end else begin
1091     if Local_PLastResString <> nil then
1092       PLastResString := nil; { clear for further use }
1093     V.VString := nil;
1094     V.VType := varString;
1095     AnsiString(V.VString) := Value;
1096   end;
1097 end;
1098
1099 {$IFNDEF COMPILER_9_UP}
1100
1101 //--------------------------------------------------------------------
1102 //                WStrCat3()     A := B + C;
1103 //
1104 //  This system function is used to concatenate two strings into one result.
1105 //    This function is added because A := '' + '' doesn't necessarily result in A = '';
1106 //--------------------------------------------------------------------
1107
1108 procedure Custom_System_WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
1109
1110   function NewWideString(CharLength: Longint): Pointer;
1111   var
1112     _NewWideString: function(CharLength: Longint): Pointer;
1113   begin
1114     asm
1115       PUSH   ECX
1116       MOV    ECX, offset System.@NewWideString;
1117       MOV    _NewWideString, ECX
1118       POP    ECX
1119     end;
1120     Result := _NewWideString(CharLength);
1121   end;
1122
1123   procedure WStrSet(var S: WideString; P: PWideChar);
1124   var
1125     Temp: Pointer;
1126   begin
1127     Temp := Pointer(InterlockedExchange(Integer(S), Integer(P)));
1128     if Temp <> nil then
1129       WideString(Temp) := '';
1130   end;
1131
1132 var
1133   Source1Len, Source2Len: Integer;
1134   NewStr: PWideChar;
1135 begin
1136   Source1Len := Length(Source1);
1137   Source2Len := Length(Source2);
1138   if (Source1Len <> 0) or (Source2Len <> 0) then
1139   begin
1140     NewStr := NewWideString(Source1Len + Source2Len);
1141     Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar));
1142     Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar));
1143     WStrSet(Dest, NewStr);
1144   end else
1145     Dest := '';
1146 end;
1147
1148 {$ENDIF}
1149
1150 //--------------------------------------------------------------------
1151 //                System proc replacements
1152 //--------------------------------------------------------------------
1153
1154 type
1155   POverwrittenData = ^TOverwrittenData;
1156   TOverwrittenData = record
1157     Location: Pointer;
1158     OldCode: array[0..6] of Byte;
1159   end;
1160
1161 procedure OverwriteProcedure(OldProcedure, NewProcedure: pointer; Data: POverwrittenData = nil);
1162 { OverwriteProcedure originally from Igor Siticov }
1163 { Modified by Jacques Garcia Vazquez }
1164 var
1165   x: PAnsiChar;
1166   y: integer;
1167   ov2, ov: cardinal;
1168   p: pointer;
1169 begin
1170   if Assigned(Data) and (Data.Location <> nil) then
1171     exit; { procedure already overwritten }
1172
1173   // need six bytes in place of 5
1174   x := PAnsiChar(OldProcedure);
1175   if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then
1176     RaiseLastOSError;
1177
1178   // if a jump is present then a redirect is found
1179   // $FF25 = jmp dword ptr [xxx]
1180   // This redirect is normally present in bpl files, but not in exe files
1181   p := OldProcedure;
1182
1183   if Word(p^) = $25FF then
1184   begin
1185     Inc(Integer(p), 2); // skip the jump
1186     // get the jump address p^ and dereference it p^^
1187     p := Pointer(Pointer(p^)^);
1188
1189     // release the memory
1190     if not VirtualProtect(Pointer(x), 6, ov, @ov2) then
1191       RaiseLastOSError;
1192
1193     // re protect the correct one
1194     x := PAnsiChar(p);
1195     if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then
1196       RaiseLastOSError;
1197   end;
1198
1199   if Assigned(Data) then
1200   begin
1201     Move(x^, Data.OldCode, 6);
1202     { Assign Location last so that Location <> nil only if OldCode is properly initialized. }
1203     Data.Location := x;
1204   end;
1205
1206   x[0] := AnsiChar($E9);
1207   y := integer(NewProcedure) - integer(p) - 5;
1208   x[1] := AnsiChar(y and 255);
1209   x[2] := AnsiChar((y shr 8) and 255);
1210   x[3] := AnsiChar((y shr 16) and 255);
1211   x[4] := AnsiChar((y shr 24) and 255);
1212
1213   if not VirtualProtect(Pointer(x), 6, ov, @ov2) then
1214     RaiseLastOSError;
1215 end;
1216
1217 procedure RestoreProcedure(OriginalProc: Pointer; Data: TOverwrittenData);
1218 var
1219   ov, ov2: Cardinal;
1220 begin
1221   if Data.Location <> nil then begin
1222     if not VirtualProtect(Data.Location, 6, PAGE_EXECUTE_READWRITE, @ov) then
1223       RaiseLastOSError;
1224     Move(Data.OldCode, Data.Location^, 6);
1225     if not VirtualProtect(Data.Location, 6, ov, @ov2) then
1226       RaiseLastOSError;
1227   end;
1228 end;
1229
1230 function Addr_System_EndThread: Pointer;
1231 begin
1232   Result := @System.EndThread;
1233 end;
1234
1235 function Addr_System_LoadResString: Pointer;
1236 begin
1237   Result := @System.LoadResString{TNT-ALLOW LoadResString};
1238 end;
1239
1240 function Addr_System_WStrFromPCharLen: Pointer;
1241 asm
1242   mov eax, offset System.@WStrFromPCharLen;
1243 end;
1244
1245 {$IFNDEF COMPILER_9_UP}
1246 function Addr_System_LStrFromPWCharLen: Pointer;
1247 asm
1248   mov eax, offset System.@LStrFromPWCharLen;
1249 end;
1250
1251 function Addr_System_WStrToString: Pointer;
1252 asm
1253   mov eax, offset System.@WStrToString;
1254 end;
1255 {$ENDIF}
1256
1257 function Addr_System_VarFromLStr: Pointer;
1258 asm
1259   mov eax, offset System.@VarFromLStr;
1260 end;
1261
1262 function Addr_System_WStrCat3: Pointer;
1263 asm
1264   mov eax, offset System.@WStrCat3;
1265 end;
1266
1267 var
1268   System_EndThread_Code,
1269   System_LoadResString_Code,
1270   System_WStrFromPCharLen_Code,
1271   {$IFNDEF COMPILER_9_UP}
1272   System_LStrFromPWCharLen_Code,
1273   System_WStrToString_Code,
1274   {$ENDIF}
1275   System_VarFromLStr_Code,
1276   {$IFNDEF COMPILER_9_UP}
1277   System_WStrCat3_Code,
1278   SysUtils_WideFmtStr_Code,
1279   {$ENDIF}
1280   Forms_TApplication_ShowException_Code,
1281   SysUtils_RaiseLastOsError_Code: TOverwrittenData;
1282
1283 procedure InstallEndThreadOverride;
1284 begin
1285   OverwriteProcedure(Addr_System_EndThread,  @Custom_System_EndThread,  @System_EndThread_Code);
1286 end;
1287
1288 procedure InstallStringConversionOverrides;
1289 begin
1290   OverwriteProcedure(Addr_System_WStrFromPCharLen,  @Custom_System_WStrFromPCharLen,  @System_WStrFromPCharLen_Code);
1291   {$IFNDEF COMPILER_9_UP}
1292   OverwriteProcedure(Addr_System_LStrFromPWCharLen, @Custom_System_LStrFromPWCharLen, @System_LStrFromPWCharLen_Code);
1293   OverwriteProcedure(Addr_System_WStrToString,      @Custom_System_WStrToString,      @System_WStrToString_Code);
1294   {$ENDIF}
1295 end;
1296
1297 procedure InstallWideResourceStrings;
1298 begin
1299   OverwriteProcedure(Addr_System_LoadResString,     @Custom_System_LoadResString,     @System_LoadResString_Code);
1300   OverwriteProcedure(Addr_System_VarFromLStr,       @Custom_System_VarFromLStr,       @System_VarFromLStr_Code);
1301 end;
1302
1303 {$IFNDEF COMPILER_9_UP}
1304 procedure InstallWideStringConcatenationFix;
1305 begin
1306   OverwriteProcedure(Addr_System_WStrCat3,          @Custom_System_WStrCat3,          @System_WStrCat3_Code);
1307 end;
1308
1309 procedure InstallWideFormatFixes;
1310 begin
1311   OverwriteProcedure(@SysUtils.WideFmtStr, @TntSysUtils.Tnt_WideFmtStr, @SysUtils_WideFmtStr_Code);
1312 end;
1313 {$ENDIF}
1314
1315 procedure InstallWideExceptions;
1316 begin
1317   OverwriteProcedure(@Forms.TApplication.ShowException, @TTntApplication.ShowException, @Forms_TApplication_ShowException_Code);
1318   OverwriteProcedure(@SysUtils.RaiseLastOsError, @TntSysUtils.WideRaiseLastOsError, @SysUtils_RaiseLastOsError_Code);
1319 end;
1320
1321 procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates);
1322 begin
1323   InstallEndThreadOverride;
1324   if tsWideResourceStrings in Updates then begin
1325     InstallStringConversionOverrides;
1326     InstallWideResourceStrings;
1327   end;
1328   {$IFNDEF COMPILER_9_UP}
1329     if tsFixImplicitCodePage in Updates then begin
1330       InstallStringConversionOverrides;
1331       { CP_ACP is the code page used by the non-Unicode Windows API. }
1332       GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP};
1333     end;
1334     if tsFixWideStrConcat in Updates then begin
1335       InstallWideStringConcatenationFix;
1336     end;
1337     if tsFixWideFormat in Updates then begin
1338       InstallWideFormatFixes;
1339     end;
1340   {$ENDIF}
1341   if tsWideExceptions in Updates then begin
1342     InstallWideExceptions
1343   end;
1344 end;
1345
1346 {$IFNDEF COMPILER_9_UP}
1347 var
1348   StartupDefaultUserCodePage: Cardinal;
1349 {$ENDIF}
1350
1351 procedure UninstallSystemOverrides;
1352 begin
1353   RestoreProcedure(Addr_System_EndThread,  System_EndThread_Code);
1354   // String Conversion
1355   RestoreProcedure(Addr_System_WStrFromPCharLen,  System_WStrFromPCharLen_Code);
1356   {$IFNDEF COMPILER_9_UP}
1357   RestoreProcedure(Addr_System_LStrFromPWCharLen, System_LStrFromPWCharLen_Code);
1358   RestoreProcedure(Addr_System_WStrToString,      System_WStrToString_Code);
1359   GDefaultSystemCodePage := StartupDefaultUserCodePage;
1360   {$ENDIF}
1361   // Wide resourcestring
1362   RestoreProcedure(Addr_System_LoadResString,     System_LoadResString_Code);
1363   RestoreProcedure(Addr_System_VarFromLStr,       System_VarFromLStr_Code);
1364   {$IFNDEF COMPILER_9_UP}
1365   // WideString concat fix
1366   RestoreProcedure(Addr_System_WStrCat3,          System_WStrCat3_Code);
1367   // WideFormat fixes
1368   RestoreProcedure(@SysUtils.WideFmtStr, SysUtils_WideFmtStr_Code);
1369   {$ENDIF}
1370   // Wide exception
1371   RestoreProcedure(@Forms.TApplication.ShowException, Forms_TApplication_ShowException_Code);
1372   RestoreProcedure(@SysUtils.RaiseLastOsError, SysUtils_RaiseLastOsError_Code);
1373 end;
1374
1375 initialization
1376   {$IFDEF COMPILER_9_UP}
1377   GDefaultSystemCodePage := GetACP;
1378   {$ELSE}
1379     {$IFDEF COMPILER_7_UP}
1380     if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then
1381       GDefaultSystemCodePage := CP_THREAD_ACP // Win 2K/XP/...
1382     else
1383       GDefaultSystemCodePage := LCIDToCodePage(GetThreadLocale); // Win NT4/95/98/ME
1384     {$ELSE}
1385     GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP};
1386     {$ENDIF}
1387   {$ENDIF}
1388   {$IFNDEF COMPILER_9_UP}
1389   StartupDefaultUserCodePage := DefaultSystemCodePage;
1390   {$ENDIF}
1391   IsDebugging := DebugHook > 0;
1392
1393 finalization
1394   UninstallSystemOverrides;
1395   FreeTntSystemThreadVars; { Make MemorySleuth happy. }
1396
1397 end.