Конфиг-файлы в Delphi без проблем
Как-то было дело и я задумался над тем, как же удобнее всего настройки пользователя где-нибудь локально, быстренько это дело написать и забыть. Хранить это дело я решил в xml-файле. Куда уж без них.
Главное в этом способе то, что при добавлении каких-то новых параметров или изменении старых, не нужно будет переписывать код сохранения данных и их загрузки. Все будет делаться автоматически. Все, что нам нужно — это создать базовый класс, который будет за нас все делать, а сами данные мы будем хранить в объектах классов-наследников.
В общем, чтобы не пудрить мозг, сразу приведу код базового класса:
unit tlXMLClass;
interface
uses
Classes, XMLIntf,
// это важно!!! модуль позволяет работать со свойствами объекта
TypInfo;
type
TXMLClass = class(TPersistent)
private
// тут у нас будет имя файла с настройками
FXMLFilePath: string;
// а тут - название приложения для идентификации
FApplicationName: string;
// название корневой ветки файла
FRootNodeName: string;
// версия
FVersion: byte;
protected
procedure SaveClass(oObject: TObject; Node: IXMLNode);
procedure LoadClass(oObject: TObject; Node: IXMLNode);
public
constructor Create(const AppName, XMLFilePath: string; RootNodeName: string = 'config');
procedure Initialize; abstract;
// загрузка значений из файла
procedure Load;
// и их сохранение
procedure Save;
// виртуальный метод, его мы будем писать в наследнике
procedure LoadDefaults; virtual;
property ApplicationName: string read FApplicationName write FApplicationName;
property RootNodeName: string read FRootNodeName;
property Version: byte read FVersion write FVersion default 1;
end;
implementation
uses
// насчет XMLDoc и XMLIntf - эти два модуля появились в Delphi не так давно,
// насколько я помню. если у вас их нет, то придется это дело реализовывать как-то по-другому.
XMLDoc, SysUtils, Windows,
resConfig;
{ TXMLConfig }
{$REGION 'Initialization'}
constructor TXMLClass.Create(const AppName, XMLFilePath: string; RootNodeName: string = 'config');
begin
Initialize;
FApplicationName := AppName;
FXMLFilePath := XMLFilePath;
FRootNodeName := RootNodeName;
// задаем настройки по-умолчанию
LoadDefaults;
end;
procedure TXMLClass.LoadDefaults;
begin
end;
{$ENDREGION}
{$REGION 'Loading'}
procedure TXMLClass.LoadClass(oObject: TObject; Node: IXMLNode);
// тут мы пробуем найти свойство и задать его значение
procedure GetProperty(PropInfo: PPropInfo);
var
sValue: string;
TempNode: IXMLNode;
LObject: TObject;
begin
// пробуем найти ветку с названием свойства
TempNode := Node.ChildNodes.FindNode(PropInfo^.Name);
// если не нашли, то выходим из функции. значение свойства останется значением по-умолчанию
if TempNode = nil then
exit;
// если свойство не является объектом, то получаем значение из ветки
if PropInfo^.PropType^.Kind <> tkClass then
sValue := TempNode.Text;
// анализируем тип свойства и задаем ему значение в соответствии с ним
case PropInfo^.PropType^.Kind of
tkEnumeration:
if GetTypeData(PropInfo^.PropType^)^.BaseType^ = TypeInfo(Boolean)
then SetPropValue(oObject, PropInfo, Boolean(StrToBool(sValue)))
else SetPropValue(oObject, PropInfo, StrToInt(sValue));
tkInteger, tkChar, tkWChar, tkSet:
SetPropValue(oObject, PropInfo, StrToInt(sValue));
tkFloat:
SetPropValue(oObject, PropInfo, StrToFloat(sValue));
tkString, tkLString, tkWString:
SetPropValue(oObject, PropInfo, sValue);
// а вот если свойство - объект, то рекурсивно выполняем процедуру
// LoadClass, но уже для найденной ветки
tkClass:
begin
LObject := GetObjectProp(oObject, PropInfo);
if LObject <> nil then
LoadClass(LObject, TempNode);
end;
end;
end;
var
i, iCount: integer;
PropInfo: PPropInfo;
PropList: PPropList;
begin
// получаем количество публичных свойств объекта
iCount := GetTypeData(oObject.ClassInfo)^.PropCount;
if iCount > 0 then
begin
// запрашиваем кусочек памяти для хранения
// списка свойств
GetMem(PropList, iCount * SizeOf(Pointer));
// и получаем их в PropList
GetPropInfos(oObject.ClassInfo, PropList);
try
// пробегаемся по списку свойств
for i := 0 to iCount - 1 do
begin
PropInfo := PropList^[i];
if PropInfo = nil then
break;
// и для каждого свойства выполняем GetProperty (см.выше)
GetProperty(PropInfo);
end;
finally
// и в самом конце освобождаем занятую списком память
FreeMem(PropList, iCount * SizeOf(Pointer));
end;
end;
end;
procedure TXMLClass.Load;
// процедура чтения из файла
var
XMLRoot: IXMLNode;
XML: IXMLDocument;
begin
LoadDefaults;
if not FileExists(FXMLFilePath) then
exit;
try
// сам xml-Файл с настройками
XML := LoadXMLDocument(FXMLFilePath);
// корневая ветка xml-документа
XMLRoot := XML.DocumentElement;
// проверка на то, наш ли этот файл
if (XMLRoot.NodeName <> FRootNodeName) or
(XMLRoot.Attributes[rsApplication] <> FApplicationName) then
exit;
FVersion := XMLRoot.Attributes[rsFormat];
// пошли загружать
LoadClass(Self, XMLRoot);
except
// возникло исключение? загружаем значения по-умолчанию
LoadDefaults;
end;
end;
{$ENDREGION}
{$REGION 'Saving'}
procedure TXMLClass.SaveClass(oObject: TObject; Node: IXMLNode);
// здесь мы сохраняем значения и процедура эта очень
// сильно похожа на процедуру загрузки, поэтому комментировать
// я здесь буду только то, чего нет в той процедуре
procedure WriteProperty(PropInfo: PPropInfo);
var
sValue: string;
LObject: TObject;
TempNode: IXMLNode;
begin
case PropInfo^.PropType^.Kind of
tkEnumeration:
if GetTypeData(PropInfo^.PropType^)^.BaseType^ = TypeInfo(Boolean)
then sValue := BoolToStr(Boolean(GetOrdProp(oObject, PropInfo)), true)
else sValue := IntToStr(GetOrdProp(oObject, PropInfo));
tkInteger, tkChar, tkWChar, tkSet:
sValue := IntToStr(GetOrdProp(oObject, PropInfo));
tkFloat:
sValue := FloatToStr(GetFloatProp(oObject, PropInfo));
tkString, tkLString, tkWString:
sValue := GetWideStrProp(oObject, PropInfo);
tkClass:
if Assigned(PropInfo^.GetProc) and Assigned(PropInfo^.SetProc) then
begin
LObject := GetObjectProp(oObject, PropInfo);
if LObject <> nil then
begin
TempNode := Node.AddChild(PropInfo^.Name);
SaveClass(LObject, TempNode);
end;
end;
end;
// тут мы создаем новую ветку в корне документа
// и записываем в него значение свойства
if PropInfo^.PropType^.Kind <> tkClass then
with Node.AddChild(PropInfo^.Name) do
Text := sValue;
end;
var
PropInfo: PPropInfo;
PropList: PPropList;
i, iCount: integer;
begin
iCount := GetTypeData(oObject.ClassInfo)^.PropCount;
if iCount > 0 then
begin
GetMem(PropList, iCount * SizeOf(Pointer));
try
GetPropInfos(oObject.ClassInfo, PropList);
for i := 0 to iCount - 1 do
begin
PropInfo := PropList^[i];
if PropInfo = nil then
Break;
WriteProperty(PropInfo);
end;
finally
FreeMem(PropList, iCount * SizeOf(Pointer));
end;
end;
end;
procedure TXMLClass.Save;
var
FRootNode: IXMLNode;
FBackFileName: string;
XML: IXMLDocument;
begin
// куда уж без бекапа. на всякий случай не помешает
FBackFileName := ChangeFileExt(FXMLFilePath, '.bak');
try
// оригинал удаляем
if FileExists(FXMLFilePath) then
DeleteFile(PChar(FXMLFilePath));
try
// создаем новый XML-документ
XML := NewXMLDocument;
// задаем ему кодировку и версию
with XML do
begin
Encoding := 'UTF-8';
Version := '1.0';
end;
// добавляем корневую ветку FRootNodeName
FRootNode := XML.AddChild(FRootNodeName);
FRootNode.Attributes[rsApplication] := FApplicationName;
FRootNode.Attributes[rsFormat] := FVersion;
SaveClass(Self, FRootNode);
// сохраняем документ
XML.SaveToFile(FXMLFilePath);
except
// а вот если произошла ошибка, то пытаемся
// восстановить файл из созданной резервной копии
if FileExists(FBackFileName) then
RenameFile(FBackFileName, FXMLFilePath);
end;
finally
// и в самом конце удаляем резервную копию
if FileExists(FBackFileName) then
DeleteFile(PChar(FBackFileName));
end;
end;
{$ENDREGION}
end.Вот такие вот дела. Код не шибко маленький, но, если разобраться, он совсем не сложный. Надеюсь еще и полезный. Для кого-нибудь :)
Да, код работает на D2007, но на версии раньше перевести его не будет проблем. На те версии, где есть поддержка XML.
Пример конфига, сгенерированного классом:
<?xml version="1.0" encoding="UTF-8" ?> <config application="test" format="0"> <Main> <HistoryDepth>40</HistoryDepth> </Main> <LookAndFeel> <WindowWidth>200</WindowWidth> <AlwaysOnTop>True</AlwaysOnTop> <AlphaBlending>False</AlphaBlending> <AlphaBlendValue>245</AlphaBlendValue> <AnimateWithAlpha>False</AnimateWithAlpha> <Elements> <ItemDefault> <Font> <Name>Tahoma</Name> <Size>8</Size> <Color>0</Color> <Bold>False</Bold> <Italic>False</Italic> <Strikeout>False</Strikeout> <Underline>False</Underline> </Font> </ItemDefault> <ItemChecked> <Font> <Name>Tahoma</Name> <Size>8</Size> <Color>9079434</Color> <Bold>False</Bold> <Italic>False</Italic> <Strikeout>True</Strikeout> <Underline>False</Underline> </Font> </ItemChecked> </Elements> </LookAndFeel> <Confirmation> <DeleteElement>True</DeleteElement> </Confirmation> <Windows> <HelpWindow> <Top>182</Top> <Left>73</Left> <Width>1135</Width> <Height>642</Height> <WindowState>0</WindowState> <SplitterLeft>156</SplitterLeft> </HelpWindow> </Windows> </config>
P.S. все это дело поддерживает группировку свойств в отдельные объекты-наследники TPersistent.
страничка проекта на GoogleCode.