Changeset 199

Timestamp:

Jan 28, 2026, 10:24:15 AM (4 hours ago)

Author:

chronos

Message:

• Fixed: Handling escaped semicolon in indexed property values.

Location:

trunk

Files:

• Packages/VCard/VCard.pas (modified) (2 diffs)
• Test.pas (modified) (3 diffs)
• TestCases.pas (modified) (2 diffs)

trunk/Packages/VCard/VCard.pas

@@ -858 +858 @@
 function TContactProperty.GetValueItem(Index: Integer): string;
 var
-  List: TStringList;
-begin
-  List := TStringList.Create;
-  try
-    List.Delimiter := ';';
-    List.NameValueSeparator := '=';
-    List.StrictDelimiter := True;
-    List.DelimitedText := Value;
-    if Index < List.Count then
-      Result := List.Strings[Index]
-      else Result := '';
-  finally
-    List.Free;
-  end;
+  I: Integer;
+  P: Integer;
+  CurrentIndex: Integer;
+  CurrentIndexStart: Integer;
+  CurrentIndexEnd: Integer;
+begin
+  CurrentIndex := 0;
+  CurrentIndexStart := 1;
+  CurrentIndexEnd := Length(Value);
+  P := 1;
+  repeat
+    I := Pos(';', Value, P);
+    if I > 0 then begin
+      if (I > 1) and (Value[I - 1] = '\') then begin
+        P := I + 1;
+        Continue;
+      end else begin
+        CurrentIndexEnd := I - 1;
+        if CurrentIndex = Index then begin
+          Break;
+        end else begin
+          P := I + 1;
+          Inc(CurrentIndex);
+          CurrentIndexStart := P;
+          CurrentIndexEnd := Length(Value);
+        end;
+      end;
+    end else begin
+      Break;
+    end;
+  until False;
+  if Index = CurrentIndex then begin
+    Result := Copy(Value, CurrentIndexStart, CurrentIndexEnd - CurrentIndexStart + 1);
+  end else Result := '';
 end;
 
@@ -895 +915 @@
 procedure TContactProperty.SetValueItem(Index: Integer; AValue: string);
 var
-  List: TStringList;
-begin
-  List := TStringList.Create;
-  try
-    List.Delimiter := ';';
-    List.NameValueSeparator := '=';
-    List.StrictDelimiter := True;
-    List.DelimitedText := Value;
-
-    // Extend subitems count
-    while List.Count <= Index do
-      List.Add('');
-
-    List.Strings[Index] := AValue;
-
-    // Remove empty items
-    while (List.Count > 0) and (List.Strings[List.Count - 1] = '') do
-      List.Delete(List.Count - 1);
-
-    Value := List.DelimitedText;
-  finally
-    List.Free;
+  I: Integer;
+  P: Integer;
+  CurrentIndex: Integer;
+  CurrentIndexStart: Integer;
+  CurrentIndexEnd: Integer;
+begin
+  CurrentIndex := 0;
+  CurrentIndexStart := 1;
+  CurrentIndexEnd := Length(Value);
+  P := 1;
+  repeat
+    I := Pos(';', Value, P);
+    if I > 0 then begin
+      if (I > 1) and (Value[I - 1] = '\') then begin
+        P := I + 1;
+        Continue;
+      end else begin
+        CurrentIndexEnd := I - 1;
+        if CurrentIndex = Index then begin
+          Break;
+        end else begin
+          P := I + 1;
+          Inc(CurrentIndex);
+          CurrentIndexStart := P;
+          CurrentIndexEnd := Length(Value);
+        end;
+      end;
+    end else begin
+      Break;
+    end;
+  until False;
+  if Index = CurrentIndex then begin
+    Value := Copy(Value, 1, CurrentIndexStart - 1) +
+      AValue + Copy(Value, CurrentIndexEnd + 1, MaxInt);
+  end else begin
+    for I := CurrentIndex + 1 to Index do begin
+      Value := Value + ';';
+      if I = Index then Value := Value + AValue;
+    end;
   end;
 end;

trunk/Test.pas

@@ -19 +19 @@
   end;
 
-  { TTestCaseCheckProperty }
-
-  TTestCaseCheckProperty = class(TTestCase)
-    Input: string;
+  { TTestCasePropertyRead }
+
+  TTestCasePropertyRead = class(TTestCase)
+    Input: string;
+    ContactIndex: Integer;
+    Index: TContactFieldIndex;
+    Value: string;
+    procedure Run; override;
+  end;
+
+  { TTestCasePropertyWrite }
+
+  TTestCasePropertyWrite = class(TTestCase)
+    Input: string;
+    Output: string;
     ContactIndex: Integer;
     Index: TContactFieldIndex;
@@ -140 +151 @@
 end;
 
-{ TTestCaseCheckProperty }
-
-procedure TTestCaseCheckProperty.Run;
+{ TTestCasePropertyRead }
+
+procedure TTestCasePropertyRead.Run;
 var
   Lines: TStringList;
@@ -169 +180 @@
 end;
 
+{ TTestCasePropertyWrite }
+
+procedure TTestCasePropertyWrite.Run;
+var
+  Lines: TStringList;
+begin
+  Lines := TStringList.Create;
+  try
+    with TVCardFile.Create(nil) do
+    try
+      Lines.Text := Input;
+      VCard.LoadFromStrings(Lines);
+      if ContactIndex < VCard.Contacts.Count then begin
+        VCard.Contacts[ContactIndex].Fields[Index] := Value;
+      end else Fail;
+      Lines.Clear;
+      VCard.SaveToStrings(Lines);
+      Log := SExpected + LineEnding +
+        '"' + Output + '"' + LineEnding + LineEnding +
+        SOutput + LineEnding +
+        '"' + Lines.Text + '"';
+      Evaluate(Lines.Text = Output);
+    finally
+      Free;
+    end;
+  finally
+    Lines.Free;
+  end;
+end;
+
 { TTestCaseLoadSave }
 

trunk/TestCases.pas

@@ -105 +105 @@
       Output := '';
     end;
-    with TTestCaseCheckProperty(AddNew('Property FN', TTestCaseCheckProperty)) do begin
+    with TTestCasePropertyRead(AddNew('Property FN', TTestCasePropertyRead)) do begin
       Index := cfFullName;
       Value := 'Name Surname';
       Input := BeginEnd('FN:' + Value + VCardLineEnding);
     end;
-    with TTestCaseCheckProperty(AddNew('Escaped new lines in text', TTestCaseCheckProperty)) do begin
+    with TTestCasePropertyRead(AddNew('Escaped new lines in text', TTestCasePropertyRead)) do begin
       Index := cfNote;
       Value := 'Line' + #13#10 + 'Line';
       Input := BeginEnd('NOTE:Line\nLine' + VCardLineEnding);
     end;
-    with TTestCaseCheckProperty(AddNew('Compound value', TTestCaseCheckProperty)) do begin
+    with TTestCasePropertyRead(AddNew('Compound value', TTestCasePropertyRead)) do begin
       Index := cfFirstName;
       Value := 'FirstName';
       Input := BeginEnd('N:Surname;FirstName;;;' + VCardLineEnding);
     end;
-    with TTestCaseCheckProperty(AddNew('Quoted-printable special symbols', TTestCaseCheckProperty)) do begin
+    with TTestCasePropertyRead(AddNew('Escaped semicolon in name get 0', TTestCasePropertyRead)) do begin
+      Index := cfLastName;
+      Value := 'Surname;Surname';
+      Input := BeginEnd('N:Surname\;Surname;Name\;Name' + VCardLineEnding);
+    end;
+    with TTestCasePropertyRead(AddNew('Escaped semicolon in name get 1', TTestCasePropertyRead)) do begin
+      Index := cfFirstName;
+      Value := 'Name;Name';
+      Input := BeginEnd('N:Surname\;Surname;Name\;Name' + VCardLineEnding);
+    end;
+    with TTestCasePropertyRead(AddNew('Escaped semicolon in name get 2', TTestCasePropertyRead)) do begin
+      Index := cfMiddleName;
+      Value := '';
+      Input := BeginEnd('N:Surname\;Surname;Name\;Name' + VCardLineEnding);
+    end;
+    with TTestCasePropertyWrite(AddNew('Escaped semicolon in name set 0', TTestCasePropertyWrite)) do begin
+      Input := BeginEnd('N:Surname\;Surname;Name\;Name' + VCardLineEnding);
+      Index := cfLastName;
+      Value := 'Surname2;Surname2';
+      Output := BeginEnd('N:Surname2\;Surname2;Name\;Name' + VCardLineEnding);
+    end;
+    with TTestCasePropertyWrite(AddNew('Escaped semicolon in name set 1', TTestCasePropertyWrite)) do begin
+      Input := BeginEnd('N:Surname\;Surname;Name\;Name' + VCardLineEnding);
+      Index := cfFirstName;
+      Value := 'Name2;Name2';
+      Output := BeginEnd('N:Surname\;Surname;Name2\;Name2' + VCardLineEnding);
+    end;
+    with TTestCasePropertyWrite(AddNew('Escaped semicolon in name set 2', TTestCasePropertyWrite)) do begin
+      Input := BeginEnd('N:Surname\;Surname;Name\;Name' + VCardLineEnding);
+      Index := cfMiddleName;
+      Value := 'Middle2;Middle2';
+      Output := BeginEnd('N:Surname\;Surname;Name\;Name;Middle2\;Middle2' + VCardLineEnding);
+    end;
+    with TTestCasePropertyRead(AddNew('Quoted-printable special symbols', TTestCasePropertyRead)) do begin
       Index := cfFullName;
       Value := 'Jméno Příjmení';
@@ -126 +159 @@
         'FN;ENCODING=QUOTED-PRINTABLE:Jm=C3=A9no=20P=C5=99=C3=ADjmen=C3=AD' + VCardLineEnding);
     end;
-    with TTestCaseCheckProperty(AddNew('Base64 special symbols', TTestCaseCheckProperty)) do begin
+    with TTestCasePropertyRead(AddNew('Base64 special symbols', TTestCasePropertyRead)) do begin
       Index := cfFullName;
       Value := 'Jméno Příjmení';