source: branches/generator/Packages/CoolTranslator/UCoolTranslator.pas

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