Licensing with OnGuard - delphi

Recently, I looked into using OnGuard as a way to help honest people abide by their principles. I agree with the views expressed by many here that no licensing system is going to protect you from someone who wants to use your software and does not want to pay for it. On the other hand, I would like to avoid making it too easy for someone else to create valid keys for my program.
After studying the manual and examples, I added the following to my main form's code:
const
TheKey: TKey = ($4A,$62,$F3,$2B,$9C,$D2,$84,$BF,$CB,$04,$0A,$C3,$3D,$11,$47,$1A);
function TfrmMain1.MakeCode(sName, sNumber: String; dtExpiration: TDate): String;
var Key: TKey;
Code: TCode;
sCode: String;
begin
Key := TheKey;
InitRegCode(Key, sName + ' - ' + sNumber, dtExpiration, Code);
sCode := BufferToHex(Code, SizeOf(Code));
Insert('-', sCode, 13);
Insert('-', sCode, 09);
Insert('-', sCode, 05);
Result := sCode
end;
function TfrmMain1.TestCode(sName, sNumber, sTestCode: String; dtExpiration: TDate): Boolean;
var Key: TKey;
Code: TCode;
sCode: String;
begin
sCode := MakeCode(sName, sNumber, dtExpiration);
Result := SameText(sCode, sTestCode);
end;
This brings up some questions:
Does seem like the correct way to use this? I would rather not add their components to my form.
Since the OnGuard source is available, couldn't a hacker reverse engineer the Key I will choose and produce valid release codes? Should I therefore add some additional obfuscation to the code or might I just weaken the system.
The Key is set as a constant here. Won't it show up in the code as contiguous bytes and be easy to copy?
My program will require (at least) annual updates and my plan is to license it with an annual subscription. Would it be stronger to add the year as a constant in my program and test dated user entries against that year in a few places.
There are 4 questions here that are closely related and pretty specific. It seemed like it would be more awkward to ask those in four separate entries and have to add references for context but I will be glad to do that if that would be preferable. Thank you for your help.
Jack

constructor TLincenceManager.Create;
begin
FSpecialCode := TOgSpecialCode.Create(nil);
FSpecialCode.OnGetModifier := OgNetCodeGetModifier;
FSpecialCode.OnChecked := OgNetCodeChecked;
FSpecialCode.OnGetCode := OgNetCodeGetCode;
FSpecialCode.OnGetKey := OgNetCodeGetKey;
FSpecialCode.AutoCheck := False;
end;
function TLincenceManager.InitializeLicenceCode: Boolean;
begin
Result := FSpecialCode.CheckCode(True) = ogValidCode;
end;
procedure TLincenceManager.OgNetCodeChecked(Sender: TObject; Status: TCodeStatus);
begin
case Status of
ogValidCode : FMaxUsers := FSpecialCode.GetValue;
ogInvalidCode : FMaxUsers := 0;
ogPastEndDate : FMaxUsers := 0;
ogDayCountUsed : FMaxUsers := 0;
ogRunCountUsed : FMaxUsers := 0;
ogNetCountUsed : FMaxUsers := 0;
ogCodeExpired : FMaxUsers := 0;
else
FMaxUsers := 0;
end;
end;
procedure TLincenceManager.OgNetCodeGetCode(Sender: TObject; var Code: TCode);
var
FileName: string;
SerialData: string;
LicenceData: TStringList;
begin
FileName := IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)));
FileName := FileName + cLicenseFileName;
SerialData := '';
LicenceData := TStringList.Create;
try
if FileExists(FileName) then
begin
LicenceData.LoadFromFile(FileName);
SerialData := LicenceData.Values['Serial'];
end;
{convert to proper form}
HexToBuffer(SerialData, Code, SizeOf(Code));
finally
LicenceData.Free;
end;
end;
procedure TLincenceManager.OgNetCodeGetKey(Sender: TObject; var Key: TKey);
const
CKey : TKey = ($4A,$62,$F3,$2B,$9C,$D2,$84,$BF,$CB,$04,$0A,$C3,$3D,$11,$47,$1A);
begin
Key := CKey;
end;
procedure TLincenceManager.OgNetCodeGetModifier(Sender: TObject; var Value: Integer);
begin
Value := GenerateMachineModifierPrim;
end;
I have posted the way I do it. I do not use "visual" components. The way I do it is the way to go, in your case you just apply the date modifier (i have machine modifier)
No in theory no. The key with which you generate you licence is of essence. If you have the key you can crack the licences. But with only the code you cant. This is just like encryption algorithms. You can know how the algorithm works but if you don't have the key you cant crack it. Look at XTEA. It is very simple yet hard to crack.
Yes the key can be extracted from binary if one knows what is doing. You could use some sort of obfuscation here. But I would not bother. For most people such protection is enough, so if you are not making the next MS Office I would not bother. People are way to paranaoid about their products. Sell it first and think about this later. Oh and since it is not a string it is a little harder to find anyway.
Just look at the time trial demos that come with onGuard to know how to do the time limited licence. However be aware that just simple manipulation of the computer clock will be enough to fool it. In my opinion best trial software is such, that is lack some vital functionality (save button...). Good time trials are very hard to make in my opinion.

I use the lower level OnGuard APIs rather than the classes as suggested by Runner. Either will work fine, the classes end up calling the lower level APIs anyway. Here are my wrapper utility functions for these lower level API methods.
{ Used by you to generate the unlock code you send to your customer, do not include in the customer software }
function GenerateReleaseCode(const inAppKey : string; inExpiryDate : TDateTime; inRegCode : string) : string;
(* inAppKey is the byte sequence key you already have
inRegCode can be anything, typically customers name
Returns the release code for the customer to type into the software *)
var
releaseCode : TCode;
key : TKey;
begin
HexToBuffer(inAppKey, key, SizeOf(TKey));
InitRegCode(key, inRegCode, inExpiryDate, releaseCode);
Result := BufferToHex(unlockCode, SizeOf(releaseCode));
end;
{ Used in your program to authenticate if the release code is valid - does not check for expiry }
function AuthenticateReleaseCode(const inReleaseCodeHexString : string; const inAppKey : TKey) : Boolean;
var
releaseCode : TCode;
begin
HexToBuffer(inReleaseCodeHexString, releaseCode, SizeOf(releaseCode));
Result := IsRegCodeValid(inAppKey, releaseCode);
end;
{ Used in your program to test if the license has expired }
function UnlockCodeExpiryDate(const inReleaseCodeHexString : string; const inAppKey : TKey) : TDateTime;
var
releaseCode : TCode;
begin
HexToBuffer(inReleaseCodeHexString, releaseCode, SizeOf(releaseCode));
Result := GetExpirationDate(inAppKey, releaseCode);
end;
I do use OnGuard extensively but only for enterprise software where piracy isn't such an issue. If you're selling consumer software and your worried about piracy I'd recommend a stronger solution such as a commercial copy protection library that encrypts the exe.
Even then you can slow the crackers down, but you can't stop them.

3) You should "scatter" the key around and maybe having part of it computed someway. The simpler to identify the key, of course the simpler to bypass protection. But even a complex key is useless if a simple JMP instruction in the proper place will bypass the whole protection check. Those checks should be also more than one, and again, scattered around.
4) Be careful with such kind of licenses - usually users don't like them unless the annual fee means also some perceived value (i.e. an antivirus gives you update signatures, or a GPS application updated maps). Just forcing users to pay annually may look good for you, but not for users, even if you add new features they may not regard as useful. If the application stop working is even worse. That's one of the issue that killed many Unix applications when Windows application with the same features but without yearly fees became available. I know that many companies are thinking to return to that model - if it will be successful is yet to be seen.

Related

In Delphi, should I care about Cyclomatic Complexity for "case of" statements?

I'm using the built-in "Method Toxicity Metrics" in Delphi 10.3 in my code review flow and I have the following method:
function LoadTagsFromFile(const Filename: String; var Tags: TFileTags; var LastError: Integer): Boolean;
var
AudioType: TAudioFormat;
begin
AudioType := ExtToAudioType(ExtractFileExt(FileName));
case AudioType of
afApe: Result := LoadApeTags(Filename, Tags, LastError);
afFlac: Result := LoadFlacTags(Filename, Tags, LastError);
afMp3: Result := LoadMp3Tags(Filename, Tags, LastError);
afMp4: Result := LoadMp4Tags(Filename, Tags, LastError);
afOgg: Result := LoadOggTags(Filename, Tags, LastError);
afWav: Result := LoadWavTags(Filename, Tags, LastError);
afWma: Result := LoadWmaTags(Filename, Tags, LastError);
else
Result := LoadTags(Filename, Tags, LastError);
end;
end;
Which is red flagged (CC = 8 making overall toxicity over 1) but I'm puzzled as how I could fix this specific case? Should I even care for this example?
You should not care at all for this example, IMHO. Firstly, the code in each case statement in clear and easy to read. Any other approach would make the code much more difficult to understand for no performance gain. i.e. you are reading a file from disk, you will never be able to measure any performance difference arising from any re-formulation of your case statement compared to the disk reading process.
Also, since you are using Delphi 10.3 you should take advantage of record helpers. I would make a
TAudioFormatHelper = record helper for TAudioFormat
private
function LoadApeTags(Filename, Tags, LastError):boolean;
... other Load functions here...
public
procedure LoadTagsFromFile(const Filename: String; var Tags: TFileTags; var LastError: Integer): Boolean;
procedure SetFromFileName(const FileName:string)
end
That way you get away from these global type methods and tie them to your enum.
i.e.
var
audioFormat:TAudioFormat;
begin
audioFormat.SetFromFileName(.....)
audioFormat.LoadTagsFromFIle(.....)
of course, LoadTagsFromFile could set the audioFormat enum as well, but that is a different story. I am just going with our design that you set the enum value based on extension first.

displaySwitch.exe code replacement for windows (pre windows 7)

I'm writing an app I'd like to be backwardly compatible to some extent on XP, or at the very least windows vista.
EDIT FOR CLARITY: I need to be able to do what the first code snippet below does, but in XP. "Does anybody know the best approach to take under XP, given the functions aren't available in USER32.DLL.?"
My initial prototype code on windows 7 just called CreateProcess to start up displayswitch.exe, which is deployed with windows 7.
if you are not familiar with it, it's a handy little utility that is what gets invoked when you press the windows key and the letter P. you can read more about it here.
while this was adequate, i subsequently needed to sense the current state (eg internal vs external or extend vs clone), so i have now coded up a winapi solution that works well on windows 7 (and i presume 8). it involves making calls to SetDisplayConfig and QueryDisplayConfig in User32.DLL
The pertinent section of it is here (minus the many, many structures i had to hand craft in pascal code from the original klingon).
function getTopology : DISPLAYCONFIG_TOPOLOGY_ID ;
var NumPathArrayElements,
NumModeInfoArrayElements : UINT32;
var PathArrayElements_Size,
ModeInfoArrayElements_Size : UINT32;
error : Longint;
paths : PDISPLAYCONFIG_PATH_INFO_array;
info : PDISPLAYCONFIG_MODE_INFO_array;
begin
NumModeInfoArrayElements := 0;
Result := DISPLAYCONFIG_TOPOLOGY_EXTERNAL;
inc(result);
error := GetDisplayConfigBufferSizes(QDC_DATABASE_CURRENT,NumPathArrayElements,NumModeInfoArrayElements);
case error of
ERROR_SUCCESS :
begin
PathArrayElements_Size := sizeof(DISPLAYCONFIG_PATH_INFO) * NumPathArrayElements ;
ModeInfoArrayElements_Size := sizeof(DISPLAYCONFIG_MODE_INFO) * NumModeInfoArrayElements;
GetMem(paths,PathArrayElements_Size);
try
GetMem(info,ModeInfoArrayElements_Size );
try
error := QueryDisplayConfig(QDC_DATABASE_CURRENT,NumPathArrayElements, paths,NumModeInfoArrayElements, info,result);
case error of
ERROR_SUCCESS :;
else
Result := DISPLAYCONFIG_TOPOLOGY_EXTERNAL;
inc(result);
end;
finally
FreeMem(info,ModeInfoArrayElements_Size );
end;
finally
FreeMem(paths,PathArrayElements_Size);
end;
end;
end;
end;
function setTopology ( top : DISPLAYCONFIG_TOPOLOGY_ID) : boolean;
var flags : dword;
begin
result := false;
flags := DecodeDISPLAYCONFIG_TOPOLOGY_ID_SDC(top);
if flags <> 0 then
begin
result := SetDisplayConfig(0,nil,0,nil,SDC_APPLY or flags) = ERROR_SUCCESS;
end;
end;
Since these functions don't exist in XP (as far as I know), I am looking for a stable way of achieving a similar thing in XP. whilst i am coding in Delphi, it's not necessary that the solution be presented as such. i am quite happy to just look at how it's done, or read a description of the appropriate steps, and implement it myself.
(removed full listing as it was confusing the issue as it did not appear like a question)

Seeking (free) framework for network programming

This is an attempt to rephrase my previous question as a result of the feeedback which it received.
I want a simple network communication which I can use as an underlying framework and never have to look at again. I just want o push a string from one PC to another and get a string in response. I don't want to have to worry about opening conenctions, keeping them open, reopening them if they close, etc.
I want to concentrate on my application and have a simple functional API along the lines of:
SendStringToOtherPc() : String; // Called at PC #1.
// Returns PC #2's result string
// or "" on error (or throws exception)
ProcessReceivedStringAndReply(); // Called at PC # 2. Sends result string
I do need to know if the other PC replied or not; and, if so, what the result string was
also "nice to have" would be for both PCs to initiate communication. If not, I can have one of them (the client poll), or have the other send its communication as a reply to the heartbeat which I need to add.
I presume that those with multiple fprojects under their belts have a "starter" framework which they use for every new project, just adding the application specific log - and it's such a framwork, or abstraction layer, that I want. Can anyone point me at a URL?
I know nothing of socket programming and don't really have time to learn. If I do, some other project will suffer.
While I do respect the argument that I should understand what my software is doing, there is a valid counter-arguement that everyone should not have to develop this particular wheel for himself, and surely there is some FOSS around which does what I want?
Thanks in advance.
Update: I seem to have started a little controversy, with some thinking me lazy or doomed to disaster. So, maybe I should explain a little of my history.
I spent three decades developing telecoms software and we always followed the OSI 7 layer model. I was generally layer 3, the network layer, and no matter whether it was a telephone exchange, base station or hanset, whether the protocol was ISDN, ISUP, DECT, GSM, GPRS, UMTS or a propietary satellite protocol, I could always instuct a Serveice Access Point of Layer 2, the data transport layer, "hey, you! Get this mesage to the other guy and tell me what his reply is". Did I know how it was done? Did I care?
#CosmicPrund, who will probably be awarded the answer unless someone points me at a Layer 2, said "The true answer to this question is that all you need is learn how to use Indy" and I beg to disagree.
Someone will, but not me if I can help it. I already leanred too many skills, programming languages, databse systems, oprerating systems and will always avoid learning more that an overview of another if I can. Like Sir Isaac Newton, I would prefer to stand on the shoulders of giants.
Software is just getting too big for one guy. Surely none of you start each project from scratch? I guess you reuse the networking code from a previous project(?) and that reusable code is my "Layer 2". And my question is where can I download such code and use it without understanding its inner workings?
Does anyone know of such a thing?
Answer: I used Indy and got what I wanted. I will porbably try to build up a library of functions which I can use as a network abstraction layer.
I have a free framework that will do all this. The benefit is that you can use it without any knowledge of sockets whatsoever. You can safely ignore connects and disconnects because this is all handled by the framework (the underlying comms framework keeps a continuous connection via configurable pings, etc). A message queueing threading model is also built into the framework. I have a demo for your exact example as well. The downside is obviously a steep learning curve. Have a look at http://www.csinnovations.com/framework_delphi.htm
The true answer to this question is that all you need is learn how to use Indy. To prove my point I'll give you a 89 lines unit that actually implements all you requested, plus a proof-of-concept sample of how to use it.
Before I show the code I'd like to mention:
89 lines of code can't be called a framework. It's just a thin wrapper that's simply not worth it. Sooner or later you'd run into stuff that requires direct access to the underlying Indy framework.
Someone with more Indy experience would probably write this using even less lines of code.
I could even make it shorter myself, since I included two overloaded "StartServer" methods for ease of demonstration.
Implementing this using components dropped on a form would cut the number of lines further.
Here's the "framework" unit:
unit UTcpIntercom;
interface
uses IdContext, IdCustomTCPServer, IdTCPServer, IdBaseComponent,
IdComponent, IdTCPConnection, IdTCPClient, SysUtils;
type
EIntercomError = class(Exception);
TReceivedText = procedure(const TextFromClient:string; var Response:string) of object;
TReceivedTextProc = procedure(const TextFromClient:string; var Response:string);
TIntercomServer = class(TIdCustomTCPServer)
protected
Event: TReceivedText;
Proc: TReceivedTextProc;
HostGreeting: string;
public
function DoExecute(AContext: TIdContext): Boolean; override;
end;
function SendTextToComputer(const TextToSend, HostToSend, HostGreeting:string; PortNumber: Integer): string;
function StartServer(PortNumber:Integer; const HostGreeting:string; OnReceivedText: TReceivedText):TIntercomServer;overload;
function StartServer(PortNumber:Integer; const HostGreeting:string; OnReceivedText: TReceivedTextProc):TIntercomServer;overload;
implementation
function SendTextToComputer(const TextToSend, HostToSend, HostGreeting:string; PortNumber: Integer): string;
var Id: TIdTCPClient;
begin
Id := TIdTCPClient.Create(nil);
try
Id.Host := HostToSend;
Id.Port := PortNumber;
Id.Connect;
try
if Id.IOHandler.ReadLn <> HostGreeting then
raise EIntercomError.Create('Host is invalid: ' + HostToSend);
Id.IOHandler.WriteLn(TextToSend);
Result := Id.IOHandler.ReadLn;
Id.Disconnect;
finally Id.Disconnect;
end;
finally Id.Free;
end;
end;
function StartServer(PortNumber:Integer; const HostGreeting:string; OnReceivedText: TReceivedText):TIntercomServer;overload;
begin
Result := TIntercomServer.Create(nil);
Result.Bindings.Add.Port := PortNumber;
Result.HostGreeting := HostGreeting;
Result.Event := OnReceivedText;
Result.Active := True;
end;
function StartServer(PortNumber:Integer; const HostGreeting:string; OnReceivedText: TReceivedTextProc):TIntercomServer;overload;
begin
Result := TIntercomServer.Create(nil);
Result.Bindings.Add.Port := PortNumber;
Result.HostGreeting := HostGreeting;
Result.Proc := OnReceivedText;
Result.Active := True;
end;
{ TIntercomServer }
function TIntercomServer.DoExecute(AContext: TIdContext): Boolean;
var Text, Response: string;
begin
AContext.Connection.IOHandler.WriteLn(HostGreeting);
Text := AContext.Connection.IOHandler.ReadLn;
Response := '';
if Assigned(Event) then
Event(Text, Response)
else if Assigned(Proc) then
Proc(Text, Response)
else
Response := 'No handler assigned.';
AContext.Connection.IOHandler.WriteLn(Response);
AContext.Connection.Disconnect;
Result := True;
end;
end.
Here's the code that uses the unit. Notice the DoSomethingWithTextFromClient, that's essentially your ProcessReceivedStringAndReply method. Also notice the use of StartServer and SendTextToComputer.
program Project9;
{$APPTYPE CONSOLE}
uses
SysUtils,
UTcpIntercom in 'UTcpIntercom.pas';
procedure DoSomethingWithTextFromClient(const TextFromClient: string; var Response:string);
var i: Integer;
C: Char;
Len: Integer;
begin
Response := TextFromClient;
Len := Length(Response);
for i:=1 to (Length(Response) div 2) do
begin
C := Response[Len-i+1];
Response[Len-i+1] := Response[i];
Response[i] := C;
end;
end;
begin
try
try
with StartServer(1000, 'Test', #DoSomethingWithTextFromClient) do
begin
WriteLn(SendTextToComputer('12345678', '127.0.0.1', 'Test', 1000));
Free;
end;
Readln;
except on E:Exception do
begin
WriteLn(E.ClassName);
WriteLn(E.Message);
Readln;
end;
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.

Tree-like Datastructure (for use with VirtualTreeview)

I have come to the point where I need to stop storing my data in a VCL component, and have an "underlying datastructure", as Mr. Rob Kennedy suggested.
First of all, this question is about "how do I make an underlying datastructure". :)
My hierachy consists of 2 levels of nodes.
Right now, I go thru my stuff by looping rootnodes, wherein I loop thru the rootnode's childnodes, to get what I need (Data). I would love to be able to store all my data in a so-called Underlying Datastructure, so that I can easily modify the entries using threads (I suppose I am able to do that?)
However, when looping through my entries (right now), the results are depending on the node's Checkstate - if I am using an underlying data structure, how do I know if my node is checked or not, when its my datastructure I loop thru, and not my nodes?
Let's say I wanted to use 2 levels.
This would be the Parent:
TRoot = Record
RootName : String;
RootId : Integer;
Kids : TList; //(of TKid)
End;
And the kid:
TKid = Record
KidName : String;
KidId : Integer;
End;
Thats basically what I do now. Comments state that this is not the best solution, so I am open to suggestions. :)
I hope you understand my question(s). :)
Thanks!
The data structure you're requesting is very simple, it's so simple I'd recommend using the windows-provided TTreeView: it allows storing the text and an ID straight into the tree's node with no additional work.
Despite my recommendation to use the simpler TTreeView I'm going to provide my take on the data structure problem. First of all I'm going to use classes, not records. In your very short code sample you're mixing records and classes in a very unfrotunate way: When you make a copy of the TRoot record (assigning records makes complete copies, because records are allways treated as "values"), you're not making a "deep copy" of the tree: The complete copy of TRoot will contain the same Kids:TList as the original, because classes, unlike records, are references: you're coping the value of the reference.
An other problem when you have a record with an object field is life cycle management: A record doesn't have an destructor so you'll need an other mechanism to free the owned object (Kids:TList). You could replace the TList with an array of Tkid but then you'll need to be very careful when passing the monster record around, because you might end making deep copies of huge records when you least expect it.
In my opinion the most prudent thing to do is to base the data structure on classes, not records: class instances (objects) are passed around as references, so you can move them around all you want with no problems. You also get built-in life cycle management (the destructor)
The base class would look like this. You'll notice it can be used as either the Root or the Kid, because both Root and Kid share data: The both have a name and an ID:
TNodeClass = class
public
Name: string;
ID: Integer;
end;
If this class is used as an Root, it needs a way to store the Kids. I assume you're on Delphi 2010+, so you have generics. This class, complete with a list, looks like this:
type
TNode = class
public
ID: integer;
Name: string;
VTNode: PVirtualNode;
Sub: TObjectList<TNode>;
constructor Create(aName: string = ''; anID: integer = 0);
destructor Destroy; override;
end;
constructor TNode.Create(aName:string; anID: Integer);
begin
Name := aName;
ID := anID;
Sub := TObjectList<TNode>.Create;
end;
destructor TNode.Destroy;
begin
Sub.Free;
end;
You might not immediately realize this, but this class alone is enough to implement a multi-level tree! Here's some code to fill up the tree with some data:
Root := TNode.Create;
// Create the Contacts leaf
Root.Sub.Add(TNode.Create('Contacts', -1));
// Add some contacts
Root.Sub[0].Sub.Add(TNode.Create('Abraham', 1));
Root.Sub[0].Sub.Add(TNode.Create('Lincoln', 2));
// Create the "Recent Calls" leaf
Root.Sub.Add(TNode.Create('Recent Calls', -1));
// Add some recent calls
Root.Sub[1].Sub.Add(TNode.Create('+00 (000) 00.00.00', 3));
Root.Sub[1].Sub.Add(TNode.Create('+00 (001) 12.34.56', 4));
You need a recursive procedure to fill the virtual tree view using this type:
procedure TForm1.AddNodestoTree(ParentNode: PVirtualNode; Node: TNode);
var SubNode: TNode;
ThisNode: PVirtualNode;
begin
ThisNode := VT.AddChild(ParentNode, Node); // This call adds a new TVirtualNode to the VT, and saves "Node" as the payload
Node.VTNode := ThisNode; // Save the PVirtualNode for future reference. This is only an example,
// the same TNode might be registered multiple times in the same VT,
// so it would be associated with multiple PVirtualNode's.
for SubNode in Node.Sub do
AddNodestoTree(ThisNode, SubNode);
end;
// And start processing like this:
VT.NodeDataSize := SizeOf(Pointer); // Make sure we specify the size of the node's payload.
// A variable holding an object reference in Delphi is actually
// a pointer, so the node needs enough space to hold 1 pointer.
AddNodesToTree(nil, Root);
When using objects, different nodes in your Virtual Tree may have different types of objects associated with them. In our example we're only adding nodes of TNode type, but in the real world you might have nodes of types TContact, TContactCategory, TRecentCall, all in one VT. You'll use the is operator to check the actual type of the object in the VT node like this:
procedure TForm1.VTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
var PayloadObject:TObject;
Node: TNode;
Contact : TContact;
ContactCategory : TContactCategory;
begin
PayloadObject := TObject(VT.GetNodeData(Node)^); // Extract the payload of the node as a TObject so
// we can check it's type before proceeding.
if not Assigned(PayloadObject) then
CellText := 'Bug: Node payload not assigned'
else if PayloadObject is TNode then
begin
Node := TNode(PayloadObject); // We know it's a TNode, assign it to the proper var so we can easily work with it
CellText := Node.Name;
end
else if PayloadObject is TContact then
begin
Contact := TContact(PayloadObject);
CellText := Contact.FirstName + ' ' + Contact.LastName + ' (' + Contact.PhoneNumber + ')';
end
else if PayloadObject is TContactCategory then
begin
ContactCategory := TContactCategory(PayloadObject);
CellText := ContactCategory.CategoryName + ' (' + IntToStr(ContactCategory.Contacts.Count) + ' contacts)';
end
else
CellText := 'Bug: don''t know how to extract CellText from ' + PayloadObject.ClassName;
end;
And here's an example why to store VirtualNode pointer to your node instances:
procedure TForm1.ButtonModifyClick(Sender: TObject);
begin
Root.Sub[0].Sub[0].Name := 'Someone else'; // I'll modify the node itself
VT.InvalidateNode(Root.Sub[0].Sub[0].VTNode); // and invalidate the tree; when displayed again, it will
// show the updated text.
end;
You know have an working example for a simple tree data structure. You'll need to "grow" this data structure to suite your needs: the possibilities are endless! To give you some ideas, directions to explore:
You can turn the Name:string into a virtual method GetText:string;virtual and then create specialized descendants of TNode that override GetText to provide specialized behavior.
Create a TNode.AddPath(Path:string; ID:Integer) that allows you to do Root.AddPath('Contacts\Abraham', 1); - that is, a method that automatically creates all intermediary nodes to the final node, to allow easy creation of the tree.
Include an PVirtualNode into TNode itself so you can check rather the Node is "checked" in the Virtual Tree. This would be a bridge of the data-GUI separation.
I believe you will be best served by finding an existing library containing a general tree implementation which you can then re-use to serve your needs.
To give you an idea why, here is some code I wrote to illustrate the most simple operation on the most simple tree structure imaginable.
type
TNode = class
Parent: TNode;
NextSibling: TNode;
FirstChild: TNode;
end;
TTree = class
Root: TNode;
function AddNode(Parent: TNode): TNode;
end;
function TTree.AddNode(Parent: TNode);
var
Node: TNode;
begin
Result := TNode.Create;
Result.Parent := Parent;
Result.NextSibling := nil;
Result.FirstChild := nil;
//this may be the first node in the tree
if not Assigned(Root) then begin
Assert(not Assigned(Parent));
Root := Result;
exit;
end;
//this may be the first child of this parent
if Assigned(Parent) and not Assigned(Parent.FirstChild) then begin
Parent.FirstChild := Result;
end;
//find the previous sibling and assign its next sibling to the new node
if Assigned(Parent) then begin
Node := Parent.FirstChild;
end else begin
Node := Root;
end;
if Assigned(Node) then begin
while Assigned(Node.NextSibling) do begin
Node := Node.NextSibling;
end;
Node.NextSibling := Result;
end;
end;
Note: I have not tested this code and so cannot vouch for its correctness. I expect it has defects.
All this does is add an new node to the tree. It gives you little control over where in the tree the node is added. If simply adds a new node as the last sibling of a specified parent node.
To take this sort of approach you would likely need to deal with:
Inserting after a specified sibling. Actually this is quite a simple variant of the above.
Removing a node. This is somewhat more complex.
Moving existing nodes within the tree.
Walking the tree.
Connecting the tree to your VST.
It's certainly feasible to do this, but you may be better advised to find a 3rd party library that already implements the functionality.
I asked similar question here. I didn't got any useful answers so I decide to make my own implementation, which you can find here.
EDIT:
I'll try to post example how you could use my data structure:
uses
svCollections.GenericTrees;
Declare your data type:
type
TMainData = record
Name: string;
ID: Integer;
end;
Declare your main data tree object somewhere in your code:
MyTree: TSVTree<TMainData>;
Create it (and do not forget to free later):
MyTree: TSVTree<TMainData>.Create(False);
Assign your VirtualStringTree to our data structure:
MyTree.VirtualTree := VST;
Then you can init your data tree with some values:
procedure TForm1.BuildStructure(Count: Integer);
var
i, j: Integer;
svNode, svNode2: TSVTreeNode<TMainData>;
Data: TMainData;
begin
MyTree.BeginUpdate;
try
for i := 0 to Count - 1 do
begin
Data.Name := Format('Root %D', [i]);
Data.ID := i;
svNode := MyTree.AddChild(nil, Data);
for j:= 0 to 10 - 1 do
begin
Data.Name := Format('Child %D', [j]);
Data.ID := j;
svNode2 := MyTree.AddChild(svNode, Data);
end;
end;
finally
MyTree.EndUpdate;
end;
end;
And set VST events to display your data:
procedure TForm1.vt1InitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode;
var ChildCount: Cardinal);
var
svNode: TSVTreeNode<TMainData>;
begin
svNode := MyTree.GetNode(Sender.GenerateIndex(Node));
if Assigned(svNode) then
begin
ChildCount := svNode.FChildCount;
end;
end;
procedure TForm1.vt1InitNode(Sender: TBaseVirtualTree; ParentNode,
Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
var
svNode: TSVTreeNode<TMainData>;
begin
svNode := MyTree.GetNode(Sender.GenerateIndex(Node));
if Assigned(svNode) then
begin
//if TSVTree<TTestas> is synced with Virtual Treeview and we are building tree by
// setting RootNodeCount, then we must set svNode.FVirtualNode := Node to
// have correct node references
svNode.FVirtualNode := Node; // Don't Forget!!!!
if svNode.HasChildren then
begin
Include(InitialStates, ivsHasChildren);
end;
end;
end;
//display info how you like, I simply get name and ID values
procedure TForm1.vt1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
var
svNode: TSVTreeNode<TMainData>;
begin
svNode := MyTree.GetNode(Sender.GenerateIndex(Node));
if Assigned(svNode) then
begin
CellText := Format('%S ID:%D',[svNode.FValue.Name, svNode.FValue.ID]);
end;
end;
At this point you work only with your MyTree data structure and all the changes made to it will be reflected in your assigned VST. You then can always save (and load) underlying structure to stream or file. Hope this helps.
If I understand correctly, you need a datastructure for your tree. Each individual node requires a record to hold its data. But the underlying heirarchy can be managed in a few different ways. Im guessing this is all to be managed in some sort of database - This has already been talked about on this site, so i will point you to:
Implementing a hierarchical data structure in a database
and here:
What is the most efficient/elegant way to parse a flat table into a tree?
and here:
SQL - How to store and navigate hierarchies?
Nested Set Model:
http://mikehillyer.com/articles/managing-hierarchical-data-in-mysql/
If you are using recent versions of Delphi that supports Generics, check GenericTree
Delphi has generics nowadays. I just invented a very nice tree data structure. Not gonna give code away just yet, not really an open source person, maybe in the near future though, also other reasons see below.
But I will give some hints on how to re-create it:
Assuming all your nodes can contain the same data structure (which seems to be the case from above, a string, an id, and then links.
The ingredients you need to re-create this is the following:
Generics
A generic type T
This type T needs to be constrained to class and constructor as follows:
<T : class, constructor> (In your case replace class with record, untested, but may also work)
two fields: node array of self (hint hint), data : T;
A property
Not just any propery, a default property ;)
A getter.
A recursive constructor with depth and child.
Some if statement to stop the construction.
And ofcourse SetLength to create the links/nodes and calling some creates in a for loop and then some subtraction of something ;)
Given all of you enough hints, would be fun and interesting to see if anybody can re-create it, otherwise I might just as well patent it, just kidding, not gonna throw money against it, might expand the class though with other facilities.
The class allocates all nodes during construction like a true data structure... noting with add and remove and such, at least not for now.
Now comes the most interesting and funny aspect of this (secret) design, something I kinda wanted and is now a reality. I can now write code as follows:
TGroup is just an example can be anything as long as it's a class in my case.
In this case it's just a class with mString
var
mGroupTree : TTree<TGroup>;
procedure Main;
var
Depth : integer;
Childs : integer;
begin
Depth := 2;
Childs := 3;
mGroupTree := TTree<TGroup>.Create( Depth, Childs );
mGroupTree.Data.mString := 'Basket'; // notice how nice this root is ! ;)
mGroupTree[0].Data.mString := 'Apples';
mGroupTree[1].Data.mString := 'Oranges';
mGroupTree[2].Data.mString := 'Bananas';
mGroupTree[0][0].Data.mString := 'Bad apple';
mGroupTree[0][1].Data.mString := 'Average apple';
mGroupTree[0][2].Data.mString := 'Good apple';
mGroupTree[1][0].Data.mString := 'Tiny orange';
mGroupTree[1][1].Data.mString := 'Medium orange';
mGroupTree[1][2].Data.mString := 'Big orange';
mGroupTree[2][0].Data.mString := 'Straight banana';
mGroupTree[2][1].Data.mString := 'Curved banana';
mGroupTree[2][2].Data.mString := 'Crooked banana';
Now what you may notice from this actual test code is that it allows "array expansion" like I have rarely seen thanks to this property, which self-references sort of...
So [] [] is depth 2.
[][][] would be depth 3.
I am still evaluating the use of this.
One potential problem is Delphi has no real technique to auto-expand these arrays, though none I have yet found and are statisfied with.
I would like a technique where I can write some code which can go to any depth level:
[0][0][0][0][0]
Not yet sure how to do that... simpelst option is "recursion".
real example:
procedure DisplayString( Depth : string; ParaTree : TTree<TGroup>);
var
vIndex : integer;
begin
if ParaTree <> nil then
begin
// if ParaTree.Data.mString <> '' then
begin
writeln( ParaTree.Data.mString );
Depth := Depth + ' ';
for vIndex := 0 to ParaTree.Childs-1 do
begin
DisplayString( Depth, ParaTree[vIndex] );
end;
end;
end;
end;
Kinda interesting isn't it.
Still exploring it's usefullness for "real applications" and if I want to go with recursion or not ;)
Maybe some day I will open source all of my code. I am close to 40 years old, when I go beyond 40, from 39 to 40, I was kinda planning on going open source. Still 4 months away from 40 =D
(I must say this is the first time I am impressed by Generics, tested it long ago, it was super buggy back then and maybe design-wise unusable, but now with the bugs fixed and constrained generics, it's very impressive in latest Delphi Toyko 10.2.3 version august 2018 ! ;) :))
I am just scratching the surface of what is impossible with latest Delphi tech, maybe with anonymous methods writing recursive routines to process this data structure might become a bit easier, also maybe parallel processing might come into consideration, Delphi help mentions this for anonymous methods.
Bye,
Skybuck.

how to quickly verify the case sensitive filename really exists

I have to make a unix compatible windows delphi routine that confirms if a file name exists in filesystem exactly in same CaSe as wanted, e.g. "John.txt" is there, not "john.txt".
If I check "FileExists('john.txt')" its always true for John.txt and JOHN.TXT due windows .
How can I create "FileExistsCaseSensitive(myfile)" function to confirm a file is really what its supposed to be.
DELPHI Sysutils.FileExists uses the following function to see if file is there, how to change it to double check file name is on file system is lowercase and exists:
function FileAge(const FileName: string): Integer;
var
Handle: THandle;
FindData: TWin32FindData;
LocalFileTime: TFileTime;
begin
Handle := FindFirstFile(PChar(FileName), FindData);
if Handle <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(Handle);
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
begin
FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi,
LongRec(Result).Lo) then Exit;
end;
end;
Result := -1;
end;
function FileExistsEx(const FileName: string): Integer;
var
Handle: THandle;
FindData: TWin32FindData;
LocalFileTime: TFileTime;
begin
Handle := FindFirstFile(PChar(FileName), FindData);
if Handle <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(Handle);
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
begin
FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, LongRec(Result).Lo) then
if AnsiSameStr(FindData.cFileName, ExtractFileName(FileName)) then Exit;
end;
end;
Result := -1;
end;
Tom, I'm also intrigued by your use case. I tend to agree with Motti that it would be counter intuitive and might strike your users as odd.
On windows file names are not case sensitive so I don't see what you can gain from treating file names as if they were case sensitive.
In any case you can't have two files named "John.txt" and "john.txt" and failing to find "John.txt" when "john.txt" exists will probably result in very puzzled users.
Trying to enforce case sensitivity in this context is un-intuitive and I can't see a viable use-case for it (if you have one I'll be happy to hear what it is).
I dealt with this issue a while back, and even if I'm sure that there are neater solutions out there, I just ended up doing an extra check to see if the given filename was equal to the name of the found file, using the case sensitive string comparer...
I ran into a similar problem using Java. Ultimately I ended up pulling up a list of the directory's contents (which loaded the correct case of filenames for each file) and then doing string compare on the filenames of each of the files.
It's an ugly hack, but it worked.
Edit: I tried doing what Banang describes but in Java at least, if you open up file "a.txt" you'r program will stubbornly report it as "a.txt" even if the underlying file system names it "A.txt".
You can implement the approach mention by Kris using Delphi's FindFirst and FindNext routines.
See this article

Resources