source: tags/1.3.1/Packages/Common/UTranslator.pas

Last change on this file was 424, checked in by chronos, 2 years ago
  • Modified: Update Common package to version 0.10.
  • Modified: fgl unit replaced by Generics.Collections.
File size: 17.1 KB
Line 
1unit UTranslator;
2
3interface
4
5uses
6 Classes, SysUtils, Forms, ExtCtrls, Controls, LazFileUtils, LazUTF8,
7 Translations, TypInfo, Dialogs, FileUtil, LCLProc, ULanguages, 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 GetLangFileDir: string;
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
73procedure Register;
74
75
76implementation
77
78procedure Register;
79begin
80 RegisterComponents('Common', [TTranslator]);
81end;
82
83{ TComponentExcludesList }
84
85function TComponentExcludesList.FindByClassType(AClassType: TClass
86 ): TComponentExcludes;
87var
88 I: Integer;
89begin
90 I := 0;
91 while (I < Count) and (TComponentExcludes(Items[I]).ExcludedClassType <> AClassType) do
92 Inc(I);
93 if I < Count then Result := TComponentExcludes(Items[I])
94 else Result := nil;
95end;
96
97procedure TComponentExcludesList.DumpToStrings(Strings: TStrings);
98var
99 I, J: Integer;
100 Text: string;
101begin
102 Strings.Clear;
103 for I := 0 to Count - 1 do
104 with TComponentExcludes(Items[I]) do begin
105 Text := ExcludedClassType.ClassName + ': ';
106 for J := 0 to PropertyExcludes.Count - 1 do
107 Text := Text + PropertyExcludes[J] + ', ';
108 Strings.Add(Text);
109 end;
110end;
111
112{ TComponentExcludes }
113
114constructor TComponentExcludes.Create;
115begin
116 PropertyExcludes := TStringList.Create;
117end;
118
119destructor TComponentExcludes.Destroy;
120begin
121 FreeAndNil(PropertyExcludes);
122 inherited;
123end;
124
125
126{ TTranslator }
127
128procedure TTranslator.Translate;
129var
130 I, J: Integer;
131 Po: TPoFile;
132 Item: TPoFileItem;
133begin
134 TranslateComponentRecursive(Application);
135
136 // Merge files to single translation file
137 try
138 Po := TPoFile.Create;
139 for I := 0 to FPoFiles.Count - 1 do
140 with TPoFile(FPoFiles[I]) do
141 for J := 0 to Items.Count - 1 do
142 with TPoFileItem(Items[J]) do begin
143 {$if (lcl_major<2)}
144 Po.Add(IdentifierLow, Original, Translation, Comments, Context,
145 Flags, PreviousID);
146 {$else}
147 Item := nil;
148 Po.FillItem(Item, IdentifierLow, Original, Translation, Comments, Context,
149 Flags, PreviousID);
150 {$endif}
151 end;
152 Translations.TranslateResourceStrings(Po);
153 finally
154 Po.Free;
155 end;
156end;
157
158procedure TTranslator.ReloadFiles;
159var
160 FileName: string;
161 FileList: TStringList;
162 I: Integer;
163 LocaleShort: string;
164 SearchMask: string;
165begin
166 FPoFiles.Clear;
167 if Assigned(FLanguage) then
168 try
169 LocaleShort := GetLocaleShort;
170 //ShowMessage(ExtractFileDir(Application.ExeName) +
171 // DirectorySeparator + 'Languages' + ' ' + '*.' + LocaleShort + '.po');
172 SearchMask := '*';
173 if LocaleShort <> '' then SearchMask := SearchMask + '.' + LocaleShort;
174 SearchMask := SearchMask + '.po';
175 FileList := FindAllFiles(GetLangFileDir, SearchMask);
176 for I := 0 to FileList.Count - 1 do begin
177 FileName := FileList[I];
178 //FileName := FindLocaleFileName('.po');
179 if FileExists(FileName) and (
180 ((LocaleShort = '') and (Pos('.', FileName) = Pos('.po', FileName))) or
181 (LocaleShort <> '')) then FPoFiles.Add(TPOFile.Create(FileName));
182 end;
183 finally
184 FileList.Free;
185 end;
186end;
187
188procedure TTranslator.SetPOFilesFolder(const AValue: string);
189begin
190 if FPoFilesFolder = AValue then Exit;
191 FPoFilesFolder := AValue;
192 ReloadFiles;
193 CheckLanguageFiles;
194end;
195
196procedure TTranslator.SetLanguage(const AValue: TLanguage);
197begin
198 if FLanguage = AValue then Exit;
199 FLanguage := AValue;
200 ReloadFiles;
201 Translate;
202 if Assigned(FOnTranslate) then FOnTranslate(Self);
203end;
204
205procedure TTranslator.TranslateComponent(Component: TPersistent);
206var
207 I, Count: Integer;
208 PropInfo: PPropInfo;
209 PropList: PPropList;
210begin
211 Count := GetTypeData(Component.ClassInfo)^.PropCount;
212 if Count > 0 then begin
213 GetMem(PropList, Count * SizeOf(Pointer));
214 try
215 GetPropInfos(Component.ClassInfo, PropList);
216 for I := 0 to Count - 1 do
217 begin
218 PropInfo := PropList^[I];
219 if PropInfo = nil then
220 Break;
221 TranslateProperty(Component, PropInfo);
222 end;
223 finally
224 FreeMem(PropList, Count * SizeOf(Pointer));
225 end;
226 end;
227end;
228
229procedure TTranslator.TranslateComponentRecursive(Component: TComponent);
230var
231 I: Integer;
232begin
233 TranslateComponent(Component);
234 for I := 0 to Component.ComponentCount - 1 do
235 TranslateComponentRecursive(Component.Components[I]);
236end;
237
238procedure TTranslator.TranslateProperty(Component: TPersistent;
239 PropInfo: PPropInfo);
240var
241 PropType: PTypeInfo;
242 Obj: TObject;
243 I: Integer;
244begin
245
246// PropInfo^.Name;
247 // Using IsDefaultPropertyValue will tell us if we should write out
248 // a given property because it was different from the default or
249 // different from the Ancestor (if applicable).
250 if (PropInfo^.GetProc <> nil) and
251 ((PropInfo^.SetProc <> nil) or
252 ((PropInfo^.PropType^.Kind = tkClass) and
253 (TObject(GetOrdProp(Component, PropInfo)) is TComponent) and
254 (csSubComponent in TComponent(GetOrdProp(Component, PropInfo)).ComponentStyle))) then
255 begin
256 begin
257 PropType := PropInfo^.PropType;
258 case PropType^.Kind of
259 tkString, tkLString, tkWString, tkAString: begin
260 if (UpperCase(PropType.Name) = 'TTRANSLATESTRING') then
261 //if not IsExcluded(Component, PropInfo^.Name) then
262 SetStrProp(Component, PropInfo, TranslateText(PropInfo^.Name, string(GetWideStrProp(Component, PropInfo))));
263 end;
264 tkClass: begin
265 Obj := TObject(GetOrdProp(Component, PropInfo));
266 if Obj is TCollection then
267 for I := 0 to TCollection(Obj).Count - 1 do
268 with TCollection(Obj).Items[I] do
269 TranslateComponent(TCollection(Obj).Items[I]);
270 (*if Obj is TStrings then
271 for I := 0 to TStrings(Obj).Count - 1 do
272 with TStrings(Obj) do
273 Strings[I] := TranslateText(Strings[I], Strings[I]);
274 *)
275 end;
276 end;
277 end;
278 end;
279end;
280
281function TTranslator.IsExcluded(Component: TPersistent; PropertyName: string
282 ): Boolean;
283var
284 Item: TClass;
285 Excludes: TComponentExcludes;
286begin
287 Result := False;
288 Item := Component.ClassType;
289 while Assigned(Item) do begin
290 Excludes := ComponentExcludes.FindByClassType(Item.ClassType);
291 if Assigned(Excludes) then begin
292 if Excludes.PropertyExcludes.IndexOf(PropertyName) <> -1 then begin
293 Result := True;
294 Exit;
295 end;
296 end;
297 Item := Item.ClassParent;
298 end;
299end;
300
301function TTranslator.GetLangFileDir: string;
302begin
303 Result := FPoFilesFolder;
304 if Copy(Result, 1, 1) <> DirectorySeparator then
305 Result := ExtractFileDir(Application.ExeName) +
306 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 + ExtensionSeparator + 'po') 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
471 // ParamStrUTF8(0) is said not to work properly in linux, but I've tested it
472 Result := ExtractFilePath(ParamStrUTF8(0)) + LangID +
473 DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
474 if FileExistsUTF8(Result) then
475 exit;
476
477 Result := ExtractFilePath(ParamStrUTF8(0)) + 'languages' + DirectorySeparator + LangID +
478 DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
479 if FileExistsUTF8(Result) then
480 exit;
481
482 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator
483 + LangID + DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
484 if FileExistsUTF8(Result) then
485 exit;
486
487 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator
488 + LangID + DirectorySeparator + 'LC_MESSAGES' + DirectorySeparator +
489 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
490 if FileExistsUTF8(Result) then
491 exit;
492
493 {$IFDEF UNIX}
494 // In unix-like systems we can try to search for global locale
495 Result := '/usr/share/locale/' + LangID + '/LC_MESSAGES/' +
496 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
497 if FileExistsUTF8(Result) then
498 exit;
499 {$ENDIF}
500 // Let us search for reducted files
501 LangShortID := copy(LangID, 1, 2);
502 // At first, check all was checked
503 Result := ExtractFilePath(ParamStrUTF8(0)) + LangShortID +
504 DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
505 if FileExistsUTF8(Result) then
506 exit;
507
508 Result := ExtractFilePath(ParamStrUTF8(0)) + 'languages' + DirectorySeparator +
509 LangShortID + DirectorySeparator + ChangeFileExt(
510 ExtractFileName(ParamStrUTF8(0)), LCExt);
511 if FileExistsUTF8(Result) then
512 exit;
513
514 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator
515 + LangShortID + DirectorySeparator + ChangeFileExt(
516 ExtractFileName(ParamStrUTF8(0)), LCExt);
517 if FileExistsUTF8(Result) then
518 exit;
519
520 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator
521 + LangShortID + DirectorySeparator + 'LC_MESSAGES' + DirectorySeparator +
522 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
523 if FileExistsUTF8(Result) then
524 exit;
525
526 // Full language in file name - this will be default for the project
527 // We need more careful handling, as it MAY result in incorrect filename
528 try
529 Result := ExtractFilePath(ParamStrUTF8(0)) + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangID])) + LCExt;
530 if FileExistsUTF8(Result) then
531 exit;
532 // Common location (like in Lazarus)
533 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator +
534 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangID])) + LCExt;
535 if FileExistsUTF8(Result) then
536 exit;
537
538 Result := ExtractFilePath(ParamStrUTF8(0)) + 'languages' +
539 DirectorySeparator + ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangID])) + LCExt;
540 if FileExistsUTF8(Result) then
541 exit;
542 except
543 Result := ''; // Or do something else (useless)
544 end;
545
546 {$IFDEF UNIX}
547 Result := '/usr/share/locale/' + LangShortID + '/LC_MESSAGES/' +
548 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), LCExt);
549 if FileExistsUTF8(Result) then
550 exit;
551 {$ENDIF}
552 Result := ExtractFilePath(ParamStrUTF8(0)) + ChangeFileExt(
553 ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangShortID])) + LCExt;
554 if FileExistsUTF8(Result) then
555 exit;
556
557 Result := ExtractFilePath(ParamStrUTF8(0)) + 'locale' + DirectorySeparator +
558 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangShortID])) + LCExt;
559 if FileExistsUTF8(Result) then
560 exit;
561
562 Result := ExtractFilePath(ParamStrUTF8(0)) + 'languages' + DirectorySeparator +
563 ChangeFileExt(ExtractFileName(ParamStrUTF8(0)), Format(FormatLang, [LangShortID])) + LCExt;
564 if FileExistsUTF8(Result) then
565 exit;
566 end;
567
568 Result := '';
569end;
570
571
572end.
573
Note: See TracBrowser for help on using the repository browser.