Ignore:
Timestamp:
Jun 15, 2024, 11:02:39 AM (5 months ago)
Author:
chronos
Message:
  • Modified: TNameDetails class moved into separate file.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/Packages/VCard/VCard.pas

    r170 r173  
    88
    99type
    10   TNamePartKind = (npNone, npPrefix, npFirst, npMiddle, npLast, npSuffix);
    11 
    12   TNamePart = record
    13     Index: Integer;
    14     Text: string;
    15     PartKind: TNamePartKind;
    16     NamePart: ^TNamePart;
    17     Previous: ^TNamePart;
    18     Next: ^TNamePart;
    19   end;
    20 
    21   TNameParts = array of TNamePart;
    22 
    23   { TNameDetails }
    24 
    25   TNameDetails = class
    26   private
    27     function GetAsNameParts: TNameParts;
    28     function GetDetail(NamePartKind: TNamePartKind): string;
    29     function IsSuffix(Text: string): Boolean;
    30   public
    31     Prefix: string;
    32     First: string;
    33     Middle: string;
    34     Last: string;
    35     Suffix: string;
    36     procedure Split(FullName: string);
    37     function GetCombined: string;
    38   end;
    39 
    4010  TErrorEvent = procedure (Text: string; Line: Integer) of object;
    4111
    … …  
    394364end;
    395365
    396 function StartsWith(Text, What: string): Boolean;
    397 begin
    398   Result := Copy(Text, 1, Length(Text)) = What;
    399 end;
    400 
    401 function EndsWith(Text, What: string): Boolean;
    402 begin
    403   Result := Copy(Text, Length(Text) - Length(What) + 1, MaxInt) = What;
    404 end;
    405 
    406366function EncodeEscaped(Text: string): string;
    407367var
    … …  
    479439end;
    480440
    481 { TNameDetails }
    482 
    483 function IsNumber(Text: string): Boolean;
    484 var
    485   Value: Integer;
    486 begin
    487   Result := TryStrToInt(Text, Value);
    488 end;
    489 
    490 function IsRomanNumber(Text: string): Boolean;
    491 var
    492   I: Integer;
    493 begin
    494   Result := True;
    495   for I := 1 to Length(Text) do
    496     if not (Text[I] in ['I', 'V', 'X', 'L', 'C', 'D', 'M']) then begin
    497       Result := False;
    498       Break;
    499     end;
    500 end;
    501 
    502 procedure SearchPart(var NameParts: TNameParts; var NamePart: TNamePart);
    503 var
    504   I: Integer;
    505 begin
    506   for I := 0 to Length(NameParts) - 1 do begin
    507     if (NameParts[I].PartKind = npNone) and (NameParts[I].Text = NamePart.Text) then begin
    508       NameParts[I].PartKind := NamePart.PartKind;
    509       NameParts[I].NamePart := @NamePart;
    510       NamePart.NamePart := @NameParts[I];
    511       Break;
    512     end;
    513   end;
    514 end;
    515 
    516 procedure SearchPartBackward(var NameParts: TNameParts; var NamePart: TNamePart);
    517 var
    518   I: Integer;
    519 begin
    520   for I := Length(NameParts) - 1 downto 0 do begin
    521     if (NameParts[I].PartKind = npNone) and (NameParts[I].Text = NamePart.Text) then begin
    522       NameParts[I].PartKind := NamePart.PartKind;
    523       NameParts[I].NamePart := @NamePart;
    524       NamePart.NamePart := @NameParts[I];
    525       Break;
    526     end;
    527   end;
    528 end;
    529 
    530 function UsedInNameParts(NamePart: TNamePartKind; NameParts: TNameParts): Boolean;
    531 var
    532   I: Integer;
    533 begin
    534   I := 0;
    535   while (I < Length(NameParts)) and (NameParts[I].PartKind <> NamePart) do Inc(I);
    536   Result := I < Length(NameParts);
    537 end;
    538 
    539441{ TVCard }
    540442
    … …  
    795697  FreeAndNil(Contacts);
    796698  inherited;
    797 end;
    798 
    799 function TNameDetails.GetAsNameParts: TNameParts;
    800 var
    801   I: Integer;
    802   K: TNamePartKind;
    803   Parts: TStringArray;
    804 begin
    805   Result := Default(TNameParts);
    806   for K := Low(TNamePartKind) to High(TNamePartKind) do begin
    807     if GetDetail(K) <> '' then begin
    808       Parts := Explode(' ', GetDetail(K));
    809       for I := 0 to Length(Parts) - 1 do begin
    810         SetLength(Result, Length(Result) + 1);
    811         Result[Length(Result) - 1].Text := Parts[I];
    812         Result[Length(Result) - 1].PartKind := K;
    813         Result[Length(Result) - 1].Index := Length(Result) - 1;
    814       end;
    815     end;
    816   end;
    817 
    818   // Update previous and next links
    819   for I := 0 to Length(Result) - 1 do begin
    820     if I > 0 then
    821       Result[I].Previous := @Result[I - 1];
    822     if (I + 1) < Length(Result) then
    823       Result[I].Next := @Result[I + 1];
    824   end;
    825 end;
    826 
    827 function TNameDetails.GetDetail(NamePartKind: TNamePartKind): string;
    828 begin
    829   case NamePartKind of
    830     npPrefix: Result := Prefix;
    831     npFirst: Result := First;
    832     npMiddle: Result := Middle;
    833     npLast: Result := Last;
    834     npSuffix: Result := Suffix;
    835   end;
    836 end;
    837 
    838 function TNameDetails.IsSuffix(Text: string): Boolean;
    839 begin
    840   Result := (Pos('.', Text) > 0) or IsNumber(Text) or
    841     IsRomanNumber(Text);
    842 end;
    843 
    844 procedure TNameDetails.Split(FullName: string);
    845 var
    846   Parts: TStringArray;
    847   NewNameParts: TNameParts;
    848   OldNameParts: TNameParts;
    849   I: Integer;
    850   J: Integer;
    851   Text: string;
    852   NextKind: TNamePartKind;
    853 begin
    854   OldNameParts := GetAsNameParts;
    855 
    856   Text := FullName;
    857   while Pos('  ', FullName) > 0 do
    858     FullName := StringReplace(FullName, '  ', ' ', [rfReplaceAll]);
    859   Text := Trim(Text);
    860 
    861   Parts := Explode(' ', Text);
    862   NewNameParts := Default(TNameParts);
    863   SetLength(NewNameParts, Length(Parts));
    864   for I := 0 to Length(NewNameParts) - 1 do begin
    865     NewNameParts[I].Index := I;
    866     NewNameParts[I].PartKind := npNone;
    867     NewNameParts[I].Text := Parts[I];
    868     if I > 0 then
    869       NewNameParts[I].Previous := @NewNameParts[I - 1];
    870     if (I + 1) < Length(NewNameParts) then
    871       NewNameParts[I].Next := @NewNameParts[I + 1];
    872   end;
    873 
    874   // Match existing parts
    875   for I := 0 to Length(OldNameParts) - 1 do begin
    876     if OldNameParts[I].Text <> '' then
    877       SearchPart(NewNameParts, OldNameParts[I]);
    878   end;
    879 
    880   // Check incorrect matches
    881   for I := 0 to Length(OldNameParts) - 1 do begin
    882     for J := I + 1 to Length(OldNameParts) - 1 do
    883       if Assigned(OldNameParts[I].NamePart) and Assigned(OldNameParts[J].NamePart) and
    884       (OldNameParts[I].NamePart^.Index >= OldNameParts[J].NamePart^.Index) then begin
    885         if Abs(I - OldNameParts[I].NamePart^.Index) >
    886         Abs(J - OldNameParts[J].NamePart^.Index) then begin
    887           OldNameParts[I].NamePart^.PartKind := npNone;
    888           OldNameParts[I].NamePart^.NamePart := nil;
    889           OldNameParts[I].NamePart := nil;
    890         end else begin
    891           OldNameParts[J].NamePart^.PartKind := npNone;
    892           OldNameParts[J].NamePart^.NamePart := nil;
    893           OldNameParts[J].NamePart := nil;
    894         end;
    895       end;
    896   end;
    897   for I := Length(OldNameParts) - 1 downto 0 do begin
    898     for J := I - 1 downto 0 do
    899       if Assigned(OldNameParts[I].NamePart) and Assigned(OldNameParts[J].NamePart) and
    900       (OldNameParts[I].NamePart^.Index <= OldNameParts[J].NamePart^.Index) then begin
    901         if Abs(I - OldNameParts[I].NamePart^.Index) >
    902         Abs(J - OldNameParts[J].NamePart^.Index) then begin
    903           OldNameParts[I].NamePart^.PartKind := npNone;
    904           OldNameParts[I].NamePart^.NamePart := nil;
    905           OldNameParts[I].NamePart := nil;
    906         end else begin
    907           OldNameParts[J].NamePart^.PartKind := npNone;
    908           OldNameParts[J].NamePart^.NamePart := nil;
    909           OldNameParts[J].NamePart := nil;
    910         end;
    911       end;
    912   end;
    913 
    914   // Match existing parts backqards
    915   for I := Length(OldNameParts) - 1 downto 0 do begin
    916     if (OldNameParts[I].Text <> '') and not Assigned(OldNameParts[I].NamePart) then
    917       SearchPartBackward(NewNameParts, OldNameParts[I]);
    918   end;
    919 
    920   // Match uncertain parts
    921   for I := 0 to Length(OldNameParts) - 1 do
    922     if not Assigned(OldNameParts[I].NamePart) then begin
    923       if Assigned(OldNameParts[I].Next) and
    924       Assigned(OldNameParts[I].Next^.NamePart) and
    925       Assigned(OldNameParts[I].Next^.NamePart^.Previous) and
    926       (OldNameParts[I].Next^.NamePart^.Previous^.PartKind = npNone) then begin
    927         OldNameParts[I].NamePart := OldNameParts[I].Next^.NamePart^.Previous;
    928         OldNameParts[I].Next^.NamePart^.Previous^.NamePart := @OldNameParts[I];
    929         OldNameParts[I].Next^.NamePart^.Previous^.PartKind := OldNameParts[I].PartKind;
    930       end else
    931       if Assigned(OldNameParts[I].Previous) and
    932       Assigned(OldNameParts[I].Previous^.NamePart) and
    933       Assigned(OldNameParts[I].Previous^.NamePart^.Next) and
    934       (OldNameParts[I].Previous^.NamePart^.Next^.PartKind = npNone) then begin
    935         OldNameParts[I].NamePart := OldNameParts[I].Previous^.NamePart^.Next;
    936         OldNameParts[I].Previous^.NamePart^.Next^.NamePart := @OldNameParts[I];
    937         OldNameParts[I].Previous^.NamePart^.Next^.PartKind := OldNameParts[I].PartKind;
    938       end;
    939     end;
    940 
    941   // Mark new unknown parts according existing parts
    942   for I := Length(Parts) - 1 downto 0 do
    943     if (NewNameParts[I].PartKind = npNone) and
    944     Assigned(NewNameParts[I].Next) and
    945     (NewNameParts[I].Next^.PartKind <> npNone) then begin
    946       if (NewNameParts[I].Next^.PartKind = npFirst) and
    947       EndsWith(NewNameParts[I].Text, '.') then begin
    948         NewNameParts[I].PartKind := npPrefix;
    949       end else NewNameParts[I].PartKind := NewNameParts[I].Next^.PartKind;
    950     end;
    951 
    952   // Mark unknown parts according to neighbouring parts
    953   for I := 0 to Length(Parts) - 1 do
    954     if (NewNameParts[I].PartKind = npNone) and
    955     Assigned(NewNameParts[I].Previous) and
    956     (NewNameParts[I].Previous^.PartKind <> npNone) then begin
    957       if (NewNameParts[I].Previous^.PartKind in [npLast, npMiddle]) and
    958       IsSuffix(NewNameParts[I].Text) then begin
    959         NewNameParts[I].PartKind := npSuffix;
    960       end else
    961       if (NewNameParts[I].Previous^.PartKind = npFirst) and
    962       (Last = '') then begin
    963         NewNameParts[I].PartKind := npLast;
    964       end else
    965       if (NewNameParts[I].Previous^.PartKind = npLast) and
    966       (Middle = '') then begin
    967         NewNameParts[I].PartKind := npLast;
    968         NewNameParts[I].Previous^.PartKind := npMiddle;
    969       end else
    970       if (NewNameParts[I].Previous^.PartKind = npPrefix) then begin
    971         NewNameParts[I].PartKind := npFirst;
    972       end else
    973         NewNameParts[I].PartKind := NewNameParts[I].Previous^.PartKind;
    974     end;
    975 
    976   // Mark remaining unknown parts based on defined filling sequence
    977   NextKind := npFirst;
    978   for I := 0 to Length(Parts) - 1 do
    979     if NewNameParts[I].PartKind = npNone then begin
    980       if EndsWith(NewNameParts[I].Text, '.') and (NextKind = npFirst) then begin
    981         NewNameParts[I].PartKind := npPrefix;
    982       end else
    983       if (NextKind = npMiddle) and IsSuffix(NewNameParts[I].Text) then begin
    984         NewNameParts[I].PartKind := npSuffix;
    985         NextKind := npSuffix;
    986       end else
    987       if NextKind = npMiddle then begin
    988         NewNameParts[I].Previous^.PartKind := npMiddle;
    989         NewNameParts[I].PartKind := npLast;
    990       end else begin
    991         NewNameParts[I].PartKind := NextKind;
    992         if NextKind = npFirst then NextKind := npLast
    993         else if NextKind = npLast then NextKind := npMiddle;
    994       end;
    995     end;
    996 
    997   // Combine multiple parts to base parts
    998   Prefix := '';
    999   First := '';
    1000   Middle := '';
    1001   Last := '';
    1002   Suffix := '';
    1003   for I := 0 to Length(Parts) - 1 do
    1004     case NewNameParts[I].PartKind of
    1005       npPrefix: Prefix := Trim(Prefix + ' ' + Parts[I]);
    1006       npFirst: First := Trim(First + ' ' + Parts[I]);
    1007       npMiddle: Middle := Trim(Middle + ' ' + Parts[I]);
    1008       npLast: Last := Trim(Last + ' ' + Parts[I]);
    1009       npSuffix: Suffix := Trim(Suffix + ' ' + Parts[I]);
    1010     end;
    1011 
    1012 {
    1013   // Title Prefix
    1014   while (Length(Parts) > 0) and EndsWith(Parts[0], '.') do begin
    1015     Prefix := Trim(Prefix + ' ' + Parts[0]);
    1016     Delete(Parts, 0, 1);
    1017   end;
    1018 
    1019   // Title Suffix
    1020   if ProcessAfter then
    1021   for I := 0 to High(Parts) do
    1022     if (Pos('.', Parts[I]) > 0) or IsNumber(Parts[I]) or IsRomanNumber(Parts[I]) then begin
    1023       for J := I to High(Parts) do
    1024         Suffix := Trim(Suffix + ' ' + Parts[J]);
    1025       SetLength(Parts, I);
    1026       Break;
    1027     end;
    1028 
    1029   if Length(Parts) = 0 then begin
    1030   end else
    1031   if Length(Parts) = 1 then begin
    1032     First := Parts[0];
    1033   end else
    1034   if Length(Parts) = 2 then begin
    1035     First := Parts[0];
    1036     Last := Parts[1];
    1037   end else begin
    1038     First := Parts[0];
    1039     for I := 0 to Length(Parts) - 3 do
    1040       Middle := Trim(Middle + ' ' + Parts[I + 1]);
    1041     Last := Parts[High(Parts)];
    1042   end;}
    1043 end;
    1044 
    1045 function TNameDetails.GetCombined: string;
    1046 begin
    1047   Result := '';
    1048   if Prefix <> '' then Result := Result + ' ' + Prefix;
    1049   if First <> '' then Result := Result + ' ' + First;
    1050   if Middle <> '' then Result := Result + ' ' + Middle;
    1051   if Last <> '' then Result := Result + ' ' + Last;
    1052   if Suffix <> '' then Result := Result + ' ' + Suffix;
    1053   Result := Trim(Result);
    1054699end;
    1055700
Note: See TracChangeset for help on using the changeset viewer.