source: ProjectTemplates/FileMenuProject/Packages/CoolTranslator/UCoolTranslator.pas

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