Archive
Quartex Pascal: Nearing completion
When developers talk about web development they usually mean creating web pages with the tools common for the web sphere. Web designer software is abundantly available online, from single-click page wizards to more ad-hoc, old school HTML / JavaScript editors. If there is something the world don’t need more of, It’s one-click website solutions.
One challenge that haven’t been addressed until recent times in the web sphere, is that of programming language. JavaScript is a fun language, but it was never really designed for large-scale application development. As websites become more and more elaborate, the need for traditional programming languages and features started to surface. In many ways the past 15 years of browser evolution, has been all about JavaScript catching up with the needs of developers.
But are we really limited to JavaScript?
When it comes to language and web technology, it was C/C++ that became the second language of the internet via the introduction of Asm.js and eventually Webassembly. It took a long time for other languages to adopt the Webassembly binary format as a target. WebAssembly is a bytecode binary format consisting of low-level instructions, much like assembly for x86 processors. These instructions are converted into real machine code by the browser (via a process called JIT compilation), and as a result the performance of Webassembly is close to native code. Having said that, Webassembly comes with its own set of restrictions and challenges, especially when it comes to manipulating the DOM (the document object model, the elements that makes up a HTML document).
The Quartex Way
Back in 2010 I had a novel idea with regards to languages: what if we translate Delphi code on source level, and emit JavaScript instead? At the time there was no such thing as webassembly, and the closest thing to a binary format was Macromedia Flash. Without rehashing the story, I teamed up with Eric Grange from Creative IT in France, the maintainer of Delphi Web Script, and the end result was a compiler that would parse Object Pascal code, construct an AST (abstract symbol tree) which is a model that represents the entire program, and further convert that into optimized JavaScript.
In order for such a system to work properly, a whole new RTL (runtime-library) had to be created. All the functions, procedures and classes that Delphi provides would not magically compile to JavaScript. So someone had to sit down and implement classes and features that made sense for the browser, from TComponent all the way up to TCustomControl – but in a way that is compatible with HTML.
It is out of this work that the Quartex Framework came into being, as a personal research and development framework dealing with web technology. Back in 2014 it was just a utility library, and it remained as such until 2019 when it became a fully functional RTL in its own right. An RTL with a wingspan from low-level binary data, all the way up to visual components and database connectivity. In 2020 it expanded to Node.js, which is a JavaScript scripting-host used to write servers and services. The Quartex framework as now a full stack RTL that radically cuts down on development time needed when writing websites, mobile applications or server technology.
The Quartex IDE
Delphi has a wonderful IDE that has been polished and evolved over almost 2 decades. It is possible to introduce new compilers and third party technology into that IDE, but Delphi is limited to native technology. The only way to integrate QTX with Delphi, would be to mimic the VCL or FMX in its entirety, so that class-names match and the form design files could be read and used by the Quartex Compiler.
While such a project would probably be easier, it also meant a massive compromise in terms of features and performance. As a native development system Delphi does things in a very specific way, and if I forced JavaScript and HTML to abide by those rules – we would lose the dynamic and flamboyant aspects of HTML5 and JavaScript. The performance would also be poor since the VCL (and consequently LCL) was never written for the browser or Node.js. A test I did on performance, comparing QTX compiled code with TMS compiled code demonstrates my point. TMS populates a listbox with roughly 1000 items in 2 seconds. QTX populates the same listbox with 20.000 items in 1.8 seconds.
The only reasonable way forward was to implement a separate IDE, one that dealt with web technology exclusively. And what better language to write such a system in than Delphi itself? I was actually thinking that Embarcadero might want to rekindle their HTML5 Builder, and let me do my magic on it. Quartex Pascal is in many ways what HTML5 Builder should have been, and it’s just getting started.
Writing an IDE is a massive undertaking. It covers technologies such as code suggestion, form and container designer, communication protocol design, license management – and much, much more. The IDE has been worked on every weekend for a year, and the results are solid.
What is important with an IDE like this, is that it represents a broad foundation for further development. It is written to be highly modular, with everything neatly isolated in classes. If a particular feature requires adjustment, then refactoring that particular module is a straightforward task. Large applications have a tendency to become a mesh of spaghetti that only the original developer understands, something I have worked very hard to avoid. The source-code is available for backers on Patreon.
Server Side Programming
Node.js is a scripting host based on Google’s V8 JavaScript engine, which runs outside the browser. It is designed to run from the command-line (read: standard scripting host) and gives developers all the features you expect from a native program, like raw file access, multi threading (read: Node operates with multi processes), servers and sockets, third party libraries and much more.
Being able to write both client and server from the same development system, a so called “full stack” development environment, is a great boon and opens up for deployment on enterprise level.
But being able to communicate across services and servers means that the IDE had to provide the tools for async network programming. Working with async code is not hard, but it can be difficult if your codebase does not take height for it.
To help simplify communication between servers, services or clients (read: browser and server, or locally as inter process communication) I wrote the Ragnarok message framework. The IDE now has a visual protocol designer which makes it extremely easy to design messages and complex datatypes that is used when communicating. The protocol designer takes your design and generates ready-to-use classes and units.
Object Pascal as a web language
You might think that object pascal with its rigid rules and pure logic is too stiff for web development. It turns out that this was exactly what the browser needed, as a solid anchor to the otherwise “anything goes” reality of JavaScript. Eric Grange made a lot of changes to the dialect which allows Quartex Pascal to interface more easily with JS, such as partial classes, external classes, static (in the C++ / C# meaning of the word), support for lambdas, inline variables, anonymous procedures, records and classes – and finally support for the async and await keywords when working with promises.
Object Pascal brings a clarity to web development that JavaScript and TypeScript simply lacks. It also introduces normal inheritance (like C/C++ and Delphi has), with abstract and virtual members. When you combine this with partial classes, you have a dialect that is extremely productive, and that takes on node.js and Javascript on its own terms.
Come join the fun
The Quartex Pascal project is nearing completion. It is not finished just yet, but I am aiming for a release of version 1.0 before xmas. Quartex Pascal is based on Patreon backing, which means those that back the project and contribute financially enjoys weekly builds and working closer with the author on shaping the system. Premium backers also have access to the source-code, with rights to modify and use the system for whatever they like, providing the no-compete clause is respected.
If you find Quartex Pascal interesting – why not become a backer?
Quartex Pascal will be free for schools and educational institutions, as well as for students, non-profit organizations and open-source development. For commercial use a symbolic fee of $300 is needed. The system is licensed as shareware in order to avoid an avalanche of clones, which can quickly kill a project.
When Nicola Tesla slaps you over the head
If you have poked around the Quartex Pascal RTL you might have notice that QTX comes with a serial-number minting system. Creating unique serial numbers that can be mathematically re-traced back to a root key (number sequence) is extremely tricky business. My solution was to dip my fingers into esoteric and occult numerology, because our ancient forbearers had a knack for puzzles and number based riddles.
And here I thought I was super clever, only to discover that Nicola Tesla scribbled a similar system on a napkin back in the late 1800s (figuratively speaking). Turns out that the basis of my system is more or less identical to Tesla’s numbers and ultimately bound by their relationships, where you operate with a growth factor that is a multiple of 12, modulated and held in check by Fibonacci, Lucas or Leonardo sequencing.
So my ego got a well deserved slap (which is always healthy, we should all be humble in the presence of that man).
I have never really been that interested in Tesla until recently, and the little I have read about him makes me incredibly sad. This man was not decades ahead of his time, but centuries.
In my view, the biggest tragedy in human history is without a doubt the loss of the great library in Alexandria, Egypt. Second only with the murder of Hypatia; a series of events that would eventually catapult humanity as a whole into a dark-age that lasted for 2000 years.
But having spent some time this morning reading about Tesla, I would add him to that list of tragic events that have affected our history (or in his case, being prevented from lifting mankind up). This is a man that constructed the walkie-talkie in the late 1800s. He even theorized that both audio and video could be transmitted over a hand-held device. And this was in the late 1800s (!).
Above: The serial-number minting dialog from the IDE. Here we use 12 seed numbers to form the root key, and each serial number is grown from these using natural numbers, as employed by various mystics and esoteric traditions.
Hat off Tesla. It is a great shame that you were born into a world that neither understood or appreciated the wonders you delivered.
Nicolas Tesla’s notebooks is best read on your knees.
Now I need to scotch tape my ego back together and get to work.
Quartex Pascal, convergence is near
A Quartex Cluster of 5 x ODroid XU4. A $400 super computer running Quartex media Desktop. Enough to power a school.
I only have the weekends to work on Quartex Pascal, but I have spent the past 18 months tinkering away, making up for wasted time. So I’m just going to leave some pictures here for you to enjoy.
Note: I was asked on LinkedIn if this has anything to do with Smart Mobile Studio, and the answer is a resounding no. I have nothing to do with Smart any more. QTX Pascal is a completely separate project that is written from scratch by yours truly.
The QTX Framework was initially a library I created back in 2014, but it has later been completely overhauled and turned into a full RTL. It is not compatible with Smart Pascal and has a completely different architecture.
QTX Pascal is indirectly funded by the Amiga Retro Community (which might sound strange, but the technical level of that community is beyond anything I have encountered elsewhere) since QTX is central to the creation of the Quartex Media Desktop. It is a shame that Embarcadero decided to not back the project. The compiler and toolchain would have been a part of Delphi by now, and I wouldn’t have to write a separate IDE. But when they see what this system can deliver in terms of services, database work, mobile and embedded -they might regret it. The project only accepts donation funding, I am not interested in investors or partners. If you want a vision turned into reality, you gotta do it yourself. Everything else just gets in the way.
For developers by developers
Quartex Pascal is made for the community. It will be free for students and open-source projects. And a commercial license will never exceed $300. It is a shareware license and the financial aspects is purely to help fund further research and development of the desktop cloud platform. The final goal (CloudForge) is to compile the IDE itself to JavaScript, so people only need a browser to write enterprise level applications via Quartex Media Desktop. When that is finished, my work is done – and people have a clear path to the future.
Unlike other systems, QTX started with the non-visual stuff, so the system has a well implemented infrastructure for writing universal services and servers, using node.js as a deployment host. Services are also Docker friendly. Runs without change on Windows, Mac OS, Linux and a wealth of embedded systems and SBCs (single board computers)
A completely new RTL written from scratch generates close to native speed JS, highly compatible (even with legacy browsers) and rock solid
There are several display modes for QTX forms, from dynamic to absolute positioning. You can mix and match between HTML and QTX code, including a HTML5 compliant WYSIWYG editor and style manager. Makes content handling a lot easier
Write object pascal, JavaScript, HTML, LDEF (webassembly), node.js services – or mix and match between them all for maximum potential. Writing mobile applications is now ridiculously easy compared to “other tools” out there.
Oh and for the proverbial frosting — The full clustered Quartex Media desktop and services is a project type. Thats right. A complete cloud infrastructure suitable for teams, kiosks, embedded, schools, intranets – and even an replacement OS for ChromeOS. You don’t need to interface with Amazon, you get your own Amazon (optional naturally).
Filesystem over websocket, IPC between hosted apps and desktop, full back-end services that are clustered, and run on anything from a Raspberry PI 4 to low-cost ARM SBCs.
Web Assembly made easy. Both for Delphi and QTX
Let there be rock
Oh, and documentation. Loads and loads of documentation.
Proper documentation, both class overview and explanations that a human being has written is paramount for learning and getting up to speed quickly.
I don’t have vacation this year, which means I only have weekends to tinker away. But i have spent the past 18-ish months preparing and slowly finishing the pieces I needed. From vector containers to form design controls, to a completely re-written RTL from scratch — so yeah. This time I’m doing it my way.
C/C++ porting, QTX and general status
C is a language that I used to play around with a lot back in the Amiga days. I think the last time I used a C compiler to write a library must have been in 1992 or something like that? I held on to my Amiga 1200 for as long as i could – but having fallen completely in love with Pascal, I eventually switched to x86 and went down the Turbo Pascal road.
Lately however, C++ developers have been asking for their own Developer group on Facebook. I run several groups on Facebook in the so-called “developer” family. So you have Delphi Developer, FPC Developer, Node.JS Developer and now – C++Builder developer. The groups more or less tend to themselves, and the node.js and FPC groups are presently being seeded (meaning, that the member count is being grown for a period).
The C++Builder group however, is having the same activity level as the Delphi group almost, thanks to some really good developers that post links, tips and help solve questions. I was also fortunate enough to have David Millington come on the Admin team. David is leading the C++Builder project, so his insight and knowledge of both language and product is exemplary. Just like Jim McKeeth, he is a wonderful resource for the community and chime in with answers to tricky questions whenever he has time to spare.
Getting back in the saddle
Having working some 30 years with Pascal and Object Pascal, 25 of those years in Delphi, C/C++ is never far away. I have an article on the subject that i’ve written for the Idera Community website, so I wont dig too deep into that here — but needless to say, Rad Studio consists of two languages: Object Pascal and C/C++, so no matter how much you love either language, the other is never far away.
So I figured it was time for this old dog to learn some new tricks! I have always said that it’s wise to learn a language immediately below and above your comfort zone. So if Delphi is your favorite language, then C/C++ is below you (meaning: more low level and complex). Above you are languages like JavaScript and C#. Learning JavaScript makes strategic sense (or use DWScript to compile Pascal to JavaScript like I do).
When I started out, the immediate language below Object Pascal was never C, but assembler. So for the longest time I turned to assembler whenever I needed a speed boost; graphics manipulation and processing pixels is especially a field where assembly makes all the difference.
But since C++Builder is indeed an integral part of Rad Studio, and Object Pascal and C/C++ so intimately connected (they have evolved side by side), why not enjoy both assembly and C right?
So I decided to jump back into the saddle and see what I could make of it.
C/C++ is not as hard as you think
I’m having a ball writing C/C++, and just like Delphi – you can start where you are.
While I’m not going to rehash the article I have already prepared for the Idera Community pages here, I do want to encourage people to give it a proper try. I have always said that if you know an archetypal language, you can easily pick up other languages, because the archetypal languages will benefit you for a lifetime. This has to do with archetypal languages operating according to how computers really work; as opposed to optimistic languages (a term from the DB work, optimistic locking), also called contextual languages, like C#, Java, JavaScript etc. are based on how human beings would like things to be.
So I now had a chance to put my money where my mouth is.
When I left C back in the early 90s, I never bothered with OOP. I mean, I used C purely for shared libraries anyways, while the actual programs were done in Pascal or a hybrid language called Blitz Basic. The latter compiled to razor sharp machine code, and you could use inline assembly – which I used a lot back then (very few programmers on those machines went without assembler, it was almost given that you could use 68k in some capacity).
Without ruining the article about to be published, I had a great time with C++Builder. It took a few hours to get my bearings, but since both the VCL and FMX frameworks are there – you can approach C/C++ just like you would Object Pascal. So it’s a matter of getting an overview really.
Needless to say, I’ll be porting a fair share of my libraries to C/C++ when I have time (those that makes sense under that paradigme). It’s always good to push yourself and there are plenty of subtle differences that I found useful.
Quartex Media Desktop
When I last wrote about QTX we were nearing the completion of the FileSystem and Task Management service. The prototype had all its file-handling directly in the core service (or server) which worked just fine — but it was linked to the Smart Pascal RTL. It has taken time to write a new RTL + a full multi-user, platform independent service stack and desktop (phew!) but we are seeing progress!
The QTX Baseline backend services is now largely done
The filesystem service is now largely done! There are a few synchronous calls I want to get rid of, but thankfully my framework has both async and sync variations of all file procedures – so that is now finished.
To make that clearer: first I have to wrap and implement the functionality for the RTL. Once they are in the RTL, I can use those functions to build the service functions. So yeah, it’s been extremely elaborate — but thankfully it’s also become a rich, well organized codebase (both the RTL and the Quartex Media Desktop codebases) – so I think we are ready to get cracking on the core!
The core is still operating with the older API. So our next step is to remove that from the core and instead delegate calls to the filesystem to our new service. So the core will simply be reduced to a post-office or traffic officer if you like. Messages come in from the desktops, and the core delegates the messages to whatever service is in charge of them.
But, this also means that both the core and the desktop must use the new and fancy messages. And this is where I did something very clever.
While I was writing the service, I also write a client class to test (obviously). And the way the core works — means that the same client that the core use to talk to the services — can be used by the desktop as well.
So our work in the desktop to get file-access and drives running again, is to wrap the client in our TQTXDevice ancestor class. The desktop NEVER accesses the API directly. All it knows about are these device drivers (or object instances). Which is how we solve things like DropBox and Google Drive support. The desktop wont have the faintest clue that its using Dropbox, or copying files between a local disk and Google Drive for example — because it only communicates with these device classes.
Recursive stuff
One thing that sucked about node.js function for deleting a folder, is that it’s recursive parameter doesn’t work on Windows or OS X. So I had to implement a full recursive deletefolder routine manually. Not a big thing, but slightly more painful than expected under asynchronous execution. Thankfully, Object Pascal allows for inline defined procedures, so I didn’t have to isolate it in a separate class.
Here is some of the code, a tiny spec compared to the full shabam, but it gives you an idea of what life is like under async conditions:
unit service.file.core;
interface
{.$DEFINE DEBUG}
const
CNT_PREFS_DEFAULTPORT = 1883;
CNT_PREFS_FILENAME = 'QTXTaskManager.preferences.ini';
CNT_PREFS_DBNAME = 'taskdata.db';
CNT_ZCONFIG_SERVICE_NAME = 'TaskManager';
uses
qtx.sysutils,
qtx.json,
qtx.db,
qtx.logfile,
qtx.orm,
qtx.time,
qtx.node.os,
qtx.node.sqlite3,
qtx.node.zconfig,
qtx.node.cluster,
qtx.node.core,
qtx.node.filesystem,
qtx.node.filewalker,
qtx.fileapi.core,
qtx.network.service,
qtx.network.udp,
qtx.inifile,
qtx.node.inifile,
NodeJS.child_process,
ragnarok.types,
ragnarok.Server,
ragnarok.messages.base,
ragnarok.messages.factory,
ragnarok.messages.network,
service.base,
service.dispatcher,
service.file.messages;
type
TQTXTaskServiceFactory = class(TMessageFactory)
protected
procedure RegisterIntrinsic; override;
end;
TQTXFileWriteCB = procedure (TagValue: variant; Error: Exception);
TQTXFileStateCB = procedure (TagValue: variant; Error: Exception);
TQTXUnRegisterLocalDeviceCB = procedure (TagValue: variant; DiskName: string; Error: Exception);
TQTXRegisterLocalDeviceCB = procedure (TagValue: variant; LocalPath: string; Error: Exception);
TQTXFindDeviceCB = procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception);
TQTXGetDisksCB = procedure (TagValue: variant; Devices: JDeviceList; Error: Exception);
TQTXGetFileInfoCB = procedure (TagValue: variant; LocalName: string; Info: JStats; Error: Exception);
TQTXGetTranslatePathCB = procedure (TagValue: variant; Original, Translated: string; Error: Exception);
TQTXCheckDevicePathCB = procedure (TagValue: variant; PathName: string; Error: Exception);
TQTXServerExecuteCB = procedure (TagValue: variant; Data: string; Error: Exception);
TQTXTaskService = class(TRagnarokService)
private
FPrefs: TQTXIniFile;
FLog: TQTXLogEmitter;
FDatabase: TSQLite3Database;
FZConfig: TQTXZConfigClient;
FRegHandle: TQTXDispatchHandle;
FRegCount: integer;
procedure HandleGetDevices(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleGetDeviceByName(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleCreateLocalDevice(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleDestroyDevice(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileRead(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileReadPartial(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleGetFileInfo(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileDelete(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileWrite(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileWritePartial(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileRename(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleGetDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleMkDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleRmDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure ExecuteExternalJS(Params: array of string;
TagValue: variant; const CB: TQTXServerExecuteCB);
procedure SendError(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage; Message: string);
protected
function GetFactory: TMessageFactory; override;
procedure SetupPreferences(const CB: TRagnarokServiceCB);
procedure SetupLogfile(LogFileName: string;const CB: TRagnarokServiceCB);
procedure SetupDatabase(const CB: TRagnarokServiceCB);
procedure ValidateLocalDiskName(TagValue: variant; Username, DeviceName: string; CB: TQTXCheckDevicePathCB);
procedure RegisterLocalDevice(TagValue: variant; Username, DiskName: string; CB: TQTXRegisterLocalDeviceCB);
procedure UnRegisterLocalDevice(TagValue: variant; UserName, DiskName:string; CB: TQTXUnRegisterLocalDeviceCB);
procedure GetDevicesForUser(TagValue: variant; UserName: string; CB: TQTXGetDisksCB);
procedure FindDeviceByName(TagValue: variant; UserName, DiskName: string; CB: TQTXFindDeviceCB);
procedure FindDeviceByType(TagValue: variant; UserName: string; &Type: JDeviceType; CB: TQTXGetDisksCB);
procedure GetTranslatedPathFor(TagValue: variant; Username, FullPath: string; CB: TQTXGetTranslatePathCB);
procedure GetFileInfo(TagValue: variant; UserName: string; FullPath: string; CB: TQTXGetFileInfoCB);
procedure SetupTaskTable(const TagValue: variant; const CB: TRagnarokServiceCB);
procedure SetupOperationsTable(const TagValue: variant; const CB: TRagnarokServiceCB);
procedure SetupDeviceTable(const TagValue: variant; const CB: TRagnarokServiceCB);
procedure AfterServerStarted; override;
procedure BeforeServerStopped; override;
procedure Dispatch(Socket: TNJWebSocketSocket; Message: TQTXBaseMessage); override;
public
property Preferences: TQTXIniFile read FPrefs;
property Database: TSQLite3Database read FDatabase;
procedure SetupService(const CB: TRagnarokServiceCB);
constructor Create; override;
destructor Destroy; override;
end;
implementation
//#############################################################################
// TQTXFileenticationFactory
//#############################################################################
procedure TQTXTaskServiceFactory.RegisterIntrinsic;
begin
writeln("Registering task interface");
&Register(TQTXFileGetDeviceListRequest);
&Register(TQTXFileGetDeviceByNameRequest);
&Register(TQTXFileCreateLocalDeviceRequest);
&Register(TQTXFileDestroyDeviceRequest);
&Register(TQTXFileReadPartialRequest);
&Register(TQTXFileReadRequest);
&Register(TQTXFileWritePartialRequest);
&Register(TQTXFileWriteRequest);
&Register(TQTXFileDeleteRequest);
&Register(TQTXFileRenameRequest);
&Register(TQTXFileInfoRequest);
&Register(TQTXFileDirRequest);
&Register(TQTXMkDirRequest);
&Register(TQTXRmDirRequest);
&Register(TQTXFileRenameRequest);
&Register(TQTXFileDirRequest);
end;
//#############################################################################
// TQTXTaskService
//#############################################################################
constructor TQTXTaskService.Create;
begin
inherited Create;
FPrefs := TQTXIniFile.Create();
FLog := TQTXLogEmitter.Create();
FDatabase := TSQLite3Database.Create(nil);
FZConfig := TQTXZConfigClient.Create();
FZConfig.Port := 2292;
self.OnUserSignedOff := procedure (Sender: TObject; Username: string)
begin
WriteToLogF("We got a service signal! User [%s] has signed off completely", [Username]);
end;
MessageDispatch.RegisterMessage(TQTXFileGetDeviceListRequest, @HandleGetDevices);
MessageDispatch.RegisterMessage(TQTXFileGetDeviceByNameRequest, @HandleGetDeviceByName);
MessageDispatch.RegisterMessage(TQTXFileCreateLocalDeviceRequest, @HandleCreateLocalDevice);
MessageDispatch.RegisterMessage(TQTXFileDestroyDeviceRequest, @HandleDestroyDevice);
MessageDispatch.RegisterMessage(TQTXFileReadRequest, @HandleFileRead);
MessageDispatch.RegisterMessage(TQTXFileReadPartialRequest, @HandleFileReadPartial);
MessageDispatch.RegisterMessage(TQTXFileWriteRequest, @HandleFileWrite);
MessageDispatch.RegisterMessage(TQTXFileWritePartialRequest, @HandleFileWritePartial);
MessageDispatch.RegisterMessage(TQTXFileInfoRequest, @HandleGetFileInfo);
MessageDispatch.RegisterMessage(TQTXFileDeleteRequest, @HandleFileDelete);
MessageDispatch.RegisterMessage(TQTXMkDirRequest, @HandleMkDir);
MessageDispatch.RegisterMessage(TQTXRmDirRequest, @HandleRmDir);
MessageDispatch.RegisterMessage(TQTXFileRenameRequest, @HandleFileRename);
MessageDispatch.RegisterMessage(TQTXFileDirRequest, @HandleGetDir);
end;
destructor TQTXTaskService.Destroy;
begin
// decouple logger from our instance
self.logging := nil;
// Release prefs + log
FPrefs.free;
FLog.free;
FZConfig.free;
inherited;
end;
procedure TQTXTaskService.SendError(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage; Message: string);
begin
var reply := TQTXErrorMessage.Create(request.ticket);
try
reply.Code := CNT_MESSAGE_CODE_ERROR;
reply.Routing.TagValue := Request.Routing.TagValue;
reply.Response := Message;
if Socket.ReadyState = rsOpen then
begin
try
Socket.Send( reply.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end else
WriteToLog("Failed to dispatch error, socket is closed error");
finally
reply.free;
end;
end;
procedure TQTXTaskService.ExecuteExternalJS(Params: array of string;
TagValue: variant; const CB: TQTXServerExecuteCB);
begin
var LTask: JChildProcess;
var lOpts := TVariant.CreateObject();
lOpts.shell := false;
lOpts.detached := true;
Params.insert(0, '--no-warnings');
// Spawn a new process, this creates a new shell interface
try
LTask := child_process().spawn('node', Params, lOpts );
except
on e: exception do
begin
if assigned(CB) then
CB(TagValue, e.message, e);
exit;
end;
end;
// Map general errors on process level
LTask.on('error', procedure (error: variant)
begin
{$IFDEF DEBUG}
writeln("error->" + error.toString());
{$ENDIF}
WriteToLog(error.toString());
if assigned(CB) then
CB(TagValue, "", nil);
end);
// map stdout so we capture the output
LTask.stdout.on('data', procedure (data: variant)
begin
if assigned(CB) then
CB(TagValue, data.toString(), nil);
end);
// map stderr so we can capture exception messages
LTask.stderr.on('data', procedure (error:variant)
begin
{$IFDEF DEBUG}
writeln("stdErr->" + error.toString());
{$ENDIF}
if assigned(CB) then
CB(TagValue, "", nil);
WriteToLog(error.toString());
end);
end;
function TQTXTaskService.GetFactory: TMessageFactory;
begin
result := TQTXTaskServiceFactory.Create();
end;
procedure TQTXTaskService.SetupService(const CB: TRagnarokServiceCB);
begin
SetupPreferences( procedure (Error: Exception)
begin
// No logfile yet setup (!)
if Error nil then
begin
WriteToLog("Preferences setup: Failed!");
WriteToLog(error.message);
raise error;
end else
WriteToLog("Preferences setup: OK");
// logfile-name is always relative to the executable
var LLogFileName := TQTXNodeFileUtils.IncludeTrailingPathDelimiter( TQTXNodeFileUtils.GetCurrentDirectory );
LLogFileName += FPrefs.ReadString('log', 'logfile', 'log.txt');
// Port is defined in the ancestor, so we assigns it here
Port := FPrefs.ReadInteger('networking', 'port', CNT_PREFS_DEFAULTPORT);
SetupLogfile(LLogFileName, procedure (Error: Exception)
begin
if Error nil then
begin
WriteToLog("Logfile setup: Failed!");
WriteToLog(error.message);
raise error;
end else
WriteToLog("Logfile setup: OK");
SetupDatabase( procedure (Error: Exception)
begin
if Error nil then
begin
WriteToLog("Database setup: Failed!");
WriteToLog(error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
end else
WriteToLog("Database setup: OK");
if assigned(CB) then
CB(nil);
end);
end);
end);
end;
procedure TQTXTaskService.SetupPreferences(const CB: TRagnarokServiceCB);
begin
var lBasePath := TQTXNodeFileUtils.GetCurrentDirectory;
var LPrefsFile := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(LBasePath) + CNT_PREFS_FILENAME;
if TQTXNodeFileUtils.FileExists(LPrefsFile) then
begin
FPrefs.LoadFromFile(nil, LPrefsFile, procedure (TagValue: variant; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end;
if assigned(CB) then
CB(nil);
end);
end else
begin
var LError := Exception.Create('Could not locate preferences file: ' + LPrefsFile);
WriteToLog(LError.message);
if assigned(CB) then
CB(LError)
else
raise LError;
end;
end;
procedure TQTXTaskService.SetupLogfile(LogFileName: string;const CB: TRagnarokServiceCB);
begin
// Attempt to open logfile
// Note: Log-object error options is set to throw exceptions
try
FLog.Open(LogFileName);
except
on e: exception do
begin
if assigned(CB) then
begin
CB(e);
exit;
end else
begin
writeln(e.message);
raise;
end;
end;
end;
// We inherit from TQTXLogObject, which means we can pipe
// all errors etc directly using built-in functions. So here
// we simply glue our instance to the log-file, and its all good
self.Logging := FLog as IQTXLogClient;
if assigned(CB) then
CB(nil);
end;
procedure TQTXTaskService.FindDeviceByType(TagValue: variant; UserName: string; &Type: JDeviceType; CB: TQTXGetDisksCB);
begin
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
WriteToLog("Failed to lookup disk, username was invalid error");
var lError := EException.Create("Failed to lookup devices, invalid username");
if assigned(CB) then
CB(TagValue, nil, lError)
else
raise lError;
exit;
end;
GetDevicesForUser(TagValue, Username,
procedure (TagValue: variant; Devices: JDeviceList; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, nil, Error)
else
raise Error;
exit;
end;
var x := 0;
while x < Devices.dlDrives.Count do
begin
if Devices.dlDrives[x].&Type &Type then
begin
Devices.dlDrives.delete(x, 1);
continue;
end;
inc(x);
end;
if assigned(CB) then
CB(TagValue, Devices, nil);
end);
end;
procedure TQTXTaskService.FindDeviceByName(TagValue: variant; Username, DiskName: string; CB: TQTXFindDeviceCB);
begin
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
var lLogText := "Failed to lookup device, username was invalid error";
WriteToLog(lLogText);
var lError := EException.Create(lLogText);
if assigned(CB) then
CB(TagValue, nil, lError)
else
raise lError;
exit;
end;
DiskName := DiskName.trim();
if DiskName.length < 1 then
begin
var lLogText := "Failed to lookup device, disk-name was invalid error";
WriteToLog(lLogText);
var lError := EException.Create(lLogText);
if assigned(CB) then
CB(TagValue, nil, lError)
else
raise lError;
exit;
end;
GetDevicesForUser(TagValue, Username,
procedure (TagValue: variant; Devices: JDeviceList; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, nil, Error)
else
raise Error;
exit;
end;
DiskName := DiskName.trim().ToLower();
var lDiskInfo: JDeviceInfo := nil;
for var disk in Devices.dlDrives do
begin
if disk.Name.ToLower() = DiskName then
begin
lDiskInfo := disk;
break;
end;
end;
if assigned(CB) then
CB(TagValue, lDiskInfo, nil);
end);
end;
procedure TQTXTaskService.GetTranslatedPathFor(TagValue: variant; Username, FullPath: string; CB: TQTXGetTranslatePathCB);
begin
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(FullPath, lInfo) then
begin
// Locate the device for the path belonging to the user
FindDeviceByName(TagValue, UserName, lInfo.MountPart,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, FullPath, '', Error)
else
raise Error;
exit;
end;
if Device.&Type dtLocal then
begin
var lError := EException.CreateFmt('Failed to translate path, device [%s] is not local error', [Device.Name]);
if assigned(CB) then
CB(TagValue, FullPath, '', Error)
else
raise Error;
exit;
end;
// We want the path + filename, so we can append that to
// the actual localized filesystem
var lExtract := FullPath;
delete(lExtract, 1, lInfo.MountPart.Length + 1);
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + lExtract;
// Return translated path
if assigned(CB) then
CB(TagValue, FullPath, lFullPath, nil);
end);
end else
begin
var lErr := EException.CreateFmt("Invalid path [%s] error", [FullPath]);
if assigned(CB) then
CB(TagValue, FullPath, '', lErr)
else
raise lErr;
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.GetFileInfo(TagValue: variant; UserName, FullPath: string; CB: TQTXGetFileInfoCB);
begin
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(FullPath, lInfo) then
begin
// Locate the device for the path belonging to the user
FindDeviceByName(TagValue, UserName, lInfo.MountPart,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, '', nil, Error)
else
raise Error;
exit;
end;
case Device.&Type of
dtLocal:
begin
// We want the path + filename, so we can append that to
// the actual localized filesystem
var lExtract := FullPath;
delete(lExtract, 1, lInfo.MountPart.Length + 1);
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + lExtract;
// Call the underlying OS to get the file statistics
NodeJsFsAPI().lStat(lFullPath,
procedure (Error: JError; Stats: JStats)
begin
if Error nil then
begin
var lError := EException.Create(Error.message);
if assigned(CB) then
CB(TagValue, lFullPath, nil, lError)
else
raise lError;
exit;
end;
// And deliver
if assigned(CB) then
CB(TagValue, lFullPath, Stats, nil);
end);
end;
dtDropbox, dtGoogle, dtMsDrive:
begin
var lError := EException.Create("Cloud bindings not activated error");
if assigned(CB) then
CB(TagValue, '', nil, lError)
end;
end;
end);
end else
begin
var lErr := EException.CreateFmt("Invalid path [%s] error", [FullPath]);
if assigned(CB) then
CB(TagValue, '', nil, lErr)
else
raise lErr;
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.GetDevicesForUser(TagValue: variant; Username: string; CB: TQTXGetDisksCB);
begin
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
WriteToLog("Failed to lookup devices, username was invalid error");
var lError := EException.Create("Failed to lookup devices, invalid username");
if assigned(CB) then
CB(TagValue, nil, lError)
else
raise lError;
exit;
end;
var lTransaction: TQTXReadTransaction;
if not TSQLite3Database(DataBase).CreateReadTransaction(lTransaction) then
begin
var lErr := EException.Create("Failed to create read-transaction error");
if assigned(cb) then
CB(TagValue, nil, lErr)
else
raise lErr;
exit;
end;
var lQuery := TSQLite3ReadTransaction(lTransaction);
lQuery.SQL := "select * from devices where owner=?";
lQuery.Parameters.AddValueOnly(Username);
lQuery.Execute(
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, nil, Error)
else
raise Error;
exit;
end;
var lDisks := new JDeviceList();
lDisks.dlUser := UserName;
for var x := 0 to lQuery.datarows.length-1 do
begin
var lInfo := new JDeviceInfo();
lInfo.Name := lQuery.datarows[x]["name"];
lInfo.&Type := JDeviceType( lQuery.datarows[x]["type"] );
lInfo.owner := lQuery.datarows[x]["owner"];
lInfo.location := lQuery.datarows[x]["location"];
lInfo.APIKey := lQuery.datarows[x]["apikey"];
lInfo.APISecret := lQuery.datarows[x]["apisecret"];
lInfo.APIPassword := lQuery.datarows[x]["apipassword"];
lInfo.APIUser := lQuery.datarows[x]["apiuser"];
lDisks.dlDrives.add(lInfo);
end;
try
if assigned(CB) then
CB(TagValue, lDisks, nil);
finally
lQuery.free;
end;
end);
end;
procedure TQTXTaskService.ValidateLocalDiskName(TagValue: variant; Username, DeviceName: string; CB: TQTXCheckDevicePathCB);
begin
var Filename := 'disk.' + username + '.' + DeviceName + '.' + ord(JDeviceType.dtLocal).ToString();
var LBasePath := TQTXNodeFileUtils.GetCurrentDirectory();
LBasePath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(LBasePath) + 'userdevices';
// Make sure the device folder is there
if not TQTXNodeFileUtils.DirectoryExists(LBasePath) then
begin
var lError := EException.CreateFmt("Directory not found: %s", [lBasePath]);
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
lBasePath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(LBasePath) + Filename;
if TQTXNodeFileUtils.DirectoryExists(LBasePath) then
begin
var lError := EException.CreateFmt("Path already exist error [%s]", [lBasePath]);
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
// OK, folder is not created yet, so its good to go
if assigned(CB) then
CB(TagValue, Filename, nil);
end;
procedure TQTXTaskService.UnRegisterLocalDevice(TagValue: variant; UserName, DiskName: string; CB: TQTXUnRegisterLocalDeviceCB);
begin
WriteToLogF("Removing local device [%s] for user [%s] ", [DiskName, Username]);
// Check username string
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
WriteToLog("Failed to unregister device, username was invalid error");
var lError := EException.Create("Failed to register device, invalid username");
if assigned(CB) then
CB(TagValue, DiskName, lError)
else
raise lError;
exit;
end;
// Check diskname string
DiskName := DiskName.trim().ToLower();
if DiskName.length < 1 then
begin
WriteToLog("Failed to unregister device, disk-name was invalid error");
var lError := EException.Create("Failed to register device, invalid disk-name");
if assigned(CB) then
CB(TagValue, DiskName, lError)
else
raise lError;
exit;
end;
FindDeviceByName(TagValue, Username, DiskName,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
// Did the search fail?
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(TagValue, DiskName, Error)
else
raise Error;
exit;
end;
// Make sure the device is local
if Device.&Type dtLocal then
begin
var lError := EException.CreateFmt('Failed to translate path, device [%s] is not local error', [Device.Name]);
if assigned(CB) then
CB(TagValue, DiskName, Error)
else
raise Error;
exit;
end;
// Delete record from database
var lWriter: TQTXWriteTransaction;
if FDatabase.CreateWriteTransaction(lWriter) then
begin
lWriter.SQL := "delete from profiles where user = ? and name = ?;";
lWriter.Parameters.AddValueOnly(Username);
lWriter.Parameters.AddValueOnly(DiskName);
lWriter.Execute(
procedure (Sender: TObject; Error: Exception)
begin
try
if Error nil then
begin
if assigned(CB) then
CB(TagValue, DiskName, Error)
else
raise Error;
exit;
end;
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
// Now delete the disk-drive directory
TQTXNodeFileUtils.DeleteDirectory(nil, lFullPath,
procedure (TagValue: variant; Path: string; Error: Exception)
begin
if assigned(CB) then
CB(TagValue, DiskName, Error)
end);
finally
lWriter.free;
lWriter := nil;
end;
end);
end;
end);
end;
procedure TQTXTaskService.RegisterLocalDevice(TagValue: variant; Username, DiskName: string; CB: TQTXRegisterLocalDeviceCB);
begin
WriteToLogF("Adding local device [%s] for user [%s] ", [DiskName, Username]);
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
WriteToLog("Failed to register device, username was invalid error");
var lError := EException.Create("Failed to register device, invalid username");
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
DiskName := DiskName.trim().ToLower();
if DiskName.length < 1 then
begin
WriteToLog("Failed to register device, disk-name was invalid error");
var lError := EException.Create("Failed to register device, invalid disk-name");
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
FindDeviceByName(TagValue, Username, DiskName,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
// Did the search fail?
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(TagValue, '', Error)
else
raise Error;
exit;
end;
// Does a device that match already exist?
if Device nil then
begin
var lError := EException.CreateFmt("Failed to create device [%s], device already exists", [DiskName]);
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
// make sure the device-folder does not exist, so we can create it
ValidateLocalDiskName(TagValue, Username, DiskName,
procedure (TagValue: variant; PathName: string; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, '', Error)
else
raise Error;
exit;
end;
// ValidateLocalDiskName only returns the valid directory-name,
// not a full path -- so we need to build up the full targetpath
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + PathName;
TQTXNodeFileUtils.CreateDirectory(nil, lFullPath,
procedure (TagValue: variant; Path: string; Error: exception)
begin
if Error nil then
begin
var lError := EException.CreateFmt("Failed to create device [%s] with path: %s", [DiskName, lFullPath]);
if assigned(CB) then
CB(TagValue, PathName, lError)
else
raise lError;
exit;
end;
FDatabase.Execute(
#'insert into devices (type, owner, name, location)
values(?, ?, ?, ?);',
[ord(JDeviceType.dtLocal), UserName, Diskname, PathName] ,
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(TagValue, PathName, Error)
else
raise Error;
exit;
end;
WriteToLogF("Device [%s] added to database user [%s]", [DiskName, UserName]);
if assigned(CB) then
CB(TagValue, PathName, nil);
end);
end);
end);
end);
end;
procedure TQTXTaskService.SetupDeviceTable(const TagValue: variant; const CB: TRagnarokServiceCB);
begin
FDatabase.Execute(
#'
create table if not exists devices
(
id integer primary key AUTOINCREMENT,
type integer,
owner text,
name text,
location text,
apikey text,
apisecret text,
apipassword text,
apiuser text
);
', [],
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end else
if assigned(CB) then
CB(nil);
end);
end;
procedure TQTXTaskService.SetupTaskTable(const TagValue: variant; const CB: TRagnarokServiceCB);
begin
FDatabase.Execute(
#'
create table if not exists tasks
(
id integer primary key AUTOINCREMENT,
state integer,
username text,
created real
);
', [],
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end else
if assigned(CB) then
CB(nil);
end);
end;
procedure TQTXTaskService.SetupOperationsTable(const TagValue: variant; const CB: TRagnarokServiceCB);
begin
FDatabase.Execute(
#'
create table if not exists operations
(
id integer primary key AUTOINCREMENT,
username text,
taskid integer,
name text,
filename text
);
', [],
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end else
if assigned(CB) then
CB(nil);
end);
end;
procedure TQTXTaskService.SetupDatabase(const CB: TRagnarokServiceCB);
begin
// Try to read database-path from preferences file
var LDbFileToOpen := FPrefs.ReadString("database", "database_name", "");
// Trim away spaces, check if there is a filename
LDbFileToOpen := LDbFileToOpen.trim();
if LDbFileToOpen.length < 1 then
begin
// No filename? Fall back on pre-defined file in CWD
var LBasePath := TQTXNodeFileUtils.GetCurrentDirectory();
LDbFileToOpen := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(LBasePath) + CNT_PREFS_DBNAME;
end;
FDatabase.AccessMode := TSQLite3AccessMode.sqaReadWriteCreate;
FDatabase.Open(LDbFileToOpen,
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end;
WriteToLog("Initializing task table");
SetupTaskTable(nil, procedure (Error: exception)
begin
if Error nil then
begin
WriteToLog("Tasks initialized: **failed");
WriteToLog(error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end else
writeToLog("Tasks initialized: OK");
WriteToLog("Initializing operations table");
SetupOperationsTable(nil, procedure (Error: exception)
begin
if Error nil then
begin
WriteToLog("Operations initialized: **failed");
WriteToLog(error.message);
if assigned(CB) then
CB(Error);
exit;
end else
writeToLog("Operations initialized: OK");
WriteToLog("Initializing device table");
SetupDeviceTable(nil, procedure (Error: exception)
begin
if Error nil then
begin
WriteToLog("Device-table initialized: **failed");
WriteToLog(error.message);
if assigned(CB) then
CB(Error);
exit;
end else
writeToLog("Device-table initialized: OK");
if assigned(CB) then
CB(nil);
end);
end);
end);
end);
end;
procedure TQTXTaskService.HandleFileRead(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileReadRequest(request);
var lUserName := lRequest.UserName;
var lFileName := lRequest.FileName;
// Check filename length
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lOptions: TReadFileOptions;
lOptions.encoding := 'binary';
NodeJsFsAPI().readFile(LocalFile, lOptions,
procedure (Error: JError; Data: JNodeBuffer)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileReadResponse.Create(Request.Ticket);
lResponse.UserName := lUserName;
lResponse.Routing.TagValue := request.routing.tagValue;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
// Convert filedata in one pass
try
var lConvert := TDataTypeConverter.Create();
try
lResponse.Attachment.AppendBytes( lConvert.TypedArrayToBytes(Data) );
finally
lConvert.free;
end;
except
on e: exception do
begin
WriteToLog(e.message);
SendError(Socket, Request, e.Message);
exit;
end;
end;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end;
procedure TQTXTaskService.HandleFileReadPartial(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileReadPartialRequest(request);
var lUserName := lRequest.UserName;
var lFileName := lRequest.FileName;
var lStart := lRequest.Offset;
var lSize := lRequest.Size;
// Check filename length
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
if lSize < 1 then
begin
SendError(Socket, Request, "Read failed, invalid size error");
exit;
end;
if lStart < 0 then
begin
SendError(Socket, Request, "Read failed, invalid offset error");
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
if lStart > Info.size then
begin
SendError(Socket, Request, "Read failed, offset beyond filesize error");
exit;
end;
NodeJsFsAPI().open(LocalFile, "r",
procedure (Error: JError; Fd: THandle)
begin
if error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
var Data = new JNodeBuffer(lSize);
NodeJsFsAPI().read(Fd, Data, 0, lSize, lStart,
procedure (Error: JError; BytesRead: integer; buffer: JNodeBuffer)
begin
if Error nil then
begin
NodeJsFsAPI().closeSync(Fd);
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Close the file-handle and return data
NodeJsFsAPI().close(Fd, procedure (Error: JError)
begin
var lResponse := TQTXFileReadPartialResponse.Create(Request.Ticket);
lResponse.UserName := lUserName;
lResponse.Routing.TagValue := request.routing.tagValue;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
// Only encode data if read
if BytesRead > 0 then
begin
// Convert filedata in one pass
try
var lConvert := TDataTypeConverter.Create();
try
lResponse.Attachment.AppendBytes( lConvert.TypedArrayToBytes(buffer) );
finally
lConvert.free;
end;
except
on e: exception do
begin
WriteToLog(e.message);
SendError(Socket, Request, e.Message);
exit;
end;
end;
end;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end);
end);
end;
procedure TQTXTaskService.HandleFileWrite(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileWriteRequest(request);
var lFileName := lRequest.FileName.trim();
var lUserName := lRequest.UserName.trim();
var FullPath := lFileName;
// Check filename length
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(FullPath, lInfo) then
begin
// Locate the device for the path belonging to the user
FindDeviceByName(nil, lUserName, lInfo.MountPart,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
case Device.&Type of
dtLocal:
begin
// We want the path + filename, so we can append that to
// the actual localized filesystem
var lExtract := FullPath;
delete(lExtract, 1, lInfo.MountPart.Length + 1);
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + lExtract;
// Extract data to be appended, if any
// note: null bytes should be allowed, it should just create the file
var lBytes: array of UInt8;
if lRequest.attachment.Size > 0 then
lBytes := lRequest.Attachment.ToBytes();
// Write the data to the file
NodeJsFsAPI().writeFile(lFullPath, lBytes,
procedure (Error: JError)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Setup response object
var lResponse := TQTXFileWriteResponse.Create(lRequest.Ticket);
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
// Send success response
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end;
dtDropbox, dtGoogle, dtMsDrive:
begin
var lErrorText := Format("Clound bindings not active error [%s]", [lRequest.FileName]);
WriteToLog(lErrorText);
SendError(Socket, Request, lErrorText);
end;
end;
end);
end else
begin
SendError(Socket, Request, format("Invalid path [%s] error", [FullPath]));
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.HandleFileWritePartial(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileWritePartialRequest(request);
var lFileName := lRequest.FileName.trim();
var lUserName := lRequest.UserName.trim();
var lFileOffset := lRequest.Offset;
// Check filename length
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
var FullPath := lFileName;
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(FullPath, lInfo) then
begin
// Locate the device for the path belonging to the user
FindDeviceByName(nil, lUserName, lInfo.MountPart,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
case Device.&Type of
dtLocal:
begin
// We want the path + filename, so we can append that to
// the actual localized filesystem
var lExtract := FullPath;
delete(lExtract, 1, lInfo.MountPart.Length + 1);
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + lExtract;
// Extract data to be appended, if any
// note: null bytes should be allowed, it should just create the file
var lBytes: array of UInt8;
if lRequest.attachment.Size > 0 then
lBytes := lRequest.Attachment.ToBytes();
var lAccess := TQTXNodeFile.Create();
lAccess.Open(lFullPath, TQTXNodeFileMode.nfWrite,
procedure (Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
lAccess.Write(lBytes, lFileOffset,
procedure (Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Setup response object
var lResponse := TQTXFileWriteResponse.Create(lRequest.Ticket);
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
// Send success response
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end;
dtDropbox, dtGoogle, dtMsDrive:
begin
var lErrorText := Format("Clound bindings not active error [%s]", [lRequest.FileName]);
WriteToLog(lErrorText);
SendError(Socket, Request, lErrorText);
end;
end;
end);
end else
begin
SendError(Socket, Request, format("Invalid path [%s] error", [FullPath]));
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.HandleRmDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXRmDirRequest(request);
var lUserName := lRequest.UserName.trim();
var lDirPath := lRequest.DirPath.trim();
if lDirPath.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lDirPath) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lParser.Parse(lDirPath, lInfo) then
begin
GetTranslatedPathFor(nil, lUserName, lDirPath,
procedure (TagValue: variant; Original, Translated: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
if not TQTXNodeFileUtils.DirectoryExists(Translated) then
begin
WriteToLogF("RmDir Failed, directory [%s] does not exist", [Translated]);
SendError(Socket, Request, Format("RmDir failed, directory [%s] does not exist", [Original]));
exit;
end;
TQTXNodeFileUtils.DeleteDirectory(nil, Translated,
procedure (TagValue: variant; Path: string; Error: Exception)
begin
if error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Setup response object
var lResponse := TQTXRmDirResponse.Create(lRequest.Ticket);
lResponse.UserName := lUserName;
lResponse.DirPath := lDirPath;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
lResponse.Routing.TagValue := lRequest.Routing.TagValue;
// Send success response
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end else
begin
var lText := format("RmDir failed, invalid path [%s] error", [lDirPath]);
WriteToLog(lText);
SendError(Socket, Request, lText);
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.HandleMkDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXMkDirRequest(request);
var lUserName := lRequest.UserName.trim();
var lDirPath := lRequest.DirPath.trim();
if lDirPath.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lDirPath) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(lDirPath, lInfo) then
begin
GetTranslatedPathFor(nil, lUserName, lDirPath,
procedure (TagValue: variant; Original, Translated: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
TQTXNodeFileUtils.DirectoryExists(nil, Translated,
procedure (TagValue: variant; Path: string; Error: Exception)
begin
if Error nil then
begin
WriteToLogF("MkDir Failed, directory [%s] already exists", [Translated]);
SendError(Socket, Request, Format("MkDir Failed, directory [%s] already exists", [Original]));
exit;
end;
TQTXNodeFileUtils.CreateDirectory(nil, Translated,
procedure (TagValue: variant; Path: string; Error: Exception)
begin
if Error nil then
begin
WriteToLogF("MkDir Failed, directory [%s] could not be created", [Original]);
SendError(Socket, Request, Format("MkDir Failed, directory [%s] could not be created", [Translated]));
exit;
end;
// Setup response object
var lResponse := TQTXMkDirResponse.Create(lRequest.Ticket);
lResponse.UserName := lUserName;
lResponse.DirPath := lDirPath;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
lResponse.Routing.TagValue := lRequest.Routing.TagValue;
// Send success response
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end);
end else
begin
var lText := format("MkDir Failed, invalid path [%s] error", [lDirPath]);
WriteToLog(lText);
SendError(Socket, Request, lText);
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.HandleFileDelete(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileDeleteRequest(Request);
var lUserName := lRequest.UserName.trim();
var lFileName := lRequest.FileName.trim();
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
if not Info.isFile then
begin
SendError(Socket, Request, "Filesystem object is not a file error");
exit;
end;
NodeJsFsAPI().unlink(LocalFile,
procedure (Error: JError)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.message);
exit;
end;
var lResponse := new TQTXFileDeleteResponse(lRequest.Ticket);
lResponse.Routing.TagValue := request.Routing.TagValue;
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end;
procedure TQTXTaskService.HandleFileRename(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileRenameRequest(Request);
var lUserName := lRequest.UserName.trim();
var lFileName := lRequest.FileName.trim();
var lNewName := lRequest.NewName.trim();
// Check filename length
if lFileName.length < 1 then
begin
SendError(Socket, Request, Format("Invalid or empty from-filename [%s] error", [lFileName]) );
exit;
end;
// check newname length
if lNewName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
if pos(lTemp, lNewName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
if pos(lTemp, lNewName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
if not Info.isFile then
begin
SendError(Socket, Request, "Filesystem object is not a file error");
exit;
end;
GetTranslatedPathFor(nil, lUsername, lNewName,
procedure (TagValue: variant; Original, Translated: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
NodeJsFsAPI().rename(LocalFile, Translated,
procedure (Error: JError)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.message);
exit;
end;
var lResponse := new TQTXFileRenameResponse(lRequest.Ticket);
lResponse.Routing.TagValue := request.Routing.TagValue;
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end);
end;
procedure TQTXTaskService.HandleGetDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileDirRequest(Request);
var lUserName := lRequest.UserName.trim();
var lPath := lRequest.Path.trim();
// prevent path escape attempts
var lTemp := "../";
if pos(lTemp, lPath) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lPath) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetTranslatedPathFor(nil, lUserName, lPath,
procedure (TagValue: variant; Original, Translated: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
//writeln("Translated path is:" + Translated);
if not TQTXNodeFileUtils.DirectoryExists(Translated) then
begin
WriteToLogF("GetDir Failed, directory [%s] does not exist", [Translated]);
SendError(Socket, Request, Format("GetDir failed, directory [%s] does not exist", [Original]));
exit;
end;
var lWalker := TQTXFileWalker.Create();
lWalker.Examine(Translated, procedure (Sender: TQTXFileWalker; Error: EException)
begin
if Error nil then
begin
WriteToLogF("GetDir Failed: %s", [Error.Message]);
SendError(Socket, Request, Format("GetDir failed: %s", [Error.Message]));
exit;
end;
// Get the directory data, swap out the path
// record with the original [amiga] style path
var lData := Sender.ExtractList();
lData.dlPath := Original;
var lResponse := new TQTXFileDirResponse(lRequest.Ticket);
lResponse.Routing.TagValue := request.Routing.TagValue;
lResponse.UserName := lUserName;
lResponse.Path := lPath;
lResponse.Assign( lData );
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
// release instance in 100ms
TQTXDispatch.execute(procedure ()
begin
try
lWalker.free
except
on e: exception do
begin
WriteToLogF("Failed to release file-walker instance: %s", [e.message]);
end;
end;
end, 100);
end);
end);
end;
procedure TQTXTaskService.HandleGetFileInfo(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileInfoRequest(Request);
var lUserName := lRequest.UserName.trim();
var lFileName := lRequest.FileName.trim();
// prevent path escape attempts
var lTemp := "../";
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Collect the data
var lData := new JFileItem();
lData.diFileName := lFileName;
lData.diFileType := if Info.isFile then JFileItemType.wtFile else JFileItemType.wtFolder;
lData.diFileSize := Info.size;
lData.diFileMode := IntToStr(Info.mode);
lData.diCreated := TDateUtils.FromJsDate( Info.cTime );
lData.diModified := TDateUtils.FromJsDate( Info.mTime );
var lResponse := new TQTXFileInfoResponse(lRequest.Ticket);
lResponse.Routing.TagValue := request.Routing.TagValue;
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Assign(lData);
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end;
procedure TQTXTaskService.HandleDestroyDevice(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lMessage := TQTXFileDestroyDeviceRequest(request);
// This will also destroy any files + unregister the device in the
// database table for the service -- do not mess with this!
UnRegisterLocalDevice(nil, lMessage.Username, lMessage.DeviceName,
procedure (TagValue: variant; LocalPath: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileDestroyDeviceResponse.Create(request.ticket);
lResponse.UserName := lMessage.UserName;
lResponse.DeviceName := lMessage.DeviceName;
lResponse.Routing.TagValue := Request.Routing.TagValue;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
begin
WriteToLog(e.message);
end;
end;
end);
end;
procedure TQTXTaskService.HandleCreateLocalDevice(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lMessage := TQTXFileCreateLocalDeviceRequest(request);
// Attempt to register.
// NOTE: This will automatically create a matching folder
// under $cwd/userdevices/[calculated_name_of_device]
RegisterLocalDevice(nil, lMessage.Username, lMessage.DeviceName,
procedure (TagValue: variant; LocalPath: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
FindDeviceByName(nil, lMessage.Username, lMessage.DeviceName,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileCreateLocalDeviceResponse.Create(request.ticket);
lResponse.UserName := lMessage.UserName;
lResponse.Routing.TagValue := Request.Routing.TagValue;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
if Device nil then
lResponse.assign(Device);
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
begin
WriteToLog(e.message);
end;
end;
end);
end);
end;
procedure TQTXTaskService.HandleGetDeviceByName(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lMessage := TQTXFileGetDeviceByNameRequest(request);
FindDeviceByName(nil, lMessage.Username, lMessage.DeviceName,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileGetDeviceByNameResponse.Create(request.ticket);
lResponse.UserName := lMessage.UserName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
if Device nil then
lResponse.assign(Device);
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
begin
WriteToLog(e.message);
end;
end;
end);
end;
procedure TQTXTaskService.HandleGetDevices(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lMessage := TQTXFileGetDeviceListRequest(Request);
GetDevicesForUser(nil, lMessage.Username,
procedure (TagValue: variant; Devices: JDeviceList; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileGetDeviceListResponse.Create(request.ticket);
lResponse.UserName := lMessage.UserName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
if Devices nil then
lResponse.assign(Devices);
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
begin
WriteToLog(e.message);
end;
end;
end);
end;
procedure TQTXTaskService.AfterServerStarted;
begin
inherited;
// Check prefs if zconfig should be applied
if self.FPrefs.ReadBoolean("zconfig", "active", false) then
begin
// ZConfig should only run on the master instance.
// We dont want to register our endpoint for each worker
if NodeJSClusterAPI().isWorker then
exit;
writeln("Setting up Zero-Configuration layer");
FZConfig.port := FPrefs.ReadInteger('zconfig', 'bindport', 2109);
FZConfig.address := GetMachineIP();
FZConfig.Start(nil, procedure (Sender: TObject; TagValue: variant; Error: Exception)
begin
if FPrefs.ReadBoolean("zconfig", "broadcast", true) then
FZConfig.Socket.setBroadcast(true);
// Build up the endpoint (URL) for our websocket server
var lEndpoint := '';
if FPrefs.ReadBoolean('networking', 'secure', false) then
lEndpoint := 'wss://'
else
lEndpoint := 'ws://';
lEndpoint += GetMachineIP();
lEndpoint += ':' + Port.ToString();
// Ping the ZConfig service on interval, until our service is registered
// We keep track of the interval handle so we can stop calling on interval later
FRegHandle := TQTXDispatch.SetInterval( procedure ()
begin
inc(FRegCount);
// Only output once to avoid overkill in the log
if FRegCount = 1 then
WriteToLogF("ZConfig registration begins [%s]", [lEndpoint]);
FZConfig.RegisterService(nil, CNT_ZCONFIG_SERVICE_NAME, SERVICE_ID_TASKMANAGER, lEndpoint,
procedure (TagValue: variant; Error: Exception)
begin
if Error = nil then
begin
WriteToLog("Service registered");
TQTXDispatch.ClearInterval(FRegHandle);
FRegCount := 0;
exit;
end;
end);
end, 1000);
end);
end;
end;
procedure TQTXTaskService.BeforeServerStopped;
begin
inherited;
end;
procedure TQTXTaskService.Dispatch(Socket: TNJWebSocketSocket; Message: TQTXBaseMessage);
begin
var LInfo := MessageDispatch.GetMessageInfoForClass(Message);
if LInfo nil then
begin
try
LInfo.MessageHandler(Socket, Message);
except
on e: exception do
begin
//Log error
WriteToLog(e.message);
end;
end;
end;
end;
end.
Nodebuilder, QTX and the release of my brand new social platform
First, let me wish everyone a wonderful new year! With xmas and the silly season firmly behind us, and my batteries recharged – I feel my coding fingers itch to get started again.
2019 was a very busy year for me. Exhausting even. I have juggled both a full time job, kids and family, as well as our community project, Quartex Media Desktop. And since that project has grown considerably, I had to stop and work on the tooling. Which is what NodeBuilder is all about.
I have also released my own social media platform (see further down). This was initially scheduled for Q4 2020, but Facebook pissed me off something insanely, so I set it up in december instead.
NodeBuilder
For those of you that read my blog you probably remember the message system I made for the Quartex Desktop, called Ragnarok? This is a system for dealing with message dispatching and RPC, except that the handling is decoupled from the transport medium. In other words, it doesnt care how you deliver a message (WebSocket, UDP, REST), but rather takes care of serialization, binary data and security.
All the back-end services that make up the desktop system, are constructed around Ragnarok. So each service exposes a set of methods that the core can call, much like a normal RPC / SOAP service would. Each method is represented by a request and response object, which Ragnarok serialize to a JSON message envelope.
In our current model I use WebSocket, which is a full duplex, long-term connection (to avoid overhead of having to connect and perform a handshake for each call). But there is nothing in the way of implementing a REST transport layer (UDP is already supported, it’s used by the Zero-Config system. The services automatically find each other and register, as long as they are connected to the same router or switch). For the public service I think REST makes more sense, since it will better utilize the software clustering that node.js offers.
Node Builder is a relatively simple service designer, but highly effective for our needs
Now for small services that expose just a handful of methods (like our chat service), writing the message classes manually is not really a problem. But the moment you start having 20 or 30 methods – and need to implement up to 60 message classes manually – this approach quickly becomes unmanageable and prone to errors. So I simply had to stop before xmas and work on our service designer. That way we can generate the boilerplate code in seconds rather than days and weeks.
While I dont have time to evolve this software beyond that of a simple service designer (well, I kinda did already), I have no problem seeing this system as a beginning of a wonderful, universal service authoring system. One that includes coding, libraries and the full scope of the QTX runtime-library.
In fact, most of the needed parts are in the codebase already, but not everything has been activated. I don’t have time to build both a native development system AND the development system for the desktop.
NodeBuilder already have a fully functional form designer and code editor, but it is dormant for now due to time restrictions. Quartex Media Desktop comes first
But right now, we have bigger fish to fry.
Quartex Media Desktop
We have made tremendous progress on our universal desktop environment, to the point where the baseline services are very close to completion. A month should be enough to finish this unless something unforeseen comes up.
Quartex Media Desktop provides an ecosystem for advanced web applications
You have to factor in that, this project has only had weekends and the odd after work hours allocated for it. So even though we have been developing this for 12 months, the actual amount of days is roughly half of that.
So all things considered I think we have done a massive amount of code in such a short time. Even simple 2d games usually take 2 years of daily development, and that includes a team of at least 5 people! Im a single developer working in my spare time.
So what exactly is left?
The last thing we did before xmas was upon us, was to throw out the last remnants of Smart Mobile Studio code. The back-end services are now completely implemented in our own QTX runtime-library, which has been written from scratch. There is not a line of code from Smart Mobile Studio in QTX, which means we no longer have to care what that system does or where it goes.
To sum up:
- Push all file handling code out of the core
- Implement file-handling as it’s own service
Those two steps might seem simple enough, but you have to remember that the older code was based on the Linux path system, and was read-only.
So when pushing that code out of the core, we also have to add all the functionality that was never implemented in our prototype.
Each class actually represents a separate “mini” program, and there are still many more methods to go before we can put this service into production.
Since Javascript does not support threads, each method needs to be implemented as a separate program. So when a method is called, the file/task manager literally spawns a new process just for that task. And the result is swiftly returned back to the caller in async manner.
So what is ultimately simple, becomes more elaborate if you want to do it right. This is the price we pay for universality and a cluster enabled service-stack.
This is also why I have put the service development on pause until we have finished the NodeBuilder tooling. And I did this because I know by experience that the moment the baseline is ready, both myself and users of the system is going to go “oh we need this, and that and those”. Being able to quickly design and auto-generate all the boilerplate code will save us months of work. So I would rather spend a couple of weeks on NodeBuilder than wasting months having to manually write all that boilerplate code down the line.
What about the QTX runtime-library?
Writing an RTL from scratch was not something I could have anticipated before we started this project. But thankfully the worst part of this job is already finished.
The RTL is divided into two parts:
Non Visual code. Classes and methods that makes QTX an RTL- Visual code. Custom Controls + standard controls (buttons, lists etc)
Visual designer
As you can see, the non-visual aspect of the system is finished and working beautifully. It’s a lot faster than the code I wrote for Smart Mobile Studio (roughly twice as fast on average). I also implemented a full visual designer, both as a Delphi visual component and QTX visual component.
Quartex Media Desktop makes running on several machines [cluster] easy and seamless
Why is the QTX Runtime-Library important again?
When the desktop is out the door, the true work begins! The desktop has several roles to play, but the most important aspect of the desktop – is to provide an ecosystem capable of hosting web based applications. Offering features and methods traditionally only found in Windows, Linux or OS X. It truly is a complete cloud system that can scale from a single affordable SBC (single board computer), to a high-end cluster of powerful servers.
Clustering and writing distributed applications has always been difficult, but Quartex Media Desktop makes it simple. It is no more difficult for a user to work on a clustered system, as it is to work on a normal, single OS. The difficult part has already been taken care of, and as long as people follow the rules, there will be no issues beyond ordinary maintenance.
And the first commercial application to come out of Quartex Components, is Cloud Forge, which is the development system for the platform. It has the same role as Visual Studio for Windows, or X Code for Apple OS X.
The Quartex Media Desktop Cluster cube. A $400 super computer
I have prepared 3 compilers for the system already. First there is C/C++ courtesy of Clang. So C developers will be able to jump in and get productive immediately. The second compiler is freepascal, or more precise pas2js, which allows you to compile ordinary freepascal code (which is highly Delphi compatible) to both JavaScript and WebAssembly.
And last but not least, there is my fork of DWScript, which is the same compiler that Smart Mobile Studio uses. Except that my fork is based on the absolute latest version, and i have modified it heavily to better match special features in QTX. So right out of the door CloudForge will have C/C++, two Object Pascal compilers, and vanilla Javascript and typescript. TypeScript also has its own WebAssembly compiler, so doing hard-core development directly in a browser or HTML5 viewport is where we are headed.
Once the IDE is finished I can finally, finally continue on the LDEF bytecode runtime, which will be used in my BlitzBasic port and ultimately replace both clang, freepascal and DWScript. As a bonus it will emit native code for a variety of systems, including x86, ARM, 68k [including 68080] and PPC.
This might sound incredibly ambitious, if not impossible. But what I’m ultimately doing here -is moving existing code that I already have into a new paradigm.
The beauty of object pascal is the sheer size and volume of available components and code. Some refactoring must be done due to the async nature of JS, but when needed we fall back on WebAssembly via Freepascal (WASM executes linear, just like ordinary native code does).
A brand new social platform
During december Facebook royally pissed me off. I cannot underline enough how much i loath A.I censorship, and the mistakes that A.I does – in which you are utterly powerless to complain or be heard by a human being. In my case i posted a gif from their own mobile application, of a female body builder that did push-ups while doing hand-stands. In other words, a completely harmless gif with strength as the punchline. The A.I was not able to distinguish between a leotard and bare-skin, and just like that i was muted for over a week. No human being would make such a ruling. As an admin of a fairly large set of groups, there are many cases where bans are the result. Disgruntled members that acts out of revenge and report technical posts about coding as porn or offensive. Again, you are helpless because there are nobody you can talk to about resolving the issue. And this time I had enough.
It was always planned that we would launch our own social media platform, an alternative to Facebook aimed at adult geeks rather than kids (Facebook operates with an age limit of 12 years). So instead of waiting I rushed out and set up a brand new social network. One where those banale restrictions Facebook has conditioned us with, does not apply.
Just to underline, this is not some simple and small web forum. This is more or less a carbon copy of Facebook the way it used to be 8-9 years ago. So instead of having a single group on facebook, we can now have as many groups as we like, on a platform that looks more or less identical to Facebook – but under our control and human rules.
Amigadisrupt.com is a brand new social media platform for geeks
You can visit the site right now at https://www.amigadisrupt.com. Obviously the major content on the platform right now is dominated by retro computing – but groups like Delphi Developer and FPC developer has already been setup and are in use. But if you are expecting thousands of active users, that will take time. We are now closing in on 250 active users which is pretty good for such a short period of time. I dont want a platform anywhere near as big as FB. The goal is to get 10k users and have a stable community of coders, retro geeks, builders and creative individuals.
AD (Amiga Disrupt) will be a standard application that comes with Quartex Media Desktop. This is the beauty of web technology, in that it can unify different resources under one roof. And we will have our cake and eat it come hell or high water.
Disclaimer: Amiga Disrupt has a lower age limit of 18 years. This is a platform meant for adults. Which means there will be profanity, jokes that would get you banned on Facebook and content that is not meant for kids. This is hacker-land, and political correctness is considered toilet paper. So if you need social toffery like FB and Twitter deals with, you will be kicked by one of the admins.
After you sign up your feed will be completely empty. Here is how to get it started. And feel free to add me to your friends-list!
Quartex Media Desktop, new compiler and general progress
It’s been a few weeks since my last update on the project. The reason I dont blog that often about Quartex Media Desktop (QTXMD), is because the official user-group has grown to 2000+ members. So it’s easier for me to post developer updates directly to the audience rather than writing articles about it.
Quartex Media Desktop ~ a complete environment that runs on every device
If you haven’t bothered digging into the project, let me try to sum it up for you quickly.
Quick recap on Quartex Media Desktop
To understand what makes this project special, first consider the relationship between Microsoft Windows and a desktop program. The operating system, be it Windows, Linux or OSX – provides an infrastructure that makes complex applications possible. The operating-system offers functions and services that programs can rely on.
The most obvious being:
- A filesystem and the ability to save and load data
- A windowing toolkit so programs can be displayed and have a UI
- A message system so programs can communicate with the OS
- A service stack that takes care of background tasks
- Authorization and identity management (security)
I have just described what the Quartex Media Desktop is all about. The goal is simple:
to provide for JavaScript what Windows and OS X provides for ordinary programs.
Just stop and think about this. Every “web application” you have ever seen, have all lacked these fundamental features. Sure you have libraries that gives you a windowing environment for Javascript, like Embarcadero Sencha; but im talking about something a bit more elaborate. Creating windows and buttons is easy, but what about ownership? A runtime environment has to keep track of the resources a program allocates, and make sure that security applies at every step.
Target audience and purpose
Take a second and think about how many services you use that have a web interface. In your house you probably have a router, and all routers can be administered via the browser. Sadly, most routers operate with a crude design and that leaves much to be desired.
Router interfaces for web are typically very limited and plain looking. Imagine what NetGear could do with Quartex Media Desktop instead
If you like to watch movies you probably have a Plex or Kodi system running somewhere in your house; perhaps you access that directly via your TV – or via a modern media system like Playstation 4 or XBox one. Both Plex and Kodi have web-based interfaces.
Netflix is now omnipresent and have practically become an institution in it’s own right. Netflix is often installed as an app – but the app is just a thin wrapper around a web-interface. That way they dont have to code apps for every possible device and OS out there.
If you commute via train in Scandinavia, chances are you buy tickets on a kiosk booth. Most of these booths run embedded software and the interface is again web based. That way they can update the whole interface without manually installing new software on each device.
Plex is a much loved system. It is based on a mix of web and native technologies
These are just examples of web based interfaces you might know and use; devices that leverage web technology. As a developer, wouldn’t it be cool if there was a system that could be forked, adapted and provide advanced functionality out of the box?
Just imagine a cheap Jensen router with a Quartex Media Desktop interface! It could provide a proper UI interface with applications that run in a windowing environment. They could disable ordinary desktop functionality and run their single application in kiosk mode. Taking full advantage of the underlying functionality without loss of security.
And the same is true for you. If you have a great idea for a web based application, you can fork the system, adjust it to suit your needs – and deploy a cutting edge cloud system in days rather than months!
New compiler?
Up until recently I used Smart Mobile Studio. But since I have left that company, the matter became somewhat pressing. I mean, QTXMD is an open-source system and cant really rely on third-party intellectual property. Eventually I fired up Delphi, forked the latest DWScript, and used that to roll a new command-line compiler.
Web technology has reached a level of performance that rivals native applications. You can pretty much retire Photoshop in favour of web based applications these days
But with a new compiler I also need a new RTL. Thankfully I have been coding away on the new RTL for over a year, but there is still a lot of work to do. I essentially have to implement the same functionality from scratch.
There will be more info on the new compiler / codegen when its production ready.
Progress
If I was to list all the work I have done since my last post, this article would be a small book. But to sum up the good stuff:
- Authentication has been moved into it’s own service
- The core (the main server) now delegates login messages to said service
- We no longer rely on the Smart Pascal filesystem drivers, but use the raw node.js functions instead (faster)
- The desktop now use the Smart Theme engine. This means that we can style the desktop to whatever we like. The OS4 theme that was hardcoded will be moved into its own proper theme-file. This means the user can select between OS4, iOS, Android and Ubuntu styling. Creating your own theme-files is also possible. The Smart theme-engine will be replaced by a more elaborate system in QTX later
- Ragnarok (the message api) messages now supports routing. If a routing structure is provided, the core will relay the message to the process in question (providing security allows said routing for the user)
- The desktop now checks for .info files when listing a directory. If a file is accompanied by an .info file, the icon is extracted and shown for that file
- Most of the service layer now relies on the QTX RTL files. We still have some dependencies on the Smart Pascal RTL, but we are making good progress on QTX. Eventually the whole system will have no dependencies outside QTX – and can thus be compiled without any financial obligations.
- QTX has it’s own node.js classes, including server and client base-classes
- Http(s) client and server classes are added to QTX
- Websocket and WebSocket-Secure are added to QTX
- TQTXHybridServer unifies http and websocket. Meaning that this server type can handle both orinary http requests – but also websocket connections on the same network socket. This is highly efficient for websocket based services
- UDP classes for node.js are implemented, both client and server
- Zero-Config classes are now added. This is used by the core for service discovery. Meaning that the child services hosted on another machine will automatically locate the core without knowing the IP. This is very important for machine clustering (optional, you can define a clear IP in the core preferences file)
- Fixed a bug where the scrollbars would corrupt widget states
- Added API functions for setting the scrollbars from hosted applications (so applications can tell the desktop that it needs scrollbar, and set the values)
- .. and much, much more
I will keep you all posted about the progress — the core (the fundamental system) is set for release in december – so time is of the essence! Im allocating more or less all my free time to this, and it will be ready to rock around xmas.
When the core is out, I can focus solely on the applications. Everything from Notepad to Calculator needs to be there, and more importantly — the developer tools. The CloudForge IDE for developers is set for 2020. With that in place you can write applications for iOS, Android, Windows, OS X and Linux directly from Quartex Media Desktop. Nothing to install, you just need a modern browser and a QTX account.
The system is brilliant for small teams and companies. They can setup their own instance, communicate directly via the server (text chat and video chat is scheduled) and work on their products in concert.
Porting TextCraft to Oxygene
TextCraft is a simple yet powerful text parser, designed for general purpose parsing jobs. I originally implemented it for Delphi, it’s the base-parser for the LDEF bytecode assembler amongst other things. It was ported to Smart Pascal, then Freepascal – and now finally Oxygene.
The LDEF Assembler is a part of the Quartex Media Desktop
The LDEF assembler and bytecode engine is currently implemented in Smart and compiles for Javascript. It’s a complete assembler and VM allowing coders to approach Asm.js from an established instruction-set. In short: you feed it source-code, it spits out bytecodes that you can execute super fast in either the browser or elsewhere. As long as there is a VM implementation available.
The Javascript version works really well, especially on node.js. In essence, i don’t need to re-compile the toolchain when moving between arm, x86, windows, linux or osx. Think of it as a type of Java bytecodes or CLR bytecodes.
Getting the code to run under Oxygene, means that I can move the whole engine into WebAssembly. The parser, assembler and linker (et-al) can thus run as WebAssembly, and I can use that from my JavaScript front-end code. Best of both worlds – the flamboyant creativity of JavaScript, and the raw speed of WebAssembly.
The port
Before I can move over the top-level parser + assembler etc, the generic parser code has to work. I was reluctant to start because I imagined the porting would take at least a day, but luckily it took me less than an hour. There are a few superficial differences between Smart, Delphi, Freepascal and Oxygene; for example the Copy() function for strings is not a lose function in Oxygene, instead you use String.SubString(). Functions like High() and Low() on strings likewise has to be refactored.
But all in all the conversion was straight-forward, and TextCraft is now a part of the QTX library for Oxygene. I’ll be uploading a commit to GIT with the whole shabam soon.
Well, hope the WordPress parser doesnt screw this up too bad.
namespace qtxlib;
//##################################################################
// TextCraft 1.2
// Written by Jon L. Aasenden
//
// This is a port of TC 1.2 from Freepascal. TextCraft is initially
// a Delphi parser framework. The original repository can be found
// on BitBucket at:
//
// https://bitbucket.org/hexmonks/main
//
//##################################################################
{$DEFINE USE_INCLUSIVE}
{$define USE_BMARK}
interface
uses
qtxlib, System, rtl,
RemObjects.Elements.RTL.Delphi,
RemObjects.Elements.RTL.Delphi.VCL;
type
// forward declarations
TTextBuffer = class;
TParserContext = class;
TCustomParser = class;
TParserModelObject = class;
// Exceptions
ETextBuffer = class(Exception);
EModelObject = class(Exception);
// Callback functions
TTextValidCB = function (Item: Char): Boolean;
// Bookmark datatype
TTextBufferBookmark = class
public
property bbOffset: Integer;
property bbCol: Integer;
property bbRow: Integer;
function Equals(const ThisMark: TTextBufferBookmark): Boolean;
end;
{.$DEFINE USE_BMARK}
TTextBuffer = class(TErrorObject)
private
FData: String;
FOffset: Integer;
FLength: Integer;
FCol: Integer;
FRow: Integer;
{$IFDEF USE_BMARK}
FBookmarks: List;
{$ENDIF}
procedure SetCacheData(NewText: String);
public
property Column: Integer read FCol;
property Row: Integer read FRow;
property Count: Integer read FLength;
property Offset: Integer read FOffset;
property CacheData: String read FData write SetCacheData;
// These functions map directly to the "Current"
// character where the offset is placed, and is used to
// write code that makes more sense to human eyes
function CrLf: Boolean;
function Space: Boolean;
function Tab: Boolean;
function SemiColon: Boolean;
function Colon: Boolean;
function ConditionEnter: Boolean;
function ConditionLeave: Boolean;
function BracketEnter: Boolean;
function BracketLeave: Boolean;
function Ptr: Boolean;
function Punctum: Boolean;
function Question: Boolean;
function Less: Boolean;
function More: Boolean;
function Equal: Boolean;
function Pipe: Boolean;
function Numeric: Boolean;
function Empty: Boolean;
function BOF: Boolean;
function EOF: Boolean;
function Current: Char;
function First: Boolean;
function Last: Boolean;
// Same as "Next", but does not automatically
// consume CR+LF, used when parsing textfragments
function NextNoCrLf: Boolean;
// Normal Next function, will automatically consume
// CRLF when it encounters it
function Next: Boolean;
function Back: Boolean;
function Bookmark: TTextBufferBookmark;
procedure Restore(const Mark: TTextBufferBookmark);
{$IFDEF USE_BMARK}
procedure Drop;
{$ENDIF}
procedure ConsumeJunk;
procedure ConsumeCRLF;
function Compare(const CompareText: String;
const CaseSensitive: Boolean): Boolean;
function Read(var Fragment: Char): Boolean; overload;
function Read: Char; overload;
function ReadTo(const CB: TTextValidCB; var TextRead: String): Boolean; overload;
function ReadTo(const Resignators: TSysCharSet; var TextRead: String): Boolean; overload;
function ReadTo(MatchText: String): Boolean; overload;
function ReadTo(MatchText: String; var TextRead: String): Boolean; overload;
function ReadToEOL: Boolean; overload;
function ReadToEOL(var TextRead: String): Boolean; overload;
function Peek: Char; overload;
function Peek(CharCount: Integer; var TextRead: String): Boolean; overload;
function NextNonControlChar(const CompareWith: Char): Boolean;
function NextNonControlText(const CompareWith: String): Boolean;
function ReadWord(var TextRead: String): Boolean;
function ReadQuotedString: String;
function ReadCommaList(var cList: List): Boolean;
function NextLine: Boolean;
procedure Inject(const TextToInject: String);
function GetCurrentLocation: TTextBufferBookmark;
function Trail: String;
procedure Clear;
procedure LoadBufferText(const NewBuffer: String);
constructor Create(const BufferText: String); overload; virtual;
finalizer;
begin
{$IFDEF USE_BMARK}
FBookmarks.Clear();
disposeAndNil(FBookmarks);
{$endif}
Clear();
end;
end;
TParserContext = class(TErrorObject)
private
FBuffer: TTextBuffer;
FStack: Stack;
public
property Buffer: TTextBuffer read FBuffer;
property Model: TParserModelObject;
procedure Push(const ModelObj: TParserModelObject);
function Pop: TParserModelObject;
function Peek: TParserModelObject;
procedure ClearStack;
constructor Create(const SourceCode: String); reintroduce; virtual;
finalizer;
begin
FStack.Clear();
FBuffer.Clear();
disposeAndNil(FStack);
disposeAndNil(FBuffer);
end;
end;
TCustomParser = class(TErrorObject)
private
FContext: TParserContext;
protected
procedure SetContext(const NewContext: TParserContext);
public
property Context: TParserContext read FContext;
function Parse: Boolean; virtual;
constructor Create(const ParseContext: TParserContext); reintroduce; virtual;
end;
TParserModelObject = class(TObject)
private
FParent: TParserModelObject;
FChildren: List;
protected
function GetParent: TParserModelObject; virtual;
function ChildGetCount: Integer; virtual;
function ChildGetItem(const Index: Integer): TParserModelObject; virtual;
function ChildAdd(const Instance: TParserModelObject): TParserModelObject; virtual;
public
property Parent: TParserModelObject read GetParent;
property Context: TParserContext;
procedure Clear; virtual;
constructor Create(const AParent: TParserModelObject); virtual;
finalizer;
begin
Clear();
FChildren := nil;
end;
end;
implementation
//#####################################################################
// Error messages
//#####################################################################
const
CNT_ERR_BUFFER_EMPTY = 'Buffer is empty error';
CNT_ERR_OFFSET_BOF = 'Offset at BOF error';
CNT_ERR_OFFSET_EOF = 'Offset at EOF error';
CNT_ERR_COMMENT_NOTCLOSED = 'Comment not closed error';
CNT_ERR_OFFSET_EXPECTED_EOF = 'Expected EOF error';
CNT_ERR_LENGTH_INVALID = 'Invalid length error';
//#####################################################################
// TTextBufferBookmark
//#####################################################################
function TTextBufferBookmark.Equals(const ThisMark: TTextBufferBookmark): boolean;
begin
result := ( (ThisMark nil) and (ThisMark self) )
and (self.bbOffset = ThisMark.bbOffset)
and (self.bbCol = ThisMark.bbCol)
and (self.bbRow = ThisMark.bbRow);
end;
//#####################################################################
// TTextBuffer
//#####################################################################
constructor TTextBuffer.Create(const BufferText: string);
begin
inherited Create();
if length(BufferText) > 0 then
LoadBufferText(BufferText)
else
Clear();
end;
procedure TTextBuffer.Clear;
begin
FData := '';
FOffset := -1;
FLength := 0;
FCol := -1;
FRow := -1;
{$IFDEF USE_BMARK}
FBookmarks.Clear();
{$ENDIF}
end;
procedure TTextBuffer.SetCacheData(NewText: string);
begin
LoadBufferText(NewText);
end;
function TTextBuffer.Trail: string;
begin
if not Empty then
begin
if not EOF then
result := FData.Substring(FOffset, length(FData) );
//result := Copy( FData, FOffset, length(FData) );
end;
end;
procedure TTextBuffer.LoadBufferText(const NewBuffer: string);
begin
// Flush existing buffer
Clear();
// Load in buffertext, init offset and values
var TempLen := NewBuffer.Length;
if TempLen > 0 then
begin
FData := NewBuffer;
FOffset := 0; // start at BOF
FCol := 0;
FRow := 0;
FLength := TempLen;
end;
end;
function TTextBuffer.GetCurrentLocation: TTextBufferBookmark;
begin
if Failed then
ClearLastError();
if not Empty then
begin
result := TTextBufferBookmark.Create;
result.bbOffset := FOffset;
result.bbCol := FCol;
result.bbRow := FRow;
end else
raise ETextBuffer.Create
('Failed to return position, buffer is empty error');
end;
function TTextBuffer.Bookmark: TTextBufferBookmark;
begin
if Failed then
ClearLastError();
if not Empty then
begin
result := TTextBufferBookmark.Create;
result.bbOffset := FOffset;
result.bbCol := FCol;
result.bbRow := FRow;
{$IFDEF USE_BMARK}
FBookmarks.add(result);
{$ENDIF}
end else
raise ETextBuffer.Create
('Failed to bookmark location, buffer is empty error');
end;
procedure TTextBuffer.Restore(const Mark: TTextBufferBookmark);
begin
if Failed then
ClearLastError();
if not Empty then
begin
if Mark nil then
begin
FOffset := Mark.bbOffset;
FCol := Mark.bbCol;
FRow := Mark.bbRow;
Mark.Free;
{$IFDEF USE_BMARK}
var idx := FBookmarks.Count;
if idx > 0 then
begin
dec(idx);
FOffset := FBookmarks[idx].bbOffset;
FCol := FBookmarks[idx].bbCol;
FRow := FBookmarks[idx].bbRow;
FBookmarks.Remove(idx);
//FBookmarks.SetLength(idx)
//FBookmarks.Delete(idx,1);
end else
raise ETextBuffer.Create('Failed to restore bookmark, none exist');
{$ENDIF}
end else
raise ETextBuffer.Create('Failed to restore bookmark, object was nil error');
end else
raise ETextBuffer.Create
('Failed to restore bookmark, buffer is empty error');
end;
{$IFDEF USE_BMARK}
procedure TTextBuffer.Drop;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if FBookmarks.Count > 0 then
FBookmarks.Remove(FBookmarks.Count-1)
else
raise ETextBuffer.Create('Failed to drop bookmark, none exist');
end else
raise ETextBuffer.Create
('Failed to drop bookmark, buffer is empty error');
end;
{$ENDIF}
function TTextBuffer.Read(var Fragment: char): boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
result := FOffset <= length(FData);
if result then
begin
// return character
Fragment := FData[FOffset];
// update offset
inc(FOffset)
end else
begin
// return invalid char
Fragment := #0;
// Set error reason
SetLastError('Offset at BOF error');
end;
end else
begin
result := false;
Fragment := #0;
SetLastError('Buffer is empty error');
end;
end;
function TTextBuffer.Read: char;
begin
if Failed then
ClearLastError();
if not Empty then
begin
result := Current;
Next();
end else
result := #0;
end;
function TTextBuffer.ReadToEOL: boolean;
begin
if Failed then
ClearLastError();
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
// Keep start
var LStart := FOffset;
// Enum until match of EOF
{$IFDEF USE_INCLUSIVE}
repeat
if (FData[FOffset] = #13)
and (FData[FOffset + 1] = #10) then
begin
result := true;
break;
end else
begin
inc(FOffset);
inc(FCol);
end;
until EOF();
{$ELSE}
While FOffset < High(FData) do
begin
if (FData[FOffset] = #13)
and (FData[FOffset + 1] = #10) then
begin
result := true;
break;
end else
begin
inc(FOffset);
inc(FCol);
end;
end;
{$ENDIF}
// Last line in textfile might not have
// a CR+LF, so we have to check for termination
if not result then
begin
if EOF then
begin
if LStart = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset <= high(FData) ) )
and ( (FData[FOffset] = '= Low(FData)) and (FOffset ') );
end;
function TTextBuffer.Equal: boolean;
begin
result := (not Empty)
and ( (FOffset >= Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset LStart then
begin
// Any text to return? Or did we start
// directly on a CR+LF and have no text to give?
var LLen := FOffset - LStart;
TextRead := FData.Substring(LStart, LLen);
//TextRead := Copy(FData, LStart, LLen);
end;
// Either way, we exit because CR+LF has been found
result := true;
break;
end;
inc(FOffset);
inc(FCol);
until EOF();
{$ELSE}
While FOffset LStart then
begin
// Any text to return? Or did we start
// directly on a CR+LF and have no text to give?
var LLen := FOffset - LStart;
TextRead := copy(FData, LStart, LLen);
end;
// Either way, we exit because CR+LF has been found
result := true;
break;
end;
inc(FOffset);
inc(FCol);
end;
{$ENDIF}
// Last line in textfile might not have
// a CR+LF, so we have to check for EOF and treat
// that as a terminator.
if not result then
begin
if FOffset >= high(FData) then
begin
if LStart 0 then
begin
TextRead := FData.Substring(LStart, LLen);
//TextRead := Copy(FData, LStart, LLen);
result := true;
end;
exit;
end;
end;
end;
end;
end;
function TTextBuffer.ReadTo(const CB: TTextValidCB; var TextRead: string): boolean;
begin
if Failed then
ClearLastError();
TextRead := '';
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
if not assigned(CB) then
begin
SetLastError('Invalid callback handler');
exit;
end;
{$IFDEF USE_INCLUSIVE}
repeat
if not CB(Current) then
break
else
TextRead := TextRead + Current;
if not Next() then
break;
until EOF();
{$ELSE}
while not EOF do
begin
if not CB(Current) then
break
else
TextRead := TextRead + Current;
if not Next() then
break;
end;
{$ENDIF}
result := TextRead.Length > 0;
end else
begin
result := false;
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
end;
function TTextBuffer.ReadTo(const Resignators: TSysCharSet; var TextRead: string): boolean;
begin
if Failed then
ClearLastError();
TextRead := '';
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
{$IFDEF USE_INCLUSIVE}
repeat
if not Resignators.Contains(Current) then
TextRead := TextRead + Current
else
break;
if not Next() then
break;
until EOF();
{$ELSE}
while not EOF do
begin
if not (Current in Resignators) then
TextRead := TextRead + Current
else
break;
if not Next() then
break;
end;
{$ENDIF}
result := TextRead.Length > 0;
end else
begin
result := false;
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
end;
function TTextBuffer.ReadTo(MatchText: string): boolean;
begin
if Failed then
ClearLastError();
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
var MatchLen := length(MatchText);
if MatchLen > 0 then
begin
MatchText := MatchText.ToLower();
repeat
var TempCache := '';
if Peek(MatchLen, TempCache) then
begin
TempCache := TempCache.ToLower();
result := SameText(TempCache, MatchText);
if result then
break;
end;
if not Next then
break;
until EOF;
end;
end else
begin
result := false;
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
end;
function TTextBuffer.ReadTo(MatchText: string; var TextRead: string): boolean;
begin
if Failed then
ClearLastError();
result := false;
TextRead := '';
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
if MatchText.Length > 0 then
begin
MatchText := MatchText.ToLower();
repeat
var TempCache := '';
if Peek(MatchText.Length, TempCache) then
begin
TempCache := TempCache.ToLower();
result := SameText(TempCache, MatchText);
if result then
break
else
TextRead := TextRead + Current;
end else
TextRead := TextRead + Current;
if not Next() then
break;
until EOF;
end;
end else
begin
result := false;
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
end;
procedure TTextBuffer.Inject(const TextToInject: string);
begin
if length(FData) > 0 then
begin
var lSeg1 := FData.Substring(1, FOffset);
var lSeg2 := FData.Substring(FOffset + 1, length(FData));
//var LSeg1 := Copy(FData, 1, FOffset);
//var LSeg2 := Copy(FData, FOffset+1, FData.Length);
FData := lSeg1 + TextToInject + lSeg2;
end else
FData := TextToInject;
end;
function TTextBuffer.Compare(const CompareText: string;
const CaseSensitive: boolean): boolean;
begin
if Failed then
ClearLastError();
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
var LenToRead := CompareText.Length;
if LenToRead > 0 then
begin
// Peek will set an error message if it
// fails, so we dont need to set anything here
var ReadData := '';
if Peek(LenToRead, ReadData) then
begin
case CaseSensitive of
false: result := ReadData.ToLower() = CompareText.ToLower();
true: result := ReadData = CompareText;
end;
end;
end else
SetLastError(CNT_ERR_LENGTH_INVALID);
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
procedure TTextBuffer.ConsumeJunk;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
repeat
case Current of
' ':
begin
end;
'"':
begin
break;
end;
#8, #09:
begin
end;
'/':
begin
(* Skip C style remark *)
if Compare('/*', false) then
begin
if ReadTo('*/') then
begin
inc(FOffset, 2);
Continue;
end else
SetLastError(CNT_ERR_COMMENT_NOTCLOSED);
end else
begin
(* Skip Pascal style remark *)
if Compare('//', false) then
begin
if ReadToEOL() then
begin
continue;
end else
SetLastError(CNT_ERR_OFFSET_EXPECTED_EOF);
end;
end;
end;
'(':
begin
(* Skip pascal style remark *)
if Compare('(*', false)
and not Compare('(*)', false) then
begin
if ReadTo('*)') then
begin
inc(FOffset, 2);
continue;
end else
SetLastError(CNT_ERR_COMMENT_NOTCLOSED);
end else
break;
end;
#13:
begin
if FData[FOffset + 1] = #10 then
inc(FOffset, 2)
else
inc(FOffset, 1);
//if Peek = #10 then
// ConsumeCRLF;
continue;
end;
#10:
begin
inc(FOffset);
continue;
end;
else
break;
end;
if not Next() then
break;
until EOF;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
procedure TTextBuffer.ConsumeCRLF;
begin
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
if (FData[FOffset] = #13) then
begin
if FData[FOffset + 1] = #10 then
inc(FOffset, 2)
else
inc(FOffset);
inc(FRow);
FCol := 0;
end;
end;
end;
function TTextBuffer.Empty: boolean;
begin
result := FLength < 1;
end;
// This method will look ahead, skipping space, tab and crlf (also known
// as control characters), and when a non control character is found it will
// perform a string compare. This method uses a bookmark and will restore
// the offset to the same position as when it was entered.
//
// Notes: The method "NextNonControlChar" is a similar method that
// performs a char-only compare.
function TTextBuffer.NextNonControlText(const CompareWith: string): boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
var Mark := Bookmark();
try
// Iterate ahead
repeat
if not (Current in [' ', #13, #10, #09]) then
break;
Next();
until EOF();
// Compare unless we hit the end of the line
if not EOF then
result := Compare(CompareWith, false);
finally
Restore(Mark);
end;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
// This method will look ahead, skipping space, tab and crlf (also known
// as control characters), and when a non control character is found it will
// perform a string compare. This method uses a bookmark and will restore
// the offset to the same position as when it was entered.
function TTextBuffer.NextNonControlChar(const CompareWith: char): boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
var Mark := Bookmark();
try
repeat
if not (Current in [' ', #13, #10, #09]) then
break;
Next();
until EOF();
//if not EOF then
result := Current.ToLower() = CompareWith.ToLower();
//result := LowerCase(Current) = LowerCase(CompareWith);
finally
Restore(Mark);
end;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.Peek: char;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if (FOffset 0 do
begin
TextRead := TextRead + Current;
if not Next() then
break;
dec(CharCount);
end;
finally
Restore(Mark);
end;
result := TextRead.Length > 0;
end else
SetLastError(CNT_ERR_OFFSET_EOF);
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.First: boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
FOffset := Low(FData);
result := true;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.Last: boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
FOffset := high(FData);
result := true;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.NextNoCrLf: boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
// Check that we are not EOF
result := FOffset <= high(FData);
if result then
begin
// Update offset into buffer
inc(FOffset);
// update column, but not if its in a lineshift
if not (FData[FOffset] in [#13, #10]) then
inc(FCol);
end else
SetLastError(CNT_ERR_OFFSET_EOF);
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.Next: boolean;
begin
if Failed then
ClearLastError();
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
// Update offset into buffer
inc(FOffset);
// update column
inc(FCol);
// This is the same as ConsumeCRLF
// But this does not generate any errors since we PEEK
// ahead into the buffer to make sure the combination
// is correct before we adjust the ROW + offset
if FOffset Low(FData));
if result then
dec(FOffset)
else
SetLastError(CNT_ERR_OFFSET_BOF);
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.Current: char;
begin
if Failed then
ClearLastError();
// Check that buffer is not empty
if not Empty then
begin
// Check that we are on char 1 or more
if FOffset >= Low(FData) then
begin
// Check that we are before or on the last char
if (FOffset <= high(FData)) then
result := FData[FOffset]
else
begin
SetLastError(CNT_ERR_OFFSET_EOF);
result := #0;
end;
end else
begin
SetLastError(CNT_ERR_OFFSET_BOF);
result := #0;
end;
end else
begin
SetLastError(CNT_ERR_BUFFER_EMPTY);
result := #0;
end;
end;
function TTextBuffer.BOF: boolean;
begin
if not Empty then
result := FOffset high(FData);
end;
function TTextBuffer.NextLine: boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
// Make sure we offset to a valid character
// in the buffer.
ConsumeJunk();
if not EOF then
begin
var ThisRow := self.FRow;
while Row = ThisRow do
begin
Next();
if EOF then
break;
end;
result := (Row ThisRow) and (not EOF);
end;
end;
end;
function TTextBuffer.ReadWord(var TextRead: string): boolean;
begin
if Failed then
ClearLastError();
TextRead := '';
if not Empty then
begin
// Make sure we offset to a valid character
// in the buffer.
ConsumeJunk();
// Not at the end of the file?
if not EOF then
begin
repeat
var el := Current;
if (el in
[ 'A'..'Z',
'a'..'z',
'0'..'9',
'_', '-' ]) then
TextRead := TextRead + el
else
break;
if not NextNoCrLf() then
break;
until EOF;
result := TextRead.Length > 0;
end else
SetLastError('Failed to read word, unexpected EOF');
end else
SetLastError('Failed to read word, buffer is empty error');
end;
function TTextBuffer.ReadCommaList(var cList: List): boolean;
var
LTemp: String;
LValue: String;
begin
if cList = nil then
cList := new List
else
cList.Clear();
if not Empty then
begin
ConsumeJunk();
While not EOF do
begin
case Current of
#09:
begin
// tab, just skip
end;
#13, #10:
begin
// CR+LF, consume and continue;
ConsumeCRLF();
end;
#0:
begin
// Unexpected EOL
break;
end;
';':
begin
//Perfectly sound ending
result := true;
break;
end;
'"':
begin
LValue := ReadQuotedString;
if LValue.Length > 0 then
begin
cList.add(LValue);
LValue := '';
end;
end;
',':
begin
LTemp := LTemp.Trim();
if LTemp.Length>0 then
begin
cList.add(LTemp);
LTemp := '';
end;
end;
else
begin
LTemp := LTemp + Current;
end;
end;
if not Next() then
break;
end;
if LTemp.Length > 0 then
cList.add(LTemp);
result := cList.Count > 0;
end;
end;
function TTextBuffer.ReadQuotedString: string;
begin
if not Empty then
begin
if not EOF then
begin
// Make sure we are on the " entry quote
if Current '"' then
begin
SetLastError('Failed to read quoted string, expected index on " character error');
exit;
end;
// Skip the entry char
if not NextNoCrLf() then
begin
SetLastError('Failed to skip initial " character error');
exit;
end;
while not EOF do
begin
// Read char from buffer
var TempChar := Current;
// Closing of string? Exit
if TempChar = '"' then
begin
if not NextNoCrLf then
SetLastError('failed to skip final " character in string error');
break;
end;
result := result + TempChar;
if not NextNoCrLf() then
break;
end;
end;
end;
end;
//##########################################################################
// TParserModelObject
//##########################################################################
constructor TParserModelObject.Create(const AParent:TParserModelObject);
begin
inherited Create;
FParent := AParent;
FChildren := new List;
end;
function TParserModelObject.GetParent:TParserModelObject;
begin
result := FParent;
end;
procedure TParserModelObject.Clear;
begin
FChildren.Clear();
end;
function TParserModelObject.ChildGetCount: integer;
begin
result := FChildren.Count;
end;
function TParserModelObject.ChildGetItem(const Index: integer): TParserModelObject;
begin
result := TParserModelObject(FChildren[Index]);
end;
function TParserModelObject.ChildAdd(const Instance: TParserModelObject): TParserModelObject;
begin
if FChildren.IndexOf(Instance) < 0 then
FChildren.add(Instance);
result := Instance;
end;
//###########################################################################
// TParserContext
//###########################################################################
constructor TParserContext.Create(const SourceCode: string);
begin
inherited Create;
FBuffer := TTextBuffer.Create(SourceCode);
FStack := new Stack;
end;
procedure TParserContext.Push(const ModelObj: TParserModelObject);
begin
if Failed then
ClearLastError();
try
FStack.Push(ModelObj);
except
on e: Exception do
SetLastError('Internal error:' + e.Message);
end;
end;
function TParserContext.Pop: TParserModelObject;
begin
if Failed then
ClearLastError();
try
result := FStack.Pop();
except
on e: Exception do
SetLastError('Internal error:' + e.Message);
end;
end;
function TParserContext.Peek: TParserModelObject;
begin
if Failed then
ClearLastError();
try
result := FStack.Peek();
except
on e: Exception do
SetLastError('Internal error:' + e.Message);
end;
end;
procedure TParserContext.ClearStack;
begin
if Failed then
ClearLastError();
try
FStack.Clear();
except
on e: Exception do
SetLastError('Internal error:' + e.Message);
end;
end;
//###########################################################################
// TCustomParser
//###########################################################################
constructor TCustomParser.Create(const ParseContext: TParserContext);
begin
inherited Create;
FContext := ParseContext;
end;
function TCustomParser.Parse: boolean;
begin
result := false;
SetLastErrorF('No parser implemented for class %s',[ClassName]);
end;
procedure TCustomParser.SetContext(const NewContext: TParserContext);
begin
FContext := NewContext;
end;
end.
QTX IDE for freepascal
It’s been a hectic couple of weeks that’s for sure. I’ve been called the death of freepascal, a devil with anterior motives, a civil war monger and much, much more. It’s quite dramatic don’t you think? I mean “civil war” (insert dark voice here) and all that. We are talking about programming languages, not the borders of Bosnia. Yet drama these guys spin like spiders on drugs.
And killing the guy that raises the red flag, when did that become popular? So when I go “yo — there is something wrong here, be careful”, they just respond “Why did you say that, I don’t want to know there are bad things in the world!”. Guess I should be glad we’re not in the army together huh? That could get messy.:”Me: Guys there are mines here, go around, seven o’clock!” — “FPC/Lazarus: Everyone into the minefield and twirk like mad! That’s an order!”.
So the entertainment is priceless. Just wonderful to watch people allergic to the words “im sorry i thrash talked you, my bad, you were right to tell us” squirm around like vipers being cooked alive on a chinese barbeque .. pride can be an ugly thing.
Be very careful when using CodeTyphon, wait until it’s clear of all GPL and copyright violations. I wouldnt go near it personally.
Well, despite all the bad news, the slandering and negativity – I remain cheerful through it all. Why? Because rather than stealing code from others or trying to bypass laws and regulations, I put my time into writing the Quartex IDE from scratch without the help on anyone. And I did that exactly to avoid the awful mess PilotLogic and freepascal now find itself in.
It’s really simple:
- If i need help, I ask politely
- If i want to use a component which is free, I ask politely
- If i want to use a full GPL piece of code, I still ask politely!
- I dont remove author names, but instead put them in the About box to respect the authors, thanking them for their work
- I try to solve things first myself before asking for help
- I use standard packages like SynEdit and Jedi exactly to avoid GPL/copyright problems
Incidentally I was trying to stop problems from happening, but everyone needs someone to blame so if blaming me for pointing out copyright theft and GPL violations — whatever makes you happy I guess. I honestly don’t care any more what happens to these systems. I should not have wasted my time trying to help FPC/Lazarus and CodeTyphon. I guess there is a reason these groups have a bad reputation – sadly I have them the benefit of the doubt.
The best comment on the FPC forum must have been “Who has given you the right to prosecute pilotlogic!” — well, in that case: who has give you the right to make FPC better? Because protecting FPC was what I was doing. So who the hell made you king and decided that you could fix bugs? Do you think you’re better than anyone else? Huh? — that’s the kind of insane thinking I’m faced with. It’s just unbelievable.
QTX for freepascal
That would be a no I think. Since people actually believe that I am a devil incarnate in all of this, it would only serve to make their insanity a self-fulfilling prophecy. And QTX will render Lazarus useless, so … dont think they would be to happu about that either. They would no doubt scream “I told you so, he was plotting this all along!”. Which is fun because I’m not that diabolical even on my best of days, I couldn’t because there is a limit to how much evil scheming I get done with 3 kids, homework, brownie baking and a full time day job as a C# programmer.
Freepascal is a great product, but the forum is full of “characters” which do more harm to the product then good.. All projects get’s nutcase “groupies” but usually the leaders have the sense to get rid of them. This has sadly not been the case here
So, I guess the plans to support freepascal has to be canceled. Which is really a shame because I truly believe in FPC/Lazarus as a universal platform. QTX would sort of be the icing on the cake. And even if you don’t like it – it would still be good to have it, because the more alternative we have the better.
But nope, I will not be supporting freepascal or lazarus after all. If people want it they can ask of course, I might change my mind in a couple of years; but right now I wont go near that copyright mess with a 10 foot pole. Nor would I support people who verbally abuse supporters when trying to help them (months in advance btw). They can blame themselves. A user group that hostile serves little or no purpose what so ever.
Alternatives
But there are always solutions for those that look; in heaps and buckets. QTX is designed to be a transcending platform, meaning that it compiles to an intermediate format (LDEF) which in turn can be represented in other languages through a code-generator API. A bit like .net but on source level rather than binary.
This means that I will be focusing on vanilla C++, shipping QTX with the free GNU C++ compiler, which is the fastest most widely developed and used compiler in the world. And I do believe it has the widest support for hardware out there as well, so it’s not bad news at all.
So to sum up:
- You write object pascal just like Delphi or FPC
- The compiler compiles to LDEF
- LDEF is compiled into C++
- C++ is compiled to machine code using the free GNU C++ compiler
- Voila, you have a free path on both Unix, Linux, Windows, OS X and pretty much every platform out there
What have you been doing lately?
That is a good question. I have been very busy with my day-job coding in C# so there has been limited time for personal projects. But last weekend I added a new cool feature to QTX, namely a second way of opening units by cursor.
QTX is still young, but packs a mean punch
You know that you can CTRL + Click on a unit-keyword and the IDE opens the file automatically for you right? Well, what if that unit is a part of a package? Wouldnt it be great if the IDE not just opened the file – but mapped the file to the treeview so you can see all the files? This is optionally of course, but it will save you a lot of time when writing packages yourself or porting packages from Delphi/FPC.
This is a humble change I agree, but sometimes making the ground-level functions rock solid is valuable. It’s exactly those functions that have been crashing Lazarus for ages. Lazarus is really only perfect on Linux, on Ubuntu for instance it’s just bloody brilliant and really hits the mark. But on OS X and Windows it’s often the small functions, those you take for granted that crash and burn.
So I’ll be spending a few extra months before alfa release just doing those functions really well. The advanced stuff can wait. I’m going for stable and rock solid over super-modern and unstable.
Messages in Smart Mobile Studio
If you have missed message coding from Delphi under Smart Pascal then you are in for a treat. The QTX library now supports application-wide messages in the browser; allowing you to send and subscribe to as many messages as you like. More or less duplicating the stuff you are used to under WinAPI.
In fact, you can subscribe to the same message in the same object as many times as you want — and also instantiate as many subscription objects as you like.
Receiving messages
Here is how you would create and setup a message-subscription for a form:
procedure TForm1.InitializeObject;
begin
inherited;
{$I 'Form1:impl'}
//create our message subscriber object
FMsgPort:=TQTXMessageSubscriber.Create;
// subscribe to message-type $100
FMsgPort.Subscribe($100,procedure (Message:TQTXMessageData)
begin
writeln("Data received:" + message.data);
end);
// subscribe to message-type $200
FMsgPort.Subscribe($200,procedure (Message:TQTXMessageData)
begin
writeln("Data received:" + message.data);
end);
end;
To send real objects through messages, simply use JSON to serialize it, then de-serialize it in your message handler.
Sending messages
The simplest way to send messages are through the two API methods:
- QTX_SendMessage(Message:TQTXMessageData);
- QTX_BroadcastMessage(Message:TQTXMessageData);
Alternatively, although highly unpractical, you could create your own message-port. The whole message system uses just a single message-port so you would never really create these yourself. If all you want to do is send and receive messages – you have more or less the same support as Delphi as for WinAPI messages — but simpler and easier to use!
Practical uses
Messages have been a part of Windows since the beginning, and it’s also hard-coded into Delphi. Their uses are almost limitless and you can use then to notify changes across controls and forms, transport data from one place to another — it’s really only creativity that sets the bounds.
What is cool about Smart Mobile Studio – is that you now have the same system under JavaScript. It works in every browser and allows your HTML5 forms and controls to communicate indirectly.
The technology is based on the HTML5 message system, which is a part of modern browsers. It’s extremely efficient and very reliable.
QTX Library for Smart Mobile Studio updated
QTX (Quartex) is a library written for Smart Mobile Studio users. It extends the run-time library with a wide range of capabilities, including database (dataset) support, custom effects, tag-attribute storage and much, much more.
If you are a serious HTML5 developer using Smart Mobile Studio, then this library is a must. The font and content measurement alone is worth the download – and did I mention that it’s free?
Facebook clone, coded in a couple of hours using QTX for Smart Mobile Studio
Library overview
QTX is packed with classes and methods, and I have done my best to make it as easy as possible to understand. I take it for granted that you understand the concept of HTML-Tags, and that you understand that Smart Mobile Studio code creates TAGS when it’s constructor fires, and removes the tag when the destructor executes. As such, we have no need for libraries like JQuery – because the handle (reference) to the element is always known. JQuery is ultimately about extracting tags within a criteria from the DOM (hence “Query” in the title, as in SQL for querying a database).
What we do like however, is plenty of effects – and dead simple syntax for using them. Well it doesnt get any easier than with QTX. The QTX library extends TW3CustomControl with it’s own class helper, meaning that once you have included the qtx.effects unit – all your controls supports the whole range of effects.
Also, effects are executed in sequence. You can trigger 10 effects and they will execute one by one, which is no small feat under HTML5 (but easy with QTX tag attribute support).
Here is a brief overview of the classes and methods you get when installing QTX:
Database
- TQTXDataset
- TQTXDatasetField
- TQTXBooleanField
- TQTXIntegerField
- TQTXFloatField
- TQTXStringField
- TQTXDatasetFields
- TQTXFieldDef
- TQTXFieldDefs
Tag-Attribute Storage
- TQTXAttrAccess
CSS3 GPU powered animations
- TQTXMoveAnimation
- TQTXFadeAnimation
- TQTXSizeAnimation
- TQTXAnimationHelper
Effect management
- TQTXEffectsHelper
- fxSetBusy
- fxBusy:boolean
- fxScaleUp
- fxScaleDown
- fxSizeTo
- fxMoveDown
- fxMoveUp
- fxMoveBy
- fxMoveTo
- fxScaleTo
- fxZoomOut
- fxZoomIn
- fxWarpIn
- fxWarpOut
- fxFadeIn
- fxFadeOut
Font and content measurement
- TQTXTextMetric
- TQTXFontInfo
- TQTXFontDetector
Helper classes
- TQTXHandleHelper
- TQTXIntegerHelper
- TQTXStringHelper
Media IO management
- TQTXIOAccess
- LoadXML
- LoadFile
- LoadCSS
- LoadScript
- LoadImage
- PreloadImages
Delayed execution
- TQTXRuntime
- DelayedDispatch
- CancelDelayedDispatch
- Execute
- Ready
- ExecuteDocumentReady
Dynamic stylesheets
- TQTXStyleSheet
Flicker free, smooth momentum scroll baseclasses
- TQTXScrollOptions,
- TQTXScrollController
- TQTXScrollWindow
3D for any HTML elements
- TQTXSprite3DController
Custom controls
- TQTXHeaderButton
- TQTXBackButton
- TQTXNextButton
- TQTXHeaderTitle
- TQTXHeaderBar
- TQTXLabel
- TQTXScrollText
Downloading
Simply point your SVN client to: svn checkout http://qtxlibrary.googlecode.com/svn/trunk/ and grab the units.
Installing
Copy the target folder into your Smart Mobile Studio -> Libraries folder and re-start the IDE. That’s it! Now include the units in your uses-clause and kick some serious HTML5 butt!
Caching effects
Sort of discovered this by surprise. I was making the typical “mouse-over” effects for buttons, where they grow a few pixels when you hover over them. But, since only one webkit transformation can be applied to an element at any given time, I decided to use a callback to catch effects that overlap.
Well, it’s pretty cool! Move the mouse pointer in and out of the control very quickly to see what I mean. And naturally, the element never looses its original size. This is perfect for music vumeter’s — or perhaps a ripple effect that never loses track of the original size?
W3Button1.OnMouseEnter:=Procedure (sender:TObject; Shift: TShiftState; X, Y: Integer)
Begin
if not w3button1.fxBusy then
w3Button1.fxScaleUp(4,0.2) else
w3_callback( procedure ()
Begin
w3Button1.OnMouseEnter(sender,shift,x,y);
end, 100);
end;
w3button1.OnMouseExit:=procedure (sender:TObject; Shift: TShiftState; X, Y: Integer)
Begin
if not w3button1.fxBusy then
w3Button1.fxScaleDown(4,0.2) else
w3_callback( procedure ()
Begin
w3Button1.onMouseExit(sender,shift,x,y);
end, 100);
end;
Oh, and remember to update the QTX svn library before trying it !
Updated
I decided to add this form of caching to the library itself. This completely removes the need for an effect-stack (linear “list” of effects to execute one after the other).
Well, everything is now in place to write some interesting, dynamic and awesome Smart Pascal visual components. I could be tempted to write a book on advanced Smart Mobile coding — interested?
Storing stuff inside the tag
User definable per-tag attributes
Another thing I learned today. As you probably understand by now, a Smart Visual Component consists of two parts. First, there is the javascript object which is what you compile from Object Pascal, secondly there is the HTML element which your control manages via code.
But what if you want to store some data which can be read/written without access to the JS code?
Let me introduce you to the problem. The effects library is capable of animating any TW3CustomControl based element, regardless of what basetype it implements (DIV, PRE, IFRAME etc..). But it does this via class helpers – so how can we store a boolean value informing us that an effect is active? We dont want to re-mold the RTL (at least not before the technology is rock solid) — so how can we attach data to an element without altering the virtual method table data?
Ta-Da! — HTML5 introduces something called Data Attributes (read more here: http://html5doctor.com/html5-custom-data-attributes/) . Basically, whenever you use attributes on a tag which begins with “data-“, the browser leaves them in place (ordinarily it would remove them or not include them in the DOM). This allows us to do stuff like below, without affecting javascript, the RTL or the DOM negatively in any way (!):
<DIV ID="w3Panel1" data-fxActive="true"> .. </DIV>
In the QTX library read/write access to data-attributes is introduced in the class TQTXAttrAccess (qtxutils.pas). So if you include this unit in your project, all TW3CustomControl based elements gain an extra property called ElementData of type TQTXAttrAccess. Think of it like an unlimited box of TComponent.Tag values 🙂
Effects without stylesheet punching
Unless you have been living under a rock you would know that the GPU can only be accessed via CSS. This means you have to write stylesheet code (which you can edit inside Smart Mobile Studio). But this ties you down a bit, because what if you want to re-use some effects in another app? You either have to copy the CSS and Pascal code over — or… you can author the effect CSS in smart pascal directly.
And that my friend is why you will find a class called TQTXStyleSheet in the qtxstyles.pas unit. It allows you to write cutting edge GPU effects that are portable between projects — and you can leave the default, model view stylesheet intact.
You are welcome!
QTXLibrary on google code
Quartex is 4ever
To make things easier in the future I decided to push all my Smart Pascal examples into one basket and upload them to Google Code. That way people don’t have to copy & paste from this website, but rather just update their SVN repo folder.
Point your SVN client at: https://code.google.com/p/qtxlibrary/
Only human
I must however stress that these units should be considered “examples”. This blog is more about experimentation, research and education than it is anything else. I do not provide any form of support. I work full-time as a professional software developer, so there is quite frankly not enough time for large-scale hobby projects.
For new features and ideas around Smart Pascal, send an email to the Smart Mobile Studio team. It will be registered in the system and receive a proper ticket.
Ayways, do a checkout of the google repository – remember to check out to the Smart Mobile Studio Libraries folder – and have a peek 🙂
What can it do?
All sorts of cool stuff! You have the in-memory dataset class, which is very handy. And the latest additions are the effect helpers. Smart Mobile Studio RTL contains a lot of cool stuff – but for beginners it may be hard to get to grips with all the new terminology. If you are serious about y0ur HTML5 coding, you should get a book and learn some JS. It makes all the difference.
So how are the effect helpers useful? Well, for instance, to make buttons that “grow” when you move your mouse hovers over them, you would write this:
W3Button1.OnMouseEnter:=Procedure (sender:TObject; Shift: TShiftState; X, Y: Integer)
Begin
//grow the button by 4x4 pixels in 0.2 seconds
w3Button1.fxScaleUp(4,0.2);
end;
w3button1.OnMouseExit:=procedure (sender:TObject; Shift: TShiftState; X, Y: Integer)
Begin
// Shrink button back to original size
w3Button1.fxScaleDown(4,0.2);
end;
Effect stack
What I have been playing with lately (thought only for now) is an effect stack. Basically a “mini” effect language that you can use to script effect chains inside your SMS application.
For instance, a script could look like:
var script:String := #"fadeout(0); fadeIn(0.6); moveTo(100,100); rotate(-30,-60,-70); scale(200,200); Scew3d(-90,-90-36); warpOut(0.9);"; FStack.push(script,w3button1); FStack.execute(esImmediate);
Reminds me a bit about the old Amos Basic “sprite language” that we used in the 90’s for writing shoot’em up enemies for games and demos.
Jon L. Aasenden 
You must be logged in to post a comment.