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