1 | unit UContact;
|
---|
2 |
|
---|
3 | {$mode delphi}{$H+}
|
---|
4 |
|
---|
5 | interface
|
---|
6 |
|
---|
7 | uses
|
---|
8 | Classes, SysUtils, fgl, Dialogs, UDataFile, LazUTF8, Base64;
|
---|
9 |
|
---|
10 | type
|
---|
11 | TContactsFile = class;
|
---|
12 |
|
---|
13 | TErrorEvent = procedure (Text: string; Line: Integer) of object;
|
---|
14 |
|
---|
15 | TDataType = (dtNone, dtString, dtInteger, dtDate, dtDateTime, dtImage, dtStringList);
|
---|
16 |
|
---|
17 | TContactFieldIndex = (cfNone, cfFirstName, cfMiddleName, cfLastName, cfTitleBefore,
|
---|
18 | cfTitleAfter, cfFullName,
|
---|
19 | cfTel, cfTelCell, cfTelFax, cfTelPager, cfTelHome2, cfTelVoip, cfTelMain,
|
---|
20 | cfTelHome, cfTelCellHome, cfTelFaxHome, cfTelPagerHome,
|
---|
21 | cfTelWork, cfTelCellWork, cfTelFaxWork, cfTelPagerWork,
|
---|
22 | cfEmail, cfUid, cfUrl, cfUrlHome, cfUrlWork,
|
---|
23 | cfEmailHome, cfEmailWork, cfEmailInternet, cfNickName, cfNote, cfRole, cfTitle,
|
---|
24 | cfCategories, cfOrganization, cfDepartment,
|
---|
25 | cfHomeAddressStreet, cfHomeAddressStreetExtended, cfHomeAddressCity, cfHomeAddressCountry,
|
---|
26 | cfHomeAddressPostalCode, cfHomeAddressRegion, cfHomeAddressPostOfficeBox,
|
---|
27 | cfWorkAddressStreet, cfWorkAddressStreetExtended, cfWorkAddressCity, cfWorkAddressCountry,
|
---|
28 | cfWorkAddressPostalCode, cfWorkAddressRegion, cfWorkAddressPostOfficeBox,
|
---|
29 | cfXTimesContacted, cfXLastTimeContacted, cfPhoto, cfDayOfBirth, cfRevision,
|
---|
30 | cfVersion, cfAnniversary, cfGender, cfLogo,
|
---|
31 | cfJabber, cfIcq, cfWindowsLive, cfGoogleTalk, cfAim, cfQq, cfYahoo, cfIrc,
|
---|
32 | cfSkype, cfMsn, cfGroupWise, cfGaduGadu,
|
---|
33 | cfTwitter, cfFacebook, cfInstagram, cfSnapchat, cfMatrix, cfYoutube,
|
---|
34 | cfPeerTube, cfLinkedIn, cfMastodon, cfMySpace, cfReddit);
|
---|
35 |
|
---|
36 | TContactFieldIndexes = TFPGList<TContactFieldIndex>;
|
---|
37 |
|
---|
38 | TContactFilterItem = class
|
---|
39 | FieldIndex: TContactFieldIndex;
|
---|
40 | Value: string;
|
---|
41 | end;
|
---|
42 |
|
---|
43 | { TContactFilterItems }
|
---|
44 |
|
---|
45 | TContactFilterItems = class(TFPGObjectList<TContactFilterItem>)
|
---|
46 | function AddNew(FieldIndex: TContactFieldIndex; Value: string): TContactFilterItem;
|
---|
47 | end;
|
---|
48 |
|
---|
49 | TContactFields = class;
|
---|
50 |
|
---|
51 | { TContactField }
|
---|
52 |
|
---|
53 | TContactField = class
|
---|
54 | SysName: string;
|
---|
55 | Groups: TStringArray;
|
---|
56 | NoGroups: TStringArray;
|
---|
57 | Title: string;
|
---|
58 | Index: TContactFieldIndex;
|
---|
59 | ValueIndex: Integer;
|
---|
60 | DataType: TDataType;
|
---|
61 | Alternatives: TContactFields;
|
---|
62 | function AddAlternative(Name: string; Groups: array of string; NoGroups:
|
---|
63 | array of string): TContactField;
|
---|
64 | function GroupsContain(Name: string): Boolean;
|
---|
65 | function Match(ASysName: string; AGroups: TStringArray): Boolean;
|
---|
66 | constructor Create;
|
---|
67 | destructor Destroy; override;
|
---|
68 | end;
|
---|
69 |
|
---|
70 | { TContactFields }
|
---|
71 |
|
---|
72 | TContactFields = class(TFPGObjectList<TContactField>)
|
---|
73 | function AddNew(Name: string; Groups: array of string; NoGroups: array of string;
|
---|
74 | Title: string; Index: TContactFieldIndex; DataType:
|
---|
75 | TDataType = dtNone; ValueIndex: Integer = -1): TContactField;
|
---|
76 | function GetBySysName(SysName: string): TContactField;
|
---|
77 | function GetBySysNameGroups(SysName: string; Groups: TStringArray): TContactField;
|
---|
78 | function GetByIndex(Index: TContactFieldIndex): TContactField;
|
---|
79 | procedure LoadToStrings(AItems: TStrings);
|
---|
80 | end;
|
---|
81 |
|
---|
82 | { TContactProperty }
|
---|
83 |
|
---|
84 | TContactProperty = class
|
---|
85 | private
|
---|
86 | function GetValueItem(Index: Integer): string;
|
---|
87 | procedure SetValueItem(Index: Integer; AValue: string);
|
---|
88 | public
|
---|
89 | Name: string;
|
---|
90 | Attributes: TStringList;
|
---|
91 | Value: string;
|
---|
92 | Encoding: string;
|
---|
93 | Charset: string;
|
---|
94 | procedure EvaluateAttributes;
|
---|
95 | function GetDecodedValue: string;
|
---|
96 | function GetEncodedValue: string;
|
---|
97 | function MatchNameGroups(AName: string; Groups: TStringArray;
|
---|
98 | NoGroups: TStringArray): Boolean;
|
---|
99 | procedure Assign(Source: TContactProperty);
|
---|
100 | constructor Create;
|
---|
101 | destructor Destroy; override;
|
---|
102 | property ValueItem[Index: Integer]: string read GetValueItem write SetValueItem;
|
---|
103 | end;
|
---|
104 |
|
---|
105 | { TContactProperties }
|
---|
106 |
|
---|
107 | TContactProperties = class(TFPGObjectList<TContactProperty>)
|
---|
108 | procedure Assign(Source: TContactProperties);
|
---|
109 | procedure AssignToList(List: TFPGObjectList<TObject>);
|
---|
110 | function GetByName(Name: string): TContactProperty;
|
---|
111 | function GetByNameGroups(Name: string; Groups: TStringArray;
|
---|
112 | NoGroups: TStringArray): TContactProperty;
|
---|
113 | function GetByNameGroupsMultiple(Name: string; Groups: TStringArray;
|
---|
114 | NoGroups: TStringArray): TContactProperties;
|
---|
115 | end;
|
---|
116 |
|
---|
117 | { TContact }
|
---|
118 |
|
---|
119 | TContact = class
|
---|
120 | private
|
---|
121 | FModified: Boolean;
|
---|
122 | FOnModify: TNotifyEvent;
|
---|
123 | function GetField(Index: TContactFieldIndex): string;
|
---|
124 | procedure SetField(Index: TContactFieldIndex; AValue: string);
|
---|
125 | procedure SetModified(AValue: Boolean);
|
---|
126 | procedure DoOnModify;
|
---|
127 | public
|
---|
128 | Properties: TContactProperties;
|
---|
129 | Parent: TContactsFile;
|
---|
130 | function HasField(FieldIndex: TContactFieldIndex): Boolean;
|
---|
131 | function FullNameToFileName: string;
|
---|
132 | function GetProperty(Field: TContactField): TContactProperty; overload;
|
---|
133 | function GetProperty(FieldIndex: TContactFieldIndex): TContactProperty; overload;
|
---|
134 | procedure Assign(Source: TContact);
|
---|
135 | function UpdateFrom(Source: TContact): Boolean;
|
---|
136 | constructor Create;
|
---|
137 | destructor Destroy; override;
|
---|
138 | procedure SaveToStrings(Output: TStrings);
|
---|
139 | function LoadFromStrings(Lines: TStrings; StartLine: Integer = 0): Integer;
|
---|
140 | procedure SaveToFile(FileName: string);
|
---|
141 | procedure LoadFromFile(FileName: string);
|
---|
142 | property Fields[Index: TContactFieldIndex]: string read GetField write SetField;
|
---|
143 | property Modified: Boolean read FModified write SetModified;
|
---|
144 | property OnModify: TNotifyEvent read FOnModify write FOnModify;
|
---|
145 | end;
|
---|
146 |
|
---|
147 | TGetContactEvent = function (Contact: TContact): TContact of object;
|
---|
148 |
|
---|
149 | { TContacts }
|
---|
150 |
|
---|
151 | TContacts = class(TFPGObjectList<TContact>)
|
---|
152 | ContactsFile: TContactsFile;
|
---|
153 | procedure Assign(Source: TContacts);
|
---|
154 | procedure AddContacts(Contacts: TContacts);
|
---|
155 | procedure InsertContacts(Index: Integer; Contacts: TContacts);
|
---|
156 | procedure AssignToList(List: TFPGObjectList<TObject>);
|
---|
157 | function AddNew: TContact;
|
---|
158 | function Search(Text: string; FieldIndex: TContactFieldIndex): TContact;
|
---|
159 | function CountByField(FieldIndex: TContactFieldIndex): Integer;
|
---|
160 | procedure Merge(Contact: TContact; FieldIndex: TContactFieldIndex);
|
---|
161 | function ToString: ansistring; override;
|
---|
162 | end;
|
---|
163 |
|
---|
164 | { TContactsFile }
|
---|
165 |
|
---|
166 | TContactsFile = class(TDataFile)
|
---|
167 | private
|
---|
168 | FOnError: TErrorEvent;
|
---|
169 | procedure InitFields;
|
---|
170 | procedure Error(Text: string; Line: Integer);
|
---|
171 | function NewItem(Key, Value: string): string;
|
---|
172 | public
|
---|
173 | Fields: TContactFields;
|
---|
174 | Contacts: TContacts;
|
---|
175 | function GetFileName: string; override;
|
---|
176 | function GetFileExt: string; override;
|
---|
177 | function GetFileFilter: string; override;
|
---|
178 | procedure SaveToStrings(Output: TStrings);
|
---|
179 | procedure LoadFromStrings(Lines: TStrings);
|
---|
180 | procedure SaveToFile(FileName: string); override;
|
---|
181 | procedure LoadFromFile(FileName: string); override;
|
---|
182 | constructor Create; override;
|
---|
183 | destructor Destroy; override;
|
---|
184 | property OnError: TErrorEvent read FOnError write FOnError;
|
---|
185 | end;
|
---|
186 |
|
---|
187 | const
|
---|
188 | VCardFileExt = '.vcf';
|
---|
189 |
|
---|
190 |
|
---|
191 | implementation
|
---|
192 |
|
---|
193 | uses
|
---|
194 | UQuotedPrintable, UCommon;
|
---|
195 |
|
---|
196 | const
|
---|
197 | VCardBegin = 'BEGIN:VCARD';
|
---|
198 | VCardEnd = 'END:VCARD';
|
---|
199 |
|
---|
200 | resourcestring
|
---|
201 | SVCardFile = 'vCard file';
|
---|
202 | SExpectedVCardBegin = 'Expected vCard begin';
|
---|
203 | SFieldIndexNotDefined = 'Field index not defined';
|
---|
204 | SContactHasNoParent = 'Contact has no parent';
|
---|
205 | SExpectedProperty = 'Expected contact property';
|
---|
206 | SVersion = 'Version';
|
---|
207 | SLastName = 'Last Name';
|
---|
208 | SFirstName = 'First Name';
|
---|
209 | SMiddleName = 'Middle Name';
|
---|
210 | STitleBefore = 'Title Before';
|
---|
211 | STitleAfter = 'Title After';
|
---|
212 | SFullName = 'Full Name';
|
---|
213 | STelephone = 'Telephone';
|
---|
214 | SMobilePhone = 'Mobile phone';
|
---|
215 | SPager = 'Pager';
|
---|
216 | SFax = 'Fax';
|
---|
217 | SHomePhone = 'Home phone';
|
---|
218 | SHomeMobile = 'Home mobile';
|
---|
219 | SHomeFax = 'Home fax';
|
---|
220 | SHomePager = 'Home pager';
|
---|
221 | SWorkPhone = 'Work phone';
|
---|
222 | SWorkFax = 'Work fax';
|
---|
223 | SWorkPager = 'Work pager';
|
---|
224 | SWorkMobile = 'Work mobile';
|
---|
225 | SHomePhone2 = 'Home phone 2';
|
---|
226 | SVoipPhone = 'VoIP phone';
|
---|
227 | SMainPhone = 'Main phone';
|
---|
228 | SEmail = 'E-mail';
|
---|
229 | SHomeEmail = 'Home E-mail';
|
---|
230 | SWorkEmail = 'Work E-mail';
|
---|
231 | SInternetEmail = 'Internet E-mail';
|
---|
232 | SNickName = 'Nick name';
|
---|
233 | SNote = 'Note';
|
---|
234 | SRole = 'Role';
|
---|
235 | STitle = 'Title';
|
---|
236 | SCategories = 'Categories';
|
---|
237 | SOrganization = 'Organization';
|
---|
238 | SDepartement = 'Departement';
|
---|
239 | SHomeAddressPostOfficeBox = 'Home address post office box';
|
---|
240 | SHomeAddressStreetExtended = 'Home address extended street';
|
---|
241 | SHomeAddressStreet = 'Home address street';
|
---|
242 | SHomeAddressCity = 'Home address city';
|
---|
243 | SHomeAddressRegion = 'Home address region';
|
---|
244 | SHomeAddressPostalCode = 'Home address postal code';
|
---|
245 | SHomeAddressCountry = 'Home address country';
|
---|
246 | SWorkAddressPostOfficeBox = 'Work address post office box';
|
---|
247 | SWorkAddressStreetExtended = 'Work address extended street';
|
---|
248 | SWorkAddressStreet = 'Work address street';
|
---|
249 | SWorkAddressCity = 'Work address city';
|
---|
250 | SWorkAddressRegion = 'Work address region';
|
---|
251 | SWorkAddressPostalCode = 'Work address postal code';
|
---|
252 | SWorkAddressCountry = 'Work address country';
|
---|
253 | STimesContacted = 'Times Contacted';
|
---|
254 | SLastTimeContacted = 'Last Time Contacted';
|
---|
255 | SPhoto = 'Photo';
|
---|
256 | SLogo = 'Logo';
|
---|
257 | SJabber = 'Jabber';
|
---|
258 | SDayOfBirth = 'Day of birth';
|
---|
259 | SAnniversary = 'Anniversary';
|
---|
260 | SRevision = 'Revision';
|
---|
261 | SUniqueIdentifier = 'Unique identifier';
|
---|
262 | SWebAddress = 'Web address';
|
---|
263 | SWebAddressHome = 'Web address home';
|
---|
264 | SWebAddressWork = 'Web address work';
|
---|
265 | SGender = 'Gender';
|
---|
266 | // Chat
|
---|
267 | SMsn = 'MSN';
|
---|
268 | SGoogleTalk = 'Google Talk';
|
---|
269 | SWindowsLive = 'Windows Live';
|
---|
270 | SAim = 'AIM';
|
---|
271 | SQq = 'QQ';
|
---|
272 | SIrc = 'IRC';
|
---|
273 | SIcq = 'ICQ';
|
---|
274 | SYahoo = 'Yahoo!';
|
---|
275 | SSkype = 'Skype';
|
---|
276 | SMatrix = 'Matrix';
|
---|
277 | SGroupWise = 'GroupWise';
|
---|
278 | SGaduGadu = 'GaduGadu';
|
---|
279 | // Social
|
---|
280 | STwitter = 'Twitter';
|
---|
281 | SFacebook = 'Facebook';
|
---|
282 | SInstagram = 'Instagram';
|
---|
283 | SMastodon = 'Mastodon';
|
---|
284 | SSnapchat = 'Snapchat';
|
---|
285 | SLinkedIn = 'LinkedIn';
|
---|
286 | SYouTube = 'YouTube';
|
---|
287 | SPeerTube = 'PeerTube';
|
---|
288 | SReddit = 'Reddit';
|
---|
289 | SMySpace = 'MySpace';
|
---|
290 |
|
---|
291 | function GetNext(var Text: string; Separator: string): string;
|
---|
292 | begin
|
---|
293 | if Pos(Separator, Text) > 0 then begin
|
---|
294 | Result := Copy(Text, 1, Pos(Separator, Text) - 1);
|
---|
295 | Delete(Text, 1, Length(Result) + Length(Separator));
|
---|
296 | end else begin
|
---|
297 | Result := Text;
|
---|
298 | Text := '';
|
---|
299 | end;
|
---|
300 | end;
|
---|
301 |
|
---|
302 | function IsAsciiString(Text: string): Boolean;
|
---|
303 | var
|
---|
304 | I: Integer;
|
---|
305 | begin
|
---|
306 | Result := True;
|
---|
307 | for I := 1 to Length(Text) do
|
---|
308 | if Ord(Text[I]) > 128 then begin
|
---|
309 | Result := False;
|
---|
310 | Break;
|
---|
311 | end;
|
---|
312 | end;
|
---|
313 |
|
---|
314 | function EndsWith(Text, What: string): Boolean;
|
---|
315 | begin
|
---|
316 | Result := Copy(Text, Length(Text) - Length(What) + 1, MaxInt) = What;
|
---|
317 | end;
|
---|
318 |
|
---|
319 | function EncodeEscaped(Text: string): string;
|
---|
320 | var
|
---|
321 | I: Integer;
|
---|
322 | O: Integer;
|
---|
323 | begin
|
---|
324 | Result := '';
|
---|
325 | I := 1;
|
---|
326 | O := 1;
|
---|
327 | SetLength(Result, Length(Text)); // Preallocate string
|
---|
328 | while I <= Length(Text) do begin
|
---|
329 | if Text[I] in [',', '\', ';'] then begin
|
---|
330 | Result[O] := '\';
|
---|
331 | Inc(O);
|
---|
332 | Result[O] := Text[I];
|
---|
333 | SetLength(Result, Length(Result) + 1);
|
---|
334 | Inc(O);
|
---|
335 | end else begin
|
---|
336 | Result[O] := Text[I];
|
---|
337 | Inc(O);
|
---|
338 | end;
|
---|
339 | Inc(I);
|
---|
340 | end;
|
---|
341 | SetLength(Result, O - 1);
|
---|
342 | end;
|
---|
343 |
|
---|
344 | function DecodeEscaped(Text: string): string;
|
---|
345 | var
|
---|
346 | I: Integer;
|
---|
347 | O: Integer;
|
---|
348 | Escaped: Boolean;
|
---|
349 | begin
|
---|
350 | Result := '';
|
---|
351 | I := 1;
|
---|
352 | O := 1;
|
---|
353 | Escaped := False;
|
---|
354 | SetLength(Result, Length(Text)); // Preallocate string
|
---|
355 | while I <= Length(Text) do begin
|
---|
356 | if Escaped then begin
|
---|
357 | Result[O] := Text[I];
|
---|
358 | Inc(O);
|
---|
359 | Escaped := False;
|
---|
360 | end else begin
|
---|
361 | if Text[I] = '\' then begin
|
---|
362 | Escaped := True;
|
---|
363 | end else begin
|
---|
364 | Result[O] := Text[I];
|
---|
365 | Inc(O);
|
---|
366 | end;
|
---|
367 | end;
|
---|
368 | Inc(I);
|
---|
369 | end;
|
---|
370 | SetLength(Result, O - 1);
|
---|
371 | end;
|
---|
372 |
|
---|
373 | { TContactFilterItems }
|
---|
374 |
|
---|
375 | function TContactFilterItems.AddNew(FieldIndex: TContactFieldIndex;
|
---|
376 | Value: string): TContactFilterItem;
|
---|
377 | begin
|
---|
378 | Result := TContactFilterItem.Create;
|
---|
379 | Result.FieldIndex := FieldIndex;
|
---|
380 | Result.Value := Value;
|
---|
381 | Add(Result);
|
---|
382 | end;
|
---|
383 |
|
---|
384 | { TContactField }
|
---|
385 |
|
---|
386 | function TContactField.AddAlternative(Name: string; Groups: array of string;
|
---|
387 | NoGroups: array of string): TContactField;
|
---|
388 | begin
|
---|
389 | Result := Alternatives.AddNew(Name, Groups, NoGroups, Title, Index, DataType, ValueIndex);
|
---|
390 | end;
|
---|
391 |
|
---|
392 | function TContactField.GroupsContain(Name: string): Boolean;
|
---|
393 | var
|
---|
394 | I: Integer;
|
---|
395 | begin
|
---|
396 | Result := False;
|
---|
397 | for I := 0 to Length(Groups) - 1 do
|
---|
398 | if Groups[I] = Name then begin
|
---|
399 | Result := True;
|
---|
400 | Break;
|
---|
401 | end;
|
---|
402 | end;
|
---|
403 |
|
---|
404 | function TContactField.Match(ASysName: string; AGroups: TStringArray): Boolean;
|
---|
405 | var
|
---|
406 | I: Integer;
|
---|
407 | begin
|
---|
408 | Result := ASysName = SysName;
|
---|
409 | if Result then begin
|
---|
410 | for I := 0 to Length(AGroups) - 1 do begin
|
---|
411 | if not GroupsContain(AGroups[I]) then begin
|
---|
412 | Result := False;
|
---|
413 | Break;
|
---|
414 | end;
|
---|
415 | end;
|
---|
416 | end;
|
---|
417 | end;
|
---|
418 |
|
---|
419 | constructor TContactField.Create;
|
---|
420 | begin
|
---|
421 | Alternatives := TContactFields.Create;
|
---|
422 | end;
|
---|
423 |
|
---|
424 | destructor TContactField.Destroy;
|
---|
425 | begin
|
---|
426 | FreeAndNil(Alternatives);
|
---|
427 | inherited;
|
---|
428 | end;
|
---|
429 |
|
---|
430 | { TContactProperties }
|
---|
431 |
|
---|
432 | procedure TContactProperties.Assign(Source: TContactProperties);
|
---|
433 | var
|
---|
434 | I: Integer;
|
---|
435 | begin
|
---|
436 | while Count < Source.Count do
|
---|
437 | Add(TContactProperty.Create);
|
---|
438 | while Count > Source.Count do
|
---|
439 | Delete(Count - 1);
|
---|
440 | for I := 0 to Count - 1 do
|
---|
441 | Items[I].Assign(Source.Items[I]);
|
---|
442 | end;
|
---|
443 |
|
---|
444 | procedure TContactProperties.AssignToList(List: TFPGObjectList<TObject>);
|
---|
445 | var
|
---|
446 | I: Integer;
|
---|
447 | begin
|
---|
448 | while List.Count > Count do List.Delete(List.Count - 1);
|
---|
449 | while List.Count < Count do List.Add(nil);
|
---|
450 | for I := 0 to Count - 1 do
|
---|
451 | List[I] := Items[I];
|
---|
452 | end;
|
---|
453 |
|
---|
454 | function TContactProperties.GetByName(Name: string): TContactProperty;
|
---|
455 | var
|
---|
456 | I: Integer;
|
---|
457 | begin
|
---|
458 | I := 0;
|
---|
459 | while (I < Count) and (Items[I].Name <> Name) and (not EndsWith(Items[I].Name, '.' + Name)) do Inc(I);
|
---|
460 | if I < Count then Result := Items[I]
|
---|
461 | else Result := nil;
|
---|
462 | end;
|
---|
463 |
|
---|
464 | function TContactProperties.GetByNameGroups(Name: string; Groups: TStringArray;
|
---|
465 | NoGroups: TStringArray): TContactProperty;
|
---|
466 | var
|
---|
467 | I: Integer;
|
---|
468 | begin
|
---|
469 | I := 0;
|
---|
470 | while (I < Count) and not Items[I].MatchNameGroups(Name, Groups, NoGroups) do Inc(I);
|
---|
471 | if I < Count then Result := Items[I]
|
---|
472 | else Result := nil;
|
---|
473 | end;
|
---|
474 |
|
---|
475 | function TContactProperties.GetByNameGroupsMultiple(Name: string;
|
---|
476 | Groups: TStringArray; NoGroups: TStringArray): TContactProperties;
|
---|
477 | var
|
---|
478 | I: Integer;
|
---|
479 | begin
|
---|
480 | Result := TContactProperties.Create(False);
|
---|
481 | for I := 0 to Count - 1 do
|
---|
482 | if Items[I].MatchNameGroups(Name, Groups, NoGroups) then
|
---|
483 | Result.Add(Items[I]);
|
---|
484 | end;
|
---|
485 |
|
---|
486 | { TContactProperty }
|
---|
487 |
|
---|
488 | function TContactProperty.GetValueItem(Index: Integer): string;
|
---|
489 | var
|
---|
490 | List: TStringList;
|
---|
491 | begin
|
---|
492 | List := TStringList.Create;
|
---|
493 | try
|
---|
494 | List.Delimiter := ';';
|
---|
495 | List.NameValueSeparator := '=';
|
---|
496 | List.StrictDelimiter := True;
|
---|
497 | List.DelimitedText := Value;
|
---|
498 | if Index < List.Count then
|
---|
499 | Result := List.Strings[Index]
|
---|
500 | else Result := '';
|
---|
501 | finally
|
---|
502 | List.Free;
|
---|
503 | end;
|
---|
504 | end;
|
---|
505 |
|
---|
506 | procedure TContactProperty.SetValueItem(Index: Integer; AValue: string);
|
---|
507 | var
|
---|
508 | List: TStringList;
|
---|
509 | begin
|
---|
510 | List := TStringList.Create;
|
---|
511 | try
|
---|
512 | List.Delimiter := ';';
|
---|
513 | List.NameValueSeparator := '=';
|
---|
514 | List.StrictDelimiter := True;
|
---|
515 | List.DelimitedText := Value;
|
---|
516 |
|
---|
517 | // Extend subitems count
|
---|
518 | while List.Count <= Index do
|
---|
519 | List.Add('');
|
---|
520 |
|
---|
521 | List.Strings[Index] := AValue;
|
---|
522 |
|
---|
523 | // Remove empty items
|
---|
524 | while (List.Count > 0) and (List.Strings[List.Count - 1] = '') do
|
---|
525 | List.Delete(List.Count - 1);
|
---|
526 |
|
---|
527 | Value := List.DelimitedText;
|
---|
528 | finally
|
---|
529 | List.Free;
|
---|
530 | end;
|
---|
531 | end;
|
---|
532 |
|
---|
533 | procedure TContactProperty.EvaluateAttributes;
|
---|
534 | var
|
---|
535 | I: Integer;
|
---|
536 | begin
|
---|
537 | if Attributes.IndexOf('BASE64') <> -1 then begin
|
---|
538 | Encoding := 'BASE64';
|
---|
539 | Value := GetDecodedValue;
|
---|
540 | end else
|
---|
541 | if Attributes.IndexOfName('ENCODING') <> -1 then begin
|
---|
542 | Encoding := Attributes.Values['ENCODING'];
|
---|
543 | if (Encoding = 'B') or (Encoding = 'b') then Encoding := 'BASE64';
|
---|
544 | if (Encoding = 'Q') or (Encoding = 'q') then Encoding := 'QUOTED-PRINTABLE';
|
---|
545 | if (Encoding = 'QUOTED-PRINTABLE') or (Encoding = 'BASE64') then begin
|
---|
546 | Value := GetDecodedValue;
|
---|
547 | Attributes.Delete(Attributes.IndexOfName('ENCODING'));
|
---|
548 | end else
|
---|
549 | end else Encoding := '';
|
---|
550 |
|
---|
551 | if Attributes.IndexOfName('CHARSET') <> -1 then
|
---|
552 | Charset := Attributes.Values['CHARSET']
|
---|
553 | else Charset := '';
|
---|
554 |
|
---|
555 | // Simplify TYPE attribute from TYPE=VALUE into VALUE
|
---|
556 | for I := 0 to Attributes.Count - 1 do begin
|
---|
557 | if Attributes.Names[I] = 'TYPE' then
|
---|
558 | Attributes.Strings[I] := Attributes.Values['TYPE'];
|
---|
559 | if Attributes.Names[I] = 'type' then
|
---|
560 | Attributes.Strings[I] := Attributes.Values['type'];
|
---|
561 | end;
|
---|
562 | end;
|
---|
563 |
|
---|
564 | function TContactProperty.GetDecodedValue: string;
|
---|
565 | begin
|
---|
566 | if Encoding = 'BASE64' then begin
|
---|
567 | Result := DecodeStringBase64(Value);
|
---|
568 | end else
|
---|
569 | if Encoding = 'QUOTED-PRINTABLE' then begin
|
---|
570 | Result := DecodeQuotedPrintable(Value);
|
---|
571 | end
|
---|
572 | else Result := '';
|
---|
573 | end;
|
---|
574 |
|
---|
575 | function TContactProperty.GetEncodedValue: string;
|
---|
576 | begin
|
---|
577 | if Encoding = 'BASE64' then begin
|
---|
578 | Result := EncodeStringBase64(Value);
|
---|
579 | end else
|
---|
580 | if Encoding = 'QUOTED-PRINTABLE' then begin
|
---|
581 | Result := EncodeQuotedPrintable(Value);
|
---|
582 | end
|
---|
583 | else Result := '';
|
---|
584 | end;
|
---|
585 |
|
---|
586 | function TContactProperty.MatchNameGroups(AName: string; Groups: TStringArray;
|
---|
587 | NoGroups: TStringArray): Boolean;
|
---|
588 | var
|
---|
589 | I: Integer;
|
---|
590 | begin
|
---|
591 | Result := (Name = AName) or EndsWith(Name, '.' + AName);
|
---|
592 | if Result and (Length(Groups) > 0) then begin
|
---|
593 | for I := 0 to Length(Groups) - 1 do
|
---|
594 | if (Attributes.IndexOf(Groups[I]) = -1) and
|
---|
595 | (Attributes.IndexOf('TYPE=' + Groups[I]) = -1) then begin
|
---|
596 | Result := False;
|
---|
597 | Break;
|
---|
598 | end;
|
---|
599 | end;
|
---|
600 | if Result and (Length(NoGroups) > 0) then begin
|
---|
601 | for I := 0 to Length(NoGroups) - 1 do
|
---|
602 | if (Attributes.IndexOf(NoGroups[I]) <> -1) or
|
---|
603 | (Attributes.IndexOf('TYPE=' + NoGroups[I]) <> -1) then begin
|
---|
604 | Result := False;
|
---|
605 | Break;
|
---|
606 | end;
|
---|
607 | end;
|
---|
608 | end;
|
---|
609 |
|
---|
610 | procedure TContactProperty.Assign(Source: TContactProperty);
|
---|
611 | begin
|
---|
612 | Name := Source.Name;
|
---|
613 | Attributes.Assign(Source.Attributes);
|
---|
614 | Value := Source.Value;
|
---|
615 | Encoding := Source.Encoding;
|
---|
616 | Charset := Source.Charset;
|
---|
617 | end;
|
---|
618 |
|
---|
619 | constructor TContactProperty.Create;
|
---|
620 | begin
|
---|
621 | Attributes := TStringList.Create;
|
---|
622 | Attributes.Delimiter := ';';
|
---|
623 | Attributes.NameValueSeparator := '=';
|
---|
624 | Attributes.StrictDelimiter := True;
|
---|
625 | end;
|
---|
626 |
|
---|
627 | destructor TContactProperty.Destroy;
|
---|
628 | begin
|
---|
629 | FreeAndNil(Attributes);
|
---|
630 | inherited;
|
---|
631 | end;
|
---|
632 |
|
---|
633 | { TContacts }
|
---|
634 |
|
---|
635 | procedure TContacts.Assign(Source: TContacts);
|
---|
636 | var
|
---|
637 | I: Integer;
|
---|
638 | begin
|
---|
639 | while Count < Source.Count do
|
---|
640 | Add(TContact.Create);
|
---|
641 | while Count > Source.Count do
|
---|
642 | Delete(Count - 1);
|
---|
643 | for I := 0 to Count - 1 do begin
|
---|
644 | Items[I].Assign(Source.Items[I]);
|
---|
645 | Items[I].Parent := ContactsFile;
|
---|
646 | end;
|
---|
647 | end;
|
---|
648 |
|
---|
649 | procedure TContacts.AddContacts(Contacts: TContacts);
|
---|
650 | var
|
---|
651 | I: Integer;
|
---|
652 | NewContact: TContact;
|
---|
653 | begin
|
---|
654 | for I := 0 to Contacts.Count - 1 do begin
|
---|
655 | NewContact := TContact.Create;
|
---|
656 | NewContact.Assign(Contacts[I]);
|
---|
657 | NewContact.Parent := ContactsFile;
|
---|
658 | Add(NewContact);
|
---|
659 | end;
|
---|
660 | end;
|
---|
661 |
|
---|
662 | procedure TContacts.InsertContacts(Index: Integer; Contacts: TContacts);
|
---|
663 | var
|
---|
664 | I: Integer;
|
---|
665 | NewContact: TContact;
|
---|
666 | begin
|
---|
667 | for I := 0 to Contacts.Count - 1 do begin
|
---|
668 | NewContact := TContact.Create;
|
---|
669 | NewContact.Assign(Contacts[I]);
|
---|
670 | NewContact.Parent := ContactsFile;
|
---|
671 | Insert(Index, NewContact);
|
---|
672 | Inc(Index);
|
---|
673 | end;
|
---|
674 | end;
|
---|
675 |
|
---|
676 | procedure TContacts.AssignToList(List: TFPGObjectList<TObject>);
|
---|
677 | var
|
---|
678 | I: Integer;
|
---|
679 | begin
|
---|
680 | while List.Count > Count do List.Delete(List.Count - 1);
|
---|
681 | while List.Count < Count do List.Add(nil);
|
---|
682 | for I := 0 to Count - 1 do
|
---|
683 | List[I] := Items[I];
|
---|
684 | end;
|
---|
685 |
|
---|
686 | function TContacts.AddNew: TContact;
|
---|
687 | begin
|
---|
688 | Result := TContact.Create;
|
---|
689 | Result.Parent := ContactsFile;
|
---|
690 | Add(Result);
|
---|
691 | end;
|
---|
692 |
|
---|
693 | function TContacts.Search(Text: string; FieldIndex: TContactFieldIndex): TContact;
|
---|
694 | var
|
---|
695 | I: Integer;
|
---|
696 | begin
|
---|
697 | Result := nil;
|
---|
698 | for I := 0 to Count - 1 do
|
---|
699 | if Items[I].Fields[FieldIndex] = Text then begin
|
---|
700 | Result := Items[I];
|
---|
701 | Break;
|
---|
702 | end;
|
---|
703 | end;
|
---|
704 |
|
---|
705 | function TContacts.CountByField(FieldIndex: TContactFieldIndex): Integer;
|
---|
706 | var
|
---|
707 | I: Integer;
|
---|
708 | begin
|
---|
709 | Result := 0;
|
---|
710 | for I := 0 to Count - 1 do
|
---|
711 | if Items[I].HasField(FieldIndex) then
|
---|
712 | Inc(Result);
|
---|
713 | end;
|
---|
714 |
|
---|
715 | procedure TContacts.Merge(Contact: TContact; FieldIndex: TContactFieldIndex);
|
---|
716 | var
|
---|
717 | NewContact: TContact;
|
---|
718 | begin
|
---|
719 | NewContact := Search(Contact.Fields[FieldIndex], FieldIndex);
|
---|
720 | if Assigned(NewContact) then begin
|
---|
721 | NewContact.UpdateFrom(Contact);
|
---|
722 | end else begin
|
---|
723 | NewContact := TContact.Create;
|
---|
724 | NewContact.Assign(Contact);
|
---|
725 | NewContact.Parent := ContactsFile;
|
---|
726 | Add(NewContact);
|
---|
727 | end;
|
---|
728 | end;
|
---|
729 |
|
---|
730 | function TContacts.ToString: ansistring;
|
---|
731 | var
|
---|
732 | I: Integer;
|
---|
733 | begin
|
---|
734 | Result := '';
|
---|
735 | for I := 0 to Count - 1 do begin
|
---|
736 | if I > 0 then Result := Result + ', ';
|
---|
737 | Result := Result + Items[I].Fields[cfFullName];
|
---|
738 | end;
|
---|
739 | end;
|
---|
740 |
|
---|
741 | { TContactFields }
|
---|
742 |
|
---|
743 | function TContactFields.AddNew(Name: string; Groups: array of string;
|
---|
744 | NoGroups: array of string; Title: string; Index: TContactFieldIndex;
|
---|
745 | DataType: TDataType = dtNone; ValueIndex: Integer = -1): TContactField;
|
---|
746 | var
|
---|
747 | I: Integer;
|
---|
748 | begin
|
---|
749 | Result := TContactField.Create;
|
---|
750 | Result.SysName := Name;
|
---|
751 | SetLength(Result.Groups, Length(Groups));
|
---|
752 | for I := 0 to Length(Groups) - 1 do
|
---|
753 | Result.Groups[I] := Groups[I];
|
---|
754 | SetLength(Result.NoGroups, Length(NoGroups));
|
---|
755 | for I := 0 to Length(NoGroups) - 1 do
|
---|
756 | Result.NoGroups[I] := NoGroups[I];
|
---|
757 | Result.Title := Title;
|
---|
758 | Result.Index := Index;
|
---|
759 | Result.ValueIndex := ValueIndex;
|
---|
760 | Result.DataType := DataType;
|
---|
761 | Add(Result);
|
---|
762 | end;
|
---|
763 |
|
---|
764 | function TContactFields.GetBySysName(SysName: string): TContactField;
|
---|
765 | var
|
---|
766 | I: Integer;
|
---|
767 | begin
|
---|
768 | I := 0;
|
---|
769 | while (I < Count) and (Items[I].SysName <> SysName) do Inc(I);
|
---|
770 | if I < Count then Result := Items[I]
|
---|
771 | else Result := nil;
|
---|
772 | end;
|
---|
773 |
|
---|
774 | function TContactFields.GetBySysNameGroups(SysName: string; Groups: TStringArray
|
---|
775 | ): TContactField;
|
---|
776 | var
|
---|
777 | I: Integer;
|
---|
778 | begin
|
---|
779 | I := 0;
|
---|
780 | while (I < Count) and not Items[I].Match(SysName, Groups) do Inc(I);
|
---|
781 | if I < Count then Result := Items[I]
|
---|
782 | else Result := nil;
|
---|
783 | end;
|
---|
784 |
|
---|
785 | function TContactFields.GetByIndex(Index: TContactFieldIndex): TContactField;
|
---|
786 | var
|
---|
787 | I: Integer;
|
---|
788 | begin
|
---|
789 | I := 0;
|
---|
790 | while (I < Count) and (Items[I].Index <> Index) do Inc(I);
|
---|
791 | if I < Count then Result := Items[I]
|
---|
792 | else Result := nil;
|
---|
793 | end;
|
---|
794 |
|
---|
795 | procedure TContactFields.LoadToStrings(AItems: TStrings);
|
---|
796 | var
|
---|
797 | I: Integer;
|
---|
798 | begin
|
---|
799 | AItems.BeginUpdate;
|
---|
800 | try
|
---|
801 | while AItems.Count < Count do AItems.Add('');
|
---|
802 | while AItems.Count > Count do AItems.Delete(AItems.Count - 1);
|
---|
803 | for I := 0 to Count - 1 do begin
|
---|
804 | AItems.Objects[I] := Items[I];
|
---|
805 | AItems[I] := Items[I].Title;
|
---|
806 | end;
|
---|
807 | SortStrings(AItems);
|
---|
808 | finally
|
---|
809 | AItems.EndUpdate;
|
---|
810 | end;
|
---|
811 | end;
|
---|
812 |
|
---|
813 | { TContact }
|
---|
814 |
|
---|
815 | function TContact.GetField(Index: TContactFieldIndex): string;
|
---|
816 | var
|
---|
817 | Prop: TContactProperty;
|
---|
818 | Field: TContactField;
|
---|
819 | begin
|
---|
820 | if not Assigned(Parent) then raise Exception.Create(SContactHasNoParent);
|
---|
821 | Field := Parent.Fields.GetByIndex(Index);
|
---|
822 | if Assigned(Field) then begin
|
---|
823 | Prop := GetProperty(Field);
|
---|
824 | if Assigned(Prop) then begin
|
---|
825 | Field := Parent.Fields.GetByIndex(Index);
|
---|
826 | if Field.ValueIndex <> -1 then begin
|
---|
827 | Result := DecodeEscaped(Prop.ValueItem[Field.ValueIndex])
|
---|
828 | end else Result := Prop.Value;
|
---|
829 | end else Result := '';
|
---|
830 | end else raise Exception.Create(SFieldIndexNotDefined);
|
---|
831 | end;
|
---|
832 |
|
---|
833 | procedure TContact.SetField(Index: TContactFieldIndex; AValue: string);
|
---|
834 | var
|
---|
835 | Prop: TContactProperty;
|
---|
836 | Field: TContactField;
|
---|
837 | I: Integer;
|
---|
838 | begin
|
---|
839 | if not Assigned(Parent) then raise Exception.Create(SContactHasNoParent);
|
---|
840 | Field := Parent.Fields.GetByIndex(Index);
|
---|
841 | if Assigned(Field) then begin
|
---|
842 | Prop := GetProperty(Field);
|
---|
843 | if (not Assigned(Prop)) and (AValue <> '') then begin
|
---|
844 | Prop := TContactProperty.Create;
|
---|
845 | Prop.Name := Field.SysName;
|
---|
846 | for I := 0 to Length(Field.Groups) - 1 do
|
---|
847 | Prop.Attributes.Add(Field.Groups[I]);
|
---|
848 | Properties.Add(Prop);
|
---|
849 | end;
|
---|
850 | if Assigned(Prop) then begin
|
---|
851 | if Field.ValueIndex <> -1 then begin
|
---|
852 | Prop.ValueItem[Field.ValueIndex] := EncodeEscaped(AValue);
|
---|
853 | end else Prop.Value := AValue;
|
---|
854 |
|
---|
855 | // Remove if empty
|
---|
856 | if Prop.Value = '' then begin
|
---|
857 | Properties.Remove(Prop);
|
---|
858 | end;
|
---|
859 | end;
|
---|
860 | Modified := True;
|
---|
861 | end else raise Exception.Create(SFieldIndexNotDefined);
|
---|
862 | end;
|
---|
863 |
|
---|
864 | procedure TContact.SetModified(AValue: Boolean);
|
---|
865 | begin
|
---|
866 | if FModified = AValue then Exit;
|
---|
867 | FModified := AValue;
|
---|
868 | DoOnModify;
|
---|
869 | end;
|
---|
870 |
|
---|
871 | procedure TContact.DoOnModify;
|
---|
872 | begin
|
---|
873 | if Assigned(FOnModify) then FOnModify(Self);
|
---|
874 | end;
|
---|
875 |
|
---|
876 | function TContact.HasField(FieldIndex: TContactFieldIndex): Boolean;
|
---|
877 | var
|
---|
878 | Field: TContactField;
|
---|
879 | begin
|
---|
880 | if not Assigned(Parent) then raise Exception.Create(SContactHasNoParent);
|
---|
881 | Field := Parent.Fields.GetByIndex(FieldIndex);
|
---|
882 | if Assigned(Field) then begin
|
---|
883 | Result := Assigned(GetProperty(Field));
|
---|
884 | end else raise Exception.Create(SFieldIndexNotDefined);
|
---|
885 | end;
|
---|
886 |
|
---|
887 | function TContact.FullNameToFileName: string;
|
---|
888 | var
|
---|
889 | I: Integer;
|
---|
890 | begin
|
---|
891 | Result := Fields[cfFullName];
|
---|
892 | for I := 1 to Length(Result) do begin
|
---|
893 | if Result[I] in [':', '/', '\', '.', '"', '*', '|', '?', '<', '>'] then
|
---|
894 | Result[I] := '_';
|
---|
895 | end;
|
---|
896 | end;
|
---|
897 |
|
---|
898 | function TContact.GetProperty(Field: TContactField): TContactProperty;
|
---|
899 | var
|
---|
900 | I: Integer;
|
---|
901 | begin
|
---|
902 | Result := Properties.GetByNameGroups(Field.SysName, Field.Groups, Field.NoGroups);
|
---|
903 | I := 0;
|
---|
904 | while (not Assigned(Result)) and (I < Field.Alternatives.Count) do begin
|
---|
905 | Result := Properties.GetByNameGroups(Field.Alternatives[I].SysName,
|
---|
906 | Field.Alternatives[I].Groups, Field.Alternatives[I].NoGroups);
|
---|
907 | if Assigned(Result) then Break;
|
---|
908 | Inc(I);
|
---|
909 | end;
|
---|
910 | end;
|
---|
911 |
|
---|
912 | function TContact.GetProperty(FieldIndex: TContactFieldIndex): TContactProperty;
|
---|
913 | var
|
---|
914 | Field: TContactField;
|
---|
915 | begin
|
---|
916 | if not Assigned(Parent) then raise Exception.Create(SContactHasNoParent);
|
---|
917 | Field := Parent.Fields.GetByIndex(FieldIndex);
|
---|
918 | if Assigned(Field) then begin
|
---|
919 | Result := GetProperty(Field);
|
---|
920 | end else Result := nil;
|
---|
921 | end;
|
---|
922 |
|
---|
923 | procedure TContact.Assign(Source: TContact);
|
---|
924 | begin
|
---|
925 | Properties.Assign(Source.Properties);
|
---|
926 | FModified := Source.FModified;
|
---|
927 | end;
|
---|
928 |
|
---|
929 | function TContact.UpdateFrom(Source: TContact): Boolean;
|
---|
930 | var
|
---|
931 | I: Integer;
|
---|
932 | begin
|
---|
933 | if not Assigned(Parent) then raise Exception.Create(SContactHasNoParent);
|
---|
934 | Result := False;
|
---|
935 | for I := 0 to Parent.Fields.Count - 1 do begin
|
---|
936 | if (Source.Fields[Parent.Fields[I].Index] <> '') and
|
---|
937 | (Source.Fields[Parent.Fields[I].Index] <>
|
---|
938 | Fields[Parent.Fields[I].Index]) then begin
|
---|
939 | Result := True;
|
---|
940 | Fields[Parent.Fields[I].Index] := Source.Fields[Parent.Fields[I].Index];
|
---|
941 | end;
|
---|
942 | end;
|
---|
943 | end;
|
---|
944 |
|
---|
945 | constructor TContact.Create;
|
---|
946 | begin
|
---|
947 | Properties := TContactProperties.Create;
|
---|
948 | end;
|
---|
949 |
|
---|
950 | destructor TContact.Destroy;
|
---|
951 | begin
|
---|
952 | FreeAndNil(Properties);
|
---|
953 | inherited;
|
---|
954 | end;
|
---|
955 |
|
---|
956 | procedure TContact.SaveToStrings(Output: TStrings);
|
---|
957 | var
|
---|
958 | I: Integer;
|
---|
959 | NameText: string;
|
---|
960 | Value2: string;
|
---|
961 | LineIndex: Integer;
|
---|
962 | OutText: string;
|
---|
963 | LinePrefix: string;
|
---|
964 | CutLength: Integer;
|
---|
965 | const
|
---|
966 | MaxLineLength = 73;
|
---|
967 | begin
|
---|
968 | with Output do begin
|
---|
969 | Add(VCardBegin);
|
---|
970 | for I := 0 to Properties.Count - 1 do
|
---|
971 | with Properties[I] do begin
|
---|
972 | NameText := Name;
|
---|
973 | if Attributes.Count > 0 then
|
---|
974 | NameText := NameText + ';' + Attributes.DelimitedText;
|
---|
975 | if Encoding <> '' then begin
|
---|
976 | Value2 := GetEncodedValue;
|
---|
977 | NameText := NameText + ';ENCODING=' + Encoding;
|
---|
978 | end else Value2 := Value;
|
---|
979 | if Pos(LineEnding, Value2) > 0 then begin
|
---|
980 | Add(NameText + ':' + GetNext(Value2, LineEnding));
|
---|
981 | while Pos(LineEnding, Value2) > 0 do begin
|
---|
982 | Add(' ' + GetNext(Value2, LineEnding));
|
---|
983 | end;
|
---|
984 | Add(' ' + GetNext(Value2, LineEnding));
|
---|
985 | Add('');
|
---|
986 | end else begin
|
---|
987 | OutText := NameText + ':' + Value2;
|
---|
988 | LineIndex := 0;
|
---|
989 | LinePrefix := '';
|
---|
990 | while True do begin
|
---|
991 | if Length(OutText) > MaxLineLength then begin
|
---|
992 | CutLength := MaxLineLength;
|
---|
993 | if Encoding = 'QUOTED-PRINTABLE' then begin
|
---|
994 | // Do not cut encoded items
|
---|
995 | if ((CutLength - 2) >= 1) and (OutText[CutLength - 2] = '=') then
|
---|
996 | Dec(CutLength, 2)
|
---|
997 | else if ((CutLength - 1) >= 1) and (OutText[CutLength - 1] = '=') then
|
---|
998 | Dec(CutLength, 1);
|
---|
999 | end;
|
---|
1000 | Add(LinePrefix + Copy(OutText, 1, CutLength));
|
---|
1001 | LinePrefix := ' ';
|
---|
1002 | System.Delete(OutText, 1, CutLength);
|
---|
1003 | Inc(LineIndex);
|
---|
1004 | Continue;
|
---|
1005 | end else begin
|
---|
1006 | Add(LinePrefix + OutText);
|
---|
1007 | Break;
|
---|
1008 | end;
|
---|
1009 | end;
|
---|
1010 | if LinePrefix <> '' then Add('');
|
---|
1011 | end;
|
---|
1012 | end;
|
---|
1013 | Add(VCardEnd);
|
---|
1014 | end;
|
---|
1015 | end;
|
---|
1016 |
|
---|
1017 | function TContact.LoadFromStrings(Lines: TStrings; StartLine: Integer = 0): Integer;
|
---|
1018 | type
|
---|
1019 | TParseState = (psNone, psInside, psFinished);
|
---|
1020 | var
|
---|
1021 | ParseState: TParseState;
|
---|
1022 | Line: string;
|
---|
1023 | Value: string;
|
---|
1024 | I: Integer;
|
---|
1025 | NewProperty: TContactProperty;
|
---|
1026 | CommandPart: string;
|
---|
1027 | Names: string;
|
---|
1028 | begin
|
---|
1029 | ParseState := psNone;
|
---|
1030 | I := StartLine;
|
---|
1031 | while I < Lines.Count do begin
|
---|
1032 | Line := Trim(Lines[I]);
|
---|
1033 | if Line = '' then begin
|
---|
1034 | // Skip empty lines
|
---|
1035 | end else
|
---|
1036 | if ParseState = psNone then begin
|
---|
1037 | if Line = VCardBegin then begin
|
---|
1038 | ParseState := psInside;
|
---|
1039 | end else begin
|
---|
1040 | Parent.Error(SExpectedVCardBegin, I + 1);
|
---|
1041 | I := -1;
|
---|
1042 | Break;
|
---|
1043 | end;
|
---|
1044 | end else
|
---|
1045 | if ParseState = psInside then begin
|
---|
1046 | if Line = VCardEnd then begin
|
---|
1047 | ParseState := psFinished;
|
---|
1048 | Inc(I);
|
---|
1049 | Break;
|
---|
1050 | end else
|
---|
1051 | if Pos(':', Line) > 0 then begin
|
---|
1052 | CommandPart := GetNext(Line, ':');
|
---|
1053 | Names := CommandPart;
|
---|
1054 | Value := Line;
|
---|
1055 | while True do begin
|
---|
1056 | Inc(I);
|
---|
1057 | if (Length(Lines[I]) > 0) and (Lines[I][1] = ' ') then begin
|
---|
1058 | Value := Value + Trim(Lines[I]);
|
---|
1059 | end else
|
---|
1060 | if (Length(Lines[I]) > 0) and (Length(Value) > 0) and (Value[Length(Value)] = '=') and
|
---|
1061 | (Lines[I][1] = '=') then begin
|
---|
1062 | Value := Value + Copy(Trim(Lines[I]), 2, MaxInt);
|
---|
1063 | end else begin
|
---|
1064 | Dec(I);
|
---|
1065 | Break;
|
---|
1066 | end;
|
---|
1067 | end;
|
---|
1068 | NewProperty := Properties.GetByName(Names);
|
---|
1069 | if not Assigned(NewProperty) then begin
|
---|
1070 | NewProperty := TContactProperty.Create;
|
---|
1071 | Properties.Add(NewProperty);
|
---|
1072 | end;
|
---|
1073 | NewProperty.Attributes.DelimitedText := Names;
|
---|
1074 | if NewProperty.Attributes.Count > 0 then begin
|
---|
1075 | NewProperty.Name := NewProperty.Attributes[0];
|
---|
1076 | NewProperty.Attributes.Delete(0);
|
---|
1077 | end;
|
---|
1078 | NewProperty.Value := Value;
|
---|
1079 | NewProperty.EvaluateAttributes;
|
---|
1080 | end else begin
|
---|
1081 | Parent.Error(SExpectedProperty, I + 1);
|
---|
1082 | I := -1;
|
---|
1083 | Break;
|
---|
1084 | end;
|
---|
1085 | end;
|
---|
1086 | Inc(I);
|
---|
1087 | end;
|
---|
1088 | Result := I;
|
---|
1089 | end;
|
---|
1090 |
|
---|
1091 | procedure TContact.SaveToFile(FileName: string);
|
---|
1092 | var
|
---|
1093 | Lines: TStringList;
|
---|
1094 | begin
|
---|
1095 | Lines := TStringList.Create;
|
---|
1096 | try
|
---|
1097 | SaveToStrings(Lines);
|
---|
1098 | Lines.SaveToFile(FileName);
|
---|
1099 | finally
|
---|
1100 | Lines.Free;
|
---|
1101 | end;
|
---|
1102 | end;
|
---|
1103 |
|
---|
1104 | procedure TContact.LoadFromFile(FileName: string);
|
---|
1105 | var
|
---|
1106 | Lines: TStringList;
|
---|
1107 | begin
|
---|
1108 | Lines := TStringList.Create;
|
---|
1109 | try
|
---|
1110 | Lines.LoadFromFile(FileName);
|
---|
1111 | {$IF FPC_FULLVERSION>=30200}
|
---|
1112 | if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
|
---|
1113 | Lines.LoadFromFile(FileName, TEncoding.Unicode);
|
---|
1114 | if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
|
---|
1115 | Lines.LoadFromFile(FileName, TEncoding.BigEndianUnicode);
|
---|
1116 | end;
|
---|
1117 | end;
|
---|
1118 | {$ENDIF}
|
---|
1119 | LoadFromStrings(Lines);
|
---|
1120 | finally
|
---|
1121 | Lines.Free;
|
---|
1122 | end;
|
---|
1123 | end;
|
---|
1124 |
|
---|
1125 | { TContactsFile }
|
---|
1126 |
|
---|
1127 | procedure TContactsFile.InitFields;
|
---|
1128 | begin
|
---|
1129 | with Fields do begin
|
---|
1130 | AddNew('VERSION', [], [], SVersion, cfVersion, dtString);
|
---|
1131 | AddNew('N', [], [], SLastName, cfLastName, dtString, 0);
|
---|
1132 | AddNew('N', [], [], SFirstName, cfFirstName, dtString, 1);
|
---|
1133 | AddNew('N', [], [], SMiddleName, cfMiddleName, dtString, 2);
|
---|
1134 | AddNew('N', [], [], STitleBefore, cfTitleBefore, dtString, 3);
|
---|
1135 | AddNew('N', [], [], STitleAfter, cfTitleAfter, dtString, 4);
|
---|
1136 | AddNew('FN', [], [], SFullName, cfFullName, dtString);
|
---|
1137 | AddNew('TEL', [], ['CELL', 'FAX', 'PAGER', 'WORK', 'HOME'], STelephone, cfTel, dtString);
|
---|
1138 | AddNew('TEL', ['CELL'], ['WORK', 'HOME'], SMobilePhone, cfTelCell, dtString);
|
---|
1139 | AddNew('TEL', ['FAX'], ['WORK', 'HOME'], SFax, cfTelFax, dtString);
|
---|
1140 | AddNew('TEL', ['PAGER'], ['WORK', 'HOME'], SPager, cfTelPager, dtString);
|
---|
1141 | AddNew('TEL', ['HOME'], ['CELL', 'FAX', 'PAGER'], SHomePhone, cfTelHome, dtString);
|
---|
1142 | AddNew('TEL', ['HOME', 'CELL'], [], SHomeMobile, cfTelCellHome, dtString);
|
---|
1143 | AddNew('TEL', ['HOME', 'FAX'], [], SHomeFax, cfTelFaxHome, dtString);
|
---|
1144 | AddNew('TEL', ['HOME', 'PAGER'], [], SHomePager, cfTelPagerHome, dtString);
|
---|
1145 | AddNew('TEL', ['WORK'], ['CELL', 'FAX', 'PAGER'], SWorkPhone, cfTelWork, dtString);
|
---|
1146 | AddNew('TEL', ['WORK', 'CELL'], [], SWorkMobile, cfTelCellWork, dtString);
|
---|
1147 | AddNew('TEL', ['WORK', 'FAX'], [], SWorkFax, cfTelFaxWork, dtString);
|
---|
1148 | AddNew('TEL', ['WORK', 'PAGER'], [], SWorkPager, cfTelPagerWork, dtString);
|
---|
1149 | AddNew('TEL', ['HOME2'], [], SHomePhone2, cfTelHome2, dtString);
|
---|
1150 | AddNew('TEL', ['VOIP'], [], SVoipPhone, cfTelVoip, dtString);
|
---|
1151 | AddNew('TEL', ['MAIN'], [], SMainPhone, cfTelMain, dtString);
|
---|
1152 | AddNew('EMAIL', [], ['HOME', 'WORK', 'INTERNET'], SEmail, cfEmail, dtString);
|
---|
1153 | AddNew('EMAIL', ['HOME'], [], SHomeEmail, cfEmailHome, dtString);
|
---|
1154 | AddNew('EMAIL', ['WORK'], [], SWorkEmail, cfEmailWork, dtString);
|
---|
1155 | AddNew('EMAIL', ['INTERNET'], [], SInternetEmail, cfEmailInternet, dtString);
|
---|
1156 | with AddNew('NICKNAME', [], [], SNickName, cfNickName, dtString) do
|
---|
1157 | AddAlternative('X-NICKNAME', [], []);
|
---|
1158 | AddNew('NOTE', [], [], SNote, cfNote, dtString);
|
---|
1159 | AddNew('ROLE', [], [], SRole, cfRole, dtString);
|
---|
1160 | AddNew('TITLE', [], [], STitle, cfTitle, dtString);
|
---|
1161 | AddNew('CATEGORIES', [], [], SCategories, cfCategories, dtString);
|
---|
1162 | AddNew('ORG', [], [], SOrganization, cfOrganization, dtString, 0);
|
---|
1163 | AddNew('ORG', [], [], SDepartement, cfDepartment, dtString, 1);
|
---|
1164 | AddNew('ADR', ['HOME'], [], SHomeAddressPostOfficeBox, cfHomeAddressPostOfficeBox, dtString, 0);
|
---|
1165 | AddNew('ADR', ['HOME'], [], SHomeAddressStreetExtended, cfHomeAddressStreetExtended, dtString, 1);
|
---|
1166 | AddNew('ADR', ['HOME'], [], SHomeAddressStreet, cfHomeAddressStreet, dtString, 2);
|
---|
1167 | AddNew('ADR', ['HOME'], [], SHomeAddressCity, cfHomeAddressCity, dtString, 3);
|
---|
1168 | AddNew('ADR', ['HOME'], [], SHomeAddressRegion, cfHomeAddressRegion, dtString, 4);
|
---|
1169 | AddNew('ADR', ['HOME'], [], SHomeAddressPostalCode, cfHomeAddressPostalCode, dtString, 5);
|
---|
1170 | AddNew('ADR', ['HOME'], [], SHomeAddressCountry, cfHomeAddressCountry, dtString, 6);
|
---|
1171 | AddNew('ADR', ['WORK'], [], SWorkAddressPostOfficeBox, cfWorkAddressPostOfficeBox, dtString, 0);
|
---|
1172 | AddNew('ADR', ['WORK'], [], SWorkAddressStreetExtended, cfWorkAddressStreetExtended, dtString, 1);
|
---|
1173 | AddNew('ADR', ['WORK'], [], SWorkAddressStreet, cfWorkAddressStreet, dtString, 2);
|
---|
1174 | AddNew('ADR', ['WORK'], [], SWorkAddressCity, cfWorkAddressCity, dtString, 3);
|
---|
1175 | AddNew('ADR', ['WORK'], [], SWorkAddressRegion, cfWorkAddressRegion, dtString, 4);
|
---|
1176 | AddNew('ADR', ['WORK'], [], SWorkAddressPostalCode, cfWorkAddressPostalCode, dtString, 5);
|
---|
1177 | AddNew('ADR', ['WORK'], [], SWorkAddressCountry, cfWorkAddressCountry, dtString, 6);
|
---|
1178 | AddNew('X-TIMES_CONTACTED', [], [], STimesContacted, cfXTimesContacted, dtString);
|
---|
1179 | AddNew('X-LAST_TIME_CONTACTED', [], [], SLastTimeContacted, cfXLastTimeContacted, dtString);
|
---|
1180 | AddNew('PHOTO', [], [], SPhoto, cfPhoto, dtImage);
|
---|
1181 | AddNew('LOGO', [], [], SLogo, cfLogo, dtImage);
|
---|
1182 | AddNew('BDAY', [], [], SDayOfBirth, cfDayOfBirth, dtDate);
|
---|
1183 | with AddNew('ANNIVERSARY', [], [], SAnniversary, cfAnniversary, dtDate) do
|
---|
1184 | AddAlternative('X-EVOLUTION-ANNIVERSARY', [], []);
|
---|
1185 | AddNew('REV', [], [], SRevision, cfRevision, dtString);
|
---|
1186 | AddNew('UID', [], [], SUniqueIdentifier, cfUid, dtString);
|
---|
1187 | AddNew('URL', [], ['HOME', 'WORK'], SWebAddress, cfUrl, dtString);
|
---|
1188 | AddNew('URL', ['HOME'], [], SWebAddressHome, cfUrlHome, dtString);
|
---|
1189 | AddNew('URL', ['WORK'], [], SWebAddressWork, cfUrlWork, dtString);
|
---|
1190 | with AddNew('GENDER', [], [], SGender, cfGender, dtString) do
|
---|
1191 | AddAlternative('X-CENTRUM-CZ-SEX', [], []);
|
---|
1192 | // Chat
|
---|
1193 | AddNew('X-MATRIX', [], [], SMatrix, cfMatrix, dtString);
|
---|
1194 | AddNew('X-JABBER', [], [], SJabber, cfJabber, dtString);
|
---|
1195 | AddNew('X-AIM', [], [], SAim, cfAim, dtString);
|
---|
1196 | AddNew('X-Windows Live', [], [], SWindowsLive, cfWindowsLive, dtString);
|
---|
1197 | AddNew('X-YAHOO', [], [], SYahoo, cfYahoo, dtString);
|
---|
1198 | with AddNew('X-SKYPE-USERNAME', [], [], SSkype, cfSkype, dtString) do begin
|
---|
1199 | AddAlternative('X-SKYPE', [], []);
|
---|
1200 | AddAlternative('X-CENTRUM-CZ-SKYPE', [], []);
|
---|
1201 | end;
|
---|
1202 | AddNew('X-QQ', [], [], SQq, cfQq, dtString);
|
---|
1203 | AddNew('X-GOOGLE-TALK', [], [], SGoogleTalk, cfGoogleTalk, dtString);
|
---|
1204 | with AddNew('X-ICQ', [], [], SIcq, cfIcq, dtString) do
|
---|
1205 | AddAlternative('X-CENTRUM-CZ-ICQ', [], []);
|
---|
1206 | AddNew('X-IRC', [], [], SIrc, cfIrc, dtString);
|
---|
1207 | with AddNew('X-MSN', [], [], SMsn, cfMsn, dtString) do
|
---|
1208 | AddAlternative('X-CENTRUM-CZ-MSN', [], []);
|
---|
1209 | AddNew('X-GROUPWISE', [], [], SGroupWise, cfGroupWise, dtString);
|
---|
1210 | AddNew('X-GADUGADU', [], [], SGaduGadu, cfGaduGadu, dtString);
|
---|
1211 | // Social
|
---|
1212 | with AddNew('X-TWITTER', [], [], STwitter, cfTwitter, dtString) do
|
---|
1213 | AddAlternative('X-SOCIALPROFILE', ['TWITTER'], []);
|
---|
1214 | with AddNew('X-FACEBOOK', [], [], SFacebook, cfFacebook, dtString) do
|
---|
1215 | AddAlternative('X-SOCIALPROFILE', ['FACEBOOK'], []);
|
---|
1216 | with AddNew('X-MASTODON', [], [], SMastodon, cfMastodon, dtString) do
|
---|
1217 | AddAlternative('X-SOCIALPROFILE', ['MASTODON'], []);
|
---|
1218 | with AddNew('X-YOUTUBE', [], [], SYouTube, cfYouTube, dtString) do
|
---|
1219 | AddAlternative('X-SOCIALPROFILE', ['YOUTUBE'], []);
|
---|
1220 | with AddNew('X-PEERTUBE', [], [], SPeerTube, cfPeerTube, dtString) do
|
---|
1221 | AddAlternative('X-SOCIALPROFILE', ['PEERTUBE'], []);
|
---|
1222 | with AddNew('X-LINKEDIN', [], [], SLinkedIn, cfLinkedIn, dtString) do
|
---|
1223 | AddAlternative('X-SOCIALPROFILE', ['LINKEDIN'], []);
|
---|
1224 | with AddNew('X-SNAPCHAT', [], [], SSnapchat, cfSnapchat, dtString) do
|
---|
1225 | AddAlternative('X-SOCIALPROFILE', ['SNAPCHAT'], []);
|
---|
1226 | with AddNew('X-INSTAGRAM', [], [], SInstagram, cfInstagram, dtString) do
|
---|
1227 | AddAlternative('X-SOCIALPROFILE', ['INSTAGRAM'], []);
|
---|
1228 | with AddNew('X-REDDIT', [], [], SReddit, cfReddit, dtString) do
|
---|
1229 | AddAlternative('X-SOCIALPROFILE', ['REDDIT'], []);
|
---|
1230 | with AddNew('X-MYSPACE', [], [], SMySpace, cfMySpace, dtString) do
|
---|
1231 | AddAlternative('X-SOCIALPROFILE', ['MYSPACE'], []);
|
---|
1232 | end;
|
---|
1233 | end;
|
---|
1234 |
|
---|
1235 | procedure TContactsFile.Error(Text: string; Line: Integer);
|
---|
1236 | begin
|
---|
1237 | if Assigned(FOnError) then FOnError(Text, Line);
|
---|
1238 | end;
|
---|
1239 |
|
---|
1240 | function TContactsFile.GetFileName: string;
|
---|
1241 | begin
|
---|
1242 | Result := SVCardFile;
|
---|
1243 | end;
|
---|
1244 |
|
---|
1245 | function TContactsFile.GetFileExt: string;
|
---|
1246 | begin
|
---|
1247 | Result := VCardFileExt;
|
---|
1248 | end;
|
---|
1249 |
|
---|
1250 | function TContactsFile.GetFileFilter: string;
|
---|
1251 | begin
|
---|
1252 | Result := GetFileName + ' (' + GetFileExt + ')|*' + GetFileExt + '|' + inherited;
|
---|
1253 | end;
|
---|
1254 |
|
---|
1255 | procedure TContactsFile.SaveToStrings(Output: TStrings);
|
---|
1256 | var
|
---|
1257 | I: Integer;
|
---|
1258 | begin
|
---|
1259 | for I := 0 to Contacts.Count - 1 do
|
---|
1260 | Contacts[I].SaveToStrings(Output);
|
---|
1261 | end;
|
---|
1262 |
|
---|
1263 | procedure TContactsFile.LoadFromStrings(Lines: TStrings);
|
---|
1264 | var
|
---|
1265 | Contact: TContact;
|
---|
1266 | I: Integer;
|
---|
1267 | NewI: Integer;
|
---|
1268 | begin
|
---|
1269 | Contacts.Clear;
|
---|
1270 |
|
---|
1271 | I := 0;
|
---|
1272 | while I < Lines.Count do begin
|
---|
1273 | Contact := TContact.Create;
|
---|
1274 | Contact.Parent := Self;
|
---|
1275 | NewI := Contact.LoadFromStrings(Lines, I);
|
---|
1276 | if NewI <= Lines.Count then begin
|
---|
1277 | if NewI <> -1 then begin
|
---|
1278 | Contacts.Add(Contact);
|
---|
1279 | I := NewI;
|
---|
1280 | end else begin
|
---|
1281 | FreeAndNil(Contact);
|
---|
1282 | Inc(I);
|
---|
1283 | end;
|
---|
1284 | end else begin
|
---|
1285 | FreeAndNil(Contact);
|
---|
1286 | Break;
|
---|
1287 | end;
|
---|
1288 | end;
|
---|
1289 | end;
|
---|
1290 |
|
---|
1291 | function TContactsFile.NewItem(Key, Value: string): string;
|
---|
1292 | var
|
---|
1293 | Charset: string;
|
---|
1294 | begin
|
---|
1295 | if not IsAsciiString(Value) then Charset := ';CHARSET=UTF-8'
|
---|
1296 | else Charset := '';
|
---|
1297 | Result := Key + Charset + ':' + Value;
|
---|
1298 | end;
|
---|
1299 |
|
---|
1300 | procedure TContactsFile.SaveToFile(FileName: string);
|
---|
1301 | var
|
---|
1302 | Lines: TStringList;
|
---|
1303 | begin
|
---|
1304 | inherited;
|
---|
1305 | Lines := TStringList.Create;
|
---|
1306 | try
|
---|
1307 | SaveToStrings(Lines);
|
---|
1308 | Lines.SaveToFile(FileName);
|
---|
1309 | finally
|
---|
1310 | Lines.Free;
|
---|
1311 | end
|
---|
1312 | end;
|
---|
1313 |
|
---|
1314 | procedure TContactsFile.LoadFromFile(FileName: string);
|
---|
1315 | var
|
---|
1316 | Lines: TStringList;
|
---|
1317 | begin
|
---|
1318 | inherited;
|
---|
1319 | Lines := TStringList.Create;
|
---|
1320 | Lines.LoadFromFile(FileName);
|
---|
1321 | {$IF FPC_FULLVERSION>=30200}
|
---|
1322 | if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
|
---|
1323 | Lines.LoadFromFile(FileName, TEncoding.Unicode);
|
---|
1324 | if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
|
---|
1325 | Lines.LoadFromFile(FileName, TEncoding.BigEndianUnicode);
|
---|
1326 | end;
|
---|
1327 | end;
|
---|
1328 | {$ENDIF}
|
---|
1329 | try
|
---|
1330 | LoadFromStrings(Lines);
|
---|
1331 | finally
|
---|
1332 | Lines.Free;
|
---|
1333 | end;
|
---|
1334 | end;
|
---|
1335 |
|
---|
1336 | constructor TContactsFile.Create;
|
---|
1337 | begin
|
---|
1338 | inherited;
|
---|
1339 | Contacts := TContacts.Create;
|
---|
1340 | Contacts.ContactsFile := Self;
|
---|
1341 | Fields := TContactFields.Create;
|
---|
1342 | InitFields;
|
---|
1343 | end;
|
---|
1344 |
|
---|
1345 | destructor TContactsFile.Destroy;
|
---|
1346 | begin
|
---|
1347 | FreeAndNil(Fields);
|
---|
1348 | FreeAndNil(Contacts);
|
---|
1349 | inherited;
|
---|
1350 | end;
|
---|
1351 |
|
---|
1352 | end.
|
---|
1353 |
|
---|