source: cprs/branches/tmg-cprs/dklang-package-3.01/DKLang.pas@ 783

Last change on this file since 783 was 468, checked in by Kevin Toppenberg, 16 years ago

CPRS v1.0.26.76
File size: 107.1 KB
Line 
1///*********************************************************************************************************************
2/// $Id: DKLang.pas,v 1.36 2006/08/11 06:59:45 dale Exp $
3///---------------------------------------------------------------------------------------------------------------------
4/// DKLang Localization Package
5/// Copyright 2002-2006 DK Software, http://www.dk-soft.org/
6///*********************************************************************************************************************
7///
8/// The contents of this package are subject to the Mozilla Public License
9/// Version 1.1 (the "License"); you may not use this file except in compliance
10/// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
11///
12/// Alternatively, you may redistribute this library, use and/or modify it under the
13/// terms of the GNU Lesser General Public License as published by the Free Software
14/// Foundation; either version 2.1 of the License, or (at your option) any later
15/// version. You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/
16///
17/// Software distributed under the License is distributed on an "AS IS" basis,
18/// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
19/// specific language governing rights and limitations under the License.
20///
21/// The initial developer of the original code is Dmitry Kann, http://www.dk-soft.org/
22/// Unicode support was initially developed by Bruce J. Miller <bjmiller-at-gmail.com>
23///
24///*********************************************************************************************************************
25// The main unit (and the only required runtime unit) of the package. Contains all the
26// basic class and component declarations
27//
28unit DKLang;
29
30{$INCLUDE TntCompilers.inc}
31
32interface
33uses
34 Windows, SysUtils, Classes, Contnrs, Masks, TntClasses,
35 // TntWideStrings shouldn't be used in BDS 2006+ as those IDEs correctly implement default WideStrings
36 {$IFDEF COMPILER_10_UP}
37 WideStrings
38 {$ELSE}
39 TntWideStrings
40 {$ENDIF}
41 ;
42
43type
44 // Error
45 EDKLangError = class(Exception);
46
47 TDKLang_Constants = class;
48
49 // A translation state
50 TDKLang_TranslationState = (
51 dktsUntranslated, // The value is still untranslated
52 dktsAutotranslated); // The value was translated using the Translation Repository and hence the result needs checking
53 TDKLang_TranslationStates = set of TDKLang_TranslationState;
54
55 //-------------------------------------------------------------------------------------------------------------------
56 // An interface to an object capable of storing its data as a language source strings
57 //-------------------------------------------------------------------------------------------------------------------
58
59 IDKLang_LanguageSourceObject = interface(IInterface)
60 ['{41861692-AF49-4973-BDA1-0B1375407D29}']
61 // Is called just before storing begins. Must return True to allow the storing or False otherwise
62 function CanStore: Boolean;
63 // Must append the language source lines (Strings) with its own data. If an entry states intersect with
64 // StateFilter, the entry should be skipped
65 procedure StoreLangSource(Strings: TWideStrings; StateFilter: TDKLang_TranslationStates);
66 // Prop handlers
67 function GetSectionName: WideString;
68 // Props
69 // -- The name of the section corresponding to object language source data (without square brackets)
70 property SectionName: WideString read GetSectionName;
71 end;
72
73 //-------------------------------------------------------------------------------------------------------------------
74 // A list of masks capable of testing an arbitrary string for matching. A string is considered matching when it
75 // matches any mask from the list
76 //-------------------------------------------------------------------------------------------------------------------
77
78 TDKLang_MaskList = class(TObjectList)
79 private
80 function GetItems(Index: Integer): TMask;
81 public
82 // Creates and fills the list from Strings
83 constructor Create(MaskStrings: TStrings);
84 // Returns True if s matches any mask from the list
85 function Matches(const s: String): Boolean;
86 // Props
87 // -- Masks by index
88 property Items[Index: Integer]: TMask read GetItems; default;
89 end;
90
91 //-------------------------------------------------------------------------------------------------------------------
92 // A single component property value translation, referred to by ID
93 //-------------------------------------------------------------------------------------------------------------------
94
95 PDKLang_PropValueTranslation = ^TDKLang_PropValueTranslation;
96 TDKLang_PropValueTranslation = record
97 iID: Integer; // An entry ID, form-wide unique and permanent
98 wsValue: WideString; // The property value translation
99 TranStates: TDKLang_TranslationStates; // Translation states
100 end;
101
102 //-------------------------------------------------------------------------------------------------------------------
103 // List of property value translations for the whole component hierarchy (usually for a single form); a plain list
104 // indexed (and sorted) by ID
105 //-------------------------------------------------------------------------------------------------------------------
106
107 TDKLang_CompTranslation = class(TList)
108 private
109 // Prop storage
110 FComponentName: String;
111 // Prop handlers
112 function GetItems(Index: Integer): PDKLang_PropValueTranslation;
113 protected
114 procedure Notify(Ptr: Pointer; Action: TListNotification); override;
115 public
116 constructor Create(const sComponentName: String);
117 // Adds an entry into the list and returns the index of the newly added entry
118 function Add(iID: Integer; const wsValue: WideString; TranStates: TDKLang_TranslationStates): Integer;
119 // Returns index of entry by its ID; -1 if not found
120 function IndexOfID(iID: Integer): Integer;
121 // Tries to find the entry by property ID; returns True, if succeeded, and its index in iIndex; otherwise returns
122 // False and its adviced insertion-point index in iIndex
123 function FindID(iID: Integer; out iIndex: Integer): Boolean;
124 // Returns the property entry for given ID, or nil if not found
125 function FindPropByID(iID: Integer): PDKLang_PropValueTranslation;
126 // Props
127 // -- Root component's name for which the translations in the list are (form, frame, datamodule etc)
128 property ComponentName: String read FComponentName;
129 // -- Translations by index
130 property Items[Index: Integer]: PDKLang_PropValueTranslation read GetItems; default;
131 end;
132
133 //-------------------------------------------------------------------------------------------------------------------
134 // List of component translations
135 //-------------------------------------------------------------------------------------------------------------------
136
137 TDKLang_CompTranslations = class(TList)
138 private
139 // Prop storage
140 FConstants: TDKLang_Constants;
141 FIsStreamUnicode: Boolean;
142 FParams: TWideStrings;
143 // Callback function for obtaining current language ID
144 function GetLangIDCallback: LANGID;
145 // Prop handlers
146 function GetItems(Index: Integer): TDKLang_CompTranslation;
147 protected
148 procedure Notify(Ptr: Pointer; Action: TListNotification); override;
149 public
150 constructor Create;
151 destructor Destroy; override;
152 procedure Clear; override;
153 // Adds an item to the list and returns the index of the newly added entry
154 function Add(Item: TDKLang_CompTranslation): Integer;
155 // Returns index of entry by component name; -1 if not found
156 function IndexOfComponentName(const sComponentName: String): Integer;
157 // Returns component translation entry by component name; nil if not found
158 function FindComponentName(const sComponentName: String): TDKLang_CompTranslation;
159 // Stream loading and storing in plaintext (ini-file-like) format. bParamsOnly tells the object to load only the
160 // sectionless parameters and not to load components nor constants. This may be used to evaluate the translation
161 // parameters only (eg. its language)
162 procedure Text_LoadFromStream(Stream: TStream; bParamsOnly: Boolean = False);
163 procedure Text_SaveToStream(Stream: TStream; bUnicode, bSkipUntranslated: Boolean);
164 // File loading in plaintext (ini-file-like) format
165 procedure Text_LoadFromFile(const wsFileName: WideString; bParamsOnly: Boolean = False);
166 // File storing in plaintext (ini-file-like) format:
167 // bUnicode - if False, stores the data in ANSI encoding; if True, stores them in Unicode
168 // bSkipUntranslated - if True, untranslated values are eliminated from the file
169 procedure Text_SaveToFile(const wsFileName: WideString; bUnicode, bSkipUntranslated: Boolean);
170 // Resource loading
171 procedure Text_LoadFromResource(Instance: HINST; const wsResName: WideString; bParamsOnly: Boolean = False); overload;
172 procedure Text_LoadFromResource(Instance: HINST; iResID: Integer; bParamsOnly: Boolean = False); overload;
173 // Props
174 // -- Constant entries
175 property Constants: TDKLang_Constants read FConstants;
176 // -- True if last loading from text file/stream detected that it used Unicode encoding; False if it was ANSI
177 property IsStreamUnicode: Boolean read FIsStreamUnicode;
178 // -- Component translations by index
179 property Items[Index: Integer]: TDKLang_CompTranslation read GetItems; default;
180 // -- Simple parameters stored in a translation file BEFORE the first section (ie. sectionless)
181 property Params: TWideStrings read FParams;
182 end;
183
184 //-------------------------------------------------------------------------------------------------------------------
185 // A single component property entry
186 //-------------------------------------------------------------------------------------------------------------------
187
188 PDKLang_PropEntry = ^TDKLang_PropEntry;
189 TDKLang_PropEntry = record
190 iID: Integer; // An entry ID, form-wide unique and permanent
191 sPropName: String; // Component's property name to which the entry is applied
192 wsDefLangValue: WideString; // The property's value for the default language, represented as a widestring
193 bValidated: Boolean; // Validation flag, used internally in TDKLang_CompEntry.UpdateEntries
194 end;
195
196 //-------------------------------------------------------------------------------------------------------------------
197 // List of property entries (sorted by property name, case-insensitively)
198 //-------------------------------------------------------------------------------------------------------------------
199
200 TDKLang_PropEntries = class(TList)
201 private
202 // Prop handlers
203 function GetItems(Index: Integer): PDKLang_PropEntry;
204 protected
205 procedure Notify(Ptr: Pointer; Action: TListNotification); override;
206 // Resets bValidated flag for each entry
207 procedure Invalidate;
208 // Deletes all invalid entries
209 procedure DeleteInvalidEntries;
210 // Returns max property entry ID over the list; 0 if list is empty
211 function GetMaxID: Integer;
212 public
213 // Add an entry into the list (returns True) or replaces the property value with sDefLangValue if property with
214 // this name already exists (and returns False). Also sets bValidated to True
215 function Add(iID: Integer; const sPropName: String; const wsDefLangValue: WideString): Boolean;
216 // Returns index of entry by its ID; -1 if not found
217 function IndexOfID(iID: Integer): Integer;
218 // Returns index of entry by property name; -1 if not found
219 function IndexOfPropName(const sPropName: String): Integer;
220 // Tries to find the entry by property name; returns True, if succeeded, and its index in iIndex; otherwise returns
221 // False and its adviced insertion-point index in iIndex
222 function FindPropName(const sPropName: String; out iIndex: Integer): Boolean;
223 // Returns entry by property name; nil if not found
224 function FindPropByName(const sPropName: String): PDKLang_PropEntry;
225 // Stream loading and storing
226 procedure LoadFromDFMResource(Stream: TStream);
227 procedure SaveToDFMResource(Stream: TStream);
228 // Props
229 // -- Entries by index
230 property Items[Index: Integer]: PDKLang_PropEntry read GetItems; default;
231 end;
232
233 //-------------------------------------------------------------------------------------------------------------------
234 // Single component entry
235 //-------------------------------------------------------------------------------------------------------------------
236
237 TDKLang_CompEntries = class;
238
239 TDKLang_CompEntry = class(TObject)
240 private
241 // Component property entries
242 FPropEntries: TDKLang_PropEntries;
243 // Owned component entries
244 FOwnedCompEntries: TDKLang_CompEntries;
245 // Prop storage
246 FName: String;
247 FComponent: TComponent;
248 FOwner: TDKLang_CompEntry;
249 // Recursively calls PropEntries.Invalidate for each component
250 procedure InvalidateProps;
251 // Returns max property entry ID across all owned components; 0 if list is empty
252 function GetMaxPropEntryID: Integer;
253 // Internal recursive update routine
254 procedure InternalUpdateEntries(var iFreePropEntryID: Integer; bModifyList, bIgnoreEmptyProps, bIgnoreNonAlphaProps, bIgnoreFontProps: Boolean; IgnoreMasks, StoreMasks: TDKLang_MaskList);
255 // Recursively establishes links to components by filling FComponent field with the component reference found by
256 // its Name. Also removes components whose names no longer associated with actually instantiated components.
257 // Required to be called after loading from the stream
258 procedure BindComponents(CurComponent: TComponent);
259 // Recursively appends property data as a language source format into Strings
260 procedure StoreLangSource(Strings: TWideStrings);
261 // Prop handlers
262 function GetName: String;
263 function GetComponentNamePath(bIncludeRoot: Boolean): String;
264 public
265 constructor Create(AOwner: TDKLang_CompEntry);
266 destructor Destroy; override;
267 // If bModifyList=True, recursively updates (or creates) component hierarchy and component property values,
268 // creating and deleting entries as appropriate. If bModifyList=False, only refreshes the [current=default]
269 // property values
270 procedure UpdateEntries(bModifyList, bIgnoreEmptyProps, bIgnoreNonAlphaProps, bIgnoreFontProps: Boolean; IgnoreMasks, StoreMasks: TDKLang_MaskList);
271 // Recursively replaces the property values with ones found in Translation; if Translation=nil, applies the default
272 // property values
273 procedure ApplyTranslation(Translation: TDKLang_CompTranslation; cCodePage: Cardinal);
274 // Stream loading/storing
275 procedure LoadFromDFMResource(Stream: TStream);
276 procedure SaveToDFMResource(Stream: TStream);
277 // Removes the given component by reference, if any; if bRecursive=True, acts recursively
278 procedure RemoveComponent(AComponent: TComponent; bRecursive: Boolean);
279 // Props
280 // -- Reference to the component (nil while loading from the stream)
281 property Component: TComponent read FComponent;
282 // -- Returns component name path in the form 'owner1.owner2.name'. If bIncludeRoot=False, excludes the top-level
283 // owner name
284 property ComponentNamePath[bIncludeRoot: Boolean]: String read GetComponentNamePath;
285 // -- Component name in the IDE
286 property Name: String read GetName;
287 // -- Owner entry, can be nil
288 property Owner: TDKLang_CompEntry read FOwner;
289 end;
290
291 //-------------------------------------------------------------------------------------------------------------------
292 // List of component entries
293 //-------------------------------------------------------------------------------------------------------------------
294
295 TDKLang_CompEntries = class(TList)
296 private
297 // Prop storage
298 FOwner: TDKLang_CompEntry;
299 // Prop handlers
300 function GetItems(Index: Integer): TDKLang_CompEntry;
301 protected
302 procedure Notify(Ptr: Pointer; Action: TListNotification); override;
303 public
304 constructor Create(AOwner: TDKLang_CompEntry);
305 // Add an entry into the list; returns the index of the newly added entry
306 function Add(Item: TDKLang_CompEntry): Integer;
307 // Returns index of entry by component name; -1 if not found
308 function IndexOfCompName(const sCompName: String): Integer;
309 // Returns index of entry by component reference; -1 if not found
310 function IndexOfComponent(CompReference: TComponent): Integer;
311 // Returns entry for given component reference; nil if not found
312 function FindComponent(CompReference: TComponent): TDKLang_CompEntry;
313 // Stream loading and storing
314 procedure LoadFromDFMResource(Stream: TStream);
315 procedure SaveToDFMResource(Stream: TStream);
316 // Props
317 // -- Items by index
318 property Items[Index: Integer]: TDKLang_CompEntry read GetItems; default;
319 // -- Owner component entry
320 property Owner: TDKLang_CompEntry read FOwner;
321 end;
322
323 //-------------------------------------------------------------------------------------------------------------------
324 // A constant
325 //-------------------------------------------------------------------------------------------------------------------
326
327 PDKLang_Constant = ^TDKLang_Constant;
328 TDKLang_Constant = record
329 sName: String; // Constant name, written obeying standard rules for identifier naming
330 wsValue: WideString; // Constant value
331 wsDefValue: WideString; // Default constant value (in the default language; initially the same as wsValue)
332 TranStates: TDKLang_TranslationStates; // Translation states
333 end;
334
335 //-------------------------------------------------------------------------------------------------------------------
336 // List of constants (sorted by name, case-insensitively)
337 //-------------------------------------------------------------------------------------------------------------------
338
339 // Callback function called when there's a need to determine language of constants being converted from ANSI to
340 // Unicode
341 TDKLang_GetLangIDCallback = function: LANGID of object;
342
343 TDKLang_Constants = class(TList, IInterface, IDKLang_LanguageSourceObject)
344 private
345 // Get language ID callback
346 FGetLangIDCallback: TDKLang_GetLangIDCallback;
347 // Prop storage
348 FAutoSaveLangSource: Boolean;
349 // IInterface
350 function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
351 function _AddRef: Integer; stdcall;
352 function _Release: Integer; stdcall;
353 // IDKLang_LanguageSourceObject
354 function IDKLang_LanguageSourceObject.CanStore = LSO_CanStore;
355 procedure IDKLang_LanguageSourceObject.StoreLangSource = LSO_StoreLangSource;
356 function IDKLang_LanguageSourceObject.GetSectionName = LSO_GetSectionName;
357 function LSO_CanStore: Boolean;
358 procedure LSO_StoreLangSource(Strings: TWideStrings; StateFilter: TDKLang_TranslationStates);
359 function LSO_GetSectionName: WideString;
360 // Prop handlers
361 function GetAsRawString: String;
362 function GetItems(Index: Integer): PDKLang_Constant;
363 function GetItemsByName(const sName: String): PDKLang_Constant;
364 function GetValues(const sName: String): WideString;
365 procedure SetAsRawString(const Value: String);
366 procedure SetValues(const sName: String; const wsValue: WideString);
367 protected
368 procedure Notify(Ptr: Pointer; Action: TListNotification); override;
369 public
370 constructor Create(AGetLangIDCallback: TDKLang_GetLangIDCallback);
371 // Add an entry into the list; returns the index of the newly inserted entry
372 function Add(const sName: String; const wsValue: WideString; TranStates: TDKLang_TranslationStates): Integer;
373 // Returns index of entry by name; -1 if not found
374 function IndexOfName(const sName: String): Integer;
375 // Tries to find the entry by name; returns True, if succeeded, and its index in iIndex; otherwise returns False
376 // and its adviced insertion-point index in iIndex
377 function FindName(const sName: String; out iIndex: Integer): Boolean;
378 // Finds the constant by name; returns nil if not found
379 function FindConstName(const sName: String): PDKLang_Constant;
380 // Stream loading/storing
381 procedure LoadFromStream(Stream: TStream);
382 procedure SaveToStream(Stream: TStream);
383 // Loads the constants from binary resource with the specified name. Returns True if resource existed, False
384 // otherwise
385 function LoadFromResource(Instance: HINST; const wsResName: WideString): Boolean;
386 // Updates the values for existing names from Constants. If Constants=nil, reverts the values to their defaults
387 // (wsDefValue)
388 procedure TranslateFrom(Constants: TDKLang_Constants);
389 // Props
390 // -- Binary list representation as raw data
391 property AsRawString: String read GetAsRawString write SetAsRawString;
392 // -- If True (default), the list will be automatically saved into the Project's language resource file (*.dklang)
393 property AutoSaveLangSource: Boolean read FAutoSaveLangSource write FAutoSaveLangSource;
394 // -- Constants by index
395 property Items[Index: Integer]: PDKLang_Constant read GetItems; default;
396 // -- Constants by name. If no constant of that name exists, an Exception is raised
397 property ItemsByName[const sName: String]: PDKLang_Constant read GetItemsByName;
398 // -- Constant values, by name. If no constant of that name exists, an Exception is raised
399 property Values[const sName: String]: WideString read GetValues write SetValues;
400 end;
401
402 //-------------------------------------------------------------------------------------------------------------------
403 // Non-visual language controller component
404 //-------------------------------------------------------------------------------------------------------------------
405
406 // TDKLanguageController options
407 TDKLanguageControllerOption = (
408 dklcoAutoSaveLangSource, // If on, the component will automatically save itself into the Project's language resource file (*.dklang)
409 dklcoIgnoreEmptyProps, // Ignore all properties having no string assigned
410 dklcoIgnoreNonAlphaProps, // Ignore all properties with no alpha characters (e.g. with numbers or symbols only); includes dklcoIgnoreEmptyProps behavior
411 dklcoIgnoreFontProps); // Ignore all TFont properties
412 TDKLanguageControllerOptions = set of TDKLanguageControllerOption;
413const
414 DKLang_DefaultControllerOptions = [dklcoAutoSaveLangSource, dklcoIgnoreEmptyProps, dklcoIgnoreNonAlphaProps, dklcoIgnoreFontProps];
415
416type
417 TDKLanguageController = class(TComponent, IDKLang_LanguageSourceObject)
418 private
419 // Prop storage
420 FIgnoreList: TStrings;
421 FOnLanguageChanged: TNotifyEvent;
422 FOnLanguageChanging: TNotifyEvent;
423 FOptions: TDKLanguageControllerOptions;
424 FRootCompEntry: TDKLang_CompEntry;
425 FSectionName: WideString;
426 FStoreList: TStrings;
427 // Methods for LangData custom property support
428 procedure LangData_Load(Stream: TStream);
429 procedure LangData_Store(Stream: TStream);
430 // IDKLang_LanguageSourceObject
431 function IDKLang_LanguageSourceObject.CanStore = LSO_CanStore;
432 procedure IDKLang_LanguageSourceObject.StoreLangSource = LSO_StoreLangSource;
433 function IDKLang_LanguageSourceObject.GetSectionName = GetActualSectionName;
434 function LSO_CanStore: Boolean;
435 procedure LSO_StoreLangSource(Strings: TWideStrings; StateFilter: TDKLang_TranslationStates);
436 // Forces component entries to update their entries. If bModifyList=False, only default property values are
437 // initialized, no entry additions/removes are allowed
438 procedure UpdateComponents(bModifyList: Boolean);
439 // Prop handlers
440 function GetActualSectionName: WideString;
441 procedure SetIgnoreList(Value: TStrings);
442 procedure SetStoreList(Value: TStrings);
443 protected
444 procedure DefineProperties(Filer: TFiler); override;
445 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
446 // Fires the OnLanguageChanging event
447 procedure DoLanguageChanging;
448 // Fires the OnLanguageChanged event
449 procedure DoLanguageChanged;
450 public
451 constructor Create(AOwner: TComponent); override;
452 destructor Destroy; override;
453 procedure Loaded; override;
454 // Props
455 // -- Name of a section that is actually used to store and read language data
456 property ActualSectionName: WideString read GetActualSectionName;
457 // -- The root entry, corresponding to the instance's owner
458 property RootCompEntry: TDKLang_CompEntry read FRootCompEntry;
459 published
460 // -- List of ignored properties
461 property IgnoreList: TStrings read FIgnoreList write SetIgnoreList;
462 // -- Language controller options
463 property Options: TDKLanguageControllerOptions read FOptions write FOptions default DKLang_DefaultControllerOptions;
464 // -- Name of a section corresponding to the form or frame served by the controller. If empty (default), Owner's
465 // name is used as section name
466 property SectionName: WideString read FSectionName write FSectionName;
467 // -- List of forcibly stored properties
468 property StoreList: TStrings read FStoreList write SetStoreList;
469 // Events
470 // -- Fires when language is changed through the LangManager
471 property OnLanguageChanging: TNotifyEvent read FOnLanguageChanging write FOnLanguageChanging;
472 // -- Fires when language is changed through the LangManager
473 property OnLanguageChanged: TNotifyEvent read FOnLanguageChanged write FOnLanguageChanged;
474 end;
475
476 //-------------------------------------------------------------------------------------------------------------------
477 // A helper language resource list
478 //-------------------------------------------------------------------------------------------------------------------
479
480 // Language resource entry kind
481 TDKLang_LangResourceKind = (
482 dklrkResName, // The entry is a resource addressed by name
483 dklrkResID, // The entry is a resource addressed by ID
484 dklrkFile); // The entry is a translation file
485
486 PDKLang_LangResource = ^TDKLang_LangResource;
487 TDKLang_LangResource = record
488 Kind: TDKLang_LangResourceKind; // Entry kind
489 Instance: HINST; // Instance containing the resource (Kind=[dklrkResName, dklrkResID])
490 wsName: WideString; // File (Kind=dklrkFile) or resource (Kind=dklrkResName) name
491 iResID: Integer; // Resource ID (Kind=dklrkResID)
492 wLangID: LANGID; // Language contained in the resource
493 end;
494
495 TDKLang_LangResources = class(TList)
496 private
497 function GetItems(Index: Integer): PDKLang_LangResource;
498 protected
499 procedure Notify(Ptr: Pointer; Action: TListNotification); override;
500 public
501 function Add(Kind: TDKLang_LangResourceKind; Instance: HINST; const wsName: WideString; iResID: Integer; wLangID: LANGID): Integer;
502 // Returns the index of entry having the specified LangID; -1 if no such entry
503 function IndexOfLangID(wLangID: LANGID): Integer;
504 // Returns the entry having the specified LangID; nil if no such entry
505 function FindLangID(wLangID: LANGID): PDKLang_LangResource;
506 // Props
507 // -- Items by index
508 property Items[Index: Integer]: PDKLang_LangResource read GetItems; default;
509 end;
510
511 //-------------------------------------------------------------------------------------------------------------------
512 // Global thread-safe language manager class
513 //-------------------------------------------------------------------------------------------------------------------
514
515 TDKLanguageManager = class(TObject)
516 private
517 // Synchronizer object to ensure the thread safety
518 FSynchronizer: TMultiReadExclusiveWriteSynchronizer;
519 // Internal constants object
520 FConstants: TDKLang_Constants;
521 // Internal list of language controllers have been created (runtime only)
522 FLangControllers: TList;
523 // Language resources registered (runtime only)
524 FLangResources: TDKLang_LangResources;
525 // Prop storage
526 FCodePage: Cardinal;
527 FDefaultLanguageID: LANGID;
528 FLanguageID: LANGID;
529 // Applies the specified translation to controllers and constants. Translations=nil means the default language to
530 // be applied
531 procedure ApplyTran(Translations: TDKLang_CompTranslations);
532 // Applies the specified translation to a single controller. Not a thread-safe method
533 procedure ApplyTranToController(Translations: TDKLang_CompTranslations; Controller: TDKLanguageController);
534 // Creates and returns the translations object, or nil if wLangID=DefaultLangID or creation failed. Not a
535 // thread-safe method
536 function GetTranslationsForLang(wLangID: LANGID): TDKLang_CompTranslations;
537 // Updates CodePage in order to match current LanguageID. Not a thread-safe method
538 procedure UpdateCodePage;
539 // Prop handlers
540 function GetConstantValue(const sName: String): WideString;
541 function GetConstantValueA(const sName: String): String;
542 function GetDefaultLanguageID: LANGID;
543 function GetLanguageCount: Integer;
544 function GetLanguageID: LANGID;
545 function GetLanguageIDs(Index: Integer): LANGID;
546 function GetLanguageIndex: Integer;
547 function GetLanguageNames(Index: Integer): WideString;
548 function GetLanguageResources(Index: Integer): PDKLang_LangResource;
549 procedure SetDefaultLanguageID(Value: LANGID);
550 procedure SetLanguageID(Value: LANGID);
551 procedure SetLanguageIndex(Value: Integer);
552 protected
553 // Internal language controller registration procedures (allowed at runtime only)
554 procedure AddLangController(Controller: TDKLanguageController);
555 procedure RemoveLangController(Controller: TDKLanguageController);
556 // Called by controllers when they are initialized and ready. Applies the currently selected language to the
557 // controller
558 procedure TranslateController(Controller: TDKLanguageController);
559 public
560 constructor Create;
561 destructor Destroy; override;
562 // Registers a translation file for specified language. Returns True if the file was a valid translation file with
563 // language specified. The file replaces any language resource for that language registered before. You can never
564 // replace the DefaultLanguage though
565 function RegisterLangFile(const wsFileName: WideString): Boolean;
566 // Register a resource as containing translation data for specified language. The resource replaces any language
567 // resource for that language registered before. You can never replace the DefaultLanguage though
568 procedure RegisterLangResource(Instance: HINST; const wsResourceName: WideString; wLangID: LANGID); overload;
569 procedure RegisterLangResource(Instance: HINST; iResID: Integer; wLangID: LANGID); overload;
570 // Removes language with the specified LangID from the registered language resources list. You cannot remove the
571 // DefaultLanguage
572 procedure UnregisterLangResource(wLangID: LANGID);
573 // Scans the specified directory for language files using given file mask. If bRecursive=True, also searches in the
574 // subdirectories of sDir. Returns the number of files successfully registered. Examples that scan the
575 // application directory for files with '.lng' extension:
576 // ScanForLangFiles(ExtractFileDir(ParamStr(0)), '*.lng', False); // ANSI version, not always correct
577 // ScanForLangFiles(WideExtractFileDir(WideParamStr(0)), '*.lng', False); // Unicode version, requires Tnt
578 // // Unicode Controls
579 function ScanForLangFiles(const wsDir, wsMask: WideString; bRecursive: Boolean): Integer;
580 // Returns the index of specified LangID, or -1 if not found
581 function IndexOfLanguageID(wLangID: LANGID): Integer;
582 // Props
583 // -- Code page corresponding to the current value of LanguageID
584 property CodePage: Cardinal read FCodePage;
585 // -- Constant values by name, Unicode version
586 property ConstantValue[const sName: String]: WideString read GetConstantValue;
587 // -- Constant values by name, ANSI version
588 property ConstantValueA[const sName: String]: String read GetConstantValueA;
589 // -- Constant values by name, Unicode version; the same as ConstantValue[]
590 property ConstantValueW[const sName: String]: WideString read GetConstantValue;
591 // -- Default language ID. The default value is US English ($409)
592 property DefaultLanguageID: LANGID read GetDefaultLanguageID write SetDefaultLanguageID;
593 // -- Current language ID. Initially equals to DefaultLanguageID. When being changed, affects all the registered
594 // language controllers as well as constants
595 property LanguageID: LANGID read GetLanguageID write SetLanguageID;
596 // -- Current language index
597 property LanguageIndex: Integer read GetLanguageIndex write SetLanguageIndex;
598 // -- Number of languages (language resources) registered, including the default language
599 property LanguageCount: Integer read GetLanguageCount;
600 // -- LangIDs of languages (language resources) registered, index ranged 0 to LanguageCount-1
601 property LanguageIDs[Index: Integer]: LANGID read GetLanguageIDs;
602 // -- Names of languages (language resources) registered, index ranged 0 to LanguageCount-1, Unicode version only
603 property LanguageNames[Index: Integer]: WideString read GetLanguageNames;
604 // -- Language resources registered, index ranged 0 to LanguageCount-1. Always nil for Index=0, ie. for default
605 // language
606 property LanguageResources[Index: Integer]: PDKLang_LangResource read GetLanguageResources;
607 end;
608
609 // Returns the global language manager instance (allowed at runtime only)
610 function LangManager: TDKLanguageManager;
611
612 // Encoding/decoding of control characters in backslashed (escaped) form (CRLF -> \n, TAB -> \t, \ -> \\ etc)
613 function EncodeControlChars(const ws: WideString): WideString; // Raw string -> Escaped string
614 function DecodeControlChars(const ws: WideString): WideString; // Escaped string -> Raw string
615 // Finds and updates the corresponding section in Strings (which appear as language source file). If no appropriate
616 // section found, appends the lines to the end of Strings
617 procedure UpdateLangSourceStrings(Strings: TWideStrings; LSObject: IDKLang_LanguageSourceObject; StateFilter: TDKLang_TranslationStates);
618 // The same as UpdateLangSourceStrings() but operates directly on a language source file. If no such file, a new file
619 // is created
620 procedure UpdateLangSourceFile(const wsFileName: WideString; LSObject: IDKLang_LanguageSourceObject; StateFilter: TDKLang_TranslationStates);
621 // Raises exception EDKLangError
622 procedure DKLangError(const sMsg: String); overload;
623 procedure DKLangError(const sMsg: String; const aParams: Array of const); overload;
624
625 // Shortcut to LangManager.ConstantValueW[]
626 function DKLangConstW(const sName: String): WideString; overload;
627 // The same, but formats constant value using aParams
628 function DKLangConstW(const sName: String; const aParams: Array of const): WideString; overload;
629 // Shortcut to LangManager.ConstantValueA[]
630 function DKLangConstA(const sName: String): String; overload;
631 // The same, but formats constant value using aParams
632 function DKLangConstA(const sName: String; const aParams: Array of const): String; overload;
633
634const
635 // Version used for saving binary data into streams
636 IDKLang_StreamVersion = 2;
637
638 // Resource name for constant entries in the .res file and executable resources
639 SDKLang_ConstResourceName = 'DKLANG_CONSTS';
640
641 // Section name for constant entries in the language source or translation files
642 SDKLang_ConstSectionName = '$CONSTANTS';
643
644 // Component translations parameter names
645 SDKLang_TranParam_LangID = 'LANGID';
646 SDKLang_TranParam_SourceLangID = 'SourceLANGID';
647 SDKLang_TranParam_Author = 'Author';
648 SDKLang_TranParam_Generator = 'Generator';
649 SDKLang_TranParam_LastModified = 'LastModified';
650 SDKLang_TranParam_TargetApplication = 'TargetApplication';
651
652 // Default language source file extension
653 SDKLang_LangSourceExtension = 'dklang';
654
655 ILangID_USEnglish = $0409;
656
657var
658 // Set to True by DKLang expert to indicate the design time execution
659 IsDesignTime: Boolean = False;
660
661resourcestring
662 SDKLangErrMsg_DuplicatePropValueID = 'Duplicate property value translation ID (%d)';
663 SDKLangErrMsg_ErrorLoadingTran = 'Loading translations failed.'#13#10'Line %d: %s';
664 SDKLangErrMsg_InvalidConstName = 'Invalid constant name ("%s")';
665 SDKLangErrMsg_DuplicateConstName = 'Duplicate constant name ("%s")';
666 SDKLangErrMsg_ConstantNotFound = 'Constant "%s" not found';
667 SDKLangErrMsg_LangManagerCalledAtDT = 'Call to LangManager() is allowed at runtime only';
668 SDKLangErrMsg_StreamVersionTooHigh = 'Stream version (%d) is greater than the current one (%d)';
669
670implementation
671uses TypInfo, Math, TntSysUtils, TntSystem;
672
673var
674 _LangManager: TDKLanguageManager = nil;
675
676 function LangManager: TDKLanguageManager;
677 begin
678 // Check that it's a runtime call
679 if IsDesignTime then DKLangError(SDKLangErrMsg_LangManagerCalledAtDT);
680 // Create _LangManager if needed
681 if _LangManager=nil then _LangManager := TDKLanguageManager.Create;
682 Result := _LangManager;
683 end;
684
685 function EncodeControlChars(const ws: WideString): WideString;
686 var
687 i, iLen: Integer;
688 wc: WideChar;
689 begin
690 Result := '';
691 iLen := Length(ws);
692 i := 1;
693 while i<=iLen do begin
694 wc := ws[i];
695 case wc of
696 // Tab character
697 #9: Result := Result+'\t';
698 // Linefeed character. Skip subsequent Carriage Return char, if any
699 #10: begin
700 Result := Result+'\n';
701 if (i<iLen) and (ws[i+1]=#13) then Inc(i);
702 end;
703 // Carriage Return character. Skip subsequent Linefeed char, if any
704 #13: begin
705 Result := Result+'\n';
706 if (i<iLen) and (ws[i+1]=#10) then Inc(i);
707 end;
708 // Backslash. Just duplicate it
709 '\': Result := Result+'\\';
710 // All control characters having no special names represent as '\00' escape sequence; add directly all others
711 else if wc<#32 then Result := Result+WideFormat('\%.2d', [Word(wc)]) else Result := Result+wc;
712 end;
713 Inc(i);
714 end;
715 end;
716
717 function DecodeControlChars(const ws: WideString): WideString;
718 var
719 i, iLen: Integer;
720 wc: WideChar;
721 bEscape: Boolean;
722 begin
723 Result := '';
724 iLen := Length(ws);
725 i := 1;
726 while i<=iLen do begin
727 wc := ws[i];
728 bEscape := False;
729 if (wc='\') and (i<iLen) then
730 case ws[i+1] of
731 // An escaped charcode '\00'
732 '0'..'9': if (i<iLen-1) and (ws[i+2] in [WideChar('0')..WideChar('9')]) then begin
733 Result := Result+WideChar((Word(ws[i+1])-Word('0'))*10+(Word(ws[i+2])-Word('0')));
734 Inc(i, 2);
735 bEscape := True;
736 end;
737 '\': begin
738 Result := Result+'\';
739 Inc(i);
740 bEscape := True;
741 end;
742 'n': begin
743 Result := Result+#13#10;
744 Inc(i);
745 bEscape := True;
746 end;
747 't': begin
748 Result := Result+#9;
749 Inc(i);
750 bEscape := True;
751 end;
752 end;
753 if not bEscape then Result := Result+wc;
754 Inc(i);
755 end;
756 end;
757
758 procedure UpdateLangSourceStrings(Strings: TWideStrings; LSObject: IDKLang_LanguageSourceObject; StateFilter: TDKLang_TranslationStates);
759 var
760 idx, i: Integer;
761 wsSectionName: WideString;
762 SLLangSrc: TTntStringList;
763 begin
764 if not LSObject.CanStore then Exit;
765 SLLangSrc := TTntStringList.Create;
766 try
767 // Put section name
768 wsSectionName := WideFormat('[%s]', [LSObject.SectionName]);
769 SLLangSrc.Add(wsSectionName);
770 // Export language source data
771 LSObject.StoreLangSource(SLLangSrc, StateFilter);
772 // Add empty string
773 SLLangSrc.Add('');
774 // Lock Strings updates
775 Strings.BeginUpdate;
776 try
777 // Try to find the section
778 idx := Strings.IndexOf(wsSectionName);
779 // If found
780 if idx>=0 then begin
781 // Remove all the lines up to the next section
782 repeat Strings.Delete(idx) until (idx=Strings.Count) or (Copy(Strings[idx], 1, 1)='[');
783 // Insert language source lines into Strings
784 for i := 0 to SLLangSrc.Count-1 do begin
785 Strings.Insert(idx, SLLangSrc[i]);
786 Inc(idx);
787 end;
788 // Else simply append the language source
789 end else
790 Strings.AddStrings(SLLangSrc);
791 finally
792 Strings.EndUpdate;
793 end;
794 finally
795 SLLangSrc.Free;
796 end;
797 end;
798
799 procedure UpdateLangSourceFile(const wsFileName: WideString; LSObject: IDKLang_LanguageSourceObject; StateFilter: TDKLang_TranslationStates);
800 var SLLangSrc: TTntStringList;
801 begin
802 SLLangSrc := TTntStringList.Create;
803 try
804 // Load language file source, if any
805 if WideFileExists(wsFileName) then SLLangSrc.LoadFromFile(wsFileName);
806 // Store the data
807 UpdateLangSourceStrings(SLLangSrc, LSObject, StateFilter);
808 // Save the language source back into file
809 SLLangSrc.SaveToFile(wsFileName);
810 finally
811 SLLangSrc.Free;
812 end;
813 end;
814
815 procedure DKLangError(const sMsg: String); overload;
816
817 function RetAddr: Pointer;
818 asm
819 mov eax, [ebp+4]
820 end;
821
822 begin
823 raise EDKLangError.Create(sMsg) at RetAddr;
824 end;
825
826 procedure DKLangError(const sMsg: String; const aParams: Array of const); overload;
827
828 function RetAddr: Pointer;
829 asm
830 mov eax, [ebp+4]
831 end;
832
833 begin
834 raise EDKLangError.CreateFmt(sMsg, aParams) at RetAddr;
835 end;
836
837 function DKLangConstW(const sName: String): WideString;
838 begin
839 Result := LangManager.ConstantValueW[sName];
840 end;
841
842 function DKLangConstW(const sName: String; const aParams: Array of const): WideString;
843 begin
844 Result := WideFormat(DKLangConstW(sName), aParams);
845 end;
846
847 function DKLangConstA(const sName: String): String;
848 begin
849 Result := LangManager.ConstantValueA[sName];
850 end;
851
852 function DKLangConstA(const sName: String; const aParams: Array of const): String;
853 begin
854 Result := Format(DKLangConstA(sName), aParams);
855 end;
856
857 //===================================================================================================================
858 // Stream I/O
859 //===================================================================================================================
860 // Writing
861
862 procedure StreamWriteByte(Stream: TStream; b: Byte);
863 begin
864 Stream.WriteBuffer(b, 1);
865 end;
866
867 procedure StreamWriteWord(Stream: TStream; w: Word);
868 begin
869 Stream.WriteBuffer(w, 2);
870 end;
871
872 procedure StreamWriteInt(Stream: TStream; i: Integer);
873 begin
874 Stream.WriteBuffer(i, 4);
875 end;
876
877 procedure StreamWriteBool(Stream: TStream; b: Boolean);
878 begin
879 Stream.WriteBuffer(b, 1);
880 end;
881
882 procedure StreamWriteStr(Stream: TStream; const s: string);
883 var w: Word;
884 begin
885 w := Length(s);
886 Stream.WriteBuffer(w, 2);
887 Stream.WriteBuffer(s[1], w);
888 end;
889
890 procedure StreamWriteWideStr(Stream: TStream; const ws: WideString);
891 var w: Word;
892 begin
893 w := Length(ws);
894 Stream.WriteBuffer(w, 2);
895 Stream.WriteBuffer(ws[1], w*2);
896 end;
897
898 procedure StreamWriteLine(Stream: TStream; const ws: WideString); overload;
899 var wsLn: WideString;
900 begin
901 wsLn := ws+#13#10;
902 Stream.WriteBuffer(wsLn[1], Length(wsLn)*2);
903 end;
904
905 procedure StreamWriteLine(Stream: TStream; const s: String); overload;
906 var sLn: String;
907 begin
908 sLn := s+#13#10;
909 Stream.WriteBuffer(sLn[1], Length(sLn));
910 end;
911
912 procedure StreamWriteLine(Stream: TStream; const ws: WideString; const aParams: Array of const); overload;
913 begin
914 StreamWriteLine(Stream, WideFormat(ws, aParams));
915 end;
916
917 // Writes stream version number
918 procedure StreamWriteStreamVersion(Stream: TStream);
919 begin
920 StreamWriteByte(Stream, IDKLang_StreamVersion);
921 end;
922
923 //===================================================================================================================
924 // Reading
925
926 function StreamReadByte(Stream: TStream): Byte;
927 begin
928 Stream.ReadBuffer(Result, 1);
929 end;
930
931 function StreamReadWord(Stream: TStream): Word;
932 begin
933 Stream.ReadBuffer(Result, 2);
934 end;
935
936 function StreamReadInt(Stream: TStream): Integer;
937 begin
938 Stream.ReadBuffer(Result, 4);
939 end;
940
941 function StreamReadBool(Stream: TStream): Boolean;
942 begin
943 Stream.ReadBuffer(Result, 1);
944 end;
945
946 function StreamReadStr(Stream: TStream): string;
947 var w: Word;
948 begin
949 w := StreamReadWord(Stream);
950 SetLength(Result, w);
951 Stream.ReadBuffer(Result[1], w);
952 end;
953
954 function StreamReadWideStr(Stream: TStream): WideString;
955 var w: Word;
956 begin
957 w := StreamReadWord(Stream);
958 SetLength(Result, w);
959 Stream.ReadBuffer(Result[1], w*2);
960 end;
961
962 //===================================================================================================================
963 // TDKLang_MaskList
964 //===================================================================================================================
965
966 constructor TDKLang_MaskList.Create(MaskStrings: TStrings);
967 var i: Integer;
968 begin
969 inherited Create;
970 for i := 0 to MaskStrings.Count-1 do Add(TMask.Create(MaskStrings[i]));
971 end;
972
973 function TDKLang_MaskList.GetItems(Index: Integer): TMask;
974 begin
975 Result := TMask(Get(Index));
976 end;
977
978 function TDKLang_MaskList.Matches(const s: String): Boolean;
979 var i: Integer;
980 begin
981 for i := 0 to Count-1 do
982 if Items[i].Matches(s) then begin
983 Result := True;
984 Exit;
985 end;
986 Result := False;
987 end;
988
989 //===================================================================================================================
990 // TDKLang_CompTranslation
991 //===================================================================================================================
992
993 function TDKLang_CompTranslation.Add(iID: Integer; const wsValue: WideString; TranStates: TDKLang_TranslationStates): Integer;
994 var p: PDKLang_PropValueTranslation;
995 begin
996 // Find insertion point and check ID uniqueness
997 if FindID(iID, Result) then DKLangError(SDKLangErrMsg_DuplicatePropValueID, [iID]);
998 // Create and insert a new entry
999 New(p);
1000 Insert(Result, p);
1001 // Initialize entry
1002 p.iID := iID;
1003 p.wsValue := wsValue;
1004 p.TranStates := TranStates;
1005 end;
1006
1007 constructor TDKLang_CompTranslation.Create(const sComponentName: String);
1008 begin
1009 inherited Create;
1010 FComponentName := sComponentName;
1011 end;
1012
1013 function TDKLang_CompTranslation.FindID(iID: Integer; out iIndex: Integer): Boolean;
1014 var iL, iR, i, iItemID: Integer;
1015 begin
1016 // Since the list is sorted by ID, implement binary search here
1017 Result := False;
1018 iL := 0;
1019 iR := Count-1;
1020 while iL<=iR do begin
1021 i := (iL+iR) shr 1;
1022 iItemID := GetItems(i).iID;
1023 if iItemID<iID then
1024 iL := i+1
1025 else if iItemID=iID then begin
1026 Result := True;
1027 iL := i;
1028 Break;
1029 end else
1030 iR := i-1;
1031 end;
1032 iIndex := iL;
1033 end;
1034
1035 function TDKLang_CompTranslation.FindPropByID(iID: Integer): PDKLang_PropValueTranslation;
1036 var idx: Integer;
1037 begin
1038 if not FindID(iID, idx) then Result := nil else Result := GetItems(idx);
1039 end;
1040
1041 function TDKLang_CompTranslation.GetItems(Index: Integer): PDKLang_PropValueTranslation;
1042 begin
1043 Result := Get(Index);
1044 end;
1045
1046 function TDKLang_CompTranslation.IndexOfID(iID: Integer): Integer;
1047 begin
1048 if not FindID(iID, Result) then Result := -1;
1049 end;
1050
1051 procedure TDKLang_CompTranslation.Notify(Ptr: Pointer; Action: TListNotification);
1052 begin
1053 // Don't call inherited Notify() here as it does nothing
1054 if Action=lnDeleted then Dispose(PDKLang_PropValueTranslation(Ptr));
1055 end;
1056
1057 //===================================================================================================================
1058 // TDKLang_CompTranslations
1059 //===================================================================================================================
1060
1061 function TDKLang_CompTranslations.Add(Item: TDKLang_CompTranslation): Integer;
1062 begin
1063 Result := inherited Add(Item);
1064 end;
1065
1066 procedure TDKLang_CompTranslations.Clear;
1067 begin
1068 inherited Clear;
1069 // Clear also parameters and constants
1070 if FParams<>nil then FParams.Clear;
1071 if FConstants<>nil then FConstants.Clear;
1072 end;
1073
1074 constructor TDKLang_CompTranslations.Create;
1075 begin
1076 inherited Create;
1077 FConstants := TDKLang_Constants.Create(GetLangIDCallback);
1078 FParams := TTntStringList.Create;
1079 end;
1080
1081 destructor TDKLang_CompTranslations.Destroy;
1082 begin
1083 FreeAndNil(FParams);
1084 FreeAndNil(FConstants);
1085 inherited Destroy;
1086 end;
1087
1088 function TDKLang_CompTranslations.FindComponentName(const sComponentName: String): TDKLang_CompTranslation;
1089 var idx: Integer;
1090 begin
1091 idx := IndexOfComponentName(sComponentName);
1092 if idx<0 then Result := nil else Result := GetItems(idx);
1093 end;
1094
1095 function TDKLang_CompTranslations.GetItems(Index: Integer): TDKLang_CompTranslation;
1096 begin
1097 Result := Get(Index);
1098 end;
1099
1100 function TDKLang_CompTranslations.GetLangIDCallback: LANGID;
1101 begin
1102 Result := StrToIntDef(Params.Values[SDKLang_TranParam_LangID], ILangID_USEnglish);
1103 end;
1104
1105 function TDKLang_CompTranslations.IndexOfComponentName(const sComponentName: String): Integer;
1106 begin
1107 for Result := 0 to Count-1 do
1108 if SameText(GetItems(Result).ComponentName, sComponentName) then Exit;
1109 Result := -1;
1110 end;
1111
1112 procedure TDKLang_CompTranslations.Notify(Ptr: Pointer; Action: TListNotification);
1113 begin
1114 // Don't call inherited Notify() here as it does nothing
1115 if Action=lnDeleted then TDKLang_CompTranslation(Ptr).Free;
1116 end;
1117
1118 procedure TDKLang_CompTranslations.Text_LoadFromFile(const wsFileName: WideString; bParamsOnly: Boolean);
1119 var Stream: TStream;
1120 begin
1121 Stream := TTntFileStream.Create(wsFileName, fmOpenRead or fmShareDenyWrite);
1122 try
1123 Text_LoadFromStream(Stream, bParamsOnly);
1124 finally
1125 Stream.Free;
1126 end;
1127 end;
1128
1129 procedure TDKLang_CompTranslations.Text_LoadFromResource(Instance: HINST; const wsResName: WideString; bParamsOnly: Boolean = False);
1130 var Stream: TStream;
1131 begin
1132 Stream := TTntResourceStream.Create(Instance, wsResName, PWideChar(RT_RCDATA));
1133 try
1134 Text_LoadFromStream(Stream, bParamsOnly);
1135 finally
1136 Stream.Free;
1137 end;
1138 end;
1139
1140 procedure TDKLang_CompTranslations.Text_LoadFromResource(Instance: HINST; iResID: Integer; bParamsOnly: Boolean = False);
1141 var Stream: TStream;
1142 begin
1143 Stream := TTntResourceStream.CreateFromID(Instance, iResID, PWideChar(RT_RCDATA));
1144 try
1145 Text_LoadFromStream(Stream, bParamsOnly);
1146 finally
1147 Stream.Free;
1148 end;
1149 end;
1150
1151 procedure TDKLang_CompTranslations.Text_LoadFromStream(Stream: TStream; bParamsOnly: Boolean = False);
1152 var SL: TTntStringList;
1153
1154 // Tries to split a line that is neither comment nor section into a name and a value and returns True if succeeded
1155 function ParseValueLine(const wsLine: WideString; out sName: String; out wsValue: WideString): Boolean;
1156 var iEqPos: Integer;
1157 begin
1158 Result := False;
1159 iEqPos := Pos('=', wsLine);
1160 if iEqPos=0 then Exit;
1161 sName := Trim(Copy(wsLine, 1, iEqPos-1)); // Convert name to ANSI
1162 wsValue := Trim(Copy(wsLine, iEqPos+1, MaxInt));
1163 if sName='' then Exit;
1164 Result := True;
1165 end;
1166
1167 // Extracts and returns the language ID parameter value from the string list, or ILangID_USEnglish if failed
1168 function RetrieveLangID(List: TTntStringList): LANGID;
1169 var
1170 i: Integer;
1171 sName: String;
1172 wsValue: WideString;
1173 begin
1174 Result := ILangID_USEnglish;
1175 for i := 0 to List.Count-1 do
1176 if ParseValueLine(List[i], sName, wsValue) and SameText(sName, SDKLang_TranParam_LangID) then begin
1177 Result := StrToIntDef(wsValue, ILangID_USEnglish);
1178 Break;
1179 end;
1180 end;
1181
1182 // Loads List from Stream, either ANSI or Unicode
1183 procedure LoadStreamIntoStringList(List: TTntStringList);
1184 var
1185 i64Pos: Int64;
1186 cCodePage: Cardinal;
1187 begin
1188 // Remember the original stream position
1189 i64Pos := Stream.Position;
1190 // Determine whether this is an Unicode source (BEFORE any reading is done)
1191 FIsStreamUnicode := AutoDetectCharacterSet(Stream)=csUnicode;
1192 Stream.Position := i64Pos;
1193 // Load the stream contents into the list
1194 List.LoadFromStream(Stream);
1195 // If this is an ANSI stream
1196 if not FIsStreamUnicode then begin
1197 // Get code page corresponding to the language from the loaded translations
1198 cCodePage := LCIDToCodePage(RetrieveLangID(List));
1199 // Reload the list using this correct code page
1200 Stream.Position := i64Pos;
1201 List.AnsiStrings.LoadFromStreamEx(Stream, cCodePage);
1202 end;
1203 end;
1204
1205 // Processes the string list, line by line
1206 procedure ProcessStringList(List: TTntStringList);
1207 type
1208 // A translation part (within the Stream)
1209 TTranslationPart = (
1210 tpParam, // A sectionless (parameter) part
1211 tpConstant, // A constant part
1212 tpComponent); // A component part
1213 var
1214 i: Integer;
1215 wsLine: WideString;
1216 CT: TDKLang_CompTranslation;
1217 Part: TTranslationPart;
1218
1219 // Parses strings starting with '[' and ending with ']'
1220 procedure ProcessSectionLine(const wsSectionName: WideString);
1221 begin
1222 // If it's a constant section
1223 if WideSameText(wsSectionName, SDKLang_ConstSectionName) then
1224 Part := tpConstant
1225 // Else assume this a component name
1226 else begin
1227 Part := tpComponent;
1228 // Try to find the component among previously loaded
1229 CT := FindComponentName(wsSectionName);
1230 // If not found, create new
1231 if CT=nil then begin
1232 CT := TDKLang_CompTranslation.Create(wsSectionName);
1233 Add(CT);
1234 end;
1235 end;
1236 end;
1237
1238 // Parses a value line and applies the value if succeeded
1239 procedure ProcessValueLine(const wsLine: WideString);
1240 var
1241 sName: String;
1242 wsValue: WideString;
1243 iID: Integer;
1244 begin
1245 // Try to split the line to name and value
1246 if ParseValueLine(wsLine, sName, wsValue) then
1247 // Apply the parsed values
1248 case Part of
1249 tpParam: FParams.Values[sName] := wsValue;
1250 tpConstant: FConstants.Add(sName, DecodeControlChars(wsValue), []);
1251 tpComponent:
1252 if CT<>nil then begin
1253 iID := StrToIntDef(sName, 0);
1254 if iID>0 then CT.Add(iID, DecodeControlChars(wsValue), []);
1255 end;
1256 end;
1257 end;
1258
1259 begin
1260 Part := tpParam; // Initially we're dealing with the sectionless part
1261 CT := nil;
1262 for i := 0 to List.Count-1 do begin
1263 try
1264 wsLine := Trim(List[i]);
1265 // Skip empty lines
1266 if wsLine<>'' then
1267 case wsLine[1] of
1268 // A comment
1269 ';': ;
1270 // A section
1271 '[': begin
1272 if bParamsOnly then Break;
1273 if (Length(wsLine)>2) and (wsLine[Length(wsLine)]=']') then ProcessSectionLine(Trim(Copy(wsLine, 2, Length(wsLine)-2)));
1274 end;
1275 // Probably an entry of form '<Name or ID>=<Value>'
1276 else ProcessValueLine(wsLine);
1277 end;
1278 except
1279 on e: Exception do DKLangError(SDKLangErrMsg_ErrorLoadingTran, [i, e.Message]);
1280 end;
1281 end;
1282 end;
1283
1284 begin
1285 // Clear all the lists
1286 Clear;
1287 // Load the stream contents into the string list
1288 SL := TTntStringList.Create;
1289 try
1290 LoadStreamIntoStringList(SL);
1291 // Parse the list line-by-line
1292 ProcessStringList(SL);
1293 finally
1294 SL.Free;
1295 end;
1296 end;
1297
1298 procedure TDKLang_CompTranslations.Text_SaveToFile(const wsFileName: WideString; bUnicode, bSkipUntranslated: Boolean);
1299 var
1300 Stream: TStream;
1301 begin
1302 Stream := TTntFileStream.Create(wsFileName, fmCreate);
1303 try
1304 Text_SaveToStream(Stream, bUnicode, bSkipUntranslated);
1305 finally
1306 Stream.Free;
1307 end;
1308 end;
1309
1310 procedure TDKLang_CompTranslations.Text_SaveToStream(Stream: TStream; bUnicode, bSkipUntranslated: Boolean);
1311 var cCodePage: Cardinal;
1312
1313 procedure DoWriteLine(const ws: WideString); overload;
1314 begin
1315 if bUnicode then StreamWriteLine(Stream, ws) else StreamWriteLine(Stream, WideStringToStringEx(ws, cCodePage));
1316 end;
1317
1318 procedure DoWriteLine(const ws: WideString; const aParams: Array of const); overload;
1319 begin
1320 DoWriteLine(WideFormat(ws, aParams));
1321 end;
1322
1323 procedure WriteParams;
1324 var i: Integer;
1325 begin
1326 for i := 0 to FParams.Count-1 do DoWriteLine(FParams[i]);
1327 // Insert an empty line
1328 if FParams.Count>0 then DoWriteLine('');
1329 end;
1330
1331 procedure WriteComponents;
1332 var
1333 iComp, iEntry: Integer;
1334 CT: TDKLang_CompTranslation;
1335 begin
1336 for iComp := 0 to Count-1 do begin
1337 CT := GetItems(iComp);
1338 // Write component's name
1339 DoWriteLine('[%s]', [CT.ComponentName]);
1340 // Write translated values in the form 'ID=Value'
1341 for iEntry := 0 to CT.Count-1 do
1342 with CT[iEntry]^ do
1343 if not bSkipUntranslated or not (dktsUntranslated in TranStates) then
1344 DoWriteLine('%.8d=%s', [iID, EncodeControlChars(wsValue)]);
1345 // Insert an empty line
1346 DoWriteLine('');
1347 end;
1348 end;
1349
1350 procedure WriteConstants;
1351 var i: Integer;
1352 begin
1353 // Write constant section name
1354 DoWriteLine('[%s]', [SDKLang_ConstSectionName]);
1355 // Write constant in the form 'Name=Value'
1356 for i := 0 to FConstants.Count-1 do
1357 with FConstants[i]^ do
1358 if not bSkipUntranslated or not (dktsUntranslated in TranStates) then
1359 DoWriteLine('%s=%s', [sName, EncodeControlChars(wsValue)]);
1360 end;
1361
1362 begin
1363 cCodePage := LCIDToCodePage(GetLangIDCallback);
1364 // If Unicode saving - mark the stream as Unicode
1365 if bUnicode then StreamWriteWord(Stream, Word(UNICODE_BOM));
1366 WriteParams;
1367 WriteComponents;
1368 WriteConstants;
1369 end;
1370
1371 //===================================================================================================================
1372 // TDKLang_PropEntries
1373 //===================================================================================================================
1374
1375 function TDKLang_PropEntries.Add(iID: Integer; const sPropName: String; const wsDefLangValue: WideString): Boolean;
1376 var
1377 p: PDKLang_PropEntry;
1378 idx: Integer;
1379 begin
1380 // Try to find the property by its name
1381 Result := not FindPropName(sPropName, idx);
1382 // If not found, create and insert a new entry
1383 if Result then begin
1384 New(p);
1385 Insert(idx, p);
1386 p.iID := iID;
1387 p.sPropName := sPropName;
1388 end else
1389 p := GetItems(idx);
1390 // Assign entry value
1391 p.wsDefLangValue := wsDefLangValue;
1392 // Validate the entry
1393 p.bValidated := True;
1394 end;
1395
1396 procedure TDKLang_PropEntries.DeleteInvalidEntries;
1397 var i: Integer;
1398 begin
1399 for i := Count-1 downto 0 do
1400 if not GetItems(i).bValidated then Delete(i);
1401 end;
1402
1403 function TDKLang_PropEntries.FindPropByName(const sPropName: String): PDKLang_PropEntry;
1404 var idx: Integer;
1405 begin
1406 if FindPropName(sPropName, idx) then Result := GetItems(idx) else Result := nil;
1407 end;
1408
1409 function TDKLang_PropEntries.FindPropName(const sPropName: String; out iIndex: Integer): Boolean;
1410 var iL, iR, i: Integer;
1411 begin
1412 // Since the list is sorted by property name, implement binary search here
1413 Result := False;
1414 iL := 0;
1415 iR := Count-1;
1416 while iL<=iR do begin
1417 i := (iL+iR) shr 1;
1418 // Don't use AnsiCompareText() here as property names are allowed to consist of alphanumeric chars and '_' only
1419 case CompareText(GetItems(i).sPropName, sPropName) of
1420 Low(Integer)..-1: iL := i+1;
1421 0: begin
1422 Result := True;
1423 iL := i;
1424 Break;
1425 end;
1426 else iR := i-1;
1427 end;
1428 end;
1429 iIndex := iL;
1430 end;
1431
1432 function TDKLang_PropEntries.GetItems(Index: Integer): PDKLang_PropEntry;
1433 begin
1434 Result := Get(Index);
1435 end;
1436
1437 function TDKLang_PropEntries.GetMaxID: Integer;
1438 var i: Integer;
1439 begin
1440 Result := 0;
1441 for i := 0 to Count-1 do Result := Max(Result, GetItems(i).iID);
1442 end;
1443
1444 function TDKLang_PropEntries.IndexOfID(iID: Integer): Integer;
1445 begin
1446 for Result := 0 to Count-1 do
1447 if GetItems(Result).iID=iID then Exit;
1448 Result := -1;
1449 end;
1450
1451 function TDKLang_PropEntries.IndexOfPropName(const sPropName: String): Integer;
1452 begin
1453 if not FindPropName(sPropName, Result) then Result := -1;
1454 end;
1455
1456 procedure TDKLang_PropEntries.Invalidate;
1457 var i: Integer;
1458 begin
1459 for i := 0 to Count-1 do GetItems(i).bValidated := False;
1460 end;
1461
1462 procedure TDKLang_PropEntries.LoadFromDFMResource(Stream: TStream);
1463 var
1464 i, iID: Integer;
1465 sName: String;
1466 begin
1467 Clear;
1468 for i := 0 to StreamReadInt(Stream)-1 do begin
1469 iID := StreamReadInt(Stream);
1470 sName := StreamReadStr(Stream);
1471 Add(iID, sName, '');
1472 end;
1473 end;
1474
1475 procedure TDKLang_PropEntries.Notify(Ptr: Pointer; Action: TListNotification);
1476 begin
1477 // Don't call inherited Notify() here as it does nothing
1478 if Action=lnDeleted then Dispose(PDKLang_PropEntry(Ptr));
1479 end;
1480
1481 procedure TDKLang_PropEntries.SaveToDFMResource(Stream: TStream);
1482 var
1483 i: Integer;
1484 p: PDKLang_PropEntry;
1485 begin
1486 StreamWriteInt(Stream, Count);
1487 for i := 0 to Count-1 do begin
1488 p := GetItems(i);
1489 StreamWriteInt(Stream, p.iID);
1490 StreamWriteStr(Stream, p.sPropName);
1491 end;
1492 end;
1493
1494 //===================================================================================================================
1495 // TDKLang_CompEntry
1496 //===================================================================================================================
1497
1498 procedure TDKLang_CompEntry.ApplyTranslation(Translation: TDKLang_CompTranslation; cCodePage: Cardinal);
1499
1500 // Applies translations to component's properties
1501 procedure TranslateProps;
1502
1503 // Returns translation of a property value in wsTranslation and True if it is present in PropEntries
1504 function GetTranslationUnicode(const sPropName: String; out wsTranslation: WideString): Boolean;
1505 var
1506 PE: PDKLang_PropEntry;
1507 idxTran: Integer;
1508 begin
1509 // Try to locate prop translation entry
1510 PE := FPropEntries.FindPropByName(sPropName);
1511 Result := PE<>nil;
1512 if Result then begin
1513 wsTranslation := PE.wsDefLangValue;
1514 // If actual translation is supplied
1515 if Translation<>nil then begin
1516 // Try to find the appropriate translation by property entry ID
1517 idxTran := Translation.IndexOfID(PE.iID);
1518 if idxTran>=0 then wsTranslation := Translation[idxTran].wsValue;
1519 end;
1520 end else
1521 wsTranslation := '';
1522 end;
1523
1524 // The same but return translation in ANSI encoding
1525 function GetTranslationAnsi(const sPropName: String; out sTranslation: String): Boolean;
1526 var ws: WideString;
1527 begin
1528 Result := GetTranslationUnicode(sPropName, ws);
1529 sTranslation := WideStringToStringEx(ws, cCodePage);
1530 end;
1531
1532 procedure ProcessObject(const sPrefix: String; Instance: TObject); forward;
1533
1534 // Processes the specified property and adds it to PropEntries if it appears suitable
1535 procedure ProcessProp(const sPrefix: String; Instance: TObject; pInfo: PPropInfo);
1536 const asSep: Array[Boolean] of String[1] = ('', '.');
1537 var
1538 i: Integer;
1539 o: TObject;
1540 sFullName, sTranslation: String;
1541 wsTranslation: WideString;
1542 begin
1543 // Test whether property is to be ignored (don't use IgnoreTest interface here)
1544 if ((Instance is TComponent) and (pInfo.Name='Name')) or not (pInfo.PropType^.Kind in [tkClass, tkString, tkLString, tkWString]) then Exit;
1545 sFullName := sPrefix+asSep[sPrefix<>'']+pInfo.Name;
1546 // Assign the new [translated] value to the property
1547 case pInfo.PropType^.Kind of
1548 tkClass:
1549 if Assigned(pInfo.GetProc) and Assigned(pInfo.SetProc) then begin
1550 o := GetObjectProp(Instance, pInfo);
1551 if o<>nil then
1552 // TWideStrings property
1553 if o is TWideStrings then begin
1554 if GetTranslationUnicode(sFullName, wsTranslation) then TWideStrings(o).Text := wsTranslation;
1555 // TStrings property
1556 end else if o is TStrings then begin
1557 if GetTranslationAnsi(sFullName, sTranslation) then TStrings(o).Text := sTranslation;
1558 // TCollection property
1559 end else if o is TCollection then
1560 for i := 0 to TCollection(o).Count-1 do ProcessObject(sFullName+Format('[%d]', [i]), TCollection(o).Items[i])
1561 // TPersistent property. Avoid processing TComponent references which may lead to a circular loop
1562 else if (o is TPersistent) and not (o is TComponent) then
1563 ProcessObject(sFullName, o);
1564 end;
1565 tkString,
1566 tkLString: if GetTranslationAnsi(sFullName, sTranslation) then SetStrProp(Instance, pInfo, sTranslation);
1567 tkWString: if GetTranslationUnicode(sFullName, wsTranslation) then SetWideStrProp(Instance, pInfo, wsTranslation);
1568 end;
1569 end;
1570
1571 // Iterates through Instance's properties and add them to PropEntries. sPrefix is the object name prefix part
1572 procedure ProcessObject(const sPrefix: String; Instance: TObject);
1573 var
1574 i, iPropCnt: Integer;
1575 pList: PPropList;
1576 begin
1577 // Get property list
1578 iPropCnt := GetPropList(Instance, pList);
1579 // Iterate thru Instance's properties
1580 if iPropCnt>0 then
1581 try
1582 for i := 0 to iPropCnt-1 do ProcessProp(sPrefix, Instance, pList^[i]);
1583 finally
1584 FreeMem(pList);
1585 end;
1586 end;
1587
1588 begin
1589 if FPropEntries<>nil then ProcessObject('', FComponent);
1590 end;
1591
1592 // Recursively applies translations to owned components
1593 procedure TranslateComponents;
1594 var i: Integer;
1595 begin
1596 if FOwnedCompEntries<>nil then
1597 for i := 0 to FOwnedCompEntries.Count-1 do FOwnedCompEntries[i].ApplyTranslation(Translation, cCodePage);
1598 end;
1599
1600 begin
1601 // Translate properties
1602 TranslateProps;
1603 // Translate owned components
1604 TranslateComponents;
1605 end;
1606
1607 procedure TDKLang_CompEntry.BindComponents(CurComponent: TComponent);
1608 var
1609 i: Integer;
1610 CE: TDKLang_CompEntry;
1611 c: TComponent;
1612 begin
1613 FComponent := CurComponent;
1614 if FComponent<>nil then begin
1615 FName := ''; // Free the memory after the link is established
1616 // Cycle thru component entries
1617 if FOwnedCompEntries<>nil then begin
1618 for i := FOwnedCompEntries.Count-1 downto 0 do begin
1619 CE := FOwnedCompEntries[i];
1620 if CE.FName<>'' then begin
1621 // Try to find the component
1622 c := CurComponent.FindComponent(CE.FName);
1623 // If not found, delete entry. Recursively call BindComponents() otherwise
1624 if c=nil then FOwnedCompEntries.Delete(i) else CE.BindComponents(c);
1625 end;
1626 end;
1627 // Destroy the list once it is empty
1628 if FOwnedCompEntries.Count=0 then FreeAndNil(FOwnedCompEntries);
1629 end;
1630 end;
1631 end;
1632
1633 constructor TDKLang_CompEntry.Create(AOwner: TDKLang_CompEntry);
1634 begin
1635 inherited Create;
1636 FOwner := AOwner;
1637 end;
1638
1639 destructor TDKLang_CompEntry.Destroy;
1640 begin
1641 FPropEntries.Free;
1642 FOwnedCompEntries.Free;
1643 inherited Destroy;
1644 end;
1645
1646 function TDKLang_CompEntry.GetComponentNamePath(bIncludeRoot: Boolean): String;
1647 begin
1648 if FOwner=nil then
1649 if bIncludeRoot then Result := Name else Result := ''
1650 else begin
1651 Result := FOwner.ComponentNamePath[bIncludeRoot];
1652 if Result<>'' then Result := Result+'.';
1653 Result := Result+Name;
1654 end;
1655 end;
1656
1657 function TDKLang_CompEntry.GetMaxPropEntryID: Integer;
1658 var i: Integer;
1659 begin
1660 if FPropEntries=nil then Result := 0 else Result := FPropEntries.GetMaxID;
1661 if FOwnedCompEntries<>nil then
1662 for i := 0 to FOwnedCompEntries.Count-1 do Result := Max(Result, FOwnedCompEntries[i].GetMaxPropEntryID);
1663 end;
1664
1665 function TDKLang_CompEntry.GetName: String;
1666 begin
1667 if FComponent=nil then Result := FName else Result := FComponent.Name;
1668 end;
1669
1670 procedure TDKLang_CompEntry.InternalUpdateEntries(var iFreePropEntryID: Integer; bModifyList, bIgnoreEmptyProps, bIgnoreNonAlphaProps, bIgnoreFontProps: Boolean; IgnoreMasks, StoreMasks: TDKLang_MaskList);
1671 var sCompPathPrefix: String;
1672
1673 // Returns True if a property is to be stored according either to its streaming store-flag or to its matching to
1674 // StoreMasks
1675 function IsPropStored(Instance: TObject; pInfo: PPropInfo; const sPropFullName: String): Boolean;
1676 begin
1677 Result := IsStoredProp(Instance, pInfo) or StoreMasks.Matches(sPropFullName);
1678 end;
1679
1680 // Returns True if a property value is allowed to be stored
1681 function IsPropValueStored(const sFullPropName: String; const wsPropVal: WideString): Boolean;
1682 var i: Integer;
1683 begin
1684 // Check whether the property value contains localizable characters
1685 if bIgnoreNonAlphaProps then begin
1686 Result := False;
1687 for i := 1 to Length(wsPropVal) do
1688 case wsPropVal[i] of
1689 'A'..'Z', 'a'..'z', #161..High(WideChar): begin
1690 Result := True;
1691 Break;
1692 end;
1693 end;
1694 // Check for emptiness (no need if bIgnoreNonAlphaProps was True)
1695 end else if bIgnoreEmptyProps then
1696 Result := wsPropVal<>''
1697 else
1698 Result := True;
1699 end;
1700
1701 // Updates the PropEntry value (creates one if needed)
1702 procedure UpdatePropValue(const sFullPropName: String; const wsPropVal: WideString);
1703 var p: PDKLang_PropEntry;
1704 begin
1705 if IsPropValueStored(sFullPropName, wsPropVal) then
1706 // If modifications are allowed
1707 if bModifyList then begin
1708 // Create PropEntries if needed
1709 if FPropEntries=nil then FPropEntries := TDKLang_PropEntries.Create;
1710 // If property is added (rather than replaced), increment the iFreePropEntryID counter; validate the entry
1711 if FPropEntries.Add(iFreePropEntryID, sFullPropName, wsPropVal) then Inc(iFreePropEntryID);
1712 // Otherwise only update the value, if any
1713 end else if FPropEntries<>nil then begin
1714 p := FPropEntries.FindPropByName(sFullPropName);
1715 if p<>nil then p.wsDefLangValue := wsPropVal;
1716 end;
1717 end;
1718
1719 // Updates property entries
1720 procedure UpdateProps;
1721
1722 procedure ProcessObject(const sPrefix: String; Instance: TObject); forward;
1723
1724 // Processes the specified property and adds it to PropEntries if it appears suitable
1725 procedure ProcessProp(const sPrefix: String; Instance: TObject; pInfo: PPropInfo);
1726 const asSep: Array[Boolean] of String[1] = ('', '.');
1727 var
1728 i: Integer;
1729 o: TObject;
1730 sPropInCompName, sPropFullName: String;
1731 begin
1732 sPropInCompName := sPrefix+asSep[sPrefix<>'']+pInfo.Name;
1733 sPropFullName := sCompPathPrefix+sPropInCompName;
1734 // Test whether property is to be ignored
1735 if ((Instance is TComponent) and (pInfo.Name='Name')) or
1736 not (pInfo.PropType^.Kind in [tkClass, tkString, tkLString, tkWString]) or
1737 IgnoreMasks.Matches(sPropFullName) then Exit;
1738 // Obtain and store property value
1739 case pInfo.PropType^.Kind of
1740 tkClass:
1741 if Assigned(pInfo.GetProc) and Assigned(pInfo.SetProc) and IsPropStored(Instance, pInfo, sPropFullName) then begin
1742 o := GetObjectProp(Instance, pInfo);
1743 if o<>nil then
1744 // TWideStrings property
1745 if o is TWideStrings then
1746 UpdatePropValue(sPropInCompName, TWideStrings(o).Text)
1747 // TStrings property
1748 else if o is TStrings then
1749 UpdatePropValue(sPropInCompName, TStrings(o).Text)
1750 // TCollection property
1751 else if o is TCollection then
1752 for i := 0 to TCollection(o).Count-1 do ProcessObject(sPropInCompName+Format('[%d]', [i]), TCollection(o).Items[i])
1753 // TPersistent property. Avoid processing TComponent references which may lead to a circular loop. Also
1754 // filter TFont property values if needed (use name comparison instead of inheritance operator to
1755 // eliminate dependency on Graphics unit)
1756 else if (o is TPersistent) and not (o is TComponent) and (not bIgnoreFontProps or (o.ClassName<>'TFont')) then
1757 ProcessObject(sPropInCompName, o);
1758 end;
1759 tkString,
1760 tkLString: if IsPropStored(Instance, pInfo, sPropFullName) then UpdatePropValue(sPropInCompName, GetStrProp(Instance, pInfo));
1761 tkWString: if IsPropStored(Instance, pInfo, sPropFullName) then UpdatePropValue(sPropInCompName, GetWideStrProp(Instance, pInfo));
1762 end;
1763 end;
1764
1765 // Iterates through Instance's properties and add them to PropEntries. sPrefix is the object name prefix part
1766 procedure ProcessObject(const sPrefix: String; Instance: TObject);
1767 var
1768 i, iPropCnt: Integer;
1769 pList: PPropList;
1770 begin
1771 // Get property list
1772 iPropCnt := GetPropList(Instance, pList);
1773 // Iterate thru Instance's properties
1774 if iPropCnt>0 then
1775 try
1776 for i := 0 to iPropCnt-1 do ProcessProp(sPrefix, Instance, pList^[i]);
1777 finally
1778 FreeMem(pList);
1779 end;
1780 end;
1781
1782 begin
1783 ProcessObject('', FComponent);
1784 // Erase all properties not validated yet
1785 if bModifyList and (FPropEntries<>nil) then begin
1786 FPropEntries.DeleteInvalidEntries;
1787 // If property list is empty, erase it
1788 if FPropEntries.Count=0 then FreeAndNil(FPropEntries);
1789 end;
1790 end;
1791
1792 // Synchronizes component list and updates each component's property entries
1793 procedure UpdateComponents;
1794 var
1795 i: Integer;
1796 c: TComponent;
1797 CE: TDKLang_CompEntry;
1798 begin
1799 for i := 0 to FComponent.ComponentCount-1 do begin
1800 c := FComponent.Components[i];
1801 if (c.Name<>'') and not (c is TDKLanguageController) then begin
1802 // Try to find the corresponding component entry
1803 if FOwnedCompEntries=nil then begin
1804 if bModifyList then FOwnedCompEntries := TDKLang_CompEntries.Create(Self);
1805 CE := nil;
1806 end else
1807 CE := FOwnedCompEntries.FindComponent(c);
1808 // If not found, and modifications are allowed, create the new entry
1809 if (CE=nil) and bModifyList then begin
1810 CE := TDKLang_CompEntry.Create(Self);
1811 CE.FComponent := c;
1812 FOwnedCompEntries.Add(CE);
1813 end;
1814 // Update the component's property entries
1815 if CE<>nil then CE.InternalUpdateEntries(iFreePropEntryID, bModifyList, bIgnoreEmptyProps, bIgnoreNonAlphaProps, bIgnoreFontProps, IgnoreMasks, StoreMasks);
1816 end;
1817 end;
1818 end;
1819
1820 begin
1821 sCompPathPrefix := ComponentNamePath[False]+'.'; // Root prop names will start with '.'
1822 // Update property entries
1823 UpdateProps;
1824 // Update component entries
1825 UpdateComponents;
1826 end;
1827
1828 procedure TDKLang_CompEntry.InvalidateProps;
1829 var i: Integer;
1830 begin
1831 if FPropEntries<>nil then FPropEntries.Invalidate;
1832 if FOwnedCompEntries<>nil then
1833 for i := 0 to FOwnedCompEntries.Count-1 do FOwnedCompEntries[i].InvalidateProps;
1834 end;
1835
1836 procedure TDKLang_CompEntry.LoadFromDFMResource(Stream: TStream);
1837 begin
1838 // Read component name
1839 FName := StreamReadStr(Stream);
1840 // Load props, if any
1841 if StreamReadBool(Stream) then begin
1842 if FPropEntries=nil then FPropEntries := TDKLang_PropEntries.Create;
1843 FPropEntries.LoadFromDFMResource(Stream);
1844 end;
1845 // Load owned components, if any (read component existence flag)
1846 if StreamReadBool(Stream) then begin
1847 if FOwnedCompEntries=nil then FOwnedCompEntries := TDKLang_CompEntries.Create(Self);
1848 FOwnedCompEntries.LoadFromDFMResource(Stream);
1849 end;
1850 end;
1851
1852 procedure TDKLang_CompEntry.RemoveComponent(AComponent: TComponent; bRecursive: Boolean);
1853 var i, idx: Integer;
1854 begin
1855 if FOwnedCompEntries<>nil then begin
1856 // Try to find the component by reference
1857 idx := FOwnedCompEntries.IndexOfComponent(AComponent);
1858 // If found, delete it
1859 if idx>=0 then begin
1860 FOwnedCompEntries.Delete(idx);
1861 // Destroy the list once it is empty
1862 if FOwnedCompEntries.Count=0 then FreeAndNil(FOwnedCompEntries);
1863 end;
1864 // The same for owned entries
1865 if bRecursive and (FOwnedCompEntries<>nil) then
1866 for i := 0 to FOwnedCompEntries.Count-1 do FOwnedCompEntries[i].RemoveComponent(AComponent, True);
1867 end;
1868 end;
1869
1870 procedure TDKLang_CompEntry.SaveToDFMResource(Stream: TStream);
1871 begin
1872 // Save component name
1873 StreamWriteStr(Stream, Name);
1874 // Store component properties
1875 StreamWriteBool(Stream, FPropEntries<>nil);
1876 if FPropEntries<>nil then FPropEntries.SaveToDFMResource(Stream);
1877 // Store owned components
1878 StreamWriteBool(Stream, FOwnedCompEntries<>nil);
1879 if FOwnedCompEntries<>nil then FOwnedCompEntries.SaveToDFMResource(Stream);
1880 end;
1881
1882 procedure TDKLang_CompEntry.StoreLangSource(Strings: TWideStrings);
1883 var
1884 i: Integer;
1885 PE: PDKLang_PropEntry;
1886 sCompPath: String;
1887 begin
1888 // Store the properties
1889 if FPropEntries<>nil then begin
1890 // Find the component path, if any
1891 sCompPath := ComponentNamePath[False];
1892 if sCompPath<>'' then sCompPath := sCompPath+'.';
1893 // Iterate through the property entries
1894 for i := 0 to FPropEntries.Count-1 do begin
1895 PE := FPropEntries[i];
1896 Strings.Add(WideFormat('%s%s=%.8d,%s', [sCompPath, PE.sPropName, PE.iID, EncodeControlChars(PE.wsDefLangValue)]));
1897 end;
1898 end;
1899 // Recursively call the method for owned entries
1900 if FOwnedCompEntries<>nil then
1901 for i := 0 to FOwnedCompEntries.Count-1 do FOwnedCompEntries[i].StoreLangSource(Strings);
1902 end;
1903
1904 procedure TDKLang_CompEntry.UpdateEntries(bModifyList, bIgnoreEmptyProps, bIgnoreNonAlphaProps, bIgnoreFontProps: Boolean; IgnoreMasks, StoreMasks: TDKLang_MaskList);
1905 var iFreePropEntryID: Integer;
1906 begin
1907 // If modifications allowed
1908 if bModifyList then begin
1909 // Invalidate all property entries
1910 InvalidateProps;
1911 // Compute next free property entry ID
1912 iFreePropEntryID := GetMaxPropEntryID+1;
1913 end else
1914 iFreePropEntryID := 0;
1915 // Call recursive update routine
1916 InternalUpdateEntries(iFreePropEntryID, bModifyList, bIgnoreEmptyProps, bIgnoreNonAlphaProps, bIgnoreFontProps, IgnoreMasks, StoreMasks);
1917 end;
1918
1919 //===================================================================================================================
1920 // TDKLang_CompEntries
1921 //===================================================================================================================
1922
1923 function TDKLang_CompEntries.Add(Item: TDKLang_CompEntry): Integer;
1924 begin
1925 Result := inherited Add(Item);
1926 end;
1927
1928 constructor TDKLang_CompEntries.Create(AOwner: TDKLang_CompEntry);
1929 begin
1930 inherited Create;
1931 FOwner := AOwner;
1932 end;
1933
1934 function TDKLang_CompEntries.FindComponent(CompReference: TComponent): TDKLang_CompEntry;
1935 var idx: Integer;
1936 begin
1937 idx := IndexOfComponent(CompReference);
1938 if idx<0 then Result := nil else Result := GetItems(idx);
1939 end;
1940
1941 function TDKLang_CompEntries.GetItems(Index: Integer): TDKLang_CompEntry;
1942 begin
1943 Result := Get(Index);
1944 end;
1945
1946 function TDKLang_CompEntries.IndexOfCompName(const sCompName: String): Integer;
1947 begin
1948 for Result := 0 to Count-1 do
1949 // Don't use AnsiSameText() here as component names are allowed to consist of alphanumeric chars and '_' only
1950 if SameText(GetItems(Result).Name, sCompName) then Exit;
1951 Result := -1;
1952 end;
1953
1954 function TDKLang_CompEntries.IndexOfComponent(CompReference: TComponent): Integer;
1955 begin
1956 for Result := 0 to Count-1 do
1957 if GetItems(Result).Component=CompReference then Exit;
1958 Result := -1;
1959 end;
1960
1961 procedure TDKLang_CompEntries.LoadFromDFMResource(Stream: TStream);
1962 var
1963 i: Integer;
1964 CE: TDKLang_CompEntry;
1965 begin
1966 Clear;
1967 for i := 0 to StreamReadInt(Stream)-1 do begin
1968 CE := TDKLang_CompEntry.Create(FOwner);
1969 Add(CE);
1970 CE.LoadFromDFMResource(Stream);
1971 end;
1972 end;
1973
1974 procedure TDKLang_CompEntries.Notify(Ptr: Pointer; Action: TListNotification);
1975 begin
1976 // Don't call inherited Notify() here as it does nothing
1977 if Action=lnDeleted then TDKLang_CompEntry(Ptr).Free;
1978 end;
1979
1980 procedure TDKLang_CompEntries.SaveToDFMResource(Stream: TStream);
1981 var i: Integer;
1982 begin
1983 StreamWriteInt(Stream, Count);
1984 for i := 0 to Count-1 do GetItems(i).SaveToDFMResource(Stream);
1985 end;
1986
1987 //===================================================================================================================
1988 // TDKLang_Constants
1989 //===================================================================================================================
1990
1991 function TDKLang_Constants.Add(const sName: String; const wsValue: WideString; TranStates: TDKLang_TranslationStates): Integer;
1992 var p: PDKLang_Constant;
1993 begin
1994 if not IsValidIdent(sName) then DKLangError(SDKLangErrMsg_InvalidConstName, [sName]);
1995 // Find insertion point and check name uniqueness
1996 if FindName(sName, Result) then DKLangError(SDKLangErrMsg_DuplicateConstName, [sName]);
1997 // Create and insert a new entry
1998 New(p);
1999 Insert(Result, p);
2000 // Initialize entry
2001 p.sName := sName;
2002 p.wsValue := wsValue;
2003 p.wsDefValue := wsValue;
2004 p.TranStates := TranStates;
2005 end;
2006
2007 constructor TDKLang_Constants.Create(AGetLangIDCallback: TDKLang_GetLangIDCallback);
2008 begin
2009 inherited Create;
2010 FAutoSaveLangSource := True;
2011 FGetLangIDCallback := AGetLangIDCallback;
2012 end;
2013
2014 function TDKLang_Constants.FindConstName(const sName: String): PDKLang_Constant;
2015 var idx: Integer;
2016 begin
2017 if FindName(sName, idx) then Result := GetItems(idx) else Result := nil;
2018 end;
2019
2020 function TDKLang_Constants.FindName(const sName: String; out iIndex: Integer): Boolean;
2021 var iL, iR, i: Integer;
2022 begin
2023 // Since the list is sorted by constant name, implement binary search here
2024 Result := False;
2025 iL := 0;
2026 iR := Count-1;
2027 while iL<=iR do begin
2028 i := (iL+iR) shr 1;
2029 // Don't use AnsiCompareText()/WideCompareText() here as constant names are allowed to consist of alphanumeric
2030 // chars and '_' only
2031 case CompareText(GetItems(i).sName, sName) of
2032 Low(Integer)..-1: iL := i+1;
2033 0: begin
2034 Result := True;
2035 iL := i;
2036 Break;
2037 end;
2038 else iR := i-1;
2039 end;
2040 end;
2041 iIndex := iL;
2042 end;
2043
2044 function TDKLang_Constants.GetAsRawString: String;
2045 var Stream: TStringStream;
2046 begin
2047 Stream := TStringStream.Create('');
2048 try
2049 SaveToStream(Stream);
2050 Result := Stream.DataString;
2051 finally
2052 Stream.Free;
2053 end;
2054 end;
2055
2056 function TDKLang_Constants.GetItems(Index: Integer): PDKLang_Constant;
2057 begin
2058 Result := Get(Index);
2059 end;
2060
2061 function TDKLang_Constants.GetItemsByName(const sName: String): PDKLang_Constant;
2062 var idx: Integer;
2063 begin
2064 if not FindName(sName, idx) then DKLangError(SDKLangErrMsg_ConstantNotFound, [sName]);
2065 Result := GetItems(idx);
2066 end;
2067
2068 function TDKLang_Constants.GetValues(const sName: String): WideString;
2069 begin
2070 Result := ItemsByName[sName].wsValue;
2071 end;
2072
2073 function TDKLang_Constants.IndexOfName(const sName: String): Integer;
2074 begin
2075 if not FindName(sName, Result) then Result := -1;
2076 end;
2077
2078 function TDKLang_Constants.LoadFromResource(Instance: HINST; const wsResName: WideString): Boolean;
2079 var Stream: TStream;
2080 begin
2081 // Check resource existence
2082 Result := FindResourceW(Instance, PWideChar(wsResName), PWideChar(RT_RCDATA))<>0;
2083 // If succeeded, load the list from resource
2084 if Result then begin
2085 Stream := TTntResourceStream.Create(Instance, wsResName, PWideChar(RT_RCDATA));
2086 try
2087 LoadFromStream(Stream);
2088 finally
2089 Stream.Free;
2090 end;
2091 end;
2092 end;
2093
2094 procedure TDKLang_Constants.LoadFromStream(Stream: TStream);
2095 var b: Byte;
2096
2097 // Implements loading from stream of version 1
2098 procedure Load_v1(bAutoSaveLangSource: Boolean);
2099 var
2100 i: Integer;
2101 sName: String;
2102 wsValue: WideString;
2103 cCodePage: Cardinal;
2104 begin
2105 cCodePage := LCIDToCodePage(FGetLangIDCallback);
2106 // AutoSaveLangSource is already read (while determining stream version)
2107 FAutoSaveLangSource := bAutoSaveLangSource;
2108 // Read item count, then read the constant names and values
2109 for i := 0 to StreamReadInt(Stream)-1 do begin
2110 sName := StreamReadStr(Stream);
2111 wsValue := StringToWideStringEx(StreamReadStr(Stream), cCodePage);
2112 Add(sName, wsValue, []);
2113 end;
2114 end;
2115
2116 // Implements loading from stream of version 2
2117 procedure Load_v2;
2118 var
2119 i: Integer;
2120 sName: String;
2121 wsValue: WideString;
2122 begin
2123 // Read props
2124 FAutoSaveLangSource := StreamReadBool(Stream);
2125 // Read item count, then read the constant names and values
2126 for i := 0 to StreamReadInt(Stream)-1 do begin
2127 sName := StreamReadStr (Stream);
2128 wsValue := StreamReadWideStr(Stream);
2129 Add(sName, wsValue, []);
2130 end;
2131 end;
2132
2133 begin
2134 // Clear the list
2135 Clear;
2136 // Read the first byte of the stream
2137 b := StreamReadByte(Stream);
2138 case b of
2139 // If it is 0 or 1, we're dealing with the very first version of the stream, and b is just boolean
2140 // AutoSaveLangSource flag
2141 0, 1: Load_v1(b<>0);
2142 2: Load_v2;
2143 else DKLangError(SDKLangErrMsg_StreamVersionTooHigh, [b, IDKLang_StreamVersion]);
2144 end;
2145 end;
2146
2147 function TDKLang_Constants.LSO_CanStore: Boolean;
2148 begin
2149 Result := True;
2150 end;
2151
2152 function TDKLang_Constants.LSO_GetSectionName: WideString;
2153 begin
2154 // Constants always use the predefined section name
2155 Result := SDKLang_ConstSectionName;
2156 end;
2157
2158 procedure TDKLang_Constants.LSO_StoreLangSource(Strings: TWideStrings; StateFilter: TDKLang_TranslationStates);
2159 var i: Integer;
2160 begin
2161 for i := 0 to Count-1 do
2162 with GetItems(i)^ do
2163 if TranStates*StateFilter=[] then Strings.Add(sName+'='+EncodeControlChars(wsValue));
2164 end;
2165
2166 procedure TDKLang_Constants.Notify(Ptr: Pointer; Action: TListNotification);
2167 begin
2168 // Don't call inherited Notify() here as it does nothing
2169 if Action=lnDeleted then Dispose(PDKLang_Constant(Ptr));
2170 end;
2171
2172 function TDKLang_Constants.QueryInterface(const IID: TGUID; out Obj): HResult;
2173 begin
2174 if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
2175 end;
2176
2177 procedure TDKLang_Constants.SaveToStream(Stream: TStream);
2178 var
2179 i: Integer;
2180 p: PDKLang_Constant;
2181 begin
2182 // Write the stream version
2183 StreamWriteStreamVersion(Stream);
2184 // Store props
2185 StreamWriteBool(Stream, FAutoSaveLangSource);
2186 // Store count
2187 StreamWriteInt(Stream, Count);
2188 // Store the constants
2189 for i := 0 to Count-1 do begin
2190 p := GetItems(i);
2191 StreamWriteStr (Stream, p.sName);
2192 StreamWriteWideStr(Stream, p.wsValue);
2193 end;
2194 end;
2195
2196 procedure TDKLang_Constants.SetAsRawString(const Value: String);
2197 var Stream: TStringStream;
2198 begin
2199 Stream := TStringStream.Create(Value);
2200 try
2201 LoadFromStream(Stream);
2202 finally
2203 Stream.Free;
2204 end;
2205 end;
2206
2207 procedure TDKLang_Constants.SetValues(const sName: String; const wsValue: WideString);
2208 begin
2209 ItemsByName[sName].wsValue := wsValue;
2210 end;
2211
2212 procedure TDKLang_Constants.TranslateFrom(Constants: TDKLang_Constants);
2213 var
2214 i, idx: Integer;
2215 pc: PDKLang_Constant;
2216 begin
2217 for i := 0 to Count-1 do begin
2218 pc := GetItems(i);
2219 // If Constants=nil this means reverting to defaults
2220 if Constants=nil then pc.wsValue := pc.wsDefValue
2221 // Else try to find the constant in Constants. Update the value if found
2222 else if Constants.FindName(pc.sName, idx) then pc.wsValue := Constants[idx].wsValue;
2223 end;
2224 end;
2225
2226 function TDKLang_Constants._AddRef: Integer;
2227 begin
2228 // No refcounting applicable
2229 Result := -1;
2230 end;
2231
2232 function TDKLang_Constants._Release: Integer;
2233 begin
2234 // No refcounting applicable
2235 Result := -1;
2236 end;
2237
2238 //===================================================================================================================
2239 // TDKLanguageController
2240 //===================================================================================================================
2241
2242 constructor TDKLanguageController.Create(AOwner: TComponent);
2243 begin
2244 inherited Create(AOwner);
2245 // Initialize IgnoreList
2246 FIgnoreList := TStringList.Create;
2247 TStringList(FIgnoreList).Duplicates := dupIgnore;
2248 TStringList(FIgnoreList).Sorted := True;
2249 // Initialize StoreList
2250 FStoreList := TStringList.Create;
2251 TStringList(FStoreList).Duplicates := dupIgnore;
2252 TStringList(FStoreList).Sorted := True;
2253 // Initialize other props
2254 FRootCompEntry := TDKLang_CompEntry.Create(nil);
2255 FOptions := DKLang_DefaultControllerOptions;
2256 if not (csLoading in ComponentState) then FRootCompEntry.BindComponents(Owner);
2257 if not (csDesigning in ComponentState) then LangManager.AddLangController(Self);
2258 end;
2259
2260 procedure TDKLanguageController.DefineProperties(Filer: TFiler);
2261
2262 function DoStore: Boolean;
2263 begin
2264 Result := (FRootCompEntry.Component<>nil) and (FRootCompEntry.Component.Name<>'');
2265 end;
2266
2267 begin
2268 inherited DefineProperties(Filer);
2269 Filer.DefineBinaryProperty('LangData', LangData_Load, LangData_Store, DoStore);
2270 end;
2271
2272 destructor TDKLanguageController.Destroy;
2273 begin
2274 if not (csDesigning in ComponentState) then LangManager.RemoveLangController(Self);
2275 FRootCompEntry.Free;
2276 FIgnoreList.Free;
2277 FStoreList.Free;
2278 inherited Destroy;
2279 end;
2280
2281 procedure TDKLanguageController.DoLanguageChanged;
2282 begin
2283 if Assigned(FOnLanguageChanged) then FOnLanguageChanged(Self);
2284 end;
2285
2286 procedure TDKLanguageController.DoLanguageChanging;
2287 begin
2288 if Assigned(FOnLanguageChanging) then FOnLanguageChanging(Self);
2289 end;
2290
2291 function TDKLanguageController.GetActualSectionName: WideString;
2292 begin
2293 if FSectionName='' then Result := Owner.Name else Result := FSectionName;
2294 end;
2295
2296 procedure TDKLanguageController.LangData_Load(Stream: TStream);
2297 begin
2298 FRootCompEntry.LoadFromDFMResource(Stream);
2299 end;
2300
2301 procedure TDKLanguageController.LangData_Store(Stream: TStream);
2302 begin
2303 UpdateComponents(True);
2304 FRootCompEntry.SaveToDFMResource(Stream);
2305 end;
2306
2307 procedure TDKLanguageController.Loaded;
2308 begin
2309 inherited Loaded;
2310 // Bind the components and refresh the properties
2311 if Owner<>nil then begin
2312 FRootCompEntry.BindComponents(Owner);
2313 UpdateComponents(False);
2314 // If at runtime, apply the language currently selected in the LangManager, to the controller itself
2315 if not (csDesigning in ComponentState) then LangManager.TranslateController(Self);
2316 end;
2317 end;
2318
2319 function TDKLanguageController.LSO_CanStore: Boolean;
2320 begin
2321 Result := (Owner<>nil) and (Owner.Name<>'');
2322 // Update the entries
2323 if Result then UpdateComponents(True);
2324 end;
2325
2326 procedure TDKLanguageController.LSO_StoreLangSource(Strings: TWideStrings; StateFilter: TDKLang_TranslationStates);
2327 begin
2328 FRootCompEntry.StoreLangSource(Strings); // StateFilter is not applicable
2329 end;
2330
2331 procedure TDKLanguageController.Notification(AComponent: TComponent; Operation: TOperation);
2332 begin
2333 inherited Notification(AComponent, Operation);
2334 // Instantly remove any component that might be contained within entries
2335 if (Operation=opRemove) and (AComponent<>Self) then FRootCompEntry.RemoveComponent(AComponent, True);
2336 end;
2337
2338 procedure TDKLanguageController.SetIgnoreList(Value: TStrings);
2339 begin
2340 FIgnoreList.Assign(Value);
2341 end;
2342
2343 procedure TDKLanguageController.SetStoreList(Value: TStrings);
2344 begin
2345 FStoreList.Assign(Value);
2346 end;
2347
2348 procedure TDKLanguageController.UpdateComponents(bModifyList: Boolean);
2349 var IgnoreMasks, StoreMasks: TDKLang_MaskList;
2350 begin
2351 // Create mask lists for testing property names
2352 IgnoreMasks := TDKLang_MaskList.Create(FIgnoreList);
2353 try
2354 StoreMasks := TDKLang_MaskList.Create(FStoreList);
2355 try
2356 FRootCompEntry.UpdateEntries(bModifyList, dklcoIgnoreEmptyProps in FOptions, dklcoIgnoreNonAlphaProps in FOptions, dklcoIgnoreFontProps in FOptions, IgnoreMasks, StoreMasks);
2357 finally
2358 StoreMasks.Free;
2359 end;
2360 finally
2361 IgnoreMasks.Free;
2362 end;
2363 end;
2364
2365 //===================================================================================================================
2366 // TDKLang_LangResources
2367 //===================================================================================================================
2368
2369 function TDKLang_LangResources.Add(Kind: TDKLang_LangResourceKind; Instance: HINST; const wsName: WideString; iResID: Integer; wLangID: LANGID): Integer;
2370 var p: PDKLang_LangResource;
2371 begin
2372 // First try to find the same language already registered
2373 Result := IndexOfLangID(wLangID);
2374 // If not found, create new
2375 if Result<0 then begin
2376 New(p);
2377 Result := inherited Add(p);
2378 p.wLangID := wLangID;
2379 // Else get the existing record
2380 end else
2381 p := GetItems(Result);
2382 // Update the resource properties
2383 p.Kind := Kind;
2384 p.Instance := Instance;
2385 p.wsName := wsName;
2386 p.iResID := iResID;
2387 end;
2388
2389 function TDKLang_LangResources.FindLangID(wLangID: LANGID): PDKLang_LangResource;
2390 var idx: Integer;
2391 begin
2392 idx := IndexOfLangID(wLangID);
2393 if idx<0 then Result := nil else Result := GetItems(idx);
2394 end;
2395
2396 function TDKLang_LangResources.GetItems(Index: Integer): PDKLang_LangResource;
2397 begin
2398 Result := Get(Index);
2399 end;
2400
2401 function TDKLang_LangResources.IndexOfLangID(wLangID: LANGID): Integer;
2402 begin
2403 for Result := 0 to Count-1 do
2404 if GetItems(Result).wLangID=wLangID then Exit;
2405 Result := -1;
2406 end;
2407
2408 procedure TDKLang_LangResources.Notify(Ptr: Pointer; Action: TListNotification);
2409 begin
2410 // Don't call inherited Notify() here as it does nothing
2411 if Action=lnDeleted then Dispose(PDKLang_LangResource(Ptr));
2412 end;
2413
2414 //===================================================================================================================
2415 // TDKLanguageManager
2416 //===================================================================================================================
2417
2418 procedure TDKLanguageManager.AddLangController(Controller: TDKLanguageController);
2419 begin
2420 FSynchronizer.BeginWrite;
2421 try
2422 FLangControllers.Add(Controller);
2423 finally
2424 FSynchronizer.EndWrite;
2425 end;
2426 end;
2427
2428 procedure TDKLanguageManager.ApplyTran(Translations: TDKLang_CompTranslations);
2429 var
2430 i: Integer;
2431 Consts: TDKLang_Constants;
2432 begin
2433 FSynchronizer.BeginRead;
2434 try
2435 // First apply the language to constants as they may be used in controllers' OnLanguageChanged event handlers
2436 if Translations=nil then Consts := nil else Consts := Translations.Constants;
2437 FConstants.TranslateFrom(Consts);
2438 // Apply translation to the controllers
2439 for i := 0 to FLangControllers.Count-1 do ApplyTranToController(Translations, FLangControllers[i]);
2440 finally
2441 FSynchronizer.EndRead;
2442 end;
2443 end;
2444
2445 procedure TDKLanguageManager.ApplyTranToController(Translations: TDKLang_CompTranslations; Controller: TDKLanguageController);
2446 var
2447 CE: TDKLang_CompEntry;
2448 CT: TDKLang_CompTranslation;
2449 begin
2450 Controller.DoLanguageChanging;
2451 try
2452 // Get the controller's root component entry
2453 CE := Controller.RootCompEntry;
2454 // If Translations supplied, try to find the translation for the entry
2455 if Translations=nil then CT := nil else CT := Translations.FindComponentName(Controller.ActualSectionName);
2456 // Finally apply the translation, either found or default
2457 CE.ApplyTranslation(CT, CodePage);
2458 finally
2459 Controller.DoLanguageChanged;
2460 end;
2461 end;
2462
2463 constructor TDKLanguageManager.Create;
2464 begin
2465 inherited Create;
2466 FSynchronizer := TMultiReadExclusiveWriteSynchronizer.Create;
2467 FConstants := TDKLang_Constants.Create(GetLanguageID);
2468 FLangControllers := TList.Create;
2469 FLangResources := TDKLang_LangResources.Create;
2470 FDefaultLanguageID := ILangID_USEnglish;
2471 FLanguageID := FDefaultLanguageID;
2472 UpdateCodePage;
2473 // Load the constants from the executable's resources
2474 FConstants.LoadFromResource(HInstance, SDKLang_ConstResourceName);
2475 // Load the default translations
2476 ApplyTran(nil);
2477 end;
2478
2479 destructor TDKLanguageManager.Destroy;
2480 begin
2481 FConstants.Free;
2482 FLangControllers.Free;
2483 FLangResources.Free;
2484 FSynchronizer.Free;
2485 inherited Destroy;
2486 end;
2487
2488 function TDKLanguageManager.GetConstantValue(const sName: String): WideString;
2489 begin
2490 FSynchronizer.BeginRead;
2491 try
2492 Result := FConstants.Values[sName];
2493 finally
2494 FSynchronizer.EndRead;
2495 end;
2496 end;
2497
2498 function TDKLanguageManager.GetConstantValueA(const sName: String): String;
2499 begin
2500 Result := WideStringToStringEx(GetConstantValue(sName), CodePage);
2501 end;
2502
2503 function TDKLanguageManager.GetDefaultLanguageID: LANGID;
2504 begin
2505 FSynchronizer.BeginRead;
2506 Result := FDefaultLanguageID;
2507 FSynchronizer.EndRead;
2508 end;
2509
2510 function TDKLanguageManager.GetLanguageCount: Integer;
2511 begin
2512 FSynchronizer.BeginRead;
2513 try
2514 Result := FLangResources.Count+1; // Increment by 1 for the default language
2515 finally
2516 FSynchronizer.EndRead;
2517 end;
2518 end;
2519
2520 function TDKLanguageManager.GetLanguageID: LANGID;
2521 begin
2522 FSynchronizer.BeginRead;
2523 Result := FLanguageID;
2524 FSynchronizer.EndRead;
2525 end;
2526
2527 function TDKLanguageManager.GetLanguageIDs(Index: Integer): LANGID;
2528 begin
2529 FSynchronizer.BeginRead;
2530 try
2531 // Index=0 always means the default language
2532 if Index=0 then
2533 Result := FDefaultLanguageID
2534 else
2535 Result := FLangResources[Index-1].wLangID;
2536 finally
2537 FSynchronizer.EndRead;
2538 end;
2539 end;
2540
2541 function TDKLanguageManager.GetLanguageIndex: Integer;
2542 begin
2543 FSynchronizer.BeginRead;
2544 try
2545 Result := IndexOfLanguageID(FLanguageID);
2546 finally
2547 FSynchronizer.EndRead;
2548 end;
2549 end;
2550
2551 function TDKLanguageManager.GetLanguageNames(Index: Integer): WideString;
2552 var wLangID: LANGID;
2553 begin
2554 FSynchronizer.BeginRead;
2555 try
2556 wLangID := GetLanguageIDs(Index);
2557 finally
2558 FSynchronizer.EndRead;
2559 end;
2560 Result := WideGetLocaleStr(wLangID, LOCALE_SLANGUAGE, IntToStr(wLangID));
2561 end;
2562
2563 function TDKLanguageManager.GetLanguageResources(Index: Integer): PDKLang_LangResource;
2564 begin
2565 FSynchronizer.BeginRead;
2566 try
2567 // Index=0 always means the default language
2568 if Index=0 then Result := nil else Result := FLangResources[Index-1];
2569 finally
2570 FSynchronizer.EndRead;
2571 end;
2572 end;
2573
2574 function TDKLanguageManager.GetTranslationsForLang(wLangID: LANGID): TDKLang_CompTranslations;
2575 var plr: PDKLang_LangResource;
2576 begin
2577 Result := nil;
2578 if wLangID<>DefaultLanguageID then begin
2579 // Try to locate the appropriate resource entry
2580 plr := FLangResources.FindLangID(wLangID);
2581 if plr<>nil then begin
2582 Result := TDKLang_CompTranslations.Create;
2583 try
2584 case plr.Kind of
2585 dklrkResName: Result.Text_LoadFromResource(plr.Instance, plr.wsName);
2586 dklrkResID: Result.Text_LoadFromResource(plr.Instance, plr.iResID);
2587 dklrkFile: Result.Text_LoadFromFile(plr.wsName);
2588 end;
2589 except
2590 Result.Free;
2591 raise;
2592 end;
2593 end;
2594 end;
2595 end;
2596
2597 function TDKLanguageManager.IndexOfLanguageID(wLangID: LANGID): Integer;
2598 begin
2599 FSynchronizer.BeginRead;
2600 try
2601 if wLangID=FDefaultLanguageID then Result := 0 else Result := FLangResources.IndexOfLangID(wLangID)+1;
2602 finally
2603 FSynchronizer.EndRead;
2604 end;
2605 end;
2606
2607 function TDKLanguageManager.RegisterLangFile(const wsFileName: WideString): Boolean;
2608 var
2609 Tran: TDKLang_CompTranslations;
2610 wLangID: LANGID;
2611 begin
2612 Result := False;
2613 FSynchronizer.BeginWrite;
2614 try
2615 // Create and load the component translations object
2616 if WideFileExists(wsFileName) then begin
2617 Tran := TDKLang_CompTranslations.Create;
2618 try
2619 Tran.Text_LoadFromFile(wsFileName, True);
2620 // Try to obtain LangID parameter
2621 wLangID := StrToIntDef(Tran.Params.Values[SDKLang_TranParam_LangID], 0);
2622 // If succeeded, add the file as a resource
2623 if wLangID>0 then begin
2624 // But only if it isn't default language
2625 if wLangID<>FDefaultLanguageID then FLangResources.Add(dklrkFile, 0, wsFileName, 0, wLangID);
2626 Result := True;
2627 end;
2628 finally
2629 Tran.Free;
2630 end;
2631 end;
2632 finally
2633 FSynchronizer.EndWrite;
2634 end;
2635 end;
2636
2637 procedure TDKLanguageManager.RegisterLangResource(Instance: HINST; const wsResourceName: WideString; wLangID: LANGID);
2638 begin
2639 FSynchronizer.BeginWrite;
2640 try
2641 if wLangID<>FDefaultLanguageID then FLangResources.Add(dklrkResName, Instance, wsResourceName, 0, wLangID);
2642 finally
2643 FSynchronizer.EndWrite;
2644 end;
2645 end;
2646
2647 procedure TDKLanguageManager.RegisterLangResource(Instance: HINST; iResID: Integer; wLangID: LANGID);
2648 begin
2649 FSynchronizer.BeginWrite;
2650 try
2651 if wLangID<>FDefaultLanguageID then FLangResources.Add(dklrkResID, Instance, '', iResID, wLangID);
2652 finally
2653 FSynchronizer.EndWrite;
2654 end;
2655 end;
2656
2657 procedure TDKLanguageManager.RemoveLangController(Controller: TDKLanguageController);
2658 begin
2659 FSynchronizer.BeginWrite;
2660 try
2661 FLangControllers.Remove(Controller);
2662 finally
2663 FSynchronizer.EndWrite;
2664 end;
2665 end;
2666
2667 function TDKLanguageManager.ScanForLangFiles(const wsDir, wsMask: WideString; bRecursive: Boolean): Integer;
2668 var
2669 wsPath: WideString;
2670 SRec: TSearchRecW;
2671 begin
2672 Result := 0;
2673 // Determine the path
2674 wsPath := WideIncludeTrailingPathDelimiter(wsDir);
2675 // Scan the directory
2676 if WideFindFirst(wsPath+wsMask, faAnyFile, SRec)=0 then
2677 try
2678 repeat
2679 // Plain file. Try to register it
2680 if SRec.Attr and faDirectory=0 then begin
2681 if RegisterLangFile(wsPath+SRec.Name) then Inc(Result);
2682 // Directory. Recurse if needed
2683 end else if bRecursive and (SRec.Name[1]<>'.') then
2684 Inc(Result, ScanForLangFiles(wsPath+SRec.Name, wsMask, True));
2685 until WideFindNext(SRec)<>0;
2686 finally
2687 WideFindClose(SRec);
2688 end;
2689 end;
2690
2691 procedure TDKLanguageManager.SetDefaultLanguageID(Value: LANGID);
2692 begin
2693 FSynchronizer.BeginWrite;
2694 if FDefaultLanguageID<>Value then FDefaultLanguageID := Value;
2695 FSynchronizer.EndWrite;
2696 end;
2697
2698 procedure TDKLanguageManager.SetLanguageID(Value: LANGID);
2699 var
2700 bChanged: Boolean;
2701 Tran: TDKLang_CompTranslations;
2702 begin
2703 Tran := nil;
2704 try
2705 FSynchronizer.BeginWrite;
2706 try
2707 // Try to obtain the Translations object
2708 Tran := GetTranslationsForLang(Value);
2709 // If nil returned, assume this a default language
2710 if Tran=nil then Value := FDefaultLanguageID;
2711 // If something changed, update the property
2712 bChanged := FLanguageID<>Value;
2713 if bChanged then begin
2714 FLanguageID := Value;
2715 UpdateCodePage;
2716 end;
2717 finally
2718 FSynchronizer.EndWrite;
2719 end;
2720 // Apply the language change after synchronizing ends because applying might require constants etc.
2721 if bChanged then ApplyTran(Tran);
2722 finally
2723 Tran.Free;
2724 end;
2725 end;
2726
2727 procedure TDKLanguageManager.SetLanguageIndex(Value: Integer);
2728 begin
2729 SetLanguageID(GetLanguageIDs(Value));
2730 end;
2731
2732 procedure TDKLanguageManager.TranslateController(Controller: TDKLanguageController);
2733 var Tran: TDKLang_CompTranslations;
2734 begin
2735 FSynchronizer.BeginRead;
2736 try
2737 // If current language is not default, the translation is required
2738 if FLanguageID<>FDefaultLanguageID then begin
2739 Tran := GetTranslationsForLang(FLanguageID);
2740 try
2741 if Tran<>nil then ApplyTranToController(Tran, Controller);
2742 finally
2743 Tran.Free;
2744 end;
2745 end;
2746 finally
2747 FSynchronizer.EndRead;
2748 end;
2749 end;
2750
2751 procedure TDKLanguageManager.UnregisterLangResource(wLangID: LANGID);
2752 var idx: Integer;
2753 begin
2754 FSynchronizer.BeginWrite;
2755 try
2756 if wLangID<>FDefaultLanguageID then begin
2757 idx := FLangResources.IndexOfLangID(wLangID);
2758 if idx>=0 then FLangResources.Delete(idx);
2759 end;
2760 finally
2761 FSynchronizer.EndWrite;
2762 end;
2763 end;
2764
2765 procedure TDKLanguageManager.UpdateCodePage;
2766 begin
2767 FCodePage := LCIDToCodePage(FLanguageID);
2768 end;
2769
2770initialization
2771finalization
2772 _LangManager.Free;
2773end.
Note: See TracBrowser for help on using the repository browser.