source: trunk/Packages/VCard/VCard.pas

Last change on this file was 199, checked in by chronos, 2 months ago
  • Fixed: Handling escaped semicolon in indexed property values.
File size: 53.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 I: Integer;
861 P: Integer;
862 CurrentIndex: Integer;
863 CurrentIndexStart: Integer;
864 CurrentIndexEnd: Integer;
865begin
866 CurrentIndex := 0;
867 CurrentIndexStart := 1;
868 CurrentIndexEnd := Length(Value);
869 P := 1;
870 repeat
871 I := Pos(';', Value, P);
872 if I > 0 then begin
873 if (I > 1) and (Value[I - 1] = '\') then begin
874 P := I + 1;
875 Continue;
876 end else begin
877 CurrentIndexEnd := I - 1;
878 if CurrentIndex = Index then begin
879 Break;
880 end else begin
881 P := I + 1;
882 Inc(CurrentIndex);
883 CurrentIndexStart := P;
884 CurrentIndexEnd := Length(Value);
885 end;
886 end;
887 end else begin
888 Break;
889 end;
890 until False;
891 if Index = CurrentIndex then begin
892 Result := Copy(Value, CurrentIndexStart, CurrentIndexEnd - CurrentIndexStart + 1);
893 end else Result := '';
894end;
895
896procedure TContactProperty.SetEncoding(AValue: TPropertyEncoding);
897begin
898 if Attributes.IndexOf(VCardBase64) <> -1 then begin
899 Attributes.Delete(Attributes.IndexOf(VCardBase64));
900 if AValue = veBase64 then Attributes.Add(VCardBase64)
901 else if AValue = veQuotedPrintable then Attributes.Add(VCardQuotedPrintable);
902 end else
903 if Attributes.IndexOf(VCardQuotedPrintable) <> -1 then begin
904 Attributes.Delete(Attributes.IndexOf(VCardQuotedPrintable));
905 if AValue = veBase64 then Attributes.Add(VCardBase64)
906 else if AValue = veQuotedPrintable then Attributes.Add(VCardQuotedPrintable);
907 end else
908 if Attributes.IndexOfName(VCardEncoding) <> -1 then begin
909 if AValue = veBase64 then Attributes.Values[VCardEncoding] := VCardBase64
910 else if AValue = veQuotedPrintable then Attributes.Values[VCardEncoding] := VCardQuotedPrintable
911 else Attributes.Delete(Attributes.IndexOfName(VCardEncoding));
912 end;
913end;
914
915procedure TContactProperty.SetValueItem(Index: Integer; AValue: string);
916var
917 I: Integer;
918 P: Integer;
919 CurrentIndex: Integer;
920 CurrentIndexStart: Integer;
921 CurrentIndexEnd: Integer;
922begin
923 CurrentIndex := 0;
924 CurrentIndexStart := 1;
925 CurrentIndexEnd := Length(Value);
926 P := 1;
927 repeat
928 I := Pos(';', Value, P);
929 if I > 0 then begin
930 if (I > 1) and (Value[I - 1] = '\') then begin
931 P := I + 1;
932 Continue;
933 end else begin
934 CurrentIndexEnd := I - 1;
935 if CurrentIndex = Index then begin
936 Break;
937 end else begin
938 P := I + 1;
939 Inc(CurrentIndex);
940 CurrentIndexStart := P;
941 CurrentIndexEnd := Length(Value);
942 end;
943 end;
944 end else begin
945 Break;
946 end;
947 until False;
948 if Index = CurrentIndex then begin
949 Value := Copy(Value, 1, CurrentIndexStart - 1) +
950 AValue + Copy(Value, CurrentIndexEnd + 1, MaxInt);
951 end else begin
952 for I := CurrentIndex + 1 to Index do begin
953 Value := Value + ';';
954 if I = Index then Value := Value + AValue;
955 end;
956 end;
957end;
958
959procedure TContactProperty.EvaluateAttributes;
960var
961 I: Integer;
962begin
963 if Encoding <> veNone then
964 Value := GetDecodedValue;
965
966 if Attributes.IndexOfName(VCardCharset) <> -1 then
967 Charset := Attributes.Values[VCardCharset]
968 else Charset := '';
969
970 // Simplify TYPE attribute from TYPE=VALUE into VALUE
971 for I := 0 to Attributes.Count - 1 do begin
972 if Attributes.Names[I] = 'TYPE' then
973 Attributes.Strings[I] := Attributes.Values['TYPE'];
974 if Attributes.Names[I] = 'type' then
975 Attributes.Strings[I] := Attributes.Values['type'];
976 end;
977end;
978
979function TContactProperty.GetDecodedValue: string;
980begin
981 if Encoding = veBase64 then begin
982 Result := DecodeStringBase64(Value);
983 end else
984 if Encoding = veQuotedPrintable then begin
985 Result := DecodeQuotedPrintable(Value, True);
986 end
987 else Result := '';
988end;
989
990function TContactProperty.GetEncodedValue: string;
991begin
992 if Encoding = veBase64 then begin
993 Result := EncodeStringBase64(Value);
994 end else
995 if Encoding = veQuotedPrintable then begin
996 Result := EncodeQuotedPrintable(Value, True);
997 end
998 else Result := '';
999end;
1000
1001function TContactProperty.MatchNameGroups(AName: string; Groups: TStringArray;
1002 NoGroups: TStringArray): Boolean;
1003var
1004 I: Integer;
1005begin
1006 Result := (Name = AName) or EndsWith(Name, '.' + AName);
1007 if Result and (Length(Groups) > 0) then begin
1008 for I := 0 to Length(Groups) - 1 do
1009 if (Attributes.IndexOf(Groups[I]) = -1) and
1010 (Attributes.IndexOf('TYPE=' + Groups[I]) = -1) then begin
1011 Result := False;
1012 Break;
1013 end;
1014 end;
1015 if Result and (Length(NoGroups) > 0) then begin
1016 for I := 0 to Length(NoGroups) - 1 do
1017 if (Attributes.IndexOf(NoGroups[I]) <> -1) or
1018 (Attributes.IndexOf('TYPE=' + NoGroups[I]) <> -1) then begin
1019 Result := False;
1020 Break;
1021 end;
1022 end;
1023end;
1024
1025procedure TContactProperty.Assign(Source: TContactProperty);
1026begin
1027 Name := Source.Name;
1028 Attributes.Assign(Source.Attributes);
1029 Value := Source.Value;
1030 Charset := Source.Charset;
1031end;
1032
1033function TContactProperty.CompareTo(ContactProperty: TContactProperty): Boolean;
1034var
1035 I: Integer;
1036begin
1037 Result := (Name = ContactProperty.Name) and (Value = ContactProperty.Value) and
1038 (Attributes.Count = ContactProperty.Attributes.Count);
1039 if Result then begin
1040 for I := 0 to Attributes.Count - 1 do
1041 if not (Attributes[I] = ContactProperty.Attributes[I]) then begin
1042 Result := False;
1043 Break;
1044 end;
1045 end;
1046end;
1047
1048constructor TContactProperty.Create;
1049begin
1050 Attributes := TStringList.Create;
1051 Attributes.Delimiter := ';';
1052 Attributes.NameValueSeparator := '=';
1053 Attributes.StrictDelimiter := True;
1054end;
1055
1056destructor TContactProperty.Destroy;
1057begin
1058 FreeAndNil(Attributes);
1059 inherited;
1060end;
1061
1062{ TContacts }
1063
1064procedure TContacts.Assign(Source: TContacts);
1065var
1066 I: Integer;
1067begin
1068 while Count > Source.Count do Delete(Count - 1);
1069 while Count < Source.Count do Add(TContact.Create);
1070 for I := 0 to Count - 1 do begin
1071 Items[I].Assign(Source.Items[I]);
1072 Items[I].ParentVCard := ParentVCard;
1073 end;
1074end;
1075
1076procedure TContacts.AddContacts(Contacts: TContacts);
1077begin
1078 InsertContacts(Count, Contacts);
1079end;
1080
1081procedure TContacts.InsertContacts(Index: Integer; Contacts: TContacts);
1082var
1083 I: Integer;
1084 NewContact: TContact;
1085begin
1086 for I := 0 to Contacts.Count - 1 do begin
1087 NewContact := TContact.Create;
1088 NewContact.Assign(Contacts[I]);
1089 NewContact.ParentVCard := ParentVCard;
1090 Insert(Index, NewContact);
1091 Inc(Index);
1092 end;
1093end;
1094
1095function TContacts.RemoveExactDuplicates: Integer;
1096var
1097 I: Integer;
1098 J: Integer;
1099begin
1100 Result := 0;
1101 for I := 0 to Count - 1 do
1102 for J := Count - 1 downto I + 1 do
1103 if Items[I].CompareTo(Items[J]) then begin
1104 Remove(Items[J]);
1105 Inc(Result);
1106 end;
1107end;
1108
1109function ComparePropertyName(constref Item1, Item2: TContactProperty): Integer;
1110begin
1111 Result := CompareStr(Item1.Name + ';' + Item1.Attributes.Text,
1112 Item2.Name + ';' + Item2.Attributes.Text);
1113end;
1114
1115function CompareContactFullName(constref Item1, Item2: TContact): Integer;
1116begin
1117 Result := CompareStr(Item1.Fields[cfFullName], Item2.Fields[cfFullName]);
1118end;
1119
1120procedure TContacts.Sort;
1121var
1122 I: Integer;
1123 ContactProperty: TContactProperty;
1124begin
1125 inherited Sort(TComparer<TContact>.Construct(CompareContactFullName));
1126 for I := 0 to Count - 1 do begin
1127 Items[I].Properties.Sort(TComparer<TContactProperty>.Construct(ComparePropertyName));
1128
1129 // Make sure VERSION is first property
1130 ContactProperty := Items[I].Properties.GetByName('VERSION');
1131 if Assigned(ContactProperty) then begin
1132 Items[I].Properties.Move(Items[I].Properties.IndexOf(ContactProperty), 0);
1133 end;
1134 end;
1135end;
1136
1137procedure TContacts.AssignToList(List: TObjects);
1138var
1139 I: Integer;
1140begin
1141 while List.Count > Count do List.Delete(List.Count - 1);
1142 for I := 0 to List.Count - 1 do List[I] := Items[I];
1143 while List.Count < Count do List.Add(Items[List.Count]);
1144end;
1145
1146function TContacts.AddNew: TContact;
1147begin
1148 Result := TContact.Create;
1149 Result.ParentVCard := ParentVCard;
1150 Add(Result);
1151end;
1152
1153function TContacts.Search(Text: string; FieldIndex: TContactFieldIndex): TContact;
1154var
1155 I: Integer;
1156begin
1157 Result := nil;
1158 for I := 0 to Count - 1 do
1159 if Items[I].Fields[FieldIndex] = Text then begin
1160 Result := Items[I];
1161 Break;
1162 end;
1163end;
1164
1165function TContacts.CountByField(FieldIndex: TContactFieldIndex): Integer;
1166var
1167 I: Integer;
1168begin
1169 Result := 0;
1170 for I := 0 to Count - 1 do
1171 if Items[I].HasField(FieldIndex) then
1172 Inc(Result);
1173end;
1174
1175procedure TContacts.Merge(Contact: TContact; FieldIndex: TContactFieldIndex);
1176var
1177 NewContact: TContact;
1178begin
1179 NewContact := Search(Contact.Fields[FieldIndex], FieldIndex);
1180 if Assigned(NewContact) then begin
1181 NewContact.UpdateFrom(Contact);
1182 end else begin
1183 NewContact := TContact.Create;
1184 NewContact.Assign(Contact);
1185 NewContact.ParentVCard := ParentVCard;
1186 Add(NewContact);
1187 end;
1188end;
1189
1190function TContacts.ToString: ansistring;
1191var
1192 I: Integer;
1193begin
1194 Result := '';
1195 for I := 0 to Count - 1 do begin
1196 if I > 0 then Result := Result + ', ';
1197 Result := Result + Items[I].Fields[cfFullName];
1198 end;
1199end;
1200
1201{ TContactFields }
1202
1203procedure TContactFields.UpdateIndexes;
1204var
1205 I: Integer;
1206 Index: TContactFieldIndex;
1207begin
1208 for Index := Low(TContactFieldIndex) to High(TContactFieldIndex) do
1209 Indexes[Index] := nil;
1210 for I := 0 to Count - 1 do
1211 if not Assigned(Indexes[Items[I].Index]) then Indexes[Items[I].Index] := Items[I]
1212 else raise Exception.Create(Format(SFieldIndexRedefined, [Integer(Items[I].Index)]));
1213 IndexesUpdated := True;
1214end;
1215
1216function TContactFields.AddNew(Name: string; Groups: array of string;
1217 NoGroups: array of string; Title: string; Index: TContactFieldIndex;
1218 DataType: TDataType = dtNone; ValueIndex: Integer = -1): TContactField;
1219var
1220 I: Integer;
1221begin
1222 Result := TContactField.Create;
1223 Result.SysName := Name;
1224 SetLength(Result.Groups, Length(Groups));
1225 for I := 0 to Length(Groups) - 1 do
1226 Result.Groups[I] := Groups[I];
1227 SetLength(Result.NoGroups, Length(NoGroups));
1228 for I := 0 to Length(NoGroups) - 1 do
1229 Result.NoGroups[I] := NoGroups[I];
1230 Result.Title := Title;
1231 Result.Index := Index;
1232 Result.ValueIndex := ValueIndex;
1233 Result.DataType := DataType;
1234 Add(Result);
1235 IndexesUpdated := False;
1236end;
1237
1238function TContactFields.GetBySysName(SysName: string): TContactField;
1239var
1240 I: Integer;
1241begin
1242 I := 0;
1243 while (I < Count) and (Items[I].SysName <> SysName) do Inc(I);
1244 if I < Count then Result := Items[I]
1245 else Result := nil;
1246end;
1247
1248function TContactFields.GetBySysNameGroups(SysName: string; Groups: TStringArray
1249 ): TContactField;
1250var
1251 I: Integer;
1252begin
1253 I := 0;
1254 while (I < Count) and not Items[I].Match(SysName, Groups) do Inc(I);
1255 if I < Count then Result := Items[I]
1256 else Result := nil;
1257end;
1258
1259function TContactFields.GetByIndex(Index: TContactFieldIndex): TContactField;
1260var
1261 I: Integer;
1262begin
1263 if IndexesUpdated then Result := Indexes[Index]
1264 else begin
1265 I := 0;
1266 while (I < Count) and (Items[I].Index <> Index) do Inc(I);
1267 if I < Count then Result := Items[I]
1268 else Result := nil;
1269 end;
1270end;
1271
1272function TContactFields.GetByTitle(Title: string): TContactField;
1273var
1274 I: Integer;
1275begin
1276 I := 0;
1277 while (I < Count) and (Items[I].Title <> Title) do Inc(I);
1278 if I < Count then Result := Items[I]
1279 else Result := nil;
1280end;
1281
1282procedure TContactFields.LoadToStrings(AItems: TStrings);
1283var
1284 I: Integer;
1285begin
1286 AItems.BeginUpdate;
1287 try
1288 while AItems.Count < Count do AItems.Add('');
1289 while AItems.Count > Count do AItems.Delete(AItems.Count - 1);
1290 for I := 0 to Count - 1 do begin
1291 AItems.Objects[I] := Items[I];
1292 AItems[I] := Items[I].Title;
1293 end;
1294 SortStrings(AItems);
1295 finally
1296 AItems.EndUpdate;
1297 end;
1298end;
1299
1300{ TContact }
1301
1302class function TContact.GetFields: TContactFields;
1303begin
1304 if not Assigned(FFields) then begin
1305 FFields := TContactFields.Create;
1306 with FFields do begin
1307 AddNew('VERSION', [], [], SVersion, cfVersion, dtString);
1308 AddNew('N', [], [], SLastName, cfLastName, dtString, 0);
1309 AddNew('N', [], [], SFirstName, cfFirstName, dtString, 1);
1310 AddNew('N', [], [], SMiddleName, cfMiddleName, dtString, 2);
1311 AddNew('N', [], [], STitleBefore, cfTitleBefore, dtString, 3);
1312 AddNew('N', [], [], STitleAfter, cfTitleAfter, dtString, 4);
1313 AddNew('FN', [], [], SFullName, cfFullName, dtString);
1314 AddNew('TEL', [], ['CELL', 'FAX', 'PAGER', 'WORK', 'HOME'], STelephone, cfTel, dtString);
1315 AddNew('TEL', ['CELL'], ['WORK', 'HOME'], SMobilePhone, cfTelCell, dtString);
1316 AddNew('TEL', ['FAX'], ['WORK', 'HOME'], SFax, cfTelFax, dtString);
1317 AddNew('TEL', ['PAGER'], ['WORK', 'HOME'], SPager, cfTelPager, dtString);
1318 AddNew('TEL', ['HOME'], ['CELL', 'FAX', 'PAGER'], SHomePhone, cfTelHome, dtString);
1319 AddNew('TEL', ['HOME', 'CELL'], [], SHomeMobile, cfTelCellHome, dtString);
1320 AddNew('TEL', ['HOME', 'FAX'], [], SHomeFax, cfTelFaxHome, dtString);
1321 AddNew('TEL', ['HOME', 'PAGER'], [], SHomePager, cfTelPagerHome, dtString);
1322 AddNew('TEL', ['WORK'], ['CELL', 'FAX', 'PAGER'], SWorkPhone, cfTelWork, dtString);
1323 AddNew('TEL', ['WORK', 'CELL'], [], SWorkMobile, cfTelCellWork, dtString);
1324 AddNew('TEL', ['WORK', 'FAX'], [], SWorkFax, cfTelFaxWork, dtString);
1325 AddNew('TEL', ['WORK', 'PAGER'], [], SWorkPager, cfTelPagerWork, dtString);
1326 AddNew('TEL', ['HOME2'], [], SHomePhone2, cfTelHome2, dtString);
1327 AddNew('TEL', ['VOIP'], [], SVoipPhone, cfTelVoip, dtString);
1328 AddNew('TEL', ['MAIN'], [], SMainPhone, cfTelMain, dtString);
1329 AddNew('EMAIL', [], ['HOME', 'WORK', 'INTERNET'], SEmail, cfEmail, dtString);
1330 AddNew('EMAIL', ['HOME'], [], SHomeEmail, cfEmailHome, dtString);
1331 AddNew('EMAIL', ['WORK'], [], SWorkEmail, cfEmailWork, dtString);
1332 AddNew('EMAIL', ['INTERNET'], [], SInternetEmail, cfEmailInternet, dtString);
1333 with AddNew('NICKNAME', [], [], SNickName, cfNickName, dtString) do
1334 AddAlternative('X-NICKNAME', [], []);
1335 AddNew('NOTE', [], [], SNote, cfNote, dtString);
1336 AddNew('ROLE', [], [], SRole, cfRole, dtString);
1337 AddNew('TITLE', [], [], STitle, cfTitle, dtString);
1338 AddNew('CATEGORIES', [], [], SCategories, cfCategories, dtString);
1339 AddNew('ORG', [], [], SOrganization, cfOrganization, dtString, 0);
1340 AddNew('ORG', [], [], SDepartement, cfDepartment, dtString, 1);
1341 AddNew('ADR', ['HOME'], [], SHomeAddressPostOfficeBox, cfHomeAddressPostOfficeBox, dtString, 0);
1342 AddNew('ADR', ['HOME'], [], SHomeAddressStreetExtended, cfHomeAddressStreetExtended, dtString, 1);
1343 AddNew('ADR', ['HOME'], [], SHomeAddressStreet, cfHomeAddressStreet, dtString, 2);
1344 AddNew('ADR', ['HOME'], [], SHomeAddressCity, cfHomeAddressCity, dtString, 3);
1345 AddNew('ADR', ['HOME'], [], SHomeAddressRegion, cfHomeAddressRegion, dtString, 4);
1346 AddNew('ADR', ['HOME'], [], SHomeAddressPostalCode, cfHomeAddressPostalCode, dtString, 5);
1347 AddNew('ADR', ['HOME'], [], SHomeAddressCountry, cfHomeAddressCountry, dtString, 6);
1348 AddNew('ADR', ['WORK'], [], SWorkAddressPostOfficeBox, cfWorkAddressPostOfficeBox, dtString, 0);
1349 AddNew('ADR', ['WORK'], [], SWorkAddressStreetExtended, cfWorkAddressStreetExtended, dtString, 1);
1350 AddNew('ADR', ['WORK'], [], SWorkAddressStreet, cfWorkAddressStreet, dtString, 2);
1351 AddNew('ADR', ['WORK'], [], SWorkAddressCity, cfWorkAddressCity, dtString, 3);
1352 AddNew('ADR', ['WORK'], [], SWorkAddressRegion, cfWorkAddressRegion, dtString, 4);
1353 AddNew('ADR', ['WORK'], [], SWorkAddressPostalCode, cfWorkAddressPostalCode, dtString, 5);
1354 AddNew('ADR', ['WORK'], [], SWorkAddressCountry, cfWorkAddressCountry, dtString, 6);
1355 AddNew('X-TIMES_CONTACTED', [], [], STimesContacted, cfXTimesContacted, dtString);
1356 AddNew('X-LAST_TIME_CONTACTED', [], [], SLastTimeContacted, cfXLastTimeContacted, dtString);
1357 AddNew('PHOTO', [], [], SPhoto, cfPhoto, dtImage);
1358 AddNew('LOGO', [], [], SLogo, cfLogo, dtImage);
1359 AddNew('BDAY', [], [], SDayOfBirth, cfDayOfBirth, dtDate);
1360 with AddNew('ANNIVERSARY', [], [], SAnniversary, cfAnniversary, dtDate) do
1361 AddAlternative('X-EVOLUTION-ANNIVERSARY', [], []);
1362 AddNew('REV', [], [], SRevision, cfRevision, dtString);
1363 AddNew('UID', [], [], SUniqueIdentifier, cfUid, dtString);
1364 AddNew('URL', [], ['HOME', 'WORK'], SWebAddress, cfUrl, dtString);
1365 AddNew('URL', ['HOME'], [], SWebAddressHome, cfUrlHome, dtString);
1366 AddNew('URL', ['WORK'], [], SWebAddressWork, cfUrlWork, dtString);
1367 with AddNew('GENDER', [], [], SGender, cfGender, dtString) do
1368 AddAlternative('X-CENTRUM-CZ-SEX', [], []);
1369 // Chat
1370 AddNew('X-MATRIX', [], [], SMatrix, cfMatrix, dtString);
1371 AddNew('X-JABBER', [], [], SJabber, cfJabber, dtString);
1372 AddNew('X-AIM', [], [], SAim, cfAim, dtString);
1373 AddNew('X-Windows Live', [], [], SWindowsLive, cfWindowsLive, dtString);
1374 AddNew('X-YAHOO', [], [], SYahoo, cfYahoo, dtString);
1375 with AddNew('X-SKYPE-USERNAME', [], [], SSkype, cfSkype, dtString) do begin
1376 AddAlternative('X-SKYPE', [], []);
1377 AddAlternative('X-CENTRUM-CZ-SKYPE', [], []);
1378 end;
1379 AddNew('X-QQ', [], [], SQq, cfQq, dtString);
1380 AddNew('X-GOOGLE-TALK', [], [], SGoogleTalk, cfGoogleTalk, dtString);
1381 with AddNew('X-ICQ', [], [], SIcq, cfIcq, dtString) do
1382 AddAlternative('X-CENTRUM-CZ-ICQ', [], []);
1383 AddNew('X-IRC', [], [], SIrc, cfIrc, dtString);
1384 with AddNew('X-MSN', [], [], SMsn, cfMsn, dtString) do
1385 AddAlternative('X-CENTRUM-CZ-MSN', [], []);
1386 AddNew('X-GROUPWISE', [], [], SGroupWise, cfGroupWise, dtString);
1387 AddNew('X-GADUGADU', [], [], SGaduGadu, cfGaduGadu, dtString);
1388 // Social
1389 with AddNew('X-TWITTER', [], [], STwitter, cfTwitter, dtString) do
1390 AddAlternative('X-SOCIALPROFILE', ['TWITTER'], []);
1391 with AddNew('X-FACEBOOK', [], [], SFacebook, cfFacebook, dtString) do
1392 AddAlternative('X-SOCIALPROFILE', ['FACEBOOK'], []);
1393 with AddNew('X-MASTODON', [], [], SMastodon, cfMastodon, dtString) do
1394 AddAlternative('X-SOCIALPROFILE', ['MASTODON'], []);
1395 with AddNew('X-YOUTUBE', [], [], SYouTube, cfYouTube, dtString) do
1396 AddAlternative('X-SOCIALPROFILE', ['YOUTUBE'], []);
1397 with AddNew('X-PEERTUBE', [], [], SPeerTube, cfPeerTube, dtString) do
1398 AddAlternative('X-SOCIALPROFILE', ['PEERTUBE'], []);
1399 with AddNew('X-LINKEDIN', [], [], SLinkedIn, cfLinkedIn, dtString) do
1400 AddAlternative('X-SOCIALPROFILE', ['LINKEDIN'], []);
1401 with AddNew('X-SNAPCHAT', [], [], SSnapchat, cfSnapchat, dtString) do
1402 AddAlternative('X-SOCIALPROFILE', ['SNAPCHAT'], []);
1403 with AddNew('X-INSTAGRAM', [], [], SInstagram, cfInstagram, dtString) do
1404 AddAlternative('X-SOCIALPROFILE', ['INSTAGRAM'], []);
1405 with AddNew('X-REDDIT', [], [], SReddit, cfReddit, dtString) do
1406 AddAlternative('X-SOCIALPROFILE', ['REDDIT'], []);
1407 with AddNew('X-MYSPACE', [], [], SMySpace, cfMySpace, dtString) do
1408 AddAlternative('X-SOCIALPROFILE', ['MYSPACE'], []);
1409 UpdateIndexes;
1410 end;
1411 end;
1412 Result := FFields;
1413end;
1414
1415function TContact.GetField(Index: TContactFieldIndex): string;
1416var
1417 Prop: TContactProperty;
1418 Field: TContactField;
1419begin
1420 if not Assigned(ParentVCard) then
1421 raise Exception.Create(SContactHasNoParent);
1422 Field := GetFields.GetByIndex(Index);
1423 if Assigned(Field) then begin
1424 Prop := GetProperty(Field);
1425 if Assigned(Prop) then begin
1426 if Field.ValueIndex <> -1 then begin
1427 Result := DecodeEscaped(Prop.ValueItem[Field.ValueIndex])
1428 end else begin
1429 if Field.DataType = dtString then Result := DecodeEscaped(Prop.Value)
1430 else Result := Prop.Value;
1431 end;
1432 end else Result := '';
1433 end else raise Exception.Create(SFieldIndexNotDefined);
1434end;
1435
1436function TContact.GetString: string;
1437var
1438 Lines: TStringList;
1439begin
1440 Lines := TStringList.Create;
1441 try
1442 SaveToStrings(Lines);
1443 Result := Lines.Text;
1444 finally
1445 Lines.Free;
1446 end;
1447end;
1448
1449procedure TContact.SetField(Index: TContactFieldIndex; AValue: string);
1450var
1451 Prop: TContactProperty;
1452 Field: TContactField;
1453 I: Integer;
1454begin
1455 if not Assigned(ParentVCard) then
1456 raise Exception.Create(SContactHasNoParent);
1457 Field := GetFields.GetByIndex(Index);
1458 if Assigned(Field) then begin
1459 Prop := GetProperty(Field);
1460 if (not Assigned(Prop)) and (AValue <> '') then begin
1461 Prop := TContactProperty.Create;
1462 Prop.Name := Field.SysName;
1463 for I := 0 to Length(Field.Groups) - 1 do
1464 Prop.Attributes.Add(Field.Groups[I]);
1465 Properties.Add(Prop);
1466 end;
1467 if Assigned(Prop) then begin
1468 if Field.ValueIndex <> -1 then begin
1469 Prop.ValueItem[Field.ValueIndex] := EncodeEscaped(AValue);
1470 end else begin
1471 if Field.DataType = dtString then Prop.Value := EncodeEscaped(AValue)
1472 else Prop.Value := AValue;
1473 end;
1474
1475 // Remove if empty
1476 if Prop.Value = '' then begin
1477 Properties.Remove(Prop);
1478 end;
1479 end;
1480 Modified := True;
1481 end else raise Exception.Create(SFieldIndexNotDefined);
1482end;
1483
1484procedure TContact.SetModified(AValue: Boolean);
1485begin
1486 if FModified = AValue then Exit;
1487 FModified := AValue;
1488 DoOnModify;
1489end;
1490
1491procedure TContact.DoOnModify;
1492begin
1493 if Assigned(FOnModify) then FOnModify(Self);
1494end;
1495
1496procedure TContact.DetectMaxLineLength(Text: string);
1497var
1498 LineLength: Integer;
1499begin
1500 LineLength := UTF8Length(Text);
1501 if LineLength > 1 then begin
1502 // Count one character less for folded line
1503 if Text[1] = ' ' then
1504 Dec(LineLength);
1505 end;
1506 if LineLength > ParentVCard.MaxLineLength then
1507 ParentVCard.MaxLineLength := LineLength;
1508end;
1509
1510procedure TContact.SetString(AValue: string);
1511var
1512 Lines: TStringList;
1513 StartLine: Integer;
1514begin
1515 Lines := TStringList.Create;
1516 try
1517 Lines.Text := AValue;
1518 StartLine := 0;
1519 LoadFromStrings(Lines, StartLine);
1520 finally
1521 Lines.Free;
1522 end;
1523end;
1524
1525function TContact.HasField(FieldIndex: TContactFieldIndex): Boolean;
1526var
1527 Field: TContactField;
1528begin
1529 if not Assigned(ParentVCard) then raise Exception.Create(SContactHasNoParent);
1530 Field := GetFields.GetByIndex(FieldIndex);
1531 if Assigned(Field) then begin
1532 Result := Assigned(GetProperty(Field));
1533 end else raise Exception.Create(SFieldIndexNotDefined);
1534end;
1535
1536function TContact.FullNameToFileName: string;
1537var
1538 I: Integer;
1539begin
1540 Result := Fields[cfFullName];
1541 for I := 1 to Length(Result) do begin
1542 if Result[I] in [':', '/', '\', '.', '"', '*', '|', '?', '<', '>'] then
1543 Result[I] := '_';
1544 end;
1545end;
1546
1547function TContact.GetProperty(Field: TContactField): TContactProperty;
1548var
1549 I: Integer;
1550begin
1551 Result := Properties.GetByNameGroups(Field.SysName, Field.Groups, Field.NoGroups);
1552 I := 0;
1553 while (not Assigned(Result)) and (I < Field.Alternatives.Count) do begin
1554 Result := Properties.GetByNameGroups(Field.Alternatives[I].SysName,
1555 Field.Alternatives[I].Groups, Field.Alternatives[I].NoGroups);
1556 if Assigned(Result) then Break;
1557 Inc(I);
1558 end;
1559end;
1560
1561function TContact.GetProperty(FieldIndex: TContactFieldIndex): TContactProperty;
1562var
1563 Field: TContactField;
1564begin
1565 if not Assigned(ParentVCard) then raise Exception.Create(SContactHasNoParent);
1566 Field := GetFields.GetByIndex(FieldIndex);
1567 if Assigned(Field) then begin
1568 Result := GetProperty(Field);
1569 end else Result := nil;
1570end;
1571
1572procedure TContact.Assign(Source: TContact);
1573begin
1574 Properties.Assign(Source.Properties);
1575 FModified := Source.FModified;
1576end;
1577
1578function TContact.UpdateFrom(Source: TContact): Boolean;
1579var
1580 I: Integer;
1581begin
1582 if not Assigned(ParentVCard) then raise Exception.Create(SContactHasNoParent);
1583 Result := False;
1584 for I := 0 to GetFields.Count - 1 do begin
1585 if (Source.Fields[GetFields[I].Index] <> '') and
1586 (Source.Fields[GetFields[I].Index] <>
1587 Fields[GetFields[I].Index]) then begin
1588 Result := True;
1589 Fields[GetFields[I].Index] := Source.Fields[GetFields[I].Index];
1590 end;
1591 end;
1592end;
1593
1594function TContact.CompareTo(Contact: TContact): Boolean;
1595var
1596 I: Integer;
1597begin
1598 Result := Properties.Count = Contact.Properties.Count;
1599 if Result then begin
1600 for I := 0 to Properties.Count - 1 do
1601 if not Properties[I].CompareTo(Contact.Properties[I]) then begin
1602 Result := False;
1603 Break;
1604 end;
1605 end;
1606end;
1607
1608constructor TContact.Create;
1609begin
1610 Properties := TContactProperties.Create;
1611end;
1612
1613destructor TContact.Destroy;
1614begin
1615 FreeAndNil(Properties);
1616 inherited;
1617end;
1618
1619class destructor TContact.Destroy2;
1620begin
1621 FreeAndNil(FFields);
1622end;
1623
1624procedure TContact.SaveToStrings(Output: TStrings);
1625var
1626 I: Integer;
1627 NameText: string;
1628 Value2: string;
1629 LineIndex: Integer;
1630 OutText: string;
1631 CutText: string;
1632 LinePrefix: string;
1633 CutLength: Integer;
1634 Cut: Boolean;
1635begin
1636 with Output do begin
1637 LineBreak := VCardLineEnding;
1638 Add(VCardBegin);
1639 for I := 0 to Properties.Count - 1 do
1640 with Properties[I] do begin
1641 NameText := Name;
1642 if Attributes.Count > 0 then
1643 NameText := NameText + ';' + Attributes.DelimitedText;
1644 if Encoding <> veNone then begin
1645 Value2 := GetEncodedValue;
1646 end else Value2 := Value;
1647 if Pos(LineEnding, Value2) > 0 then begin
1648 Add(NameText + ':' + GetNext(Value2, LineEnding));
1649 while Pos(LineEnding, Value2) > 0 do begin
1650 Add(' ' + GetNext(Value2, LineEnding));
1651 end;
1652 Add(' ' + GetNext(Value2, LineEnding));
1653 Add('');
1654 end else begin
1655 OutText := NameText + ':' + Value2;
1656 LineIndex := 0;
1657 LinePrefix := '';
1658 Cut := False;
1659 while True do begin
1660 if UTF8Length(OutText) > ParentVCard.MaxLineLength then begin
1661 Cut := True;
1662 CutLength := ParentVCard.MaxLineLength;
1663 if Encoding = veQuotedPrintable then begin
1664 Dec(CutLength); // There will be softline break at the end
1665 // Do not cut encoded items at the end of line
1666 if ((CutLength - 1) >= 1) and (OutText[CutLength - 1] = QuotedPrintableEscapeCharacter) then
1667 Dec(CutLength, 2)
1668 else if OutText[CutLength] = QuotedPrintableEscapeCharacter then
1669 Dec(CutLength, 1);
1670 end;
1671
1672 CutText := UTF8Copy(OutText, 1, CutLength);
1673 System.Delete(OutText, 1, Length(CutText));
1674 if Encoding = veQuotedPrintable then
1675 CutText := CutText + QuotedPrintableEscapeCharacter; // Add soft line break
1676 Add(LinePrefix + CutText);
1677 if Encoding <> veQuotedPrintable then
1678 LinePrefix := ' ';
1679 Inc(LineIndex);
1680 Continue;
1681 end else begin
1682 Add(LinePrefix + OutText);
1683 if Cut then Add('');
1684 Break;
1685 end;
1686 end;
1687 end;
1688 end;
1689 Add(VCardEnd);
1690 end;
1691end;
1692
1693function TContact.LoadFromStrings(Lines: TStrings; var StartLine: Integer): Boolean;
1694type
1695 TParseState = (psNone, psInside, psFinished);
1696var
1697 ParseState: TParseState;
1698 Line: string;
1699 Line2: string;
1700 Value: string;
1701 I: Integer;
1702 NewProperty: TContactProperty;
1703 CommandPart: string;
1704 Names: string;
1705 QuotedPrintableMultiLine: Boolean;
1706begin
1707 Result := False;
1708 ParseState := psNone;
1709 I := StartLine;
1710 while I < Lines.Count do begin
1711 Line := Lines[I];
1712 //DetectMaxLineLength(Line);
1713
1714 if Line = '' then begin
1715 // Skip empty lines
1716 end else
1717 if ParseState = psNone then begin
1718 if Line = VCardBegin then begin
1719 ParseState := psInside;
1720 end else begin
1721 ParentVCard.Error(SExpectedVCardBegin, I + 1);
1722 Break;
1723 end;
1724 end else
1725 if ParseState = psInside then begin
1726 if Line = VCardEnd then begin
1727 ParseState := psFinished;
1728 Inc(I);
1729 Result := True;
1730 Break;
1731 end else
1732 if Pos(':', Line) > 0 then begin
1733 CommandPart := GetNext(Line, ':');
1734 Names := CommandPart;
1735 QuotedPrintableMultiLine := Pos('encoding=quoted-printable', LowerCase(CommandPart)) > 0;
1736 Value := Line;
1737 while True do begin
1738 Inc(I);
1739 if I >= Lines.Count then Break;
1740 Line2 := Lines[I];
1741 //DetectMaxLineLength(Line2);
1742 if (Length(Line2) > 0) and (Line2[1] = ' ') then begin
1743 Value := Value + Copy(Line2, 2, MaxInt);
1744 end else
1745 if QuotedPrintableMultiLine and (Length(Value) > 0) and
1746 (Value[Length(Value)] = QuotedPrintableEscapeCharacter) then begin
1747 SetLength(Value, Length(Value) - 1);
1748 Value := Value + Line2;
1749 end else begin
1750 Dec(I);
1751 Break;
1752 end;
1753 end;
1754 NewProperty := Properties.GetByName(Names);
1755 if not Assigned(NewProperty) then begin
1756 NewProperty := TContactProperty.Create;
1757 Properties.Add(NewProperty);
1758 end;
1759 NewProperty.Attributes.DelimitedText := Names;
1760 if NewProperty.Attributes.Count > 0 then begin
1761 NewProperty.Name := NewProperty.Attributes[0];
1762 NewProperty.Attributes.Delete(0);
1763 end;
1764 NewProperty.Value := Value;
1765 NewProperty.EvaluateAttributes;
1766 end else begin
1767 ParentVCard.Error(SExpectedProperty, I + 1);
1768 Break;
1769 end;
1770 end;
1771 Inc(I);
1772 end;
1773 if Result then StartLine := I;
1774end;
1775
1776procedure TContact.SaveToFile(FileName: string);
1777var
1778 Lines: TStringList;
1779begin
1780 Lines := TStringList.Create;
1781 try
1782 SaveToStrings(Lines);
1783 Lines.SaveToFile(FileName);
1784 finally
1785 Lines.Free;
1786 end;
1787end;
1788
1789procedure TContact.LoadFromFile(FileName: string);
1790var
1791 Lines: TStringList;
1792 StartLine: Integer;
1793begin
1794 Lines := TStringList.Create;
1795 try
1796 Lines.LoadFromFile(FileName);
1797 {$IF FPC_FULLVERSION>=30200}
1798 if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
1799 Lines.LoadFromFile(FileName, TEncoding.Unicode);
1800 if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
1801 Lines.LoadFromFile(FileName, TEncoding.BigEndianUnicode);
1802 end;
1803 end;
1804 {$ENDIF}
1805 StartLine := 0;
1806 LoadFromStrings(Lines, StartLine);
1807 finally
1808 Lines.Free;
1809 end;
1810end;
1811
1812end.
1813
Note: See TracBrowser for help on using the repository browser.