Source code of file oscpmwin/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:
