source: trunk/Packages/CoolTranslator/UCoolTranslator.pas

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