source: trunk/Packages/Common/UTranslator.pas

Last change on this file was 218, checked in by chronos, 3 years ago
  • Fixed: Relative path detection for language files directory.
File size: 16.9 KB
Line 
1unit UTranslator;
2
3{$mode delphi}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, Forms, ExtCtrls, Controls, fgl, LazFileUtils, LazUTF8,
9 Translations, TypInfo, Dialogs, FileUtil, LCLProc, ULanguages, LCLType,
10 LCLVersion;
11
12type
13 THandleStringEvent = function (AValue: string): string of object;
14
15 TPoFiles = class(TFPGObjectList<TPOFile>)
16 end;
17
18 { TComponentExcludes }
19
20 TComponentExcludes = class
21 ExcludedClassType: TClass;
22 PropertyExcludes: TStringList;
23 constructor Create;
24 destructor Destroy; override;
25 end;
26
27 { TComponentExcludesList }
28
29 TComponentExcludesList = class(TFPGObjectList<TComponentExcludes>)
30 function FindByClassType(AClassType: TClass): TComponentExcludes;
31 procedure DumpToStrings(Strings: TStrings);
32 end;
33
34 { TTranslator }
35
36 TTranslator = class(TComponent)
37 private
38 FLanguage: TLanguage;
39 FOnAutomaticLanguage: THandleStringEvent;
40 FOnTranslate: TNotifyEvent;
41 FPoFilesFolder: string;
42 FPoFiles: TPoFiles;
43 function GetLocale: string;
44 function GetLocaleShort: string;
45 function FindLocaleFileName(LCExt: string): string;
46 function GetLocaleFileName(const LangID, LCExt: string): string;
47 procedure ReloadFiles;
48 procedure SetPOFilesFolder(const AValue: string);
49 procedure SetLanguage(const AValue: TLanguage);
50 procedure TranslateProperty(Component: TPersistent; PropInfo: PPropInfo);
51 function IsExcluded(Component: TPersistent; PropertyName: string): Boolean;
52 function GetLangFileDir: string;
53 public
54 ComponentExcludes: TComponentExcludesList;
55 Languages: TLanguages;
56 procedure Translate;
57 procedure LanguageListToStrings(Strings: TStrings; WithCode: Boolean = True);
58 procedure TranslateResourceStrings(PoFileName: string);
59 procedure TranslateUnitResourceStrings(UnitName: string; PoFileName: string);
60 procedure TranslateComponent(Component: TPersistent);
61 procedure TranslateComponentRecursive(Component: TComponent);
62 function TranslateText(Identifier, Text: string): string;
63 procedure AddExcludes(AClassType: TClass; PropertyName: string);
64 procedure CheckLanguageFiles;
65 constructor Create(AOwner: TComponent); override;
66 destructor Destroy; override;
67 published
68 property POFilesFolder: string read FPoFilesFolder write SetPOFilesFolder;
69 property Language: TLanguage read FLanguage write SetLanguage;
70 property OnTranslate: TNotifyEvent read FOnTranslate write FOnTranslate;
71 property OnAutomaticLanguage: THandleStringEvent read FOnAutomaticLanguage
72 write FOnAutomaticLanguage;
73 end;
74
75procedure Register;
76
77const
78 PoFileExt = '.po';
79
80
81implementation
82
83procedure Register;
84begin
85 RegisterComponents('Common', [TTranslator]);
86end;
87
88{ TComponentExcludesList }
89
90function TComponentExcludesList.FindByClassType(AClassType: TClass
91 ): TComponentExcludes;
92var
93 I: Integer;
94begin
95 I := 0;
96 while (I < Count) and (TComponentExcludes(Items[I]).ExcludedClassType <> AClassType) do
97 Inc(I);
98 if I < Count then Result := TComponentExcludes(Items[I])
99 else Result := nil;
100end;
101
102procedure TComponentExcludesList.DumpToStrings(Strings: TStrings);
103var
104 I, J: Integer;
105 Text: string;
106begin
107 Strings.Clear;
108 for I := 0 to Count - 1 do
109 with TComponentExcludes(Items[I]) do begin
110 Text := ExcludedClassType.ClassName + ': ';
111 for J := 0 to PropertyExcludes.Count - 1 do
112 Text := Text + PropertyExcludes[J] + ', ';
113 Strings.Add(Text);
114 end;
115end;
116
117{ TComponentExcludes }
118
119constructor TComponentExcludes.Create;
120begin
121 PropertyExcludes := TStringList.Create;
122end;
123
124destructor TComponentExcludes.Destroy;
125begin
126 FreeAndNil(PropertyExcludes);
127 inherited;
128end;
129
130
131{ TTranslator }
132
133procedure TTranslator.Translate;
134var
135 I, J: Integer;
136 Po: TPoFile;
137 Item: TPoFileItem;
138begin
139 TranslateComponentRecursive(Application);
140
141 // Merge files to single translation file
142 try
143 Po := TPoFile.Create;
144 for I := 0 to FPoFiles.Count - 1 do
145 with TPoFile(FPoFiles[I]) do
146 for J := 0 to Items.Count - 1 do
147 with TPoFileItem(Items[J]) do begin
148 {$if (lcl_major<2)}
149 Po.Add(IdentifierLow, Original, Translation, Comments, Context,
150 Flags, PreviousID);
151 {$else}
152 Item := nil;
153 Po.FillItem(Item, IdentifierLow, Original, Translation, Comments, Context,
154 Flags, PreviousID);
155 {$endif}
156 end;
157 Translations.TranslateResourceStrings(Po);
158 finally
159 Po.Free;
160 end;
161end;
162
163procedure TTranslator.ReloadFiles;
164var
165 FileName: string;
166 FileList: TStringList;
167 I: Integer;
168 LocaleShort: string;
169 SearchMask: string;
170begin
171 FPoFiles.Clear;
172 if Assigned(FLanguage) then
173 try
174 LocaleShort := GetLocaleShort;
175 SearchMask := '*';
176 if LocaleShort <> '' then SearchMask := SearchMask + '.' + LocaleShort;
177 SearchMask := SearchMask + PoFileExt;
178 FileList := FindAllFiles(GetLangFileDir, SearchMask);
179 for I := 0 to FileList.Count - 1 do begin
180 FileName := FileList[I];
181 if FileExists(FileName) and (
182 ((LocaleShort = '') and (Pos('.', FileName) = Pos(PoFileExt, FileName))) or
183 (LocaleShort <> '')) then FPoFiles.Add(TPOFile.Create(FileName));
184 end;
185 finally
186 FileList.Free;
187 end;
188end;
189
190procedure TTranslator.SetPOFilesFolder(const AValue: string);
191begin
192 if FPoFilesFolder = AValue then Exit;
193 FPoFilesFolder := AValue;
194 ReloadFiles;
195 CheckLanguageFiles;
196end;
197
198procedure TTranslator.SetLanguage(const AValue: TLanguage);
199begin
200 if FLanguage = AValue then Exit;
201 FLanguage := AValue;
202 ReloadFiles;
203 Translate;
204 if Assigned(FOnTranslate) then FOnTranslate(Self);
205end;
206
207procedure TTranslator.TranslateComponent(Component: TPersistent);
208var
209 I, Count: Integer;
210 PropInfo: PPropInfo;
211 PropList: PPropList;
212begin
213 Count := GetTypeData(Component.ClassInfo)^.PropCount;
214 if Count > 0 then begin
215 GetMem(PropList, Count * SizeOf(Pointer));
216 try
217 GetPropInfos(Component.ClassInfo, PropList);
218 for I := 0 to Count - 1 do
219 begin
220 PropInfo := PropList^[I];
221 if PropInfo = nil then
222 Break;
223 TranslateProperty(Component, PropInfo);
224 end;
225 finally
226 FreeMem(PropList, Count * SizeOf(Pointer));
227 end;
228 end;
229end;
230
231procedure TTranslator.TranslateComponentRecursive(Component: TComponent);
232var
233 I: Integer;
234begin
235 TranslateComponent(Component);
236 for I := 0 to Component.ComponentCount - 1 do
237 TranslateComponentRecursive(Component.Components[I]);
238end;
239
240procedure TTranslator.TranslateProperty(Component: TPersistent;
241 PropInfo: PPropInfo);
242var
243 PropType: PTypeInfo;
244 Obj: TObject;
245 I: Integer;
246begin
247// PropInfo^.Name;
248 // Using IsDefaultPropertyValue will tell us if we should write out
249 // a given property because it was different from the default or
250 // different from the Ancestor (if applicable).
251 if (PropInfo^.GetProc <> nil) and
252 ((PropInfo^.SetProc <> nil) or
253 ((PropInfo^.PropType^.Kind = tkClass) and
254 (TObject(GetOrdProp(Component, PropInfo)) is TComponent) and
255 (csSubComponent in TComponent(GetOrdProp(Component, PropInfo)).ComponentStyle))) then
256 begin
257 begin
258 PropType := PropInfo^.PropType;
259 case PropType^.Kind of
260 tkString, tkLString, tkWString, tkAString: begin
261 if (UpperCase(PropType.Name) = 'TTRANSLATESTRING') then
262 //if not IsExcluded(Component, PropInfo^.Name) then
263 SetStrProp(Component, PropInfo, TranslateText(PropInfo^.Name, string(GetWideStrProp(Component, PropInfo))));
264 end;
265 tkClass: begin
266 Obj := TObject(GetOrdProp(Component, PropInfo));
267 if Obj is TCollection then
268 for I := 0 to TCollection(Obj).Count - 1 do
269 with TCollection(Obj).Items[I] do
270 TranslateComponent(TCollection(Obj).Items[I]);
271 (*if Obj is TStrings then
272 for I := 0 to TStrings(Obj).Count - 1 do
273 with TStrings(Obj) do
274 Strings[I] := TranslateText(Strings[I], Strings[I]);
275 *)
276 end;
277 end;
278 end;
279 end;
280end;
281
282function TTranslator.IsExcluded(Component: TPersistent; PropertyName: string
283 ): Boolean;
284var
285 Item: TClass;
286 Excludes: TComponentExcludes;
287begin
288 Result := False;
289 Item := Component.ClassType;
290 while Assigned(Item) do begin
291 Excludes := ComponentExcludes.FindByClassType(Item.ClassType);
292 if Assigned(Excludes) then begin
293 if Excludes.PropertyExcludes.IndexOf(PropertyName) <> -1 then begin
294 Result := True;
295 Exit;
296 end;
297 end;
298 Item := Item.ClassParent;
299 end;
300end;
301
302function TTranslator.GetLangFileDir: string;
303begin
304 Result := FPoFilesFolder;
305 if not FilenameIsAbsolute(Result) then
306 Result := ExtractFileDir(Application.ExeName) + DirectorySeparator + Result;
307end;
308
309procedure TTranslator.LanguageListToStrings(Strings: TStrings; WithCode: Boolean = True);
310var
311 I: Integer;
312 ItemName: string;
313begin
314 with Strings do begin
315 BeginUpdate;
316 try
317 Clear;
318 for I := 0 to Languages.Count - 1 do
319 with Languages[I] do
320 if Available then begin
321 ItemName := Name;
322 if WithCode and (Code <> '') then ItemName := ItemName + ' (' + Code + ')';
323 AddObject(ItemName, Languages[I]);
324 end;
325 finally
326 EndUpdate;
327 end;
328 end;
329end;
330
331procedure TTranslator.TranslateResourceStrings(PoFileName: string);
332begin
333 Translations.TranslateResourceStrings(PoFileName);
334end;
335
336procedure TTranslator.TranslateUnitResourceStrings(UnitName: string;
337 PoFileName: string);
338begin
339 Translations.TranslateUnitResourceStrings(UnitName, PoFileName);
340end;
341
342function TTranslator.TranslateText(Identifier, Text: string): string;
343var
344 I: Integer;
345begin
346 Result := '';
347 if Text <> '' then begin
348 for I := 0 to FPoFiles.Count - 1 do begin
349 Result := TPoFile(FPoFiles[I]).Translate(Identifier, Text);
350 if Result <> Text then Break;
351 end;
352 if Result = '' then Result := Text;
353 end else Result := '';
354end;
355
356procedure TTranslator.AddExcludes(AClassType: TClass; PropertyName: string
357 );
358var
359 NewItem: TComponentExcludes;
360begin
361 NewItem := ComponentExcludes.FindByClassType(AClassType);
362 if not Assigned(NewItem) then begin
363 NewItem := TComponentExcludes.Create;
364 NewItem.ExcludedClassType := AClassType;
365 ComponentExcludes.Add(NewItem);
366 end;
367 NewItem.PropertyExcludes.Add(PropertyName);
368end;
369
370procedure TTranslator.CheckLanguageFiles;
371var
372 I: Integer;
373 LangDir: string;
374begin
375 LangDir := GetLangFileDir;
376 Languages.SearchByCode('').Available := True; // Automatic
377
378 for I := 1 to Languages.Count - 1 do
379 with Languages[I] do begin
380 Available := FileExists(LangDir + DirectorySeparator + ExtractFileNameOnly(Application.ExeName) +
381 '.' + Code + PoFileExt) or (Code = 'en');
382 end;
383end;
384
385constructor TTranslator.Create(AOwner: TComponent);
386begin
387 inherited;
388 FPoFiles := TPoFiles.Create;
389 ComponentExcludes := TComponentExcludesList.Create;
390 Languages := TLanguages.Create;
391 POFilesFolder := 'Languages';
392 CheckLanguageFiles;
393
394 // LCL
395 AddExcludes(TComponent, 'Name');
396 //AddExcludes(TAction, 'Category');
397 AddExcludes(TControl, 'HelpKeyword');
398end;
399
400destructor TTranslator.Destroy;
401begin
402 FreeAndNil(FPoFiles);
403 FreeAndNil(Languages);
404 FreeAndNil(ComponentExcludes);
405 inherited;
406end;
407
408function TTranslator.GetLocale: string;
409var
410 Lang: string;
411 I: Integer;
412 T: string;
413begin
414 // Win32 user may decide to override locale with LANG variable.
415 Lang := GetEnvironmentVariable('LANG');
416
417 // Use user selected language
418 if Assigned(Language) and (Language.Code <> '') then
419 Lang := Language.Code;
420
421 if Lang = '' then begin
422 for i := 1 to Paramcount - 1 do
423 if (ParamStr(i) = '--LANG') or (ParamStr(i) = '-l') or
424 (ParamStr(i) = '--lang') then
425 Lang := ParamStr(i + 1);
426 end;
427 if Lang = '' then begin
428 T := '';
429 LazGetLanguageIDs(Lang, T);
430 end;
431
432 if Assigned(Language) and (Language.Code = '') and Assigned(FOnAutomaticLanguage) then begin
433 Lang := FOnAutomaticLanguage(Lang);
434 end;
435
436 Result := Lang;
437end;
438
439function TTranslator.GetLocaleShort: string;
440begin
441 Result := Copy(GetLocale, 1, 2);
442end;
443
444function TTranslator.FindLocaleFileName(LCExt: string): string;
445var
446 Lang: string;
447begin
448 Result := '';
449 Lang := GetLocale;
450
451 Result := GetLocaleFileName(Lang, LCExt);
452 if Result <> '' then
453 Exit;
454
455 Result := ChangeFileExt(ParamStr(0), LCExt);
456 if FileExistsUTF8(Result) then
457 Exit;
458
459 Result := '';
460end;
461
462function TTranslator.GetLocaleFileName(const LangID, LCExt: string): string;
463var
464 LangShortID: string;
465 FormatLang: string;
466begin
467 if LangID <> '' then FormatLang := '.%s' else FormatLang := '';
468
469 begin
470 // ParamStrUTF8(0) is said not to work properly in linux, but I've tested it
471 Result := ExtractFilePath(ParamStrUTF8(0)) + LangID +
472 DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
473 if FileExistsUTF8(Result) then
474 exit;
475
476 Result := ExtractFilePath(ParamStrUTF8(0)) + 'languages' + DirectorySeparator + LangID +
477 DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
478 if FileExistsUTF8(Result) then
479 exit;
480
481 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator
482 + LangID + DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
483 if FileExistsUTF8(Result) then
484 exit;
485
486 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator
487 + LangID + DirectorySeparator + 'LC_MESSAGES' + DirectorySeparator +
488 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
489 if FileExistsUTF8(Result) then
490 exit;
491
492 {$IFDEF UNIX}
493 // In unix-like systems we can try to search for global locale
494 Result := '/usr/share/locale/' + LangID + '/LC_MESSAGES/' +
495 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
496 if FileExistsUTF8(Result) then
497 exit;
498 {$ENDIF}
499 // Let us search for reducted files
500 LangShortID := copy(LangID, 1, 2);
501 // At first, check all was checked
502 Result := ExtractFilePath(ParamStrUTF8(0)) + LangShortID +
503 DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
504 if FileExistsUTF8(Result) then
505 exit;
506
507 Result := ExtractFilePath(ParamStrUTF8(0)) + 'languages' + DirectorySeparator +
508 LangShortID + DirectorySeparator + ChangeFileExt(
509 ExtractFileName(ParamStrUTF8(0)), LCExt);
510 if FileExistsUTF8(Result) then
511 exit;
512
513 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator
514 + LangShortID + DirectorySeparator + ChangeFileExt(
515 ExtractFileName(ParamStrUTF8(0)), LCExt);
516 if FileExistsUTF8(Result) then
517 exit;
518
519 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator
520 + LangShortID + DirectorySeparator + 'LC_MESSAGES' + DirectorySeparator +
521 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
522 if FileExistsUTF8(Result) then
523 exit;
524
525 // Full language in file name - this will be default for the project
526 // We need more careful handling, as it MAY result in incorrect filename
527 try
528 Result := ExtractFilePath(ParamStrUTF8(0)) + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangID])) + LCExt;
529 if FileExistsUTF8(Result) then
530 exit;
531 // Common location (like in Lazarus)
532 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator +
533 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangID])) + LCExt;
534 if FileExistsUTF8(Result) then
535 exit;
536
537 Result := ExtractFilePath(ParamStrUTF8(0)) + 'languages' +
538 DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangID])) + LCExt;
539 if FileExistsUTF8(Result) then
540 exit;
541 except
542 Result := ''; // Or do something else (useless)
543 end;
544
545 {$IFDEF UNIX}
546 Result := '/usr/share/locale/' + LangShortID + '/LC_MESSAGES/' +
547 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
548 if FileExistsUTF8(Result) then
549 exit;
550 {$ENDIF}
551 Result := ExtractFilePath(ParamStrUTF8(0)) + ChangeFileExt(
552 ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangShortID])) + LCExt;
553 if FileExistsUTF8(Result) then
554 exit;
555
556 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator +
557 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangShortID])) + LCExt;
558 if FileExistsUTF8(Result) then
559 exit;
560
561 Result := ExtractFilePath(ParamStrUTF8(0)) + 'languages' + DirectorySeparator +
562 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangShortID])) + LCExt;
563 if FileExistsUTF8(Result) then
564 exit;
565 end;
566
567 Result := '';
568end;
569
570
571end.
572
Note: See TracBrowser for help on using the repository browser.