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

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