source: trunk/Packages/VCard/VCard.pas

Last change on this file was 173, checked in by chronos, 17 months ago
  • Modified: TNameDetails class moved into separate file.
File size: 52.1 KB
Line 
1unit VCard;
2
3interface
4
5uses
6 Classes, SysUtils, Dialogs, LazUTF8, Base64, Graphics, Common, Table,
7 Generics.Collections, Generics.Defaults, ListViewSort;
8
9type
10 TErrorEvent = procedure (Text: string; Line: Integer) of object;
11
12 TDataType = (dtNone, dtString, dtInteger, dtDate, dtDateTime, dtImage, dtStringList);
13
14 TContactFieldIndex = (cfNone, cfFirstName, cfMiddleName, cfLastName, cfTitleBefore,
15 cfTitleAfter, cfFullName,
16 cfTel, cfTelCell, cfTelFax, cfTelPager, cfTelHome2, cfTelVoip, cfTelMain,
17 cfTelHome, cfTelCellHome, cfTelFaxHome, cfTelPagerHome,
18 cfTelWork, cfTelCellWork, cfTelFaxWork, cfTelPagerWork,
19 cfEmail, cfUid, cfUrl, cfUrlHome, cfUrlWork,
20 cfEmailHome, cfEmailWork, cfEmailInternet, cfNickName, cfNote, cfRole, cfTitle,
21 cfCategories, cfOrganization, cfDepartment,
22 cfHomeAddressStreet, cfHomeAddressStreetExtended, cfHomeAddressCity, cfHomeAddressCountry,
23 cfHomeAddressPostalCode, cfHomeAddressRegion, cfHomeAddressPostOfficeBox,
24 cfWorkAddressStreet, cfWorkAddressStreetExtended, cfWorkAddressCity, cfWorkAddressCountry,
25 cfWorkAddressPostalCode, cfWorkAddressRegion, cfWorkAddressPostOfficeBox,
26 cfXTimesContacted, cfXLastTimeContacted, cfPhoto, cfDayOfBirth, cfRevision,
27 cfVersion, cfAnniversary, cfGender, cfLogo,
28 cfJabber, cfIcq, cfWindowsLive, cfGoogleTalk, cfAim, cfQq, cfYahoo, cfIrc,
29 cfSkype, cfMsn, cfGroupWise, cfGaduGadu,
30 cfTwitter, cfFacebook, cfInstagram, cfSnapchat, cfMatrix, cfYoutube,
31 cfPeerTube, cfLinkedIn, cfMastodon, cfMySpace, cfReddit);
32
33 TContactFieldIndexes = TList<TContactFieldIndex>;
34
35 TContactFilterItem = class
36 FieldIndex: TContactFieldIndex;
37 Value: string;
38 end;
39
40 { TContactFilterItems }
41
42 TContactFilterItems = class(TObjectList<TContactFilterItem>)
43 function AddNew(FieldIndex: TContactFieldIndex; Value: string): TContactFilterItem;
44 end;
45
46 TContactFields = class;
47
48 { TContactField }
49
50 TContactField = class
51 SysName: string;
52 Groups: TStringArray;
53 NoGroups: TStringArray;
54 Title: string;
55 Index: TContactFieldIndex;
56 ValueIndex: Integer;
57 DataType: TDataType;
58 Alternatives: TContactFields;
59 function AddAlternative(Name: string; Groups: array of string; NoGroups:
60 array of string): TContactField;
61 function GroupsContain(Name: string): Boolean;
62 function Match(ASysName: string; AGroups: TStringArray): Boolean;
63 constructor Create;
64 destructor Destroy; override;
65 end;
66
67 { TContactFields }
68
69 TContactFields = class(TObjectList<TContactField>)
70 private
71 Indexes: array[TContactFieldIndex] of TContactField;
72 IndexesUpdated: Boolean;
73 public
74 procedure UpdateIndexes;
75 function AddNew(Name: string; Groups: array of string; NoGroups: array of string;
76 Title: string; Index: TContactFieldIndex; DataType:
77 TDataType = dtNone; ValueIndex: Integer = -1): TContactField;
78 function GetBySysName(SysName: string): TContactField;
79 function GetBySysNameGroups(SysName: string; Groups: TStringArray): TContactField;
80 function GetByIndex(Index: TContactFieldIndex): TContactField;
81 function GetByTitle(Title: string): TContactField;
82 procedure LoadToStrings(AItems: TStrings);
83 end;
84
85 TPropertyEncoding = (veNone, veQuotedPrintable, veBase64, ve8bit);
86
87 { TContactProperty }
88
89 TContactProperty = class
90 private
91 function GetEncoding: TPropertyEncoding;
92 function GetValueItem(Index: Integer): string;
93 procedure SetEncoding(AValue: TPropertyEncoding);
94 procedure SetValueItem(Index: Integer; AValue: string);
95 public
96 Name: string;
97 Attributes: TStringList;
98 Value: string;
99 Charset: string;
100 procedure EvaluateAttributes;
101 function GetDecodedValue: string;
102 function GetEncodedValue: string;
103 function MatchNameGroups(AName: string; Groups: TStringArray;
104 NoGroups: TStringArray): Boolean;
105 procedure Assign(Source: TContactProperty);
106 function CompareTo(ContactProperty: TContactProperty): Boolean;
107 constructor Create;
108 destructor Destroy; override;
109 property ValueItem[Index: Integer]: string read GetValueItem write SetValueItem;
110 property Encoding: TPropertyEncoding read GetEncoding write SetEncoding;
111 end;
112
113 { TContactProperties }
114
115 TContactProperties = class(TObjectList<TContactProperty>)
116 function AddNew(Name, Value: string): TContactProperty;
117 procedure Assign(Source: TContactProperties);
118 procedure AssignToList(List: TObjects);
119 function GetByName(Name: string): TContactProperty;
120 function GetMultipleByName(Name: string): TContactProperties;
121 function GetByNameGroups(Name: string; Groups: TStringArray;
122 NoGroups: TStringArray): TContactProperty;
123 function GetByNameGroupsMultiple(Name: string; Groups: TStringArray;
124 NoGroups: TStringArray): TContactProperties;
125 function RemoveExactDuplicates: Integer;
126 end;
127
128 TVCard = class;
129
130 { TContact }
131
132 TContact = class
133 private
134 FModified: Boolean;
135 FOnModify: TNotifyEvent;
136 class var FFields: TContactFields;
137 procedure DoOnModify;
138 procedure DetectMaxLineLength(Text: string);
139 function GetField(Index: TContactFieldIndex): string;
140 function GetString: string;
141 procedure SetField(Index: TContactFieldIndex; AValue: string);
142 procedure SetModified(AValue: Boolean);
143 procedure SetString(AValue: string);
144 public
145 Properties: TContactProperties;
146 ParentVCard: TVCard;
147 class function GetFields: TContactFields; static;
148 function HasField(FieldIndex: TContactFieldIndex): Boolean;
149 function FullNameToFileName: string;
150 function GetProperty(Field: TContactField): TContactProperty; overload;
151 function GetProperty(FieldIndex: TContactFieldIndex): TContactProperty; overload;
152 procedure Assign(Source: TContact);
153 function UpdateFrom(Source: TContact): Boolean;
154 function CompareTo(Contact: TContact): Boolean;
155 constructor Create;
156 destructor Destroy; override;
157 class destructor Destroy2;
158 procedure SaveToStrings(Output: TStrings);
159 function LoadFromStrings(Lines: TStrings; var StartLine: Integer): Boolean;
160 procedure SaveToFile(FileName: string);
161 procedure LoadFromFile(FileName: string);
162 property Fields[Index: TContactFieldIndex]: string read GetField write SetField;
163 property Modified: Boolean read FModified write SetModified;
164 property AsString: string read GetString write SetString;
165 published
166 property OnModify: TNotifyEvent read FOnModify write FOnModify;
167 end;
168
169 TGetContactEvent = function (Contact: TContact): TContact of object;
170
171 { TContacts }
172
173 TContacts = class(TObjectList<TContact>)
174 ParentVCard: TVCard;
175 procedure Assign(Source: TContacts);
176 procedure AssignToList(List: TObjects);
177 procedure AddContacts(Contacts: TContacts);
178 procedure InsertContacts(Index: Integer; Contacts: TContacts);
179 function AddNew: TContact;
180 function Search(Text: string; FieldIndex: TContactFieldIndex): TContact;
181 function CountByField(FieldIndex: TContactFieldIndex): Integer;
182 procedure Merge(Contact: TContact; FieldIndex: TContactFieldIndex);
183 function ToString: ansistring; override;
184 function RemoveExactDuplicates: Integer;
185 procedure Sort;
186 end;
187
188 { TVCard }
189
190 TVCard = class(TComponent)
191 private
192 FMaxLineLength: Integer;
193 FModified: Boolean;
194 FOnModify: TNotifyEvent;
195 FOnError: TErrorEvent;
196 function GetString: string;
197 procedure SetModified(AValue: Boolean);
198 procedure SetString(AValue: string);
199 procedure Error(Text: string; Line: Integer);
200 procedure DoOnModify;
201 public
202 Contacts: TContacts;
203 procedure Assign(Source: TPersistent); override;
204 procedure SaveToStrings(Output: TStrings);
205 procedure LoadFromStrings(Lines: TStrings);
206 procedure SaveToFile(FileName: string);
207 procedure LoadFromFile(FileName: string);
208 procedure ExportToStrings(Lines: TStrings; Format: TTableFormat; HumanReadableHeader: Boolean);
209 procedure ImportFromStrings(Lines: TStrings; Format: TTableFormat; HumanReadableHeader: Boolean);
210 procedure ExportToFile(FileName: string; Format: TTableFormat; HumanReadableHeader: Boolean);
211 procedure ImportFromFile(FileName: string; Format: TTableFormat; HumanReadableHeader: Boolean);
212 procedure ExportToTable(Table: TTable; HumanReadableHeader: Boolean);
213 procedure ImportFromTable(Table: TTable; HumanReadableHeader: Boolean);
214 constructor Create(AOwner: TComponent); override;
215 destructor Destroy; override;
216 property AsString: string read GetString write SetString;
217 property Modified: Boolean read FModified write SetModified;
218 published
219 property MaxLineLength: Integer read FMaxLineLength write FMaxLineLength;
220 property OnModify: TNotifyEvent read FOnModify write FOnModify;
221 property OnError: TErrorEvent read FOnError write FOnError;
222 end;
223
224const
225 VCardFileExt = '.vcf';
226 VCardBegin = 'BEGIN:VCARD';
227 VCardEnd = 'END:VCARD';
228 VCardBase64 = 'BASE64';
229 VCardBase64Short = 'B';
230 VCardQuotedPrintable = 'QUOTED-PRINTABLE';
231 VCardQuotedPrintableShort = 'Q';
232 VCardEncoding = 'ENCODING';
233 VCardCharset = 'CHARSET';
234 VCardLineEnding = #13#10;
235
236procedure Register;
237
238
239implementation
240
241uses
242 QuotedPrintable;
243
244const
245 DefaultMaxLineLength = 75;
246
247resourcestring
248 SFieldIndexRedefined = 'Field index %d redefined';
249 SExpectedVCardBegin = 'Expected vCard begin';
250 SFieldIndexNotDefined = 'Field index not defined';
251 SContactHasNoParent = 'Contact has no parent';
252 SExpectedProperty = 'Expected contact property';
253 SVersion = 'Version';
254 SLastName = 'Last Name';
255 SFirstName = 'First Name';
256 SMiddleName = 'Middle Name';
257 STitleBefore = 'Title Before';
258 STitleAfter = 'Title After';
259 SFullName = 'Full Name';
260 STelephone = 'Telephone';
261 SMobilePhone = 'Mobile phone';
262 SPager = 'Pager';
263 SFax = 'Fax';
264 SHomePhone = 'Home phone';
265 SHomeMobile = 'Home mobile';
266 SHomeFax = 'Home fax';
267 SHomePager = 'Home pager';
268 SWorkPhone = 'Work phone';
269 SWorkFax = 'Work fax';
270 SWorkPager = 'Work pager';
271 SWorkMobile = 'Work mobile';
272 SHomePhone2 = 'Home phone 2';
273 SVoipPhone = 'VoIP phone';
274 SMainPhone = 'Main phone';
275 SEmail = 'E-mail';
276 SHomeEmail = 'Home E-mail';
277 SWorkEmail = 'Work E-mail';
278 SInternetEmail = 'Internet E-mail';
279 SNickName = 'Nick name';
280 SNote = 'Note';
281 SRole = 'Role';
282 STitle = 'Title';
283 SCategories = 'Categories';
284 SOrganization = 'Organization';
285 SDepartement = 'Departement';
286 SHomeAddressPostOfficeBox = 'Home address post office box';
287 SHomeAddressStreetExtended = 'Home address extended street';
288 SHomeAddressStreet = 'Home address street';
289 SHomeAddressCity = 'Home address city';
290 SHomeAddressRegion = 'Home address region';
291 SHomeAddressPostalCode = 'Home address postal code';
292 SHomeAddressCountry = 'Home address country';
293 SWorkAddressPostOfficeBox = 'Work address post office box';
294 SWorkAddressStreetExtended = 'Work address extended street';
295 SWorkAddressStreet = 'Work address street';
296 SWorkAddressCity = 'Work address city';
297 SWorkAddressRegion = 'Work address region';
298 SWorkAddressPostalCode = 'Work address postal code';
299 SWorkAddressCountry = 'Work address country';
300 STimesContacted = 'Times Contacted';
301 SLastTimeContacted = 'Last Time Contacted';
302 SPhoto = 'Photo';
303 SLogo = 'Logo';
304 SJabber = 'Jabber';
305 SDayOfBirth = 'Day of birth';
306 SAnniversary = 'Anniversary';
307 SRevision = 'Revision';
308 SUniqueIdentifier = 'Unique identifier';
309 SWebAddress = 'Web address';
310 SWebAddressHome = 'Web address home';
311 SWebAddressWork = 'Web address work';
312 SGender = 'Gender';
313 // Chat
314 SMsn = 'MSN';
315 SGoogleTalk = 'Google Talk';
316 SWindowsLive = 'Windows Live';
317 SAim = 'AIM';
318 SQq = 'QQ';
319 SIrc = 'IRC';
320 SIcq = 'ICQ';
321 SYahoo = 'Yahoo!';
322 SSkype = 'Skype';
323 SMatrix = 'Matrix';
324 SGroupWise = 'GroupWise';
325 SGaduGadu = 'GaduGadu';
326 // Social
327 STwitter = 'Twitter';
328 SFacebook = 'Facebook';
329 SInstagram = 'Instagram';
330 SMastodon = 'Mastodon';
331 SSnapchat = 'Snapchat';
332 SLinkedIn = 'LinkedIn';
333 SYouTube = 'YouTube';
334 SPeerTube = 'PeerTube';
335 SReddit = 'Reddit';
336 SMySpace = 'MySpace';
337
338procedure Register;
339begin
340 RegisterComponents('VCard', [TVCard]);
341end;
342
343function GetNext(var Text: string; Separator: string): string;
344begin
345 if Pos(Separator, Text) > 0 then begin
346 Result := Copy(Text, 1, Pos(Separator, Text) - 1);
347 Delete(Text, 1, Length(Result) + Length(Separator));
348 end else begin
349 Result := Text;
350 Text := '';
351 end;
352end;
353
354function IsAsciiString(Text: string): Boolean;
355var
356 I: Integer;
357begin
358 Result := True;
359 for I := 1 to Length(Text) do
360 if Ord(Text[I]) > 128 then begin
361 Result := False;
362 Break;
363 end;
364end;
365
366function EncodeEscaped(Text: string): string;
367var
368 I: Integer;
369 O: Integer;
370 InNewLine: Boolean;
371begin
372 Result := '';
373 I := 1;
374 O := 1;
375 InNewLine := False;
376 SetLength(Result, Length(Text)); // Preallocate string
377 while I <= Length(Text) do begin
378 if Text[I] in [',', '\', ';'] then begin
379 InNewLine := False;
380 Result[O] := '\';
381 SetLength(Result, Length(Result) + 1);
382 Inc(O);
383 Result[O] := Text[I];
384 Inc(O);
385 end else
386 if Text[I] in [#13, #10] then begin
387 if not InNewLine then begin
388 Result[O] := '\';
389 Inc(O);
390 SetLength(Result, Length(Result) + 1);
391 Result[O] := 'n';
392 Inc(O);
393 InNewLine := True;
394 end;
395 end else begin
396 InNewLine := False;
397 Result[O] := Text[I];
398 Inc(O);
399 end;
400 Inc(I);
401 end;
402 SetLength(Result, O - 1);
403end;
404
405function DecodeEscaped(Text: string): string;
406var
407 I: Integer;
408 O: Integer;
409 Escaped: Boolean;
410begin
411 Result := '';
412 I := 1;
413 O := 1;
414 Escaped := False;
415 SetLength(Result, Length(Text)); // Preallocate string
416 while I <= Length(Text) do begin
417 if Escaped then begin
418 if Text[I] = 'n' then begin
419 Result[O] := #13;
420 Inc(O);
421 Result[O] := #10;
422 Inc(O);
423 end else begin
424 Result[O] := Text[I];
425 Inc(O);
426 end;
427 Escaped := False;
428 end else begin
429 if Text[I] = '\' then begin
430 Escaped := True;
431 end else begin
432 Result[O] := Text[I];
433 Inc(O);
434 end;
435 end;
436 Inc(I);
437 end;
438 SetLength(Result, O - 1);
439end;
440
441{ TVCard }
442
443function TVCard.GetString: string;
444var
445 I: Integer;
446begin
447 Result := '';
448 for I := 0 to Contacts.Count - 1 do
449 Result := Result + Contacts[I].AsString;
450end;
451
452procedure TVCard.SetModified(AValue: Boolean);
453begin
454 if FModified = AValue then Exit;
455 FModified := AValue;
456 DoOnModify;
457end;
458
459procedure TVCard.SetString(AValue: string);
460var
461 Lines: TStringList;
462begin
463 Lines := TStringList.Create;
464 try
465 Lines.Text := AValue;
466 LoadFromStrings(Lines);
467 Modified := True;
468 finally
469 Lines.Free;
470 end;
471end;
472
473procedure TVCard.DoOnModify;
474begin
475 if Assigned(FOnModify) then FOnModify(Self);
476end;
477
478procedure TVCard.Error(Text: string; Line: Integer);
479begin
480 if Assigned(FOnError) then FOnError(Text, Line);
481end;
482
483procedure TVCard.Assign(Source: TPersistent);
484begin
485 if Source is TVCard then
486 Contacts.Assign((Source as TVCard).Contacts)
487 else inherited;
488end;
489
490procedure TVCard.SaveToStrings(Output: TStrings);
491var
492 I: Integer;
493begin
494 for I := 0 to Contacts.Count - 1 do
495 Contacts[I].SaveToStrings(Output);
496end;
497
498procedure TVCard.LoadFromStrings(Lines: TStrings);
499var
500 Contact: TContact;
501 I: Integer;
502begin
503 Contacts.Clear;
504 //MaxLineLength := 10;
505
506 I := 0;
507 while I < Lines.Count do begin
508 Contact := TContact.Create;
509 Contact.ParentVCard := Self;
510 if Contact.LoadFromStrings(Lines, I) then begin
511 Contacts.Add(Contact);
512 end else begin
513 FreeAndNil(Contact);
514 Inc(I);
515 end;
516 end;
517end;
518
519procedure TVCard.SaveToFile(FileName: string);
520var
521 Lines: TStringList;
522begin
523 Lines := TStringList.Create;
524 try
525 SaveToStrings(Lines);
526 Lines.SaveToFile(FileName);
527 finally
528 Lines.Free;
529 end
530end;
531
532procedure TVCard.LoadFromFile(FileName: string);
533var
534 Lines: TStringList;
535begin
536 Lines := TStringList.Create;
537 Lines.LoadFromFile(FileName);
538 {$IF FPC_FULLVERSION>=30200}
539 if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
540 Lines.LoadFromFile(FileName, TEncoding.Unicode);
541 if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
542 Lines.LoadFromFile(FileName, TEncoding.BigEndianUnicode);
543 end;
544 end;
545 {$ENDIF}
546 try
547 LoadFromStrings(Lines);
548 finally
549 Lines.Free;
550 end;
551end;
552
553procedure TVCard.ExportToStrings(Lines: TStrings; Format: TTableFormat;
554 HumanReadableHeader: Boolean);
555var
556 Table: TTable;
557begin
558 Table := TTable.Create;
559 try
560 ExportToTable(Table, HumanReadableHeader);
561 Lines.Text := Table.GetOutput(Format);
562 finally
563 FreeAndNil(Table);
564 end;
565end;
566
567procedure TVCard.ImportFromStrings(Lines: TStrings; Format: TTableFormat;
568 HumanReadableHeader: Boolean);
569var
570 Table: TTable;
571begin
572 Table := TTable.Create;
573 try
574 Table.SetInput(Format, Lines.Text);
575 ImportFromTable(Table, HumanReadableHeader);
576 finally
577 FreeAndNil(Table);
578 end;
579end;
580
581procedure TVCard.ExportToFile(FileName: string; Format: TTableFormat;
582 HumanReadableHeader: Boolean);
583var
584 Lines: TStringList;
585begin
586 Lines := TStringList.Create;
587 try
588 ExportToStrings(Lines, Format, HumanReadableHeader);
589 Lines.SaveToFile(FileName);
590 finally
591 Lines.Free;
592 end
593end;
594
595procedure TVCard.ImportFromFile(FileName: string; Format: TTableFormat;
596 HumanReadableHeader: Boolean);
597var
598 Lines: TStringList;
599begin
600 Lines := TStringList.Create;
601 Lines.LoadFromFile(FileName);
602 try
603 ImportFromStrings(Lines, Format, HumanReadableHeader);
604 finally
605 Lines.Free;
606 end;
607end;
608
609procedure TVCard.ExportToTable(Table: TTable; HumanReadableHeader: Boolean);
610var
611 Row: TRow;
612 I: Integer;
613 J: Integer;
614 Values: TStringList;
615 Index: Integer;
616 Fields: TContactFields;
617 Field: TContactField;
618 Columns: TStringList;
619begin
620 Table.Clear;
621
622 Values := TStringList.Create;
623 Columns := TStringList.Create;
624 try
625 // Get all properties types
626 for I := 0 to Contacts.Count - 1 do begin
627 for J := 0 to Contacts[I].Properties.Count - 1 do
628 if not Contacts[I].Properties[J].Name.StartsWith('PHOTO') and
629 (Table.Columns.IndexOf(Contacts[I].Properties[J].Name) = -1) then begin
630 Table.Columns.Add(Contacts[I].Properties[J].Name);
631 Columns.Add(Contacts[I].Properties[J].Name);
632 end;
633 end;
634
635 if HumanReadableHeader then begin
636 Fields := TContact.GetFields;
637 for I := 0 to Table.Columns.Count - 1 do begin
638 Field := Fields.GetBySysName(Table.Columns[I]);
639 if Assigned(Field) then Table.Columns[I] := Field.Title;
640 end;
641 end;
642
643 for I := 0 to Contacts.Count - 1 do begin
644 Values.Clear;
645 for J := 0 to Columns.Count - 1 do
646 Values.Add('');
647 for J := 0 to Contacts[I].Properties.Count - 1 do begin
648 Index := Columns.IndexOf(Contacts[I].Properties[J].Name);
649 if Index <> -1 then
650 Values[Index] := Contacts[I].Properties[J].Value;
651 end;
652
653 Row := Table.AddRow;
654 for J := 0 to Values.Count - 1 do
655 Row.Cells.Add(Values[J]);
656 end;
657 finally
658 Values.Free;
659 Columns.Free;
660 end;
661end;
662
663procedure TVCard.ImportFromTable(Table: TTable; HumanReadableHeader: Boolean);
664var
665 Contact: TContact;
666 I: Integer;
667 J: Integer;
668 Fields: TContactFields;
669 Field: TContactField;
670begin
671 if HumanReadableHeader then begin
672 Fields := TContact.GetFields;
673 for I := 0 to Table.Columns.Count - 1 do begin
674 Field := Fields.GetByTitle(Table.Columns[I]);
675 if Assigned(Field) then Table.Columns[I] := Field.SysName;
676 end;
677 end;
678
679 Contacts.Clear;
680 for I := 0 to Table.Rows.Count - 1 do begin
681 Contact := Contacts.AddNew;
682 for J := 0 to Table.Rows[I].Cells.Count - 1 do
683 Contact.Properties.AddNew(Table.Columns[J], Table.Rows[I].Cells[J]);
684 end;
685end;
686
687constructor TVCard.Create(AOwner: TComponent);
688begin
689 inherited;
690 FMaxLineLength := DefaultMaxLineLength;
691 Contacts := TContacts.Create;
692 Contacts.ParentVCard := Self;
693end;
694
695destructor TVCard.Destroy;
696begin
697 FreeAndNil(Contacts);
698 inherited;
699end;
700
701{ TContactFilterItems }
702
703function TContactFilterItems.AddNew(FieldIndex: TContactFieldIndex;
704 Value: string): TContactFilterItem;
705begin
706 Result := TContactFilterItem.Create;
707 Result.FieldIndex := FieldIndex;
708 Result.Value := Value;
709 Add(Result);
710end;
711
712{ TContactField }
713
714function TContactField.AddAlternative(Name: string; Groups: array of string;
715 NoGroups: array of string): TContactField;
716begin
717 Result := Alternatives.AddNew(Name, Groups, NoGroups, Title, Index, DataType, ValueIndex);
718end;
719
720function TContactField.GroupsContain(Name: string): Boolean;
721var
722 I: Integer;
723begin
724 Result := False;
725 for I := 0 to Length(Groups) - 1 do
726 if Groups[I] = Name then begin
727 Result := True;
728 Break;
729 end;
730end;
731
732function TContactField.Match(ASysName: string; AGroups: TStringArray): Boolean;
733var
734 I: Integer;
735begin
736 Result := ASysName = SysName;
737 if Result then begin
738 for I := 0 to Length(AGroups) - 1 do begin
739 if not GroupsContain(AGroups[I]) then begin
740 Result := False;
741 Break;
742 end;
743 end;
744 end;
745end;
746
747constructor TContactField.Create;
748begin
749 Alternatives := TContactFields.Create;
750end;
751
752destructor TContactField.Destroy;
753begin
754 FreeAndNil(Alternatives);
755 inherited;
756end;
757
758{ TContactProperties }
759
760function TContactProperties.AddNew(Name, Value: string): TContactProperty;
761begin
762 Result := TContactProperty.Create;
763 Result.Name := Name;
764 Result.Value := Value;
765 Add(Result);
766end;
767
768procedure TContactProperties.Assign(Source: TContactProperties);
769var
770 I: Integer;
771begin
772 while Count > Source.Count do Delete(Count - 1);
773 while Count < Source.Count do Add(TContactProperty.Create);
774 for I := 0 to Count - 1 do Items[I].Assign(Source.Items[I]);
775end;
776
777procedure TContactProperties.AssignToList(List: TObjects);
778var
779 I: Integer;
780begin
781 while List.Count > Count do List.Delete(List.Count - 1);
782 for I := 0 to List.Count - 1 do List[I] := Items[I];
783 while List.Count < Count do List.Add(Items[List.Count]);
784end;
785
786function TContactProperties.GetByName(Name: string): TContactProperty;
787var
788 I: Integer;
789begin
790 I := 0;
791 while (I < Count) and (Items[I].Name <> Name) and (not EndsWith(Items[I].Name, '.' + Name)) do Inc(I);
792 if I < Count then Result := Items[I]
793 else Result := nil;
794end;
795
796function TContactProperties.GetMultipleByName(Name: string): TContactProperties;
797var
798 I: Integer;
799begin
800 Result := TContactProperties.Create(False);
801 for I := 0 to Count - 1 do
802 if (Items[I].Name = Name) or EndsWith(Items[I].Name, '.' + Name) then
803 Result.Add(Items[I]);
804end;
805
806function TContactProperties.GetByNameGroups(Name: string; Groups: TStringArray;
807 NoGroups: TStringArray): TContactProperty;
808var
809 I: Integer;
810begin
811 I := 0;
812 while (I < Count) and not Items[I].MatchNameGroups(Name, Groups, NoGroups) do Inc(I);
813 if I < Count then Result := Items[I]
814 else Result := nil;
815end;
816
817function TContactProperties.GetByNameGroupsMultiple(Name: string;
818 Groups: TStringArray; NoGroups: TStringArray): TContactProperties;
819var
820 I: Integer;
821begin
822 Result := TContactProperties.Create(False);
823 for I := 0 to Count - 1 do
824 if Items[I].MatchNameGroups(Name, Groups, NoGroups) then
825 Result.Add(Items[I]);
826end;
827
828function TContactProperties.RemoveExactDuplicates: Integer;
829var
830 I: Integer;
831 J: Integer;
832begin
833 Result := 0;
834 for I := 0 to Count - 1 do
835 for J := Count - 1 downto I + 1 do
836 if Items[I].CompareTo(Items[J]) then begin
837 Remove(Items[J]);
838 Inc(Result);
839 end;
840end;
841
842{ TContactProperty }
843
844function TContactProperty.GetEncoding: TPropertyEncoding;
845var
846 EncodingText: string;
847begin
848 Result := veNone;
849 if Attributes.IndexOf(VCardBase64) <> -1 then Result := veBase64
850 else if Attributes.IndexOf(VCardQuotedPrintable) <> -1 then Result := veQuotedPrintable
851 else if Attributes.IndexOfName(VCardEncoding) <> -1 then begin
852 EncodingText := UpperCase(Attributes.Values[VCardEncoding]);
853 if (EncodingText = VCardBase64) or (EncodingText = VCardBase64Short) then Result := veBase64
854 else if (EncodingText = VCardQuotedPrintable) or (EncodingText = VCardQuotedPrintableShort) then Result := veQuotedPrintable
855 end;
856end;
857
858function TContactProperty.GetValueItem(Index: Integer): string;
859var
860 List: TStringList;
861begin
862 List := TStringList.Create;
863 try
864 List.Delimiter := ';';
865 List.NameValueSeparator := '=';
866 List.StrictDelimiter := True;
867 List.DelimitedText := Value;
868 if Index < List.Count then
869 Result := List.Strings[Index]
870 else Result := '';
871 finally
872 List.Free;
873 end;
874end;
875
876procedure TContactProperty.SetEncoding(AValue: TPropertyEncoding);
877begin
878 if Attributes.IndexOf(VCardBase64) <> -1 then begin
879 Attributes.Delete(Attributes.IndexOf(VCardBase64));
880 if AValue = veBase64 then Attributes.Add(VCardBase64)
881 else if AValue = veQuotedPrintable then Attributes.Add(VCardQuotedPrintable);
882 end else
883 if Attributes.IndexOf(VCardQuotedPrintable) <> -1 then begin
884 Attributes.Delete(Attributes.IndexOf(VCardQuotedPrintable));
885 if AValue = veBase64 then Attributes.Add(VCardBase64)
886 else if AValue = veQuotedPrintable then Attributes.Add(VCardQuotedPrintable);
887 end else
888 if Attributes.IndexOfName(VCardEncoding) <> -1 then begin
889 if AValue = veBase64 then Attributes.Values[VCardEncoding] := VCardBase64
890 else if AValue = veQuotedPrintable then Attributes.Values[VCardEncoding] := VCardQuotedPrintable
891 else Attributes.Delete(Attributes.IndexOfName(VCardEncoding));
892 end;
893end;
894
895procedure TContactProperty.SetValueItem(Index: Integer; AValue: string);
896var
897 List: TStringList;
898begin
899 List := TStringList.Create;
900 try
901 List.Delimiter := ';';
902 List.NameValueSeparator := '=';
903 List.StrictDelimiter := True;
904 List.DelimitedText := Value;
905
906 // Extend subitems count
907 while List.Count <= Index do
908 List.Add('');
909
910 List.Strings[Index] := AValue;
911
912 // Remove empty items
913 while (List.Count > 0) and (List.Strings[List.Count - 1] = '') do
914 List.Delete(List.Count - 1);
915
916 Value := List.DelimitedText;
917 finally
918 List.Free;
919 end;
920end;
921
922procedure TContactProperty.EvaluateAttributes;
923var
924 I: Integer;
925begin
926 if Encoding <> veNone then
927 Value := GetDecodedValue;
928
929 if Attributes.IndexOfName(VCardCharset) <> -1 then
930 Charset := Attributes.Values[VCardCharset]
931 else Charset := '';
932
933 // Simplify TYPE attribute from TYPE=VALUE into VALUE
934 for I := 0 to Attributes.Count - 1 do begin
935 if Attributes.Names[I] = 'TYPE' then
936 Attributes.Strings[I] := Attributes.Values['TYPE'];
937 if Attributes.Names[I] = 'type' then
938 Attributes.Strings[I] := Attributes.Values['type'];
939 end;
940end;
941
942function TContactProperty.GetDecodedValue: string;
943begin
944 if Encoding = veBase64 then begin
945 Result := DecodeStringBase64(Value);
946 end else
947 if Encoding = veQuotedPrintable then begin
948 Result := DecodeQuotedPrintable(Value, True);
949 end
950 else Result := '';
951end;
952
953function TContactProperty.GetEncodedValue: string;
954begin
955 if Encoding = veBase64 then begin
956 Result := EncodeStringBase64(Value);
957 end else
958 if Encoding = veQuotedPrintable then begin
959 Result := EncodeQuotedPrintable(Value, True);
960 end
961 else Result := '';
962end;
963
964function TContactProperty.MatchNameGroups(AName: string; Groups: TStringArray;
965 NoGroups: TStringArray): Boolean;
966var
967 I: Integer;
968begin
969 Result := (Name = AName) or EndsWith(Name, '.' + AName);
970 if Result and (Length(Groups) > 0) then begin
971 for I := 0 to Length(Groups) - 1 do
972 if (Attributes.IndexOf(Groups[I]) = -1) and
973 (Attributes.IndexOf('TYPE=' + Groups[I]) = -1) then begin
974 Result := False;
975 Break;
976 end;
977 end;
978 if Result and (Length(NoGroups) > 0) then begin
979 for I := 0 to Length(NoGroups) - 1 do
980 if (Attributes.IndexOf(NoGroups[I]) <> -1) or
981 (Attributes.IndexOf('TYPE=' + NoGroups[I]) <> -1) then begin
982 Result := False;
983 Break;
984 end;
985 end;
986end;
987
988procedure TContactProperty.Assign(Source: TContactProperty);
989begin
990 Name := Source.Name;
991 Attributes.Assign(Source.Attributes);
992 Value := Source.Value;
993 Charset := Source.Charset;
994end;
995
996function TContactProperty.CompareTo(ContactProperty: TContactProperty): Boolean;
997var
998 I: Integer;
999begin
1000 Result := (Name = ContactProperty.Name) and (Value = ContactProperty.Value) and
1001 (Attributes.Count = ContactProperty.Attributes.Count);
1002 if Result then begin
1003 for I := 0 to Attributes.Count - 1 do
1004 if not (Attributes[I] = ContactProperty.Attributes[I]) then begin
1005 Result := False;
1006 Break;
1007 end;
1008 end;
1009end;
1010
1011constructor TContactProperty.Create;
1012begin
1013 Attributes := TStringList.Create;
1014 Attributes.Delimiter := ';';
1015 Attributes.NameValueSeparator := '=';
1016 Attributes.StrictDelimiter := True;
1017end;
1018
1019destructor TContactProperty.Destroy;
1020begin
1021 FreeAndNil(Attributes);
1022 inherited;
1023end;
1024
1025{ TContacts }
1026
1027procedure TContacts.Assign(Source: TContacts);
1028var
1029 I: Integer;
1030begin
1031 while Count > Source.Count do Delete(Count - 1);
1032 while Count < Source.Count do Add(TContact.Create);
1033 for I := 0 to Count - 1 do begin
1034 Items[I].Assign(Source.Items[I]);
1035 Items[I].ParentVCard := ParentVCard;
1036 end;
1037end;
1038
1039procedure TContacts.AddContacts(Contacts: TContacts);
1040begin
1041 InsertContacts(Count, Contacts);
1042end;
1043
1044procedure TContacts.InsertContacts(Index: Integer; Contacts: TContacts);
1045var
1046 I: Integer;
1047 NewContact: TContact;
1048begin
1049 for I := 0 to Contacts.Count - 1 do begin
1050 NewContact := TContact.Create;
1051 NewContact.Assign(Contacts[I]);
1052 NewContact.ParentVCard := ParentVCard;
1053 Insert(Index, NewContact);
1054 Inc(Index);
1055 end;
1056end;
1057
1058function TContacts.RemoveExactDuplicates: Integer;
1059var
1060 I: Integer;
1061 J: Integer;
1062begin
1063 Result := 0;
1064 for I := 0 to Count - 1 do
1065 for J := Count - 1 downto I + 1 do
1066 if Items[I].CompareTo(Items[J]) then begin
1067 Remove(Items[J]);
1068 Inc(Result);
1069 end;
1070end;
1071
1072function ComparePropertyName(constref Item1, Item2: TContactProperty): Integer;
1073begin
1074 Result := CompareStr(Item1.Name + ';' + Item1.Attributes.Text,
1075 Item2.Name + ';' + Item2.Attributes.Text);
1076end;
1077
1078function CompareContactFullName(constref Item1, Item2: TContact): Integer;
1079begin
1080 Result := CompareStr(Item1.Fields[cfFullName], Item2.Fields[cfFullName]);
1081end;
1082
1083procedure TContacts.Sort;
1084var
1085 I: Integer;
1086 ContactProperty: TContactProperty;
1087begin
1088 inherited Sort(TComparer<TContact>.Construct(CompareContactFullName));
1089 for I := 0 to Count - 1 do begin
1090 Items[I].Properties.Sort(TComparer<TContactProperty>.Construct(ComparePropertyName));
1091
1092 // Make sure VERSION is first property
1093 ContactProperty := Items[I].Properties.GetByName('VERSION');
1094 if Assigned(ContactProperty) then begin
1095 Items[I].Properties.Move(Items[I].Properties.IndexOf(ContactProperty), 0);
1096 end;
1097 end;
1098end;
1099
1100procedure TContacts.AssignToList(List: TObjects);
1101var
1102 I: Integer;
1103begin
1104 while List.Count > Count do List.Delete(List.Count - 1);
1105 for I := 0 to List.Count - 1 do List[I] := Items[I];
1106 while List.Count < Count do List.Add(Items[List.Count]);
1107end;
1108
1109function TContacts.AddNew: TContact;
1110begin
1111 Result := TContact.Create;
1112 Result.ParentVCard := ParentVCard;
1113 Add(Result);
1114end;
1115
1116function TContacts.Search(Text: string; FieldIndex: TContactFieldIndex): TContact;
1117var
1118 I: Integer;
1119begin
1120 Result := nil;
1121 for I := 0 to Count - 1 do
1122 if Items[I].Fields[FieldIndex] = Text then begin
1123 Result := Items[I];
1124 Break;
1125 end;
1126end;
1127
1128function TContacts.CountByField(FieldIndex: TContactFieldIndex): Integer;
1129var
1130 I: Integer;
1131begin
1132 Result := 0;
1133 for I := 0 to Count - 1 do
1134 if Items[I].HasField(FieldIndex) then
1135 Inc(Result);
1136end;
1137
1138procedure TContacts.Merge(Contact: TContact; FieldIndex: TContactFieldIndex);
1139var
1140 NewContact: TContact;
1141begin
1142 NewContact := Search(Contact.Fields[FieldIndex], FieldIndex);
1143 if Assigned(NewContact) then begin
1144 NewContact.UpdateFrom(Contact);
1145 end else begin
1146 NewContact := TContact.Create;
1147 NewContact.Assign(Contact);
1148 NewContact.ParentVCard := ParentVCard;
1149 Add(NewContact);
1150 end;
1151end;
1152
1153function TContacts.ToString: ansistring;
1154var
1155 I: Integer;
1156begin
1157 Result := '';
1158 for I := 0 to Count - 1 do begin
1159 if I > 0 then Result := Result + ', ';
1160 Result := Result + Items[I].Fields[cfFullName];
1161 end;
1162end;
1163
1164{ TContactFields }
1165
1166procedure TContactFields.UpdateIndexes;
1167var
1168 I: Integer;
1169 Index: TContactFieldIndex;
1170begin
1171 for Index := Low(TContactFieldIndex) to High(TContactFieldIndex) do
1172 Indexes[Index] := nil;
1173 for I := 0 to Count - 1 do
1174 if not Assigned(Indexes[Items[I].Index]) then Indexes[Items[I].Index] := Items[I]
1175 else raise Exception.Create(Format(SFieldIndexRedefined, [Integer(Items[I].Index)]));
1176 IndexesUpdated := True;
1177end;
1178
1179function TContactFields.AddNew(Name: string; Groups: array of string;
1180 NoGroups: array of string; Title: string; Index: TContactFieldIndex;
1181 DataType: TDataType = dtNone; ValueIndex: Integer = -1): TContactField;
1182var
1183 I: Integer;
1184begin
1185 Result := TContactField.Create;
1186 Result.SysName := Name;
1187 SetLength(Result.Groups, Length(Groups));
1188 for I := 0 to Length(Groups) - 1 do
1189 Result.Groups[I] := Groups[I];
1190 SetLength(Result.NoGroups, Length(NoGroups));
1191 for I := 0 to Length(NoGroups) - 1 do
1192 Result.NoGroups[I] := NoGroups[I];
1193 Result.Title := Title;
1194 Result.Index := Index;
1195 Result.ValueIndex := ValueIndex;
1196 Result.DataType := DataType;
1197 Add(Result);
1198 IndexesUpdated := False;
1199end;
1200
1201function TContactFields.GetBySysName(SysName: string): TContactField;
1202var
1203 I: Integer;
1204begin
1205 I := 0;
1206 while (I < Count) and (Items[I].SysName <> SysName) do Inc(I);
1207 if I < Count then Result := Items[I]
1208 else Result := nil;
1209end;
1210
1211function TContactFields.GetBySysNameGroups(SysName: string; Groups: TStringArray
1212 ): TContactField;
1213var
1214 I: Integer;
1215begin
1216 I := 0;
1217 while (I < Count) and not Items[I].Match(SysName, Groups) do Inc(I);
1218 if I < Count then Result := Items[I]
1219 else Result := nil;
1220end;
1221
1222function TContactFields.GetByIndex(Index: TContactFieldIndex): TContactField;
1223var
1224 I: Integer;
1225begin
1226 if IndexesUpdated then Result := Indexes[Index]
1227 else begin
1228 I := 0;
1229 while (I < Count) and (Items[I].Index <> Index) do Inc(I);
1230 if I < Count then Result := Items[I]
1231 else Result := nil;
1232 end;
1233end;
1234
1235function TContactFields.GetByTitle(Title: string): TContactField;
1236var
1237 I: Integer;
1238begin
1239 I := 0;
1240 while (I < Count) and (Items[I].Title <> Title) do Inc(I);
1241 if I < Count then Result := Items[I]
1242 else Result := nil;
1243end;
1244
1245procedure TContactFields.LoadToStrings(AItems: TStrings);
1246var
1247 I: Integer;
1248begin
1249 AItems.BeginUpdate;
1250 try
1251 while AItems.Count < Count do AItems.Add('');
1252 while AItems.Count > Count do AItems.Delete(AItems.Count - 1);
1253 for I := 0 to Count - 1 do begin
1254 AItems.Objects[I] := Items[I];
1255 AItems[I] := Items[I].Title;
1256 end;
1257 SortStrings(AItems);
1258 finally
1259 AItems.EndUpdate;
1260 end;
1261end;
1262
1263{ TContact }
1264
1265class function TContact.GetFields: TContactFields;
1266begin
1267 if not Assigned(FFields) then begin
1268 FFields := TContactFields.Create;
1269 with FFields do begin
1270 AddNew('VERSION', [], [], SVersion, cfVersion, dtString);
1271 AddNew('N', [], [], SLastName, cfLastName, dtString, 0);
1272 AddNew('N', [], [], SFirstName, cfFirstName, dtString, 1);
1273 AddNew('N', [], [], SMiddleName, cfMiddleName, dtString, 2);
1274 AddNew('N', [], [], STitleBefore, cfTitleBefore, dtString, 3);
1275 AddNew('N', [], [], STitleAfter, cfTitleAfter, dtString, 4);
1276 AddNew('FN', [], [], SFullName, cfFullName, dtString);
1277 AddNew('TEL', [], ['CELL', 'FAX', 'PAGER', 'WORK', 'HOME'], STelephone, cfTel, dtString);
1278 AddNew('TEL', ['CELL'], ['WORK', 'HOME'], SMobilePhone, cfTelCell, dtString);
1279 AddNew('TEL', ['FAX'], ['WORK', 'HOME'], SFax, cfTelFax, dtString);
1280 AddNew('TEL', ['PAGER'], ['WORK', 'HOME'], SPager, cfTelPager, dtString);
1281 AddNew('TEL', ['HOME'], ['CELL', 'FAX', 'PAGER'], SHomePhone, cfTelHome, dtString);
1282 AddNew('TEL', ['HOME', 'CELL'], [], SHomeMobile, cfTelCellHome, dtString);
1283 AddNew('TEL', ['HOME', 'FAX'], [], SHomeFax, cfTelFaxHome, dtString);
1284 AddNew('TEL', ['HOME', 'PAGER'], [], SHomePager, cfTelPagerHome, dtString);
1285 AddNew('TEL', ['WORK'], ['CELL', 'FAX', 'PAGER'], SWorkPhone, cfTelWork, dtString);
1286 AddNew('TEL', ['WORK', 'CELL'], [], SWorkMobile, cfTelCellWork, dtString);
1287 AddNew('TEL', ['WORK', 'FAX'], [], SWorkFax, cfTelFaxWork, dtString);
1288 AddNew('TEL', ['WORK', 'PAGER'], [], SWorkPager, cfTelPagerWork, dtString);
1289 AddNew('TEL', ['HOME2'], [], SHomePhone2, cfTelHome2, dtString);
1290 AddNew('TEL', ['VOIP'], [], SVoipPhone, cfTelVoip, dtString);
1291 AddNew('TEL', ['MAIN'], [], SMainPhone, cfTelMain, dtString);
1292 AddNew('EMAIL', [], ['HOME', 'WORK', 'INTERNET'], SEmail, cfEmail, dtString);
1293 AddNew('EMAIL', ['HOME'], [], SHomeEmail, cfEmailHome, dtString);
1294 AddNew('EMAIL', ['WORK'], [], SWorkEmail, cfEmailWork, dtString);
1295 AddNew('EMAIL', ['INTERNET'], [], SInternetEmail, cfEmailInternet, dtString);
1296 with AddNew('NICKNAME', [], [], SNickName, cfNickName, dtString) do
1297 AddAlternative('X-NICKNAME', [], []);
1298 AddNew('NOTE', [], [], SNote, cfNote, dtString);
1299 AddNew('ROLE', [], [], SRole, cfRole, dtString);
1300 AddNew('TITLE', [], [], STitle, cfTitle, dtString);
1301 AddNew('CATEGORIES', [], [], SCategories, cfCategories, dtString);
1302 AddNew('ORG', [], [], SOrganization, cfOrganization, dtString, 0);
1303 AddNew('ORG', [], [], SDepartement, cfDepartment, dtString, 1);
1304 AddNew('ADR', ['HOME'], [], SHomeAddressPostOfficeBox, cfHomeAddressPostOfficeBox, dtString, 0);
1305 AddNew('ADR', ['HOME'], [], SHomeAddressStreetExtended, cfHomeAddressStreetExtended, dtString, 1);
1306 AddNew('ADR', ['HOME'], [], SHomeAddressStreet, cfHomeAddressStreet, dtString, 2);
1307 AddNew('ADR', ['HOME'], [], SHomeAddressCity, cfHomeAddressCity, dtString, 3);
1308 AddNew('ADR', ['HOME'], [], SHomeAddressRegion, cfHomeAddressRegion, dtString, 4);
1309 AddNew('ADR', ['HOME'], [], SHomeAddressPostalCode, cfHomeAddressPostalCode, dtString, 5);
1310 AddNew('ADR', ['HOME'], [], SHomeAddressCountry, cfHomeAddressCountry, dtString, 6);
1311 AddNew('ADR', ['WORK'], [], SWorkAddressPostOfficeBox, cfWorkAddressPostOfficeBox, dtString, 0);
1312 AddNew('ADR', ['WORK'], [], SWorkAddressStreetExtended, cfWorkAddressStreetExtended, dtString, 1);
1313 AddNew('ADR', ['WORK'], [], SWorkAddressStreet, cfWorkAddressStreet, dtString, 2);
1314 AddNew('ADR', ['WORK'], [], SWorkAddressCity, cfWorkAddressCity, dtString, 3);
1315 AddNew('ADR', ['WORK'], [], SWorkAddressRegion, cfWorkAddressRegion, dtString, 4);
1316 AddNew('ADR', ['WORK'], [], SWorkAddressPostalCode, cfWorkAddressPostalCode, dtString, 5);
1317 AddNew('ADR', ['WORK'], [], SWorkAddressCountry, cfWorkAddressCountry, dtString, 6);
1318 AddNew('X-TIMES_CONTACTED', [], [], STimesContacted, cfXTimesContacted, dtString);
1319 AddNew('X-LAST_TIME_CONTACTED', [], [], SLastTimeContacted, cfXLastTimeContacted, dtString);
1320 AddNew('PHOTO', [], [], SPhoto, cfPhoto, dtImage);
1321 AddNew('LOGO', [], [], SLogo, cfLogo, dtImage);
1322 AddNew('BDAY', [], [], SDayOfBirth, cfDayOfBirth, dtDate);
1323 with AddNew('ANNIVERSARY', [], [], SAnniversary, cfAnniversary, dtDate) do
1324 AddAlternative('X-EVOLUTION-ANNIVERSARY', [], []);
1325 AddNew('REV', [], [], SRevision, cfRevision, dtString);
1326 AddNew('UID', [], [], SUniqueIdentifier, cfUid, dtString);
1327 AddNew('URL', [], ['HOME', 'WORK'], SWebAddress, cfUrl, dtString);
1328 AddNew('URL', ['HOME'], [], SWebAddressHome, cfUrlHome, dtString);
1329 AddNew('URL', ['WORK'], [], SWebAddressWork, cfUrlWork, dtString);
1330 with AddNew('GENDER', [], [], SGender, cfGender, dtString) do
1331 AddAlternative('X-CENTRUM-CZ-SEX', [], []);
1332 // Chat
1333 AddNew('X-MATRIX', [], [], SMatrix, cfMatrix, dtString);
1334 AddNew('X-JABBER', [], [], SJabber, cfJabber, dtString);
1335 AddNew('X-AIM', [], [], SAim, cfAim, dtString);
1336 AddNew('X-Windows Live', [], [], SWindowsLive, cfWindowsLive, dtString);
1337 AddNew('X-YAHOO', [], [], SYahoo, cfYahoo, dtString);
1338 with AddNew('X-SKYPE-USERNAME', [], [], SSkype, cfSkype, dtString) do begin
1339 AddAlternative('X-SKYPE', [], []);
1340 AddAlternative('X-CENTRUM-CZ-SKYPE', [], []);
1341 end;
1342 AddNew('X-QQ', [], [], SQq, cfQq, dtString);
1343 AddNew('X-GOOGLE-TALK', [], [], SGoogleTalk, cfGoogleTalk, dtString);
1344 with AddNew('X-ICQ', [], [], SIcq, cfIcq, dtString) do
1345 AddAlternative('X-CENTRUM-CZ-ICQ', [], []);
1346 AddNew('X-IRC', [], [], SIrc, cfIrc, dtString);
1347 with AddNew('X-MSN', [], [], SMsn, cfMsn, dtString) do
1348 AddAlternative('X-CENTRUM-CZ-MSN', [], []);
1349 AddNew('X-GROUPWISE', [], [], SGroupWise, cfGroupWise, dtString);
1350 AddNew('X-GADUGADU', [], [], SGaduGadu, cfGaduGadu, dtString);
1351 // Social
1352 with AddNew('X-TWITTER', [], [], STwitter, cfTwitter, dtString) do
1353 AddAlternative('X-SOCIALPROFILE', ['TWITTER'], []);
1354 with AddNew('X-FACEBOOK', [], [], SFacebook, cfFacebook, dtString) do
1355 AddAlternative('X-SOCIALPROFILE', ['FACEBOOK'], []);
1356 with AddNew('X-MASTODON', [], [], SMastodon, cfMastodon, dtString) do
1357 AddAlternative('X-SOCIALPROFILE', ['MASTODON'], []);
1358 with AddNew('X-YOUTUBE', [], [], SYouTube, cfYouTube, dtString) do
1359 AddAlternative('X-SOCIALPROFILE', ['YOUTUBE'], []);
1360 with AddNew('X-PEERTUBE', [], [], SPeerTube, cfPeerTube, dtString) do
1361 AddAlternative('X-SOCIALPROFILE', ['PEERTUBE'], []);
1362 with AddNew('X-LINKEDIN', [], [], SLinkedIn, cfLinkedIn, dtString) do
1363 AddAlternative('X-SOCIALPROFILE', ['LINKEDIN'], []);
1364 with AddNew('X-SNAPCHAT', [], [], SSnapchat, cfSnapchat, dtString) do
1365 AddAlternative('X-SOCIALPROFILE', ['SNAPCHAT'], []);
1366 with AddNew('X-INSTAGRAM', [], [], SInstagram, cfInstagram, dtString) do
1367 AddAlternative('X-SOCIALPROFILE', ['INSTAGRAM'], []);
1368 with AddNew('X-REDDIT', [], [], SReddit, cfReddit, dtString) do
1369 AddAlternative('X-SOCIALPROFILE', ['REDDIT'], []);
1370 with AddNew('X-MYSPACE', [], [], SMySpace, cfMySpace, dtString) do
1371 AddAlternative('X-SOCIALPROFILE', ['MYSPACE'], []);
1372 UpdateIndexes;
1373 end;
1374 end;
1375 Result := FFields;
1376end;
1377
1378function TContact.GetField(Index: TContactFieldIndex): string;
1379var
1380 Prop: TContactProperty;
1381 Field: TContactField;
1382begin
1383 if not Assigned(ParentVCard) then
1384 raise Exception.Create(SContactHasNoParent);
1385 Field := GetFields.GetByIndex(Index);
1386 if Assigned(Field) then begin
1387 Prop := GetProperty(Field);
1388 if Assigned(Prop) then begin
1389 if Field.ValueIndex <> -1 then begin
1390 Result := DecodeEscaped(Prop.ValueItem[Field.ValueIndex])
1391 end else begin
1392 if Field.DataType = dtString then Result := DecodeEscaped(Prop.Value)
1393 else Result := Prop.Value;
1394 end;
1395 end else Result := '';
1396 end else raise Exception.Create(SFieldIndexNotDefined);
1397end;
1398
1399function TContact.GetString: string;
1400var
1401 Lines: TStringList;
1402begin
1403 Lines := TStringList.Create;
1404 try
1405 SaveToStrings(Lines);
1406 Result := Lines.Text;
1407 finally
1408 Lines.Free;
1409 end;
1410end;
1411
1412procedure TContact.SetField(Index: TContactFieldIndex; AValue: string);
1413var
1414 Prop: TContactProperty;
1415 Field: TContactField;
1416 I: Integer;
1417begin
1418 if not Assigned(ParentVCard) then
1419 raise Exception.Create(SContactHasNoParent);
1420 Field := GetFields.GetByIndex(Index);
1421 if Assigned(Field) then begin
1422 Prop := GetProperty(Field);
1423 if (not Assigned(Prop)) and (AValue <> '') then begin
1424 Prop := TContactProperty.Create;
1425 Prop.Name := Field.SysName;
1426 for I := 0 to Length(Field.Groups) - 1 do
1427 Prop.Attributes.Add(Field.Groups[I]);
1428 Properties.Add(Prop);
1429 end;
1430 if Assigned(Prop) then begin
1431 if Field.ValueIndex <> -1 then begin
1432 Prop.ValueItem[Field.ValueIndex] := EncodeEscaped(AValue);
1433 end else begin
1434 if Field.DataType = dtString then Prop.Value := EncodeEscaped(AValue)
1435 else Prop.Value := AValue;
1436 end;
1437
1438 // Remove if empty
1439 if Prop.Value = '' then begin
1440 Properties.Remove(Prop);
1441 end;
1442 end;
1443 Modified := True;
1444 end else raise Exception.Create(SFieldIndexNotDefined);
1445end;
1446
1447procedure TContact.SetModified(AValue: Boolean);
1448begin
1449 if FModified = AValue then Exit;
1450 FModified := AValue;
1451 DoOnModify;
1452end;
1453
1454procedure TContact.DoOnModify;
1455begin
1456 if Assigned(FOnModify) then FOnModify(Self);
1457end;
1458
1459procedure TContact.DetectMaxLineLength(Text: string);
1460var
1461 LineLength: Integer;
1462begin
1463 LineLength := UTF8Length(Text);
1464 if LineLength > 1 then begin
1465 // Count one character less for folded line
1466 if Text[1] = ' ' then
1467 Dec(LineLength);
1468 end;
1469 if LineLength > ParentVCard.MaxLineLength then
1470 ParentVCard.MaxLineLength := LineLength;
1471end;
1472
1473procedure TContact.SetString(AValue: string);
1474var
1475 Lines: TStringList;
1476 StartLine: Integer;
1477begin
1478 Lines := TStringList.Create;
1479 try
1480 Lines.Text := AValue;
1481 StartLine := 0;
1482 LoadFromStrings(Lines, StartLine);
1483 finally
1484 Lines.Free;
1485 end;
1486end;
1487
1488function TContact.HasField(FieldIndex: TContactFieldIndex): Boolean;
1489var
1490 Field: TContactField;
1491begin
1492 if not Assigned(ParentVCard) then raise Exception.Create(SContactHasNoParent);
1493 Field := GetFields.GetByIndex(FieldIndex);
1494 if Assigned(Field) then begin
1495 Result := Assigned(GetProperty(Field));
1496 end else raise Exception.Create(SFieldIndexNotDefined);
1497end;
1498
1499function TContact.FullNameToFileName: string;
1500var
1501 I: Integer;
1502begin
1503 Result := Fields[cfFullName];
1504 for I := 1 to Length(Result) do begin
1505 if Result[I] in [':', '/', '\', '.', '"', '*', '|', '?', '<', '>'] then
1506 Result[I] := '_';
1507 end;
1508end;
1509
1510function TContact.GetProperty(Field: TContactField): TContactProperty;
1511var
1512 I: Integer;
1513begin
1514 Result := Properties.GetByNameGroups(Field.SysName, Field.Groups, Field.NoGroups);
1515 I := 0;
1516 while (not Assigned(Result)) and (I < Field.Alternatives.Count) do begin
1517 Result := Properties.GetByNameGroups(Field.Alternatives[I].SysName,
1518 Field.Alternatives[I].Groups, Field.Alternatives[I].NoGroups);
1519 if Assigned(Result) then Break;
1520 Inc(I);
1521 end;
1522end;
1523
1524function TContact.GetProperty(FieldIndex: TContactFieldIndex): TContactProperty;
1525var
1526 Field: TContactField;
1527begin
1528 if not Assigned(ParentVCard) then raise Exception.Create(SContactHasNoParent);
1529 Field := GetFields.GetByIndex(FieldIndex);
1530 if Assigned(Field) then begin
1531 Result := GetProperty(Field);
1532 end else Result := nil;
1533end;
1534
1535procedure TContact.Assign(Source: TContact);
1536begin
1537 Properties.Assign(Source.Properties);
1538 FModified := Source.FModified;
1539end;
1540
1541function TContact.UpdateFrom(Source: TContact): Boolean;
1542var
1543 I: Integer;
1544begin
1545 if not Assigned(ParentVCard) then raise Exception.Create(SContactHasNoParent);
1546 Result := False;
1547 for I := 0 to GetFields.Count - 1 do begin
1548 if (Source.Fields[GetFields[I].Index] <> '') and
1549 (Source.Fields[GetFields[I].Index] <>
1550 Fields[GetFields[I].Index]) then begin
1551 Result := True;
1552 Fields[GetFields[I].Index] := Source.Fields[GetFields[I].Index];
1553 end;
1554 end;
1555end;
1556
1557function TContact.CompareTo(Contact: TContact): Boolean;
1558var
1559 I: Integer;
1560begin
1561 Result := Properties.Count = Contact.Properties.Count;
1562 if Result then begin
1563 for I := 0 to Properties.Count - 1 do
1564 if not Properties[I].CompareTo(Contact.Properties[I]) then begin
1565 Result := False;
1566 Break;
1567 end;
1568 end;
1569end;
1570
1571constructor TContact.Create;
1572begin
1573 Properties := TContactProperties.Create;
1574end;
1575
1576destructor TContact.Destroy;
1577begin
1578 FreeAndNil(Properties);
1579 inherited;
1580end;
1581
1582class destructor TContact.Destroy2;
1583begin
1584 FreeAndNil(FFields);
1585end;
1586
1587procedure TContact.SaveToStrings(Output: TStrings);
1588var
1589 I: Integer;
1590 NameText: string;
1591 Value2: string;
1592 LineIndex: Integer;
1593 OutText: string;
1594 CutText: string;
1595 LinePrefix: string;
1596 CutLength: Integer;
1597 Cut: Boolean;
1598begin
1599 with Output do begin
1600 LineBreak := VCardLineEnding;
1601 Add(VCardBegin);
1602 for I := 0 to Properties.Count - 1 do
1603 with Properties[I] do begin
1604 NameText := Name;
1605 if Attributes.Count > 0 then
1606 NameText := NameText + ';' + Attributes.DelimitedText;
1607 if Encoding <> veNone then begin
1608 Value2 := GetEncodedValue;
1609 end else Value2 := Value;
1610 if Pos(LineEnding, Value2) > 0 then begin
1611 Add(NameText + ':' + GetNext(Value2, LineEnding));
1612 while Pos(LineEnding, Value2) > 0 do begin
1613 Add(' ' + GetNext(Value2, LineEnding));
1614 end;
1615 Add(' ' + GetNext(Value2, LineEnding));
1616 Add('');
1617 end else begin
1618 OutText := NameText + ':' + Value2;
1619 LineIndex := 0;
1620 LinePrefix := '';
1621 Cut := False;
1622 while True do begin
1623 if UTF8Length(OutText) > ParentVCard.MaxLineLength then begin
1624 Cut := True;
1625 CutLength := ParentVCard.MaxLineLength;
1626 if Encoding = veQuotedPrintable then begin
1627 Dec(CutLength); // There will be softline break at the end
1628 // Do not cut encoded items at the end of line
1629 if ((CutLength - 1) >= 1) and (OutText[CutLength - 1] = QuotedPrintableEscapeCharacter) then
1630 Dec(CutLength, 2)
1631 else if OutText[CutLength] = QuotedPrintableEscapeCharacter then
1632 Dec(CutLength, 1);
1633 end;
1634
1635 CutText := UTF8Copy(OutText, 1, CutLength);
1636 System.Delete(OutText, 1, Length(CutText));
1637 if Encoding = veQuotedPrintable then
1638 CutText := CutText + QuotedPrintableEscapeCharacter; // Add soft line break
1639 Add(LinePrefix + CutText);
1640 if Encoding <> veQuotedPrintable then
1641 LinePrefix := ' ';
1642 Inc(LineIndex);
1643 Continue;
1644 end else begin
1645 Add(LinePrefix + OutText);
1646 if Cut then Add('');
1647 Break;
1648 end;
1649 end;
1650 end;
1651 end;
1652 Add(VCardEnd);
1653 end;
1654end;
1655
1656function TContact.LoadFromStrings(Lines: TStrings; var StartLine: Integer): Boolean;
1657type
1658 TParseState = (psNone, psInside, psFinished);
1659var
1660 ParseState: TParseState;
1661 Line: string;
1662 Line2: string;
1663 Value: string;
1664 I: Integer;
1665 NewProperty: TContactProperty;
1666 CommandPart: string;
1667 Names: string;
1668 QuotedPrintableMultiLine: Boolean;
1669begin
1670 Result := False;
1671 ParseState := psNone;
1672 I := StartLine;
1673 while I < Lines.Count do begin
1674 Line := Lines[I];
1675 //DetectMaxLineLength(Line);
1676
1677 if Line = '' then begin
1678 // Skip empty lines
1679 end else
1680 if ParseState = psNone then begin
1681 if Line = VCardBegin then begin
1682 ParseState := psInside;
1683 end else begin
1684 ParentVCard.Error(SExpectedVCardBegin, I + 1);
1685 Break;
1686 end;
1687 end else
1688 if ParseState = psInside then begin
1689 if Line = VCardEnd then begin
1690 ParseState := psFinished;
1691 Inc(I);
1692 Result := True;
1693 Break;
1694 end else
1695 if Pos(':', Line) > 0 then begin
1696 CommandPart := GetNext(Line, ':');
1697 Names := CommandPart;
1698 QuotedPrintableMultiLine := Pos('encoding=quoted-printable', LowerCase(CommandPart)) > 0;
1699 Value := Line;
1700 while True do begin
1701 Inc(I);
1702 if I >= Lines.Count then Break;
1703 Line2 := Lines[I];
1704 //DetectMaxLineLength(Line2);
1705 if (Length(Line2) > 0) and (Line2[1] = ' ') then begin
1706 Value := Value + Copy(Line2, 2, MaxInt);
1707 end else
1708 if QuotedPrintableMultiLine and (Length(Value) > 0) and
1709 (Value[Length(Value)] = QuotedPrintableEscapeCharacter) then begin
1710 SetLength(Value, Length(Value) - 1);
1711 Value := Value + Line2;
1712 end else begin
1713 Dec(I);
1714 Break;
1715 end;
1716 end;
1717 NewProperty := Properties.GetByName(Names);
1718 if not Assigned(NewProperty) then begin
1719 NewProperty := TContactProperty.Create;
1720 Properties.Add(NewProperty);
1721 end;
1722 NewProperty.Attributes.DelimitedText := Names;
1723 if NewProperty.Attributes.Count > 0 then begin
1724 NewProperty.Name := NewProperty.Attributes[0];
1725 NewProperty.Attributes.Delete(0);
1726 end;
1727 NewProperty.Value := Value;
1728 NewProperty.EvaluateAttributes;
1729 end else begin
1730 ParentVCard.Error(SExpectedProperty, I + 1);
1731 Break;
1732 end;
1733 end;
1734 Inc(I);
1735 end;
1736 if Result then StartLine := I;
1737end;
1738
1739procedure TContact.SaveToFile(FileName: string);
1740var
1741 Lines: TStringList;
1742begin
1743 Lines := TStringList.Create;
1744 try
1745 SaveToStrings(Lines);
1746 Lines.SaveToFile(FileName);
1747 finally
1748 Lines.Free;
1749 end;
1750end;
1751
1752procedure TContact.LoadFromFile(FileName: string);
1753var
1754 Lines: TStringList;
1755 StartLine: Integer;
1756begin
1757 Lines := TStringList.Create;
1758 try
1759 Lines.LoadFromFile(FileName);
1760 {$IF FPC_FULLVERSION>=30200}
1761 if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
1762 Lines.LoadFromFile(FileName, TEncoding.Unicode);
1763 if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
1764 Lines.LoadFromFile(FileName, TEncoding.BigEndianUnicode);
1765 end;
1766 end;
1767 {$ENDIF}
1768 StartLine := 0;
1769 LoadFromStrings(Lines, StartLine);
1770 finally
1771 Lines.Free;
1772 end;
1773end;
1774
1775end.
1776
Note: See TracBrowser for help on using the repository browser.