Changeset 129 for trunk/UVCard.pas


Ignore:
Timestamp:
Apr 9, 2022, 11:52:13 AM (3 years ago)
Author:
chronos
Message:
  • Added: TVCard as TComponent descendant.
  • Modified: TContactsFile renamed to TVCardFile and moved into separate file.
File:
1 moved

Legend:

Unmodified
Added
Removed

  • trunk/UVCard.pas

    r127 r129  
    1 unit UContact;
     1unit UVCard;
    22
    33interface
    44
    55uses
    6   Classes, SysUtils, fgl, Dialogs, UDataFile, LazUTF8, Base64, Graphics;
     6  Classes, SysUtils, Dialogs, LazUTF8, Base64, Graphics, UListViewSort,
     7  Generics.Collections, Generics.Defaults;
    78
    89type
    … …  
    3637    function GetCombined: string;
    3738  end;
    38 
    39   TContactsFile = class;
    4039
    4140  TErrorEvent = procedure (Text: string; Line: Integer) of object;
    … …  
    6261    cfPeerTube, cfLinkedIn, cfMastodon, cfMySpace, cfReddit);
    6362
    64   TContactFieldIndexes = TFPGList<TContactFieldIndex>;
     63  TContactFieldIndexes = TList<TContactFieldIndex>;
    6564
    6665  TContactFilterItem = class
    … …  
    7170  { TContactFilterItems }
    7271
    73   TContactFilterItems = class(TFPGObjectList<TContactFilterItem>)
     72  TContactFilterItems = class(TObjectList<TContactFilterItem>)
    7473    function AddNew(FieldIndex: TContactFieldIndex; Value: string): TContactFilterItem;
    7574  end;
    … …  
    9897  { TContactFields }
    9998
    100   TContactFields = class(TFPGObjectList<TContactField>)
     99  TContactFields = class(TObjectList<TContactField>)
    101100  private
    102101    Indexes: array[TContactFieldIndex] of TContactField;
    … …  
    143142  { TContactProperties }
    144143
    145   TContactProperties = class(TFPGObjectList<TContactProperty>)
     144  TContactProperties = class(TObjectList<TContactProperty>)
    146145    function AddNew(Name, Value: string): TContactProperty;
    147146    procedure Assign(Source: TContactProperties);
    148     procedure AssignToList(List: TFPGObjectList<TObject>);
     147    procedure AssignToList(List: TObjects);
    149148    function GetByName(Name: string): TContactProperty;
    150149    function GetByNameGroups(Name: string; Groups: TStringArray;
    … …  
    153152      NoGroups: TStringArray): TContactProperties;
    154153  end;
     154
     155  TVCard = class;
    155156
    156157  { TContact }
    … …  
    170171  public
    171172    Properties: TContactProperties;
    172     ContactsFile: TContactsFile;
     173    ParentVCard: TVCard;
    173174    class function GetFields: TContactFields; static;
    174175    function HasField(FieldIndex: TContactFieldIndex): Boolean;
    … …  
    197198  { TContacts }
    198199
    199   TContacts = class(TFPGObjectList<TContact>)
    200     ContactsFile: TContactsFile;
     200  TContacts = class(TObjectList<TContact>)
     201    ParentVCard: TVCard;
    201202    procedure Assign(Source: TContacts);
     203    procedure AssignToList(List: TObjects);
    202204    procedure AddContacts(Contacts: TContacts);
    203205    procedure InsertContacts(Index: Integer; Contacts: TContacts);
    204     procedure AssignToList(List: TFPGObjectList<TObject>);
    205206    function AddNew: TContact;
    206207    function Search(Text: string; FieldIndex: TContactFieldIndex): TContact;
    … …  
    209210    function ToString: ansistring; override;
    210211    procedure RemoveExactDuplicates;
    211   end;
    212 
    213   { TContactsFile }
    214 
    215   TContactsFile = class(TDataFile)
     212    procedure Sort;
     213  end;
     214
     215  { TVCard }
     216
     217  TVCard = class(TComponent)
    216218  private
    217219    FMaxLineLength: Integer;
     220    FModified: Boolean;
     221    FOnModify: TNotifyEvent;
    218222    FOnError: TErrorEvent;
     223    function GetString: string;
     224    procedure SetModified(AValue: Boolean);
     225    procedure SetString(AValue: string);
    219226    procedure Error(Text: string; Line: Integer);
    220     function GetString: string;
    221     function NewItem(Key, Value: string): string;
    222     procedure SetString(AValue: string);
     227    procedure DoOnModify;
    223228  public
    224229    Contacts: TContacts;
    225     function GetFileName: string; override;
    226     function GetFileExt: string; override;
    227     function GetFileFilter: string; override;
     230    procedure Assign(Source: TPersistent); override;
    228231    procedure SaveToStrings(Output: TStrings);
    229232    procedure LoadFromStrings(Lines: TStrings);
    230     procedure SaveToFile(FileName: string); override;
    231     procedure LoadFromFile(FileName: string); override;
    232     procedure Sort;
    233     procedure Assign(Source: TContactsFile);
    234     constructor Create; override;
     233    procedure SaveToFile(FileName: string);
     234    procedure LoadFromFile(FileName: string);
     235    constructor Create(AOwner: TComponent); override;
    235236    destructor Destroy; override;
    236237    property AsString: string read GetString write SetString;
     238    property Modified: Boolean read FModified write SetModified;
    237239  published
     240    property MaxLineLength: Integer read FMaxLineLength write FMaxLineLength;
     241    property OnModify: TNotifyEvent read FOnModify write FOnModify;
    238242    property OnError: TErrorEvent read FOnError write FOnError;
    239     property MaxLineLength: Integer read FMaxLineLength write FMaxLineLength;
    240243  end;
    241244
    … …  
    261264
    262265resourcestring
    263   SVCardFile = 'vCard file';
    264266  SFieldIndexRedefined = 'Field index %d redefined';
    265267  SExpectedVCardBegin = 'Expected vCard begin';
    … …  
    518520end;
    519521
     522{ TVCard }
     523
     524function TVCard.GetString: string;
     525var
     526  I: Integer;
     527begin
     528  Result := '';
     529  for I := 0 to Contacts.Count - 1 do
     530    Result := Result + Contacts[I].AsString;
     531end;
     532
     533procedure TVCard.SetModified(AValue: Boolean);
     534begin
     535  if FModified = AValue then Exit;
     536  FModified := AValue;
     537  DoOnModify;
     538end;
     539
     540procedure TVCard.SetString(AValue: string);
     541var
     542  Lines: TStringList;
     543begin
     544  Lines := TStringList.Create;
     545  try
     546    Lines.Text := AValue;
     547    LoadFromStrings(Lines);
     548    Modified := True;
     549  finally
     550    Lines.Free;
     551  end;
     552end;
     553
     554procedure TVCard.DoOnModify;
     555begin
     556  if Assigned(FOnModify) then FOnModify(Self);
     557end;
     558
     559procedure TVCard.Error(Text: string; Line: Integer);
     560begin
     561  if Assigned(FOnError) then FOnError(Text, Line);
     562end;
     563
     564procedure TVCard.Assign(Source: TPersistent);
     565begin
     566  inherited;
     567  if Source is TVCard then Contacts.Assign((Source as TVCard).Contacts);
     568end;
     569
     570procedure TVCard.SaveToStrings(Output: TStrings);
     571var
     572  I: Integer;
     573begin
     574  for I := 0 to Contacts.Count - 1 do
     575    Contacts[I].SaveToStrings(Output);
     576end;
     577
     578procedure TVCard.LoadFromStrings(Lines: TStrings);
     579var
     580  Contact: TContact;
     581  I: Integer;
     582begin
     583  Contacts.Clear;
     584  //MaxLineLength := 10;
     585
     586  I := 0;
     587  while I < Lines.Count do begin
     588    Contact := TContact.Create;
     589    Contact.ParentVCard := Self;
     590    if Contact.LoadFromStrings(Lines, I) then begin
     591      Contacts.Add(Contact);
     592    end else begin
     593      FreeAndNil(Contact);
     594      Inc(I);
     595    end;
     596  end;
     597end;
     598
     599procedure TVCard.SaveToFile(FileName: string);
     600var
     601  Lines: TStringList;
     602begin
     603  Lines := TStringList.Create;
     604  try
     605    SaveToStrings(Lines);
     606    Lines.SaveToFile(FileName);
     607  finally
     608    Lines.Free;
     609  end
     610end;
     611
     612procedure TVCard.LoadFromFile(FileName: string);
     613var
     614  Lines: TStringList;
     615begin
     616  Lines := TStringList.Create;
     617  Lines.LoadFromFile(FileName);
     618  {$IF FPC_FULLVERSION>=30200}
     619  if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
     620    Lines.LoadFromFile(FileName, TEncoding.Unicode);
     621    if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
     622      Lines.LoadFromFile(FileName, TEncoding.BigEndianUnicode);
     623    end;
     624  end;
     625  {$ENDIF}
     626  try
     627    LoadFromStrings(Lines);
     628  finally
     629    Lines.Free;
     630  end;
     631end;
     632
     633constructor TVCard.Create(AOwner: TComponent);
     634begin
     635  inherited;
     636  FMaxLineLength := DefaultMaxLineLength;
     637  Contacts := TContacts.Create;
     638  Contacts.ParentVCard := Self;
     639end;
     640
     641destructor TVCard.Destroy;
     642begin
     643  FreeAndNil(Contacts);
     644  inherited;
     645end;
     646
    520647function TNameDetails.GetAsNameParts: TNameParts;
    521648var
    … …  
    846973  I: Integer;
    847974begin
    848   while Count < Source.Count do
    849     Add(TContactProperty.Create);
    850   while Count > Source.Count do
    851     Delete(Count - 1);
    852   for I := 0 to Count - 1 do
    853     Items[I].Assign(Source.Items[I]);
    854 end;
    855 
    856 procedure TContactProperties.AssignToList(List: TFPGObjectList<TObject>);
     975  while Count > Source.Count do Delete(Count - 1);
     976  while Count < Source.Count do Add(TContactProperty.Create);
     977  for I := 0 to Count - 1 do Items[I].Assign(Source.Items[I]);
     978end;
     979
     980procedure TContactProperties.AssignToList(List: TObjects);
    857981var
    858982  I: Integer;
    859983begin
    860984  while List.Count > Count do List.Delete(List.Count - 1);
    861   while List.Count < Count do List.Add(nil);
    862   for I := 0 to Count - 1 do
    863     List[I] := Items[I];
     985  for I := 0 to List.Count - 1 do List[I] := Items[I];
     986  while List.Count < Count do List.Add(Items[List.Count]);
    864987end;
    865988
    … …  
    10851208  I: Integer;
    10861209begin
    1087   while Count < Source.Count do
    1088     Add(TContact.Create);
    1089   while Count > Source.Count do
    1090     Delete(Count - 1);
     1210  while Count > Source.Count do Delete(Count - 1);
     1211  while Count < Source.Count do Add(TContact.Create);
    10911212  for I := 0 to Count - 1 do begin
    10921213    Items[I].Assign(Source.Items[I]);
    1093     Items[I].ContactsFile := ContactsFile;
     1214    Items[I].ParentVCard := ParentVCard;
    10941215  end;
    10951216end;
    … …  
    11081229    NewContact := TContact.Create;
    11091230    NewContact.Assign(Contacts[I]);
    1110     NewContact.ContactsFile := ContactsFile;
     1231    NewContact.ParentVCard := ParentVCard;
    11111232    Insert(Index, NewContact);
    11121233    Inc(Index);
    … …  
    11261247end;
    11271248
    1128 procedure TContacts.AssignToList(List: TFPGObjectList<TObject>);
     1249function ComparePropertyName(constref Item1, Item2: TContactProperty): Integer;
     1250begin
     1251  Result := CompareStr(Item1.Name + ';' + Item1.Attributes.Text,
     1252    Item2.Name + ';' + Item2.Attributes.Text);
     1253end;
     1254
     1255function CompareContactFullName(constref Item1, Item2: TContact): Integer;
     1256begin
     1257  Result := CompareStr(Item1.Fields[cfFullName], Item2.Fields[cfFullName]);
     1258end;
     1259
     1260procedure TContacts.Sort;
     1261var
     1262  I: Integer;
     1263begin
     1264  inherited Sort(TComparer<TContact>.Construct(CompareContactFullName));
     1265  for I := 0 to Count - 1 do
     1266    Items[I].Properties.Sort(TComparer<TContactProperty>.Construct(ComparePropertyName));
     1267end;
     1268
     1269procedure TContacts.AssignToList(List: TObjects);
    11291270var
    11301271  I: Integer;
    11311272begin
    11321273  while List.Count > Count do List.Delete(List.Count - 1);
    1133   while List.Count < Count do List.Add(nil);
    1134   for I := 0 to Count - 1 do
    1135     List[I] := Items[I];
     1274  for I := 0 to List.Count - 1 do List[I] := Items[I];
     1275  while List.Count < Count do List.Add(Items[List.Count]);
    11361276end;
    11371277
    … …  
    11391279begin
    11401280  Result := TContact.Create;
    1141   Result.ContactsFile := ContactsFile;
     1281  Result.ParentVCard := ParentVCard;
    11421282  Add(Result);
    11431283end;
    … …  
    11751315    NewContact := TContact.Create;
    11761316    NewContact.Assign(Contact);
    1177     NewContact.ContactsFile := ContactsFile;
     1317    NewContact.ParentVCard := ParentVCard;
    11781318    Add(NewContact);
    11791319  end;
    … …  
    14001540  Field: TContactField;
    14011541begin
    1402   if not Assigned(ContactsFile) then
     1542  if not Assigned(ParentVCard) then
    14031543    raise Exception.Create(SContactHasNoParent);
    14041544  Field := GetFields.GetByIndex(Index);
    … …  
    14351575  I: Integer;
    14361576begin
    1437   if not Assigned(ContactsFile) then
     1577  if not Assigned(ParentVCard) then
    14381578    raise Exception.Create(SContactHasNoParent);
    14391579  Field := GetFields.GetByIndex(Index);
    … …  
    14861626      Dec(LineLength);
    14871627  end;
    1488   if LineLength > ContactsFile.MaxLineLength then
    1489     ContactsFile.MaxLineLength := LineLength;
     1628  if LineLength > ParentVCard.MaxLineLength then
     1629    ParentVCard.MaxLineLength := LineLength;
    14901630end;
    14911631
    … …  
    15091649  Field: TContactField;
    15101650begin
    1511   if not Assigned(ContactsFile) then raise Exception.Create(SContactHasNoParent);
     1651  if not Assigned(ParentVCard) then raise Exception.Create(SContactHasNoParent);
    15121652  Field := GetFields.GetByIndex(FieldIndex);
    15131653  if Assigned(Field) then begin
    … …  
    15451685  Field: TContactField;
    15461686begin
    1547   if not Assigned(ContactsFile) then raise Exception.Create(SContactHasNoParent);
     1687  if not Assigned(ParentVCard) then raise Exception.Create(SContactHasNoParent);
    15481688  Field := GetFields.GetByIndex(FieldIndex);
    15491689  if Assigned(Field) then begin
    … …  
    15621702  I: Integer;
    15631703begin
    1564   if not Assigned(ContactsFile) then raise Exception.Create(SContactHasNoParent);
     1704  if not Assigned(ParentVCard) then raise Exception.Create(SContactHasNoParent);
    15651705  Result := False;
    15661706  for I := 0 to GetFields.Count - 1 do begin
    … …  
    16371777        LinePrefix := '';
    16381778        while True do begin
    1639           if UTF8Length(OutText) > ContactsFile.MaxLineLength then begin
    1640             CutLength := ContactsFile.MaxLineLength;
     1779          if UTF8Length(OutText) > ParentVCard.MaxLineLength then begin
     1780            CutLength := ParentVCard.MaxLineLength;
    16411781            if Encoding = veQuotedPrintable then begin
    16421782              Dec(CutLength); // There will be softline break at the end
    … …  
    16961836        ParseState := psInside;
    16971837      end else begin
    1698         ContactsFile.Error(SExpectedVCardBegin, I + 1);
     1838        ParentVCard.Error(SExpectedVCardBegin, I + 1);
    16991839        Break;
    17001840      end;
    … …  
    17421882        NewProperty.EvaluateAttributes;
    17431883      end else begin
    1744         ContactsFile.Error(SExpectedProperty, I + 1);
     1884        ParentVCard.Error(SExpectedProperty, I + 1);
    17451885        Break;
    17461886      end;
    … …  
    17871927end;
    17881928
    1789 { TContactsFile }
    1790 
    1791 procedure TContactsFile.Error(Text: string; Line: Integer);
    1792 begin
    1793   if Assigned(FOnError) then FOnError(Text, Line);
    1794 end;
    1795 
    1796 function TContactsFile.GetString: string;
    1797 var
    1798   I: Integer;
    1799 begin
    1800   Result := '';
    1801   for I := 0 to Contacts.Count - 1 do
    1802     Result := Result + Contacts[I].AsString;
    1803 end;
    1804 
    1805 function TContactsFile.GetFileName: string;
    1806 begin
    1807   Result := SVCardFile;
    1808 end;
    1809 
    1810 function TContactsFile.GetFileExt: string;
    1811 begin
    1812   Result := VCardFileExt;
    1813 end;
    1814 
    1815 function TContactsFile.GetFileFilter: string;
    1816 begin
    1817   Result := GetFileName + ' (' + GetFileExt + ')|*' + GetFileExt + '|' + inherited;
    1818 end;
    1819 
    1820 procedure TContactsFile.SaveToStrings(Output: TStrings);
    1821 var
    1822   I: Integer;
    1823 begin
    1824   for I := 0 to Contacts.Count - 1 do
    1825     Contacts[I].SaveToStrings(Output);
    1826 end;
    1827 
    1828 procedure TContactsFile.LoadFromStrings(Lines: TStrings);
    1829 var
    1830   Contact: TContact;
    1831   I: Integer;
    1832 begin
    1833   Contacts.Clear;
    1834   //MaxLineLength := 10;
    1835 
    1836   I := 0;
    1837   while I < Lines.Count do begin
    1838     Contact := TContact.Create;
    1839     Contact.ContactsFile := Self;
    1840     if Contact.LoadFromStrings(Lines, I) then begin
    1841       Contacts.Add(Contact);
    1842     end else begin
    1843       FreeAndNil(Contact);
    1844       Inc(I);
    1845     end;
    1846   end;
    1847 end;
    1848 
    1849 function TContactsFile.NewItem(Key, Value: string): string;
    1850 var
    1851   Charset: string;
    1852 begin
    1853   if not IsAsciiString(Value) then Charset := ';CHARSET=UTF-8'
    1854     else Charset := '';
    1855   Result := Key + Charset + ':' + Value;
    1856 end;
    1857 
    1858 procedure TContactsFile.SetString(AValue: string);
    1859 var
    1860   Lines: TStringList;
    1861 begin
    1862   Lines := TStringList.Create;
    1863   try
    1864     Lines.Text := AValue;
    1865     LoadFromStrings(Lines);
    1866     Modified := True;
    1867   finally
    1868     Lines.Free;
    1869   end;
    1870 end;
    1871 
    1872 procedure TContactsFile.SaveToFile(FileName: string);
    1873 var
    1874   Lines: TStringList;
    1875 begin
    1876   inherited;
    1877   Lines := TStringList.Create;
    1878   try
    1879     SaveToStrings(Lines);
    1880     Lines.SaveToFile(FileName);
    1881   finally
    1882     Lines.Free;
    1883   end
    1884 end;
    1885 
    1886 procedure TContactsFile.LoadFromFile(FileName: string);
    1887 var
    1888   Lines: TStringList;
    1889 begin
    1890   inherited;
    1891   Lines := TStringList.Create;
    1892   Lines.LoadFromFile(FileName);
    1893   {$IF FPC_FULLVERSION>=30200}
    1894   if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
    1895     Lines.LoadFromFile(FileName, TEncoding.Unicode);
    1896     if (Length(Lines.Text) > 0) and (Pos(VCardBegin, Lines.Text) = 0) then begin
    1897       Lines.LoadFromFile(FileName, TEncoding.BigEndianUnicode);
    1898     end;
    1899   end;
    1900   {$ENDIF}
    1901   try
    1902     LoadFromStrings(Lines);
    1903   finally
    1904     Lines.Free;
    1905   end;
    1906 end;
    1907 
    1908 function CompareContactFullName(const Item1, Item2: TContact): Integer;
    1909 begin
    1910   Result := CompareStr(Item1.Fields[cfFullName], Item2.Fields[cfFullName]);
    1911 end;
    1912 
    1913 function ComparePropertyName(const Item1, Item2: TContactProperty): Integer;
    1914 begin
    1915   Result := CompareStr(Item1.Name + ';' + Item1.Attributes.Text,
    1916     Item2.Name + ';' + Item2.Attributes.Text);
    1917 end;
    1918 
    1919 procedure TContactsFile.Sort;
    1920 var
    1921   I: Integer;
    1922 begin
    1923   Contacts.Sort(CompareContactFullName);
    1924   for I := 0 to Contacts.Count - 1 do
    1925     Contacts[I].Properties.Sort(ComparePropertyName);
    1926 end;
    1927 
    1928 procedure TContactsFile.Assign(Source: TContactsFile);
    1929 begin
    1930   inherited Assign(Source);
    1931   Contacts.Assign(Source.Contacts);
    1932 end;
    1933 
    1934 constructor TContactsFile.Create;
    1935 begin
    1936   inherited;
    1937   Contacts := TContacts.Create;
    1938   Contacts.ContactsFile := Self;
    1939   MaxLineLength := DefaultMaxLineLength;
    1940 end;
    1941 
    1942 destructor TContactsFile.Destroy;
    1943 begin
    1944   FreeAndNil(Contacts);
    1945   inherited;
    1946 end;
    1947 
    19481929end.
    19491930
Note: See TracChangeset for help on using the changeset viewer.