1 unit LCLTranslator;
2
3 { Copyright (C) 2004-2015 V.I.Volchenko and Lazarus Developers Team
4
5 This library is free software; you can redistribute it and/or modify it
6 under the terms of the GNU Library General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or (at your
8 option) any later version.
9
10 This program is distributed in the hope that it will be useful, but WITHOUT
11 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
13 for more details.
14
15 You should have received a copy of the GNU Library General Public License
16 along with this library; if not, write to the Free Software Foundation,
17 Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA.
18 }
19 {
20 This unit is needed for using translated form strings made by Lazarus IDE.
21 It searches for translated .po/.mo files in some common places. If you need
22 to have .po/.mo files anywhere else, don't use this unit but initialize
23 LRSMoFile variable from LResources in your project by yourself.
24
25 If you need standard translation, just use this unit in your project and enable
26 i18n in project options. Note that you will have to call SetDefaultLang manually.
27 If you want it to be called automatically, use DefaultTranslator unit instead.
28
29 Another reason for including this unit may be using translated LCL messages.
30 This unit localizes LCL too, if it finds lclstrconsts.xx.po/lclstrconsts.xx.mo
31 in directory where your program translation files are placed.
32 }
33 {$mode objfpc}{$H+}
34
35 interface
36
37 uses
38 // RTL + FCL
39 Classes, SysUtils, typinfo, GetText,
40 // LCL
41 LResources, Forms, LCLType,
42 // LazUtils
43 {$IFDEF VerbosePOTranslator}
44 LazLoggerBase,
45 {$ENDIF}
46 Translations, LazFileUtils, LazUTF8;
47
48 type
49
50 { TUpdateTranslator }
51
52 TUpdateTranslator = class(TAbstractTranslator)
53 private
54 FStackPath: string;
55 procedure IntUpdateTranslation(AnInstance: TPersistent; Level: integer = 0);
56 public
57 procedure UpdateTranslation(AnInstance: TPersistent);
58 end;
59
60 TDefaultTranslator = class(TUpdateTranslator)
61 private
62 FMOFile: TMOFile;
63 public
64 constructor Create(MOFileName: string);
65 destructor Destroy; override;
66 procedure TranslateStringProperty(Sender: TObject; const Instance: TPersistent;
67 PropInfo: PPropInfo; var Content: string); override;
68 end;
69
70 { TPOTranslator }
71
72 TPOTranslator = class(TUpdateTranslator)
73 private
74 FPOFile: TPOFile;
75 public
76 constructor Create(POFileName: string);
77 constructor Create(aPOFile: TPOFile);
78 destructor Destroy; override;
79 procedure TranslateStringProperty(Sender: TObject; const Instance: TPersistent;
80 PropInfo: PPropInfo; var Content: string); override;
81 end;
82
83 procedure SetDefaultLang(Lang: string; Dir: string = ''; ForceUpdate: boolean = true);
GetDefaultLangnull84 function GetDefaultLang: String;
85
86 implementation
87
88
89 type
90 TPersistentAccess = class(TPersistent);
91
92 var
93 DefaultLang: String = '';
94
FindLocaleFileNamenull95 function FindLocaleFileName(LCExt: string; Lang: string; Dir: string): string;
96 var
97 T, CurParam: string;
98 i: integer;
99
GetLocaleFileNamenull100 function GetLocaleFileName(const LangID, LCExt: string; Dir: string): string;
101 var
102 LangShortID: string;
103 AppDir,LCFileName,FullLCFileName: String;
104 absoluteDir: Boolean;
105 begin
106 DefaultLang := LangID;
107
108 AppDir := ExtractFilePath(ParamStrUTF8(0));
109 LCFileName := ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
110
111 if LangID <> '' then
112 begin
113 FullLCFileName := ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), '.' + LangID) + LCExt;
114
115 if Dir<>'' then
116 begin
117 Dir := AppendPathDelim(Dir);
118 absoluteDir := FilenameIsAbsolute(Dir);
119 if absoluteDir then
120 Result := Dir + LangID + DirectorySeparator + LCFileName
121 else
122 Result := AppDir + Dir + LangID + DirectorySeparator + LCFileName;
123 if FileExistsUTF8(Result) then
124 exit;
125 end;
126
127 //ParamStrUTF8(0) is said not to work properly in linux, but I've tested it
128 Result := AppDir + LangID + DirectorySeparator + LCFileName;
129 if FileExistsUTF8(Result) then
130 exit;
131
132 Result := AppDir + 'languages' + DirectorySeparator + LangID +
133 DirectorySeparator + LCFileName;
134 if FileExistsUTF8(Result) then
135 exit;
136
137 Result := AppDir + 'locale' + DirectorySeparator + LangID +
138 DirectorySeparator + LCFileName;
139 if FileExistsUTF8(Result) then
140 exit;
141
142 Result := AppDir + 'locale' + DirectorySeparator + LangID +
143 DirectorySeparator + 'LC_MESSAGES' + DirectorySeparator + LCFileName;
144 if FileExistsUTF8(Result) then
145 exit;
146
147 {$IFDEF UNIX}
148 //In unix-like systems we can try to search for global locale
149 Result := '/usr/share/locale/' + LangID + '/LC_MESSAGES/' + LCFileName;
150 if FileExistsUTF8(Result) then
151 exit;
152 {$ENDIF}
153 //Let us search for short id files
154 LangShortID := copy(LangID, 1, 2);
155 Defaultlang := LangShortID;
156
157 if Dir<>'' then
158 begin
159 if absoluteDir then
160 Result := Dir + LangShortID + DirectorySeparator + LCFileName
161 else
162 Result := AppDir + Dir + LangShortID + DirectorySeparator + LCFileName;
163 if FileExistsUTF8(Result) then
164 exit;
165 end;
166
167 //At first, check all was checked
168 Result := AppDir + LangShortID + DirectorySeparator + LCFileName;
169 if FileExistsUTF8(Result) then
170 exit;
171
172 Result := AppDir + 'languages' + DirectorySeparator +
173 LangShortID + DirectorySeparator + LCFileName;
174 if FileExistsUTF8(Result) then
175 exit;
176
177 Result := AppDir + 'locale' + DirectorySeparator
178 + LangShortID + DirectorySeparator + LCFileName;
179 if FileExistsUTF8(Result) then
180 exit;
181
182 Result := AppDir + 'locale' + DirectorySeparator + LangShortID +
183 DirectorySeparator + 'LC_MESSAGES' + DirectorySeparator + LCFileName;
184 if FileExistsUTF8(Result) then
185 exit;
186
187 //Full language in file name - this will be default for the project
188 //We need more careful handling, as it MAY result in incorrect filename
189 try
190 if Dir<>'' then
191 begin
192 if absoluteDir then
193 Result := Dir + FullLCFileName
194 else
195 Result := AppDir + Dir + FullLCFileName;
196 if FileExistsUTF8(Result) then
197 exit;
198 end;
199
200 Result := AppDir + FullLCFileName;
201 if FileExistsUTF8(Result) then
202 exit;
203
204 //Common location (like in Lazarus)
205 Result := AppDir + 'locale' + DirectorySeparator + FullLCFileName;
206 if FileExistsUTF8(Result) then
207 exit;
208
209 Result := AppDir + 'languages' + DirectorySeparator + FullLCFileName;
210 if FileExistsUTF8(Result) then
211 exit;
212 except
213 Result := '';//Or do something else (useless)
214 end;
215 {$IFDEF UNIX}
216 Result := '/usr/share/locale/' + LangShortID + '/LC_MESSAGES/' +
217 LCFileName;
218 if FileExistsUTF8(Result) then
219 exit;
220 {$ENDIF}
221
222 FullLCFileName := ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), '.' + LangShortID) + LCExt;
223
224 if Dir<>'' then
225 begin
226 if absoluteDir then
227 Result := Dir + FullLCFileName
228 else
229 Result := AppDir + Dir + FullLCFileName;
230 if FileExistsUTF8(Result) then
231 exit;
232 end;
233
234 Result := AppDir + FullLCFileName;
235 if FileExistsUTF8(Result) then
236 exit;
237
238 Result := AppDir + 'locale' + DirectorySeparator + FullLCFileName;
239 if FileExistsUTF8(Result) then
240 exit;
241
242 Result := AppDir + 'languages' + DirectorySeparator + FullLCFileName;
243 if FileExistsUTF8(Result) then
244 exit;
245 end;
246
247 Result := AppDir + LCFileName;
248 if FileExistsUTF8(Result) then
249 exit;
250
251 Result := AppDir + 'locale' + DirectorySeparator + LCFileName;
252 if FileExistsUTF8(Result) then
253 exit;
254
255 Result := AppDir + 'languages' + DirectorySeparator + LCFileName;
256 if FileExistsUTF8(Result) then
257 exit;
258
259 Result := '';
260 DefaultLang := '';
261 end;
262
263 begin
264 Result := '';
265
266 if Lang = '' then
267 for i := 1 to ParamCount do
268 begin
269 CurParam := ParamStrUTF8(i);
270 if (CurParam = '-l') or (UTF8LowerCase(CurParam) = '--lang') then
271 begin
272 if i < ParamCount then
273 Lang := ParamStrUTF8(i + 1);
274 end
275 else
276 if UTF8StartsText('--lang=', CurParam) then
277 begin
278 Lang := CurParam;
279 UTF8Delete(Lang, 1, Length('--lang='));
280 end;
281 end;
282
283 //User can decide to override locale with LANG variable.
284 if Lang = '' then
285 Lang := GetEnvironmentVariableUTF8('LANG');
286
287 if Lang = '' then
288 LazGetLanguageIDs(Lang, T);
289
290 Result := GetLocaleFileName(Lang, LCExt, Dir);
291 end;
292
293 function GetIdentifierPath(Sender: TObject;
294 const Instance: TPersistent;
295 PropInfo: PPropInfo): string;
296 var
297 Tmp: TPersistent;
298 Component: TComponent;
299 Reader: TReader;
300 begin
301 Result := '';
302 if (PropInfo=nil) or (PropInfo^.PropType<>TypeInfo(TTranslateString)) then
303 exit;
304
305 // do not translate at design time
306 // get the component
307 Tmp := Instance;
308 while Assigned(Tmp) and not (Tmp is TComponent) do
309 Tmp := TPersistentAccess(Tmp).GetOwner;
310 if not Assigned(Tmp) then
311 exit;
312 Component := Tmp as TComponent;
313 if (csDesigning in Component.ComponentState) then
314 exit;
315
316 if (Sender is TReader) then
317 begin
318 Reader := TReader(Sender);
319 if Reader.Driver is TLRSObjectReader then
320 Result := TLRSObjectReader(Reader.Driver).GetStackPath
321 else
322 Result := Instance.ClassName + '.' + PropInfo^.Name;
323 end else if (Sender is TUpdateTranslator) then
324 Result := TUpdateTranslator(Sender).FStackPath + '.' + PropInfo^.Name;
325 Result := LowerCase(Result); // GetText requires same case as in .po file, which is lowercase
326 end;
327
328 { TUpdateTranslator }
329
330 procedure TUpdateTranslator.IntUpdateTranslation(AnInstance: TPersistent; Level: integer = 0);
331 var
332 i,j: integer;
333 APropCount: integer;
334 APropList: PPropList;
335 APropInfo: PPropInfo;
336 TmpStr: string;
337 APersistentProp: TPersistent;
338 StoreStackPath: string;
339 AComponent, SubComponent: TComponent;
340 begin
341 {$IFDEF VerbosePOTranslator}
342 debugln(['TUpdateTranslator.IntUpdateTranslation START ',DbgSName(AnInstance),' Level=',Level]);
343 {$ENDIF}
344 APropCount := GetPropList(AnInstance.ClassInfo, APropList);
345 try
346 for i := 0 to APropCount-1 do
347 begin
348 APropInfo:=APropList^[i];
349 if Assigned(PPropInfo(APropInfo)^.GetProc) and
350 Assigned(APropInfo^.PropType) and
351 IsStoredProp(AnInstance, APropInfo) then
352 case APropInfo^.PropType^.Kind of
353 tkSString,
354 tkLString,
355 tkAString:
356 if APropInfo^.PropType=TypeInfo(TTranslateString) then
357 begin
358 TmpStr := '';
359 {$IFDEF VerbosePOTranslator}
360 debugln(['TUpdateTranslator.IntUpdateTranslation ',GetStrProp(AnInstance,APropInfo)]);
361 {$ENDIF}
362 LRSTranslator.TranslateStringProperty(Self,AnInstance,APropInfo,TmpStr);
363 if TmpStr <>'' then
364 SetStrProp(AnInstance, APropInfo, TmpStr);
365 end;
366 tkClass:
367 begin
368 APersistentProp := TPersistent(GetObjectProp(AnInstance, APropInfo, TPersistent));
369 if Assigned(APersistentProp) then
370 begin
371 if APersistentProp is TCollection then
372 begin
373 for j := 0 to TCollection(APersistentProp).Count-1 do
374 begin
375 StoreStackPath:=FStackPath;
376 FStackPath:=FStackPath+'.'+APropInfo^.Name+'['+IntToStr(j)+']';
377 IntUpdateTranslation(TCollection(APersistentProp).Items[j],Level+1);
378 FStackPath:=StoreStackPath;
379 end;
380 end
381 else
382 begin
383 if APersistentProp is TComponent then
384 begin
385 AComponent:=TComponent(APersistentProp);
386 if (csSubComponent in AComponent.ComponentStyle) then
387 begin
388 StoreStackPath:=FStackPath;
389 FStackPath:=FStackPath+'.'+APropInfo^.Name;
390 IntUpdateTranslation(APersistentProp,Level+1);
391 FStackPath:=StoreStackPath;
392 end
393 end
394 else
395 begin
396 StoreStackPath:=FStackPath;
397 FStackPath:=FStackPath+'.'+APropInfo^.Name;
398 IntUpdateTranslation(APersistentProp,Level+1);
399 FStackPath:=StoreStackPath;
400 end;
401 end;
402 end;
403 end;
404 end;
405 end;
406 finally
407 Freemem(APropList);
408 end;
409
410 if (Level=0) and (AnInstance is TComponent) then
411 begin
412 AComponent:=TComponent(AnInstance);
413 for i := 0 to AComponent.ComponentCount-1 do
414 begin
415 SubComponent:=AComponent.Components[i];
416 StoreStackPath:=FStackPath;
417 if SubComponent is TCustomFrame then
418 UpdateTranslation(SubComponent);
419 if SubComponent.Name='' then continue;
420 FStackPath:=StoreStackPath+'.'+SubComponent.Name;
421 IntUpdateTranslation(SubComponent,Level+1);
422 FStackPath:=StoreStackPath;
423 end;
424 end;
425 end;
426
427 procedure TUpdateTranslator.UpdateTranslation(AnInstance: TPersistent);
428 begin
429 FStackPath:=AnInstance.ClassName;
430 IntUpdateTranslation(AnInstance);
431 end;
432
433 { TDefaultTranslator }
434
435 constructor TDefaultTranslator.Create(MOFileName: string);
436 begin
437 inherited Create;
438 FMOFile := TMOFile.Create(UTF8ToSys(MOFileName));
439 end;
440
441 destructor TDefaultTranslator.Destroy;
442 begin
443 FMOFile.Free;
444 //If someone will use this class incorrectly, it can be destroyed
445 //before Reader destroying. It is a very bad thing, but in THIS situation
446 //in this case is impossible. Maybe, in future we can overcome this difficulty
447 inherited Destroy;
448 end;
449
450 procedure TDefaultTranslator.TranslateStringProperty(Sender: TObject;
451 const Instance: TPersistent; PropInfo: PPropInfo; var Content: string);
452 var
453 s: string;
454 begin
455 if Assigned(FMOFile) then
456 begin
457 s := GetIdentifierPath(Sender, Instance, PropInfo);
458 if s <> '' then
459 begin
460 s := FMoFile.Translate(s + #4 + Content);
461
462 if s = '' then
463 s := FMOFile.Translate(Content);
464
465 if s <> '' then
466 Content := s;
467 end;
468 end;
469 end;
470
471 { TPOTranslator }
472
473 constructor TPOTranslator.Create(POFileName: string);
474 begin
475 inherited Create;
476 // TPOFile expects AFileName in UTF-8 encoding, no conversion required
477 FPOFile := TPOFile.Create(POFileName, true);
478 end;
479
480 constructor TPOTranslator.Create(aPOFile: TPOFile);
481 begin
482 inherited Create;
483 FPOFile := aPOFile;
484 end;
485
486 destructor TPOTranslator.Destroy;
487 begin
488 FPOFile.Free;
489 //If someone will use this class incorrectly, it can be destroyed
490 //before Reader destroying. It is a very bad thing, but in THIS situation
491 //in this case is impossible. May be, in future we can overcome this difficulty
492 inherited Destroy;
493 end;
494
495 procedure TPOTranslator.TranslateStringProperty(Sender: TObject;
496 const Instance: TPersistent; PropInfo: PPropInfo; var Content: string);
497 var
498 s: string;
499 begin
500 if Assigned(FPOFile) then
501 begin
502 s := GetIdentifierPath(Sender, Instance, PropInfo);
503 {$IFDEF VerbosePOTranslator}
504 debugln(['TPOTranslator.TranslateStringProperty Content="',Content,'" s="',s,'" Instance=',Instance.ClassName,' PropInfo.Name=',PropInfo^.Name]);
505 {$ENDIF}
506 if s <> '' then
507 begin
508 s := FPOFile.Translate(s, Content);
509
510 if s <> '' then
511 Content := s;
512 end;
513 end;
514 end;
515
516 procedure SetDefaultLang(Lang: string; Dir: string = ''; ForceUpdate: boolean = true);
517 { Arguments:
518 Lang - language (e.g. 'ru', 'de'); empty argument is default language.
519 Dir - custom translation files subdirectory (e.g. 'mylng'); empty argument means searching only in predefined subdirectories.
520 ForceUpdate - true means forcing immediate interface update. Only should be set to false when the procedure is
521 called from unit Initialization section. User code normally should not specify it.
522 }
523 var
524 Dot1: integer;
525 LCLPath, lcfn: string;
526 LocalTranslator: TUpdateTranslator;
527 i: integer;
528
529 begin
530 LocalTranslator := nil;
531 // search first po translation resources
532 try
533 lcfn := FindLocaleFileName('.po', Lang, Dir);
534 if lcfn <> '' then
535 begin
536 Translations.TranslateResourceStrings(lcfn);
537 LCLPath := ExtractFileName(lcfn);
538 Dot1 := pos('.', LCLPath);
539 if Dot1 > 1 then
540 begin
541 Delete(LCLPath, 1, Dot1 - 1);
542 LCLPath := ExtractFilePath(lcfn) + 'lclstrconsts' + LCLPath;
543 Translations.TranslateUnitResourceStrings('LCLStrConsts', LCLPath);
544 end;
545 LocalTranslator := TPOTranslator.Create(lcfn);
546 end;
547 except
548 lcfn := '';
549 end;
550
551 if lcfn='' then
552 begin
553 // try now with MO translation resources
554 try
555 lcfn := FindLocaleFileName('.mo', Lang, Dir);
556 if lcfn <> '' then
557 begin
558 GetText.TranslateResourceStrings(UTF8ToSys(lcfn));
559 LCLPath := ExtractFileName(lcfn);
560 Dot1 := pos('.', LCLPath);
561 if Dot1 > 1 then
562 begin
563 Delete(LCLPath, 1, Dot1 - 1);
564 LCLPath := ExtractFilePath(lcfn) + 'lclstrconsts' + LCLPath;
565 if FileExistsUTF8(LCLPath) then
566 GetText.TranslateResourceStrings(UTF8ToSys(LCLPath));
567 end;
568 LocalTranslator := TDefaultTranslator.Create(lcfn);
569 end;
570 except
571 lcfn := '';
572 end;
573 end;
574
575 if LocalTranslator<>nil then
576 begin
577 if Assigned(LRSTranslator) then
578 LRSTranslator.Free;
579 LRSTranslator := LocalTranslator;
580
581 // Do not update the translations when this function is called from within
582 // the unit initialization.
583 if ForceUpdate=true then
584 begin
585 for i := 0 to Screen.CustomFormCount-1 do
586 LocalTranslator.UpdateTranslation(Screen.CustomForms[i]);
587 for i := 0 to Screen.DataModuleCount-1 do
588 LocalTranslator.UpdateTranslation(Screen.DataModules[i]);
589 end;
590 end;
591 end;
592
593 function GetDefaultLang: String;
594 begin
595 if DefaultLang = '' then SetDefaultLang('');
596 GetDefaultLang := DefaultLang;
597 end;
598
599 finalization
600 LRSTranslator.Free;
601
602 end.
603