Source code of file oscpmwin_v0.4.1.745/gnugettext.pas from the
osCommerce Product Manager for Windows.


0000:   unit gnugettext;
0001:   (**************************************************************)
0002:   (*                                                            *)
0003:   (*  (C) Copyright by Lars B. Dybdahl and others               *)
0004:   (*  E-mail: Lars@dybdahl.dk, phone +45 70201241               *)
0005:   (*  File version: $Date: 2005/09/05 01:02:59 $                *)
0006:   (*  Revision: $Revision: 1.4 $                          *)
0007:   (*                                                            *)
0008:   (*  Contributors: Peter Thornqvist, Troy Wolbrink,            *)
0009:   (*                Frank Andreas de Groot, Igor Siticov,       *)
0010:   (*                Jacques Garcia Vazquez                      *)
0011:   (*                                                            *)
0012:   (*  See http://dybdahl.dk/dxgettext/ for more information     *)
0013:   (*                                                            *)
0014:   (**************************************************************)
0015:   
0016:   // Redistribution and use in source and binary forms, with or without
0017:   // modification, are permitted provided that the following conditions are met:
0018:   //
0019:   // The names of any contributor may not be used to endorse or promote
0020:   // products derived from this software without specific prior written permission.
0021:   //
0022:   // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
0023:   // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
0024:   // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
0025:   // ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
0026:   // LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
0027:   // DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
0028:   // SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
0029:   // CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
0030:   // OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
0031:   // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
0032:   
0033:   interface
0034:   
0035:   // If the conditional define DXGETTEXTDEBUG is defined, debugging log is activated.
0036:   // Use DefaultInstance.DebugLogToFile() to write the log to a file.
0037:   { $define DXGETTEXTDEBUG}
0038:   
0039:   
0040:   uses
0041:   {$ifdef MSWINDOWS}
0042:     Windows,
0043:   {$else}
0044:     Libc,
0045:   {$endif}
0046:     Classes, SysUtils, TypInfo;
0047:   
0048:   (*****************************************************************************)
0049:   (*                                                                           *)
0050:   (*  MAIN API                                                                 *)
0051:   (*                                                                           *)
0052:   (*****************************************************************************)
0053:   
0054:   // Main GNU gettext functions. See documentation for instructions on how to use them.
0055:   function _(const szMsgId: widestring): widestring;
0056:   function gettext(const szMsgId: widestring): widestring;
0057:   function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
0058:   function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
0059:   function ngettext(const singular,plural: widestring; Number:longint): widestring;
0060:   procedure textdomain(const szDomain: string);
0061:   function getcurrenttextdomain: string;
0062:   procedure bindtextdomain(const szDomain: string; const szDirectory: string);
0063:   
0064:   // Set language to use
0065:   procedure UseLanguage(LanguageCode: string);
0066:   function GetCurrentLanguage:string;
0067:   
0068:   // Translates a component (form, frame etc.) to the currently selected language.
0069:   // Put TranslateComponent(self) in the OnCreate event of all your forms.
0070:   // See the manual for documentation on these functions
0071:   type
0072:     TTranslator=procedure (obj:TObject) of object;
0073:   
0074:   procedure TP_Ignore(AnObject:TObject; const name:string);
0075:   procedure TP_IgnoreClass (IgnClass:TClass);
0076:   procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:string);
0077:   procedure TP_GlobalIgnoreClass (IgnClass:TClass);
0078:   procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:string);
0079:   procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
0080:   procedure TranslateComponent(AnObject: TComponent; const TextDomain:string='');
0081:   procedure RetranslateComponent(AnObject: TComponent; const TextDomain:string='');
0082:   
0083:   // Add more domains that resourcestrings can be extracted from. If a translation
0084:   // is not found in the default domain, this domain will be searched, too.
0085:   // This is useful for adding mo files for certain runtime libraries and 3rd
0086:   // party component libraries
0087:   procedure AddDomainForResourceString (const domain:string);
0088:   procedure RemoveDomainForResourceString (const domain:string);
0089:   
0090:   // Unicode-enabled way to get resourcestrings, automatically translated
0091:   // Use like this: ws:=LoadResStringW(@NameOfResourceString);
0092:   function LoadResString(ResStringRec: PResStringRec): widestring;
0093:   function LoadResStringA(ResStringRec: PResStringRec): ansistring;
0094:   function LoadResStringW(ResStringRec: PResStringRec): widestring;
0095:   
0096:   // This returns an empty string if not translated or translator name is not specified.
0097:   function GetTranslatorNameAndEmail:widestring;
0098:   
0099:   
0100:   (*****************************************************************************)
0101:   (*                                                                           *)
0102:   (*  ADVANCED FUNCTIONALITY                                                   *)
0103:   (*                                                                           *)
0104:   (*****************************************************************************)
0105:   
0106:   const
0107:     DefaultTextDomain = 'default';
0108:   
0109:   var
0110:     ExecutableFilename:string;    // This is set to paramstr(0) or the name of the DLL you are creating.
0111:   
0112:   type
0113:     EGnuGettext=class(Exception);
0114:     EGGProgrammingError=class(EGnuGettext);
0115:     EGGComponentError=class(EGnuGettext);
0116:     EGGIOError=class(EGnuGettext);
0117:     EGGAnsi2WideConvError=class(EGnuGettext);
0118:   
0119:   // This function will turn resourcestring hooks on or off, eventually with BPL file support.
0120:   // Please do not activate BPL file support when the package is in design mode.
0121:   const AutoCreateHooks=true;
0122:   procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);
0123:   
0124:   
0125:   
0126:   
0127:   (*****************************************************************************)
0128:   (*                                                                           *)
0129:   (*  CLASS based implementation.                                              *)
0130:   (*  Use TGnuGettextInstance to have more than one language                   *)
0131:   (*  in your application at the same time                                     *)
0132:   (*                                                                           *)
0133:   (*****************************************************************************)
0134:   
0135:   {$ifdef MSWINDOWS}
0136:   {$ifndef VER140}
0137:   {$WARN UNSAFE_TYPE OFF}
0138:   {$WARN UNSAFE_CODE OFF}
0139:   {$WARN UNSAFE_CAST OFF}
0140:   {$endif}
0141:   {$endif}
0142:   
0143:   type
0144:     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
0145:     TGetPluralForm=function (Number:Longint):Integer;
0146:     TDebugLogger=procedure (line: ansistring) of object;
0147:     TMoFile= // Don't use this class. It's for internal use.
0148:       class // Threadsafe. Only constructor and destructor are writing to memory
0149:       private
0150:         doswap: boolean;
0151:       public
0152:         Users:Integer; // Reference count. If it reaches zero, this object should be destroyed.
0153:         constructor Create (filename:string;Offset,Size:int64);
0154:         destructor Destroy; override;
0155:         function gettext(const msgid: ansistring;var found:boolean): ansistring; // uses mo file
0156:         property isSwappedArchitecture:boolean read doswap;
0157:       private
0158:         N, O, T: Cardinal; // Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html
0159:         startindex,startstep:integer;
0160:         {$ifdef mswindows}
0161:         mo: THandle;
0162:         momapping: THandle;
0163:         {$endif}
0164:         momemoryHandle:PChar;
0165:         momemory: PChar;
0166:         function autoswap32(i: cardinal): cardinal;
0167:         function CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;
0168:       end;
0169:     TDomain= // Don't use this class. It's for internal use.
0170:       class
0171:       private
0172:         Enabled:boolean;
0173:         vDirectory: string;
0174:         procedure setDirectory(const dir: string);
0175:       public
0176:         DebugLogger:TDebugLogger;
0177:         Domain: string;
0178:         property Directory: string read vDirectory write setDirectory;
0179:         constructor Create;
0180:         destructor Destroy; override;
0181:         // Set parameters
0182:         procedure SetLanguageCode (const langcode:string);
0183:         procedure SetFilename (const filename:string); // Bind this domain to a specific file
0184:         // Get information
0185:         procedure GetListOfLanguages(list:TStrings);
0186:         function GetTranslationProperty(Propertyname: string): WideString;
0187:         function gettext(const msgid: ansistring): ansistring; // uses mo file
0188:       private
0189:         mofile:TMoFile;
0190:         SpecificFilename:string;
0191:         curlang: string;
0192:         OpenHasFailedBefore: boolean;
0193:         procedure OpenMoFile;
0194:         procedure CloseMoFile;
0195:       end;
0196:     TExecutable=
0197:       class
0198:         procedure Execute; virtual; abstract;
0199:       end;
0200:     TGnuGettextInstance=
0201:       class
0202:       private
0203:         fOnDebugLine:TOnDebugLine;
0204:         CreatorThread:Cardinal;  // Only this thread can use LoadResString
0205:       public
0206:         Enabled:Boolean;      // Set this to false to disable translations
0207:         DesignTimeCodePage:Integer;  // See MultiByteToWideChar() in Win32 API for documentation
0208:         constructor Create;
0209:         destructor Destroy; override;
0210:         procedure UseLanguage(LanguageCode: string);
0211:         procedure GetListOfLanguages (const domain:string; list:TStrings); // Puts list of language codes, for which there are translations in the specified domain, into list
0212:         function gettext(const szMsgId: ansistring): widestring; overload;
0213:         function gettext(const szMsgId: widestring): widestring; overload;
0214:         function ngettext(const singular,plural:ansistring;Number:longint):widestring; overload;
0215:         function ngettext(const singular,plural:widestring;Number:longint):widestring; overload;
0216:         function GetCurrentLanguage:string;
0217:         function GetTranslationProperty (const Propertyname:string):WideString;
0218:         function GetTranslatorNameAndEmail:widestring;
0219:   
0220:         // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites()
0221:         procedure TP_Ignore(AnObject:TObject; const name:string);
0222:         procedure TP_IgnoreClass (IgnClass:TClass);
0223:         procedure TP_IgnoreClassProperty (IgnClass:TClass;propertyname:string);
0224:         procedure TP_GlobalIgnoreClass (IgnClass:TClass);
0225:         procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:string);
0226:         procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
0227:         procedure TranslateProperties(AnObject: TObject; textdomain:string='');
0228:         procedure TranslateComponent(AnObject: TComponent; const TextDomain:string='');
0229:         procedure RetranslateComponent(AnObject: TComponent; const TextDomain:string='');
0230:   
0231:         // Multi-domain functions
0232:         function dgettext(const szDomain: string; const szMsgId: ansistring): widestring; overload;
0233:         function dgettext(const szDomain: string; const szMsgId: widestring): widestring; overload;
0234:         function dngettext(const szDomain: string; const singular,plural:ansistring;Number:longint):widestring; overload;
0235:         function dngettext(const szDomain: string; const singular,plural:widestring;Number:longint):widestring; overload;
0236:         procedure textdomain(const szDomain: string);
0237:         function getcurrenttextdomain: string;
0238:         procedure bindtextdomain(const szDomain: string; const szDirectory: string);
0239:         procedure bindtextdomainToFile (const szDomain: string; const filename: string); // Also works with files embedded in exe file
0240:   
0241:         // Windows API functions
0242:         function LoadResString(ResStringRec: PResStringRec): widestring;
0243:   
0244:         // Output all log info to this file. This may only be called once.
0245:         procedure DebugLogToFile (const filename:string; append:boolean=false);
0246:         procedure DebugLogPause (PauseEnabled:boolean);
0247:         property  OnDebugLine: TOnDebugLine read fOnDebugLine write fOnDebugLine; // If set, all debug output goes here
0248:   
0249:         // Conversion according to design-time character set
0250:         function ansi2wide (const s:ansistring):widestring;
0251:       protected
0252:         procedure TranslateStrings (sl:TStrings;const TextDomain:string);
0253:   
0254:         // Override these three, if you want to inherited from this class
0255:         // to create a new class that handles other domain and language dependent
0256:         // issues
0257:         procedure WhenNewLanguage (const LanguageID:string); virtual;         // Override to know when language changes
0258:         procedure WhenNewDomain (const TextDomain:string); virtual; // Override to know when text domain changes. Directory is purely informational
0259:         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.
0260:       private
0261:         curlang: string;
0262:         curGetPluralForm:TGetPluralForm;
0263:         curmsgdomain: string;
0264:         savefileCS: TMultiReadExclusiveWriteSynchronizer;
0265:         savefile: TextFile;
0266:         savememory: TStringList;
0267:         DefaultDomainDirectory:string;
0268:         domainlist: TStringList;     // List of domain names. Objects are TDomain.
0269:         TP_IgnoreList:TStringList;   // Temporary list, reset each time TranslateProperties is called
0270:         TP_ClassHandling:TList;      // Items are TClassMode. If a is derived from b, a comes first
0271:         TP_GlobalClassHandling:TList;      // Items are TClassMode. If a is derived from b, a comes first
0272:         TP_Retranslator:TExecutable; // Cast this to TTP_Retranslator
0273:         DebugLogCS:TMultiReadExclusiveWriteSynchronizer;
0274:         DebugLog:TStream;
0275:         DebugLogOutputPaused:Boolean;
0276:         function TP_CreateRetranslator:TExecutable;  // Must be freed by caller!
0277:         procedure FreeTP_ClassHandlingItems;
0278:         procedure DebugWriteln(line: ansistring);
0279:         procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;
0280:           TodoList: TStrings; const TextDomain:string);
0281:         function Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain;  // Translates a single property of an object
0282:       end;
0283:   
0284:   var
0285:     DefaultInstance:TGnuGettextInstance;
0286:   
0287:   implementation
0288:   
0289:   {$ifndef MSWINDOWS}
0290:   {$ifndef LINUX}
0291:     'This version of gnugettext.pas is only meant to be compiled with Kylix 3,'
0292:     'Delphi 6, Delphi 7 and later versions. If you use other versions, please'
0293:     'get the gnugettext.pas version from the Delphi 5 directory.'
0294:   {$endif}
0295:   {$endif}
0296:   
0297:   (**************************************************************************)
0298:   // Some comments on the implementation:
0299:   // This unit should be independent of other units where possible.
0300:   // It should have a small footprint in any way.
0301:   (**************************************************************************)
0302:   // TMultiReadExclusiveWriteSynchronizer is used instead of TCriticalSection
0303:   // because it makes this unit independent of the SyncObjs unit
0304:   (**************************************************************************)
0305:   
0306:   
0307:   type
0308:     TTP_RetranslatorItem=
0309:       class
0310:         obj:TObject;
0311:         Propname:string;
0312:         OldValue:WideString;
0313:       end;
0314:     TTP_Retranslator=
0315:       class (TExecutable)
0316:         TextDomain:string;
0317:         Instance:TGnuGettextInstance;
0318:         constructor Create;
0319:         destructor Destroy; override;
0320:         procedure Remember (obj:TObject; PropName:String; OldValue:WideString);
0321:         procedure Execute; override;
0322:       private
0323:         list:TList;
0324:       end;
0325:     TEmbeddedFileInfo=
0326:       class
0327:         offset,size:int64;
0328:       end;
0329:     TFileLocator=
0330:       class // This class finds files even when embedded inside executable
0331:         constructor Create;
0332:         destructor Destroy; override;
0333:         procedure Analyze;  // List files embedded inside executable
0334:         function FileExists (filename:string):boolean;
0335:         function GetMoFile (filename:string;DebugLogger:TDebugLogger):TMoFile;
0336:         procedure ReleaseMoFile (mofile:TMoFile);
0337:       private
0338:         basedirectory:string;
0339:         filelist:TStringList; //Objects are TEmbeddedFileInfo. Filenames are relative to .exe file
0340:         MoFilesCS:TMultiReadExclusiveWriteSynchronizer;
0341:         MoFiles:TStringList; // Objects are filenames+offset, objects are TMoFile
0342:         function ReadInt64 (str:TStream):int64;
0343:       end;
0344:     TGnuGettextComponentMarker=
0345:       class (TComponent)
0346:       public
0347:         LastLanguage:string;
0348:         Retranslator:TExecutable;
0349:         destructor Destroy; override;
0350:       end;
0351:     TClassMode=
0352:       class
0353:         HClass:TClass;
0354:         SpecialHandler:TTranslator;
0355:         PropertiesToIgnore:TStringList; // This is ignored if Handler is set
0356:         constructor Create;
0357:         destructor Destroy; override;
0358:       end;
0359:     TRStrinfo = record
0360:       strlength, stroffset: cardinal;
0361:     end;
0362:     TStrInfoArr = array[0..10000000] of TRStrinfo;
0363:     PStrInfoArr = ^TStrInfoArr;
0364:     TCharArray5=array[0..4] of ansichar;
0365:     THook=  // Replaces a runtime library procedure with a custom procedure
0366:       class
0367:       public
0368:         constructor Create (OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);
0369:         destructor Destroy; override;  // Restores unhooked state
0370:         procedure Reset (FollowJump:boolean=false); // Disables and picks up patch points again
0371:         procedure Disable;
0372:         procedure Enable;
0373:       private
0374:         oldproc,newproc:Pointer;
0375:         Patch:TCharArray5;
0376:         Original:TCharArray5;
0377:         PatchPosition:PChar;
0378:         procedure Shutdown; // Same as destroy, except that object is not destroyed
0379:       end;
0380:   
0381:   var
0382:     // System information
0383:     Win32PlatformIsUnicode:boolean=False;
0384:     
0385:     // Information about files embedded inside .exe file
0386:     FileLocator:TFileLocator;
0387:   
0388:     // Hooks into runtime library functions
0389:     ResourceStringDomainListCS:TMultiReadExclusiveWriteSynchronizer;
0390:     ResourceStringDomainList:TStringList;
0391:     HookLoadResString:THook;
0392:     HookLoadStr:THook;
0393:     HookFmtLoadStr:THook;
0394:   
0395:   function GGGetEnvironmentVariable(const Name:string):string;
0396:   var
0397:     Len: integer;
0398:     W : String;
0399:   begin
0400:     Result := '';
0401:     SetLength(W,1);
0402:     Len := Windows.GetEnvironmentVariable(PChar(Name), PChar(W), 1);
0403:     if Len > 0 then begin
0404:       SetLength(Result, Len - 1);
0405:       Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), Len);
0406:     end;
0407:   end;
0408:   
0409:   function StripCR (s:string):string;
0410:   var
0411:     i:integer;
0412:   begin
0413:     i:=1;
0414:     while i<=length(s) do begin
0415:       if s[i]=#13 then delete (s,i,1) else inc (i);
0416:     end;
0417:     Result:=s;
0418:   end;
0419:   
0420:   function LF2LineBreakA (s:string):string;
0421:   {$ifdef MSWINDOWS}
0422:   var
0423:     i:integer;
0424:   {$endif}
0425:   begin
0426:     {$ifdef MSWINDOWS}
0427:     Assert (sLinebreak=#13#10);
0428:     i:=1;
0429:     while i<=length(s) do begin
0430:       if (s[i]=#10) and (copy(s,i-1,1)<>#13) then begin
0431:         insert (#13,s,i);
0432:         inc (i,2);
0433:       end else
0434:         inc (i);
0435:     end;
0436:     {$endif}
0437:     Result:=s;
0438:   end;
0439:   
0440:   function IsWriteProp(Info: PPropInfo): Boolean;
0441:   begin
0442:     Result := Assigned(Info) and (Info^.SetProc <> nil);
0443:   end;
0444:   
0445:   function string2csyntax(s: string): string;
0446:   // Converts a string to the syntax that is used in .po files
0447:   var
0448:     i: integer;
0449:     c: char;
0450:   begin
0451:     Result := '';
0452:     for i := 1 to length(s) do begin
0453:       c := s[i];
0454:       case c of
0455:         #32..#33, #35..#255: Result := Result + c;
0456:         #13: Result := Result + '\r';
0457:         #10: Result := Result + '\n"'#13#10'"';
0458:         #34: Result := Result + '\"';
0459:       else
0460:         Result := Result + '\0x' + IntToHex(ord(c), 2);
0461:       end;
0462:     end;
0463:     Result := '"' + Result + '"';
0464:   end;
0465:   
0466:   function ResourceStringGettext(MsgId: widestring): widestring;
0467:   var
0468:     i:integer;
0469:   begin
0470:     if (MsgID='') or (ResourceStringDomainListCS=nil) then begin
0471:       // This only happens during very complicated program startups that fail,
0472:       // or when Msgid=''
0473:       Result:=MsgId;
0474:       exit;
0475:     end;
0476:     ResourceStringDomainListCS.BeginRead;
0477:     try
0478:       for i:=0 to ResourceStringDomainList.Count-1 do begin
0479:         Result:=dgettext(ResourceStringDomainList.Strings[i], MsgId);
0480:         if Result<>MsgId then
0481:           break;
0482:       end;
0483:     finally
0484:       ResourceStringDomainListCS.EndRead;
0485:     end;
0486:   end;
0487:   
0488:   function gettext(const szMsgId: widestring): widestring;
0489:   begin
0490:     Result:=DefaultInstance.gettext(szMsgId);
0491:   end;
0492:   
0493:   function _(const szMsgId: widestring): widestring;
0494:   begin
0495:     Result:=DefaultInstance.gettext(szMsgId);
0496:   end;
0497:   
0498:   function dgettext(const szDomain: string; const szMsgId: widestring): widestring;
0499:   begin
0500:     Result:=DefaultInstance.dgettext(szDomain, szMsgId);
0501:   end;
0502:   
0503:   function dngettext(const szDomain: string; const singular,plural: widestring; Number:longint): widestring;
0504:   begin
0505:     Result:=DefaultInstance.dngettext(szDomain,singular,plural,Number);
0506:   end;
0507:   
0508:   function ngettext(const singular,plural: widestring; Number:longint): widestring;
0509:   begin
0510:     Result:=DefaultInstance.ngettext(singular,plural,Number);
0511:   end;
0512:   
0513:   procedure textdomain(const szDomain: string);
0514:   begin
0515:     DefaultInstance.textdomain(szDomain);
0516:   end;
0517:   
0518:   procedure SetGettextEnabled (enabled:boolean);
0519:   begin
0520:     DefaultInstance.Enabled:=enabled;
0521:   end;
0522:   
0523:   function getcurrenttextdomain: string;
0524:   begin
0525:     Result:=DefaultInstance.getcurrenttextdomain;
0526:   end;
0527:   
0528:   procedure bindtextdomain(const szDomain: string; const szDirectory: string);
0529:   begin
0530:     DefaultInstance.bindtextdomain(szDomain, szDirectory);
0531:   end;
0532:   
0533:   procedure TP_Ignore(AnObject:TObject; const name:string);
0534:   begin
0535:     DefaultInstance.TP_Ignore(AnObject, name);
0536:   end;
0537:   
0538:   procedure TP_GlobalIgnoreClass (IgnClass:TClass);
0539:   begin
0540:     DefaultInstance.TP_GlobalIgnoreClass(IgnClass);
0541:   end;
0542:   
0543:   procedure TP_IgnoreClass (IgnClass:TClass);
0544:   begin
0545:     DefaultInstance.TP_IgnoreClass(IgnClass);
0546:   end;
0547:   
0548:   procedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:string);
0549:   begin
0550:     DefaultInstance.TP_IgnoreClassProperty(IgnClass,propertyname);
0551:   end;
0552:   
0553:   procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:string);
0554:   begin
0555:     DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass,propertyname);
0556:   end;
0557:   
0558:   procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);
0559:   begin
0560:     DefaultInstance.TP_GlobalHandleClass (HClass, Handler);
0561:   end;
0562:   
0563:   procedure TranslateComponent(AnObject: TComponent; const TextDomain:string='');
0564:   begin
0565:     DefaultInstance.TranslateComponent(AnObject, TextDomain);
0566:   end;
0567:   
0568:   procedure RetranslateComponent(AnObject: TComponent; const TextDomain:string='');
0569:   begin
0570:     DefaultInstance.RetranslateComponent(AnObject, TextDomain);
0571:   end;
0572:   
0573:   {$ifdef MSWINDOWS}
0574:   
0575:   // These constants are only used in Windows 95
0576:   // Thanks to Frank Andreas de Groot for this table
0577:   const
0578:     IDAfrikaans                 = $0436;  IDAlbanian                  = $041C;
0579:     IDArabicAlgeria             = $1401;  IDArabicBahrain             = $3C01;
0580:     IDArabicEgypt               = $0C01;  IDArabicIraq                = $0801;
0581:     IDArabicJordan              = $2C01;  IDArabicKuwait              = $3401;
0582:     IDArabicLebanon             = $3001;  IDArabicLibya               = $1001;
0583:     IDArabicMorocco             = $1801;  IDArabicOman                = $2001;
0584:     IDArabicQatar               = $4001;  IDArabic                    = $0401;
0585:     IDArabicSyria               = $2801;  IDArabicTunisia             = $1C01;
0586:     IDArabicUAE                 = $3801;  IDArabicYemen               = $2401;
0587:     IDArmenian                  = $042B;  IDAssamese                  = $044D;
0588:     IDAzeriCyrillic             = $082C;  IDAzeriLatin                = $042C;
0589:     IDBasque                    = $042D;  IDByelorussian              = $0423;
0590:     IDBengali                   = $0445;  IDBulgarian                 = $0402;
0591:     IDBurmese                   = $0455;  IDCatalan                   = $0403;
0592:     IDChineseHongKong           = $0C04;  IDChineseMacao              = $1404;
0593:     IDSimplifiedChinese         = $0804;  IDChineseSingapore          = $1004;
0594:     IDTraditionalChinese        = $0404;  IDCroatian                  = $041A;
0595:     IDCzech                     = $0405;  IDDanish                    = $0406;
0596:     IDBelgianDutch              = $0813;  IDDutch                     = $0413;
0597:     IDEnglishAUS                = $0C09;  IDEnglishBelize             = $2809;
0598:     IDEnglishCanadian           = $1009;  IDEnglishCaribbean          = $2409;
0599:     IDEnglishIreland            = $1809;  IDEnglishJamaica            = $2009;
0600:     IDEnglishNewZealand         = $1409;  IDEnglishPhilippines        = $3409;
0601:     IDEnglishSouthAfrica        = $1C09;  IDEnglishTrinidad           = $2C09;
0602:     IDEnglishUK                 = $0809;  IDEnglishUS                 = $0409;
0603:     IDEnglishZimbabwe           = $3009;  IDEstonian                  = $0425;
0604:     IDFaeroese                  = $0438;  IDFarsi                     = $0429;
0605:     IDFinnish                   = $040B;  IDBelgianFrench             = $080C;
0606:     IDFrenchCameroon            = $2C0C;  IDFrenchCanadian            = $0C0C;
0607:     IDFrenchCotedIvoire         = $300C;  IDFrench                    = $040C;
0608:     IDFrenchLuxembourg          = $140C;  IDFrenchMali                = $340C;
0609:     IDFrenchMonaco              = $180C;  IDFrenchReunion             = $200C;
0610:     IDFrenchSenegal             = $280C;  IDSwissFrench               = $100C;
0611:     IDFrenchWestIndies          = $1C0C;  IDFrenchZaire               = $240C;
0612:     IDFrisianNetherlands        = $0462;  IDGaelicIreland             = $083C;
0613:     IDGaelicScotland            = $043C;  IDGalician                  = $0456;
0614:     IDGeorgian                  = $0437;  IDGermanAustria             = $0C07;
0615:     IDGerman                    = $0407;  IDGermanLiechtenstein       = $1407;
0616:     IDGermanLuxembourg          = $1007;  IDSwissGerman               = $0807;
0617:     IDGreek                     = $0408;  IDGujarati                  = $0447;
0618:     IDHebrew                    = $040D;  IDHindi                     = $0439;
0619:     IDHungarian                 = $040E;  IDIcelandic                 = $040F;
0620:     IDIndonesian                = $0421;  IDItalian                   = $0410;
0621:     IDSwissItalian              = $0810;  IDJapanese                  = $0411;
0622:     IDKannada                   = $044B;  IDKashmiri                  = $0460;
0623:     IDKazakh                    = $043F;  IDKhmer                     = $0453;
0624:     IDKirghiz                   = $0440;  IDKonkani                   = $0457;
0625:     IDKorean                    = $0412;  IDLao                       = $0454;
0626:     IDLatvian                   = $0426;  IDLithuanian                = $0427;
0627:     IDMacedonian                = $042F;  IDMalaysian                 = $043E;
0628:     IDMalayBruneiDarussalam     = $083E;  IDMalayalam                 = $044C;
0629:     IDMaltese                   = $043A;  IDManipuri                  = $0458;
0630:     IDMarathi                   = $044E;  IDMongolian                 = $0450;
0631:     IDNepali                    = $0461;  IDNorwegianBokmol           = $0414;
0632:     IDNorwegianNynorsk          = $0814;  IDOriya                     = $0448;
0633:     IDPolish                    = $0415;  IDBrazilianPortuguese       = $0416;
0634:     IDPortuguese                = $0816;  IDPunjabi                   = $0446;
0635:     IDRhaetoRomanic             = $0417;  IDRomanianMoldova           = $0818;
0636:     IDRomanian                  = $0418;  IDRussianMoldova            = $0819;
0637:     IDRussian                   = $0419;  IDSamiLappish               = $043B;
0638:     IDSanskrit                  = $044F;  IDSerbianCyrillic           = $0C1A;
0639:     IDSerbianLatin              = $081A;  IDSesotho                   = $0430;
0640:     IDSindhi                    = $0459;  IDSlovak                    = $041B;
0641:     IDSlovenian                 = $0424;  IDSorbian                   = $042E;
0642:     IDSpanishArgentina          = $2C0A;  IDSpanishBolivia            = $400A;
0643:     IDSpanishChile              = $340A;  IDSpanishColombia           = $240A;
0644:     IDSpanishCostaRica          = $140A;  IDSpanishDominicanRepublic  = $1C0A;
0645:     IDSpanishEcuador            = $300A;  IDSpanishElSalvador         = $440A;
0646:     IDSpanishGuatemala          = $100A;  IDSpanishHonduras           = $480A;
0647:     IDMexicanSpanish            = $080A;  IDSpanishNicaragua          = $4C0A;
0648:     IDSpanishPanama             = $180A;  IDSpanishParaguay           = $3C0A;
0649:     IDSpanishPeru               = $280A;  IDSpanishPuertoRico         = $500A;
0650:     IDSpanishModernSort         = $0C0A;  IDSpanish                   = $040A;
0651:     IDSpanishUruguay            = $380A;  IDSpanishVenezuela          = $200A;
0652:     IDSutu                      = $0430;  IDSwahili                   = $0441;
0653:     IDSwedishFinland            = $081D;  IDSwedish                   = $041D;
0654:     IDTajik                     = $0428;  IDTamil                     = $0449;
0655:     IDTatar                     = $0444;  IDTelugu                    = $044A;
0656:     IDThai                      = $041E;  IDTibetan                   = $0451;
0657:     IDTsonga                    = $0431;  IDTswana                    = $0432;
0658:     IDTurkish                   = $041F;  IDTurkmen                   = $0442;
0659:     IDUkrainian                 = $0422;  IDUrdu                      = $0420;
0660:     IDUzbekCyrillic             = $0843;  IDUzbekLatin                = $0443;
0661:     IDVenda                     = $0433;  IDVietnamese                = $042A;
0662:     IDWelsh                     = $0452;  IDXhosa                     = $0434;
0663:     IDZulu                      = $0435;
0664:   
0665:   function GetWindowsLanguage: string;
0666:   var
0667:     langid: Cardinal;
0668:     langcode: string;
0669:     CountryName: array[0..4] of char;
0670:     LanguageName: array[0..4] of char;
0671:     works: boolean;
0672:   begin
0673:     // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero
0674:     works := 3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName));
0675:     works := works and (3 = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName,
0676:       SizeOf(CountryName)));
0677:     if works then begin
0678:       // Windows 98, Me, NT4, 2000, XP and newer
0679:       LangCode := PChar(@LanguageName[0]);
0680:       if lowercase(LangCode)='no' then LangCode:='nb';
0681:       LangCode:=LangCode + '_' + PChar(@CountryName[0]);
0682:     end else begin
0683:       // This part should only happen on Windows 95.
0684:       langid := GetThreadLocale;
0685:       case langid of
0686:         IDBelgianDutch: langcode := 'nl_BE';
0687:         IDBelgianFrench: langcode := 'fr_BE';
0688:         IDBrazilianPortuguese: langcode := 'pt_BR';
0689:         IDDanish: langcode := 'da_DK';
0690:         IDDutch: langcode := 'nl_NL';
0691:         IDEnglishUK: langcode := 'en_GB';
0692:         IDEnglishUS: langcode := 'en_US';
0693:         IDFinnish: langcode := 'fi_FI';
0694:         IDFrench: langcode := 'fr_FR';
0695:         IDFrenchCanadian: langcode := 'fr_CA';
0696:         IDGerman: langcode := 'de_DE';
0697:         IDGermanLuxembourg: langcode := 'de_LU';
0698:         IDGreek: langcode := 'el_GR';
0699:         IDIcelandic: langcode := 'is_IS';
0700:         IDItalian: langcode := 'it_IT';
0701:         IDKorean: langcode := 'ko_KO';
0702:         IDNorwegianBokmol: langcode := 'nb_NO';
0703:         IDNorwegianNynorsk: langcode := 'nn_NO';
0704:         IDPolish: langcode := 'pl_PL';
0705:         IDPortuguese: langcode := 'pt_PT';
0706:         IDRussian: langcode := 'ru_RU';
0707:         IDSpanish, IDSpanishModernSort: langcode := 'es_ES';
0708:         IDSwedish: langcode := 'sv_SE';
0709:         IDSwedishFinland: langcode := 'sv_FI';
0710:       else
0711:         langcode := 'C';
0712:       end;
0713:     end;
0714:     Result := langcode;
0715:   end;
0716:   {$endif}
0717:   
0718:   function LoadResStringA(ResStringRec: PResStringRec): string;
0719:   begin
0720:     Result:=DefaultInstance.LoadResString(ResStringRec);
0721:   end;
0722:   
0723:   function GetTranslatorNameAndEmail:widestring;
0724:   begin
0725:     Result:=DefaultInstance.GetTranslatorNameAndEmail;
0726:   end;
0727:   
0728:   procedure UseLanguage(LanguageCode: string);
0729:   begin
0730:     DefaultInstance.UseLanguage(LanguageCode);
0731:   end;
0732:   
0733:   type
0734:     PStrData = ^TStrData;
0735:     TStrData = record
0736:       Ident: Integer;
0737:       Str: string;
0738:     end;
0739:     
0740:   function SysUtilsEnumStringModules(Instance: Longint; Data: Pointer): Boolean;
0741:   {$IFDEF MSWINDOWS}
0742:   var
0743:     Buffer: array [0..1023] of char;
0744:   begin
0745:     with PStrData(Data)^ do begin
0746:       SetString(Str, Buffer,
0747:         LoadString(Instance, Ident, Buffer, sizeof(Buffer)));
0748:       Result := Str = '';
0749:     end;
0750:   end;
0751:   {$ENDIF}
0752:   {$IFDEF LINUX}
0753:   var
0754:     rs:TResStringRec;
0755:     Module:HModule;
0756:   begin
0757:     Module:=Instance;
0758:     rs.Module:=@Module;
0759:     with PStrData(Data)^ do begin
0760:       rs.Identifier:=Ident;
0761:       Str:=System.LoadResString(@rs);
0762:       Result:=Str='';
0763:     end;
0764:   end;
0765:   {$ENDIF}
0766:   
0767:   function SysUtilsFindStringResource(Ident: Integer): string;
0768:   var
0769:     StrData: TStrData;
0770:   begin
0771:     StrData.Ident := Ident;
0772:     StrData.Str := '';
0773:     EnumResourceModules(SysUtilsEnumStringModules, @StrData);
0774:     Result := StrData.Str;
0775:   end;
0776:   
0777:   function SysUtilsLoadStr(Ident: Integer): string;
0778:   begin
0779:     {$ifdef DXGETTEXTDEBUG}
0780:     DefaultInstance.DebugWriteln ('Sysutils.LoadRes('+IntToStr(ident)+') called');
0781:     {$endif}
0782:     Result := ResourceStringGettext(SysUtilsFindStringResource(Ident));
0783:   end;
0784:   
0785:   function SysUtilsFmtLoadStr(Ident: Integer; const Args: array of const): string;
0786:   begin
0787:     {$ifdef DXGETTEXTDEBUG}
0788:     DefaultInstance.DebugWriteln ('Sysutils.FmtLoadRes('+IntToStr(ident)+',Args) called');
0789:     {$endif}
0790:     FmtStr(Result, SysUtilsFindStringResource(Ident), Args);
0791:     Result:=ResourceStringGettext(Result);
0792:   end;
0793:   
0794:   function LoadResString(ResStringRec: PResStringRec): widestring;
0795:   begin
0796:     Result:=DefaultInstance.LoadResString(ResStringRec);
0797:   end;
0798:   
0799:   function LoadResStringW(ResStringRec: PResStringRec): widestring;
0800:   begin
0801:     Result:=DefaultInstance.LoadResString(ResStringRec);
0802:   end;
0803:   
0804:   
0805:   
0806:   function GetCurrentLanguage:string;
0807:   begin
0808:     Result:=DefaultInstance.GetCurrentLanguage;
0809:   end;
0810:   
0811:   { TDomain }
0812:   
0813:   procedure TDomain.CloseMoFile;
0814:   begin
0815:     if mofile<>nil then begin
0816:       FileLocator.ReleaseMoFile(mofile);
0817:       mofile:=nil;
0818:     end;
0819:     OpenHasFailedBefore:=False;
0820:   end;
0821:   
0822:   destructor TDomain.Destroy;
0823:   begin
0824:     CloseMoFile;
0825:     inherited;
0826:   end;
0827:   
0828:   {$ifdef mswindows}
0829:   function GetLastWinError:string;
0830:   var
0831:     errcode:Cardinal;
0832:   begin
0833:     SetLength (Result,2000);
0834:     errcode:=GetLastError();
0835:     Windows.FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PChar(Result),2000,nil);
0836:     Result:=StrPas(PChar(Result));
0837:   end;
0838:   {$endif}
0839:   
0840:   procedure TDomain.OpenMoFile;
0841:   var
0842:     filename: string;
0843:   begin
0844:     // Check if it is already open
0845:     if mofile<>nil then
0846:       exit;
0847:   
0848:     // Check if it has been attempted to open the file before
0849:     if OpenHasFailedBefore then
0850:       exit;
0851:   
0852:     if SpecificFilename<>'' then
0853:       filename:=SpecificFilename
0854:     else begin
0855:       filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
0856:       if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then
0857:         filename := Directory + copy(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
0858:     end;
0859:     if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin
0860:       OpenHasFailedBefore:=True;
0861:       exit;
0862:     end;
0863:     mofile:=FileLocator.GetMoFile(filename, DebugLogger);
0864:   
0865:     {$ifdef DXGETTEXTDEBUG}
0866:     if mofile.isSwappedArchitecture then
0867:       DebugLogger ('.mo file is swapped (comes from another CPU architecture)');
0868:     {$endif}
0869:   
0870:     // Check, that the contents of the file is utf-8
0871:     if pos('CHARSET=UTF-8',uppercase(GetTranslationProperty('Content-Type')))=0 then begin
0872:       CloseMoFile;
0873:       {$ifdef DXGETTEXTDEBUG}
0874:       DebugLogger ('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.');
0875:       {$endif}
0876:       {$ifdef MSWINDOWS}
0877:       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);
0878:       {$else}
0879:       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.');
0880:       {$endif}
0881:       Enabled:=False;
0882:     end;
0883:   end;
0884:   
0885:   function TDomain.GetTranslationProperty(
0886:     Propertyname: string): WideString;
0887:   var
0888:     sl:TStringList;
0889:     i:integer;
0890:     s:string;
0891:   begin
0892:     Propertyname:=uppercase(Propertyname)+': ';
0893:     sl:=TStringList.Create;
0894:     try
0895:       sl.Text:=utf8encode(gettext(''));
0896:       for i:=0 to sl.Count-1 do begin
0897:         s:=sl.Strings[i];
0898:         if uppercase(copy(s,1,length(Propertyname)))=Propertyname then begin
0899:           Result:=utf8decode(trim(copy(s,length(PropertyName)+1,maxint)));
0900:           {$ifdef DXGETTEXTDEBUG}
0901:           DebugLogger ('GetTranslationProperty('+PropertyName+') returns '''+Result+'''.');
0902:           {$endif}
0903:           exit;
0904:         end;
0905:       end;
0906:     finally
0907:       FreeAndNil (sl);
0908:     end;
0909:     Result:='';
0910:     {$ifdef DXGETTEXTDEBUG}
0911:     DebugLogger ('GetTranslationProperty('+PropertyName+') did not find any value. An empty string is returned.');
0912:     {$endif}
0913:   end;
0914:   
0915:   procedure TDomain.setDirectory(const dir: string);
0916:   begin
0917:     vDirectory := IncludeTrailingPathDelimiter(dir);
0918:     SpecificFilename:='';
0919:     CloseMoFile;
0920:   end;
0921:   
0922:   procedure AddDomainForResourceString (const domain:string);
0923:   begin
0924:     {$ifdef DXGETTEXTDEBUG}
0925:     DefaultInstance.DebugWriteln ('Extra domain for resourcestring: '+domain);
0926:     {$endif}
0927:     ResourceStringDomainListCS.BeginWrite;
0928:     try
0929:       if ResourceStringDomainList.IndexOf(domain)=-1 then
0930:         ResourceStringDomainList.Add (domain);
0931:     finally
0932:       ResourceStringDomainListCS.EndWrite;
0933:     end;
0934:   end;
0935:   
0936:   procedure RemoveDomainForResourceString (const domain:string);
0937:   var
0938:     i:integer;
0939:   begin
0940:     {$ifdef DXGETTEXTDEBUG}
0941:     DefaultInstance.DebugWriteln ('Remove domain for resourcestring: '+domain);
0942:     {$endif}
0943:     ResourceStringDomainListCS.BeginWrite;
0944:     try
0945:       i:=ResourceStringDomainList.IndexOf(domain);
0946:       if i<>-1 then
0947:         ResourceStringDomainList.Delete (i);
0948:     finally
0949:       ResourceStringDomainListCS.EndWrite;
0950:     end;
0951:   end;
0952:   
0953:   procedure TDomain.SetLanguageCode(const langcode: string);
0954:   begin
0955:     CloseMoFile;
0956:     curlang:=langcode;
0957:   end;
0958:   
0959:   function GetPluralForm2EN(Number: Integer): Integer;
0960:   begin
0961:     Number:=abs(Number);
0962:     if Number=1 then Result:=0 else Result:=1;
0963:   end;
0964:   
0965:   function GetPluralForm1(Number: Integer): Integer;
0966:   begin
0967:     Result:=0;
0968:   end;
0969:   
0970:   function GetPluralForm2FR(Number: Integer): Integer;
0971:   begin
0972:     Number:=abs(Number);
0973:     if (Number=1) or (Number=0) then Result:=0 else Result:=1;
0974:   end;
0975:   
0976:   function GetPluralForm3LV(Number: Integer): Integer;
0977:   begin
0978:     Number:=abs(Number);
0979:     if (Number mod 10=1) and (Number mod 100<>11) then
0980:       Result:=0
0981:     else
0982:       if Number<>0 then Result:=1
0983:                    else Result:=2;
0984:   end;
0985:   
0986:   function GetPluralForm3GA(Number: Integer): Integer;
0987:   begin
0988:     Number:=abs(Number);
0989:     if Number=1 then Result:=0
0990:     else if Number=2 then Result:=1
0991:     else Result:=2;
0992:   end;
0993:   
0994:   function GetPluralForm3LT(Number: Integer): Integer;
0995:   var
0996:     n1,n2:byte;
0997:   begin
0998:     Number:=abs(Number);
0999:     n1:=Number mod 10;
1000:     n2:=Number mod 100;
1001:     if (n1=1) and (n2<>11) then
1002:       Result:=0
1003:     else
1004:       if (n1>=2) and ((n2<10) or (n2>=20)) then Result:=1
1005:       else Result:=2;
1006:   end;
1007:   
1008:   function GetPluralForm3PL(Number: Integer): Integer;
1009:   var
1010:     n1,n2:byte;
1011:   begin
1012:     Number:=abs(Number);
1013:     n1:=Number mod 10;
1014:     n2:=Number mod 100;
1015:     if n1=1 then Result:=0
1016:     else if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
1017:     else Result:=2;
1018:   end;
1019:   
1020:   function GetPluralForm3RU(Number: Integer): Integer;
1021:   var
1022:     n1,n2:byte;
1023:   begin
1024:     Number:=abs(Number);
1025:     n1:=Number mod 10;
1026:     n2:=Number mod 100;
1027:     if (n1=1) and (n2<>11) then
1028:       Result:=0
1029:     else
1030:       if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1
1031:       else Result:=2;
1032:   end;
1033:   
1034:   function GetPluralForm4SL(Number: Integer): Integer;
1035:   var
1036:     n2:byte;
1037:   begin
1038:     Number:=abs(Number);
1039:     n2:=Number mod 100;
1040:     if n2=1 then Result:=0
1041:     else
1042:     if n2=2 then Result:=1
1043:     else
1044:     if (n2=3) or (n2=4) then Result:=2
1045:     else
1046:       Result:=3;
1047:   end;
1048:   
1049:   procedure TDomain.GetListOfLanguages(list: TStrings);
1050:   var
1051:     sr:TSearchRec;
1052:     more:boolean;
1053:     filename, path, langcode:string;
1054:     i, j:integer;
1055:   begin
1056:     list.Clear;
1057:   
1058:     // Iterate through filesystem
1059:     more:=FindFirst (Directory+'*',faAnyFile,sr)=0;
1060:     while more do begin
1061:       if (sr.Attr and faDirectory<>0) and (sr.name<>'.') and (sr.name<>'..') then begin
1062:         filename := Directory + sr.Name + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
1063:         if fileexists(filename) then begin
1064:           langcode:=lowercase(sr.name);
1065:           if list.IndexOf(langcode)=-1 then
1066:             list.Add(langcode);
1067:         end;
1068:       end;
1069:       more:=FindNext (sr)=0;
1070:     end;
1071:   
1072:     // Iterate through embedded files
1073:     for i:=0 to FileLocator.filelist.Count-1 do begin
1074:       filename:=FileLocator.basedirectory+FileLocator.filelist.Strings[i];
1075:       path:=Directory;
1076:       {$ifdef MSWINDOWS}
1077:       path:=uppercase(path);
1078:       filename:=uppercase(filename);
1079:       {$endif}
1080:       j:=length(path);
1081:       if copy(filename,1,j)=path then begin
1082:         path:=PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';
1083:         {$ifdef MSWINDOWS}
1084:         path:=uppercase(path);
1085:         {$endif}
1086:         if copy(filename,length(filename)-length(path)+1,length(path))=path then begin
1087:           langcode:=lowercase(copy(filename,j+1,length(filename)-length(path)-j));
1088:           if list.IndexOf(langcode)=-1 then
1089:             list.Add(langcode);
1090:         end;
1091:       end;
1092:     end;
1093:   end;
1094:   
1095:   procedure TDomain.SetFilename(const filename: string);
1096:   begin
1097:     CloseMoFile;
1098:     vDirectory := '';
1099:     SpecificFilename:=filename;
1100:   end;
1101:   
1102:   function TDomain.gettext(const msgid: ansistring): ansistring;
1103:   var
1104:     found:boolean;
1105:   begin
1106:     if not Enabled then begin
1107:       Result:=msgid;
1108:       exit;
1109:     end;
1110:     if (mofile=nil) and (not OpenHasFailedBefore) then
1111:       OpenMoFile;
1112:     if mofile=nil then begin
1113:       {$ifdef DXGETTEXTDEBUG}
1114:       DebugLogger('.mo file is not open. Not translating "'+msgid+'"');
1115:       {$endif}
1116:       Result := msgid;
1117:     end else begin
1118:       Result:=mofile.gettext(msgid,found);
1119:       {$ifdef DXGETTEXTDEBUG}
1120:       if found then
1121:         DebugLogger ('Found in .mo ('+Domain+'): "'+utf8encode(msgid)+'"->"'+utf8encode(Result)+'"')
1122:       else
1123:         DebugLogger ('Translation not found in .mo file ('+Domain+') : "'+utf8encode(msgid)+'"');
1124:       {$endif}
1125:     end;
1126:   end;
1127:   
1128:   constructor TDomain.Create;
1129:   begin
1130:     inherited Create;
1131:     Enabled:=True;
1132:   end;
1133:   
1134:   { TGnuGettextInstance }
1135:   
1136:   procedure TGnuGettextInstance.bindtextdomain(const szDomain,
1137:     szDirectory: string);
1138:   var
1139:     dir:string;
1140:   begin
1141:     dir:=IncludeTrailingPathDelimiter(szDirectory);
1142:     {$ifdef DXGETTEXTDEBUG}
1143:     DebugWriteln ('Text domain "'+szDomain+'" is now located at "'+dir+'"');
1144:     {$endif}
1145:     getdomain(szDomain,DefaultDomainDirectory,CurLang).Directory := dir;
1146:     WhenNewDomainDirectory (szDomain, szDirectory);
1147:   end;
1148:   
1149:   constructor TGnuGettextInstance.Create;
1150:   begin
1151:     CreatorThread:=GetCurrentThreadId;
1152:     {$ifdef MSWindows}
1153:     DesignTimeCodePage:=CP_ACP;
1154:     {$endif}
1155:     {$ifdef DXGETTEXTDEBUG}
1156:     DebugLogCS:=TMultiReadExclusiveWriteSynchronizer.Create;
1157:     DebugLog:=TMemoryStream.Create;
1158:     DebugWriteln('Debug log started '+DateTimeToStr(Now));
1159:     DebugWriteln('');
1160:     {$endif}
1161:     curGetPluralForm:=GetPluralForm2EN;
1162:     Enabled:=True;
1163:     curmsgdomain:=DefaultTextDomain;
1164:     savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;
1165:     domainlist := TStringList.Create;
1166:     TP_IgnoreList:=TStringList.Create;
1167:     TP_IgnoreList.Sorted:=True;
1168:     TP_GlobalClassHandling:=TList.Create;
1169:     TP_ClassHandling:=TList.Create;
1170:   
1171:     // Set some settings
1172:     DefaultDomainDirectory := IncludeTrailingPathDelimiter(extractfilepath(ExecutableFilename))+'locale';
1173:   
1174:     UseLanguage('');
1175:   
1176:     bindtextdomain(DefaultTextDomain, DefaultDomainDirectory);
1177:     textdomain(DefaultTextDomain);
1178:   
1179:     // Add default properties to ignore
1180:     TP_GlobalIgnoreClassProperty(TComponent,'Name');
1181:     TP_GlobalIgnoreClassProperty(TCollection,'PropName');
1182:   end;
1183:   
1184:   destructor TGnuGettextInstance.Destroy;
1185:   begin
1186:     if savememory <> nil then begin
1187:       savefileCS.BeginWrite;
1188:       try
1189:         CloseFile(savefile);
1190:       finally
1191:         savefileCS.EndWrite;
1192:       end;
1193:       FreeAndNil(savememory);
1194:     end;
1195:     FreeAndNil (savefileCS);
1196:     FreeAndNil (TP_IgnoreList);
1197:     while TP_GlobalClassHandling.Count<>0 do begin
1198:       TObject(TP_GlobalClassHandling.Items[0]).Free;
1199:       TP_GlobalClassHandling.Delete(0);
1200:     end;
1201:     FreeAndNil (TP_GlobalClassHandling);
1202:     FreeTP_ClassHandlingItems;
1203:     FreeAndNil (TP_ClassHandling);
1204:     while domainlist.Count <> 0 do begin
1205:       domainlist.Objects[0].Free;
1206:       domainlist.Delete(0);
1207:     end;
1208:     FreeAndNil(domainlist);
1209:     {$ifdef DXGETTEXTDEBUG}
1210:     FreeAndNil (DebugLog);
1211:     FreeAndNil (DebugLogCS);
1212:     {$endif}
1213:     inherited;
1214:   end;
1215:   
1216:   function TGnuGettextInstance.dgettext(const szDomain: string; const szMsgId: ansistring): widestring;
1217:   begin
1218:     Result:=dgettext(szDomain, ansi2wide(szMsgId));
1219:   end;
1220:   
1221:   function TGnuGettextInstance.dgettext(const szDomain: string;
1222:     const szMsgId: widestring): widestring;
1223:   begin
1224:     if not Enabled then begin
1225:       {$ifdef DXGETTEXTDEBUG}
1226:       DebugWriteln ('Translation has been disabled. Text is not being translated: '+szMsgid);
1227:       {$endif}
1228:       Result:=szMsgId;
1229:     end else begin
1230:       Result:=UTF8Decode(LF2LineBreakA(getdomain(szDomain,DefaultDomainDirectory,CurLang).gettext(StripCR(utf8encode(szMsgId)))));
1231:       {$ifdef DXGETTEXTDEBUG}
1232:       if (szMsgId<>'') and (Result='') then
1233:         DebugWriteln (Format('Error: Translation of %s was an empty string. This may never occur.',[szMsgId]));
1234:       {$endif}
1235:     end;
1236:   end;
1237:   
1238:   function TGnuGettextInstance.GetCurrentLanguage: string;
1239:   begin
1240:     Result:=curlang;
1241:   end;
1242:   
1243:   function TGnuGettextInstance.getcurrenttextdomain: string;
1244:   begin
1245:     Result := curmsgdomain;
1246:   end;
1247:   
1248:   function TGnuGettextInstance.gettext(
1249:     const szMsgId: ansistring): widestring;
1250:   begin
1251:     Result := dgettext(curmsgdomain, szMsgId);
1252:   end;
1253:   
1254:   function TGnuGettextInstance.gettext(
1255:     const szMsgId: widestring): widestring;
1256:   begin
1257:     Result := dgettext(curmsgdomain, szMsgId);
1258:   end;
1259:   
1260:   procedure TGnuGettextInstance.textdomain(const szDomain: string);
1261:   begin
1262:     {$ifdef DXGETTEXTDEBUG}
1263:     DebugWriteln ('Changed text domain to "'+szDomain+'"');
1264:     {$endif}
1265:     curmsgdomain := szDomain;
1266:     WhenNewDomain (szDomain);
1267:   end;
1268:   
1269:   function TGnuGettextInstance.TP_CreateRetranslator : TExecutable;
1270:   var
1271:     ttpr:TTP_Retranslator;
1272:   begin
1273:     ttpr:=TTP_Retranslator.Create;
1274:     ttpr.Instance:=self;
1275:     TP_Retranslator:=ttpr;
1276:     Result:=ttpr;
1277:     {$ifdef DXGETTEXTDEBUG}
1278:     DebugWriteln ('A retranslator was created.');
1279:     {$endif}
1280:   end;
1281:   
1282:   procedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass;
1283:     Handler: TTranslator);
1284:   var
1285:     cm:TClassMode;
1286:     i:integer;
1287:   begin
1288:     for i:=0 to TP_GlobalClassHandling.Count-1 do begin
1289:       cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
1290:       if cm.HClass=HClass then
1291:         raise EGGProgrammingError.Create ('You cannot set a handler for a class that has already been assigned otherwise.');
1292:       if HClass.InheritsFrom(cm.HClass) then begin
1293:         // This is the place to insert this class
1294:         cm:=TClassMode.Create;
1295:         cm.HClass:=HClass;
1296:         cm.SpecialHandler:=Handler;
1297:         TP_GlobalClassHandling.Insert(i,cm);
1298:         {$ifdef DXGETTEXTDEBUG}
1299:         DebugWriteln ('A handler was set for class '+HClass.ClassName+'.');
1300:         {$endif}
1301:         exit;
1302:       end;
1303:     end;
1304:     cm:=TClassMode.Create;
1305:     cm.HClass:=HClass;
1306:     cm.SpecialHandler:=Handler;
1307:     TP_GlobalClassHandling.Add(cm);
1308:     {$ifdef DXGETTEXTDEBUG}
1309:     DebugWriteln ('A handler was set for class '+HClass.ClassName+'.');
1310:     {$endif}
1311:   end;
1312:   
1313:   procedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass);
1314:   var
1315:     cm:TClassMode;
1316:     i:integer;
1317:   begin
1318:     for i:=0 to TP_GlobalClassHandling.Count-1 do begin
1319:       cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
1320:       if cm.HClass=IgnClass then
1321:         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.');
1322:       if IgnClass.InheritsFrom(cm.HClass) then begin
1323:         // This is the place to insert this class
1324:         cm:=TClassMode.Create;
1325:         cm.HClass:=IgnClass;
1326:         TP_GlobalClassHandling.Insert(i,cm);
1327:         {$ifdef DXGETTEXTDEBUG}
1328:         DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');
1329:         {$endif}
1330:         exit;
1331:       end;
1332:     end;
1333:     cm:=TClassMode.Create;
1334:     cm.HClass:=IgnClass;
1335:     TP_GlobalClassHandling.Add(cm);
1336:     {$ifdef DXGETTEXTDEBUG}
1337:     DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');
1338:     {$endif}
1339:   end;
1340:   
1341:   procedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(
1342:     IgnClass: TClass; propertyname: string);
1343:   var
1344:     cm:TClassMode;
1345:     i,idx:integer;
1346:   begin
1347:     propertyname:=uppercase(propertyname);
1348:     for i:=0 to TP_GlobalClassHandling.Count-1 do begin
1349:       cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;
1350:       if cm.HClass=IgnClass then begin
1351:         if Assigned(cm.SpecialHandler) then
1352:           raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.');
1353:         if not cm.PropertiesToIgnore.Find(propertyname,idx) then
1354:           cm.PropertiesToIgnore.Add(propertyname);
1355:         {$ifdef DXGETTEXTDEBUG}
1356:         DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
1357:         {$endif}
1358:         exit;
1359:       end;
1360:       if IgnClass.InheritsFrom(cm.HClass) then begin
1361:         // This is the place to insert this class
1362:         cm:=TClassMode.Create;
1363:         cm.HClass:=IgnClass;
1364:         cm.PropertiesToIgnore.Add(propertyname);
1365:         TP_GlobalClassHandling.Insert(i,cm);
1366:         {$ifdef DXGETTEXTDEBUG}
1367:         DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
1368:         {$endif}
1369:         exit;
1370:       end;
1371:     end;
1372:     cm:=TClassMode.Create;
1373:     cm.HClass:=IgnClass;
1374:     cm.PropertiesToIgnore.Add(propertyname);
1375:     TP_GlobalClassHandling.Add(cm);
1376:     {$ifdef DXGETTEXTDEBUG}
1377:     DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
1378:     {$endif}
1379:   end;
1380:   
1381:   procedure TGnuGettextInstance.TP_Ignore(AnObject: TObject;
1382:     const name: string);
1383:   begin
1384:     TP_IgnoreList.Add(uppercase(name));
1385:     {$ifdef DXGETTEXTDEBUG}
1386:     DebugWriteln ('On object with class name '+AnObject.ClassName+', ignore is set on '+name);
1387:     {$endif}
1388:   end;
1389:   
1390:   procedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent;
1391:     const TextDomain: string);
1392:   var
1393:     comp:TGnuGettextComponentMarker;
1394:   begin
1395:     {$ifdef DXGETTEXTDEBUG}
1396:     DebugWriteln ('======================================================================');
1397:     DebugWriteln ('TranslateComponent() was called for a component with name '+AnObject.Name+'.');
1398:     {$endif}
1399:     comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
1400:     if comp=nil then begin
1401:       comp:=TGnuGettextComponentMarker.Create (nil);
1402:       comp.Name:='GNUgettextMarker';
1403:       comp.Retranslator:=TP_CreateRetranslator;
1404:       TranslateProperties (AnObject, TextDomain);
1405:       AnObject.InsertComponent(comp);
1406:       {$ifdef DXGETTEXTDEBUG}
1407:       DebugWriteln ('This is the first time, that this component has been translated. A retranslator component has been created for this component.');
1408:       {$endif}
1409:     end else begin
1410:       {$ifdef DXGETTEXTDEBUG}
1411:       DebugWriteln ('This is not the first time, that this component has been translated.');
1412:       {$endif}
1413:       if comp.LastLanguage<>curlang then begin
1414:         {$ifdef DXGETTEXTDEBUG}
1415:         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.');
1416:         {$endif}
1417:         {$ifdef mswindows}
1418:         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);
1419:         {$else}
1420:         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.');
1421:         {$endif}
1422:       end else begin
1423:         {$ifdef DXGETTEXTDEBUG}
1424:         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.');
1425:         {$endif}
1426:       end;
1427:     end;
1428:     comp.LastLanguage:=curlang;
1429:     {$ifdef DXGETTEXTDEBUG}
1430:     DebugWriteln ('======================================================================');
1431:     {$endif}
1432:   end;
1433:   
1434:   procedure TGnuGettextInstance.TranslateProperty (AnObject:TObject; PropInfo:PPropInfo; TodoList:TStrings; const TextDomain:string);
1435:   var
1436:     ppi:PPropInfo;
1437:     ws: WideString;
1438:     old: WideString;
1439:     obj:TObject;
1440:     Propname:string;
1441:   begin
1442:     PropName:=PropInfo^.Name;
1443:     try
1444:       // Translate certain types of properties
1445:       case PropInfo^.PropType^.Kind of
1446:         tkString, tkLString, tkWString:
1447:           begin
1448:             {$ifdef DXGETTEXTDEBUG}
1449:             DebugWriteln ('Translating '+AnObject.ClassName+'.'+PropName);
1450:             {$endif}
1451:             if PropInfo^.PropType^.Kind<>tkWString then
1452:               old := ansi2wide(GetStrProp(AnObject, PropName))
1453:             else
1454:               old := GetWideStrProp(AnObject, PropName);
1455:             {$ifdef DXGETTEXTDEBUG}
1456:             if old='' then
1457:               DebugWriteln ('(Empty, not translated)')
1458:             else
1459:               DebugWriteln ('Old value: "'+old+'"');
1460:             {$endif}
1461:             if (old <> '') and (IsWriteProp(PropInfo)) then begin
1462:               if TP_Retranslator<>nil then
1463:                 (TP_Retranslator as TTP_Retranslator).Remember(AnObject, PropName, old);
1464:               ws := dgettext(textdomain,old);
1465:               if ws <> old then begin
1466:                 ppi:=GetPropInfo(AnObject, Propname);
1467:                 if ppi<>nil then begin
1468:                   SetWideStrProp(AnObject, ppi, ws);
1469:                 end else begin
1470:                   DebugWriteln ('ERROR: Property disappeared: '+Propname+' for object of type '+AnObject.ClassName);
1471:                 end;
1472:               end;
1473:             end;
1474:           end { case item };
1475:         tkClass:
1476:           begin
1477:             obj:=GetObjectProp(AnObject, PropName);
1478:             if obj<>nil then 
1479:               TodoList.AddObject ('',obj);
1480:           end { case item };
1481:         end { case };
1482:     except
1483:       on E:Exception do
1484:         raise EGGComponentError.Create ('Property cannot be translated.'+sLineBreak+
1485:           'Add TP_GlobalIgnoreClassProperty('+AnObject.ClassName+','''+PropName+''') to your source code or use'+sLineBreak+
1486:           'TP_Ignore (self,''.'+PropName+''') to prevent this message.'+sLineBreak+
1487:           'Reason: '+e.Message);
1488:     end;
1489:   end;
1490:   
1491:   procedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; textdomain:string='');
1492:   var
1493:     TodoList:TStringList; // List of Name/TObject's that is to be processed
1494:     DoneList:TStringList; // List of hex codes representing pointers to objects that have been done
1495:     i, j, Count: integer;
1496:     PropList: PPropList;
1497:     UPropName: string;
1498:     PropInfo: PPropInfo;
1499:     comp:TComponent;
1500:     cm,currentcm:TClassMode;
1501:     ObjectPropertyIgnoreList:TStringList;
1502:     objid, Name:string;
1503:   begin
1504:     {$ifdef DXGETTEXTDEBUG}
1505:     DebugWriteln ('----------------------------------------------------------------------');
1506:     DebugWriteln ('TranslateProperties() was called for an object of class '+AnObject.ClassName+' with domain "'+textdomain+'".');
1507:     {$endif}
1508:     if textdomain='' then
1509:       textdomain:=curmsgdomain;
1510:     if TP_Retranslator<>nil then
1511:       (TP_Retranslator as TTP_Retranslator).TextDomain:=textdomain;
1512:     DoneList:=TStringList.Create;
1513:     TodoList:=TStringList.Create;
1514:     ObjectPropertyIgnoreList:=TStringList.Create;
1515:     try
1516:       TodoList.AddObject('', AnObject);
1517:       DoneList.Sorted:=True;
1518:       ObjectPropertyIgnoreList.Sorted:=True;
1519:       ObjectPropertyIgnoreList.Duplicates:=dupIgnore;
1520:       ObjectPropertyIgnoreList.CaseSensitive:=False;
1521:       DoneList.Duplicates:=dupError;
1522:       DoneList.CaseSensitive:=True;
1523:   
1524:       while TodoList.Count<>0 do begin
1525:         AnObject:=TodoList.Objects[0];
1526:         Name:=TodoList.Strings[0];
1527:         TodoList.Delete(0);
1528:         if (AnObject<>nil) and (AnObject is TPersistent) then begin
1529:           // Make sure each object is only translated once
1530:           Assert (sizeof(integer)=sizeof(TObject));
1531:           objid:=IntToHex(integer(AnObject),8);
1532:           if DoneList.Find(objid,i) then begin
1533:             continue;
1534:           end else begin
1535:             DoneList.Add(objid);
1536:           end;
1537:   
1538:           ObjectPropertyIgnoreList.Clear;
1539:   
1540:           // Find out if there is special handling of this object
1541:           currentcm:=nil;
1542:           // First check the local handling instructions
1543:           for j:=0 to TP_ClassHandling.Count-1 do begin
1544:             cm:=TObject(TP_ClassHandling.Items[j]) as TClassMode;
1545:             if AnObject.InheritsFrom(cm.HClass) then begin
1546:               if cm.PropertiesToIgnore.Count<>0 then begin
1547:                 ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);
1548:               end else begin
1549:                 // Ignore the entire class
1550:                 currentcm:=cm;
1551:                 break;
1552:               end;
1553:             end;
1554:           end;
1555:           // Then check the global handling instructions
1556:           if currentcm=nil then
1557:           for j:=0 to TP_GlobalClassHandling.Count-1 do begin
1558:             cm:=TObject(TP_GlobalClassHandling.Items[j]) as TClassMode;
1559:             if AnObject.InheritsFrom(cm.HClass) then begin
1560:               if cm.PropertiesToIgnore.Count<>0 then begin
1561:                 ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);
1562:               end else begin
1563:                 // Ignore the entire class
1564:                 currentcm:=cm;
1565:                 break;
1566:               end;
1567:             end;
1568:           end;
1569:           if currentcm<>nil then begin
1570:             ObjectPropertyIgnoreList.Clear;
1571:             // Ignore or use special handler
1572:             if Assigned(currentcm.SpecialHandler) then begin
1573:               currentcm.SpecialHandler (AnObject);
1574:               {$ifdef DXGETTEXTDEBUG}
1575:               DebugWriteln ('Special handler activated for '+AnObject.ClassName);
1576:               {$endif}
1577:             end else begin
1578:               {$ifdef DXGETTEXTDEBUG}
1579:               DebugWriteln ('Ignoring object '+AnObject.ClassName);
1580:               {$endif}
1581:             end;
1582:             continue;
1583:           end;
1584:   
1585:           Count := GetPropList(AnObject, PropList);
1586:           try
1587:             for j := 0 to Count - 1 do begin
1588:               PropInfo := PropList[j];
1589:               UPropName:=uppercase(PropInfo^.Name);
1590:               // Ignore properties that are meant to be ignored
1591:               if ((currentcm=nil) or (not currentcm.PropertiesToIgnore.Find(UPropName,i))) and
1592:                  (not TP_IgnoreList.Find(Name+'.'+UPropName,i)) and
1593:                  (not ObjectPropertyIgnoreList.Find(UPropName,i)) then begin
1594:                 TranslateProperty (AnObject,PropInfo,TodoList,TextDomain);
1595:               end;  // if
1596:             end;  // for
1597:           finally
1598:             if Count<>0 then
1599:               FreeMem (PropList);
1600:           end;
1601:           if AnObject is TStrings then begin
1602:             if ((AnObject as TStrings).Text<>'') and (TP_Retranslator<>nil) then
1603:               (TP_Retranslator as TTP_Retranslator).Remember(AnObject, 'Text', (AnObject as TStrings).Text);
1604:             TranslateStrings (AnObject as TStrings,TextDomain);
1605:           end;
1606:           // Check for TCollection
1607:           if AnObject is TCollection then begin
1608:             for i := 0 to (AnObject as TCollection).Count - 1 do
1609:               TodoList.AddObject('',(AnObject as TCollection).Items[i]);
1610:           end;
1611:           if AnObject is TComponent then begin
1612:             for i := 0 to TComponent(AnObject).ComponentCount - 1 do begin
1613:               comp:=TComponent(AnObject).Components[i];
1614:               if (not TP_IgnoreList.Find(uppercase(comp.Name),j)) then begin
1615:                 TodoList.AddObject(uppercase(comp.Name),comp);
1616:               end;
1617:             end;
1618:           end;
1619:         end { if AnObject<>nil };
1620:       end { while todolist.count<>0 };
1621:     finally
1622:       FreeAndNil (todolist);
1623:       FreeAndNil (ObjectPropertyIgnoreList);
1624:       FreeAndNil (DoneList);
1625:     end;
1626:     FreeTP_ClassHandlingItems;
1627:     TP_IgnoreList.Clear;
1628:     TP_Retranslator:=nil;
1629:     {$ifdef DXGETTEXTDEBUG}
1630:     DebugWriteln ('----------------------------------------------------------------------');
1631:     {$endif}
1632:   end;
1633:   
1634:   procedure TGnuGettextInstance.UseLanguage(LanguageCode: string);
1635:   var
1636:     i,p:integer;
1637:     dom:TDomain;
1638:     l2:string[2];
1639:   begin
1640:     {$ifdef DXGETTEXTDEBUG}
1641:     DebugWriteln('UseLanguage('''+LanguageCode+'''); called');
1642:     {$endif}
1643:   
1644:     if LanguageCode='' then begin
1645:       LanguageCode:=GGGetEnvironmentVariable('LANG');
1646:       {$ifdef DXGETTEXTDEBUG}
1647:       DebugWriteln ('LANG env variable is '''+LanguageCode+'''.');
1648:       {$endif}
1649:       {$ifdef MSWINDOWS}
1650:       if LanguageCode='' then begin
1651:         LanguageCode:=GetWindowsLanguage;
1652:         {$ifdef DXGETTEXTDEBUG}
1653:         DebugWriteln ('Found Windows language code to be '''+LanguageCode+'''.');
1654:         {$endif}
1655:       end;
1656:       {$endif}
1657:       p:=pos('.',LanguageCode);
1658:       if p<>0 then
1659:         LanguageCode:=copy(LanguageCode,1,p-1);
1660:       {$ifdef DXGETTEXTDEBUG}
1661:       DebugWriteln ('Language code that will be set is '''+LanguageCode+'''.');
1662:       {$endif}
1663:     end;
1664:   
1665:     curlang := LanguageCode;
1666:     for i:=0 to domainlist.Count-1 do begin
1667:       dom:=domainlist.Objects[i] as TDomain;
1668:       dom.SetLanguageCode (curlang);
1669:     end;
1670:   
1671:     l2:=lowercase(copy(curlang,1,2));
1672:     if (l2='en') or (l2='de') then curGetPluralForm:=GetPluralForm2EN else
1673:     if (l2='hu') or (l2='ko') or (l2='zh') or (l2='ja') or (l2='tr') then curGetPluralForm:=GetPluralForm1 else
1674:     if (l2='fr') or (l2='fa') or (lowercase(curlang)='pt_br') then curGetPluralForm:=GetPluralForm2FR else
1675:     if (l2='lv') then curGetPluralForm:=GetPluralForm3LV else
1676:     if (l2='ga') then curGetPluralForm:=GetPluralForm3GA else
1677:     if (l2='lt') then curGetPluralForm:=GetPluralForm3LT else
1678:     if (l2='ru') or (l2='cs') or (l2='sk') or (l2='uk') or (l2='hr') then curGetPluralForm:=GetPluralForm3RU else
1679:     if (l2='pl') then curGetPluralForm:=GetPluralForm3PL else
1680:     if (l2='sl') then curGetPluralForm:=GetPluralForm4SL else begin
1681:       curGetPluralForm:=GetPluralForm2EN;
1682:       {$ifdef DXGETTEXTDEBUG}
1683:       DebugWriteln ('Plural form for the language was not found. English plurality system assumed.');
1684:       {$endif}
1685:     end;
1686:   
1687:     WhenNewLanguage (curlang);
1688:   
1689:     {$ifdef DXGETTEXTDEBUG}
1690:     DebugWriteln('');
1691:     {$endif}
1692:   end;
1693:   
1694:   procedure TGnuGettextInstance.TranslateStrings(sl: TStrings;const TextDomain:string);
1695:   var
1696:     line: string;
1697:     i: integer;
1698:     s:TStringList;
1699:   begin
1700:     if sl.Count > 0 then begin
1701:       sl.BeginUpdate;
1702:       try
1703:         s:=TStringList.Create;
1704:         try
1705:           s.Assign (sl);
1706:           for i:=0 to s.Count-1 do begin
1707:             line:=s.Strings[i];
1708:             if line<>'' then
1709:               s.Strings[i]:=dgettext(TextDomain,line);
1710:           end;
1711:           sl.Assign(s);
1712:         finally
1713:           FreeAndNil (s);
1714:         end;
1715:       finally
1716:         sl.EndUpdate;
1717:       end;
1718:     end;
1719:   end;
1720:   
1721:   function TGnuGettextInstance.GetTranslatorNameAndEmail: widestring;
1722:   begin
1723:     Result:=GetTranslationProperty('LAST-TRANSLATOR');
1724:   end;
1725:   
1726:   function TGnuGettextInstance.GetTranslationProperty(
1727:     const Propertyname: string): WideString;
1728:   begin
1729:     Result:=getdomain(curmsgdomain,DefaultDomainDirectory,CurLang).GetTranslationProperty (Propertyname);
1730:   end;
1731:   
1732:   function TGnuGettextInstance.dngettext(const szDomain: string; const singular, plural: widestring;
1733:     Number: Integer): widestring;
1734:   var
1735:     org,trans:widestring;
1736:     idx:integer;
1737:     p:integer;
1738:   begin
1739:     {$ifdef DXGETTEXTDEBUG}
1740:     DebugWriteln ('dngettext translation (domain '+szDomain+', number is '+IntTostr(Number)+') of '+singular+'/'+plural);
1741:     {$endif}
1742:     org:=singular+#0+plural;
1743:     trans:=dgettext(szDomain,org);
1744:     if org=trans then begin
1745:       {$ifdef DXGETTEXTDEBUG}
1746:       DebugWriteln ('Translation was equal to english version. English plural forms assumed.');
1747:       {$endif}
1748:       idx:=GetPluralForm2EN(Number)
1749:     end else
1750:       idx:=curGetPluralForm(Number);
1751:     {$ifdef DXGETTEXTDEBUG}
1752:     DebugWriteln ('Index '+IntToStr(idx)+' will be used');
1753:     {$endif}
1754:     while true do begin
1755:       p:=pos(#0,trans);
1756:       if p=0 then begin
1757:         {$ifdef DXGETTEXTDEBUG}
1758:         DebugWriteln ('Last translation used: '+utf8encode(trans));
1759:         {$endif}
1760:         Result:=trans;
1761:         exit;
1762:       end;
1763:       if idx=0 then begin
1764:         {$ifdef DXGETTEXTDEBUG}
1765:         DebugWriteln ('Translation found: '+utf8encode(trans));
1766:         {$endif}
1767:         Result:=copy(trans,1,p-1);
1768:         exit;
1769:       end;
1770:       delete (trans,1,p);
1771:       dec (idx);
1772:     end;
1773:   end;
1774:   
1775:   function TGnuGettextInstance.ngettext(const singular, plural: ansistring;
1776:     Number: Integer): widestring;
1777:   begin
1778:     Result := dngettext(curmsgdomain, singular, plural, Number);
1779:   end;
1780:   
1781:   function TGnuGettextInstance.ngettext(const singular, plural: widestring;
1782:     Number: Integer): widestring;
1783:   begin
1784:     Result := dngettext(curmsgdomain, singular, plural, Number);
1785:   end;
1786:   
1787:   procedure TGnuGettextInstance.WhenNewDomain(const TextDomain: string);
1788:   begin
1789:     // This is meant to be empty.
1790:   end;
1791:   
1792:   procedure TGnuGettextInstance.WhenNewLanguage(const LanguageID: string);
1793:   begin
1794:     // This is meant to be empty.
1795:   end;
1796:   
1797:   procedure TGnuGettextInstance.WhenNewDomainDirectory(const TextDomain,
1798:     Directory: string);
1799:   begin
1800:     // This is meant to be empty.
1801:   end;
1802:   
1803:   procedure TGnuGettextInstance.GetListOfLanguages(const domain: string;
1804:     list: TStrings);
1805:   begin
1806:     getdomain(Domain,DefaultDomainDirectory,CurLang).GetListOfLanguages(list);
1807:   end;
1808:   
1809:   procedure TGnuGettextInstance.bindtextdomainToFile(const szDomain,
1810:     filename: string);
1811:   begin
1812:     {$ifdef DXGETTEXTDEBUG}
1813:     DebugWriteln ('Text domain "'+szDomain+'" is now bound to file named "'+filename+'"');
1814:     {$endif}
1815:     getdomain(szDomain,DefaultDomainDirectory,CurLang).SetFilename (filename);
1816:   end;
1817:   
1818:   procedure TGnuGettextInstance.DebugLogPause(PauseEnabled: boolean);
1819:   begin
1820:     DebugLogOutputPaused:=PauseEnabled;
1821:   end;
1822:   
1823:   procedure TGnuGettextInstance.DebugLogToFile(const filename: string; append:boolean=false);
1824:   {$ifdef DXGETTEXTDEBUG}
1825:   var
1826:     fs:TFileStream;
1827:     marker:string;
1828:   {$endif}
1829:   begin
1830:     {$ifdef DXGETTEXTDEBUG}
1831:     // Create the file if needed
1832:     if (not fileexists(filename)) or (not append) then
1833:       fileclose (filecreate (filename));
1834:   
1835:     // Open file
1836:     fs:=TFileStream.Create (filename,fmOpenWrite or fmShareDenyWrite);
1837:     if append then
1838:       fs.Seek(0,soFromEnd);
1839:   
1840:     // Write header if appending
1841:     if fs.Position<>0 then begin
1842:       marker:=sLineBreak+'==========================================================================='+sLineBreak;
1843:       fs.WriteBuffer(marker[1],length(marker));
1844:     end;
1845:   
1846:     // Copy the memorystream contents to the file
1847:     DebugLog.Seek(0,soFromBeginning);
1848:     fs.CopyFrom(DebugLog,0);
1849:   
1850:     // Make DebugLog point to the filestream
1851:     FreeAndNil (DebugLog);
1852:     DebugLog:=fs;
1853:   {$endif}
1854:   end;
1855:   
1856:   procedure TGnuGettextInstance.DebugWriteln(line: ansistring);
1857:   Var
1858:     Discard: Boolean;
1859:   begin
1860:     Assert (DebugLogCS<>nil);
1861:     Assert (DebugLog<>nil);
1862:   
1863:     DebugLogCS.BeginWrite;
1864:     try
1865:       if DebugLogOutputPaused then
1866:         exit;
1867:   
1868:       if Assigned (fOnDebugLine) then begin
1869:         Discard := True;
1870:         fOnDebugLine (Self, Line, Discard);
1871:         If Discard then Exit;
1872:       end;
1873:   
1874:       line:=line+sLineBreak;
1875:   
1876:       // Ensure that memory usage doesn't get too big.
1877:       if (DebugLog is TMemoryStream) and (DebugLog.Position>1000000) then begin
1878:         line:=sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak+
1879:               'Debug log halted because memory usage grew too much.'+sLineBreak+
1880:               'Specify a filename to store the debug log in or disable debug loggin in gnugettext.pas.'+
1881:               sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak;
1882:         DebugLogOutputPaused:=True;
1883:       end;
1884:       DebugLog.WriteBuffer(line[1],length(line));
1885:     finally
1886:       DebugLogCS.EndWrite;
1887:     end;
1888:   end;
1889:   
1890:   function TGnuGettextInstance.Getdomain(const domain, DefaultDomainDirectory, CurLang: string): TDomain;
1891:   // Retrieves the TDomain object for the specified domain.
1892:   // Creates one, if none there, yet.
1893:   var
1894:     idx: integer;
1895:   begin
1896:     idx := domainlist.IndexOf(Domain);
1897:     if idx = -1 then begin
1898:       Result := TDomain.Create;
1899:       Result.DebugLogger:=DebugWriteln;
1900:       Result.Domain := Domain;
1901:       Result.Directory := DefaultDomainDirectory;
1902:       Result.SetLanguageCode(curlang);
1903:       domainlist.AddObject(Domain, Result);
1904:     end else begin
1905:       Result := domainlist.Objects[idx] as TDomain;
1906:     end;
1907:   end;
1908:   
1909:   function TGnuGettextInstance.LoadResString(
1910:     ResStringRec: PResStringRec): widestring;
1911:   {$ifdef MSWINDOWS}
1912:   var
1913:     Len: Integer;
1914:     Buffer: array [0..1023] of char;
1915:   {$endif}
1916:   {$ifdef LINUX }
1917:   const
1918:     ResStringTableLen = 16;
1919:   type
1920:     ResStringTable = array [0..ResStringTableLen-1] of LongWord;
1921:   var
1922:     Handle: TResourceHandle;
1923:     Tab: ^ResStringTable;
1924:     ResMod: HMODULE;
1925:   {$endif }
1926:   begin
1927:     if ResStringRec=nil then
1928:       exit;
1929:     if ResStringRec.Identifier>=64*1024 then begin
1930:       {$ifdef DXGETTEXTDEBUG}
1931:       DebugWriteln ('LoadResString was given an invalid ResStringRec.Identifier');
1932:       {$endif}
1933:       Result:='ERROR';
1934:       exit;
1935:     end else begin
1936:       {$ifdef LINUX}
1937:       // This works with Unicode if the Linux has utf-8 character set
1938:       // Result:=System.LoadResString(ResStringRec);
1939:       ResMod:=FindResourceHInstance(ResStringRec^.Module^);
1940:       Handle:=FindResource(ResMod,
1941:         PChar(ResStringRec^.Identifier div ResStringTableLen), PChar(6));   // RT_STRING
1942:       Tab:=Pointer(LoadResource(ResMod, Handle));
1943:       if Tab=nil then
1944:         Result:=''
1945:       else
1946:         Result:=PWideChar(PChar(Tab)+Tab[ResStringRec^.Identifier mod ResStringTableLen]);
1947:       {$endif}
1948:       {$ifdef MSWINDOWS}
1949:       if not Win32PlatformIsUnicode then begin
1950:         SetString(Result, Buffer,
1951:           LoadString(FindResourceHInstance(ResStringRec.Module^),
1952:             ResStringRec.Identifier, Buffer, SizeOf(Buffer)))
1953:       end else begin
1954:         Result := '';
1955:         Len := 0;
1956:         While Len = Length(Result) do begin
1957:           if Length(Result) = 0 then
1958:             SetLength(Result, 1024)
1959:           else
1960:             SetLength(Result, Length(Result) * 2);
1961:           Len := LoadStringW(FindResourceHInstance(ResStringRec.Module^),
1962:             ResStringRec.Identifier, PWideChar(Result), Length(Result));
1963:         end;
1964:         SetLength(Result, Len);
1965:       end;
1966:       {$endif}
1967:     end;
1968:     {$ifdef DXGETTEXTDEBUG}
1969:     DebugWriteln ('Loaded resourcestring: '+utf8encode(Result));
1970:     {$endif}
1971:     if CreatorThread<>GetCurrentThreadId then begin
1972:       {$ifdef DXGETTEXTDEBUG}
1973:       DebugWriteln ('LoadResString was called from an invalid thread. Resourcestring was not translated.');
1974:       {$endif}
1975:     end else
1976:       Result:=ResourceStringGettext(Result);
1977:   end;
1978:   
1979:   procedure TGnuGettextInstance.RetranslateComponent(AnObject: TComponent;
1980:     const TextDomain: string);
1981:   var
1982:     comp:TGnuGettextComponentMarker;
1983:   begin
1984:     {$ifdef DXGETTEXTDEBUG}
1985:     DebugWriteln ('======================================================================');
1986:     DebugWriteln ('RetranslateComponent() was called for a component with name '+AnObject.Name+'.');
1987:     {$endif}
1988:     comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;
1989:     if comp=nil then begin
1990:       {$ifdef DXGETTEXTDEBUG}
1991:       DebugWriteln ('Retranslate was called on an object that has not been translated before. An Exception is being raised.');
1992:       {$endif}
1993:       raise EGGProgrammingError.Create ('Retranslate was called on an object that has not been translated before. Please use TranslateComponent() before RetranslateComponent().');
1994:     end else begin
1995:       if comp.LastLanguage<>curlang then begin
1996:         {$ifdef DXGETTEXTDEBUG}
1997:         DebugWriteln ('The retranslator is being executed.');
1998:         {$endif}
1999:         comp.Retranslator.Execute;
2000:       end else begin
2001:         {$ifdef DXGETTEXTDEBUG}
2002:         DebugWriteln ('The language has not changed. The retranslator is not executed.');
2003:         {$endif}
2004:       end;
2005:     end;
2006:     comp.LastLanguage:=curlang;
2007:     {$ifdef DXGETTEXTDEBUG}
2008:     DebugWriteln ('======================================================================');
2009:     {$endif}
2010:   end;
2011:   
2012:   procedure TGnuGettextInstance.TP_IgnoreClass(IgnClass: TClass);
2013:   var
2014:     cm:TClassMode;
2015:     i:integer;
2016:   begin
2017:     for i:=0 to TP_ClassHandling.Count-1 do begin
2018:       cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;
2019:       if cm.HClass=IgnClass then
2020:         raise EGGProgrammingError.Create ('You cannot add a class to the ignore list that is already on that list: '+IgnClass.ClassName+'.');
2021:       if IgnClass.InheritsFrom(cm.HClass) then begin
2022:         // This is the place to insert this class
2023:         cm:=TClassMode.Create;
2024:         cm.HClass:=IgnClass;
2025:         TP_ClassHandling.Insert(i,cm);
2026:         {$ifdef DXGETTEXTDEBUG}
2027:         DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.');
2028:         {$endif}
2029:         exit;
2030:       end;
2031:     end;
2032:     cm:=TClassMode.Create;
2033:     cm.HClass:=IgnClass;
2034:     TP_ClassHandling.Add(cm);
2035:     {$ifdef DXGETTEXTDEBUG}
2036:     DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.');
2037:     {$endif}
2038:   end;
2039:   
2040:   procedure TGnuGettextInstance.TP_IgnoreClassProperty(IgnClass: TClass;
2041:     propertyname: string);
2042:   var
2043:     cm:TClassMode;
2044:     i:integer;
2045:   begin
2046:     propertyname:=uppercase(propertyname);
2047:     for i:=0 to TP_ClassHandling.Count-1 do begin
2048:       cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;
2049:       if cm.HClass=IgnClass then begin
2050:         if Assigned(cm.SpecialHandler) then
2051:           raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.');
2052:         cm.PropertiesToIgnore.Add(propertyname);
2053:         {$ifdef DXGETTEXTDEBUG}
2054:         DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
2055:         {$endif}
2056:         exit;
2057:       end;
2058:       if IgnClass.InheritsFrom(cm.HClass) then begin
2059:         // This is the place to insert this class
2060:         cm:=TClassMode.Create;
2061:         cm.HClass:=IgnClass;
2062:         cm.PropertiesToIgnore.Add(propertyname);
2063:         TP_ClassHandling.Insert(i,cm);
2064:         {$ifdef DXGETTEXTDEBUG}
2065:         DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
2066:         {$endif}
2067:         exit;
2068:       end;
2069:     end;
2070:     cm:=TClassMode.Create;
2071:     cm.HClass:=IgnClass;
2072:     cm.PropertiesToIgnore.Add(propertyname);
2073:     TP_GlobalClassHandling.Add(cm);
2074:     {$ifdef DXGETTEXTDEBUG}
2075:     DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');
2076:     {$endif}
2077:   end;
2078:   
2079:   procedure TGnuGettextInstance.FreeTP_ClassHandlingItems;
2080:   begin
2081:     while TP_ClassHandling.Count<>0 do begin
2082:       TObject(TP_ClassHandling.Items[0]).Free;
2083:       TP_ClassHandling.Delete(0);
2084:     end;
2085:   end;
2086:   
2087:   function TGnuGettextInstance.ansi2wide(const s: ansistring): widestring;
2088:   {$ifdef MSWindows}
2089:   var
2090:     len:integer;
2091:   {$endif}
2092:   begin
2093:   {$ifdef MSWindows}
2094:     if DesignTimeCodePage=CP_ACP then begin
2095:       // No design-time codepage specified. Using runtime codepage instead.
2096:   {$endif}
2097:       Result:=s;
2098:   {$ifdef MSWindows}
2099:     end else begin
2100:       len:=length(s);
2101:       if len=0 then
2102:         Result:=''
2103:       else begin
2104:         SetLength (Result,len);
2105:         len:=MultiByteToWideChar(DesignTimeCodePage,0,pchar(s),len,pwidechar(Result),len);
2106:         if len=0 then
2107:           raise EGGAnsi2WideConvError.Create ('Cannot convert string to widestring:'+sLineBreak+s);
2108:         SetLength (Result,len);
2109:       end;
2110:     end;
2111:   {$endif}
2112:   end;
2113:   
2114:   {$ifndef DELPHI5OROLDER}
2115:   function TGnuGettextInstance.dngettext(const szDomain: string; const singular,
2116:     plural: ansistring; Number: Integer): widestring;
2117:   begin
2118:     Result:=dngettext (szDomain, ansi2wide(singular), ansi2wide(plural), Number);
2119:   end;
2120:   {$endif}
2121:   
2122:   { TClassMode }
2123:   
2124:   constructor TClassMode.Create;
2125:   begin
2126:     PropertiesToIgnore:=TStringList.Create;
2127:     PropertiesToIgnore.Sorted:=True;
2128:     PropertiesToIgnore.Duplicates:=dupError;
2129:     {$ifndef DELPHI5OROLDER}
2130:     PropertiesToIgnore.CaseSensitive:=False;
2131:     {$endif}
2132:   end;
2133:   
2134:   destructor TClassMode.Destroy;
2135:   begin
2136:     FreeAndNil (PropertiesToIgnore);
2137:     inherited;
2138:   end;
2139:   
2140:   { TFileLocator }
2141:   
2142:   procedure TFileLocator.Analyze;
2143:   var
2144:     s:ansistring;
2145:     i:integer;
2146:     offset:int64;
2147:     fs:TFileStream;
2148:     fi:TEmbeddedFileInfo;
2149:     filename:string;
2150:   begin
2151:     s:='6637DB2E-62E1-4A60-AC19-C23867046A89'#0#0#0#0#0#0#0#0;
2152:     s:=copy(s,length(s)-7,8);
2153:     offset:=0;
2154:     for i:=8 downto 1 do
2155:       offset:=offset shl 8+ord(s[i]);  
2156:     if offset=0 then
2157:       exit;
2158:     BaseDirectory:=ExtractFilePath(ExecutableFilename);
2159:     try
2160:       fs:=TFileStream.Create(ExecutableFilename,fmOpenRead or fmShareDenyNone);
2161:       try
2162:         while true do begin
2163:           fs.Seek(offset,soFromBeginning);
2164:           offset:=ReadInt64(fs);
2165:           if offset=0 then
2166:             exit;
2167:           fi:=TEmbeddedFileInfo.Create;
2168:           try
2169:             fi.Offset:=ReadInt64(fs);
2170:             fi.Size:=ReadInt64(fs);
2171:             SetLength (filename, offset-fs.position);
2172:             fs.ReadBuffer (filename[1],offset-fs.position);
2173:             filename:=trim(filename);
2174:             filelist.AddObject(filename,fi);
2175:           except
2176:             FreeAndNil (fi);
2177:             raise;
2178:           end;
2179:         end;
2180:       finally
2181:         FreeAndNil (fs);
2182:       end;
2183:     except
2184:       {$ifdef DXGETTEXTDEBUG}
2185:       raise;
2186:       {$endif}
2187:     end;
2188:   end;
2189:   
2190:   constructor TFileLocator.Create;
2191:   begin
2192:     MoFilesCS:=TMultiReadExclusiveWriteSynchronizer.Create;
2193:     MoFiles:=TStringList.Create;
2194:     filelist:=TStringList.Create;
2195:     {$ifdef LINUX}
2196:     filelist.Duplicates:=dupError;
2197:     filelist.CaseSensitive:=True;
2198:     {$endif}
2199:     MoFiles.Sorted:=True;
2200:     {$ifndef DELPHI5OROLDER}
2201:     MoFiles.Duplicates:=dupError;
2202:     MoFiles.CaseSensitive:=False;
2203:     {$ifdef MSWINDOWS}
2204:     filelist.Duplicates:=dupError;
2205:     filelist.CaseSensitive:=False;
2206:     {$endif}
2207:     {$endif}
2208:     filelist.Sorted:=True;
2209:   end;
2210:   
2211:   destructor TFileLocator.Destroy;
2212:   begin
2213:     while filelist.count<>0 do begin
2214:       filelist.Objects[0].Free;
2215:       filelist.Delete (0);
2216:     end;
2217:     FreeAndNil (filelist);
2218:     FreeAndNil (MoFiles);
2219:     FreeAndNil (MoFilesCS);
2220:     inherited;
2221:   end;
2222:   
2223:   function TFileLocator.FileExists(filename: string): boolean;
2224:   var
2225:     idx:integer;
2226:   begin
2227:     if copy(filename,1,length(basedirectory))=basedirectory then 
2228:       filename:=copy(filename,length(basedirectory)+1,maxint);
2229:     Result:=filelist.Find(filename,idx);
2230:   end;
2231:   
2232:   function TFileLocator.GetMoFile(filename: string; DebugLogger:TDebugLogger): TMoFile;
2233:   var
2234:     fi:TEmbeddedFileInfo;
2235:     idx:integer;
2236:     idxname:string;
2237:     Offset, Size: Int64;
2238:     realfilename:string;
2239:   begin
2240:     // Find real filename
2241:     offset:=0;
2242:     size:=0;
2243:     realfilename:=filename;
2244:     if copy(filename,1,length(basedirectory))=basedirectory then begin
2245:       filename:=copy(filename,length(basedirectory)+1,maxint);
2246:       idx:=filelist.IndexOf(filename);
2247:       if idx<>-1 then begin
2248:         fi:=filelist.Objects[idx] as TEmbeddedFileInfo;
2249:         realfilename:=ExecutableFilename;
2250:         offset:=fi.offset;
2251:         size:=fi.size;
2252:         {$ifdef DXGETTEXTDEBUG}
2253:         DebugLogger ('Instead of '+filename+', using '+realfilename+' from offset '+IntTostr(offset)+', size '+IntToStr(size));
2254:         {$endif}
2255:       end;
2256:     end;
2257:   
2258:   
2259:     {$ifdef DXGETTEXTDEBUG}
2260:     DebugLogger ('Reading .mo data from file '''+filename+'''');
2261:     {$endif}
2262:   
2263:     // Find TMoFile object
2264:     MoFilesCS.BeginWrite;
2265:     try
2266:       idxname:=realfilename+#0+IntToStr(offset);
2267:       if MoFiles.Find(idxname, idx) then begin
2268:         Result:=MoFiles.Objects[idx] as TMoFile;
2269:       end else begin
2270:         Result:=TMoFile.Create (realfilename, Offset, Size);
2271:         MoFiles.AddObject(idxname, Result);
2272:       end;
2273:       Inc (Result.Users);
2274:     finally
2275:       MoFilesCS.EndWrite;
2276:     end;
2277:   end;
2278:   
2279:   function TFileLocator.ReadInt64(str: TStream): int64;
2280:   begin
2281:     Assert (sizeof(Result)=8);
2282:     str.ReadBuffer(Result,8);
2283:   end;
2284:   
2285:   procedure TFileLocator.ReleaseMoFile(mofile: TMoFile);
2286:   var
2287:     i:integer;
2288:   begin
2289:     Assert (mofile<>nil);
2290:     
2291:     MoFilesCS.BeginWrite;
2292:     try
2293:       dec (mofile.Users);
2294:       if mofile.Users<=0 then begin
2295:         i:=MoFiles.Count-1;
2296:         while i>=0 do begin
2297:           if MoFiles.Objects[i]=mofile then begin
2298:             MoFiles.Delete(i);
2299:             FreeAndNil (mofile);
2300:             break;
2301:           end;
2302:           dec (i);
2303:         end;
2304:       end;
2305:     finally
2306:       MoFilesCS.EndWrite;
2307:     end;
2308:   end;
2309:   
2310:   { TTP_Retranslator }
2311:   
2312:   constructor TTP_Retranslator.Create;
2313:   begin
2314:     list:=TList.Create;
2315:   end;
2316:   
2317:   destructor TTP_Retranslator.Destroy;
2318:   var
2319:     i:integer;
2320:   begin
2321:     for i:=0 to list.Count-1 do
2322:       TObject(list.Items[i]).Free;
2323:     FreeAndNil (list);
2324:     inherited;
2325:   end;
2326:   
2327:   procedure TTP_Retranslator.Execute;
2328:   var
2329:     i:integer;
2330:     sl:TStrings;
2331:     item:TTP_RetranslatorItem;
2332:     newvalue:WideString;
2333:     {$ifndef DELPHI5OROLDER}
2334:     ppi:PPropInfo;
2335:     {$endif}
2336:   begin
2337:     for i:=0 to list.Count-1 do begin
2338:       item:=TObject(list.items[i]) as TTP_RetranslatorItem;
2339:       if item.obj is TStrings then begin
2340:         // Since we don't know the order of items in sl, and don't have
2341:         // the original .Objects[] anywhere, we cannot anticipate anything
2342:         // about the current sl.Strings[] and sl.Objects[] values. We therefore
2343:         // have to discard both values. We can, however, set the original .Strings[]
2344:         // value into the list and retranslate that.
2345:         sl:=TStringList.Create;
2346:         try
2347:           sl.Text:=item.OldValue;
2348:           Instance.TranslateStrings(sl,textdomain);
2349:           (item.obj as TStrings).BeginUpdate;
2350:           try
2351:             (item.obj as TStrings).Text:=sl.Text;
2352:           finally
2353:             (item.obj as TStrings).EndUpdate;
2354:           end;
2355:         finally
2356:           FreeAndNil (sl);
2357:         end;
2358:       end else begin
2359:         newValue:=instance.dgettext(textdomain,item.OldValue);
2360:         {$ifdef DELPHI5OROLDER}
2361:         SetStrProp(item.obj, item.PropName, newValue);
2362:         {$endif}
2363:         {$ifndef DELPHI5OROLDER}
2364:         ppi:=GetPropInfo(item.obj, item.Propname);
2365:         if ppi<>nil then begin
2366:           SetWideStrProp(item.obj, ppi, newValue);
2367:         end else begin
2368:           {$ifdef DXGETTEXTDEBUG}
2369:           Instance.DebugWriteln ('ERROR: On retranslation, property disappeared: '+item.Propname+' for object of type '+item.obj.ClassName);
2370:           {$endif}
2371:         end;
2372:         {$endif}
2373:       end;
2374:     end;
2375:   end;
2376:   
2377:   procedure TTP_Retranslator.Remember(obj: TObject; PropName: String;
2378:     OldValue: WideString);
2379:   var
2380:     item:TTP_RetranslatorItem;
2381:   begin
2382:     item:=TTP_RetranslatorItem.Create;
2383:     item.obj:=obj;
2384:     item.Propname:=Propname;
2385:     item.OldValue:=OldValue;
2386:     list.Add(item);
2387:   end;
2388:   
2389:   { TGnuGettextComponentMarker }
2390:   
2391:   destructor TGnuGettextComponentMarker.Destroy;
2392:   begin
2393:     FreeAndNil (Retranslator);
2394:     inherited;
2395:   end;
2396:   
2397:   { THook }
2398:   
2399:   constructor THook.Create(OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);
2400:   { Idea and original code from Igor Siticov }
2401:   { Modified by Jacques Garcia Vazquez and Lars Dybdahl }
2402:   begin
2403:     {$ifndef CPU386}
2404:     'This procedure only works on Intel i386 compatible processors.'
2405:     {$endif}
2406:   
2407:     oldproc:=OldProcedure;
2408:     newproc:=NewProcedure;
2409:   
2410:     Reset (FollowJump);
2411:   end;
2412:   
2413:   destructor THook.Destroy;
2414:   begin
2415:     Shutdown;
2416:     inherited;
2417:   end;
2418:   
2419:   procedure THook.Disable;
2420:   begin
2421:     Assert (PatchPosition<>nil,'Patch position in THook was nil when Disable was called');
2422:     PatchPosition[0]:=Original[0];
2423:     PatchPosition[1]:=Original[1];
2424:     PatchPosition[2]:=Original[2];
2425:     PatchPosition[3]:=Original[3];
2426:     PatchPosition[4]:=Original[4];
2427:   end;
2428:   
2429:   procedure THook.Enable;
2430:   begin
2431:     Assert (PatchPosition<>nil,'Patch position in THook was nil when Enable was called');
2432:     PatchPosition[0]:=Patch[0];
2433:     PatchPosition[1]:=Patch[1];
2434:     PatchPosition[2]:=Patch[2];
2435:     PatchPosition[3]:=Patch[3];
2436:     PatchPosition[4]:=Patch[4];
2437:   end;
2438:   
2439:   procedure THook.Reset(FollowJump: boolean);
2440:   var
2441:     offset:integer;
2442:     {$ifdef LINUX}
2443:     p:pointer;
2444:     pagesize:integer;
2445:     {$endif}
2446:     {$ifdef MSWindows}
2447:     ov: cardinal;
2448:     {$endif}
2449:   begin
2450:     if PatchPosition<>nil then
2451:       Shutdown;
2452:   
2453:     patchPosition := OldProc;
2454:     if FollowJump and (Word(OldProc^) = $25FF) then begin
2455:       // This finds the correct procedure if a virtual jump has been inserted
2456:       // at the procedure address
2457:       Inc(Integer(patchPosition), 2); // skip the jump
2458:       patchPosition := pChar(Pointer(pointer(patchPosition)^)^);
2459:     end;
2460:     offset:=integer(NewProc)-integer(pointer(patchPosition))-5;
2461:   
2462:     Patch[0] := char($E9);
2463:     Patch[1] := char(offset and 255);
2464:     Patch[2] := char((offset shr 8) and 255);
2465:     Patch[3] := char((offset shr 16) and 255);
2466:     Patch[4] := char((offset shr 24) and 255);
2467:   
2468:     Original[0]:=PatchPosition[0];
2469:     Original[1]:=PatchPosition[1];
2470:     Original[2]:=PatchPosition[2];
2471:     Original[3]:=PatchPosition[3];
2472:     Original[4]:=PatchPosition[4];
2473:   
2474:     {$ifdef MSWINDOWS}
2475:     if not VirtualProtect(Pointer(PatchPosition), 5, PAGE_EXECUTE_READWRITE, @ov) then
2476:       RaiseLastOSError;
2477:     {$endif}
2478:     {$ifdef LINUX}
2479:     pageSize:=sysconf (_SC_PAGE_SIZE);
2480:     p:=pointer(PatchPosition);
2481:     p:=pointer((integer(p) + PAGESIZE-1) and not (PAGESIZE-1) - pageSize);
2482:     if mprotect (p, pageSize, PROT_READ + PROT_WRITE + PROT_EXEC) <> 0 then
2483:       RaiseLastOSError;
2484:     {$endif}
2485:   end;
2486:   
2487:   procedure THook.Shutdown;
2488:   begin
2489:     Disable;
2490:     PatchPosition:=nil;
2491:   end;
2492:   
2493:   procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);
2494:   begin
2495:     HookLoadResString.Reset (SupportPackages);
2496:     HookLoadStr.Reset (SupportPackages);
2497:     HookFmtLoadStr.Reset (SupportPackages);
2498:     if enabled then begin
2499:       HookLoadResString.Enable;
2500:       HookLoadStr.Enable;
2501:       HookFmtLoadStr.Enable;
2502:     end;
2503:   end;
2504:   
2505:   { TMoFile }
2506:   
2507:   function TMoFile.autoswap32(i: cardinal): cardinal;
2508:   var
2509:     cnv1, cnv2:
2510:       record
2511:         case integer of
2512:           0: (arr: array[0..3] of byte);
2513:           1: (int: cardinal);
2514:       end;
2515:   begin
2516:     if doswap then begin
2517:       cnv1.int := i;
2518:       cnv2.arr[0] := cnv1.arr[3];
2519:       cnv2.arr[1] := cnv1.arr[2];
2520:       cnv2.arr[2] := cnv1.arr[1];
2521:       cnv2.arr[3] := cnv1.arr[0];
2522:       Result := cnv2.int;
2523:     end else
2524:       Result := i;
2525:   end;
2526:   
2527:   function TMoFile.CardinalInMem(baseptr: PChar; Offset: Cardinal): Cardinal;
2528:   var pc:^Cardinal;
2529:   begin
2530:     inc (baseptr,offset);
2531:     pc:=Pointer(baseptr);
2532:     Result:=pc^;
2533:     if doswap then
2534:       autoswap32(Result);
2535:   end;
2536:   
2537:   constructor TMoFile.Create(filename: string; Offset,Size:int64);
2538:   var
2539:     i:cardinal;
2540:     nn:integer;
2541:     {$ifdef linux}
2542:     mofile:TFileStream;
2543:     {$endif}
2544:   begin
2545:     if sizeof(i) <> 4 then
2546:       raise EGGProgrammingError.Create('TDomain in gnugettext is written for an architecture that has 32 bit integers.');
2547:   
2548:     {$ifdef mswindows}
2549:     // Map the mo file into memory and let the operating system decide how to cache
2550:     mo:=createfile (PChar(filename),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0);
2551:     if mo=INVALID_HANDLE_VALUE then
2552:       raise EGGIOError.Create ('Cannot open file '+filename);
2553:     momapping:=CreateFileMapping (mo, nil, PAGE_READONLY, 0, 0, nil);
2554:     if momapping=0 then
2555:       raise EGGIOError.Create ('Cannot create memory map on file '+filename);
2556:     momemoryHandle:=MapViewOfFile (momapping,FILE_MAP_READ,0,0,0);
2557:     if momemoryHandle=nil then begin
2558:       raise EGGIOError.Create ('Cannot map file '+filename+' into memory. Reason: '+GetLastWinError);
2559:     end;
2560:     momemory:=momemoryHandle+offset;
2561:     {$endif}
2562:     {$ifdef linux}
2563:     // Read the whole file into memory
2564:     mofile:=TFileStream.Create (filename, fmOpenRead or fmShareDenyNone);
2565:     try
2566:       if size=0 then
2567:         size:=mofile.Size;
2568:       Getmem (momemoryHandle,size);
2569:       momemory:=momemoryHandle;
2570:       mofile.Seek(offset,soFromBeginning);
2571:       mofile.ReadBuffer(momemory^,size);
2572:     finally
2573:       FreeAndNil (mofile);
2574:     end;
2575:     {$endif}
2576:   
2577:     // Check the magic number
2578:     doswap:=False;
2579:     i:=CardinalInMem(momemory,0);
2580:     if (i <> $950412DE) and (i <> $DE120495) then
2581:       EGGIOError.Create('This file is not a valid GNU gettext mo file: ' + filename);
2582:     doswap := (i = $DE120495);
2583:   
2584:   
2585:     // Find the positions in the file according to the file format spec
2586:     CardinalInMem(momemory,4);       // Read the version number, but don't use it for anything.
2587:     N:=CardinalInMem(momemory,8);    // Get string count
2588:     O:=CardinalInMem(momemory,12);   // Get offset of original strings
2589:     T:=CardinalInMem(momemory,16);   // Get offset of translated strings
2590:   
2591:     // Calculate start conditions for a binary search
2592:     nn := N;
2593:     startindex := 1;
2594:     while nn <> 0 do begin
2595:       nn := nn shr 1;
2596:       startindex := startindex shl 1;
2597:     end;
2598:     startindex := startindex shr 1;
2599:     startstep := startindex shr 1;
2600:   end;
2601:   
2602:   destructor TMoFile.Destroy;
2603:   begin
2604:     {$ifdef mswindows}
2605:     UnMapViewOfFile (momemoryHandle);
2606:     CloseHandle (momapping);
2607:     CloseHandle (mo);
2608:     {$endif}
2609:     {$ifdef linux}
2610:     FreeMem (momemoryHandle);
2611:     {$endif}
2612:     inherited;
2613:   end;
2614:   
2615:   function TMoFile.gettext(const msgid: ansistring;var found:boolean): ansistring;
2616:   var
2617:     i, step: cardinal;
2618:     offset, pos: cardinal;
2619:     CompareResult:integer;
2620:     msgidptr,a,b:PChar;
2621:     abidx:integer;
2622:     size, msgidsize:integer;
2623:   begin
2624:     found:=false;
2625:     msgidptr:=PChar(msgid);
2626:     msgidsize:=length(msgid);
2627:   
2628:     // Do binary search
2629:     i:=startindex;
2630:     step:=startstep;
2631:     while true do begin
2632:       // Get string for index i
2633:       pos:=O+8*(i-1);
2634:       offset:=CardinalInMem (momemory,pos+4);
2635:       size:=CardinalInMem (momemory,pos);
2636:       a:=msgidptr;
2637:       b:=momemory+offset;
2638:       abidx:=size;
2639:       if msgidsize<abidx then
2640:         abidx:=msgidsize;
2641:       CompareResult:=0;
2642:       while abidx<>0 do begin
2643:         CompareResult:=integer(byte(a^))-integer(byte(b^));
2644:         if CompareResult<>0 then
2645:           break;
2646:         dec (abidx);
2647:         inc (a);
2648:         inc (b);
2649:       end;
2650:       if CompareResult=0 then 
2651:         CompareResult:=msgidsize-size;
2652:       if CompareResult=0 then begin  // msgid=s
2653:         // Found the msgid
2654:         pos:=T+8*(i-1);
2655:         offset:=CardinalInMem (momemory,pos+4);
2656:         size:=CardinalInMem (momemory,pos);
2657:         SetString (Result,momemory+offset,size);
2658:         found:=True;
2659:         break;
2660:       end;
2661:       if step=0 then begin
2662:         // Not found
2663:         Result:=msgid;
2664:         break;
2665:       end;
2666:       if CompareResult<0 then begin  // msgid<s
2667:         if i < 1+step then
2668:           i := 1
2669:         else
2670:           i := i - step;
2671:         step := step shr 1;
2672:       end else begin  // msgid>s
2673:         i := i + step;
2674:         if i > N then
2675:           i := N;
2676:         step := step shr 1;
2677:       end;
2678:     end;
2679:   end;
2680:   
2681:   initialization
2682:     {$ifdef DXGETTEXTDEBUG}
2683:     {$ifdef MSWINDOWS}
2684:     MessageBox (0,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.','Information',MB_OK);
2685:     {$endif}
2686:     {$ifdef LINUX}
2687:     writeln (stderr,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.');
2688:     {$endif}
2689:     {$endif}
2690:     if IsLibrary then begin
2691:       // Get DLL/shared object filename
2692:       SetLength (ExecutableFilename,300);
2693:       {$ifdef MSWINDOWS}
2694:       SetLength (ExecutableFilename,GetModuleFileName(HInstance, PChar(ExecutableFilename), length(ExecutableFilename)));
2695:       {$else}
2696:       // This line has not been tested on Linux, yet, but should work.
2697:       SetLength (ExecutableFilename,GetModuleFileName(0, PChar(ExecutableFilename), length(ExecutableFilename)));
2698:       {$endif}
2699:     end else
2700:       ExecutableFilename:=Paramstr(0);
2701:     FileLocator:=TFileLocator.Create;
2702:     FileLocator.Analyze;
2703:     ResourceStringDomainList:=TStringList.Create;
2704:     ResourceStringDomainList.Add(DefaultTextDomain);
2705:     ResourceStringDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create;
2706:     DefaultInstance:=TGnuGettextInstance.Create;
2707:     {$ifdef MSWINDOWS}
2708:     Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
2709:     {$endif}
2710:   
2711:     // replace Borlands LoadResString with gettext enabled version:
2712:     HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringA);
2713:     HookLoadStr:=THook.Create (@sysutils.LoadStr, @SysUtilsLoadStr);
2714:     HookFmtLoadStr:=THook.Create (@sysutils.FmtLoadStr, @SysUtilsFmtLoadStr);
2715:     HookIntoResourceStrings (AutoCreateHooks,false);
2716:   
2717:   finalization
2718:     FreeAndNil (DefaultInstance);
2719:     FreeAndNil (ResourceStringDomainListCS);
2720:     FreeAndNil (ResourceStringDomainList);
2721:     FreeAndNil (HookFmtLoadStr);
2722:     FreeAndNil (HookLoadStr);
2723:     FreeAndNil (HookLoadResString);
2724:     FreeAndNil (FileLocator);
2725:   
2726:   end.
2727:   
 
 
NA fum/lmd: 2007.07.15
Copyright ©1994-2024 by Mario A. Valdez-Ramírez.
no siga este enlace / do not follow this link