source: trunk/Packages/CoolTranslator/UCoolTranslator.pas

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