1 unit gnugettext;
2 (**************************************************************)
3 (* *)
4 (* (C) Copyright by Lars B. Dybdahl and others *)
5 (* E-mail: Lars@dybdahl.dk, phone +45 70201241 *)
6 (* File version: $Date: 2005-12-06 00:25:47 $ *)
7 (* Revision: $Revision: 1.3 $ *)
8 (* *)
9 (* Contributors: Peter Thornqvist, Troy Wolbrink, *)
10 (* Frank Andreas de Groot, Igor Siticov, *)
11 (* Jacques Garcia Vazquez *)
12 (* *)
13 (* See http://dybdahl.dk/dxgettext/ for more information *)
14 (* *)
15 (**************************************************************)
16
17 // Redistribution and use in source and binary forms, with or without
18 // modification, are permitted provided that the following conditions are met:
19 //
20 // The names of any contributor may not be used to endorse or promote
21 // products derived from this software without specific prior written permission.
22 //
23 // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
24 // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
25 // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
26 // ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
27 // LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
28 // DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
29 // SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30 // CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
31 // OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
32 // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33
34 interface
35
36 // If the conditional define DXGETTEXTDEBUG is defined, debugging log is activated.
37 // Use DefaultInstance.DebugLogToFile() to write the log to a file.
38 { $define DXGETTEXTDEBUG}
39
40 {$ifdef VER100}
41 // Delphi 3
42 {$DEFINE DELPHI5OROLDER}
43 {$DEFINE DELPHI6OROLDER}
44 {$endif}
45 {$ifdef VER110}
46 // C++ Builder 3
47 {$DEFINE DELPHI5OROLDER}
48 {$DEFINE DELPHI6OROLDER}
49 {$endif}
50 {$ifdef VER120}
51 // Delphi 4
52 {$DEFINE DELPHI4OROLDER}
53 {$DEFINE DELPHI5OROLDER}
54 {$DEFINE DELPHI6OROLDER}
55 {$endif}
56 {$ifdef VER125}
57 // C++ Builder 4
58 {$DEFINE DELPHI5OROLDER}
59 {$DEFINE DELPHI6OROLDER}
60 {$endif}
61 {$ifdef VER130}
62 // Delphi 5
63 {$DEFINE DELPHI5OROLDER}
64 {$DEFINE DELPHI6OROLDER}
65 {$ifdef WIN32}
66 {$DEFINE MSWINDOWS}
67 {$endif}
68 {$endif}
69 {$ifdef VER135}
70 // C++ Builder 5
71 {$DEFINE DELPHI5OROLDER}
72 {$DEFINE DELPHI6OROLDER}
73 {$ifdef WIN32}
74 {$DEFINE MSWINDOWS}
75 {$endif}
76 {$endif}
77 {$ifdef VER140}
78 // Delphi 6
79 {$ifdef MSWINDOWS}
80 {$DEFINE DELPHI6OROLDER}
81 {$endif}
82 {$endif}
83 {$ifdef VER150}
84 // Delphi 7
85 {$endif}
86
87 uses
88 TypInfo,
89 {$ifdef DELPHI4OROLDER}
90 gnugettextD4,
91 {$else}
92 {$ifdef DELPHI5OROLDER}
93 gnugettextD5,
94 {$endif}
95 {$endif}
96
97 {$ifdef MSWINDOWS}
98 Windows,
99 Delphi,
100 {$else}
101 Libc,
102 {$endif}
103 Classes, SysUtils;
104
105 (*****************************************************************************)
106 (* *)
107 (* MAIN API *)
108 (* *)
109 (*****************************************************************************)
110
111 // Main GNU gettext functions. See documentation for instructions on how to use them.
_null112 function _(const szMsgId: widestring): widestring;
gettextnull113 function gettext(const szMsgId: widestring): widestring;
dgettextnull114 function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
dngettextnull115 function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
ngettextnull116 function ngettext(const singular,plural: widestring; Number:longint): widestring;
117 procedure textdomain(const szDomain: string);
getcurrenttextdomainnull118 function getcurrenttextdomain: string;
119 procedure bindtextdomain(const szDomain: string; const szDirectory: string);
120
121 // Set language to use
122 procedure UseLanguage(LanguageCode: string);
GetCurrentLanguagenull123 function GetCurrentLanguage:string;
124
125 // Translates a component (form, frame etc.) to the currently selected language.
126 // Put TranslateComponent(self) in the OnCreate event of all your forms.
127 // See the manual for documentation on these functions
128 type
129 TTranslator=procedure (obj:TObject) of object;
130
131 procedure TP_Ignore(AnObject:TObject; const name:string);
132 procedure TP_IgnoreClass (IgnClass:TClass);
133 procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:string);
134 procedure TP_GlobalIgnoreClass (IgnClass:TClass);
135 procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:string);
136 procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
137 procedure TranslateComponent(AnObject: TComponent; const TextDomain:string='');
138 procedure RetranslateComponent(AnObject: TComponent; const TextDomain:string='');
139
140 // Add more domains that resourcestrings can be extracted from. If a translation
141 // is not found in the default domain, this domain will be searched, too.
142 // This is useful for adding mo files for certain runtime libraries and 3rd
143 // party component libraries
144 procedure AddDomainForResourceString (const domain:string);
145 procedure RemoveDomainForResourceString (const domain:string);
146
147 // Unicode-enabled way to get resourcestrings, automatically translated
148 // Use like this: ws:=LoadResStringW(@NameOfResourceString);
LoadResStringnull149 function LoadResString(ResStringRec: PResStringRec): widestring;
LoadResStringAnull150 function LoadResStringA(ResStringRec: PResStringRec): ansistring;
LoadResStringWnull151 function LoadResStringW(ResStringRec: PResStringRec): widestring;
152
153 // This returns an empty string if not translated or translator name is not specified.
GetTranslatorNameAndEmailnull154 function GetTranslatorNameAndEmail:widestring;
155
156
157 (*****************************************************************************)
158 (* *)
159 (* ADVANCED FUNCTIONALITY *)
160 (* *)
161 (*****************************************************************************)
162
163 const
164 DefaultTextDomain = 'default';
165
166 var
167 ExecutableFilename:string; // This is set to paramstr(0) or the name of the DLL you are creating.
168
169 type
170 EGnuGettext=class(Exception);
171 EGGProgrammingError=class(EGnuGettext);
172 EGGComponentError=class(EGnuGettext);
173 EGGIOError=class(EGnuGettext);
174 EGGAnsi2WideConvError=class(EGnuGettext);
175
willnull176 // This function will turn resourcestring hooks on or off, eventually with BPL file support.
177 // Please do not activate BPL file support when the package is in design mode.
178 const AutoCreateHooks=true;
179 procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);
180
181
182
183
184 (*****************************************************************************)
185 (* *)
186 (* CLASS based implementation. *)
187 (* Use TGnuGettextInstance to have more than one language *)
188 (* in your application at the same time *)
189 (* *)
190 (*****************************************************************************)
191
192 {$ifdef MSWINDOWS}
193 {$ifndef DELPHI6OROLDER}
194 {$WARN UNSAFE_TYPE OFF}
195 {$WARN UNSAFE_CODE OFF}
196 {$WARN UNSAFE_CAST OFF}
197 {$endif}
198 {$endif}
199
200 type
201 TOnDebugLine = Procedure (Sender: TObject; const Line: String; var Discard: Boolean) of Object; // Set Discard to false if output should still go to ordinary debug log
202 TGetPluralForm=function (Number:Longint):Integer;
203 TDebugLogger=procedure (line: ansistring) of object;
204 TMoFile= // Don't use this class. It's for internal use.
205 class // Threadsafe. Only constructor and destructor are writing to memory
206 private
207 doswap: boolean;
208 public
209 Users:Integer; // Reference count. If it reaches zero, this object should be destroyed.
210 constructor Create (filename:string;Offset,Size:int64);
211 destructor Destroy; override;
gettextnull212 function gettext(const msgid: ansistring;var found:boolean): ansistring; // uses mo file
213 property isSwappedArchitecture:boolean read doswap;
214 private
215 N, O, T: Cardinal; // Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html
216 startindex,startstep:integer;
217 {$ifdef mswindows}
218 mo: THandle;
219 momapping: THandle;
220 {$endif}
221 momemoryHandle:PChar;
222 momemory: PChar;
autoswap32null223 function autoswap32(i: cardinal): cardinal;
CardinalInMemnull224 function CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;
225 end;
226 TDomain= // Don't use this class. It's for internal use.
227 class
228 private
229 Enabled:boolean;
230 vDirectory: string;
231 procedure setDirectory(const dir: string);
232 public
233 DebugLogger:TDebugLogger;
234 Domain: string;
235 property Directory: string read vDirectory write setDirectory;
236 constructor Create;
237 destructor Destroy; override;
238 // Set parameters
239 procedure SetLanguageCode (const langcode:string);
240 procedure SetFilename (const filename:string); // Bind this domain to a specific file
241 // Get information
242 procedure GetListOfLanguages(list:TStrings);
GetTranslationPropertynull243 function GetTranslationProperty(Propertyname: string): WideString;
gettextnull244 function gettext(const msgid: ansistring): ansistring; // uses mo file
245 private
246 mofile:TMoFile;
247 SpecificFilename:string;
248 curlang: string;
249 OpenHasFailedBefore: boolean;
250 procedure OpenMoFile;
251 procedure CloseMoFile;
252 end;
253 TExecutable=
254 class
255 procedure Execute; virtual; abstract;
256 end;
257 TGnuGettextInstance=
258 class
259 private
260 fOnDebugLine:TOnDebugLine;
261 CreatorThread:Cardinal; // Only this thread can use LoadResString
262 public
263 Enabled:Boolean; // Set this to false to disable translations
264 DesignTimeCodePage:Integer; // See MultiByteToWideChar() in Win32 API for documentation
265 constructor Create;
266 destructor Destroy; override;
267 procedure UseLanguage(LanguageCode: string);
268 procedure GetListOfLanguages (const domain:string; list:TStrings); // Puts list of language codes, for which there are translations in the specified domain, into list
269 {$ifdef DELPHI5OROLDER}
gettextnull270 function gettext(const szMsgId: widestring): widestring;
ngettextnull271 function ngettext(const singular,plural:widestring;Number:longint):widestring;
272 {$endif}
273 {$ifndef DELPHI5OROLDER}
gettextnull274 function gettext(const szMsgId: ansistring): widestring; overload;
gettextnull275 function gettext(const szMsgId: widestring): widestring; overload;
ngettextnull276 function ngettext(const singular,plural:ansistring;Number:longint):widestring; overload;
ngettextnull277 function ngettext(const singular,plural:widestring;Number:longint):widestring; overload;
278 {$endif}
GetCurrentLanguagenull279 function GetCurrentLanguage:string;
GetTranslationPropertynull280 function GetTranslationProperty (const Propertyname:string):WideString;
GetTranslatorNameAndEmailnull281 function GetTranslatorNameAndEmail:widestring;
282
283 // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites()
284 procedure TP_Ignore(AnObject:TObject; const name:string);
285 procedure TP_IgnoreClass (IgnClass:TClass);
286 procedure TP_IgnoreClassProperty (IgnClass:TClass;propertyname:string);
287 procedure TP_GlobalIgnoreClass (IgnClass:TClass);
288 procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
289 procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
290 procedure TranslateProperties(AnObject: TObject; textdomain:string='');
291 procedure TranslateComponent(AnObject: TComponent; const TextDomain:string='');
292 procedure RetranslateComponent(AnObject: TComponent; const TextDomain:string='');
293
294 // Multi-domain functions
295 {$ifdef DELPHI5OROLDER}
dgettextnull296 function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
dngettextnull297 function dngettext(const szDomain: string; const singular,plural:widestring;Number:longint):widestring;
298 {$endif}
299 {$ifndef DELPHI5OROLDER}
dgettextnull300 function dgettext(const szDomain: string; const szMsgId: ansistring): widestring; overload;
dgettextnull301 function dgettext(const szDomain: string; const szMsgId: widestring): widestring; overload;
dngettextnull302 function dngettext(const szDomain: string; const singular,plural:ansistring;Number:longint):widestring; overload;
dngettextnull303 function dngettext(const szDomain: string; const singular,plural:widestring;Number:longint):widestring; overload;
304 {$endif}
305 procedure textdomain(const szDomain: string);
getcurrenttextdomainnull306 function getcurrenttextdomain: string;
307 procedure bindtextdomain(const szDomain: string; const szDirectory: string);
308 procedure bindtextdomainToFile (const szDomain: string; const filename: string); // Also works with files embedded in exe file
309
310 // Windows API functions
LoadResStringnull311 function LoadResString(ResStringRec: PResStringRec): widestring;
312
313 // Output all log info to this file. This may only be called once.
314 procedure DebugLogToFile (const filename:string; append:boolean=false);
315 procedure DebugLogPause (PauseEnabled:boolean);
316 property OnDebugLine: TOnDebugLine read fOnDebugLine write fOnDebugLine; // If set, all debug output goes here
317
318 // Conversion according to design-time character set
ansi2widenull319 function ansi2wide (const s:ansistring):widestring;
320 protected
321 procedure TranslateStrings (sl:TStrings;const TextDomain:string);
322
323 // Override these three, if you want to inherited from this class
324 // to create a new class that handles other domain and language dependent
325 // issues
326 procedure WhenNewLanguage (const LanguageID:string); virtual; // Override to know when language changes
327 procedure WhenNewDomain (const TextDomain:string); virtual; // Override to know when text domain changes. Directory is purely informational
328 procedure WhenNewDomainDirectory (const TextDomain,Directory:string); virtual; // Override to know when any text domain's directory changes. It won't be called if a domain is fixed to a specific file.
329 private
330 curlang: string;
331 curGetPluralForm:TGetPluralForm;
332 curmsgdomain: string;
333 savefileCS: TMultiReadExclusiveWriteSynchronizer;
334 savefile: TextFile;
335 savememory: TStringList;
336 DefaultDomainDirectory:string;
337 domainlist: TStringList; // List of domain names. Objects are TDomain.
338 TP_IgnoreList:TStringList; // Temporary list, reset each time TranslateProperties is called
339 TP_ClassHandling:TList; // Items are TClassMode. If a is derived from b, a comes first
340 TP_GlobalClassHandling:TList; // Items are TClassMode. If a is derived from b, a comes first
341 TP_Retranslator:TExecutable; // Cast this to TTP_Retranslator
342 DebugLogCS:TMultiReadExclusiveWriteSynchronizer;
343 DebugLog:TStream;
344 DebugLogOutputPaused:Boolean;
TP_CreateRetranslatornull345 function TP_CreateRetranslator:TExecutable; // Must be freed by caller!
346 procedure FreeTP_ClassHandlingItems;
347 procedure DebugWriteln(line: ansistring);
348 procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;
349 TodoList: TStrings; const TextDomain:string);
Getdomainnull350 function Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain; // Translates a single property of an object
351 end;
352
353 var
354 DefaultInstance:TGnuGettextInstance;
355
356 implementation
357
358 (**************************************************************************)
359 // Some comments on the implementation:
360 // This unit should be independent of other units where possible.
361 // It should have a small footprint in any way.
362 (**************************************************************************)
363 // TMultiReadExclusiveWriteSynchronizer is used instead of TCriticalSection
364 // because it makes this unit independent of the SyncObjs unit
365 (**************************************************************************)
366
367 {$ifdef DELPHI5OROLDER}
368 uses
369 FileCtrl;
370 {$endif}
371
372 type
373 TTP_RetranslatorItem=
374 class
375 obj:TObject;
376 Propname:string;
377 OldValue:WideString;
378 end;
379 TTP_Retranslator=
380 class (TExecutable)
381 TextDomain:string;
382 Instance:TGnuGettextInstance;
383 constructor Create;
384 destructor Destroy; override;
385 procedure Remember (obj:TObject; PropName:String; OldValue:WideString);
386 procedure Execute; override;
387 private
388 list:TList;
389 end;
390 TEmbeddedFileInfo=
391 class
392 offset,size:int64;
393 end;
394 TFileLocator=
395 class // This class finds files even when embedded inside executable
396 constructor Create;
397 destructor Destroy; override;
398 procedure Analyze; // List files embedded inside executable
FileExistsnull399 function FileExists (filename:string):boolean;
GetMoFilenull400 function GetMoFile (filename:string;DebugLogger:TDebugLogger):TMoFile;
401 procedure ReleaseMoFile (mofile:TMoFile);
402 private
403 basedirectory:string;
404 filelist:TStringList; //Objects are TEmbeddedFileInfo. Filenames are relative to .exe file
405 MoFilesCS:TMultiReadExclusiveWriteSynchronizer;
406 MoFiles:TStringList; // Objects are filenames+offset, objects are TMoFile
ReadInt64null407 function ReadInt64 (str:TStream):int64;
408 end;
409 TGnuGettextComponentMarker=
410 class (TComponent)
411 public
412 LastLanguage:string;
413 Retranslator:TExecutable;
414 destructor Destroy; override;
415 end;
416 TClassMode=
417 class
418 HClass:TClass;
419 SpecialHandler:TTranslator;
420 PropertiesToIgnore:TStringList; // This is ignored if Handler is set
421 constructor Create;
422 destructor Destroy; override;
423 end;
424 TRStrinfo = record
425 strlength, stroffset: cardinal;
426 end;
427 TStrInfoArr = array[0..10000000] of TRStrinfo;
428 PStrInfoArr = ^TStrInfoArr;
429 TCharArray5=array[0..4] of ansichar;
430 THook= // Replaces a runtime library procedure with a custom procedure
431 class
432 public
433 constructor Create (OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);
434 destructor Destroy; override; // Restores unhooked state
435 procedure Reset (FollowJump:boolean=false); // Disables and picks up patch points again
436 procedure Disable;
437 procedure Enable;
438 private
439 oldproc,newproc:Pointer;
440 Patch:TCharArray5;
441 Original:TCharArray5;
442 PatchPosition:PChar;
443 procedure Shutdown; // Same as destroy, except that object is not destroyed
444 end;
445
446 var
447 // System information
448 Win32PlatformIsUnicode:boolean=False;
449
450 // Information about files embedded inside .exe file
451 FileLocator:TFileLocator;
452
453 // Hooks into runtime library functions
454 ResourceStringDomainListCS:TMultiReadExclusiveWriteSynchronizer;
455 ResourceStringDomainList:TStringList;
456 HookLoadResString:THook;
457 HookLoadStr:THook;
458 HookFmtLoadStr:THook;
459
GGGetEnvironmentVariablenull460 function GGGetEnvironmentVariable(const Name:string):string;
461 var
462 Len: integer;
463 W : String;
464 begin
465 Result := '';
466 SetLength(W,1);
467 Len := Windows.GetEnvironmentVariable(PChar(Name), PChar(W), 1);
468 if Len > 0 then begin
469 SetLength(Result, Len - 1);
470 Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), Len);
471 end;
472 end;
473
StripCRnull474 function StripCR (s:string):string;
475 var
476 i:integer;
477 begin
478 i:=1;
479 while i<=length(s) do begin
480 if s[i]=#13 then delete (s,i,1) else inc (i);
481 end;
482 Result:=s;
483 end;
484
LF2LineBreakAnull485 function LF2LineBreakA (s:string):string;
486 {$ifdef MSWINDOWS}
487 var
488 i:integer;
489 {$endif}
490 begin
491 {$ifdef MSWINDOWS}
492 Assert (sLinebreak=#13#10);
493 i:=1;
494 while i<=length(s) do begin
495 if (s[i]=#10) and (copy(s,i-1,1)<>#13) then begin
496 insert (#13,s,i);
497 inc (i,2);
498 end else
499 inc (i);
500 end;
501 {$endif}
502 Result:=s;
503 end;
504
IsWritePropnull505 function IsWriteProp(Info: PPropInfo): Boolean;
506 begin
507 Result := Assigned(Info) and (Info^.SetProc <> nil);
508 end;
509
string2csyntaxnull510 function string2csyntax(s: string): string;
511 // Converts a string to the syntax that is used in .po files
512 var
513 i: integer;
514 c: char;
515 begin
516 Result := '';
517 for i := 1 to length(s) do begin
518 c := s[i];
519 case c of
520 #32..#33, #35..#255: Result := Result + c;
521 #13: Result := Result + '\r';
522 #10: Result := Result + '\n"'#13#10'"';
523 #34: Result := Result + '\"';
524 else
525 Result := Result + '\0x' + IntToHex(ord(c), 2);
526 end;
527 end;
528 Result := '"' + Result + '"';
529 end;
530
ResourceStringGettextnull531 function ResourceStringGettext(MsgId: widestring): widestring;
532 var
533 i:integer;
534 begin
535 if (MsgID='') or (ResourceStringDomainListCS=nil) then begin
536 // This only happens during very complicated program startups that fail,
537 // or when Msgid=''
538 Result:=MsgId;
539 exit;
540 end;
541 ResourceStringDomainListCS.BeginRead;
542 try
543 for i:=0 to ResourceStringDomainList.Count-1 do begin
544 Result:=dgettext(ResourceStringDomainList.Strings[i], MsgId);
545 if Result<>MsgId then
546 break;
547 end;
548 finally
549 ResourceStringDomainListCS.EndRead;
550 end;
551 end;
552
gettextnull553 function gettext(const szMsgId: widestring): widestring;
554 begin
555 Result:=DefaultInstance.gettext(szMsgId);
556 end;
557
_null558 function _(const szMsgId: widestring): widestring;
559 begin
560 Result:=DefaultInstance.gettext(szMsgId);
561 end;
562
dgettextnull563 function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
564 begin
565 Result:=DefaultInstance.dgettext(szDomain, szMsgId);
566 end;
567
dngettextnull568 function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
569 begin
570 Result:=DefaultInstance.dngettext(szDomain,singular,plural,Number);
571 end;
572
ngettextnull573 function ngettext(const singular,plural: widestring; Number:longint): widestring;
574 begin
575 Result:=DefaultInstance.ngettext(singular,plural,Number);
576 end;
577
578 procedure textdomain(const szDomain: string);
579 begin
580 DefaultInstance.textdomain(szDomain);
581 end;
582
583 procedure SetGettextEnabled (enabled:boolean);
584 begin
585 DefaultInstance.Enabled:=enabled;
586 end;
587
getcurrenttextdomainnull588 function getcurrenttextdomain: string;
589 begin
590 Result:=DefaultInstance.getcurrenttextdomain;
591 end;
592
593 procedure bindtextdomain(const szDomain: string; const szDirectory: string);
594 begin
595 DefaultInstance.bindtextdomain(szDomain, szDirectory);
596 end;
597
598 procedure TP_Ignore(AnObject:TObject; const name:string);
599 begin
600 DefaultInstance.TP_Ignore(AnObject, name);
601 end;
602
603 procedure TP_GlobalIgnoreClass (IgnClass:TClass);
604 begin
605 DefaultInstance.TP_GlobalIgnoreClass(IgnClass);
606 end;
607
608 procedure TP_IgnoreClass (IgnClass:TClass);
609 begin
610 DefaultInstance.TP_IgnoreClass(IgnClass);
611 end;
612
613 procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:string);
614 begin
615 DefaultInstance.TP_IgnoreClassProperty(IgnClass,propertyname);
616 end;
617
618 procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:string);
619 begin
620 DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass,propertyname);
621 end;
622
623 procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
624 begin
625 DefaultInstance.TP_GlobalHandleClass (HClass, Handler);
626 end;
627
628 procedure TranslateComponent(AnObject: TComponent; const TextDomain:string='');
629 begin
630 DefaultInstance.TranslateComponent(AnObject, TextDomain);
631 end;
632
633 procedure RetranslateComponent(AnObject: TComponent; const TextDomain:string='');
634 begin
635 DefaultInstance.RetranslateComponent(AnObject, TextDomain);
636 end;
637
638 {$ifdef MSWINDOWS}
639
640 // These constants are only used in Windows 95
641 // Thanks to Frank Andreas de Groot for this table
642 const
643 IDAfrikaans = $0436; IDAlbanian = $041C;
644 IDArabicAlgeria = $1401; IDArabicBahrain = $3C01;
645 IDArabicEgypt = $0C01; IDArabicIraq = $0801;
646 IDArabicJordan = $2C01; IDArabicKuwait = $3401;
647 IDArabicLebanon = $3001; IDArabicLibya = $1001;
648 IDArabicMorocco = $1801; IDArabicOman = $2001;
649 IDArabicQatar = $4001; IDArabic = $0401;
650 IDArabicSyria = $2801; IDArabicTunisia = $1C01;
651 IDArabicUAE = $3801; IDArabicYemen = $2401;
652 IDArmenian = $042B; IDAssamese = $044D;
653 IDAzeriCyrillic = $082C; IDAzeriLatin = $042C;
654 IDBasque = $042D; IDByelorussian = $0423;
655 IDBengali = $0445; IDBulgarian = $0402;
656 IDBurmese = $0455; IDCatalan = $0403;
657 IDChineseHongKong = $0C04; IDChineseMacao = $1404;
658 IDSimplifiedChinese = $0804; IDChineseSingapore = $1004;
659 IDTraditionalChinese = $0404; IDCroatian = $041A;
660 IDCzech = $0405; IDDanish = $0406;
661 IDBelgianDutch = $0813; IDDutch = $0413;
662 IDEnglishAUS = $0C09; IDEnglishBelize = $2809;
663 IDEnglishCanadian = $1009; IDEnglishCaribbean = $2409;
664 IDEnglishIreland = $1809; IDEnglishJamaica = $2009;
665 IDEnglishNewZealand = $1409; IDEnglishPhilippines = $3409;
666 IDEnglishSouthAfrica = $1C09; IDEnglishTrinidad = $2C09;
667 IDEnglishUK = $0809; IDEnglishUS = $0409;
668 IDEnglishZimbabwe = $3009; IDEstonian = $0425;
669 IDFaeroese = $0438; IDFarsi = $0429;
670 IDFinnish = $040B; IDBelgianFrench = $080C;
671 IDFrenchCameroon = $2C0C; IDFrenchCanadian = $0C0C;
672 IDFrenchCotedIvoire = $300C; IDFrench = $040C;
673 IDFrenchLuxembourg = $140C; IDFrenchMali = $340C;
674 IDFrenchMonaco = $180C; IDFrenchReunion = $200C;
675 IDFrenchSenegal = $280C; IDSwissFrench = $100C;
676 IDFrenchWestIndies = $1C0C; IDFrenchZaire = $240C;
677 IDFrisianNetherlands = $0462; IDGaelicIreland = $083C;
678 IDGaelicScotland = $043C; IDGalician = $0456;
679 IDGeorgian = $0437; IDGermanAustria = $0C07;
680 IDGerman = $0407; IDGermanLiechtenstein = $1407;
681 IDGermanLuxembourg = $1007; IDSwissGerman = $0807;
682 IDGreek = $0408; IDGujarati = $0447;
683 IDHebrew = $040D; IDHindi = $0439;
684 IDHungarian = $040E; IDIcelandic = $040F;
685 IDIndonesian = $0421; IDItalian = $0410;
686 IDSwissItalian = $0810; IDJapanese = $0411;
687 IDKannada = $044B; IDKashmiri = $0460;
688 IDKazakh = $043F; IDKhmer = $0453;
689 IDKirghiz = $0440; IDKonkani = $0457;
690 IDKorean = $0412; IDLao = $0454;
691 IDLatvian = $0426; IDLithuanian = $0427;
692 IDMacedonian = $042F; IDMalaysian = $043E;
693 IDMalayBruneiDarussalam = $083E; IDMalayalam = $044C;
694 IDMaltese = $043A; IDManipuri = $0458;
695 IDMarathi = $044E; IDMongolian = $0450;
696 IDNepali = $0461; IDNorwegianBokmol = $0414;
697 IDNorwegianNynorsk = $0814; IDOriya = $0448;
698 IDPolish = $0415; IDBrazilianPortuguese = $0416;
699 IDPortuguese = $0816; IDPunjabi = $0446;
700 IDRhaetoRomanic = $0417; IDRomanianMoldova = $0818;
701 IDRomanian = $0418; IDRussianMoldova = $0819;
702 IDRussian = $0419; IDSamiLappish = $043B;
703 IDSanskrit = $044F; IDSerbianCyrillic = $0C1A;
704 IDSerbianLatin = $081A; IDSesotho = $0430;
705 IDSindhi = $0459; IDSlovak = $041B;
706 IDSlovenian = $0424; IDSorbian = $042E;
707 IDSpanishArgentina = $2C0A; IDSpanishBolivia = $400A;
708 IDSpanishChile = $340A; IDSpanishColombia = $240A;
709 IDSpanishCostaRica = $140A; IDSpanishDominicanRepublic = $1C0A;
710 IDSpanishEcuador = $300A; IDSpanishElSalvador = $440A;
711 IDSpanishGuatemala = $100A; IDSpanishHonduras = $480A;
712 IDMexicanSpanish = $080A; IDSpanishNicaragua = $4C0A;
713 IDSpanishPanama = $180A; IDSpanishParaguay = $3C0A;
714 IDSpanishPeru = $280A; IDSpanishPuertoRico = $500A;
715 IDSpanishModernSort = $0C0A; IDSpanish = $040A;
716 IDSpanishUruguay = $380A; IDSpanishVenezuela = $200A;
717 IDSutu = $0430; IDSwahili = $0441;
718 IDSwedishFinland = $081D; IDSwedish = $041D;
719 IDTajik = $0428; IDTamil = $0449;
720 IDTatar = $0444; IDTelugu = $044A;
721 IDThai = $041E; IDTibetan = $0451;
722 IDTsonga = $0431; IDTswana = $0432;
723 IDTurkish = $041F; IDTurkmen = $0442;
724 IDUkrainian = $0422; IDUrdu = $0420;
725 IDUzbekCyrillic = $0843; IDUzbekLatin = $0443;
726 IDVenda = $0433; IDVietnamese = $042A;
727 IDWelsh = $0452; IDXhosa = $0434;
728 IDZulu = $0435;
729
GetWindowsLanguagenull730 function GetWindowsLanguage: string;
731 var
732 langid: Cardinal;
733 langcode: string;
734 CountryName: array[0..4] of char;
735 LanguageName: array[0..4] of char;
736 works: boolean;
737 begin
738 // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero
739 works := 3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName));
740 works := works and (3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName,
741 SizeOf(CountryName)));
742 if works then begin
743 // Windows 98, Me, NT4, 2000, XP and newer
744 LangCode := PChar(@LanguageName[0]);
745 if lowercase(LangCode)='no' then LangCode:='nb';
746 LangCode:=LangCode + '_' + PChar(@CountryName[0]);
747 end else begin
748 // This part should only happen on Windows 95.
749 langid := GetThreadLocale;
750 case langid of
751 IDBelgianDutch: langcode := 'nl_BE';
752 IDBelgianFrench: langcode := 'fr_BE';
753 IDBrazilianPortuguese: langcode := 'pt_BR';
754 IDDanish: langcode := 'da_DK';
755 IDDutch: langcode := 'nl_NL';
756 IDEnglishUK: langcode := 'en_GB';
757 IDEnglishUS: langcode := 'en_US';
758 IDFinnish: langcode := 'fi_FI';
759 IDFrench: langcode := 'fr_FR';
760 IDFrenchCanadian: langcode := 'fr_CA';
761 IDGerman: langcode := 'de_DE';
762 IDGermanLuxembourg: langcode := 'de_LU';
763 IDGreek: langcode := 'el_GR';
764 IDIcelandic: langcode := 'is_IS';
765 IDItalian: langcode := 'it_IT';
766 IDKorean: langcode := 'ko_KO';
767 IDNorwegianBokmol: langcode := 'nb_NO';
768 IDNorwegianNynorsk: langcode := 'nn_NO';
769 IDPolish: langcode := 'pl_PL';
770 IDPortuguese: langcode := 'pt_PT';
771 IDRussian: langcode := 'ru_RU';
772 IDSpanish, IDSpanishModernSort: langcode := 'es_ES';
773 IDSwedish: langcode := 'sv_SE';
774 IDSwedishFinland: langcode := 'sv_FI';
775 else
776 langcode := 'C';
777 end;
778 end;
779 Result := langcode;
780 end;
781 {$endif}
782
LoadResStringAnull783 function LoadResStringA(ResStringRec: PResStringRec): string;
784 begin
785 Result:=DefaultInstance.LoadResString(ResStringRec);
786 end;
787
GetTranslatorNameAndEmailnull788 function GetTranslatorNameAndEmail:widestring;
789 begin
790 Result:=DefaultInstance.GetTranslatorNameAndEmail;
791 end;
792
793 procedure UseLanguage(LanguageCode: string);
794 begin
795 DefaultInstance.UseLanguage(LanguageCode);
796 end;
797
798 type
799 PStrData = ^TStrData;
800 TStrData = record
801 Ident: Integer;
802 Str: string;
803 end;
804
SysUtilsEnumStringModulesnull805 function SysUtilsEnumStringModules(Instance: Longint; Data: Pointer): Boolean;
806 {$IFDEF MSWINDOWS}
807 var
808 Buffer: array [0..1023] of char;
809 begin
810 with PStrData(Data)^ do begin
811 SetString(Str, Buffer,
812 LoadString(Instance, Ident, Buffer, sizeof(Buffer)));
813 Result := Str = '';
814 end;
815 end;
816 {$ENDIF}
817 {$IFDEF LINUX}
818 var
819 rs:TResStringRec;
820 Module:HModule;
821 begin
822 Module:=Instance;
823 rs.Module:=@Module;
824 with PStrData(Data)^ do begin
825 rs.Identifier:=Ident;
826 Str:=System.LoadResString(@rs);
827 Result:=Str='';
828 end;
829 end;
830 {$ENDIF}
831
SysUtilsFindStringResourcenull832 function SysUtilsFindStringResource(Ident: Integer): string;
833 var
834 StrData: TStrData;
835 begin
836 StrData.Ident := Ident;
837 StrData.Str := '';
838 EnumResourceModules(SysUtilsEnumStringModules, @StrData);
839 Result := StrData.Str;
840 end;
841
SysUtilsLoadStrnull842 function SysUtilsLoadStr(Ident: Integer): string;
843 begin
844 {$ifdef DXGETTEXTDEBUG}
845 DefaultInstance.DebugWriteln ('Sysutils.LoadRes('+IntToStr(ident)+') called');
846 {$endif}
847 Result := ResourceStringGettext(SysUtilsFindStringResource(Ident));
848 end;
849
SysUtilsFmtLoadStrnull850 function SysUtilsFmtLoadStr(Ident: Integer; const Args: array of const): string;
851 begin
852 {$ifdef DXGETTEXTDEBUG}
853 DefaultInstance.DebugWriteln ('Sysutils.FmtLoadRes('+IntToStr(ident)+',Args) called');
854 {$endif}
855 FmtStr(Result, SysUtilsFindStringResource(Ident), Args);
856 Result:=ResourceStringGettext(Result);
857 end;
858
LoadResStringnull859 function LoadResString(ResStringRec: PResStringRec): widestring;
860 begin
861 Result:=DefaultInstance.LoadResString(ResStringRec);
862 end;
863
LoadResStringWnull864 function LoadResStringW(ResStringRec: PResStringRec): widestring;
865 begin
866 Result:=DefaultInstance.LoadResString(ResStringRec);
867 end;
868
869
870
GetCurrentLanguagenull871 function GetCurrentLanguage:string;
872 begin
873 Result:=DefaultInstance.GetCurrentLanguage;
874 end;
875
876 { TDomain }
877
878 procedure TDomain.CloseMoFile;
879 begin
880 if mofile<>nil then begin
881 FileLocator.ReleaseMoFile(mofile);
882 mofile:=nil;
883 end;
884 OpenHasFailedBefore:=False;
885 end;
886
887 destructor TDomain.Destroy;
888 begin
889 CloseMoFile;
890 inherited;
891 end;
892
893 {$ifdef mswindows}
GetLastWinErrornull894 function GetLastWinError:string;
895 var
896 errcode:Cardinal;
897 begin
898 SetLength (Result,2000);
899 errcode:=GetLastError();
900 Windows.FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PChar(Result),2000,nil);
901 Result:=StrPas(PChar(Result));
902 end;
903 {$endif}
904
905 procedure TDomain.OpenMoFile;
906 var
907 filename: string;
908 begin
909 // Check if it is already open
910 if mofile<>nil then
911 exit;
912
913 // Check if it has been attempted to open the file before
914 if OpenHasFailedBefore then
915 exit;
916
917 if SpecificFilename<>'' then
918 filename:=SpecificFilename
919 else begin
920 filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
921 if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then
922 filename := Directory + copy(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
923 end;
924 if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin
925 OpenHasFailedBefore:=True;
926 exit;
927 end;
928 mofile:=FileLocator.GetMoFile(filename, DebugLogger);
929
930 {$ifdef DXGETTEXTDEBUG}
931 if mofile.isSwappedArchitecture then
932 DebugLogger ('.mo file is swapped (comes from another CPU architecture)');
933 {$endif}
934
935 // Check, that the contents of the file is utf-8
936 if pos('CHARSET=UTF-8',uppercase(GetTranslationProperty('Content-Type')))=0 then begin
937 CloseMoFile;
938 {$ifdef DXGETTEXTDEBUG}
939 DebugLogger ('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.');
940 {$endif}
941 {$ifdef MSWINDOWS}
942 MessageBox(0,PChar('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.'),'Localization problem',MB_OK);
943 {$else}
944 writeln (stderr,'The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.');
945 {$endif}
946 Enabled:=False;
947 end;
948 end;
949
GetTranslationPropertynull950 function TDomain.GetTranslationProperty(
951 Propertyname: string): WideString;
952 var
953 sl:TStringList;
954 i:integer;
955 s:string;
956 begin
957 Propertyname:=uppercase(Propertyname)+': ';
958 sl:=TStringList.Create;
959 try
960 sl.Text:=utf8encode(gettext(''));
961 for i:=0 to sl.Count-1 do begin
962 s:=sl.Strings[i];
963 if uppercase(copy(s,1,length(Propertyname)))=Propertyname then begin
964 Result:=utf8decode(trim(copy(s,length(PropertyName)+1,maxint)));
965 {$ifdef DXGETTEXTDEBUG}
966 DebugLogger ('GetTranslationProperty('+PropertyName+') returns '''+Result+'''.');
967 {$endif}
968 exit;
969 end;
970 end;
971 finally
972 FreeAndNil (sl);
973 end;
974 Result:='';
975 {$ifdef DXGETTEXTDEBUG}
976 DebugLogger ('GetTranslationProperty('+PropertyName+') did not find any value. An empty string is returned.');
977 {$endif}
978 end;
979
980 procedure TDomain.setDirectory(const dir: string);
981 begin
982 vDirectory := IncludeTrailingPathDelimiter(dir);
983 SpecificFilename:='';
984 CloseMoFile;
985 end;
986
987 procedure AddDomainForResourceString (const domain:string);
988 begin
989 {$ifdef DXGETTEXTDEBUG}
990 DefaultInstance.DebugWriteln ('Extra domain for resourcestring: '+domain);
991 {$endif}
992 ResourceStringDomainListCS.BeginWrite;
993 try
994 if ResourceStringDomainList.IndexOf(domain)=-1 then
995 ResourceStringDomainList.Add (domain);
996 finally
997 ResourceStringDomainListCS.EndWrite;
998 end;
999 end;
1000
1001 procedure RemoveDomainForResourceString (const domain:string);
1002 var
1003 i:integer;
1004 begin
1005 {$ifdef DXGETTEXTDEBUG}
1006 DefaultInstance.DebugWriteln ('Remove domain for resourcestring: '+domain);
1007 {$endif}
1008 ResourceStringDomainListCS.BeginWrite;
1009 try
1010 i:=ResourceStringDomainList.IndexOf(domain);
1011 if i<>-1 then
1012 ResourceStringDomainList.Delete (i);
1013 finally
1014 ResourceStringDomainListCS.EndWrite;
1015 end;
1016 end;
1017
1018 procedure TDomain.SetLanguageCode(const langcode: string);
1019 begin
1020 CloseMoFile;
1021 curlang:=langcode;
1022 end;
1023
GetPluralForm2ENnull1024 function GetPluralForm2EN(Number: Integer): Integer;
1025 begin
1026 Number:=abs(Number);
1027 if Number=1 then Result:=0 else Result:=1;
1028 end;
1029
GetPluralForm1null1030 function GetPluralForm1(Number: Integer): Integer;
1031 begin
1032 Result:=0;
1033 end;
1034
GetPluralForm2FRnull1035 function GetPluralForm2FR(Number: Integer): Integer;
1036 begin
1037 Number:=abs(Number);
1038 if (Number=1) or (Number=0) then Result:=0 else Result:=1;
1039 end;
1040
GetPluralForm3LVnull1041 function GetPluralForm3LV(Number: Integer): Integer;
1042 begin
1043 Number:=abs(Number);
1044 if (Number mod 10=1) and (Number mod 100<>11) then
1045 Result:=0
1046 else
1047 if Number<>0 then Result:=1
1048 else Result:=2;
1049 end;
1050
GetPluralForm3GAnull1051 function GetPluralForm3GA(Number: Integer): Integer;
1052 begin
1053 Number:=abs(Number);
1054 if Number=1 then Result:=0
1055 else if Number=2 then Result:=1
1056 else Result:=2;
1057 end;
1058
GetPluralForm3LTnull1059 function GetPluralForm3LT(Number: Integer): Integer;
1060 var
1061 n1,n2:byte;
1062 begin
1063 Number:=abs(Number);
1064 n1:=Number mod 10;
1065 n2:=Number mod 100;
1066 if (n1=1) and (n2<>11) then
1067 Result:=0
1068 else
1069 if (n1>=2) and ((n2<10) or (n2>=20)) then Result:=1
1070 else Result:=2;
1071 end;
1072
GetPluralForm3PLnull1073 function GetPluralForm3PL(Number: Integer): Integer;
1074 var
1075 n1,n2:byte;
1076 begin
1077 Number:=abs(Number);
1078 n1:=Number mod 10;
1079 n2:=Number mod 100;
1080 if n1=1 then Result:=0
1081 else if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
1082 else Result:=2;
1083 end;
1084
GetPluralForm3RUnull1085 function GetPluralForm3RU(Number: Integer): Integer;
1086 var
1087 n1,n2:byte;
1088 begin
1089 Number:=abs(Number);
1090 n1:=Number mod 10;
1091 n2:=Number mod 100;
1092 if (n1=1) and (n2<>11) then
1093 Result:=0
1094 else
1095 if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
1096 else Result:=2;
1097 end;
1098
GetPluralForm4SLnull1099 function GetPluralForm4SL(Number: Integer): Integer;
1100 var
1101 n2:byte;
1102 begin
1103 Number:=abs(Number);
1104 n2:=Number mod 100;
1105 if n2=1 then Result:=0
1106 else
1107 if n2=2 then Result:=1
1108 else
1109 if (n2=3) or (n2=4) then Result:=2
1110 else
1111 Result:=3;
1112 end;
1113
1114 procedure TDomain.GetListOfLanguages(list: TStrings);
1115 var
1116 sr:TSearchRec;
1117 more:boolean;
1118 filename, path, langcode:string;
1119 i, j:integer;
1120 begin
1121 list.Clear;
1122
1123 // Iterate through filesystem
1124 more:=FindFirst (Directory+'*',faAnyFile,sr)=0;
1125 while more do begin
1126 if (sr.Attr and faDirectory<>0) and (sr.name<>'.') and (sr.name<>'..') then begin
1127 filename := Directory + sr.Name + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
1128 if fileexists(filename) then begin
1129 langcode:=lowercase(sr.name);
1130 if list.IndexOf(langcode)=-1 then
1131 list.Add(langcode);
1132 end;
1133 end;
1134 more:=FindNext (sr)=0;
1135 end;
1136
1137 // Iterate through embedded files
1138 for i:=0 to FileLocator.filelist.Count-1 do begin
1139 filename:=FileLocator.basedirectory+FileLocator.filelist.Strings[i];
1140 path:=Directory;
1141 {$ifdef MSWINDOWS}
1142 path:=uppercase(path);
1143 filename:=uppercase(filename);
1144 {$endif}
1145 j:=length(path);
1146 if copy(filename,1,j)=path then begin
1147 path:=PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
1148 {$ifdef MSWINDOWS}
1149 path:=uppercase(path);
1150 {$endif}
1151 if copy(filename,length(filename)-length(path)+1,length(path))=path then begin
1152 langcode:=lowercase(copy(filename,j+1,length(filename)-length(path)-j));
1153 if list.IndexOf(langcode)=-1 then
1154 list.Add(langcode);
1155 end;
1156 end;
1157 end;
1158 end;
1159
1160 procedure TDomain.SetFilename(const filename: string);
1161 begin
1162 CloseMoFile;
1163 vDirectory := '';
1164 SpecificFilename:=filename;
1165 end;
1166
gettextnull1167 function TDomain.gettext(const msgid: ansistring): ansistring;
1168 var
1169 found:boolean;
1170 begin
1171 if not Enabled then begin
1172 Result:=msgid;
1173 exit;
1174 end;
1175 if (mofile=nil) and (not OpenHasFailedBefore) then
1176 OpenMoFile;
1177 if mofile=nil then begin
1178 {$ifdef DXGETTEXTDEBUG}
1179 DebugLogger('.mo file is not open. Not translating "'+msgid+'"');
1180 {$endif}
1181 Result := msgid;
1182 end else begin
1183 Result:=mofile.gettext(msgid,found);
1184 {$ifdef DXGETTEXTDEBUG}
1185 if found then
1186 DebugLogger ('Found in .mo ('+Domain+'): "'+utf8encode(msgid)+'"->"'+utf8encode(Result)+'"')
1187 else
1188 DebugLogger ('Translation not found in .mo file ('+Domain+') : "'+utf8encode(msgid)+'"');
1189 {$endif}
1190 end;
1191 end;
1192
1193 constructor TDomain.Create;
1194 begin
1195 inherited Create;
1196 Enabled:=True;
1197 end;
1198
1199 { TGnuGettextInstance }
1200
1201 procedure TGnuGettextInstance.bindtextdomain(const szDomain,
1202 szDirectory: string);
1203 var
1204 dir:string;
1205 begin
1206 dir:=IncludeTrailingPathDelimiter(szDirectory);
1207 {$ifdef DXGETTEXTDEBUG}
1208 DebugWriteln ('Text domain "'+szDomain+'" is now located at "'+dir+'"');
1209 {$endif}
1210 getdomain(szDomain,DefaultDomainDirectory,CurLang).Directory := dir;
1211 WhenNewDomainDirectory (szDomain, szDirectory);
1212 end;
1213
1214 constructor TGnuGettextInstance.Create;
1215 begin
1216 CreatorThread:=GetCurrentThreadId;
1217 {$ifdef MSWindows}
1218 DesignTimeCodePage:=CP_ACP;
1219 {$endif}
1220 {$ifdef DXGETTEXTDEBUG}
1221 DebugLogCS:=TMultiReadExclusiveWriteSynchronizer.Create;
1222 DebugLog:=TMemoryStream.Create;
1223 DebugWriteln('Debug log started '+DateTimeToStr(Now));
1224 DebugWriteln('');
1225 {$endif}
1226 curGetPluralForm:=GetPluralForm2EN;
1227 Enabled:=True;
1228 curmsgdomain:=DefaultTextDomain;
1229 savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;
1230 domainlist := TStringList.Create;
1231 TP_IgnoreList:=TStringList.Create;
1232 TP_IgnoreList.Sorted:=True;
1233 TP_GlobalClassHandling:=TList.Create;
1234 TP_ClassHandling:=TList.Create;
1235
1236 // Set some settings
1237 DefaultDomainDirectory := IncludeTrailingPathDelimiter(extractfilepath(ExecutableFilename))+'locale';
1238
1239 UseLanguage('');
1240
1241 bindtextdomain(DefaultTextDomain, DefaultDomainDirectory);
1242 textdomain(DefaultTextDomain);
1243
1244 // Add default properties to ignore
1245 TP_GlobalIgnoreClassProperty(TComponent,'Name');
1246 TP_GlobalIgnoreClassProperty(TCollection,'PropName');
1247 end;
1248
1249 destructor TGnuGettextInstance.Destroy;
1250 begin
1251 if savememory <> nil then begin
1252 savefileCS.BeginWrite;
1253 try
1254 CloseFile(savefile);
1255 finally
1256 savefileCS.EndWrite;
1257 end;
1258 FreeAndNil(savememory);
1259 end;
1260 FreeAndNil (savefileCS);
1261 FreeAndNil (TP_IgnoreList);
1262 while TP_GlobalClassHandling.Count<>0 do begin
1263 TObject(TP_GlobalClassHandling.Items[0]).Free;
1264 TP_GlobalClassHandling.Delete(0);
1265 end;
1266 FreeAndNil (TP_GlobalClassHandling);
1267 FreeTP_ClassHandlingItems;
1268 FreeAndNil (TP_ClassHandling);
1269 while domainlist.Count <> 0 do begin
1270 domainlist.Objects[0].Free;
1271 domainlist.Delete(0);
1272 end;
1273 FreeAndNil(domainlist);
1274 {$ifdef DXGETTEXTDEBUG}
1275 FreeAndNil (DebugLog);
1276 FreeAndNil (DebugLogCS);
1277 {$endif}
1278 inherited;
1279 end;
1280
1281 {$ifndef DELPHI5OROLDER}
dgettextnull1282 function TGnuGettextInstance.dgettext(const szDomain: string; const szMsgId: ansistring): widestring;
1283 begin
1284 Result:=dgettext(szDomain, ansi2wide(szMsgId));
1285 end;
1286 {$endif}
1287
dgettextnull1288 function TGnuGettextInstance.dgettext(const szDomain: string;
1289 const szMsgId: widestring): widestring;
1290 begin
1291 if not Enabled then begin
1292 {$ifdef DXGETTEXTDEBUG}
1293 DebugWriteln ('Translation has been disabled. Text is not being translated: '+szMsgid);
1294 {$endif}
1295 Result:=szMsgId;
1296 end else begin
1297 Result:=UTF8Decode(LF2LineBreakA(getdomain(szDomain,DefaultDomainDirectory,CurLang).gettext(StripCR(utf8encode(szMsgId)))));
1298 {$ifdef DXGETTEXTDEBUG}
1299 if (szMsgId<>'') and (Result='') then
1300 DebugWriteln (Format('Error: Translation of %s was an empty string. This may never occur.',[szMsgId]));
1301 {$endif}
1302 end;
1303 end;
1304
GetCurrentLanguagenull1305 function TGnuGettextInstance.GetCurrentLanguage: string;
1306 begin
1307 Result:=curlang;
1308 end;
1309
getcurrenttextdomainnull1310 function TGnuGettextInstance.getcurrenttextdomain: string;
1311 begin
1312 Result := curmsgdomain;
1313 end;
1314
1315 {$ifndef DELPHI5OROLDER}
gettextnull1316 function TGnuGettextInstance.gettext(
1317 const szMsgId: ansistring): widestring;
1318 begin
1319 Result := dgettext(curmsgdomain, szMsgId);
1320 end;
1321 {$endif}
1322
gettextnull1323 function TGnuGettextInstance.gettext(
1324 const szMsgId: widestring): widestring;
1325 begin
1326 Result := dgettext(curmsgdomain, szMsgId);
1327 end;
1328
1329 procedure TGnuGettextInstance.textdomain(const szDomain: string);
1330 begin
1331 {$ifdef DXGETTEXTDEBUG}
1332 DebugWriteln ('Changed text domain to "'+szDomain+'"');
1333 {$endif}
1334 curmsgdomain := szDomain;
1335 WhenNewDomain (szDomain);
1336 end;
1337
TGnuGettextInstance.TP_CreateRetranslatornull1338 function TGnuGettextInstance.TP_CreateRetranslator : TExecutable;
1339 var
1340 ttpr:TTP_Retranslator;
1341 begin
1342 ttpr:=TTP_Retranslator.Create;
1343 ttpr.Instance:=self;
1344 TP_Retranslator:=ttpr;
1345 Result:=ttpr;
1346 {$ifdef DXGETTEXTDEBUG}
1347 DebugWriteln ('A retranslator was created.');
1348 {$endif}
1349 end;
1350
1351 procedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass;
1352 Handler: TTranslator);
1353 var
1354 cm:TClassMode;
1355 i:integer;
1356 begin
1357 for i:=0 to TP_GlobalClassHandling.Count-1 do begin
1358 cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
1359 if cm.HClass=HClass then
1360 raise EGGProgrammingError.Create ('You cannot set a handler for a class that has already been assigned otherwise.');
1361 if HClass.InheritsFrom(cm.HClass) then begin
1362 // This is the place to insert this class
1363 cm:=TClassMode.Create;
1364 cm.HClass:=HClass;
1365 cm.SpecialHandler:=Handler;
1366 TP_GlobalClassHandling.Insert(i,cm);
1367 {$ifdef DXGETTEXTDEBUG}
1368 DebugWriteln ('A handler was set for class '+HClass.ClassName+'.');
1369 {$endif}
1370 exit;
1371 end;
1372 end;
1373 cm:=TClassMode.Create;
1374 cm.HClass:=HClass;
1375 cm.SpecialHandler:=Handler;
1376 TP_GlobalClassHandling.Add(cm);
1377 {$ifdef DXGETTEXTDEBUG}
1378 DebugWriteln ('A handler was set for class '+HClass.ClassName+'.');
1379 {$endif}
1380 end;
1381
1382 procedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass);
1383 var
1384 cm:TClassMode;
1385 i:integer;
1386 begin
1387 for i:=0 to TP_GlobalClassHandling.Count-1 do begin
1388 cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
1389 if cm.HClass=IgnClass then
1390 raise EGGProgrammingError.Create ('You cannot add a class to the ignore list that is already on that list: '+IgnClass.ClassName+'. You should keep all TP_Global functions in one place in your source code.');
1391 if IgnClass.InheritsFrom(cm.HClass) then begin
1392 // This is the place to insert this class
1393 cm:=TClassMode.Create;
1394 cm.HClass:=IgnClass;
1395 TP_GlobalClassHandling.Insert(i,cm);
1396 {$ifdef DXGETTEXTDEBUG}
1397 DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');
1398 {$endif}
1399 exit;
1400 end;
1401 end;
1402 cm:=TClassMode.Create;
1403 cm.HClass:=IgnClass;
1404 TP_GlobalClassHandling.Add(cm);
1405 {$ifdef DXGETTEXTDEBUG}
1406 DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');
1407 {$endif}
1408 end;
1409
1410 procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(
1411 IgnClass: TClass; propertyname: string);
1412 var
1413 cm:TClassMode;
1414 i,idx:integer;
1415 begin
1416 propertyname:=uppercase(propertyname);
1417 for i:=0 to TP_GlobalClassHandling.Count-1 do begin
1418 cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
1419 if cm.HClass=IgnClass then begin
1420 if Assigned(cm.SpecialHandler) then
1421 raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.');
1422 if not cm.PropertiesToIgnore.Find(propertyname,idx) then
1423 cm.PropertiesToIgnore.Add(propertyname);
1424 {$ifdef DXGETTEXTDEBUG}
1425 DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
1426 {$endif}
1427 exit;
1428 end;
1429 if IgnClass.InheritsFrom(cm.HClass) then begin
1430 // This is the place to insert this class
1431 cm:=TClassMode.Create;
1432 cm.HClass:=IgnClass;
1433 cm.PropertiesToIgnore.Add(propertyname);
1434 TP_GlobalClassHandling.Insert(i,cm);
1435 {$ifdef DXGETTEXTDEBUG}
1436 DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
1437 {$endif}
1438 exit;
1439 end;
1440 end;
1441 cm:=TClassMode.Create;
1442 cm.HClass:=IgnClass;
1443 cm.PropertiesToIgnore.Add(propertyname);
1444 TP_GlobalClassHandling.Add(cm);
1445 {$ifdef DXGETTEXTDEBUG}
1446 DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
1447 {$endif}
1448 end;
1449
1450 procedure TGnuGettextInstance.TP_Ignore(AnObject: TObject;
1451 const name: string);
1452 begin
1453 TP_IgnoreList.Add(uppercase(name));
1454 {$ifdef DXGETTEXTDEBUG}
1455 DebugWriteln ('On object with class name '+AnObject.ClassName+', ignore is set on '+name);
1456 {$endif}
1457 end;
1458
1459 procedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent;
1460 const TextDomain: string);
1461 var
1462 comp:TGnuGettextComponentMarker;
1463 begin
1464 {$ifdef DXGETTEXTDEBUG}
1465 DebugWriteln ('======================================================================');
1466 DebugWriteln ('TranslateComponent() was called for a component with name '+AnObject.Name+'.');
1467 {$endif}
1468 comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
1469 if comp=nil then begin
1470 comp:=TGnuGettextComponentMarker.Create (nil);
1471 comp.Name:='GNUgettextMarker';
1472 comp.Retranslator:=TP_CreateRetranslator;
1473 TranslateProperties (AnObject, TextDomain);
1474 AnObject.InsertComponent(comp);
1475 {$ifdef DXGETTEXTDEBUG}
1476 DebugWriteln ('This is the first time, that this component has been translated. A retranslator component has been created for this component.');
1477 {$endif}
1478 end else begin
1479 {$ifdef DXGETTEXTDEBUG}
1480 DebugWriteln ('This is not the first time, that this component has been translated.');
1481 {$endif}
1482 if comp.LastLanguage<>curlang then begin
1483 {$ifdef DXGETTEXTDEBUG}
1484 DebugWriteln ('ERROR: TranslateComponent() was called twice with different languages. This indicates an attempt to switch language at runtime, but by using TranslateComponent every time. This API has changed - please use RetranslateComponent() instead.');
1485 {$endif}
1486 {$ifdef mswindows}
1487 MessageBox (0,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.','Error',MB_OK);
1488 {$else}
1489 writeln (stderr,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.');
1490 {$endif}
1491 end else begin
1492 {$ifdef DXGETTEXTDEBUG}
1493 DebugWriteln ('ERROR: TranslateComponent has been called twice, but with the same language chosen. This is a mistake, but in order to prevent that the application breaks, no exception is raised.');
1494 {$endif}
1495 end;
1496 end;
1497 comp.LastLanguage:=curlang;
1498 {$ifdef DXGETTEXTDEBUG}
1499 DebugWriteln ('======================================================================');
1500 {$endif}
1501 end;
1502
1503 procedure TGnuGettextInstance.TranslateProperty (AnObject:TObject; PropInfo:PPropInfo; TodoList:TStrings; const TextDomain:string);
1504 var
1505 {$ifdef DELPHI5OROLDER}
1506 ws: string;
1507 old: string;
1508 {$endif}
1509 {$ifndef DELPHI5OROLDER}
1510 ppi:PPropInfo;
1511 ws: WideString;
1512 old: WideString;
1513 {$endif}
1514 obj:TObject;
1515 Propname:string;
1516 begin
1517 PropName:=PropInfo^.Name;
1518 try
1519 // Translate certain types of properties
1520 case PropInfo^.PropType^.Kind of
1521 tkString, tkLString, tkWString:
1522 begin
1523 {$ifdef DXGETTEXTDEBUG}
1524 DebugWriteln ('Translating '+AnObject.ClassName+'.'+PropName);
1525 {$endif}
1526 {$ifdef DELPHI5OROLDER}
1527 old := GetStrProp(AnObject, PropName);
1528 {$endif}
1529 {$ifndef DELPHI5OROLDER}
1530 if PropInfo^.PropType^.Kind<>tkWString then
1531 old := ansi2wide(GetStrProp(AnObject, PropName))
1532 else
1533 old := GetWideStrProp(AnObject, PropName);
1534 {$endif}
1535 {$ifdef DXGETTEXTDEBUG}
1536 if old='' then
1537 DebugWriteln ('(Empty, not translated)')
1538 else
1539 DebugWriteln ('Old value: "'+old+'"');
1540 {$endif}
1541 if (old <> '') and (IsWriteProp(PropInfo)) then begin
1542 if TP_Retranslator<>nil then
1543 (TP_Retranslator as TTP_Retranslator).Remember(AnObject, PropName, old);
1544 ws := dgettext(textdomain,old);
1545 if ws <> old then begin
1546 {$ifdef DELPHI5OROLDER}
1547 SetStrProp(AnObject, PropName, ws);
1548 {$endif}
1549 {$ifndef DELPHI5OROLDER}
1550 ppi:=GetPropInfo(AnObject, Propname);
1551 if ppi<>nil then begin
1552 SetWideStrProp(AnObject, ppi, ws);
1553 end else begin
1554 {$ifdef DXGETTEXTDEBUG}
1555 DebugWriteln ('ERROR: Property disappeared: '+Propname+' for object of type '+AnObject.ClassName);
1556 {$endif}
1557 end;
1558 {$endif}
1559 end;
1560 end;
1561 end { case item };
1562 tkClass:
1563 begin
1564 // obj:=GetObjectProp(AnObject, PropName);
1565 // if obj<>nil then
1566 // TodoList.AddObject ('',obj);
1567 end { case item };
1568 end { case };
1569 except
1570 on E:Exception do
1571 raise EGGComponentError.Create ('Property cannot be translated.'+sLineBreak+
1572 'Add TP_GlobalIgnoreClassProperty('+AnObject.ClassName+','''+PropName+''') to your source code or use'+sLineBreak+
1573 'TP_Ignore (self,''.'+PropName+''') to prevent this message.'+sLineBreak+
1574 'Reason: '+e.Message);
1575 end;
1576 end;
1577
1578 procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; textdomain:string='');
1579 var
1580 TodoList:TStringList; // List of Name/TObject's that is to be processed
1581 DoneList:TStringList; // List of hex codes representing pointers to objects that have been done
1582 i, j, Count: integer;
1583 PropList: PPropList;
1584 UPropName: string;
1585 PropInfo: PPropInfo;
1586 comp:TComponent;
1587 cm,currentcm:TClassMode;
1588 ObjectPropertyIgnoreList:TStringList;
1589 objid, Name:string;
1590 {$ifdef DELPHI5OROLDER}
1591 Data:PTypeData;
1592 {$endif}
1593 begin
1594 {$ifdef DXGETTEXTDEBUG}
1595 DebugWriteln ('----------------------------------------------------------------------');
1596 DebugWriteln ('TranslateProperties() was called for an object of class '+AnObject.ClassName+' with domain "'+textdomain+'".');
1597 {$endif}
1598 if textdomain='' then
1599 textdomain:=curmsgdomain;
1600 if TP_Retranslator<>nil then
1601 (TP_Retranslator as TTP_Retranslator).TextDomain:=textdomain;
1602 DoneList:=TStringList.Create;
1603 TodoList:=TStringList.Create;
1604 ObjectPropertyIgnoreList:=TStringList.Create;
1605 try
1606 TodoList.AddObject('', AnObject);
1607 DoneList.Sorted:=True;
1608 ObjectPropertyIgnoreList.Sorted:=True;
1609 {$ifndef DELPHI5OROLDER}
1610 ObjectPropertyIgnoreList.Duplicates:=dupIgnore;
1611 ObjectPropertyIgnoreList.CaseSensitive:=False;
1612 DoneList.Duplicates:=dupError;
1613 DoneList.CaseSensitive:=True;
1614 {$endif}
1615
1616 while TodoList.Count<>0 do begin
1617 AnObject:=TodoList.Objects[0];
1618 Name:=TodoList.Strings[0];
1619 TodoList.Delete(0);
1620 if (AnObject<>nil) and (AnObject is TPersistent) then begin
1621 // Make sure each object is only translated once
1622 Assert (sizeof(integer)=sizeof(TObject));
1623 objid:=IntToHex(integer(AnObject),8);
1624 if DoneList.Find(objid,i) then begin
1625 continue;
1626 end else begin
1627 DoneList.Add(objid);
1628 end;
1629
1630 ObjectPropertyIgnoreList.Clear;
1631
1632 // Find out if there is special handling of this object
1633 currentcm:=nil;
1634 // First check the local handling instructions
1635 for j:=0 to TP_ClassHandling.Count-1 do begin
1636 cm:=TObject(TP_ClassHandling.Items[j]) as TClassMode;
1637 if AnObject.InheritsFrom(cm.HClass) then begin
1638 if cm.PropertiesToIgnore.Count<>0 then begin
1639 ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);
1640 end else begin
1641 // Ignore the entire class
1642 currentcm:=cm;
1643 break;
1644 end;
1645 end;
1646 end;
1647 // Then check the global handling instructions
1648 if currentcm=nil then
1649 for j:=0 to TP_GlobalClassHandling.Count-1 do begin
1650 cm:=TObject(TP_GlobalClassHandling.Items[j]) as TClassMode;
1651 if AnObject.InheritsFrom(cm.HClass) then begin
1652 if cm.PropertiesToIgnore.Count<>0 then begin
1653 ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);
1654 end else begin
1655 // Ignore the entire class
1656 currentcm:=cm;
1657 break;
1658 end;
1659 end;
1660 end;
1661 if currentcm<>nil then begin
1662 ObjectPropertyIgnoreList.Clear;
1663 // Ignore or use special handler
1664 if Assigned(currentcm.SpecialHandler) then begin
1665 currentcm.SpecialHandler (AnObject);
1666 {$ifdef DXGETTEXTDEBUG}
1667 DebugWriteln ('Special handler activated for '+AnObject.ClassName);
1668 {$endif}
1669 end else begin
1670 {$ifdef DXGETTEXTDEBUG}
1671 DebugWriteln ('Ignoring object '+AnObject.ClassName);
1672 {$endif}
1673 end;
1674 continue;
1675 end;
1676
1677 {$ifdef DELPHI5OROLDER}
1678 if AnObject.ClassInfo=nil then begin
1679 {$ifdef DXGETTEXTDEBUG}
1680 DebugWriteln ('ClassInfo=nil encountered for class '+AnObject.ClassName+'. Translation of that component has stopped. You should ignore this object.');
1681 {$endif}
1682 continue;
1683 end;
1684 Data := GetTypeData(AnObject.Classinfo);
1685 Count := Data^.PropCount;
1686 GetMem(PropList, Count * Sizeof(PPropInfo));
1687 {$endif}
1688 {$ifndef DELPHI5OROLDER}
1689 Count := GetPropList(AnObject, PropList);
1690 {$endif}
1691 try
1692 {$ifdef DELPHI5OROLDER}
1693 GetPropInfos(AnObject.ClassInfo, PropList);
1694 {$endif}
1695 for j := 0 to Count - 1 do begin
1696 PropInfo := PropList[j];
1697 UPropName:=uppercase(PropInfo^.Name);
1698 // Ignore properties that are meant to be ignored
1699 if ((currentcm=nil) or (not currentcm.PropertiesToIgnore.Find(UPropName,i))) and
1700 (not TP_IgnoreList.Find(Name+'.'+UPropName,i)) and
1701 (not ObjectPropertyIgnoreList.Find(UPropName,i)) then begin
1702 TranslateProperty (AnObject,PropInfo,TodoList,TextDomain);
1703 end; // if
1704 end; // for
1705 finally
1706 {$ifdef DELPHI5OROLDER}
1707 FreeMem(PropList, Data^.PropCount * Sizeof(PPropInfo));
1708 {$endif}
1709 {$ifndef DELPHI5OROLDER}
1710 if Count<>0 then
1711 FreeMem (PropList);
1712 {$endif}
1713 end;
1714 if AnObject is TStrings then begin
1715 if ((AnObject as TStrings).Text<>'') and (TP_Retranslator<>nil) then
1716 (TP_Retranslator as TTP_Retranslator).Remember(AnObject, 'Text', (AnObject as TStrings).Text);
1717 TranslateStrings (AnObject as TStrings,TextDomain);
1718 end;
1719 // Check for TCollection
1720 if AnObject is TCollection then begin
1721 for i := 0 to (AnObject as TCollection).Count - 1 do
1722 TodoList.AddObject('',(AnObject as TCollection).Items[i]);
1723 end;
1724 if AnObject is TComponent then begin
1725 for i := 0 to TComponent(AnObject).ComponentCount - 1 do begin
1726 comp:=TComponent(AnObject).Components[i];
1727 if (not TP_IgnoreList.Find(uppercase(comp.Name),j)) then begin
1728 TodoList.AddObject(uppercase(comp.Name),comp);
1729 end;
1730 end;
1731 end;
1732 end { if AnObject<>nil };
1733 end { while todolist.count<>0 };
1734 finally
1735 FreeAndNil (todolist);
1736 FreeAndNil (ObjectPropertyIgnoreList);
1737 FreeAndNil (DoneList);
1738 end;
1739 FreeTP_ClassHandlingItems;
1740 TP_IgnoreList.Clear;
1741 TP_Retranslator:=nil;
1742 {$ifdef DXGETTEXTDEBUG}
1743 DebugWriteln ('----------------------------------------------------------------------');
1744 {$endif}
1745 end;
1746
1747 procedure TGnuGettextInstance.UseLanguage(LanguageCode: string);
1748 var
1749 i,p:integer;
1750 dom:TDomain;
1751 l2:string[2];
1752 begin
1753 {$ifdef DXGETTEXTDEBUG}
1754 DebugWriteln('UseLanguage('''+LanguageCode+'''); called');
1755 {$endif}
1756
1757 if LanguageCode='' then begin
1758 LanguageCode:=GGGetEnvironmentVariable('LANG');
1759 {$ifdef DXGETTEXTDEBUG}
1760 DebugWriteln ('LANG env variable is '''+LanguageCode+'''.');
1761 {$endif}
1762 {$ifdef MSWINDOWS}
1763 if LanguageCode='' then begin
1764 LanguageCode:=GetWindowsLanguage;
1765 {$ifdef DXGETTEXTDEBUG}
1766 DebugWriteln ('Found Windows language code to be '''+LanguageCode+'''.');
1767 {$endif}
1768 end;
1769 {$endif}
1770 p:=pos('.',LanguageCode);
1771 if p<>0 then
1772 LanguageCode:=copy(LanguageCode,1,p-1);
1773 {$ifdef DXGETTEXTDEBUG}
1774 DebugWriteln ('Language code that will be set is '''+LanguageCode+'''.');
1775 {$endif}
1776 end;
1777
1778 curlang := LanguageCode;
1779 for i:=0 to domainlist.Count-1 do begin
1780 dom:=domainlist.Objects[i] as TDomain;
1781 dom.SetLanguageCode (curlang);
1782 end;
1783
1784 l2:=lowercase(copy(curlang,1,2));
1785 if (l2='en') or (l2='de') then curGetPluralForm:=GetPluralForm2EN else
1786 if (l2='hu') or (l2='ko') or (l2='zh') or (l2='ja') or (l2='tr') then curGetPluralForm:=GetPluralForm1 else
1787 if (l2='fr') or (l2='fa') or (lowercase(curlang)='pt_br') then curGetPluralForm:=GetPluralForm2FR else
1788 if (l2='lv') then curGetPluralForm:=GetPluralForm3LV else
1789 if (l2='ga') then curGetPluralForm:=GetPluralForm3GA else
1790 if (l2='lt') then curGetPluralForm:=GetPluralForm3LT else
1791 if (l2='ru') or (l2='cs') or (l2='sk') or (l2='uk') or (l2='hr') then curGetPluralForm:=GetPluralForm3RU else
1792 if (l2='pl') then curGetPluralForm:=GetPluralForm3PL else
1793 if (l2='sl') then curGetPluralForm:=GetPluralForm4SL else begin
1794 curGetPluralForm:=GetPluralForm2EN;
1795 {$ifdef DXGETTEXTDEBUG}
1796 DebugWriteln ('Plural form for the language was not found. English plurality system assumed.');
1797 {$endif}
1798 end;
1799
1800 WhenNewLanguage (curlang);
1801
1802 {$ifdef DXGETTEXTDEBUG}
1803 DebugWriteln('');
1804 {$endif}
1805 end;
1806
1807 procedure TGnuGettextInstance.TranslateStrings(sl: TStrings;const TextDomain:string);
1808 var
1809 line: string;
1810 i: integer;
1811 s:TStringList;
1812 begin
1813 if sl.Count > 0 then begin
1814 sl.BeginUpdate;
1815 try
1816 s:=TStringList.Create;
1817 try
1818 s.Assign (sl);
1819 for i:=0 to s.Count-1 do begin
1820 line:=s.Strings[i];
1821 if line<>'' then
1822 s.Strings[i]:=dgettext(TextDomain,line);
1823 end;
1824 sl.Assign(s);
1825 finally
1826 FreeAndNil (s);
1827 end;
1828 finally
1829 sl.EndUpdate;
1830 end;
1831 end;
1832 end;
1833
GetTranslatorNameAndEmailnull1834 function TGnuGettextInstance.GetTranslatorNameAndEmail: widestring;
1835 begin
1836 Result:=GetTranslationProperty('LAST-TRANSLATOR');
1837 end;
1838
GetTranslationPropertynull1839 function TGnuGettextInstance.GetTranslationProperty(
1840 const Propertyname: string): WideString;
1841 begin
1842 Result:=getdomain(curmsgdomain,DefaultDomainDirectory,CurLang).GetTranslationProperty (Propertyname);
1843 end;
1844
dngettextnull1845 function TGnuGettextInstance.dngettext(const szDomain: string; const singular, plural: widestring;
1846 Number: Integer): widestring;
1847 var
1848 org,trans:widestring;
1849 idx:integer;
1850 p:integer;
1851 begin
1852 {$ifdef DXGETTEXTDEBUG}
1853 DebugWriteln ('dngettext translation (domain '+szDomain+', number is '+IntTostr(Number)+') of '+singular+'/'+plural);
1854 {$endif}
1855 org:=singular+#0+plural;
1856 trans:=dgettext(szDomain,org);
1857 if org=trans then begin
1858 {$ifdef DXGETTEXTDEBUG}
1859 DebugWriteln ('Translation was equal to english version. English plural forms assumed.');
1860 {$endif}
1861 idx:=GetPluralForm2EN(Number)
1862 end else
1863 idx:=curGetPluralForm(Number);
1864 {$ifdef DXGETTEXTDEBUG}
1865 DebugWriteln ('Index '+IntToStr(idx)+' will be used');
1866 {$endif}
1867 while true do begin
1868 p:=pos(#0,trans);
1869 if p=0 then begin
1870 {$ifdef DXGETTEXTDEBUG}
1871 DebugWriteln ('Last translation used: '+utf8encode(trans));
1872 {$endif}
1873 Result:=trans;
1874 exit;
1875 end;
1876 if idx=0 then begin
1877 {$ifdef DXGETTEXTDEBUG}
1878 DebugWriteln ('Translation found: '+utf8encode(trans));
1879 {$endif}
1880 Result:=copy(trans,1,p-1);
1881 exit;
1882 end;
1883 delete (trans,1,p);
1884 dec (idx);
1885 end;
1886 end;
1887
1888 {$ifndef DELPHI5OROLDER}
ngettextnull1889 function TGnuGettextInstance.ngettext(const singular, plural: ansistring;
1890 Number: Integer): widestring;
1891 begin
1892 Result := dngettext(curmsgdomain, singular, plural, Number);
1893 end;
1894 {$endif}
1895
ngettextnull1896 function TGnuGettextInstance.ngettext(const singular, plural: widestring;
1897 Number: Integer): widestring;
1898 begin
1899 Result := dngettext(curmsgdomain, singular, plural, Number);
1900 end;
1901
1902 procedure TGnuGettextInstance.WhenNewDomain(const TextDomain: string);
1903 begin
1904 // This is meant to be empty.
1905 end;
1906
1907 procedure TGnuGettextInstance.WhenNewLanguage(const LanguageID: string);
1908 begin
1909 // This is meant to be empty.
1910 end;
1911
1912 procedure TGnuGettextInstance.WhenNewDomainDirectory(const TextDomain,
1913 Directory: string);
1914 begin
1915 // This is meant to be empty.
1916 end;
1917
1918 procedure TGnuGettextInstance.GetListOfLanguages(const domain: string;
1919 list: TStrings);
1920 begin
1921 getdomain(Domain,DefaultDomainDirectory,CurLang).GetListOfLanguages(list);
1922 end;
1923
1924 procedure TGnuGettextInstance.bindtextdomainToFile(const szDomain,
1925 filename: string);
1926 begin
1927 {$ifdef DXGETTEXTDEBUG}
1928 DebugWriteln ('Text domain "'+szDomain+'" is now bound to file named "'+filename+'"');
1929 {$endif}
1930 getdomain(szDomain,DefaultDomainDirectory,CurLang).SetFilename (filename);
1931 end;
1932
1933 procedure TGnuGettextInstance.DebugLogPause(PauseEnabled: boolean);
1934 begin
1935 DebugLogOutputPaused:=PauseEnabled;
1936 end;
1937
1938 procedure TGnuGettextInstance.DebugLogToFile(const filename: string; append:boolean=false);
1939 {$ifdef DXGETTEXTDEBUG}
1940 var
1941 fs:TFileStream;
1942 marker:string;
1943 {$endif}
1944 begin
1945 {$ifdef DXGETTEXTDEBUG}
1946 // Create the file if needed
1947 if (not fileexists(filename)) or (not append) then
1948 fileclose (filecreate (filename));
1949
1950 // Open file
1951 fs:=TFileStream.Create (filename,fmOpenWrite or fmShareDenyWrite);
1952 if append then
1953 fs.Seek(0,soFromEnd);
1954
1955 // Write header if appending
1956 if fs.Position<>0 then begin
1957 marker:=sLineBreak+'==========================================================================='+sLineBreak;
1958 fs.WriteBuffer(marker[1],length(marker));
1959 end;
1960
1961 // Copy the memorystream contents to the file
1962 DebugLog.Seek(0,soFromBeginning);
1963 fs.CopyFrom(DebugLog,0);
1964
1965 // Make DebugLog point to the filestream
1966 FreeAndNil (DebugLog);
1967 DebugLog:=fs;
1968 {$endif}
1969 end;
1970
1971 procedure TGnuGettextInstance.DebugWriteln(line: ansistring);
1972 Var
1973 Discard: Boolean;
1974 begin
1975 Assert (DebugLogCS<>nil);
1976 Assert (DebugLog<>nil);
1977
1978 DebugLogCS.BeginWrite;
1979 try
1980 if DebugLogOutputPaused then
1981 exit;
1982
1983 if Assigned (fOnDebugLine) then begin
1984 Discard := True;
1985 fOnDebugLine (Self, Line, Discard);
1986 If Discard then Exit;
1987 end;
1988
1989 line:=line+sLineBreak;
1990
1991 // Ensure that memory usage doesn't get too big.
1992 if (DebugLog is TMemoryStream) and (DebugLog.Position>1000000) then begin
1993 line:=sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak+
1994 'Debug log halted because memory usage grew too much.'+sLineBreak+
1995 'Specify a filename to store the debug log in or disable debug loggin in gnugettext.pas.'+
1996 sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak;
1997 DebugLogOutputPaused:=True;
1998 end;
1999 DebugLog.WriteBuffer(line[1],length(line));
2000 finally
2001 DebugLogCS.EndWrite;
2002 end;
2003 end;
2004
Getdomainnull2005 function TGnuGettextInstance.Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain;
2006 // Retrieves the TDomain object for the specified domain.
2007 // Creates one, if none there, yet.
2008 var
2009 idx: integer;
2010 begin
2011 idx := domainlist.IndexOf(Domain);
2012 if idx = -1 then begin
2013 Result := TDomain.Create;
2014 Result.DebugLogger:=DebugWriteln;
2015 Result.Domain := Domain;
2016 Result.Directory := DefaultDomainDirectory;
2017 Result.SetLanguageCode(curlang);
2018 domainlist.AddObject(Domain, Result);
2019 end else begin
2020 Result := domainlist.Objects[idx] as TDomain;
2021 end;
2022 end;
2023
LoadResStringnull2024 function TGnuGettextInstance.LoadResString(
2025 ResStringRec: PResStringRec): widestring;
2026 {$ifdef MSWINDOWS}
2027 var
2028 Len: Integer;
2029 Buffer: array [0..1023] of char;
2030 {$endif}
2031 {$ifdef LINUX }
2032 const
2033 ResStringTableLen = 16;
2034 type
2035 ResStringTable = array [0..ResStringTableLen-1] of LongWord;
2036 var
2037 Handle: TResourceHandle;
2038 Tab: ^ResStringTable;
2039 ResMod: HMODULE;
2040 {$endif }
2041 begin
2042 if ResStringRec=nil then
2043 exit;
2044 if ResStringRec.Identifier>=64*1024 then begin
2045 {$ifdef DXGETTEXTDEBUG}
2046 DebugWriteln ('LoadResString was given an invalid ResStringRec.Identifier');
2047 {$endif}
2048 Result:='ERROR';
2049 exit;
2050 end else begin
2051 {$ifdef LINUX}
2052 // This works with Unicode if the Linux has utf-8 character set
2053 // Result:=System.LoadResString(ResStringRec);
2054 ResMod:=FindResourceHInstance(ResStringRec^.Module^);
2055 Handle:=FindResource(ResMod,
2056 PChar(ResStringRec^.Identifier div ResStringTableLen), PChar(6)); // RT_STRING
2057 Tab:=Pointer(LoadResource(ResMod, Handle));
2058 if Tab=nil then
2059 Result:=''
2060 else
2061 Result:=PWideChar(PChar(Tab)+Tab[ResStringRec^.Identifier mod ResStringTableLen]);
2062 {$endif}
2063 {$ifdef MSWINDOWS}
2064 if not Win32PlatformIsUnicode then begin
2065 SetString(Result, Buffer,
2066 LoadString(FindResourceHInstance(ResStringRec.Module^),
2067 ResStringRec.Identifier, Buffer, SizeOf(Buffer)))
2068 end else begin
2069 Result := '';
2070 Len := 0;
2071 While Len = Length(Result) do begin
2072 if Length(Result) = 0 then
2073 SetLength(Result, 1024)
2074 else
2075 SetLength(Result, Length(Result) * 2);
2076 Len := LoadStringW(FindResourceHInstance(ResStringRec.Module^),
2077 ResStringRec.Identifier, PWideChar(Result), Length(Result));
2078 end;
2079 SetLength(Result, Len);
2080 end;
2081 {$endif}
2082 end;
2083 {$ifdef DXGETTEXTDEBUG}
2084 DebugWriteln ('Loaded resourcestring: '+utf8encode(Result));
2085 {$endif}
2086 if CreatorThread<>GetCurrentThreadId then begin
2087 {$ifdef DXGETTEXTDEBUG}
2088 DebugWriteln ('LoadResString was called from an invalid thread. Resourcestring was not translated.');
2089 {$endif}
2090 end else
2091 Result:=ResourceStringGettext(Result);
2092 end;
2093
2094 procedure TGnuGettextInstance.RetranslateComponent(AnObject: TComponent;
2095 const TextDomain: string);
2096 var
2097 comp:TGnuGettextComponentMarker;
2098 begin
2099 {$ifdef DXGETTEXTDEBUG}
2100 DebugWriteln ('======================================================================');
2101 DebugWriteln ('RetranslateComponent() was called for a component with name '+AnObject.Name+'.');
2102 {$endif}
2103 comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
2104 if comp=nil then begin
2105 {$ifdef DXGETTEXTDEBUG}
2106 DebugWriteln ('Retranslate was called on an object that has not been translated before. An Exception is being raised.');
2107 {$endif}
2108 raise EGGProgrammingError.Create ('Retranslate was called on an object that has not been translated before. Please use TranslateComponent() before RetranslateComponent().');
2109 end else begin
2110 if comp.LastLanguage<>curlang then begin
2111 {$ifdef DXGETTEXTDEBUG}
2112 DebugWriteln ('The retranslator is being executed.');
2113 {$endif}
2114 comp.Retranslator.Execute;
2115 end else begin
2116 {$ifdef DXGETTEXTDEBUG}
2117 DebugWriteln ('The language has not changed. The retranslator is not executed.');
2118 {$endif}
2119 end;
2120 end;
2121 comp.LastLanguage:=curlang;
2122 {$ifdef DXGETTEXTDEBUG}
2123 DebugWriteln ('======================================================================');
2124 {$endif}
2125 end;
2126
2127 procedure TGnuGettextInstance.TP_IgnoreClass(IgnClass: TClass);
2128 var
2129 cm:TClassMode;
2130 i:integer;
2131 begin
2132 for i:=0 to TP_ClassHandling.Count-1 do begin
2133 cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;
2134 if cm.HClass=IgnClass then
2135 raise EGGProgrammingError.Create ('You cannot add a class to the ignore list that is already on that list: '+IgnClass.ClassName+'.');
2136 if IgnClass.InheritsFrom(cm.HClass) then begin
2137 // This is the place to insert this class
2138 cm:=TClassMode.Create;
2139 cm.HClass:=IgnClass;
2140 TP_ClassHandling.Insert(i,cm);
2141 {$ifdef DXGETTEXTDEBUG}
2142 DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.');
2143 {$endif}
2144 exit;
2145 end;
2146 end;
2147 cm:=TClassMode.Create;
2148 cm.HClass:=IgnClass;
2149 TP_ClassHandling.Add(cm);
2150 {$ifdef DXGETTEXTDEBUG}
2151 DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.');
2152 {$endif}
2153 end;
2154
2155 procedure TGnuGettextInstance.TP_IgnoreClassProperty(IgnClass: TClass;
2156 propertyname: string);
2157 var
2158 cm:TClassMode;
2159 i:integer;
2160 begin
2161 propertyname:=uppercase(propertyname);
2162 for i:=0 to TP_ClassHandling.Count-1 do begin
2163 cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;
2164 if cm.HClass=IgnClass then begin
2165 if Assigned(cm.SpecialHandler) then
2166 raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.');
2167 cm.PropertiesToIgnore.Add(propertyname);
2168 {$ifdef DXGETTEXTDEBUG}
2169 DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
2170 {$endif}
2171 exit;
2172 end;
2173 if IgnClass.InheritsFrom(cm.HClass) then begin
2174 // This is the place to insert this class
2175 cm:=TClassMode.Create;
2176 cm.HClass:=IgnClass;
2177 cm.PropertiesToIgnore.Add(propertyname);
2178 TP_ClassHandling.Insert(i,cm);
2179 {$ifdef DXGETTEXTDEBUG}
2180 DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
2181 {$endif}
2182 exit;
2183 end;
2184 end;
2185 cm:=TClassMode.Create;
2186 cm.HClass:=IgnClass;
2187 cm.PropertiesToIgnore.Add(propertyname);
2188 TP_GlobalClassHandling.Add(cm);
2189 {$ifdef DXGETTEXTDEBUG}
2190 DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
2191 {$endif}
2192 end;
2193
2194 procedure TGnuGettextInstance.FreeTP_ClassHandlingItems;
2195 begin
2196 while TP_ClassHandling.Count<>0 do begin
2197 TObject(TP_ClassHandling.Items[0]).Free;
2198 TP_ClassHandling.Delete(0);
2199 end;
2200 end;
2201
ansi2widenull2202 function TGnuGettextInstance.ansi2wide(const s: ansistring): widestring;
2203 {$ifdef MSWindows}
2204 var
2205 len:integer;
2206 {$endif}
2207 begin
2208 {$ifdef MSWindows}
2209 if DesignTimeCodePage=CP_ACP then begin
2210 // No design-time codepage specified. Using runtime codepage instead.
2211 {$endif}
2212 Result:=s;
2213 {$ifdef MSWindows}
2214 end else begin
2215 len:=length(s);
2216 if len=0 then
2217 Result:=''
2218 else begin
2219 SetLength (Result,len);
2220 len:=MultiByteToWideChar(DesignTimeCodePage,0,pchar(s),len,pwidechar(Result),len);
2221 if len=0 then
2222 raise EGGAnsi2WideConvError.Create ('Cannot convert string to widestring:'+sLineBreak+s);
2223 SetLength (Result,len);
2224 end;
2225 end;
2226 {$endif}
2227 end;
2228
2229 {$ifndef DELPHI5OROLDER}
dngettextnull2230 function TGnuGettextInstance.dngettext(const szDomain: string; const singular,
2231 plural: ansistring; Number: Integer): widestring;
2232 begin
2233 Result:=dngettext (szDomain, ansi2wide(singular), ansi2wide(plural), Number);
2234 end;
2235 {$endif}
2236
2237 { TClassMode }
2238
2239 constructor TClassMode.Create;
2240 begin
2241 PropertiesToIgnore:=TStringList.Create;
2242 PropertiesToIgnore.Sorted:=True;
2243 PropertiesToIgnore.Duplicates:=dupError;
2244 {$ifndef DELPHI5OROLDER}
2245 PropertiesToIgnore.CaseSensitive:=False;
2246 {$endif}
2247 end;
2248
2249 destructor TClassMode.Destroy;
2250 begin
2251 FreeAndNil (PropertiesToIgnore);
2252 inherited;
2253 end;
2254
2255 { TFileLocator }
2256
2257 procedure TFileLocator.Analyze;
2258 var
2259 s:ansistring;
2260 i:integer;
2261 offset:int64;
2262 fs:TFileStream;
2263 fi:TEmbeddedFileInfo;
2264 filename:string;
2265 begin
2266 s:='6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0;
2267 s:=copy(s,length(s)-7,8);
2268 offset:=0;
2269 for i:=8 downto 1 do
2270 offset:=offset shl 8+ord(s[i]);
2271 if offset=0 then
2272 exit;
2273 BaseDirectory:=ExtractFilePath(ExecutableFilename);
2274 try
2275 fs:=TFileStream.Create(ExecutableFilename,fmOpenRead or fmShareDenyNone);
2276 try
2277 while true do begin
2278 fs.Seek(offset,soFromBeginning);
2279 offset:=ReadInt64(fs);
2280 if offset=0 then
2281 exit;
2282 fi:=TEmbeddedFileInfo.Create;
2283 try
2284 fi.Offset:=ReadInt64(fs);
2285 fi.Size:=ReadInt64(fs);
2286 SetLength (filename, offset-fs.position);
2287 fs.ReadBuffer (filename[1],offset-fs.position);
2288 filename:=trim(filename);
2289 filelist.AddObject(filename,fi);
2290 except
2291 FreeAndNil (fi);
2292 raise;
2293 end;
2294 end;
2295 finally
2296 FreeAndNil (fs);
2297 end;
2298 except
2299 {$ifdef DXGETTEXTDEBUG}
2300 raise;
2301 {$endif}
2302 end;
2303 end;
2304
2305 constructor TFileLocator.Create;
2306 begin
2307 MoFilesCS:=TMultiReadExclusiveWriteSynchronizer.Create;
2308 MoFiles:=TStringList.Create;
2309 filelist:=TStringList.Create;
2310 {$ifdef LINUX}
2311 filelist.Duplicates:=dupError;
2312 filelist.CaseSensitive:=True;
2313 {$endif}
2314 MoFiles.Sorted:=True;
2315 {$ifndef DELPHI5OROLDER}
2316 MoFiles.Duplicates:=dupError;
2317 MoFiles.CaseSensitive:=False;
2318 {$ifdef MSWINDOWS}
2319 filelist.Duplicates:=dupError;
2320 filelist.CaseSensitive:=False;
2321 {$endif}
2322 {$endif}
2323 filelist.Sorted:=True;
2324 end;
2325
2326 destructor TFileLocator.Destroy;
2327 begin
2328 while filelist.count<>0 do begin
2329 filelist.Objects[0].Free;
2330 filelist.Delete (0);
2331 end;
2332 FreeAndNil (filelist);
2333 FreeAndNil (MoFiles);
2334 FreeAndNil (MoFilesCS);
2335 inherited;
2336 end;
2337
FileExistsnull2338 function TFileLocator.FileExists(filename: string): boolean;
2339 var
2340 idx:integer;
2341 begin
2342 if copy(filename,1,length(basedirectory))=basedirectory then
2343 filename:=copy(filename,length(basedirectory)+1,maxint);
2344 Result:=filelist.Find(filename,idx);
2345 end;
2346
TFileLocator.GetMoFilenull2347 function TFileLocator.GetMoFile(filename: string; DebugLogger:TDebugLogger): TMoFile;
2348 var
2349 fi:TEmbeddedFileInfo;
2350 idx:integer;
2351 idxname:string;
2352 Offset, Size: Int64;
2353 realfilename:string;
2354 begin
2355 // Find real filename
2356 offset:=0;
2357 size:=0;
2358 realfilename:=filename;
2359 if copy(filename,1,length(basedirectory))=basedirectory then begin
2360 filename:=copy(filename,length(basedirectory)+1,maxint);
2361 idx:=filelist.IndexOf(filename);
2362 if idx<>-1 then begin
2363 fi:=filelist.Objects[idx] as TEmbeddedFileInfo;
2364 realfilename:=ExecutableFilename;
2365 offset:=fi.offset;
2366 size:=fi.size;
2367 {$ifdef DXGETTEXTDEBUG}
2368 DebugLogger ('Instead of '+filename+', using '+realfilename+' from offset '+IntTostr(offset)+', size '+IntToStr(size));
2369 {$endif}
2370 end;
2371 end;
2372
2373
2374 {$ifdef DXGETTEXTDEBUG}
2375 DebugLogger ('Reading .mo data from file '''+filename+'''');
2376 {$endif}
2377
2378 // Find TMoFile object
2379 MoFilesCS.BeginWrite;
2380 try
2381 idxname:=realfilename+#1+IntToStr(offset);
2382 if MoFiles.Find(idxname, idx) then begin
2383 Result:=MoFiles.Objects[idx] as TMoFile;
2384 end else begin
2385 Result:=TMoFile.Create (realfilename, Offset, Size);
2386 MoFiles.AddObject(idxname, Result);
2387 end;
2388 Inc (Result.Users);
2389 finally
2390 MoFilesCS.EndWrite;
2391 end;
2392 end;
2393
ReadInt64null2394 function TFileLocator.ReadInt64(str: TStream): int64;
2395 begin
2396 Assert (sizeof(Result)=8);
2397 str.ReadBuffer(Result,8);
2398 end;
2399
2400 procedure TFileLocator.ReleaseMoFile(mofile: TMoFile);
2401 var
2402 i:integer;
2403 begin
2404 Assert (mofile<>nil);
2405
2406 MoFilesCS.BeginWrite;
2407 try
2408 dec (mofile.Users);
2409 if mofile.Users<=0 then begin
2410 i:=MoFiles.Count-1;
2411 while i>=0 do begin
2412 if MoFiles.Objects[i]=mofile then begin
2413 MoFiles.Delete(i);
2414 FreeAndNil (mofile);
2415 break;
2416 end;
2417 dec (i);
2418 end;
2419 end;
2420 finally
2421 MoFilesCS.EndWrite;
2422 end;
2423 end;
2424
2425 { TTP_Retranslator }
2426
2427 constructor TTP_Retranslator.Create;
2428 begin
2429 list:=TList.Create;
2430 end;
2431
2432 destructor TTP_Retranslator.Destroy;
2433 var
2434 i:integer;
2435 begin
2436 for i:=0 to list.Count-1 do
2437 TObject(list.Items[i]).Free;
2438 FreeAndNil (list);
2439 inherited;
2440 end;
2441
2442 procedure TTP_Retranslator.Execute;
2443 var
2444 i:integer;
2445 sl:TStrings;
2446 item:TTP_RetranslatorItem;
2447 newvalue:WideString;
2448 {$ifndef DELPHI5OROLDER}
2449 ppi:PPropInfo;
2450 {$endif}
2451 begin
2452 for i:=0 to list.Count-1 do begin
2453 item:=TObject(list.items[i]) as TTP_RetranslatorItem;
2454 if item.obj is TStrings then begin
2455 // Since we don't know the order of items in sl, and don't have
2456 // the original .Objects[] anywhere, we cannot anticipate anything
2457 // about the current sl.Strings[] and sl.Objects[] values. We therefore
2458 // have to discard both values. We can, however, set the original .Strings[]
2459 // value into the list and retranslate that.
2460 sl:=TStringList.Create;
2461 try
2462 sl.Text:=item.OldValue;
2463 Instance.TranslateStrings(sl,textdomain);
2464 (item.obj as TStrings).BeginUpdate;
2465 try
2466 (item.obj as TStrings).Text:=sl.Text;
2467 finally
2468 (item.obj as TStrings).EndUpdate;
2469 end;
2470 finally
2471 FreeAndNil (sl);
2472 end;
2473 end else begin
2474 newValue:=instance.dgettext(textdomain,item.OldValue);
2475 {$ifdef DELPHI5OROLDER}
2476 SetStrProp(item.obj, item.PropName, newValue);
2477 {$endif}
2478 {$ifndef DELPHI5OROLDER}
2479 ppi:=GetPropInfo(item.obj, item.Propname);
2480 if ppi<>nil then begin
2481 SetWideStrProp(item.obj, ppi, newValue);
2482 end else begin
2483 {$ifdef DXGETTEXTDEBUG}
2484 Instance.DebugWriteln ('ERROR: On retranslation, property disappeared: '+item.Propname+' for object of type '+item.obj.ClassName);
2485 {$endif}
2486 end;
2487 {$endif}
2488 end;
2489 end;
2490 end;
2491
2492 procedure TTP_Retranslator.Remember(obj: TObject; PropName: String;
2493 OldValue: WideString);
2494 var
2495 item:TTP_RetranslatorItem;
2496 begin
2497 item:=TTP_RetranslatorItem.Create;
2498 item.obj:=obj;
2499 item.Propname:=Propname;
2500 item.OldValue:=OldValue;
2501 list.Add(item);
2502 end;
2503
2504 { TGnuGettextComponentMarker }
2505
2506 destructor TGnuGettextComponentMarker.Destroy;
2507 begin
2508 FreeAndNil (Retranslator);
2509 inherited;
2510 end;
2511
2512 { THook }
2513
2514 constructor THook.Create(OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);
2515 { Idea and original code from Igor Siticov }
2516 { Modified by Jacques Garcia Vazquez and Lars Dybdahl }
2517 begin
2518 {$ifndef CPU386}
2519 'This procedure only works on Intel i386 compatible processors.'
2520 {$endif}
2521
2522 oldproc:=OldProcedure;
2523 newproc:=NewProcedure;
2524
2525 Reset (FollowJump);
2526 end;
2527
2528 destructor THook.Destroy;
2529 begin
2530 Shutdown;
2531 inherited;
2532 end;
2533
2534 procedure THook.Disable;
2535 begin
2536 Assert (PatchPosition<>nil,'Patch position in THook was nil when Disable was called');
2537 PatchPosition[0]:=Original[0];
2538 PatchPosition[1]:=Original[1];
2539 PatchPosition[2]:=Original[2];
2540 PatchPosition[3]:=Original[3];
2541 PatchPosition[4]:=Original[4];
2542 end;
2543
2544 procedure THook.Enable;
2545 begin
2546 Assert (PatchPosition<>nil,'Patch position in THook was nil when Enable was called');
2547 PatchPosition[0]:=Patch[0];
2548 PatchPosition[1]:=Patch[1];
2549 PatchPosition[2]:=Patch[2];
2550 PatchPosition[3]:=Patch[3];
2551 PatchPosition[4]:=Patch[4];
2552 end;
2553
2554 procedure THook.Reset(FollowJump: boolean);
2555 var
2556 offset:integer;
2557 {$ifdef LINUX}
2558 p:pointer;
2559 pagesize:integer;
2560 {$endif}
2561 {$ifdef MSWindows}
2562 ov: cardinal;
2563 {$endif}
2564 begin
2565 if PatchPosition<>nil then
2566 Shutdown;
2567
2568 patchPosition := OldProc;
2569 if FollowJump and (Word(OldProc^) = $25FF) then begin
2570 // This finds the correct procedure if a virtual jump has been inserted
2571 // at the procedure address
2572 Inc(Integer(patchPosition), 2); // skip the jump
2573 patchPosition := pChar(Pointer(pointer(patchPosition)^)^);
2574 end;
2575 offset:=integer(NewProc)-integer(pointer(patchPosition))-5;
2576
2577 Patch[0] := char($E9);
2578 Patch[1] := char(offset and 255);
2579 Patch[2] := char((offset shr 8) and 255);
2580 Patch[3] := char((offset shr 16) and 255);
2581 Patch[4] := char((offset shr 24) and 255);
2582
2583 Original[0]:=PatchPosition[0];
2584 Original[1]:=PatchPosition[1];
2585 Original[2]:=PatchPosition[2];
2586 Original[3]:=PatchPosition[3];
2587 Original[4]:=PatchPosition[4];
2588
2589 {$ifdef MSWINDOWS}
2590 if not VirtualProtect(Pointer(PatchPosition), 5, PAGE_EXECUTE_READWRITE, @ov) then
2591 RaiseLastOSError;
2592 {$endif}
2593 {$ifdef LINUX}
2594 pageSize:=sysconf (_SC_PAGE_SIZE);
2595 p:=pointer(PatchPosition);
2596 p:=pointer((integer(p) + PAGESIZE-1) and not (PAGESIZE-1) - pageSize);
2597 if mprotect (p, pageSize, PROT_READ + PROT_WRITE + PROT_EXEC) <> 0 then
2598 RaiseLastOSError;
2599 {$endif}
2600 end;
2601
2602 procedure THook.Shutdown;
2603 begin
2604 Disable;
2605 PatchPosition:=nil;
2606 end;
2607
2608 procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);
2609 begin
2610 HookLoadResString.Reset (SupportPackages);
2611 HookLoadStr.Reset (SupportPackages);
2612 HookFmtLoadStr.Reset (SupportPackages);
2613 if enabled then begin
2614 HookLoadResString.Enable;
2615 HookLoadStr.Enable;
2616 HookFmtLoadStr.Enable;
2617 end;
2618 end;
2619
2620 { TMoFile }
2621
TMoFile.autoswap32null2622 function TMoFile.autoswap32(i: cardinal): cardinal;
2623 var
2624 cnv1, cnv2:
2625 record
2626 case integer of
2627 0: (arr: array[0..3] of byte);
2628 1: (int: cardinal);
2629 end;
2630 begin
2631 if doswap then begin
2632 cnv1.int := i;
2633 cnv2.arr[0] := cnv1.arr[3];
2634 cnv2.arr[1] := cnv1.arr[2];
2635 cnv2.arr[2] := cnv1.arr[1];
2636 cnv2.arr[3] := cnv1.arr[0];
2637 Result := cnv2.int;
2638 end else
2639 Result := i;
2640 end;
2641
TMoFile.CardinalInMemnull2642 function TMoFile.CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;
2643 var pc:^Cardinal;
2644 begin
2645 inc (baseptr,offset);
2646 pc:=Pointer(baseptr);
2647 Result:=pc^;
2648 if doswap then
2649 autoswap32(Result);
2650 end;
2651
2652 constructor TMoFile.Create(filename: string; Offset,Size:int64);
2653 var
2654 i:cardinal;
2655 nn:integer;
2656 {$ifdef linux}
2657 mofile:TFileStream;
2658 {$endif}
2659 begin
2660 if sizeof(i) <> 4 then
2661 raise EGGProgrammingError.Create('TDomain in gnugettext is written for an architecture that has 32 bit integers.');
2662
2663 {$ifdef mswindows}
2664 // Map the mo file into memory and let the operating system decide how to cache
2665 mo:=createfile (PChar(filename),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0);
2666 if mo=INVALID_HANDLE_VALUE then
2667 raise EGGIOError.Create ('Cannot open file '+filename);
2668 momapping:=CreateFileMapping (mo, nil, PAGE_READONLY, 0, 0, nil);
2669 if momapping=0 then
2670 raise EGGIOError.Create ('Cannot create memory map on file '+filename);
2671 momemoryHandle:=MapViewOfFile (momapping,FILE_MAP_READ,0,0,0);
2672 if momemoryHandle=nil then begin
2673 raise EGGIOError.Create ('Cannot map file '+filename+' into memory. Reason: '+GetLastWinError);
2674 end;
2675 momemory:=momemoryHandle+offset;
2676 {$endif}
2677 {$ifdef linux}
2678 // Read the whole file into memory
2679 mofile:=TFileStream.Create (filename, fmOpenRead or fmShareDenyNone);
2680 try
2681 if size=0 then
2682 size:=mofile.Size;
2683 Getmem (momemoryHandle,size);
2684 momemory:=momemoryHandle;
2685 mofile.Seek(offset,soFromBeginning);
2686 mofile.ReadBuffer(momemory^,size);
2687 finally
2688 FreeAndNil (mofile);
2689 end;
2690 {$endif}
2691
2692 // Check the magic number
2693 doswap:=False;
2694 i:=CardinalInMem(momemory,0);
2695 if (i <> $950412DE) and (i <> $DE120495) then
2696 EGGIOError.Create('This file is not a valid GNU gettext mo file: ' + filename);
2697 doswap := (i = $DE120495);
2698
2699
2700 // Find the positions in the file according to the file format spec
2701 CardinalInMem(momemory,4); // Read the version number, but don't use it for anything.
2702 N:=CardinalInMem(momemory,8); // Get string count
2703 O:=CardinalInMem(momemory,12); // Get offset of original strings
2704 T:=CardinalInMem(momemory,16); // Get offset of translated strings
2705
2706 // Calculate start conditions for a binary search
2707 nn := N;
2708 startindex := 1;
2709 while nn <> 0 do begin
2710 nn := nn shr 1;
2711 startindex := startindex shl 1;
2712 end;
2713 startindex := startindex shr 1;
2714 startstep := startindex shr 1;
2715 end;
2716
2717 destructor TMoFile.Destroy;
2718 begin
2719 {$ifdef mswindows}
2720 UnMapViewOfFile (momemoryHandle);
2721 CloseHandle (momapping);
2722 CloseHandle (mo);
2723 {$endif}
2724 {$ifdef linux}
2725 FreeMem (momemoryHandle);
2726 {$endif}
2727 inherited;
2728 end;
2729
gettextnull2730 function TMoFile.gettext(const msgid: ansistring;var found:boolean): ansistring;
2731 var
2732 i, step: cardinal;
2733 offset, pos: cardinal;
2734 CompareResult:integer;
2735 msgidptr,a,b:PChar;
2736 abidx:integer;
2737 size, msgidsize:integer;
2738 begin
2739 found:=false;
2740 msgidptr:=PChar(msgid);
2741 msgidsize:=length(msgid);
2742
2743 // Do binary search
2744 i:=startindex;
2745 step:=startstep;
2746 while true do begin
2747 // Get string for index i
2748 pos:=O+8*(i-1);
2749 offset:=CardinalInMem (momemory,pos+4);
2750 size:=CardinalInMem (momemory,pos);
2751 a:=msgidptr;
2752 b:=momemory+offset;
2753 abidx:=size;
2754 if msgidsize<abidx then
2755 abidx:=msgidsize;
2756 CompareResult:=0;
2757 while abidx<>0 do begin
2758 CompareResult:=integer(byte(a^))-integer(byte(b^));
2759 if CompareResult<>0 then
2760 break;
2761 dec (abidx);
2762 inc (a);
2763 inc (b);
2764 end;
2765 if CompareResult=0 then
2766 CompareResult:=msgidsize-size;
2767 if CompareResult=0 then begin // msgid=s
2768 // Found the msgid
2769 pos:=T+8*(i-1);
2770 offset:=CardinalInMem (momemory,pos+4);
2771 size:=CardinalInMem (momemory,pos);
2772 SetString (Result,momemory+offset,size);
2773 found:=True;
2774 break;
2775 end;
2776 if step=0 then begin
2777 // Not found
2778 Result:=msgid;
2779 break;
2780 end;
2781 if CompareResult<0 then begin // msgid<s
2782 if i < 1+step then
2783 i := 1
2784 else
2785 i := i - step;
2786 step := step shr 1;
2787 end else begin // msgid>s
2788 i := i + step;
2789 if i > N then
2790 i := N;
2791 step := step shr 1;
2792 end;
2793 end;
2794 end;
2795
2796 initialization
2797 {$ifdef DXGETTEXTDEBUG}
2798 {$ifdef MSWINDOWS}
2799 MessageBox (0,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.','Information',MB_OK);
2800 {$endif}
2801 {$ifdef LINUX}
2802 writeln (stderr,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.');
2803 {$endif}
2804 {$endif}
2805 if IsLibrary then begin
2806 // Get DLL/shared object filename
2807 SetLength (ExecutableFilename,300);
2808 {$ifdef MSWINDOWS}
2809 SetLength (ExecutableFilename,GetModuleFileName(HInstance, PChar(ExecutableFilename), length(ExecutableFilename)));
2810 {$else}
2811 // This line has not been tested on Linux, yet, but should work.
2812 SetLength (ExecutableFilename,GetModuleFileName(0, PChar(ExecutableFilename), length(ExecutableFilename)));
2813 {$endif}
2814 end else
2815 ExecutableFilename:=Paramstr(0);
2816 FileLocator:=TFileLocator.Create;
2817 FileLocator.Analyze;
2818 ResourceStringDomainList:=TStringList.Create;
2819 ResourceStringDomainList.Add(DefaultTextDomain);
2820 ResourceStringDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create;
2821 DefaultInstance:=TGnuGettextInstance.Create;
2822 {$ifdef MSWINDOWS}
2823 Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
2824 {$endif}
2825
2826 // replace Borlands LoadResString with gettext enabled version:
2827 HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringA);
2828 HookLoadStr:=THook.Create (@sysutils.LoadStr, @SysUtilsLoadStr);
2829 HookFmtLoadStr:=THook.Create (@sysutils.FmtLoadStr, @SysUtilsFmtLoadStr);
2830 HookIntoResourceStrings (AutoCreateHooks,false);
2831
2832 finalization
2833 FreeAndNil (DefaultInstance);
2834 FreeAndNil (ResourceStringDomainListCS);
2835 FreeAndNil (ResourceStringDomainList);
2836 FreeAndNil (HookFmtLoadStr);
2837 FreeAndNil (HookLoadStr);
2838 FreeAndNil (HookLoadResString);
2839 FreeAndNil (FileLocator);
2840
2841 end.
2842
2843