source: tags/1.3.0/Packages/CoolTranslator/UCoolTranslator.pas

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