Context Navigation

DKLang.pas@ 1531

Last change on this file since 1531 was 819, checked in by Kevin Toppenberg, 14 years ago
Fixed crash on non-login
File size: 107.3 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	//
28	unit DKLang;
29
30	{$INCLUDE TntCompilers.inc}
31
32	interface
33	uses
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
43	type
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;
413	const
414	DKLang_DefaultControllerOptions = [dklcoAutoSaveLangSource, dklcoIgnoreEmptyProps, dklcoIgnoreNonAlphaProps, dklcoIgnoreFontProps];
415
416	type
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
634	const
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
657	var
658	// Set to True by DKLang expert to indicate the design time execution
659	IsDesignTime: Boolean = False;
660
661	resourcestring
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
670	implementation
671	uses TypInfo, Math, TntSysUtils, TntSystem;
672
673	var
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	var LM: TDKLanguageManager; //kt
2274	begin
2275	//kt original --> if not (csDesigning in ComponentState) then begin LangManager.RemoveLangController(Self);
2276	if not (csDesigning in ComponentState) then begin
2277	LM := LangManager;
2278	if Assigned(LM) then LM.RemoveLangController(Self);
2279	end;
2280	FRootCompEntry.Free;
2281	FIgnoreList.Free;
2282	FStoreList.Free;
2283	inherited Destroy;
2284	end;
2285
2286	procedure TDKLanguageController.DoLanguageChanged;
2287	begin
2288	if Assigned(FOnLanguageChanged) then FOnLanguageChanged(Self);
2289	end;
2290
2291	procedure TDKLanguageController.DoLanguageChanging;
2292	begin
2293	if Assigned(FOnLanguageChanging) then FOnLanguageChanging(Self);
2294	end;
2295
2296	function TDKLanguageController.GetActualSectionName: WideString;
2297	begin
2298	if FSectionName='' then Result := Owner.Name else Result := FSectionName;
2299	end;
2300
2301	procedure TDKLanguageController.LangData_Load(Stream: TStream);
2302	begin
2303	FRootCompEntry.LoadFromDFMResource(Stream);
2304	end;
2305
2306	procedure TDKLanguageController.LangData_Store(Stream: TStream);
2307	begin
2308	UpdateComponents(True);
2309	FRootCompEntry.SaveToDFMResource(Stream);
2310	end;
2311
2312	procedure TDKLanguageController.Loaded;
2313	begin
2314	inherited Loaded;
2315	// Bind the components and refresh the properties
2316	if Owner<>nil then begin
2317	FRootCompEntry.BindComponents(Owner);
2318	UpdateComponents(False);
2319	// If at runtime, apply the language currently selected in the LangManager, to the controller itself
2320	if not (csDesigning in ComponentState) then LangManager.TranslateController(Self);
2321	end;
2322	end;
2323
2324	function TDKLanguageController.LSO_CanStore: Boolean;
2325	begin
2326	Result := (Owner<>nil) and (Owner.Name<>'');
2327	// Update the entries
2328	if Result then UpdateComponents(True);
2329	end;
2330
2331	procedure TDKLanguageController.LSO_StoreLangSource(Strings: TWideStrings; StateFilter: TDKLang_TranslationStates);
2332	begin
2333	FRootCompEntry.StoreLangSource(Strings); // StateFilter is not applicable
2334	end;
2335
2336	procedure TDKLanguageController.Notification(AComponent: TComponent; Operation: TOperation);
2337	begin
2338	inherited Notification(AComponent, Operation);
2339	// Instantly remove any component that might be contained within entries
2340	if (Operation=opRemove) and (AComponent<>Self) then FRootCompEntry.RemoveComponent(AComponent, True);
2341	end;
2342
2343	procedure TDKLanguageController.SetIgnoreList(Value: TStrings);
2344	begin
2345	FIgnoreList.Assign(Value);
2346	end;
2347
2348	procedure TDKLanguageController.SetStoreList(Value: TStrings);
2349	begin
2350	FStoreList.Assign(Value);
2351	end;
2352
2353	procedure TDKLanguageController.UpdateComponents(bModifyList: Boolean);
2354	var IgnoreMasks, StoreMasks: TDKLang_MaskList;
2355	begin
2356	// Create mask lists for testing property names
2357	IgnoreMasks := TDKLang_MaskList.Create(FIgnoreList);
2358	try
2359	StoreMasks := TDKLang_MaskList.Create(FStoreList);
2360	try
2361	FRootCompEntry.UpdateEntries(bModifyList, dklcoIgnoreEmptyProps in FOptions, dklcoIgnoreNonAlphaProps in FOptions, dklcoIgnoreFontProps in FOptions, IgnoreMasks, StoreMasks);
2362	finally
2363	StoreMasks.Free;
2364	end;
2365	finally
2366	IgnoreMasks.Free;
2367	end;
2368	end;
2369
2370	//===================================================================================================================
2371	// TDKLang_LangResources
2372	//===================================================================================================================
2373
2374	function TDKLang_LangResources.Add(Kind: TDKLang_LangResourceKind; Instance: HINST; const wsName: WideString; iResID: Integer; wLangID: LANGID): Integer;
2375	var p: PDKLang_LangResource;
2376	begin
2377	// First try to find the same language already registered
2378	Result := IndexOfLangID(wLangID);
2379	// If not found, create new
2380	if Result<0 then begin
2381	New(p);
2382	Result := inherited Add(p);
2383	p.wLangID := wLangID;
2384	// Else get the existing record
2385	end else
2386	p := GetItems(Result);
2387	// Update the resource properties
2388	p.Kind := Kind;
2389	p.Instance := Instance;
2390	p.wsName := wsName;
2391	p.iResID := iResID;
2392	end;
2393
2394	function TDKLang_LangResources.FindLangID(wLangID: LANGID): PDKLang_LangResource;
2395	var idx: Integer;
2396	begin
2397	idx := IndexOfLangID(wLangID);
2398	if idx<0 then Result := nil else Result := GetItems(idx);
2399	end;
2400
2401	function TDKLang_LangResources.GetItems(Index: Integer): PDKLang_LangResource;
2402	begin
2403	Result := Get(Index);
2404	end;
2405
2406	function TDKLang_LangResources.IndexOfLangID(wLangID: LANGID): Integer;
2407	begin
2408	for Result := 0 to Count-1 do
2409	if GetItems(Result).wLangID=wLangID then Exit;
2410	Result := -1;
2411	end;
2412
2413	procedure TDKLang_LangResources.Notify(Ptr: Pointer; Action: TListNotification);
2414	begin
2415	// Don't call inherited Notify() here as it does nothing
2416	if Action=lnDeleted then Dispose(PDKLang_LangResource(Ptr));
2417	end;
2418
2419	//===================================================================================================================
2420	// TDKLanguageManager
2421	//===================================================================================================================
2422
2423	procedure TDKLanguageManager.AddLangController(Controller: TDKLanguageController);
2424	begin
2425	FSynchronizer.BeginWrite;
2426	try
2427	FLangControllers.Add(Controller);
2428	finally
2429	FSynchronizer.EndWrite;
2430	end;
2431	end;
2432
2433	procedure TDKLanguageManager.ApplyTran(Translations: TDKLang_CompTranslations);
2434	var
2435	i: Integer;
2436	Consts: TDKLang_Constants;
2437	begin
2438	FSynchronizer.BeginRead;
2439	try
2440	// First apply the language to constants as they may be used in controllers' OnLanguageChanged event handlers
2441	if Translations=nil then Consts := nil else Consts := Translations.Constants;
2442	FConstants.TranslateFrom(Consts);
2443	// Apply translation to the controllers
2444	for i := 0 to FLangControllers.Count-1 do ApplyTranToController(Translations, FLangControllers[i]);
2445	finally
2446	FSynchronizer.EndRead;
2447	end;
2448	end;
2449
2450	procedure TDKLanguageManager.ApplyTranToController(Translations: TDKLang_CompTranslations; Controller: TDKLanguageController);
2451	var
2452	CE: TDKLang_CompEntry;
2453	CT: TDKLang_CompTranslation;
2454	begin
2455	Controller.DoLanguageChanging;
2456	try
2457	// Get the controller's root component entry
2458	CE := Controller.RootCompEntry;
2459	// If Translations supplied, try to find the translation for the entry
2460	if Translations=nil then CT := nil else CT := Translations.FindComponentName(Controller.ActualSectionName);
2461	// Finally apply the translation, either found or default
2462	CE.ApplyTranslation(CT, CodePage);
2463	finally
2464	Controller.DoLanguageChanged;
2465	end;
2466	end;
2467
2468	constructor TDKLanguageManager.Create;
2469	begin
2470	inherited Create;
2471	FSynchronizer := TMultiReadExclusiveWriteSynchronizer.Create;
2472	FConstants := TDKLang_Constants.Create(GetLanguageID);
2473	FLangControllers := TList.Create;
2474	FLangResources := TDKLang_LangResources.Create;
2475	FDefaultLanguageID := ILangID_USEnglish;
2476	FLanguageID := FDefaultLanguageID;
2477	UpdateCodePage;
2478	// Load the constants from the executable's resources
2479	FConstants.LoadFromResource(HInstance, SDKLang_ConstResourceName);
2480	// Load the default translations
2481	ApplyTran(nil);
2482	end;
2483
2484	destructor TDKLanguageManager.Destroy;
2485	begin
2486	FConstants.Free;
2487	FLangControllers.Free;
2488	FLangResources.Free;
2489	FSynchronizer.Free;
2490	inherited Destroy;
2491	end;
2492
2493	function TDKLanguageManager.GetConstantValue(const sName: String): WideString;
2494	begin
2495	FSynchronizer.BeginRead;
2496	try
2497	Result := FConstants.Values[sName];
2498	finally
2499	FSynchronizer.EndRead;
2500	end;
2501	end;
2502
2503	function TDKLanguageManager.GetConstantValueA(const sName: String): String;
2504	begin
2505	Result := WideStringToStringEx(GetConstantValue(sName), CodePage);
2506	end;
2507
2508	function TDKLanguageManager.GetDefaultLanguageID: LANGID;
2509	begin
2510	FSynchronizer.BeginRead;
2511	Result := FDefaultLanguageID;
2512	FSynchronizer.EndRead;
2513	end;
2514
2515	function TDKLanguageManager.GetLanguageCount: Integer;
2516	begin
2517	FSynchronizer.BeginRead;
2518	try
2519	Result := FLangResources.Count+1; // Increment by 1 for the default language
2520	finally
2521	FSynchronizer.EndRead;
2522	end;
2523	end;
2524
2525	function TDKLanguageManager.GetLanguageID: LANGID;
2526	begin
2527	FSynchronizer.BeginRead;
2528	Result := FLanguageID;
2529	FSynchronizer.EndRead;
2530	end;
2531
2532	function TDKLanguageManager.GetLanguageIDs(Index: Integer): LANGID;
2533	begin
2534	FSynchronizer.BeginRead;
2535	try
2536	// Index=0 always means the default language
2537	if Index=0 then
2538	Result := FDefaultLanguageID
2539	else
2540	Result := FLangResources[Index-1].wLangID;
2541	finally
2542	FSynchronizer.EndRead;
2543	end;
2544	end;
2545
2546	function TDKLanguageManager.GetLanguageIndex: Integer;
2547	begin
2548	FSynchronizer.BeginRead;
2549	try
2550	Result := IndexOfLanguageID(FLanguageID);
2551	finally
2552	FSynchronizer.EndRead;
2553	end;
2554	end;
2555
2556	function TDKLanguageManager.GetLanguageNames(Index: Integer): WideString;
2557	var wLangID: LANGID;
2558	begin
2559	FSynchronizer.BeginRead;
2560	try
2561	wLangID := GetLanguageIDs(Index);
2562	finally
2563	FSynchronizer.EndRead;
2564	end;
2565	Result := WideGetLocaleStr(wLangID, LOCALE_SLANGUAGE, IntToStr(wLangID));
2566	end;
2567
2568	function TDKLanguageManager.GetLanguageResources(Index: Integer): PDKLang_LangResource;
2569	begin
2570	FSynchronizer.BeginRead;
2571	try
2572	// Index=0 always means the default language
2573	if Index=0 then Result := nil else Result := FLangResources[Index-1];
2574	finally
2575	FSynchronizer.EndRead;
2576	end;
2577	end;
2578
2579	function TDKLanguageManager.GetTranslationsForLang(wLangID: LANGID): TDKLang_CompTranslations;
2580	var plr: PDKLang_LangResource;
2581	begin
2582	Result := nil;
2583	if wLangID<>DefaultLanguageID then begin
2584	// Try to locate the appropriate resource entry
2585	plr := FLangResources.FindLangID(wLangID);
2586	if plr<>nil then begin
2587	Result := TDKLang_CompTranslations.Create;
2588	try
2589	case plr.Kind of
2590	dklrkResName: Result.Text_LoadFromResource(plr.Instance, plr.wsName);
2591	dklrkResID: Result.Text_LoadFromResource(plr.Instance, plr.iResID);
2592	dklrkFile: Result.Text_LoadFromFile(plr.wsName);
2593	end;
2594	except
2595	Result.Free;
2596	raise;
2597	end;
2598	end;
2599	end;
2600	end;
2601
2602	function TDKLanguageManager.IndexOfLanguageID(wLangID: LANGID): Integer;
2603	begin
2604	FSynchronizer.BeginRead;
2605	try
2606	if wLangID=FDefaultLanguageID then Result := 0 else Result := FLangResources.IndexOfLangID(wLangID)+1;
2607	finally
2608	FSynchronizer.EndRead;
2609	end;
2610	end;
2611
2612	function TDKLanguageManager.RegisterLangFile(const wsFileName: WideString): Boolean;
2613	var
2614	Tran: TDKLang_CompTranslations;
2615	wLangID: LANGID;
2616	begin
2617	Result := False;
2618	FSynchronizer.BeginWrite;
2619	try
2620	// Create and load the component translations object
2621	if WideFileExists(wsFileName) then begin
2622	Tran := TDKLang_CompTranslations.Create;
2623	try
2624	Tran.Text_LoadFromFile(wsFileName, True);
2625	// Try to obtain LangID parameter
2626	wLangID := StrToIntDef(Tran.Params.Values[SDKLang_TranParam_LangID], 0);
2627	// If succeeded, add the file as a resource
2628	if wLangID>0 then begin
2629	// But only if it isn't default language
2630	if wLangID<>FDefaultLanguageID then FLangResources.Add(dklrkFile, 0, wsFileName, 0, wLangID);
2631	Result := True;
2632	end;
2633	finally
2634	Tran.Free;
2635	end;
2636	end;
2637	finally
2638	FSynchronizer.EndWrite;
2639	end;
2640	end;
2641
2642	procedure TDKLanguageManager.RegisterLangResource(Instance: HINST; const wsResourceName: WideString; wLangID: LANGID);
2643	begin
2644	FSynchronizer.BeginWrite;
2645	try
2646	if wLangID<>FDefaultLanguageID then FLangResources.Add(dklrkResName, Instance, wsResourceName, 0, wLangID);
2647	finally
2648	FSynchronizer.EndWrite;
2649	end;
2650	end;
2651
2652	procedure TDKLanguageManager.RegisterLangResource(Instance: HINST; iResID: Integer; wLangID: LANGID);
2653	begin
2654	FSynchronizer.BeginWrite;
2655	try
2656	if wLangID<>FDefaultLanguageID then FLangResources.Add(dklrkResID, Instance, '', iResID, wLangID);
2657	finally
2658	FSynchronizer.EndWrite;
2659	end;
2660	end;
2661
2662	procedure TDKLanguageManager.RemoveLangController(Controller: TDKLanguageController);
2663	begin
2664	FSynchronizer.BeginWrite;
2665	try
2666	FLangControllers.Remove(Controller);
2667	finally
2668	FSynchronizer.EndWrite;
2669	end;
2670	end;
2671
2672	function TDKLanguageManager.ScanForLangFiles(const wsDir, wsMask: WideString; bRecursive: Boolean): Integer;
2673	var
2674	wsPath: WideString;
2675	SRec: TSearchRecW;
2676	begin
2677	Result := 0;
2678	// Determine the path
2679	wsPath := WideIncludeTrailingPathDelimiter(wsDir);
2680	// Scan the directory
2681	if WideFindFirst(wsPath+wsMask, faAnyFile, SRec)=0 then
2682	try
2683	repeat
2684	// Plain file. Try to register it
2685	if SRec.Attr and faDirectory=0 then begin
2686	if RegisterLangFile(wsPath+SRec.Name) then Inc(Result);
2687	// Directory. Recurse if needed
2688	end else if bRecursive and (SRec.Name[1]<>'.') then
2689	Inc(Result, ScanForLangFiles(wsPath+SRec.Name, wsMask, True));
2690	until WideFindNext(SRec)<>0;
2691	finally
2692	WideFindClose(SRec);
2693	end;
2694	end;
2695
2696	procedure TDKLanguageManager.SetDefaultLanguageID(Value: LANGID);
2697	begin
2698	FSynchronizer.BeginWrite;
2699	if FDefaultLanguageID<>Value then FDefaultLanguageID := Value;
2700	FSynchronizer.EndWrite;
2701	end;
2702
2703	procedure TDKLanguageManager.SetLanguageID(Value: LANGID);
2704	var
2705	bChanged: Boolean;
2706	Tran: TDKLang_CompTranslations;
2707	begin
2708	Tran := nil;
2709	try
2710	FSynchronizer.BeginWrite;
2711	try
2712	// Try to obtain the Translations object
2713	Tran := GetTranslationsForLang(Value);
2714	// If nil returned, assume this a default language
2715	if Tran=nil then Value := FDefaultLanguageID;
2716	// If something changed, update the property
2717	bChanged := FLanguageID<>Value;
2718	if bChanged then begin
2719	FLanguageID := Value;
2720	UpdateCodePage;
2721	end;
2722	finally
2723	FSynchronizer.EndWrite;
2724	end;
2725	// Apply the language change after synchronizing ends because applying might require constants etc.
2726	if bChanged then ApplyTran(Tran);
2727	finally
2728	Tran.Free;
2729	end;
2730	end;
2731
2732	procedure TDKLanguageManager.SetLanguageIndex(Value: Integer);
2733	begin
2734	SetLanguageID(GetLanguageIDs(Value));
2735	end;
2736
2737	procedure TDKLanguageManager.TranslateController(Controller: TDKLanguageController);
2738	var Tran: TDKLang_CompTranslations;
2739	begin
2740	FSynchronizer.BeginRead;
2741	try
2742	// If current language is not default, the translation is required
2743	if FLanguageID<>FDefaultLanguageID then begin
2744	Tran := GetTranslationsForLang(FLanguageID);
2745	try
2746	if Tran<>nil then ApplyTranToController(Tran, Controller);
2747	finally
2748	Tran.Free;
2749	end;
2750	end;
2751	finally
2752	FSynchronizer.EndRead;
2753	end;
2754	end;
2755
2756	procedure TDKLanguageManager.UnregisterLangResource(wLangID: LANGID);
2757	var idx: Integer;
2758	begin
2759	FSynchronizer.BeginWrite;
2760	try
2761	if wLangID<>FDefaultLanguageID then begin
2762	idx := FLangResources.IndexOfLangID(wLangID);
2763	if idx>=0 then FLangResources.Delete(idx);
2764	end;
2765	finally
2766	FSynchronizer.EndWrite;
2767	end;
2768	end;
2769
2770	procedure TDKLanguageManager.UpdateCodePage;
2771	begin
2772	FCodePage := LCIDToCodePage(FLanguageID);
2773	end;
2774
2775	initialization
2776	finalization
2777	_LangManager.Free;
2778	_LangManager := nil; //kt added
2779	end.

Note: See TracBrowser for help on using the repository browser.

Context Navigation

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

Download in other formats: