source: trunk/Packages/Common/Translator.pas

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