[Pas2js] Pas2JS-Widgets with LFM streaming
Sven Barth
pascaldragon at googlemail.com
Fri Jul 26 19:34:25 CEST 2019
Hello together!
I've experimented a bit with Pas2JS and the Pas2JS-Widgets by
heliosroots ( https://github.com/heliosroots/Pas2JS_Widget/tree/master )
and implemented loading of unmodified LFM files. It's a bit cumbersome
for now, cause it needs changes in the project's HTML source as well as
the main project file for each form added, but as a proof of concept it
works. I've attached the patch that needs to be applied to the
Pas2JS-Widget master.
To use it you proceed as follows:
- make sure you have installed Pas2JSDsgn (from Pas2JS) and
Pas2JS_Designer_Package (from Pas2JS-Widgets)
- make sure you at least once opened Pas2JS_RTL (from Pas2JS) and
Pas2JS_Widget (from Pas2JS-Widgets)
- create a new "Web Browser Application"
- add Pas2JS_RTL and Pas2JS_Widget as requirements
- add new forms using New -> Module -> Web Form (Pas2JS)
- remove the overridden Loaded method from any forms
- replace the main program's code with this (of course adjust the
form/unit names to your needs):
=== code begin ===
program tp2j;
{$mode objfpc}
uses
Forms, FormLoader, Interfaces, Unit1;
procedure DoInit(aData: TObject);
begin
Application.Initialize;
Application.CreateForm(TWForm1, WForm1);
Application.Run;
end;
begin
LoadForms([TWForm1], @DoInit, Nil);
end.
=== code end ===
- add a script tag in front of the project's script tag in the HTML
file: <script src="unit1.lfm" type="application/x-lazarus-form"
id="TWForm1.lfm"></script>
- play around with the form (add components (from the Pas2JS component
tab only!), add events, etc.)
- before compiling make sure that the project *does not* contain a
requirement of Pas2JS_Designer_Package (the IDE currently adds this when
adding a component)
- make sure that the *.LFM files are at the same location as the *.JS file
- load your application in the browser -> you should now see your form
A screenshot showing the resulting browser and the IDE is attached. :)
This can obviously be further improved:
- adding support also for frames and data modules
- caching the converted object stream (so that it doesn't need to be
converted for each creation of a form)
- add some way of asynchronous loading?
And then of course the Pas2JS Widgets needs to be improved. :)
@heliosroots (in case you read this): do you have a more current version
of your components? I've seen in one of your videos that you also have
DB components available.
Regards,
Sven
-------------- next part --------------
diff --git a/pas2js/packages/widget/controls.pas b/pas2js/packages/widget/controls.pas
index 681a639..a020f44 100755
--- a/pas2js/packages/widget/controls.pas
+++ b/pas2js/packages/widget/controls.pas
@@ -264,6 +264,7 @@ type
procedure MouseMove(Shift: TShiftState; X, Y: integer); virtual;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); virtual;
procedure MouseWeel(Shift: TShiftState; WheelDelta: NativeInt; MousePos: TPoint; var Handled: boolean);
+ procedure SetParentComponent(Value: TComponent); override;
protected
property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle;
property TabOrder: NativeInt read FTabOrder write SetTabOrder;
@@ -1302,6 +1303,12 @@ begin
end;
end;
+procedure TControl.SetParentComponent(Value: TComponent);
+begin
+ if Value is TWinControl then
+ SetParent(TWinControl(Value));
+end;
+
function TControl.HandleClick(AEvent: TJSMouseEvent): boolean;
begin
AEvent.StopPropagation;
diff --git a/pas2js/packages/widget/formloader.pas b/pas2js/packages/widget/formloader.pas
new file mode 100644
index 0000000..438f6dd
--- /dev/null
+++ b/pas2js/packages/widget/formloader.pas
@@ -0,0 +1,64 @@
+{
+ Based on Rtl.ScriptLoader (thus the same license as that (ToDo: which is?)).
+
+ Modifications by Sven Barth
+}
+unit FormLoader;
+
+interface
+
+uses
+ Forms;
+
+type
+ TLoadedCallBack = Reference to procedure(Data : TObject);
+ TProc = reference to procedure;
+ TCustomFormClassArray = array of TCustomFormClass;
+
+procedure LoadForms(aForms: TCustomFormClassArray; aCallback: TLoadedCallback; aData: TObject);
+
+implementation
+
+uses
+ SysUtils,
+ JS, Web;
+
+procedure LoadForms(aForms: TCustomFormClassArray; aCallback: TLoadedCallback; aData: TObject);
+
+ procedure Loader(aForm: TCustomFormClass; aHandler: TProc);
+ var
+ script: TJSElement;
+ req: TJSXMLHttpRequest;
+
+ procedure DoLoaded;
+ begin
+ script.textContent := req.responseText;
+ aHandler;
+ end;
+
+ var
+ src: String;
+ begin
+ script := document.getElementById(aForm.ClassName + '.lfm');
+ if not Assigned(script) then
+ raise Exception.CreateFmt('No script element found for ', [aForm.ClassName]);
+ src := script['src'];
+ req := TJSXMLHttpRequest.new;
+ req.AddEventListener('load', @DoLoaded);
+ req.Open('GET', src);
+ req.Send;
+ end;
+
+ procedure Run;
+ begin
+ if Length(aForms) > 0 then
+ Loader(TCustomFormClass(TJSArray(aForms).shift()), @Run)
+ else if Assigned(aCallback) then
+ aCallback(aData);
+ end;
+
+begin
+ Run;
+end;
+
+end.
diff --git a/pas2js/packages/widget/forms.pas b/pas2js/packages/widget/forms.pas
index e7f74b7..8f82ba1 100755
--- a/pas2js/packages/widget/forms.pas
+++ b/pas2js/packages/widget/forms.pas
@@ -128,10 +128,12 @@ type
protected
procedure Changed; override;
function CreateHandleElement: TJSHTMLElement; override;
+ procedure ProcessResource; virtual;
protected
class function GetControlClassDefaultSize: TSize; override;
public
constructor Create(AOwner: TComponent); override;
+ constructor CreateNew(AOwner: TComponent; Num: Integer = 0); virtual;
destructor Destroy; override;
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
@@ -216,12 +218,58 @@ type
property OnUnload: TNotifyEvent read FOnUnload write FOnUnload;
end;
+ { TWForm }
+
+ TWForm = class(TCustomForm)
+ published
+ property ActiveControl;
+ property Align;
+ property AlphaBlend;
+ property AlphaBlendValue;
+ property Caption;
+ property ClientHeight;
+ property ClientWidth;
+ property Color;
+ property Enabled;
+ property Font;
+ property HandleClass;
+ property HandleID;
+ property KeyPreview;
+ property ShowHint;
+ property Visible;
+ property OnActivate;
+ property OnClick;
+ property OnClose;
+ property OnCloseQuery;
+ property OnCreate;
+ property OnDblClick;
+ property OnDeactivate;
+ property OnDestroy;
+ property OnHide;
+ property OnKeyDown;
+ property OnKeyPress;
+ property OnKeyUp;
+ property OnMouseDown;
+ property OnMouseEnter;
+ property OnMouseLeave;
+ property OnMouseMove;
+ property OnMouseUp;
+ property OnMouseWheel;
+ property OnResize;
+ property OnScroll;
+ property OnShow;
+ end;
+ TWFormClass = class of TWForm;
+
{ TODO: TScreen }
function Application: TApplication;
implementation
+uses
+ LResources, LCLStrConsts;
+
{$hints off}
procedure DefaultModalProc(Sender: TObject; ModalResult: TModalResult);
@@ -591,6 +639,13 @@ begin
Result := TJSHTMLElement(Document.CreateElement('div'));
end;
+procedure TCustomForm.ProcessResource;
+begin
+ if not InitResourceComponent(Self, TWForm) then
+ raise EResNotFound.CreateFmt(
+ rsFormResourceSNotFoundForResourcelessFormsCreateNew, [ClassName]);
+end;
+
class function TCustomForm.GetControlClassDefaultSize: TSize;
begin
Result.Cx := 320;
@@ -598,6 +653,25 @@ begin
end;
constructor TCustomForm.Create(AOwner: TComponent);
+begin
+ //GlobalNameSpace.BeginWrite;
+ try
+ CreateNew(AOwner, 1); // this calls BeginFormUpdate, which is ended in AfterConstruction
+ if (ClassType <> TWForm) and not (csDesigning in ComponentState) then
+ begin
+ //Include(FFormState, fsCreating);
+ try
+ ProcessResource;
+ finally
+ //Exclude(FFormState, fsCreating);
+ end;
+ end;
+ finally
+ //GlobalNameSpace.EndWrite;
+ end;
+end;
+
+constructor TCustomForm.CreateNew(AOwner: TComponent; Num: Integer);
begin
inherited Create(AOwner);
FActiveControl := nil;
diff --git a/pas2js/packages/widget/graphics.pas b/pas2js/packages/widget/graphics.pas
index 4f41764..6c433cd 100755
--- a/pas2js/packages/widget/graphics.pas
+++ b/pas2js/packages/widget/graphics.pas
@@ -279,6 +279,10 @@ function JSColor(const AColor: TColor): string;
function JSFont(const AFont: TFont): string;
function JSMeasureText(const AText: string; const AFontName: string; const AFontSize: NativeInt; const AFixedWidth: NativeInt = 0): TSize; overload;
+function IdentEntry(Entry: Longint; out MapEntry: TIdentMapEntry): boolean;
+function ColorToIdent(Color: Longint; out Ident: String): Boolean;
+function IdentToColor(const Ident: string; out Color: Longint): Boolean;
+function ColorIndex(Color: Longint; out Index: Integer): Boolean;
implementation
@@ -948,5 +952,108 @@ begin
Result := TextExtent(AText).Cx;
end;
+const
+ Colors: array[0..46] of TIdentMapEntry = (
+ // standard colors
+ (Value: clBlack; Name: 'clBlack'),
+ (Value: clMaroon; Name: 'clMaroon'),
+ (Value: clGreen; Name: 'clGreen'),
+ (Value: clOlive; Name: 'clOlive'),
+ (Value: clNavy; Name: 'clNavy'),
+ (Value: clPurple; Name: 'clPurple'),
+ (Value: clTeal; Name: 'clTeal'),
+ (Value: clGray; Name: 'clGray'),
+ (Value: clSilver; Name: 'clSilver'),
+ (Value: clRed; Name: 'clRed'),
+ (Value: clLime; Name: 'clLime'),
+ (Value: clYellow; Name: 'clYellow'),
+ (Value: clBlue; Name: 'clBlue'),
+ (Value: clFuchsia; Name: 'clFuchsia'),
+ (Value: clAqua; Name: 'clAqua'),
+ (Value: clWhite; Name: 'clWhite'),
+
+ // extended colors
+ (Value: clMoneyGreen; Name: 'clMoneyGreen'),
+ (Value: clSkyBlue; Name: 'clSkyBlue'),
+ (Value: clCream; Name: 'clCream'),
+ (Value: clMedGray; Name: 'clMedGray'),
+
+ // special colors
+ (Value: clNone; Name: 'clNone'),
+ (Value: clDefault; Name: 'clDefault'),
+
+ // system colors
+ (Value: clScrollBar; Name: 'clScrollBar'),
+ (Value: clBackground; Name: 'clBackground'),
+ (Value: clActiveCaption; Name: 'clActiveCaption'),
+ (Value: clInactiveCaption; Name: 'clInactiveCaption'),
+ (Value: clMenu; Name: 'clMenu'),
+ //(Value: clMenuBar; Name: 'clMenuBar'),
+ //(Value: clMenuHighlight; Name: 'clMenuHighlight'),
+ (Value: clMenuText; Name: 'clMenuText'),
+ (Value: clWindow; Name: 'clWindow'),
+ (Value: clWindowFrame; Name: 'clWindowFrame'),
+ (Value: clWindowText; Name: 'clWindowText'),
+ (Value: clCaptionText; Name: 'clCaptionText'),
+ (Value: clActiveBorder; Name: 'clActiveBorder'),
+ (Value: clInactiveBorder; Name: 'clInactiveBorder'),
+ (Value: clAppWorkspace; Name: 'clAppWorkspace'),
+ (Value: clHighlight; Name: 'clHighlight'),
+ (Value: clHighlightText; Name: 'clHighlightText'),
+ (Value: clBtnFace; Name: 'clBtnFace'),
+ (Value: clBtnShadow; Name: 'clBtnShadow'),
+ (Value: clGrayText; Name: 'clGrayText'),
+ (Value: clBtnText; Name: 'clBtnText'),
+ (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
+ (Value: clBtnHighlight; Name: 'clBtnHighlight'),
+ (Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
+ (Value: cl3DLight; Name: 'cl3DLight'),
+ (Value: clInfoText; Name: 'clInfoText'),
+ (Value: clInfoBk; Name: 'clInfoBk')
+
+ //(Value: clHotLight; Name: 'clHotLight'),
+ //(Value: clGradientActiveCaption; Name: 'clGradientActiveCaption'),
+ //(Value: clGradientInactiveCaption; Name: 'clGradientInactiveCaption'),
+
+ // one our special color
+ //(Value: clForm; Name: 'clForm')
+ );
+
+function IdentEntry(Entry: Longint; out MapEntry: TIdentMapEntry): boolean;
+begin
+ Result := False;
+ if (Entry >= 0) and (Entry <= High(Colors)) then
+ begin
+ MapEntry := Colors[Entry];
+ Result := True;
+ end;
+end;
+
+function ColorToIdent(Color: Longint; out Ident: String): Boolean;
+begin
+ Result := IntToIdent(Color, Ident, Colors);
+end;
+
+function IdentToColor(const Ident: string; out Color: Longint): Boolean;
+begin
+ Result := IdentToInt(Ident, Color, Colors);
+end;
+
+function ColorIndex(Color: Longint; out Index: Integer): Boolean;
+var
+ i: integer;
+begin
+ for i := Low(Colors) to High(Colors) do
+ if Colors[i].Value = Color then
+ begin
+ Result := True;
+ Index := i;
+ exit;
+ end;
+ Result := False;
+end;
+
+initialization
+ RegisterIntegerConsts(TypeInfo(TColor), TIdentToInt(@IdentToColor), TIntToIdent(@ColorToIdent));
end.
diff --git a/pas2js/packages/widget/lclstrconsts.pas b/pas2js/packages/widget/lclstrconsts.pas
new file mode 100644
index 0000000..5869992
--- /dev/null
+++ b/pas2js/packages/widget/lclstrconsts.pas
@@ -0,0 +1,32 @@
+{
+ /***************************************************************************
+ lclstrconsts.pas
+ ----------------
+ This unit contains all resource strings of the LCL (not interfaces)
+
+
+ ***************************************************************************/
+
+ *****************************************************************************
+ This file is part of the Lazarus Component Library (LCL)
+
+ See the file COPYING.modifiedLGPL.txt, included in this distribution,
+ for details about the license.
+ *****************************************************************************
+}
+unit LCLStrConsts;
+
+{$mode objfpc}{$H+}
+
+interface
+
+resourcestring
+ rsFormResourceSNotFoundForResourcelessFormsCreateNew = 'Form resource %s '
+ +'not found. For resourceless forms CreateNew constructor must be used.'
+ +' See the global variable RequireDerivedFormResource.';
+ rsFormStreamingError = 'Form streaming "%s" error: %s';
+
+implementation
+
+end.
+
diff --git a/pas2js/packages/widget/lresources.pas b/pas2js/packages/widget/lresources.pas
new file mode 100644
index 0000000..5d4c4a1
--- /dev/null
+++ b/pas2js/packages/widget/lresources.pas
@@ -0,0 +1,129 @@
+{
+ Note: This file is based on LCL's LResources unit.
+
+ Original Author: Mattias Gaertner
+
+ *****************************************************************************
+ This file is part of the Lazarus Component Library (LCL)
+
+ See the file COPYING.modifiedLGPL.txt, included in this distribution,
+ for details about the license.
+ *****************************************************************************
+
+ Abstract:
+ This unit maintains and stores all lazarus resources in the global list
+ named LazarusResources and provides methods and types to stream components.
+
+ A lazarus resource is an ansistring, with a name and a valuetype. Both, name
+ and valuetype, are ansistrings as well.
+ Lazarus resources are normally included via an include directive in the
+ initialization part of a unit. To create such include files use the
+ BinaryToLazarusResourceCode procedure.
+ To create a LRS file from an LFM file use the LFMtoLRSfile function which
+ transforms the LFM text to binary format and stores it as Lazarus resource
+ include file.
+}
+unit LResources;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes;
+
+function InitResourceComponent(Instance: TComponent;
+ RootAncestor: TClass):Boolean;
+function InitLazResourceComponent(Instance: TComponent;
+ RootAncestor: TClass): Boolean;
+
+implementation
+
+uses
+ Web, SysUtils,
+ LCLStrConsts;
+
+function InitResourceComponent(Instance: TComponent; RootAncestor: TClass
+ ): Boolean;
+begin
+ Result := InitLazResourceComponent(Instance, RootAncestor);
+end;
+
+function InitLazResourceComponent(Instance: TComponent; RootAncestor: TClass
+ ): Boolean;
+
+ function InitComponent(ClassType: TClass): Boolean;
+ var
+ ResName: String;
+ Stream: TStream;
+ BinStream: TMemoryStream;
+ Reader: TReader;
+ script: TJSElement;
+ begin
+ //DebugLn(['[InitComponent] ClassType=',ClassType.Classname,' Instance=',DbgsName(Instance),' RootAncestor=',DbgsName(RootAncestor),' ClassType.ClassParent=',DbgsName(ClassType.ClassParent)]);
+ Result := False;
+ if (ClassType = TComponent) or (ClassType = RootAncestor) then
+ Exit;
+ if Assigned(ClassType.ClassParent) then
+ Result := InitComponent(ClassType.ClassParent);
+
+ Stream := nil;
+ ResName := ClassType.ClassName;
+
+ script := Document.getElementById(ResName + '.lfm');
+ if Assigned(script) and (script.textContent <> '') then
+ Stream := TStringStream.Create(script.textContent);
+
+ if Stream = nil then
+ Exit;
+
+ try
+ //DebugLn('Form Stream "',ClassType.ClassName,'"');
+ try
+ BinStream := TMemoryStream.Create;
+ try
+ ObjectTextToBinary(Stream, BinStream);
+
+ BinStream.Position := 0;
+
+ Reader := TReader.Create(BinStream);
+ try
+ Reader.ReadRootComponent(Instance);
+ finally
+ Reader.Free;
+ end;
+ finally
+ BinStream.Free;
+ end;
+ except
+ on E: Exception do begin
+ Writeln(Format(rsFormStreamingError,[ClassType.ClassName,E.Message]));
+ raise;//exit;
+ end;
+ end;
+ finally
+ Stream.Free;
+ end;
+ Result := True;
+ end;
+
+
+begin
+ if Instance.ComponentState * [csLoading, csInline] <> []
+ then begin
+ // global loading not needed
+ Result := InitComponent(Instance.ClassType);
+ end
+ else try
+ //BeginGlobalLoading;
+ Result := InitComponent(Instance.ClassType);
+ //NotifyGlobalLoading;
+ finally
+ //EndGlobalLoading;
+ end;
+end;
+
+initialization
+ RegisterInitComponentHandler(TComponent, @InitResourceComponent);
+end.
+
diff --git a/pas2js/packages/widget/pas2js_widget.lpk b/pas2js/packages/widget/pas2js_widget.lpk
index b98a54a..180af11 100755
--- a/pas2js/packages/widget/pas2js_widget.lpk
+++ b/pas2js/packages/widget/pas2js_widget.lpk
@@ -60,7 +60,7 @@
SOFTWARE.
} "/>
<Version Major="1"/>
- <Files Count="15">
+ <Files Count="18">
<Item1>
<Filename Value="webextra.pas"/>
<UnitName Value="WebExtra"/>
@@ -121,6 +121,18 @@
<Filename Value="webctrls.pas"/>
<UnitName Value="WebCtrls"/>
</Item15>
+ <Item16>
+ <Filename Value="lclstrconsts.pas"/>
+ <UnitName Value="lclstrconsts"/>
+ </Item16>
+ <Item17>
+ <Filename Value="formloader.pas"/>
+ <UnitName Value="FormLoader"/>
+ </Item17>
+ <Item18>
+ <Filename Value="lresources.pas"/>
+ <UnitName Value="LResources"/>
+ </Item18>
</Files>
<RequiredPkgs Count="1">
<Item1>
diff --git a/pas2js/packages/widget/webctrls.pas b/pas2js/packages/widget/webctrls.pas
index 3e70bf7..d6aab47 100755
--- a/pas2js/packages/widget/webctrls.pas
+++ b/pas2js/packages/widget/webctrls.pas
@@ -44,49 +44,6 @@ uses
type
- { TWForm }
-
- TWForm = class(TCustomForm)
- published
- property ActiveControl;
- property Align;
- property AlphaBlend;
- property AlphaBlendValue;
- property Caption;
- property ClientHeight;
- property ClientWidth;
- property Color;
- property Enabled;
- property Font;
- property HandleClass;
- property HandleID;
- property KeyPreview;
- property ShowHint;
- property Visible;
- property OnActivate;
- property OnClick;
- property OnClose;
- property OnCloseQuery;
- property OnCreate;
- property OnDblClick;
- property OnDeactivate;
- property OnDestroy;
- property OnHide;
- property OnKeyDown;
- property OnKeyPress;
- property OnKeyUp;
- property OnMouseDown;
- property OnMouseEnter;
- property OnMouseLeave;
- property OnMouseMove;
- property OnMouseUp;
- property OnMouseWheel;
- property OnResize;
- property OnScroll;
- property OnShow;
- end;
- TWFormClass = class of TWForm;
-
{ TWFrame }
TWFrame = class(TCustomFrame)
-------------- next part --------------
A non-text attachment was scrubbed...
Name: streaming.png
Type: image/png
Size: 217641 bytes
Desc: not available
URL: <http://lists.freepascal.org/pipermail/pas2js/attachments/20190726/40baa152/attachment-0001.png>
More information about the Pas2js
mailing list