About

Written Nov. 12, 2007 (updated Nov. 13 2007)
This page was created by me, in response to attacks on me by the Free Pascal team and community. The following is in support of my comments on this blog post regarding what I believe to be copyright issues related to Borland's Delphi and the Free Pascal runtime. These examples were all taken from one file in the project, classes.pp.

Examples of copyright concerns

ExtractStrings from Delphi 7 copyright Borland 1995-2001
Only modifications made to make comparison easier:
  • Renamed variables to match FP version
  • changed case to match FP version (try -> Try)
  • differences and spacing and line wrap to match FP version
Other than these changes the code is original Delphi 7 code
Received via email from the FP Core team: "ExtractStrings - Considered too similar to consider an independend implementation. We still don't know wether it was written by us or contributed."
http://www.freepascal.org/cgi-bin/viewcvs.cgi/trunk/rtl/objpas/classes/classes.inc?view=markup
1 function ExtractStrings(Separators, WhiteSpace: TSysCharSet; 2 Content: PChar; Strings: TStrings): Integer; 3 4 var 5 Start, P: PChar; 6 EOS, InQuote: Boolean; 7 QC: Char; 8 S: string; 9 10 begin 11 Result := 0; 12 if (Content = nil) or (Content^=#0) or (Strings = nil) then 13 Exit; 14 P := Content; 15 InQuote := False; 16 QC := #0; 17 18 19 20 Strings.BeginUpdate; 21 Try 22 repeat 23 while P^ in WhiteSpace + [#13, #10] do 24 P := StrNextChar(P); 25 Start := P; 26 while True do 27 begin 28 while (InQuote and not (P^ in [QC, #0])) or 29 not (P^ in Separators + [#0, #13, #10, '''', '"']) do 30 P := StrNextChar(P); 31 if P^ in ['''', '"'] then 32 begin 33 If (QC <> #0) and (QC = P^) then 34 QC := #0 35 else if QC = #0 then 36 QC := P^; 37 InQuote := QC <> #0; 38 P := StrNextChar(P); 39 end 40 else 41 Break; 42 end; 43 EOS := P^ = #0; 44 if (Start <> P) and (Start^ <> #0) then 45 begin 46 if Strings <> nil then 47 begin 48 SetString(S, Start, P - Start); 49 Strings.Add(S); 50 end; 51 Inc(Result); 52 end; 53 54 P := StrNextChar(P); 55 until EOS; 56 finally 57 Strings.EndUpdate; 58 end; 59 end;
1 function ExtractStrings(Separators, WhiteSpace: TSysCharSet; 2 Content: PChar; Strings: TStrings): Integer; 3 4 var 5 Start,P: PChar; 6 InQuote: Boolean; 7 QC: Char; 8 S : string; 9 10 begin 11 Result:=0; 12 if Not (Assigned(Content) and (Content^<>#0)) then 13 Exit; 14 P:=Content; 15 InQuote:=False; 16 QC:=#0; 17 WhiteSpace:=WhiteSpace+[#10,#13]; 18 Separators:=Separators+[#0,#10,#13,'''','"']; 19 if Assigned(Strings) then 20 Strings.BeginUpdate; 21 Try 22 repeat 23 while P^ in WhiteSpace do 24 Inc(P); // Not MBCS safe 25 Start:=P; 26 while True do 27 begin 28 while (InQuote and not (P^ in [QC, #0])) or 29 not (P^ in Separators) do 30 Inc(P); // Not MBCS safe 31 if P^ in ['''', '"'] then 32 begin 33 If (QC=#0) then 34 QC:=P^ 35 else if (QC=P^) then 36 QC:=#0; 37 InQuote:=QC<>#0; 38 Inc(P); 39 end 40 else 41 Break; 42 end; 43 if (Start<>P) then 44 begin 45 if Assigned(Strings) then 46 begin 47 SetString(S,Start,P-Start); 48 Strings.Add(S); 49 end; 50 Inc(Result); 51 end; 52 If (P^<>#0) then 53 Inc(P); 54 until (P^=#0); 55 finally 56 if Assigned(Strings) then 57 Strings.EndUpdate; 58 end; 59 end;
AllocateHWnd from Delphi 7 added one blank line from Classes.pas
Received via email from the FP Core team: "AllocateWindow - Is quite a bit different between implementations. The similar naming of variables makes it suspicious though."
AllocateWindow from tthread.inc
http://www.freepascal.org/cgi-bin/viewcvs.cgi/trunk/rtl/win/tthread.inc?view=markup
1 function AllocateHWnd(Method: TWndMethod): HWND; 2 var 3 TempClass: TWndClass; 4 ClassRegistered: Boolean; 5 begin 6 UtilWindowClass.hInstance := HInstance; 7 8 ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName, 9 TempClass); 10 if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then 11 begin 12 if ClassRegistered then 13 Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance); 14 Windows.RegisterClass(UtilWindowClass); 15 end; 16 Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName, 17 '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil); 18 if Assigned(Method) then 19 SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method))); 20 end;
1 function AllocateWindow: HWND; 2 var 3 TempClass: TWndClass; 4 ClassRegistered: Boolean; 5 begin 6 ThreadWindowClass.hInstance := HInstance; 7 ThreadWindowClass.lpfnWndProc:=WndProc(@ThreadWndProc); 8 ClassRegistered := GetClassInfo(HInstance, ThreadWindowClass.lpszClassName, 9 @TempClass); 10 if not ClassRegistered or (TempClass.lpfnWndProc <> WndProc(@ThreadWndProc)) then 11 begin 12 if ClassRegistered then 13 Windows.UnregisterClass(ThreadWindowClass.lpszClassName, HInstance); 14 Windows.RegisterClass(ThreadWindowClass); 15 end; 16 Result := CreateWindow(ThreadWindowClass.lpszClassName, '', 0, 17 0, 0, 0, 0, 0, 0, HInstance, nil); 18 end;
Unmodified Code from Delphi 7 Classes.pas starting at line 2348
Received via email from the FP Core team: TIntConst - The "author" claims to have taken this code from public RTTI documentation. Most likely not clean regarding copyrights.
/trunk/rtl/objpas/classes/classes.inc http://www.freepascal.org/cgi-bin/viewcvs.cgi/trunk/rtl/objpas/classes/classes.inc?view=markup
1 type 2 TIntConst = class 3 IntegerType: PTypeInfo; 4 IdentToIntFn: TIdentToInt; 5 IntToIdentFn: TIntToIdent; 6 constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt; 7 AIntToIdent: TIntToIdent); 8 end; 9 10 constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt; 11 AIntToIdent: TIntToIdent); 12 begin 13 IntegerType := AIntegerType; 14 IdentToIntFn := AIdentToInt; 15 IntToIdentFn := AIntToIdent; 16 end; 17 18 procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToIntFn: TIdentToInt; 19 IntToIdentFn: TIntToIdent); 20 begin 21 IntConstList.Add(TIntConst.Create(IntegerType, IdentToIntFn, IntToIdentFn)); 22 end; 23 24 function FindIntToIdent(AIntegerType: Pointer): TIntToIdent; 25 var 26 i: Integer; 27 begin 28 Result := nil; 29 with IntConstList.LockList do 30 try 31 for i := Count - 1 downto 0 do 32 with TIntConst(Items[I]) do 33 if AIntegerType = IntegerType then 34 begin 35 Result := @IntToIdent; 36 Exit; 37 end; 38 finally 39 IntConstList.UnlockList; 40 end; 41 end; 42 43 function FindIdentToInt(AIntegerType: Pointer): TIdentToInt; 44 var 45 i: Integer; 46 begin 47 Result := nil; 48 with IntConstList.LockList do 49 try 50 for i := Count - 1 downto 0 do 51 with TIntConst(Items[I]) do 52 if IntegerType = AIntegerType then 53 begin 54 Result := @IdentToInt; 55 Exit; 56 end; 57 finally 58 IntConstList.UnlockList; 59 end; 60 end; 61 62 function IdentToInt(const Ident: String; var Int: LongInt; 63 const Map: array of TIdentMapEntry): Boolean; 64 var 65 i: Integer; 66 begin 67 for i := Low(Map) to High(Map) do 68 if SameText(Map[i].Name, Ident) then 69 begin 70 Result := True; 71 Int := Map[i].Value; 72 exit; 73 end; 74 Result := False; 75 end; 76 77 function IntToIdent(Int: LongInt; var Ident: String; 78 const Map: array of TIdentMapEntry): Boolean; 79 var 80 i: Integer; 81 begin 82 for i := Low(Map) to High(Map) do 83 if Map[i].Value = Int then 84 begin 85 Result := True; 86 Ident := Map[i].Name; 87 exit; 88 end; 89 Result := False; 90 end;
1 type 2 TIntConst = class 3 IntegerType: PTypeInfo; // The integer type RTTI pointer 4 IdentToIntFn: TIdentToInt; // Identifier to Integer conversion 5 IntToIdentFn: TIntToIdent; // Integer to Identifier conversion 6 constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt; 7 AIntToIdent: TIntToIdent); 8 end; 9 10 constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt; 11 AIntToIdent: TIntToIdent); 12 begin 13 IntegerType := AIntegerType; 14 IdentToIntFn := AIdentToInt; 15 IntToIdentFn := AIntToIdent; 16 end; 17 18 procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToIntFn: TIdentToInt; 19 IntToIdentFn: TIntToIdent); 20 begin 21 IntConstList.Add(TIntConst.Create(IntegerType, IdentToIntFn, IntToIdentFn)); 22 end; 23 24 function FindIntToIdent(AIntegerType: Pointer): TIntToIdent; 25 var 26 i: Integer; 27 begin 28 with IntConstList.LockList do 29 try 30 for i := 0 to Count - 1 do 31 if TIntConst(Items[i]).IntegerType = AIntegerType then 32 exit(TIntConst(Items[i]).IntToIdentFn); 33 Result := nil; 34 finally 35 IntConstList.UnlockList; 36 end; 37 end; 38 39 function FindIdentToInt(AIntegerType: Pointer): TIdentToInt; 40 var 41 i: Integer; 42 begin 43 with IntConstList.LockList do 44 try 45 for i := 0 to Count - 1 do 46 with TIntConst(Items[I]) do 47 if TIntConst(Items[I]).IntegerType = AIntegerType then 48 exit(IdentToIntFn); 49 Result := nil; 50 finally 51 IntConstList.UnlockList; 52 end; 53 end; 54 55 function IdentToInt(const Ident: String; var Int: LongInt; 56 const Map: array of TIdentMapEntry): Boolean; 57 var 58 i: Integer; 59 begin 60 for i := Low(Map) to High(Map) do 61 if CompareText(Map[i].Name, Ident) = 0 then 62 begin 63 Int := Map[i].Value; 64 exit(True); 65 end; 66 Result := False; 67 end; 68 69 function IntToIdent(Int: LongInt; var Ident: String; 70 const Map: array of TIdentMapEntry): Boolean; 71 var 72 i: Integer; 73 begin 74 for i := Low(Map) to High(Map) do 75 if Map[i].Value = Int then 76 begin 77 Ident := Map[i].Name; 78 exit(True); 79 end; 80 Result := False; 81 end;
ReadComponentResFile from Delphi 7 Unmodified
Of particular interest because part of the original Delphi code is commented out with a "!!!"
/trunk/rtl/objpas/classes/classes.inc http://www.freepascal.org/cgi-bin/viewcvs.cgi/trunk/rtl/objpas/classes/classes.inc?view=markup
1 function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent; 2 var 3 Stream: TStream; 4 begin 5 Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); 6 try 7 Result := Stream.ReadComponentRes(Instance); 8 finally 9 Stream.Free; 10 end; 11 end; 12
1 function ReadComponentResFile(const FileName: String; Instance: TComponent): TComponent; 2 var 3 FileStream: TStream; 4 begin 5 FileStream := TFileStream.Create(FileName, fmOpenRead {!!!:or fmShareDenyWrite}); 6 try 7 Result := FileStream.ReadComponentRes(Instance); 8 finally 9 FileStream.Free; 10 end; 11 end;
GlobalFixupReferences from Delphi 7 Classes.pas
Only modifications made to make comparison easier:
  • Renamed variables to match FP version
  • changed case to match FP version (try -> Try)
This is interesting because it illustrates inlining of what were nested procedures where the code is otherwise identical.
Received via email from the FP Core team: GlobalFixupReferences - Looks like an actual copyright violation. According to old cvs backups, the original code was contributed in 1998 and was then almost exactly the same as the Delphi implementation, including comments. The current differences are caused by developments later.
/trunk/rtl/objpas/classes/classes.inc http://www.freepascal.org/cgi-bin/viewcvs.cgi/trunk/rtl/objpas/classes/classes.inc?view=markup
1 procedure GlobalFixupReferences; 2 var 3 GlobalList: TList; DoneList: TList; ToDoList: TList; 4 I: Integer; 5 Root: TComponent; 6 Instance: TPersistent; 7 Reference: Pointer; 8 9 procedure AddFinished(Instance: TPersistent); 10 begin 11 if (DoneList.IndexOf(Instance) < 0) and 12 (ToDoList.IndexOf(Instance) >= 0) then 13 DoneList.Add(Instance); 14 end; 15 16 procedure AddNotFinished(Instance: TPersistent); 17 var 18 Index: Integer; 19 begin 20 Index := DoneList.IndexOf(Instance); 21 if Index <> -1 then DoneList.Delete(Index); 22 if ToDoList.IndexOf(Instance) < 0 then 23 ToDoList.Add(Instance); 24 end; 25 26 begin 27 // Fixup resolution requires a stable component / name space 28 // Block construction and destruction of forms / datamodules during fixups 29 GlobalNameSpace.BeginWrite; 30 try 31 GlobalList := GlobalFixupList.LockList; 32 try 33 if GlobalList.Count > 0 then 34 begin 35 DoneList := TList.Create; 36 try 37 ToDoList := TList.Create; 38 try 39 i := 0; 40 while i < GlobalList.Count do 41 with TPropFixup(GlobalList[i]) do 42 begin 43 Root := FindGlobalComponent(FRootName); 44 if (Root <> nil) or (GetOrdProp(FInstance, FPropInfo) <> 0) then 45 begin 46 if Root <> nil then 47 begin 48 Reference := FindNestedComponent(Root, FName); 49 ResolveReference(Reference); 50 end; 51 AddFinished(FInstance); 52 GlobalList.Delete(i); 53 Free; 54 end else 55 begin 56 AddNotFinished(FInstance); 57 Inc(I); 58 end; 59 end; 60 finally 61 ToDoList.Free; 62 end; 63 for i := 0 to DoneList.Count - 1 do 64 begin 65 Instance := DoneList[I]; 66 if Instance is TComponent then 67 Exclude(TComponent(Instance).FComponentState, csFixups); 68 end; 69 finally 70 DoneList.Free; 71 end; 72 end; 73 finally 74 GlobalFixupList.UnlockList; 75 end; 76 finally 77 GlobalNameSpace.EndWrite; 78 end; 79 end; 80
1 procedure GlobalFixupReferences; 2 var 3 GlobalList, DoneList, ToDoList: TList; 4 I, Index: Integer; 5 Root: TComponent; 6 Instance: TPersistent; 7 Reference: Pointer; 8 begin 9 GlobalNameSpace.BeginWrite; 10 try 11 GlobalList := GlobalFixupList.LockList; 12 try 13 if GlobalList.Count > 0 then 14 begin 15 ToDoList := nil; 16 DoneList := TList.Create; 17 ToDoList := TList.Create; 18 try 19 i := 0; 20 while i < GlobalList.Count do 21 with TPropFixup(GlobalList[i]) do 22 begin 23 Root := FindGlobalComponent(FRootName); 24 if Assigned(Root) or (GetOrdProp(FInstance, FPropInfo) <> 0) then 25 begin 26 if Assigned(Root) then 27 begin 28 Reference := FindNestedComponent(Root, FName); 29 SetOrdProp(FInstance, FPropInfo, PtrUInt(Reference)); 30 end; 31 // Move component to list of done components, if necessary 32 if (DoneList.IndexOf(FInstance) < 0) and 33 (ToDoList.IndexOf(FInstance) >= 0) then 34 DoneList.Add(FInstance); 35 GlobalList.Delete(i); 36 Free; // ...the fixup 37 end else 38 begin 39 // Move component to list of components to process, if necessary 40 Index := DoneList.IndexOf(FInstance); 41 if Index <> -1 then 42 DoneList.Delete(Index); 43 if ToDoList.IndexOf(FInstance) < 0 then 44 ToDoList.Add(FInstance); 45 Inc(i); 46 end; 47 end; 48 for i := 0 to DoneList.Count - 1 do 49 begin 50 Instance := TPersistent(DoneList[I]); 51 if Instance.InheritsFrom(TComponent) then 52 Exclude(TComponent(Instance).FComponentState, csFixups); 53 end; 54 finally 55 ToDoList.Free; 56 DoneList.Free; 57 end; 58 end; 59 finally 60 GlobalFixupList.UnlockList; 61 end; 62 finally 63 GlobalNameSpace.EndWrite; 64 end; 65 end; 66
FindNestedComponent from Delphi 7
Only modifications made to make comparison easier: FindNestedComponent - A bit too similar to be considered an independend implementation. We did not find the origin of this code yet.
  • Added blank lines
  • Wrapped lines
Notice here:
  • the "if NamePath = '' then Exit;" has been change to simply wrap the following block of code rather than call Exit
  • Simple substitution of UpperCase for SameText
  • if (Found = nil)... changed to if (not Assigned(Found)) used extensively throughout FP runtime
Received via email from the FP Core team: FindNestedComponent - A bit too similar to be considered an independend implementation. We did not find the origin of this code yet.
/trunk/rtl/objpas/classes/classes.inc http://www.freepascal.org/cgi-bin/viewcvs.cgi/trunk/rtl/objpas/classes/classes.inc?view=markup
1 function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent; 2 var 3 Current, Found: TComponent; 4 S, P: PChar; 5 Name: string; 6 begin 7 Result := nil; 8 if NamePath = '' then Exit; 9 10 Current := Root; 11 P := PChar(Pointer(NamePath)); 12 while P^ <> #0 do 13 begin 14 S := P; 15 while not (P^ in ['.', '-', #0]) do 16 Inc(P); 17 SetString(Name, S, P - S); 18 Found := Current.FindComponent(Name); 19 if (Found = nil) and SameText(Name, 'Owner') then { Do not translate } 20 Found := Current; 21 22 23 if Found = nil then Exit; 24 if P^ = '.' then 25 Inc(P); 26 if P^ = '-' then 27 Inc(P); 28 if P^ = '>' then 29 Inc(P); 30 31 Current := Found; 32 end; 33 34 Result := Current; 35 end;
1 function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent; 2 var 3 Current, Found: TComponent; 4 s, p: PChar; 5 Name: String; 6 begin 7 Result := nil; 8 if Length(NamePath) > 0 then 9 begin 10 Current := Root; 11 p := PChar(NamePath); 12 while p[0] <> #0 do 13 begin 14 s := p; 15 while not (p^ in ['.', '-', #0]) do 16 Inc(p); 17 SetString(Name, s, p - s); 18 Found := Current.FindComponent(Name); 19 if (not Assigned(Found)) and (UpperCase(Name) = 'OWNER') then 20 Found := Current; 21 if not Assigned(Found) then exit; 22 23 // Remove the dereference operator from the name 24 if p[0] = '.' then 25 Inc(P); 26 if p[0] = '-' then 27 Inc(P); 28 if p[0] = '>' then 29 Inc(P); 30 31 Current := Found; 32 end; 33 end; 34 Result := Current; 35 end;