Hi Marcos,
> OK, if you can I appreciate that.
> Some functions of fcl-web returns a new object... I have to be careful
> with memory leaks.
See: addressbook.pp.
Mind you, my code isn't web related, it just handles an xml-file.
Bart
unit AddressBook;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, DOM, XMLWrite, XMLRead;
type
TPersonField = (pfInvalid, pfName, pfFirstName, pfPrefix, pfAddress, pfZIP, pfCity,
pfPhonePrivate, pfPhoneWork, pfGSM, pfFax, pfEmail, pfWeb, pfRemark, pfMarked);
TInfoField = (ifInvalid, ifAppVersion, ifCopyRight, ifWarning);
TAppNode = (anAddressBook, anInfo, anPersonContainer, anPerson);
const
PersonFields: Array[TPersonField] of DOMString = (#0#1,'Naam','Voornaam','Voorv','Adres','Postcode','Plaats',
'TelPrive','TelWerk','GSM','Fax','Email','Web','Opmerking','Markeer');
InfoFields: Array[TInfoField] of DOMString = (#0#1,'Applicatie','CopyRight','Waarschuwing');
AppNodes: Array[TAppNode] of DOMString = ('AdresBoek','Info','Personen','Persoon');
type
{ TPerson }
TPerson = class
private
FName: String;
FFirstName: String;
FPrefix: String;
FAddress: String;
FZIP: String;
FCity: String;
FPhonePrivate: String;
FPhoneWork: String;
FGSM: STring;
FFax: String;
FEmail: String;
FWeb: String;
FMarked: Boolean;
FRemark: String;
FOnChange: TNotifyEvent;
procedure SetAddress(const AValue: String);
procedure SetCity(const AValue: String);
procedure SetEmail(const AValue: String);
procedure SetFax(const AValue: String);
procedure SetFirstName(const AValue: String);
procedure SetGSM(const AValue: String);
procedure SetMarked(const AValue: Boolean);
procedure SetName(const AValue: String);
procedure SetOnChange(const AValue: TNotifyEvent);
procedure SetPhonePrivate(const AValue: String);
procedure SetPhoneWork(const AValue: String);
procedure SetPrefix(const AValue: String);
procedure SetRemark(const AValue: String);
procedure SetWeb(const AValue: String);
procedure SetZIP(const AValue: String);
protected
procedure PersonChanged;
public
procedure Assign(APerson: TPerson);
procedure Clear;
function Matches(APerson: TPerson): Boolean;
function IsEmpty: Boolean;
constructor Create;
property Name: String read FName write SetName;
property Prefix: String read FPrefix write SetPrefix;
property FirstName: String read FFirstName write SetFirstName;
property Address: String read FAddress write SetAddress;
property ZIP: String read FZIP write SetZIP;
property City: String read FCity write SetCity;
property PhonePrivate: String read FPhonePrivate write SetPhonePrivate;
property PhoneWork: String read FPhoneWork write SetPhoneWork;
property GSM: String read FGSM write SetGSM;
property Fax: String read FFax write SetFax;
property Email: String read FEmail write SetEmail;
property Web: String read FWeb write SetWeb;
property Remark: String read FRemark write SetRemark;
property Marked: Boolean read FMarked write SetMarked;
property OnChange: TNotifyEvent read FOnChange write SetOnChange;
end;
const
SNoImporter = 'No importer assigned';
SNoExporter = 'No exporter assigned';
SInternalListError = 'Fatal internal list error';
SUtf8Notification: String = 'LET OP: Dit bestand moet in UTF-8 codering opgeslagen worden!';
type
EAddressBook = class(EStreamError);
EInternalListError = class(EAddressBook);
ENoImporter = class(EAddressBook);
ENoExporter = class(EAddressBook);
EAddressBookReadError = class(EAddressBook);
EAddressBookWriteError = class(EAddressBook);
//Forward declarations
TCustomAddressBookExporter = Class;
TCustomAddressBookImporter = Class;
{ TAddressBook }
TAddressBook = class
private
FCopyright: String;
//FCurrentIndex: Integer;
FList: TList;
FImporter: TCustomAddressBookImporter;
FExporter: TCustomAddressBookExporter;
FModified: Boolean;
FVersion: String;
FFileName: String;
function GetPersonCount: Integer;
function GetPerson(const i: Integer): TPerson;
procedure SetCopyright(const AValue: String);
procedure SetPerson(const i: Integer; const APerson: TPerson);
//procedure SetCurrentIndex(const AValue: Integer);
procedure SetExporter(const AValue: TCustomAddressBookExporter);
procedure SetImporter(const AValue: TCustomAddressBookImporter);
procedure SetModified(const AValue: Boolean);
procedure SetVersion(const AValue: String);
procedure XmlToList(XMLDoc: TXMlDocument);
procedure OnPersonChanged(Sender: TObject);
protected
public
function AddPerson(out Index: Integer): Boolean;
procedure DeletePerson(const Index: Integer);
procedure Sort(const Ascending: Boolean = True);
function FindNamePartial(const Value: String; const StartIndex: Integer): Integer;
function FindText(const Value: String; const StartIndex: Integer): Integer;
procedure LoadFromFile(const Fn: String);
procedure SaveToFile(const Fn: String);
procedure ExportToFile(const Fn: String; const MarkedOnly: Boolean = False);
procedure ImportFromFile(const Fn: String);
procedure Clear;
constructor Create;
destructor Destroy; override;
//Public properties
property Copyright: String read FCopyright write SetCopyright;
property Version: String read FVersion write SetVersion;
property Persons[i: Integer]: TPerson read GetPerson write SetPerson; default;
property Count: Integer read GetPersonCount;
property Exporter: TCustomAddressBookExporter read FExporter write SetExporter;
property Importer: TCustomAddressBookImporter read FImporter write SetImporter;
property Modified: Boolean read FModified write SetModified;
//FileName is set to a real value,if LoadFromFile or SaveToFile succeeds,
//it is cleared on failure (load/save), or on import
property FileName: String read FFileName;
end;
{ TCustomAddressBookExporter }
TCustomAddressBookExporter = Class
public
procedure ExportToFile(const Fn: String; ABook: TAddressBook; const MarkedOnly: Boolean = False); virtual; abstract;
end;
{ TCustomAddressBookImporter }
TCustomAddressBookImporter = Class
public
procedure ImportFromFile(const Fn: String; ABook: TAddressBook); virtual; abstract;
end;
implementation
{$ifdef windows}
uses win9xwsmanager; //needed for UTF8UpperCase on Win9x systems
{$endif}
{ TPerson }
procedure TPerson.SetName(const AValue: String);
begin
if FName=AValue then exit;
FName:=AValue;
PersonChanged;
end;
procedure TPerson.SetAddress(const AValue: String);
begin
if FAddress=AValue then exit;
FAddress:=AValue;
PersonChanged;
end;
procedure TPerson.SetCity(const AValue: String);
begin
if FCity=AValue then exit;
FCity:=AValue;
PersonChanged;
end;
procedure TPerson.SetEmail(const AValue: String);
begin
if FEmail=AValue then exit;
FEmail:=AValue;
PersonChanged;
end;
procedure TPerson.SetFax(const AValue: String);
begin
if FFax=AValue then exit;
FFax:=AValue;
PersonChanged;
end;
procedure TPerson.SetFirstName(const AValue: String);
begin
if FFirstName=AValue then exit;
FFirstName:=AValue;
PersonChanged;
end;
procedure TPerson.SetGSM(const AValue: String);
begin
if FGSM=AValue then exit;
FGSM:=AValue;
PersonChanged;
end;
procedure TPerson.SetMarked(const AValue: Boolean);
begin
if FMarked=AValue then exit;
FMarked:=AValue;
PersonChanged;
end;
procedure TPerson.SetPhonePrivate(const AValue: String);
begin
if FPhonePrivate=AValue then exit;
FPhonePrivate:=AValue;
PersonChanged;
end;
procedure TPerson.SetPhoneWork(const AValue: String);
begin
if FPhoneWork=AValue then exit;
FPhoneWork:=AValue;
PersonChanged;
end;
procedure TPerson.SetPrefix(const AValue: String);
begin
if FPrefix=AValue then exit;
FPrefix:=AValue;
PersonChanged;
end;
procedure TPerson.SetRemark(const AValue: String);
begin
if FRemark=AValue then exit;
FRemark:=AValue;
PersonChanged;
end;
procedure TPerson.SetWeb(const AValue: String);
begin
if FWeb=AValue then exit;
FWeb:=AValue;
PersonChanged;
end;
procedure TPerson.SetZIP(const AValue: String);
begin
if FZIP=AValue then exit;
FZIP:=AValue;
PersonChanged;
end;
procedure TPerson.SetOnChange(const AValue: TNotifyEvent);
begin
if FOnChange=AValue then exit;
FOnChange:=AValue;
end;
procedure TPerson.PersonChanged;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TPerson.Assign(APerson: TPerson);
begin
if Assigned(APerson) and (not Self.Matches(APerson)) then
begin
FName := APerson.Name;
FFirstName := APerson.FirstName;
FPrefix := APerson.Prefix;
FAddress := APerson.Address;
FZIP := APerson.ZIP;
FCity := APerson.City;
FPhonePrivate := APerson.PhonePrivate;
FPhoneWork := APerson.PhoneWork;
FGSM := APerson.GSM;
FFax := APerson.Fax;
FEmail := APerson.Email;
FWeb := APerson.Web;
FRemark := APerson.Remark;
FMarked := APerson.Marked;
PersonChanged;
end
else Clear;
end;
procedure TPerson.Clear;
begin
FName := '';
FName := '';
FFirstName := '';
FPrefix := '';
FAddress := '';
FZIP := '';
FCity := '';
FPhonePrivate := '';
FPhoneWork := '';
FGSM := '';
FFax := '';
FEmail := '';
FWeb := '';
FRemark := '';
FMarked := False;
PersonChanged;
end;
function TPerson.Matches(APerson: TPerson): Boolean;
begin
Result :=
( (FName = APerson.Name) and
(FFirstName = APerson.FirstName) and
(FPrefix = APerson.Prefix) and
(FAddress = APerson.Address) and
(FZip = APerson.Zip) and
(FCity = APerson.City) and
(FPhonePrivate = APerson.PhonePrivate) and
(FPhoneWork = APerson.PhoneWork) and
(FGSM = APerson.GSM) and
(FFax = APerson.Fax) and
(FEmail = APerson.Email) and
(FWeb = APerson.Web) and
(FRemark = APerson.Remark) and
(FMarked = APerson.Marked) );
end;
function TPerson.IsEmpty: Boolean;
begin
Result :=
(FName = '') and
(FFirstName = '') and
(FPrefix = '') and
(FAddress = '') and
(FZIP = '') and
(FCity = '') and
(FPhonePrivate = '') and
(FPhoneWork = '') and
(FGSM = '') and
(FFax = '') and
(FEmail = '') and
(FWeb = '') and
(FRemark = '') and
(FMarked = False);
end;
constructor TPerson.Create;
begin
FName := '';
FFirstName := '';
FPrefix := '';
FAddress := '';
FZIP := '';
FCity := '';
FPhonePrivate := '';
FPhoneWork := '';
FGSM := '';
FFax := '';
FEmail := '';
FWeb := '';
FRemark := '';
FMarked := False;
FOnChange := nil;
end;
{ TAdressBook }
//Helper functions
function DomStrToBool(AValue: DomString): Boolean;
begin
if (AValue = '1') then Result := True
else Result := False;
end;
function DomBoolStr(const Value: Boolean): DomString;
begin
if Value then
Result := '1'
else
Result := '0';
end;
function Pad(const Value, Width: Integer): String;
begin
Result := IntToStr(Value);
While Length(Result) < Width do Result := '0' + Result;
end;
//Original code from Lazarus LCLProc unit
function UTF8UpperCase(const s: String): String;
begin
Result := UTF8Encode(WideUpperCase(UTF8Decode(s)));
end;
function SortBookDescending(Person1, Person2: Pointer): Integer;
begin
Result := 0 - AnsiCompareText(TPerson(Person1).Name, TPerson(Person2).Name);
end;
function SortBookAscending(Person1, Person2: Pointer): Integer;
begin
Result := AnsiCompareText(TPerson(Person1).Name, TPerson(Person2).Name);
end;
function TAddressBook.GetPersonCount: Integer;
begin
Result := FList.Count;
end;
function TAddressBook.GetPerson(const i: Integer): TPerson;
begin
if FList.Count > i then Result := TPerson(FList.Items[i]) else Result := nil;
end;
procedure TAddressBook.SetCopyright(const AValue: String);
begin
if FCopyright =AValue then exit;
FCopyright :=AValue;
end;
{
procedure TAddressBook.SetCurrentIndex(const AValue: Integer);
begin
if FCurrentIndex=AValue then exit;
FCurrentIndex:=AValue;
end;
}
procedure TAddressBook.SetExporter(const AValue: TCustomAddressBookExporter);
begin
if FExporter=AValue then exit;
FExporter:=AValue;
end;
procedure TAddressBook.SetImporter(const AValue: TCustomAddressBookImporter);
begin
if FImporter=AValue then exit;
FImporter:=AValue;
end;
procedure TAddressBook.SetModified(const AValue: Boolean);
begin
if FModified=AValue then exit;
FModified:=AValue;
end;
procedure TAddressBook.SetVersion(const AValue: String);
begin
if FVersion =AValue then exit;
FVersion :=AValue;
end;
procedure TAddressBook.SetPerson(const i: Integer; const APerson: TPerson);
var
AFoo: TPerson;
begin
//writeln('TAddressBook.SetPerson: i = ',i);
//if not Assigned(FList.Items[i]) then FList.Items[i] := TPerson.Create;
AFoo := TPerson(FList.Items[i]);
if not AFoo.Matches(APerson) then
begin
AFoo.Assign(APerson);
//FModified := True;
end;
end;
function TAddressBook.AddPerson(out Index: Integer): Boolean;
begin
Index := FList.Add(TPerson.Create);
Result := (Index >= 0);
if Result then TPerson(FList[Index]).OnChange := @OnPersonChanged;
FModified := True;
end;
procedure TAddressBook.DeletePerson(const Index: Integer);
var
APerson: TPerson;
begin
if Index < FList.Count then
begin
FModified := True;
APerson := TPerson(FList.Items[Index]);
APerson.Free;
APerson := nil;
FList.Delete(Index);
end;
end;
procedure TAddressBook.Sort(const Ascending: Boolean = True);
begin
if (FList.Count > 1) then
begin
FModified := True;
if Ascending then
FList.Sort(@SortBookAscending)
else
FList.Sort(@SortBookDescending)
end;
end;
function TAddressBook.FindNamePartial(const Value: String; const StartIndex: Integer): Integer;
//Find a name that starts with Value, case insensitive
var
i: Integer;
begin
Result := -1; //Assume failure
for i := StartIndex to Count - 1 do
begin
if (Pos(UTF8UpperCase(Value), UTF8UpperCase(Persons[i].Name)) = 1) then
begin
Result := i;
exit;
end;
end;
for i := 0 to StartIndex - 1 do
begin
if (Pos(UTF8UpperCase(Value), UTF8UpperCase(Persons[i].Name)) = 1) then
begin
Result := i;
exit;
end;
end;
end;
function TAddressBook.FindText(const Value: String; const StartIndex: Integer): Integer;
//Find text in any field, case insensitive
var
i: Integer;
begin
Result := -1; //Assume failure
for i := StartIndex to Count - 1 do
begin
// writeln('FindText: UC(Value) = ',Utf8UpperCase(Value),' i = ',i,' UC(Persons[',i,'].Name) = ',
// Utf8UpperCase(Persons[i].Name),' Pos = ',Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Name)));
//There is no need to use Utf8Pos(), since we are only interested in Pos() > 0, not the "real" position
if (Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Name)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].FirstName)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Prefix)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].ZIP)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].City)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].PhonePrivate)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].PhoneWork)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].GSM)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Fax)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Email)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Web)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Remark)) > 0) then
begin
Result := i;
exit;
end;
end;
for i := 0 to StartIndex - 1 do
begin
if (Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Name)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].FirstName)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Prefix)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].ZIP)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].City)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].PhonePrivate)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].PhoneWork)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].GSM)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Fax)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Email)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Web)) > 0) or
(Pos(Utf8UpperCase(Value), Utf8UpperCase(Persons[i].Remark)) > 0) then
begin
Result := i;
exit;
end;
end;
end;
procedure TAddressBook.XmlToList(XMLDoc: TXMlDocument);
var
iNode: TDOMNode;
APerson: TPerson;
FoundPerson: Boolean;
function IsRoot(Node: TDomNode): Boolean;
begin
Result := (Node.ParentNode = XMLDoc);
end;
function IsAddressBook(Node: TDomNode; const Level: Integer): Boolean;
begin
Result := (Level = 0) and (Node.CompareName('AdresBoek') = 0);
//if not result then DbgOut(' -B ') else DbgOut(' +B ');
end;
function IsPersonContainer(Node: TDomNode; const Level: Integer): Boolean;
begin
Result := (Level = 1) and (Node.CompareName('Adressen') = 0) and IsAddressBook(Node.ParentNode, Level - 1);
//if not result then DbgOut(' -C ') else DbgOut(' +C ');
end;
function IsPerson(Node: TDomNode; const Level: Integer): Boolean;
begin
Result := (Level = 2) and (Node.CompareName('Adres') = 0) and IsPersonContainer(Node.ParentNode, Level - 1);
//if not result then DbgOut(' -P ') else DbgOut(' +P ');
end;
function IsValidPersonField(Node: TDomNode; Level: Integer; out APersonField: TPersonField): Boolean;
var
FieldIndex: TPersonField;
begin
APersonField := pfInvalid;
Result := (Level = 4) and (Node.NodeType = TEXT_NODE)
and IsPerson(Node.ParentNode.ParentNode, Level - 2);
if Result then
begin
for FieldIndex := Low(TPersonField) to High(TPersonField) do
begin
if (FieldIndex <> pfInvalid) and (Node.ParentNode.CompareName(PersonFields[FieldIndex]) = 0) then
begin
APersonField := FieldIndex;
Exit;
end;
end;
Result := False;
end;
end;
procedure ProcessNode(Node: TDOMNode; {const Ident: String;} const Level: Integer);
var
cNode: TDOMNode;
//S: String;
APersonField: TPersonField;
dummyIndex: Integer;
begin
if Node = nil then Exit; // Stops if reached a leaf
//S := '['+node.NodeName + ' L=' + IntToStr(Level);
if IsPerson(Node, Level) then
begin
FoundPerson := True;
//New Person node: first store last one (if this is not the first Person node)
//writeln('New person: current count = ',FList.Count);
if (FList.Count > 0) then TPerson(FList.Items[Count-1]).Assign(Aperson);
//then add a new person to the list
APerson.Clear;
if not AddPerson(dummyIndex) then Raise EInternalListError.Create('Fail on TAddressBook.AddPerson: Internal List Error');
end;
//S := S + '] ' + Node.NodeValue;
//writeln(Ident + S); //'['+S+node.NodeName+'] '+Node.NodeValue{Node.Attributes[0].NodeValue});
if (Node.NodeType = TEXT_NODE) then
begin
if IsValidPersonField(Node, Level, APersonField) then
begin
case APersonField of
pfName : APerson.Name := Node.NodeValue;
pfFirstName: Aperson.FirstName := Node.NodeValue;
pfPrefix: Aperson.Prefix := Node.NodeValue;
pfAddress: Aperson.Address := Node.NodeValue;
pfZIP: Aperson.ZIP := Node.NodeValue;
pfCity: Aperson.City := Node.NodeValue;
pfPhonePrivate: Aperson.PhonePrivate := Node.NodeValue;
pfPhoneWork: Aperson.PhoneWork := Node.NodeValue;
pfGSM: Aperson.GSM := Node.NodeValue;
pfFax: Aperson.Fax := Node.NodeValue;
pfEmail: Aperson.Email := Node.NodeValue;
pfWeb: Aperson.Web := Node.NodeValue;
pfRemark: Aperson.Remark := AdjustLineBreaks(Node.NodeValue);
pfMarked: Aperson.Marked := DomStrToBool(Node.NodeValue);
end;
end;
end;
cNode := Node.FirstChild;
// Processes all child nodes
while cNode <> nil do
begin
ProcessNode(cNode, {Ident + ' ',} Level + 1);
cNode := cNode.NextSibling;
end;
//writeln(Ident+'[/'+node.NodeName+'] ');
end;
begin
APerson := TPerson.Create;
FoundPerson := False;
try
iNode := XMLDoc{.DocumentElement}.FirstChild;
while iNode <> nil do
begin
ProcessNode(iNode, {'',} 0); // Recursive
iNode := iNode.NextSibling;
end;
//The last person found has not been updated in the list in ProcessNode
if FoundPerson and (Count > 0) then Persons[Count - 1].Assign(APerson);
finally
APerson.Free;
end;
end;
procedure TAddressBook.OnPersonChanged(Sender: TObject);
begin
//writeln('TAddressBook.OnPersonChanged');
FModified := True;
end;
procedure TAddressBook.LoadFromFile(const Fn: String);
var
Doc: TXMlDocument;
begin
//writeln('TBook.LoadFromFile');
FFileName := ''; //Assume failure
Clear;
//writeln(' LFF: after Clear');
try
try
//writeln(' LFF: ReadXML');
ReadXMLFile(Doc, Fn);
//writeln(' LFF: XMLToList');
XmlToList(Doc);
FModified := False;
FFileName := Fn;
except
on E: EXMLReadError do
begin
Raise EAddressBookReadError.Create(E.Message);
//writeln('LoadFromFile Error [',e.classname,']: ',e.message);
end;
end;
finally
Doc.free;
end;
end;
procedure TAddressBook.SaveToFile(const Fn: String);
var Doc: TXMLDocument;
ndRoot, ndVersion, ndCopyRight, ndWarning, ndAdressContainer, ndInfo,
ndAdress, ndName, ndFirstName, ndPrefix, ndAddress, ndZIP,
ndCity, ndPhonePrivate, ndFax, ndGSM, ndEmail, ndWeb,
ndRemark, ndMarked, ndPhoneWork: TDOMElement;
APerson: TPerson;
i: Integer;
begin
//In case of error FFileName must be cleared!
FFileName := '';
Doc := TXMLDocument.Create;
Try
ndRoot := Doc.CreateElement(AppNodes[anAddressBook]);
Doc.AppendChild(ndRoot);
//Info section
ndInfo := Doc.CreateElement(AppNodes[anInfo]);
ndRoot.AppendChild(ndInfo);
//Create TextNodes for Info section
ndVersion := Doc.CreateElement(InfoFields[ifAppVersion]);
ndVersion.AppendChild(Doc.CreateTextNode(FVersion));
ndInfo.AppendChild(ndVersion);
ndCopyRight := Doc.CreateElement(InfoFields[ifCopyRight]);
ndCopyRight.AppendChild(Doc.CreateTextNode(FCopyRight));
ndInfo.AppendChild(ndCopyRight);
ndWarning := Doc.CreateElement(InfoFields[ifWarning]);
ndWarning.AppendChild(Doc.CreateTextNode(SUtf8Notification));
ndInfo.AppendChild(ndWarning);
//Persons container
ndAdressContainer := Doc.CreateElement(AppNodes[anPersonContainer]);
ndRoot.AppendChild(ndAdressContainer);
for i := 0 to Self.Count - 1 do
begin
APerson := TPerson(FList.Items[i]);
// first child of Persons container
ndAdress := Doc.CreateElement(AppNodes[anPerson]);
TDOMElement(ndAdress).SetAttribute('Index', Pad(i, 3)); // create atributes to parent node
//Create TextNodes for Person
ndName := Doc.CreateElement(PersonFields[pfName]);
ndName.AppendChild(Doc.CreateTextNode(APerson.Name));
ndAdress.AppendChild(ndName);
ndFirstName := Doc.CreateElement(PersonFields[pfFirstName]);
ndFirstName.AppendChild(Doc.CreateTextNode(APerson.FirstName));
ndAdress.AppendChild(ndFirstName);
ndPrefix := Doc.CreateElement(PersonFields[pfPrefix]);
ndPrefix.AppendChild(Doc.CreateTextNode(APerson.Prefix));
ndAdress.AppendChild(ndPrefix);
ndAddress := Doc.CreateElement(PersonFields[pfAddress]);
ndAddress.AppendChild(Doc.CreateTextNode(APerson.Address));
ndAdress.AppendChild(ndAddress);
ndZIP := Doc.CreateElement(PersonFields[pfZIP]);
ndZIP.AppendChild(Doc.CreateTextNode(APerson.ZIP));
ndAdress.AppendChild(ndZIP);
ndCity := Doc.CreateElement(PersonFields[pfCity]);
ndCity.AppendChild(Doc.CreateTextNode(APerson.City));
ndAdress.AppendChild(ndCity);
ndPhonePrivate := Doc.CreateElement(PersonFields[pfPhonePrivate]);
ndPhonePrivate.AppendChild(Doc.CreateTextNode(APerson.PhonePrivate));
ndAdress.AppendChild(ndPhonePrivate);
ndPhoneWork := Doc.CreateElement(PersonFields[pfPhoneWork]);
ndPhoneWork.AppendChild(Doc.CreateTextNode(APerson.PhoneWork));
ndAdress.AppendChild(ndPhoneWork);
ndGSM := Doc.CreateElement(PersonFields[pfGSM]);
ndGSM.AppendChild(Doc.CreateTextNode(APerson.GSM));
ndAdress.AppendChild(ndGSM);
ndFax := Doc.CreateElement(PersonFields[pfFax]);
ndFax.AppendChild(Doc.CreateTextNode(APerson.Fax));
ndAdress.AppendChild(ndFax);
ndEmail := Doc.CreateElement(PersonFields[pfEmail]);
ndEmail.AppendChild(Doc.CreateTextNode(APerson.Email));
ndAdress.AppendChild(ndEmail);
ndWeb := Doc.CreateElement(PersonFields[pfWeb]);
ndWeb.AppendChild(Doc.CreateTextNode(APerson.Web));
ndAdress.AppendChild(ndWeb);
ndRemark := Doc.CreateElement(PersonFields[pfRemark]);
ndRemark.AppendChild(Doc.CreateTextNode(APerson.Remark));
ndAdress.AppendChild(ndRemark);
ndMarked := Doc.CreateElement(PersonFields[pfMarked]);
ndMarked.AppendChild(Doc.CreateTextNode(DomBoolStr(APerson.Marked)));
ndAdress.AppendChild(ndMarked);
{
nd? := Doc.CreateElement(PersonFields[pf?]);
nd?.AppendChild(Doc.CreateTextNode(APerson.?));
ndAdress.AppendChild(nd?);
}
ndAdressContainer.AppendChild(ndAdress);
end;
try
WriteXmlFile(Doc, Fn);
FModified := False;
FFileName := Fn;
except
on E: EStreamError do Raise EAddressBookWriteError.Create(E.Message);
end;
finally
Doc.free;
end;
end;
procedure TAddressBook.ExportToFile(const Fn: String; const MarkedOnly: Boolean = False);
begin
if Assigned(FExporter) then FExporter.ExportToFile(Fn, Self, MarkedOnly)
else Raise ENoExporter.Create(SNoExporter);
end;
procedure TAddressBook.ImportFromFile(const Fn: String);
begin
if Assigned(FImporter) then
begin
FFileName := '';
FImporter.ImportFromFile(Fn, Self);
end
else Raise ENoImporter.Create(SNoImporter);
end;
constructor TAddressBook.Create;
begin
FList := TList.Create;
FExporter := nil;
FExporter := nil;
//FCurrentIndex := -1;
FModified := False;
FCopyRight := 'Copyright 2011 by Flying Sheep Inc. & Bart Broersma';
FVersion := 'Versie 3.0.0 RC1';
end;
destructor TAddressBook.Destroy;
begin
Clear;
FList.Free;
inherited Destroy;
end;
procedure TAddressBook.Clear;
var
AFoo: TPerson;
i: Integer;
begin
//writeln('TAddressBook.Clear: FList.Count = ',FList.Count);
if (FList.Count > 0) then FModified := True;
for i := FList.Count - 1 downto 0 do
begin
//write('Freeing Person ',i,' ');
AFoo := TPerson(FList.Items[i]);
AFoo.Free;
AFoo := nil;
//writeln('OK');
end;
FList.Clear;
end;
end.
_______________________________________________
fpc-pascal maillist - fpc-pascal@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-pascal
