moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-24 18:22:25 -05:00
Code Issues Releases Wiki Activity

PS Added

Browse Source 
git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@38 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond 2009-09-12 06:24:59 +00:00
parent 9a2b50ef82
commit 6f80c64d9c
67 changed files with 52891 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

309
Projects/SAMufasaGUI/project1.lpi
View File

@ -7,7 +7,7 @@
<TargetFileExt Value=""/>
<Title Value="Mufasa Stand Alone"/>
<UseXPManifest Value="True"/>
<ActiveEditorIndexAtStart Value="9"/>
<ActiveEditorIndexAtStart Value="8"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
@ -24,20 +24,24 @@
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<RequiredPackages Count="2">
<Item1>
<PackageName Value="LCL"/>
<PackageName Value="SynEdit"/>
<MinVersion Major="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="50">
<Units Count="64">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="project1"/>
<CursorPos X="12" Y="11"/>
<TopLine Value="1"/>
<CursorPos X="13" Y="17"/>
<TopLine Value="7"/>
<EditorIndex Value="0"/>
<UsageCount Value="65"/>
<UsageCount Value="70"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
@ -166,10 +170,10 @@
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="TestUnit"/>
<CursorPos X="26" Y="266"/>
<TopLine Value="241"/>
<EditorIndex Value="5"/>
<UsageCount Value="31"/>
<CursorPos X="19" Y="271"/>
<TopLine Value="259"/>
<EditorIndex Value="7"/>
<UsageCount Value="36"/>
<Loaded Value="True"/>
</Unit18>
<Unit19>
@ -298,20 +302,20 @@
<Filename Value="../../Units/MMLCore/client.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Client"/>
<CursorPos X="46" Y="39"/>
<TopLine Value="1"/>
<EditorIndex Value="3"/>
<UsageCount Value="30"/>
<CursorPos X="25" Y="4"/>
<TopLine Value="4"/>
<EditorIndex Value="5"/>
<UsageCount Value="35"/>
<Loaded Value="True"/>
</Unit37>
<Unit38>
<Filename Value="../../Units/MMLCore/mufasatypes.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="MufasaTypes"/>
<CursorPos X="3" Y="16"/>
<TopLine Value="1"/>
<EditorIndex Value="2"/>
<UsageCount Value="30"/>
<CursorPos X="4" Y="26"/>
<TopLine Value="12"/>
<EditorIndex Value="4"/>
<UsageCount Value="35"/>
<Loaded Value="True"/>
</Unit38>
<Unit39>
@ -327,22 +331,20 @@
<UnitName Value="files"/>
<CursorPos X="62" Y="61"/>
<TopLine Value="46"/>
<EditorIndex Value="7"/>
<UsageCount Value="31"/>
<Loaded Value="True"/>
<UsageCount Value="36"/>
</Unit40>
<Unit41>
<Filename Value="../../Units/MMLCore/window.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Window"/>
<CursorPos X="35" Y="187"/>
<TopLine Value="174"/>
<EditorIndex Value="4"/>
<UsageCount Value="30"/>
<CursorPos X="8" Y="262"/>
<TopLine Value="255"/>
<EditorIndex Value="6"/>
<UsageCount Value="35"/>
<Loaded Value="True"/>
</Unit41>
<Unit42>
<Filename Value="../../../../Documents/lazarus/lcl/forms.pp"/>
<Filename Value="../../../Documents/lazarus/lcl/forms.pp"/>
<UnitName Value="Forms"/>
<CursorPos X="15" Y="1236"/>
<TopLine Value="981"/>
@ -360,27 +362,23 @@
<UnitName Value="windowutil"/>
<CursorPos X="39" Y="19"/>
<TopLine Value="9"/>
<EditorIndex Value="6"/>
<UsageCount Value="14"/>
<Loaded Value="True"/>
<UsageCount Value="15"/>
</Unit44>
<Unit45>
<Filename Value="../../Units/MMLCore/input.pas"/>
<UnitName Value="Input"/>
<CursorPos X="39" Y="203"/>
<TopLine Value="187"/>
<EditorIndex Value="8"/>
<UsageCount Value="13"/>
<Loaded Value="True"/>
<UsageCount Value="14"/>
</Unit45>
<Unit46>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="finder"/>
<CursorPos X="24" Y="130"/>
<TopLine Value="99"/>
<EditorIndex Value="1"/>
<UsageCount Value="23"/>
<TopLine Value="111"/>
<EditorIndex Value="3"/>
<UsageCount Value="28"/>
<Loaded Value="True"/>
</Unit46>
<Unit47>
@ -394,136 +392,195 @@
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="MMLThread"/>
<CursorPos X="49" Y="20"/>
<CursorPos X="132" Y="5"/>
<TopLine Value="1"/>
<EditorIndex Value="9"/>
<UsageCount Value="21"/>
<Loaded Value="True"/>
<UsageCount Value="26"/>
</Unit48>
<Unit49>
<Filename Value="../../../../Documents/fpc/rtl/objpas/classes/classesh.inc"/>
<Filename Value="../../../Documents/fpc/rtl/objpas/classes/classesh.inc"/>
<CursorPos X="27" Y="1430"/>
<TopLine Value="1422"/>
<UsageCount Value="10"/>
</Unit49>
<Unit50>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="mmlpsthread"/>
<CursorPos X="20" Y="156"/>
<TopLine Value="150"/>
<EditorIndex Value="8"/>
<UsageCount Value="24"/>
<Loaded Value="True"/>
</Unit50>
<Unit51>
<Filename Value="../../Units/PascalScript/uPSComponent.pas"/>
<UnitName Value="uPSComponent"/>
<CursorPos X="21" Y="193"/>
<TopLine Value="183"/>
<EditorIndex Value="13"/>
<UsageCount Value="13"/>
<Loaded Value="True"/>
</Unit51>
<Unit52>
<Filename Value="../../../FPC/FPCCheckout/rtl/objpas/classes/classesh.inc"/>
<CursorPos X="94" Y="494"/>
<TopLine Value="489"/>
<EditorIndex Value="12"/>
<UsageCount Value="13"/>
<Loaded Value="True"/>
</Unit52>
<Unit53>
<Filename Value="../../../FPC/FPCCheckout/rtl/objpas/types.pp"/>
<UnitName Value="types"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="11"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit53>
<Unit54>
<Filename Value="../../../FPC/FPCCheckout/rtl/objpas/typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="10"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit54>
<Unit55>
<Filename Value="../../Units/PascalScript/uPSC_forms.pas"/>
<UnitName Value="uPSC_forms"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="9"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit55>
<Unit56>
<Filename Value="project1.lrs"/>
<CursorPos X="20" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="1"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit56>
<Unit57>
<Filename Value="../../../lazarus/lcl/lresources.pp"/>
<UnitName Value="LResources"/>
<CursorPos X="3" Y="1396"/>
<TopLine Value="1396"/>
<EditorIndex Value="2"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit57>
<Unit58>
<Filename Value="../../../lazarus/components/synedit/synmemo.pas"/>
<UnitName Value="SynMemo"/>
<CursorPos X="16" Y="150"/>
<TopLine Value="31"/>
<UsageCount Value="10"/>
</Unit58>
<Unit59>
<Filename Value="../../../lazarus/components/synedit/syneditmiscclasses.pp"/>
<UnitName Value="SynEditMiscClasses"/>
<CursorPos X="29" Y="100"/>
<TopLine Value="92"/>
<UsageCount Value="10"/>
</Unit59>
<Unit60>
<Filename Value="../../../lazarus/components/synedit/synedit.pp"/>
<UnitName Value="SynEdit"/>
<CursorPos X="22" Y="1531"/>
<TopLine Value="1523"/>
<UsageCount Value="10"/>
</Unit60>
<Unit61>
<Filename Value="../../../lazarus/components/synedit/syngutterchanges.pas"/>
<UnitName Value="SynGutterChanges"/>
<CursorPos X="34" Y="126"/>
<TopLine Value="118"/>
<UsageCount Value="10"/>
</Unit61>
<Unit62>
<Filename Value="../../../lazarus/components/synedit/syneditlines.pas"/>
<UnitName Value="SynEditLines"/>
<CursorPos X="21" Y="48"/>
<TopLine Value="40"/>
<UsageCount Value="10"/>
</Unit62>
<Unit63>
<Filename Value="../../../lazarus/components/synedit/synedittextbase.pas"/>
<UnitName Value="SynEditTextBase"/>
<CursorPos X="3" Y="75"/>
<TopLine Value="124"/>
<UsageCount Value="10"/>
</Unit63>
</Units>
<JumpHistory Count="29" HistoryIndex="28">
<JumpHistory Count="16" HistoryIndex="15">
<Position1>
<Filename Value="../../Units/MMLCore/windowutil.pas"/>
<Caret Line="34" Column="34" TopLine="24"/>
<Filename Value="testunit.pas"/>
<Caret Line="274" Column="26" TopLine="258"/>
</Position1>
<Position2>
<Filename Value="../../Units/MMLCore/files.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
<Filename Value="testunit.pas"/>
<Caret Line="271" Column="35" TopLine="258"/>
</Position2>
<Position3>
<Filename Value="../../Units/MMLCore/files.pas"/>
<Caret Line="213" Column="5" TopLine="203"/>
<Filename Value="testunit.pas"/>
<Caret Line="271" Column="14" TopLine="258"/>
</Position3>
<Position4>
<Filename Value="../../Units/MMLCore/input.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
<Filename Value="testunit.pas"/>
<Caret Line="271" Column="19" TopLine="258"/>
</Position4>
<Position5>
<Filename Value="../../Units/MMLCore/client.pas"/>
<Caret Line="8" Column="53" TopLine="1"/>
<Filename Value="testunit.pas"/>
<Caret Line="22" Column="47" TopLine="22"/>
</Position5>
<Position6>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="35" Column="5" TopLine="31"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="30" Column="45" TopLine="22"/>
</Position6>
<Position7>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="92" Column="48" TopLine="75"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="8" Column="73" TopLine="22"/>
</Position7>
<Position8>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="84" Column="12" TopLine="64"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="30" Column="45" TopLine="22"/>
</Position8>
<Position9>
<Filename Value="testunit.pas"/>
<Caret Line="84" Column="18" TopLine="69"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="225" Column="50" TopLine="217"/>
</Position9>
<Position10>
<Filename Value="testunit.pas"/>
<Caret Line="88" Column="30" TopLine="65"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="227" Column="5" TopLine="219"/>
</Position10>
<Position11>
<Filename Value="testunit.pas"/>
<Caret Line="87" Column="16" TopLine="69"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="53" Column="19" TopLine="40"/>
</Position11>
<Position12>
<Filename Value="testunit.pas"/>
<Caret Line="90" Column="41" TopLine="75"/>
<Caret Line="279" Column="3" TopLine="270"/>
</Position12>
<Position13>
<Filename Value="../../Units/MMLCore/input.pas"/>
<Caret Line="201" Column="18" TopLine="1"/>
<Filename Value="testunit.pas"/>
<Caret Line="271" Column="19" TopLine="259"/>
</Position13>
<Position14>
<Filename Value="../../Units/MMLCore/input.pas"/>
<Caret Line="209" Column="34" TopLine="195"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="65" Column="26" TopLine="22"/>
</Position14>
<Position15>
<Filename Value="../../Units/MMLCore/input.pas"/>
<Caret Line="215" Column="65" TopLine="193"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="49" Column="15" TopLine="21"/>
</Position15>
<Position16>
<Filename Value="../../Units/MMLCore/input.pas"/>
<Caret Line="202" Column="41" TopLine="182"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="55" Column="16" TopLine="26"/>
</Position16>
<Position17>
<Filename Value="../../Units/MMLCore/input.pas"/>
<Caret Line="203" Column="39" TopLine="183"/>
</Position17>
<Position18>
<Filename Value="../../Units/MMLCore/input.pas"/>
<Caret Line="202" Column="39" TopLine="183"/>
</Position18>
<Position19>
<Filename Value="../../Units/MMLCore/input.pas"/>
<Caret Line="188" Column="63" TopLine="172"/>
</Position19>
<Position20>
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<Caret Line="31" Column="21" TopLine="7"/>
</Position20>
<Position21>
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<Caret Line="34" Column="6" TopLine="12"/>
</Position21>
<Position22>
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<Caret Line="40" Column="12" TopLine="13"/>
</Position22>
<Position23>
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<Caret Line="36" Column="38" TopLine="14"/>
</Position23>
<Position24>
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<Caret Line="42" Column="5" TopLine="14"/>
</Position24>
<Position25>
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<Caret Line="41" Column="38" TopLine="18"/>
</Position25>
<Position26>
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<Caret Line="42" Column="47" TopLine="20"/>
</Position26>
<Position27>
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<Caret Line="29" Column="12" TopLine="12"/>
</Position27>
<Position28>
<Filename Value="testunit.pas"/>
<Caret Line="250" Column="18" TopLine="57"/>
</Position28>
<Position29>
<Filename Value="testunit.pas"/>
<Caret Line="263" Column="20" TopLine="239"/>
</Position29>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
@ -533,7 +590,7 @@
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)/"/>
<OtherUnitFiles Value="$(ProjPath)../../Units/MMLCore/;/home/merlijn/Programs/mufasa/Units/MMLAddon/"/>
<OtherUnitFiles Value="$(ProjPath)../../Units/MMLCore/;$(ProjPath)../../Units/MMLAddon/;$(ProjPath)../../Units/PascalScript/"/>
</SearchPaths>
<CodeGeneration>
<Optimizations>

3
Projects/SAMufasaGUI/project1.lpr
View File

@ -8,7 +8,7 @@ uses
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, LResources, Window, files, MufasaTypes, Client, TestUnit, finder,
MMLThread;
MMLThread, mmlpsthread;
{$IFDEF WINDOWS}{$R project1.rc}{$ENDIF}
@ -16,6 +16,7 @@ begin
Application.Title:='Mufasa Stand Alone';
{$I project1.lrs}
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

1398
Projects/SAMufasaGUI/testunit.lfm
View File

File diff suppressed because it is too large Load Diff

296
Projects/SAMufasaGUI/testunit.lrs
View File

@ -1,10 +1,286 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TForm1','FORMDATA',[
'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'q'#1#6'Height'#3#15#2#3'Top'#3#223#0#5'Wi'
+'dth'#3#11#3#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'#12'ClientH'
+'eight'#3#15#2#11'ClientWidth'#3#11#3#8'Position'#7#14'poScreenCenter'#10'LC'
+'LVersion'#6#6'0.9.29'#0#7'TButton'#7'Button1'#4'Left'#2#8#6'Height'#2#25#3
+'Top'#2#16#5'Width'#2'K'#7'Caption'#6#7'Button1'#7'OnClick'#7#12'Button1Clic'
+'k'#8'TabOrder'#2#0#0#0#0
]);
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TForm1','FORMDATA',[
'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'q'#1#6'Height'#3#15#2#3'Top'#3#223#0#5'Wi'
+'dth'#3#11#3#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'#12'ClientH'
+'eight'#3#15#2#11'ClientWidth'#3#11#3#8'Position'#7#14'poScreenCenter'#10'LC'
+'LVersion'#6#6'0.9.29'#0#7'TButton'#7'Button1'#4'Left'#2#8#6'Height'#2#25#3
+'Top'#2#16#5'Width'#2'K'#7'Caption'#6#3'Run'#7'OnClick'#7#12'Button1Click'#8
+'TabOrder'#2#0#0#0#8'TSynEdit'#8'SynEdit1'#4'Left'#2#8#6'Height'#3'('#1#3'To'
+'p'#2'@'#5'Width'#3#216#2#5'Align'#7#8'alCustom'#11'Font.Height'#2#243#9'Fon'
+'t.Name'#6#11'Courier New'#10'Font.Pitch'#7#7'fpFixed'#12'Font.Quality'#7#16
+'fqNonAntialiased'#11'ParentColor'#8#10'ParentFont'#8#8'TabOrder'#2#1#12'Gut'
+'ter.Width'#2'9'#19'Gutter.MouseActions'#14#1#5'Shift'#11#0#9'ShiftMask'#11#0
+#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'C'
+'ommand'#2#13#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0
+#9'ShiftMask'#11#0#6'Button'#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'Cli'
+'ckDir'#7#4'cdUp'#7'Command'#2#12#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2
+#0#0#0#11'Highlighter'#7#17'SynFreePascalSyn1'#10'Keystrokes'#14#1#7'Command'
+#7#4'ecUp'#8'ShortCut'#2'&'#0#1#7'Command'#7#7'ecSelUp'#8'ShortCut'#3'& '#0#1
+#7'Command'#7#10'ecScrollUp'#8'ShortCut'#3'&@'#0#1#7'Command'#7#6'ecDown'#8
+'ShortCut'#2'('#0#1#7'Command'#7#9'ecSelDown'#8'ShortCut'#3'( '#0#1#7'Comman'
+'d'#7#12'ecScrollDown'#8'ShortCut'#3'(@'#0#1#7'Command'#7#6'ecLeft'#8'ShortC'
+'ut'#2'%'#0#1#7'Command'#7#9'ecSelLeft'#8'ShortCut'#3'% '#0#1#7'Command'#7#10
+'ecWordLeft'#8'ShortCut'#3'%@'#0#1#7'Command'#7#13'ecSelWordLeft'#8'ShortCut'
+#3'%`'#0#1#7'Command'#7#7'ecRight'#8'ShortCut'#2''''#0#1#7'Command'#7#10'ecS'
+'elRight'#8'ShortCut'#3''' '#0#1#7'Command'#7#11'ecWordRight'#8'ShortCut'#3
+'''@'#0#1#7'Command'#7#14'ecSelWordRight'#8'ShortCut'#3'''`'#0#1#7'Command'#7
+#10'ecPageDown'#8'ShortCut'#2'"'#0#1#7'Command'#7#13'ecSelPageDown'#8'ShortC'
+'ut'#3'" '#0#1#7'Command'#7#12'ecPageBottom'#8'ShortCut'#3'"@'#0#1#7'Command'
+#7#15'ecSelPageBottom'#8'ShortCut'#3'"`'#0#1#7'Command'#7#8'ecPageUp'#8'Shor'
+'tCut'#2'!'#0#1#7'Command'#7#11'ecSelPageUp'#8'ShortCut'#3'! '#0#1#7'Command'
+#7#9'ecPageTop'#8'ShortCut'#3'!@'#0#1#7'Command'#7#12'ecSelPageTop'#8'ShortC'
+'ut'#3'!`'#0#1#7'Command'#7#11'ecLineStart'#8'ShortCut'#2'$'#0#1#7'Command'#7
+#14'ecSelLineStart'#8'ShortCut'#3'$ '#0#1#7'Command'#7#11'ecEditorTop'#8'Sho'
+'rtCut'#3'$@'#0#1#7'Command'#7#14'ecSelEditorTop'#8'ShortCut'#3'$`'#0#1#7'Co'
+'mmand'#7#9'ecLineEnd'#8'ShortCut'#2'#'#0#1#7'Command'#7#12'ecSelLineEnd'#8
+'ShortCut'#3'# '#0#1#7'Command'#7#14'ecEditorBottom'#8'ShortCut'#3'#@'#0#1#7
+'Command'#7#17'ecSelEditorBottom'#8'ShortCut'#3'#`'#0#1#7'Command'#7#12'ecTo'
+'ggleMode'#8'ShortCut'#2'-'#0#1#7'Command'#7#6'ecCopy'#8'ShortCut'#3'-@'#0#1
+#7'Command'#7#7'ecPaste'#8'ShortCut'#3'- '#0#1#7'Command'#7#12'ecDeleteChar'
+#8'ShortCut'#2'.'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'. '#0#1#7'Command'
+#7#16'ecDeleteLastChar'#8'ShortCut'#2#8#0#1#7'Command'#7#16'ecDeleteLastChar'
+#8'ShortCut'#3#8' '#0#1#7'Command'#7#16'ecDeleteLastWord'#8'ShortCut'#3#8'@'
+#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#4#8#128#0#0#0#1#7'Command'#7#6'ecRed'
+'o'#8'ShortCut'#4#8#160#0#0#0#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#2#13
+#0#1#7'Command'#7#11'ecSelectAll'#8'ShortCut'#3'A@'#0#1#7'Command'#7#6'ecCop'
+'y'#8'ShortCut'#3'C@'#0#1#7'Command'#7#13'ecBlockIndent'#8'ShortCut'#3'I`'#0
+#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#3'M@'#0#1#7'Command'#7#12'ecInse'
+'rtLine'#8'ShortCut'#3'N@'#0#1#7'Command'#7#12'ecDeleteWord'#8'ShortCut'#3'T'
+'@'#0#1#7'Command'#7#15'ecBlockUnindent'#8'ShortCut'#3'U`'#0#1#7'Command'#7#7
+'ecPaste'#8'ShortCut'#3'V@'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'X@'#0#1#7
+'Command'#7#12'ecDeleteLine'#8'ShortCut'#3'Y@'#0#1#7'Command'#7#11'ecDeleteE'
+'OL'#8'ShortCut'#3'Y`'#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#3'Z@'#0#1#7'Co'
+'mmand'#7#6'ecRedo'#8'ShortCut'#3'Z`'#0#1#7'Command'#7#13'ecGotoMarker0'#8'S'
+'hortCut'#3'0@'#0#1#7'Command'#7#13'ecGotoMarker1'#8'ShortCut'#3'1@'#0#1#7'C'
+'ommand'#7#13'ecGotoMarker2'#8'ShortCut'#3'2@'#0#1#7'Command'#7#13'ecGotoMar'
+'ker3'#8'ShortCut'#3'3@'#0#1#7'Command'#7#13'ecGotoMarker4'#8'ShortCut'#3'4@'
+#0#1#7'Command'#7#13'ecGotoMarker5'#8'ShortCut'#3'5@'#0#1#7'Command'#7#13'ec'
+'GotoMarker6'#8'ShortCut'#3'6@'#0#1#7'Command'#7#13'ecGotoMarker7'#8'ShortCu'
+'t'#3'7@'#0#1#7'Command'#7#13'ecGotoMarker8'#8'ShortCut'#3'8@'#0#1#7'Command'
+#7#13'ecGotoMarker9'#8'ShortCut'#3'9@'#0#1#7'Command'#7#12'ecSetMarker0'#8'S'
+'hortCut'#3'0`'#0#1#7'Command'#7#12'ecSetMarker1'#8'ShortCut'#3'1`'#0#1#7'Co'
+'mmand'#7#12'ecSetMarker2'#8'ShortCut'#3'2`'#0#1#7'Command'#7#12'ecSetMarker'
+'3'#8'ShortCut'#3'3`'#0#1#7'Command'#7#12'ecSetMarker4'#8'ShortCut'#3'4`'#0#1
+#7'Command'#7#12'ecSetMarker5'#8'ShortCut'#3'5`'#0#1#7'Command'#7#12'ecSetMa'
+'rker6'#8'ShortCut'#3'6`'#0#1#7'Command'#7#12'ecSetMarker7'#8'ShortCut'#3'7`'
+#0#1#7'Command'#7#12'ecSetMarker8'#8'ShortCut'#3'8`'#0#1#7'Command'#7#12'ecS'
,'etMarker9'#8'ShortCut'#3'9`'#0#1#7'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4
+'1'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel2'#8'ShortCut'#4'2'#160#0#0#0#1#7
+'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4'3'#160#0#0#0#1#7'Command'#7#12'Ec'
+'FoldLevel1'#8'ShortCut'#4'4'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel1'#8'Sh'
+'ortCut'#4'5'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel6'#8'ShortCut'#4'6'#160
+#0#0#0#1#7'Command'#7#12'EcFoldLevel7'#8'ShortCut'#4'7'#160#0#0#0#1#7'Comman'
+'d'#7#12'EcFoldLevel8'#8'ShortCut'#4'8'#160#0#0#0#1#7'Command'#7#12'EcFoldLe'
+'vel9'#8'ShortCut'#4'9'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel0'#8'ShortCut'
+#4'0'#160#0#0#0#1#7'Command'#7#13'EcFoldCurrent'#8'ShortCut'#4'-'#160#0#0#0#1
+#7'Command'#7#15'EcUnFoldCurrent'#8'ShortCut'#4'+'#160#0#0#0#1#7'Command'#7
+#18'EcToggleMarkupWord'#8'ShortCut'#4'M'#128#0#0#0#1#7'Command'#7#14'ecNorma'
+'lSelect'#8'ShortCut'#3'N`'#0#1#7'Command'#7#14'ecColumnSelect'#8'ShortCut'#3
+'C`'#0#1#7'Command'#7#12'ecLineSelect'#8'ShortCut'#3'L`'#0#1#7'Command'#7#5
+'ecTab'#8'ShortCut'#2#9#0#1#7'Command'#7#10'ecShiftTab'#8'ShortCut'#3#9' '#0
+#1#7'Command'#7#14'ecMatchBracket'#8'ShortCut'#3'B`'#0#1#7'Command'#7#10'ecC'
+'olSelUp'#8'ShortCut'#4'&'#160#0#0#0#1#7'Command'#7#12'ecColSelDown'#8'Short'
+'Cut'#4'('#160#0#0#0#1#7'Command'#7#12'ecColSelLeft'#8'ShortCut'#4'%'#160#0#0
+#0#1#7'Command'#7#13'ecColSelRight'#8'ShortCut'#4''''#160#0#0#0#1#7'Command'
+#7#16'ecColSelPageDown'#8'ShortCut'#4'"'#160#0#0#0#1#7'Command'#7#18'ecColSe'
+'lPageBottom'#8'ShortCut'#4'"'#224#0#0#0#1#7'Command'#7#14'ecColSelPageUp'#8
+'ShortCut'#4'!'#160#0#0#0#1#7'Command'#7#15'ecColSelPageTop'#8'ShortCut'#4'!'
+#224#0#0#0#1#7'Command'#7#17'ecColSelLineStart'#8'ShortCut'#4'$'#160#0#0#0#1
+#7'Command'#7#15'ecColSelLineEnd'#8'ShortCut'#4'#'#160#0#0#0#1#7'Command'#7
+#17'ecColSelEditorTop'#8'ShortCut'#4'$'#224#0#0#0#1#7'Command'#7#20'ecColSel'
+'EditorBottom'#8'ShortCut'#4'#'#224#0#0#0#0#12'MouseActions'#14#1#5'Shift'#11
+#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'
+#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Optio'
+'n'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#0#9'ShiftMask'#11#7'ssShi'
+'ft'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDi'
+'r'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Option'#2#1#8'Priority'#2#0#0
+#1#5'Shift'#11#5'ssAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6
+'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3
+#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#5's'
+'sAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'Clic'
+'kCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3#9'MoveCaret'#9
+#6'Option'#2#1#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'
+#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2
+#12#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMa'
+'sk'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccDouble'#8'ClickDir'#7#6
+'cdDown'#7'Command'#2#6#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'S'
+'hift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccTri'
+'ple'#8'ClickDir'#7#6'cdDown'#7'Command'#2#7#9'MoveCaret'#9#6'Option'#2#0#8
+'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10
+'ClickCount'#7#6'ccQuad'#8'ClickDir'#7#6'cdDown'#7'Command'#2#8#9'MoveCaret'
+#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Butto'
+'n'#7#8'mbMiddle'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Com'
+'mand'#2#10#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#6's'
+'sCtrl'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#6'ssCtrl'#0#6'Button'#7#6'mbLe'
+'ft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#11#9'Mo'
+'veCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#15'MouseSelActions'#14#1#5'Shi'
+'ft'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingl'
+'e'#8'ClickDir'#7#6'cdDown'#7'Command'#2#9#9'MoveCaret'#8#6'Option'#2#0#8'Pr'
+'iority'#2#0#0#0#13'Lines.Strings'#1#6#12'program new;'#6#5'begin'#6#4'end.'
+#0#21'BracketHighlightStyle'#7#8'sbhsBoth'#0#18'TSynGutterPartList'#0#0#15'T'
+'SynGutterMarks'#0#5'Width'#2#23#0#0#20'TSynGutterLineNumber'#0#5'Width'#2#17
+#12'MouseActions'#14#0#21'MarkupInfo.Background'#7#9'clBtnFace'#21'MarkupInf'
+'o.Foreground'#7#6'clNone'#10'DigitCount'#2#2#30'ShowOnlyLineNumbersMultiple'
+'sOf'#2#1#9'ZeroStart'#8#12'LeadingZeros'#8#0#0#17'TSynGutterChanges'#0#5'Wi'
+'dth'#2#4#13'ModifiedColor'#4#252#233#0#0#10'SavedColor'#7#7'clGreen'#0#0#19
+'TSynGutterSeparator'#0#5'Width'#2#2#0#0#21'TSynGutterCodeFolding'#0#12'Mous'
+'eActions'#14#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#7'mbRight'#10'Cl'
+'ickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#16#9'MoveCaret'#8
+#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#7'ssShift'#0
+#6'Button'#7#8'mbMiddle'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7
,'Command'#2#14#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7
+'ssShift'#0#9'ShiftMask'#11#7'ssShift'#0#6'Button'#7#8'mbMiddle'#10'ClickCou'
+'nt'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Opt'
+'ion'#2#1#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6
+'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#0#9
+'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#21'MarkupInfo.Background'#7#6
+'clNone'#21'MarkupInfo.Foreground'#7#6'clGray'#20'MouseActionsExpanded'#14#1
+#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'cc'
+'Any'#8'ClickDir'#7#6'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Option'#2#0#8
+'Priority'#2#0#0#0#21'MouseActionsCollapsed'#14#1#5'Shift'#11#6'ssCtrl'#0#9
+'ShiftMask'#11#6'ssCtrl'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8
+'ClickDir'#7#6'cdDown'#7'Command'#2#15#9'MoveCaret'#8#6'Option'#2#0#8'Priori'
+'ty'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#6'ssCtrl'#0#6'Button'#7#6'mbLeft'
+#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#15#9'MoveCar'
+'et'#8#6'Option'#2#1#8'Priority'#2#0#0#0#0#0#0#0#8'TSynMemo'#8'SynMemo1'#6'C'
+'ursor'#7#7'crIBeam'#4'Left'#2#20#6'Height'#2'}'#3'Top'#3#131#1#5'Width'#3
+#142#2#11'Font.Height'#2#243#9'Font.Name'#6#11'Courier New'#10'Font.Pitch'#7
+#7'fpFixed'#12'Font.Quality'#7#16'fqNonAntialiased'#11'ParentColor'#8#10'Par'
+'entFont'#8#8'TabOrder'#2#2#12'Gutter.Width'#2'9'#19'Gutter.MouseActions'#14
+#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5
+'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#13#9'MoveCaret'#8#6'Option'#2#0
+#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#7'mbRight'
+#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#12#9'MoveCa'
+'ret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#10'Keystrokes'#14#1#7'Command'#7#4
+'ecUp'#8'ShortCut'#2'&'#0#1#7'Command'#7#7'ecSelUp'#8'ShortCut'#3'& '#0#1#7
+'Command'#7#10'ecScrollUp'#8'ShortCut'#3'&@'#0#1#7'Command'#7#6'ecDown'#8'Sh'
+'ortCut'#2'('#0#1#7'Command'#7#9'ecSelDown'#8'ShortCut'#3'( '#0#1#7'Command'
+#7#12'ecScrollDown'#8'ShortCut'#3'(@'#0#1#7'Command'#7#6'ecLeft'#8'ShortCut'
+#2'%'#0#1#7'Command'#7#9'ecSelLeft'#8'ShortCut'#3'% '#0#1#7'Command'#7#10'ec'
+'WordLeft'#8'ShortCut'#3'%@'#0#1#7'Command'#7#13'ecSelWordLeft'#8'ShortCut'#3
+'%`'#0#1#7'Command'#7#7'ecRight'#8'ShortCut'#2''''#0#1#7'Command'#7#10'ecSel'
+'Right'#8'ShortCut'#3''' '#0#1#7'Command'#7#11'ecWordRight'#8'ShortCut'#3''''
+'@'#0#1#7'Command'#7#14'ecSelWordRight'#8'ShortCut'#3'''`'#0#1#7'Command'#7
+#10'ecPageDown'#8'ShortCut'#2'"'#0#1#7'Command'#7#13'ecSelPageDown'#8'ShortC'
+'ut'#3'" '#0#1#7'Command'#7#12'ecPageBottom'#8'ShortCut'#3'"@'#0#1#7'Command'
+#7#15'ecSelPageBottom'#8'ShortCut'#3'"`'#0#1#7'Command'#7#8'ecPageUp'#8'Shor'
+'tCut'#2'!'#0#1#7'Command'#7#11'ecSelPageUp'#8'ShortCut'#3'! '#0#1#7'Command'
+#7#9'ecPageTop'#8'ShortCut'#3'!@'#0#1#7'Command'#7#12'ecSelPageTop'#8'ShortC'
+'ut'#3'!`'#0#1#7'Command'#7#11'ecLineStart'#8'ShortCut'#2'$'#0#1#7'Command'#7
+#14'ecSelLineStart'#8'ShortCut'#3'$ '#0#1#7'Command'#7#11'ecEditorTop'#8'Sho'
+'rtCut'#3'$@'#0#1#7'Command'#7#14'ecSelEditorTop'#8'ShortCut'#3'$`'#0#1#7'Co'
+'mmand'#7#9'ecLineEnd'#8'ShortCut'#2'#'#0#1#7'Command'#7#12'ecSelLineEnd'#8
+'ShortCut'#3'# '#0#1#7'Command'#7#14'ecEditorBottom'#8'ShortCut'#3'#@'#0#1#7
+'Command'#7#17'ecSelEditorBottom'#8'ShortCut'#3'#`'#0#1#7'Command'#7#12'ecTo'
+'ggleMode'#8'ShortCut'#2'-'#0#1#7'Command'#7#6'ecCopy'#8'ShortCut'#3'-@'#0#1
+#7'Command'#7#7'ecPaste'#8'ShortCut'#3'- '#0#1#7'Command'#7#12'ecDeleteChar'
+#8'ShortCut'#2'.'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'. '#0#1#7'Command'
+#7#16'ecDeleteLastChar'#8'ShortCut'#2#8#0#1#7'Command'#7#16'ecDeleteLastChar'
+#8'ShortCut'#3#8' '#0#1#7'Command'#7#16'ecDeleteLastWord'#8'ShortCut'#3#8'@'
+#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#4#8#128#0#0#0#1#7'Command'#7#6'ecRed'
+'o'#8'ShortCut'#4#8#160#0#0#0#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#2#13
+#0#1#7'Command'#7#11'ecSelectAll'#8'ShortCut'#3'A@'#0#1#7'Command'#7#6'ecCop'
+'y'#8'ShortCut'#3'C@'#0#1#7'Command'#7#13'ecBlockIndent'#8'ShortCut'#3'I`'#0
+#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#3'M@'#0#1#7'Command'#7#12'ecInse'
+'rtLine'#8'ShortCut'#3'N@'#0#1#7'Command'#7#12'ecDeleteWord'#8'ShortCut'#3'T'
+'@'#0#1#7'Command'#7#15'ecBlockUnindent'#8'ShortCut'#3'U`'#0#1#7'Command'#7#7
+'ecPaste'#8'ShortCut'#3'V@'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'X@'#0#1#7
+'Command'#7#12'ecDeleteLine'#8'ShortCut'#3'Y@'#0#1#7'Command'#7#11'ecDeleteE'
+'OL'#8'ShortCut'#3'Y`'#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#3'Z@'#0#1#7'Co'
+'mmand'#7#6'ecRedo'#8'ShortCut'#3'Z`'#0#1#7'Command'#7#13'ecGotoMarker0'#8'S'
+'hortCut'#3'0@'#0#1#7'Command'#7#13'ecGotoMarker1'#8'ShortCut'#3'1@'#0#1#7'C'
+'ommand'#7#13'ecGotoMarker2'#8'ShortCut'#3'2@'#0#1#7'Command'#7#13'ecGotoMar'
+'ker3'#8'ShortCut'#3'3@'#0#1#7'Command'#7#13'ecGotoMarker4'#8'ShortCut'#3'4@'
+#0#1#7'Command'#7#13'ecGotoMarker5'#8'ShortCut'#3'5@'#0#1#7'Command'#7#13'ec'
,'GotoMarker6'#8'ShortCut'#3'6@'#0#1#7'Command'#7#13'ecGotoMarker7'#8'ShortCu'
+'t'#3'7@'#0#1#7'Command'#7#13'ecGotoMarker8'#8'ShortCut'#3'8@'#0#1#7'Command'
+#7#13'ecGotoMarker9'#8'ShortCut'#3'9@'#0#1#7'Command'#7#12'ecSetMarker0'#8'S'
+'hortCut'#3'0`'#0#1#7'Command'#7#12'ecSetMarker1'#8'ShortCut'#3'1`'#0#1#7'Co'
+'mmand'#7#12'ecSetMarker2'#8'ShortCut'#3'2`'#0#1#7'Command'#7#12'ecSetMarker'
+'3'#8'ShortCut'#3'3`'#0#1#7'Command'#7#12'ecSetMarker4'#8'ShortCut'#3'4`'#0#1
+#7'Command'#7#12'ecSetMarker5'#8'ShortCut'#3'5`'#0#1#7'Command'#7#12'ecSetMa'
+'rker6'#8'ShortCut'#3'6`'#0#1#7'Command'#7#12'ecSetMarker7'#8'ShortCut'#3'7`'
+#0#1#7'Command'#7#12'ecSetMarker8'#8'ShortCut'#3'8`'#0#1#7'Command'#7#12'ecS'
+'etMarker9'#8'ShortCut'#3'9`'#0#1#7'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4
+'1'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel2'#8'ShortCut'#4'2'#160#0#0#0#1#7
+'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4'3'#160#0#0#0#1#7'Command'#7#12'Ec'
+'FoldLevel1'#8'ShortCut'#4'4'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel1'#8'Sh'
+'ortCut'#4'5'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel6'#8'ShortCut'#4'6'#160
+#0#0#0#1#7'Command'#7#12'EcFoldLevel7'#8'ShortCut'#4'7'#160#0#0#0#1#7'Comman'
+'d'#7#12'EcFoldLevel8'#8'ShortCut'#4'8'#160#0#0#0#1#7'Command'#7#12'EcFoldLe'
+'vel9'#8'ShortCut'#4'9'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel0'#8'ShortCut'
+#4'0'#160#0#0#0#1#7'Command'#7#13'EcFoldCurrent'#8'ShortCut'#4'-'#160#0#0#0#1
+#7'Command'#7#15'EcUnFoldCurrent'#8'ShortCut'#4'+'#160#0#0#0#1#7'Command'#7
+#18'EcToggleMarkupWord'#8'ShortCut'#4'M'#128#0#0#0#1#7'Command'#7#14'ecNorma'
+'lSelect'#8'ShortCut'#3'N`'#0#1#7'Command'#7#14'ecColumnSelect'#8'ShortCut'#3
+'C`'#0#1#7'Command'#7#12'ecLineSelect'#8'ShortCut'#3'L`'#0#1#7'Command'#7#5
+'ecTab'#8'ShortCut'#2#9#0#1#7'Command'#7#10'ecShiftTab'#8'ShortCut'#3#9' '#0
+#1#7'Command'#7#14'ecMatchBracket'#8'ShortCut'#3'B`'#0#1#7'Command'#7#10'ecC'
+'olSelUp'#8'ShortCut'#4'&'#160#0#0#0#1#7'Command'#7#12'ecColSelDown'#8'Short'
+'Cut'#4'('#160#0#0#0#1#7'Command'#7#12'ecColSelLeft'#8'ShortCut'#4'%'#160#0#0
+#0#1#7'Command'#7#13'ecColSelRight'#8'ShortCut'#4''''#160#0#0#0#1#7'Command'
+#7#16'ecColSelPageDown'#8'ShortCut'#4'"'#160#0#0#0#1#7'Command'#7#18'ecColSe'
+'lPageBottom'#8'ShortCut'#4'"'#224#0#0#0#1#7'Command'#7#14'ecColSelPageUp'#8
+'ShortCut'#4'!'#160#0#0#0#1#7'Command'#7#15'ecColSelPageTop'#8'ShortCut'#4'!'
+#224#0#0#0#1#7'Command'#7#17'ecColSelLineStart'#8'ShortCut'#4'$'#160#0#0#0#1
+#7'Command'#7#15'ecColSelLineEnd'#8'ShortCut'#4'#'#160#0#0#0#1#7'Command'#7
+#17'ecColSelEditorTop'#8'ShortCut'#4'$'#224#0#0#0#1#7'Command'#7#20'ecColSel'
+'EditorBottom'#8'ShortCut'#4'#'#224#0#0#0#0#12'MouseActions'#14#1#5'Shift'#11
+#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'
+#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Optio'
+'n'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#0#9'ShiftMask'#11#7'ssShi'
+'ft'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDi'
+'r'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Option'#2#1#8'Priority'#2#0#0
+#1#5'Shift'#11#5'ssAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6
+'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3
+#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#5's'
+'sAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'Clic'
+'kCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3#9'MoveCaret'#9
+#6'Option'#2#1#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'
+#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2
+#12#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMa'
+'sk'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccDouble'#8'ClickDir'#7#6
+'cdDown'#7'Command'#2#6#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'S'
+'hift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccTri'
+'ple'#8'ClickDir'#7#6'cdDown'#7'Command'#2#7#9'MoveCaret'#9#6'Option'#2#0#8
+'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10
+'ClickCount'#7#6'ccQuad'#8'ClickDir'#7#6'cdDown'#7'Command'#2#8#9'MoveCaret'
+#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Butto'
+'n'#7#8'mbMiddle'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Com'
+'mand'#2#10#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#6's'
+'sCtrl'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#6'ssCtrl'#0#6'Button'#7#6'mbLe'
+'ft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#11#9'Mo'
+'veCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#15'MouseSelActions'#14#1#5'Shi'
+'ft'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingl'
+'e'#8'ClickDir'#7#6'cdDown'#7'Command'#2#9#9'MoveCaret'#8#6'Option'#2#0#8'Pr'
+'iority'#2#0#0#0#13'Lines.Strings'#1#6#8'SynMemo1'#0#8'OnChange'#7#14'SynMem'
+'o1Change'#0#18'TSynGutterPartList'#0#0#15'TSynGutterMarks'#0#5'Width'#2#23#0
+#0#20'TSynGutterLineNumber'#0#5'Width'#2#17#12'MouseActions'#14#0#21'MarkupI'
,'nfo.Background'#7#9'clBtnFace'#21'MarkupInfo.Foreground'#7#6'clNone'#10'Dig'
+'itCount'#2#2#30'ShowOnlyLineNumbersMultiplesOf'#2#1#9'ZeroStart'#8#12'Leadi'
+'ngZeros'#8#0#0#17'TSynGutterChanges'#0#5'Width'#2#4#13'ModifiedColor'#4#252
+#233#0#0#10'SavedColor'#7#7'clGreen'#0#0#19'TSynGutterSeparator'#0#5'Width'#2
+#2#0#0#21'TSynGutterCodeFolding'#0#12'MouseActions'#14#1#5'Shift'#11#0#9'Shi'
+'ftMask'#11#0#6'Button'#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'
+#7#4'cdUp'#7'Command'#2#16#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5
+'Shift'#11#0#9'ShiftMask'#11#7'ssShift'#0#6'Button'#7#8'mbMiddle'#10'ClickCo'
+'unt'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Op'
+'tion'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#0#9'ShiftMask'#11#7'ss'
+'Shift'#0#6'Button'#7#8'mbMiddle'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6
+'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Option'#2#1#8'Priority'#2#0#0#1#5
+'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAn'
+'y'#8'ClickDir'#7#6'cdDown'#7'Command'#2#0#9'MoveCaret'#8#6'Option'#2#0#8'Pr'
+'iority'#2#0#0#0#21'MarkupInfo.Background'#7#6'clNone'#21'MarkupInfo.Foregro'
+'und'#7#6'clGray'#20'MouseActionsExpanded'#14#1#5'Shift'#11#0#9'ShiftMask'#11
+#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7
+'Command'#2#14#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#21'MouseActi'
+'onsCollapsed'#14#1#5'Shift'#11#6'ssCtrl'#0#9'ShiftMask'#11#6'ssCtrl'#0#6'Bu'
+'tton'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Comma'
+'nd'#2#15#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'S'
+'hiftMask'#11#6'ssCtrl'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8
+'ClickDir'#7#6'cdDown'#7'Command'#2#15#9'MoveCaret'#8#6'Option'#2#1#8'Priori'
+'ty'#2#0#0#0#0#0#0#0#17'TSynFreePascalSyn'#17'SynFreePascalSyn1'#7'Enabled'#8
+#12'CompilerMode'#7#9'pcmObjFPC'#14'NestedComments'#9#4'left'#3#242#1#3'top'
+#2'Y'#0#0#0
]);

24
Projects/SAMufasaGUI/testunit.pas
View File

@ -6,7 +6,8 @@ interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, Client, MufasaTypes, mmlthread;
StdCtrls, SynEdit, SynHighlighterPas, SynMemo, Client, MufasaTypes,
mmlpsthread;
type
@ -14,7 +15,11 @@ type
TForm1 = class(TForm)
Button1: TButton;
SynEdit1: TSynEdit;
SynFreePascalSyn1: TSynFreePascalSyn;
SynMemo1: TSynMemo;
procedure Button1Click(Sender: TObject);
procedure SynMemo1Change(Sender: TObject);
private
{ private declarations }
public
@ -254,13 +259,24 @@ end;
procedure TForm1.Button1Click(Sender: TObject);
Var
//MyThread: TMyThread;
MMLThread: TMMLThread;
// MMLThread: TMMLThread;
MMLPSThread : TMMLPSThread;
begin
{ MyThread := TMyThread.Create(True);
MyThread.Resume; }
MMLThread := TMMLThread.Create(True);
MMLThread.Resume;
{ MMLThread := TMMLThread.Create(True);
MMLThread.Resume;}
MMLPSThread := TMMLPSThread.Create(True);
MMLPSThread.SetPSScript(SynEdit1.Lines.Text);
MMLPSThread.SetDebug(SynMemo1);
MMLPSThread.Resume;
end;
procedure TForm1.SynMemo1Change(Sender: TObject);
begin
end;
initialization

245
Units/MMLAddon/mmlpsthread.pas Normal file
View File

@ -0,0 +1,245 @@
unit mmlpsthread;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,SynMemo;
type
{ TMMLPSThread }
TMMLPSThread = class(TThread)
protected
// PSScript : TPSScript;
// PSClient : TPSScript;
// Client: TClient;
// DebugTo : TStrings;
Client : TClient;
PSScript : TPSScript;
DebugTo : TSynMemo;
procedure OnCompile(Sender: TPSScript);
procedure AfterExecute(Sender : TPSScript);
function RequireFile(Sender: TObject; const OriginFileName: String;
var FileName, OutPut: string): Boolean;
procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler);
procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
procedure OutputMessages;
procedure Execute; override;
public
procedure SetPSScript(Script : string);
procedure SetDebug( Strings : TSynMemo );
function SetClientInfo : boolean;
// function CompilePSScript : boolean;
// function
constructor Create(CreateSuspended: Boolean);
destructor Destroy;
end;
implementation
uses
MufasaTypes,{$ifdef mswindows}windows,{$endif}
uPSC_std, uPSC_Controls,uPSC_Classes,uPSC_Graphics,uPSC_stdctrls,uPSC_Forms,uPSC_extctrls, //Compile-libs
uPSR_std, uPSR_Controls,uPSR_Classes,uPSR_Graphics,uPSR_stdctrls,uPSR_Forms,uPSR_extctrls; //Runtime-libs
threadvar
CurrThread : TMMLPSThread;
{Some General PS Functions here}
procedure Writeln(str : string);
begin;
if CurrThread.DebugTo <> nil then
CurrThread.DebugTo.Lines.Add(Str);
//Just overwriting itz.. soz.
end;
function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;
var
i : integer;
begin;
Writeln('We have a length of: ' + inttostr(length(v)));
Try
Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname));
Except
Writeln('We has some errors :-(');
end;
end;
{
Note to Raymond: For PascalScript, Create it on the .Create,
Execute it on the .Execute, and don't forget to Destroy it on .Destroy.
Furthermore, all the wrappers can be in the unit "implementation" section.
Better still to create an .inc for it, otherwise this unit will become huge.
(You can even split up the .inc's in stuff like color, bitmap, etc. )
Also, don't add PS to this unit, but make a seperate unit for it.
Unit "MMLPSThread", perhaps?
See the TestUnit for use of this thread, it's pretty straightforward.
It may also be wise to turn the "Importing of wrappers" into an include as
well, it will really make the unit more straightforward to use and read.
}
constructor TMMLPSThread.Create(CreateSuspended : boolean);
begin
if Client <> nil then
Writeln('ThreadClient seems to be set, so not recreating it.') //reset client to defaults?
//ThreadClient.ResetToDefaults
else
Client := TClient.Create;
if PSScript <> nil then
PSScript.Free;
// Create Stuff here
PSScript := TPSScript.Create(nil);
PSScript.UsePreProcessor:= True;
PSScript.OnNeedFile := @RequireFile;
PSScript.OnCompile:= @OnCompile;
PSScript.OnCompImport:= @OnCompImport;
PSScript.OnExecImport:= @OnExecImport;
PSScript.OnAfterExecute:= @AfterExecute;
{$IFDEF CPU386 }
PSScript.Defines.Add ('CPU386');
{$ENDIF }
PSScript.Defines.Add ('MUFASA');
PSScript.Defines.Add ('COGAT');
PSScript.Defines.Add ('RAYMONDPOWNS');
{$IFDEF MSWINDOWS }
PSScript.Defines.Add ('MSWINDOWS');
PSScript.Defines.Add ('WIN32');
PSScript.Defines.Add ('WINDOWS');
{$ENDIF }
{$IFDEF LINUX }
PSScript.Defines.Add ('LINUX');
{$ENDIF }
FreeOnTerminate := True;
inherited Create(CreateSuspended);
end;
destructor TMMLPSThread.Destroy;
begin
Client.Free;
PSScript.Free;
inherited Destroy;
end;
procedure TMMLPSThread.OnCompile(Sender: TPSScript);
begin
//Here we add all the initalizing, of BMPArray etc
Sender.AddFunction(@ThreadSafeCall,'function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;');
Sender.AddFunction(@Writeln,'procedure writeln(s : string);');
//Also the functions get added into the engine, right here.
end;
procedure TMMLPSThread.AfterExecute(Sender: TPSScript);
begin
//Here we add all the Script-freeing-leftovers (like BMParray etc)
end;
function TMMLPSThread.RequireFile(Sender: TObject;
const OriginFileName: String; var FileName, OutPut: string): Boolean;
begin
end;
procedure TMMLPSThread.OnCompImport(Sender: TObject; x: TPSPascalCompiler);
begin
SIRegister_Std(x);
SIRegister_Controls(x);
SIRegister_Classes(x, true);
SIRegister_Graphics(x, true);
SIRegister_stdctrls(x);
SIRegister_Forms(x);
SIRegister_ExtCtrls(x);
end;
procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec;
x: TPSRuntimeClassImporter);
begin
RIRegister_Std(x);
RIRegister_Classes(x, True);
RIRegister_Controls(x);
RIRegister_Graphics(x, True);
RIRegister_stdctrls(x);
RIRegister_Forms(x);
RIRegister_ExtCtrls(x);
end;
procedure TMMLPSThread.OutputMessages;
var
l: Longint;
b: Boolean;
begin
b := False;
for l := 0 to PSScript.CompilerMessageCount - 1 do
begin
Writeln(PSScript.CompilerErrorToStr(l));
if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then
begin
b := True;
// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos;
end;
end;
end;
procedure TMMLPSThread.Execute;
var
time, i, ii: Integer;
begin;
CurrThread := Self;
time := GetTickCount;
try
if PSScript.Compile then
begin
OutputMessages;
Writeln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.');
// if not (ScriptState = SCompiling) then
if not PSScript.Execute then
begin
// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition;
Writeln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.'
+Inttostr(PSScript.ExecErrorByteCodePosition));
end else Writeln('Succesfully executed');
end else
begin
OutputMessages;
Writeln('Compiling failed');
end;
except
on E : Exception do
Writeln('Error: ' + E.Message);
end;
end;
procedure TMMLPSThread.SetPSScript(Script: string);
begin
PSScript.Script.Text:= Script;
end;
procedure TMMLPSThread.SetDebug(Strings: TSynMemo);
begin
DebugTo := Strings;
end;
function TMMLPSThread.SetClientInfo: boolean;
begin
//Set the client handle, etc
end;
{ Include stuff here? }
//{$I inc/colors.inc}
//{$I inc/bitmaps.inc}
end.

2
Units/MMLCore/mufasatypes.pas
View File

@ -23,7 +23,7 @@ type
TClickType = (mouse_Left, mouse_Right, mouse_Middle);
TMousePress = (mouse_Down, mouse_Up);
TPointArray = array of TPoint;
TVariantArray = Array of Variant;
implementation

62
Units/PascalScript/PascalScript.inc Normal file
View File

@ -0,0 +1,62 @@
{----------------------------------------------------------------------------}
{ RemObjects Pascal Script }
{ }
{ compiler: Delphi 2 and up, Kylix 3 and up }
{ platform: Win32, Linux }
{ }
{ (c)opyright RemObjects Software. all rights reserved. }
{ }
{----------------------------------------------------------------------------}
{$INCLUDE eDefines.inc}
{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF}
{$IFDEF VER125}{C4}{$B-}{$X+}{$T-}{$H+}{$ENDIF}
{$IFDEF VER110}{C3}{$B-}{$X+}{$T-}{$H+}{$ENDIF}
{$IFDEF VER93}{C1}{$B-}{$X+}{$T-}{$H+}{$ENDIF}
{$IFDEF DELPHI4UP}
{$DEFINE PS_HAVEVARIANT}
{$DEFINE PS_DYNARRAY}
{$ENDIF}
{$IFNDEF FPC}
{$B-}{$X+}{$T-}{$H+}
{$ELSE}
{$R-}{$Q-}
{$ENDIF}
{$IFNDEF FPC}
{$IFNDEF DELPHI4UP}
{$IFNDEF LINUX}
{$DEFINE PS_NOINT64}
{$ENDIF}
{$ENDIF}
{$IFDEF DELPHI2}
{$DEFINE PS_NOINT64}
{$DEFINE PS_NOWIDESTRING}
{$B-}{$X+}{$T-}{$H+}
{$ENDIF}
{$IFDEF LINUX}{KYLIX}{$DEFINE CLX}{$DEFINE DELPHI3UP}{$DEFINE DELPHI6UP}{$ENDIF}
{$ENDIF}
{$R-}{$Q-}
{
Defines:
IFPS3_NOSMARTLIST - Don't use the smart list option
}
{$UNDEF DEBUG}
{$IFDEF CLX}
{$DEFINE PS_NOIDISPATCH} // not implemented
{$ENDIF}
{$IFDEF FPC}
{$I PascalScriptFPC.inc}
{$ENDIF}

15
Units/PascalScript/PascalScriptFPC.inc Normal file
View File

@ -0,0 +1,15 @@
{$DEFINE PS_HAVEVARIANT}
{$DEFINE PS_DYNARRAY}
{$DEFINE PS_NOIDISPATCH}
{$if (fpc_version=2) and (fpc_release>=3) and (fpc_patch>=1)}
{.$if (fpc_version=2) and (fpc_release>=2) and (fpc_patch>=4)}
{$UNDEF FPC_OLD_FIX}
{$UNDEF PS_FPCSTRINGWORKAROUND}
{FreePascal 2.3.1 and above has much Delphi compatibility bugs fixed}
{$else}
{$DEFINE FPC_OLD_FIX}
{$DEFINE PS_FPCSTRINGWORKAROUND}
{$ifend}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI6UP}

30
Units/PascalScript/PascalScript_Core_Ext_Reg.pas Normal file
View File

@ -0,0 +1,30 @@
unit PascalScript_Core_Ext_Reg;
{----------------------------------------------------------------------------}
{ RemObjects Pascal Script }
{ }
{ compiler: Delphi 2 and up, Kylix 3 and up }
{ platform: Win32, Linux }
{ }
{ (c)opyright RemObjects Software. all rights reserved. }
{ }
{----------------------------------------------------------------------------}
{$I PascalScript.inc}
interface
procedure Register;
implementation
uses
Classes,
uPSComponentExt;
procedure Register;
begin
RegisterComponents('RemObjects Pascal Script',[TPSScriptExtension]);
end;
end.

65
Units/PascalScript/PascalScript_Core_Reg.pas Normal file
View File

@ -0,0 +1,65 @@
unit PascalScript_Core_Reg;
{----------------------------------------------------------------------------
/ RemObjects Pascal Script
/
/ compiler: Delphi 2 and up, Kylix 3 and up
/ platform: Win32, Linux
/
/ (c)opyright RemObjects Software. all rights reserved.
/
----------------------------------------------------------------------------}
{$I PascalScript.inc}
interface
{$IFNDEF FPC}
{$R PascalScript_Core_Glyphs.res}
{$ENDIF}
procedure Register;
implementation
uses
Classes,
{$IFDEF FPC}
LResources,
{$ENDIF}
uPSComponent,
uPSDebugger,
uPSComponent_Default,
{$IFNDEF FPC}
uPSComponent_COM,
{$ENDIF}
uPSComponent_DB,
uPSComponent_Forms,
uPSComponent_Controls,
uPSComponent_StdCtrls;
procedure Register;
begin
RegisterComponents('Pascal Script', [TPSScript,
TPSScriptDebugger,
TPSDllPlugin,
TPSImport_Classes,
TPSImport_DateUtils,
{$IFNDEF FPC}
TPSImport_ComObj,
{$ENDIF}
TPSImport_DB,
TPSImport_Forms,
TPSImport_Controls,
TPSImport_StdCtrls,
TPSCustumPlugin]);
end;
{$IFDEF FPC}
initialization;
{$i pascalscript.lrs}
{$ENDIF}
end.

48
Units/PascalScript/PascalScript_Core_Reg_noDB.pas Normal file
View File

@ -0,0 +1,48 @@
unit PascalScript_Core_Reg_noDB;
{----------------------------------------------------------------------------}
{ RemObjects Pascal Script
{
{ compiler: Delphi 2 and up, Kylix 3 and up
{ platform: Win32, Linux
{
{ (c)opyright RemObjects Software. all rights reserved.
{
{----------------------------------------------------------------------------}
{$I PascalScript.inc}
interface
{$R PascalScript_Core_Glyphs.res}
procedure Register;
implementation
uses
Classes,
uPSComponent,
uPSComponentExt,
uPSDebugger,
uPSComponent_Default,
uPSComponent_COM,
uPSComponent_Forms,
uPSComponent_Controls,
uPSComponent_StdCtrls;
procedure Register;
begin
RegisterComponents('Pascal Script', [TPSScript,
TPSScriptDebugger,
TPSDllPlugin,
TPSImport_Classes,
TPSImport_DateUtils,
TPSImport_ComObj,
TPSImport_Forms,
TPSImport_Controls,
TPSImport_StdCtrls,
TPSScriptExtension]);
end;
end.

34
Units/PascalScript/PascalScript_RO_Reg.pas Normal file
View File

@ -0,0 +1,34 @@
unit PascalScript_RO_Reg;
{----------------------------------------------------------------------------}
{ RemObjects Pascal Script
{
{ compiler: Delphi 2 and up, Kylix 3 and up
{ platform: Win32, Linux
{
{ (c)opyright RemObjects Software. all rights reserved.
{
{ Using this code requires a valid license of Pascal Script
{ which can be obtained at http://www.remobjects.com.
{----------------------------------------------------------------------------}
{$I PascalScript.inc}
interface
{$R PascalScript_RO_Glyphs.res}
procedure Register;
implementation
uses
Classes,
uROPSServerLink;
procedure Register;
begin
RegisterComponents('Pascal Script', [TPSRemObjectsSdkPlugin]);
end;
end.

312
Units/PascalScript/arm.inc Normal file
View File

@ -0,0 +1,312 @@
{ implementation of the arm procedure call standard for function calls in pascal script
Copyright (c) 2008 by Henry Vermaak (henry.vermaak@gmail.com)
todo: add eabi (define FPC_ABI_EABI) and wince support
notes:
most arm cpus don't allow unaligned access. by default (?) the linux kernel
is set up to try and correct unaligned access, which can lead to strange behaviour.
to turn this off, try (as root):
echo 4 > /proc/cpu/alignment
if you have an alignment problem, you will now get a crash with a backtrace like this:
(make sure you compile with -O- -gl)
An unhandled exception occurred at $0006C014 :
EBusError : Bus error or misaligned data access
$0006C014 PROCESSREPEAT, line 9670 of upscompiler.pas
$00068AAC TPSPASCALCOMPILER__PROCESSSUB, line 10459 of upscompiler.pas
$0007D0B4 TPSPASCALCOMPILER__COMPILE, line 11704 of upscompiler.pas
you can fix this by using the "unaligned" keyword around the pointer operation.
search for occurances of "unaligned" to see how this is done,
(use $ifdef FPC_REQUIRES_PROPER_ALIGNMENT).
for more information, visit:
http://www.aleph1.co.uk/oldsite/armlinux/book/afaq.html
}
const
rtINT = 0;
rtINT64 = 1;
rtFLOAT = 2;
type
Trint = array[1..4] of dword;
Trfloat = array[1..4] of double;
{$goto on}
{ define labels }
label
stack_loop,
load_regs,
asmcall_end,
int_result,
int64_result,
float_result;
{ call a function from a pointer }
{ resulttype: 0 = int, 1 = int64, 2 = float }
function armasmcall(rint: Trint; rfloat: Trfloat; proc, stack: pointer; stacksize, resulttype: integer): pointer; assembler; nostackframe;
asm
mov r12, r13
stmfd r13!, {r4, r5, r6, r7, r8, r9, r10, r11, r12, r14, r15}
sub r11, r12, #4
mov r4, #80 (* space for preserved registers and parameters *)
ldr r5, [r11, #4] (* stacksize we need for subroutine *)
add r4, r4, r5
sub r13, r13, r4 (* create stack space *)
(* store parameters on stack *)
str r0, [r11, #-44] (* rint *)
str r1, [r11, #-48] (* rfloat *)
str r2, [r11, #-52] (* proc *)
str r3, [r11, #-56] (* stack *)
ldr r0, [r11, #4]
str r0, [r11, #-60] (* stacksize *)
ldr r0, [r11, #8]
str r0, [r11, #-64] (* resulttype *)
(* store params for sub-routine that don't fit into r0-r3 at start of stack *)
ldr r0, [r11, #-60] (* stacksize *)
cmp r0, #0
beq load_regs (* skip if no stack *)
mov r1, r13 (* this points to the bottom now *)
ldr r2, [r11, #-56] (* stack pointer *)
stack_loop:
ldmia r2!, {r4} (* get stack + update pos *)
stmia r1!, {r4} (* store stack + update pos *)
subs r0, r0, #4
bne stack_loop
load_regs:
(* load general regs *)
ldr r4, [r11, #-44] (* rint *)
ldr r0, [r4]
ldr r1, [r4, #4]
ldr r2, [r4, #8]
ldr r3, [r4, #12]
{$ifdef FPUFPA}
(* load float regs *)
ldr r4, [r11, #-48] (* rfloat *)
ldfd f0, [r4]
ldfd f1, [r4, #8]
ldfd f2, [r4, #16]
ldfd f3, [r4, #24]
{$endif}
(* branch to the proc pointer *)
ldr r4, [r11, #-52]
mov r14, r15
mov r15, r4
(* blx r4 *)
ldr r4, [r11, #-64] (* get resulttype *)
cmp r4, #1
blt int_result
beq int64_result
bgt float_result
int_result:
str r0, [r11, #-72]
b asmcall_end
int64_result:
str r0, [r11, #-72]
str r1, [r11, #-68]
b asmcall_end
float_result:
{$ifdef FPUFPA}
stfd f0, [r11, #-72]
{$else}
b int64_result
{$endif}
b asmcall_end
asmcall_end:
sub r0, r11, #72 (* return pointer to result on stack *)
ldmea r11,{r4,r5,r6,r7,r8,r9,r10,r11,r13,r15}
end;
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
var
rint: Trint; { registers r0 to r3 }
rfloat: Trfloat; { registers f0 to f3 }
st: packed array of byte; { stack }
i, j, rindex, findex, stindex: integer;
fvar: PPSVariantIFC;
IsConstructor: Boolean;
{ add a dword to stack }
procedure addstackdword(value: dword);
begin
setlength(st, stindex+4);
pdword(@st[stindex])^ := value;
inc(stindex, 4);
end;
{ add a float to stack }
procedure addstackfloat(value: pointer; size: integer);
begin
setlength(st, stindex + (size * 4));
if size = 1
then psingle(@st[stindex])^ := single(value^)
else pdouble(@st[stindex])^ := double(value^);
inc(stindex, size*4);
end;
{ add to the general registers or overflow to stack }
procedure addgen(value: dword);
begin
if rindex <= 4
then begin
rint[rindex] := value;
inc(rindex);
end
else begin
addstackdword(value);
end;
end;
{ add to the float registers or overflow to stack }
{ size = 1 for single, 2 for double }
procedure addfloat(value: pointer; size: integer);
begin
if findex <= 4
then begin
if size = 1
then rfloat[findex] := single(value^)
else rfloat[findex] := double(value^);
inc(findex);
end
else begin
addstackfloat(value, size);
end;
end;
begin
if (Integer(CallingConv) and 64) <> 0 then begin
IsConstructor := true;
CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64);
end else IsConstructor := false;
rindex := 1;
findex := 1;
stindex := 0;
setlength(st, stindex);
Result := False;
{ the pointer of the result needs to be passed first in the case of some result types }
if assigned(res)
then begin
case res.atype.basetype of
btStaticArray, btRecord: addgen(dword(res.dta));
end;
end;
{ process all parameters }
for i := 0 to Params.Count-1 do begin
if Params[i] = nil
then Exit;
fvar := Params[i];
{ cook dynamic arrays - fpc stores size-1 at @array-4 }
if (fvar.aType.BaseType = btArray)
then dec(pdword(pointer(fvar.dta^)-4)^);
if fvar.varparam
then begin { var param }
case fvar.aType.BaseType of
{ add var params here }
btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF}
btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: addgen(dword(fvar.dta));
else begin
writeln(stderr, 'Parameter type not recognised!');
Exit;
end;
end; { case }
end else begin { not a var param }
case fvar.aType.BaseType of
// btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
// btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
// {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: writeln('normal param');
{ add normal params here }
btString: addgen(dword(pstring(fvar.dta)^));
btU8, btS8: addgen(dword(pbyte(fvar.dta)^));
btU16, BtS16: addgen(dword(pword(fvar.dta)^));
btU32, btS32: addgen(dword(pdword(fvar.dta)^));
btSingle: {$ifdef FPUFPA}
addfloat(fvar.dta, 1);
{$else}
addgen(dword(psingle(fvar.dta)^));
{$endif}
btDouble{, btExtended}: {$ifdef FPUFPA}
addfloat(fvar.dta, 2);
{$else}
begin
addgen(lo(qword(pdouble(fvar.dta)^)));
addgen(hi(qword(pdouble(fvar.dta)^)));
end;
{$endif}
btPChar: addgen(dword(ppchar(fvar.dta)^));
btChar: addgen(dword(pchar(fvar.dta)^));
{$IFNDEF PS_NOINT64}bts64:{$ENDIF} begin
addgen(dword(pint64(fvar.dta)^ and $ffffffff));
addgen(dword(pint64(fvar.dta)^ shr 32));
end;
btStaticArray: addgen(dword(fvar.dta));
btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do
addgen(pdword(fvar.dta + j*4)^);
btArray: addstackdword(dword(fvar.dta^)); { this is a bit weird }
{ btVariant, btSet, btInterface, btClass }
else begin
writeln(stderr, 'Parameter type not implemented!');
Exit;
end;
end; { case }
end; { else }
end; { for }
if not assigned(res)
then begin
armasmcall(rint, rfloat, address, st, stindex, rtINT); { ignore return }
end
else begin
case res.atype.basetype of
{ add result types here }
btString: pstring(res.dta)^ := pstring(armasmcall(rint, rfloat, address, st, stindex, rtINT))^;
btU8, btS8: pbyte(res.dta)^ := byte(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
btU16, btS16: pword(res.dta)^ := word(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
btU32, btS32: pdword(res.dta)^ := pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^;
btSingle: psingle(res.dta)^ := pdouble(armasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
btDouble{, btExtended}: pdouble(res.dta)^ := pdouble(armasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
btPChar: ppchar(res.dta)^ := pchar(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
btChar: pchar(res.dta)^ := char(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
btStaticArray, btRecord: armasmcall(rint, rfloat, address, st, stindex, rtINT);
btArray: res.dta := armasmcall(rint, rfloat, address, st, stindex, rtINT);
else begin
writeln(stderr, 'Result type not implemented!');
exit;
end; { else }
end; { case }
end;
{ cook dynamic arrays - fpc stores size-1 at @array-4 }
for i := 0 to Params.Count-1 do begin
fvar := Params[i];
if (fvar.aType.BaseType = btArray)
then inc(pdword(pointer(fvar.dta^)-4)^);
end;
Result := True;
end;

493
Units/PascalScript/eDefines.inc Normal file
View File

@ -0,0 +1,493 @@
{----------------------------------------------------------------------------}
{file: eDefines.inc }
{type: Delphi include file }
{ }
{compiler: Borland Pascal 7, }
{ Delphi 1-7, 2005-2007 for Win32 }
{ Kylix 1-3, }
{ C++Builder 1-6, 2006-2007 }
{ Free Pascal Compiler 2.x }
{ }
{platforms: DOS, DPMI, Win16, Win32, Win64, Linux, Mac OS X }
{ }
{author: mh@elitedev.com }
{ }
{contents: Defines that can be flexibily used to determine the exact }
{ compiler version used. }
{ }
{(c)opyright elitedevelopments software. all rights reserved. }
{ http://www.elitedev.com }
{ }
{ Third Party component developers are encouraged to use the set of defines }
{ established in this file, rather then their own system, for checking their }
{ component libraries agains different versions of Delphi and C++Builder. }
{ }
{ This file may be distributed freely with both free and commercial source }
{ libraries, but you are asked to please leave this comment in place, and }
{ to return any improvements you make to this file to the maintainer that }
{ is noted above. }
{----------------------------------------------------------------------------}
{----------------------------------------------------------------------------}
{ Compiler and OS version defines: }
{ }
{ exact compiler versions: }
{ }
{ BP7 Borland Pascal 7.0 }
{ DELPHI1 Delphi 1.0 (any Delphi) }
{ DELPHI2 Delphi 2.0 }
{ DELPHI3 Delphi 3.0 }
{ DELPHI4 Delphi 4.0 }
{ DELPHI5 Delphi 5.0 }
{ DELPHI6 Delphi 6.0 }
{ DELPHI7 Delphi 7.0 }
{ DELPHI9 Delphi 2005 }
{ DELPHI2005 Delphi 2005 }
{ DELPHI2006 Delphi 2006 }
{ DELPHI2007 Delphi 2007 }
{ KYLIX1 Kylix 1.0 }
{ KYLIX2 Kylix 2.0 }
{ KYLIX3 Kylix 3.0 }
{ CBUILDER1 C++Builder 1.0 }
{ CBUILDER3 C++Builder 3.0 }
{ CBUILDER4 C++Builder 4.0 }
{ CBUILDER5 C++Builder 5.0 }
{ }
{ }
{ minimum compiler versions: }
{ }
{ DELPHI1UP Delphi 1.0 and above (any Delphi) }
{ DELPHI2UP Delphi 2.0 and above }
{ DELPHI3UP Delphi 3.0 and above }
{ DELPHI4UP Delphi 4.0 and above }
{ DELPHI5UP Delphi 5.0 and above }
{ DELPHI6UP Delphi 6.0 and above }
{ DELPHI7UP Delphi 7.0 and above }
{ DELPHI9UP Delphi 9.0 (2005) and above }
{ DELPHI10UP Delphi 10.0 (2006) and above }
{ DELPHI11UP Delphi 11.0 (2007) and above }
{ DELPHI2005UP Delphi 2005 and above }
{ DELPHI2006UP Delphi 2006 and above }
{ DELPHI2007UP Delphi 2007 and above }
{ KYLIX1UP Kylix 1.0 and above (any Kylix) }
{ KYLIX2UP Kylix 2.0 and above (any Kylix) }
{ KYLIX3UP Kylix 3.0 and above (any Kylix) }
{ CBUILDER1UP C++Builder 1.0 and above or Delphi 2 and above }
{ CBUILDER3UP C++Builder 3.0 and above or Delphi 3.0 and above }
{ CBUILDER4UP C++Builder 4.0 and above or Delphi 4.0 and above }
{ CBUILDER5UP C++Builder 5.0 and above or Delphi 5.0 and above }
{ CBUILDER6UP C++Builder 5.0 and above or Delphi 5.0 and above }
{ }
{ }
{ compiler types: }
{ }
{ BP Borland Pascal (not Delphi or C++Builder) }
{ DELPHI any Delphi version (but not C++Builder or Kylix) }
{ KYLIX any Kylix version (not Delphi or C++Builder for Windows) }
{ CBUILDER any C++Builder for Windows (Pascal) }
{ }
{ }
{ target platforms compiler types: }
{ }
{ DELPHI_16BIT 16bit Delphi (but not C++Builder!) }
{ DELPHI_32BIT 32bit Delphi (but not C++Builder) }
{ KYLIX_32BIT 32bit Kylix (but not C++Builder) }
{ CBUILDER_32BIT 32bit C++Builer's Pascal (but not Delphi) }
{ }
{ }
{ target cpu types }
{ }
{ CPU16 16bit Delphi or Borland Pascal }
{ CPU32 32bit Delphi or Free Pascal }
{ CPU64 64bit Free Pascal }
{ }
{ target platforms }
{ }
{ DOS any DOS (plain and DPMI) }
{ REALMODE 16bit realmode DOS }
{ PROTECTEDMODE 16bit DPMI DOS }
{ }
{ MSWINDOWS any Windows platform }
{ WIN16 16bit Windows }
{ WIN32 32bit Windows }
{ WIN64 64bit Windows }
{ DOTNET .NET }
{ }
{ LINUX any Linux platform }
{ LINUX32 32bit Linux }
{ LINUX64 64bit Linux }
{ }
{ DARWIN Any Mac OS X }
{ DARWIN32 32bit Mac OS X }
{ DARWIN64 64bit Mac OS X }
{----------------------------------------------------------------------------}
{ defines for Borland Pascal 7.0 }
{$IFDEF VER70}
{$DEFINE BP}
{$DEFINE BP7}
{$DEFINE 16BIT}
{$DEFINE CPU16}
{ defines for BP7 DOS real mode }
{$IFDEF MSDOS}
{$DEFINE DOS}
{$DEFINE REALMODE}
{$ENDIF}
{ defines for BP7 DOS protected mode }
{$IFDEF DPMI}
{$DEFINE DOS}
{$DEFINE PROTECTEDMODE}
{$ENDIF}
{ defines for BP7 Windows }
{$IFDEF WINDOWS}
{$DEFINE MSWINDOWS}
{$DEFINE WIN16}
{$ENDIF}
{$ENDIF}
{ defines for Delphi 1.0 thru 7.0 }
{$IFDEF MSWINDOWS}
{ defines for Delphi 1.0 }
{$IFDEF VER80}
{$DEFINE DELPHI}
{$DEFINE DELPHI1}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI_16BIT}
{$DEFINE WIN16}
{$DEFINE 16BIT}
{$DEFINE CPU16}
{$ENDIF}
{ defines for Delphi 2.0 }
{$IFDEF VER90}
{$DEFINE DELPHI}
{$DEFINE DELPHI2}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$ENDIF}
{ defines for C++Builder 1.0 }
{$IFDEF VER93}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE CBUILDER}
{$DEFINE CBUILDER1}
{$DEFINE CBUILDER1UP}
{$ENDIF}
{ defines for Delphi 3.0 }
{$IFDEF VER100}
{$DEFINE DELPHI}
{$DEFINE DELPHI3}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$ENDIF}
{ defines for C++Builder 3.0 }
{$IFDEF VER110}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE CBUILDER}
{$DEFINE CBUILDER3}
{$DEFINE CBUILDER1UP}
{$DEFINE CBUILDER3UP}
{$ENDIF}
{ defines for Delphi 4.0 }
{$IFDEF VER120}
{$DEFINE DELPHI}
{$DEFINE DELPHI4}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$ENDIF}
{ defines for C++Builder 4.0 }
{$IFDEF VER125}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$DEFINE CBUILDER}
{$DEFINE CBUILDER4}
{$DEFINE CBUILDER1UP}
{$DEFINE CBUILDER3UP}
{$DEFINE CBUILDER4UP}
{$ENDIF}
{ defines for Delphi 5.0 }
{$IFDEF VER130}
{$DEFINE DELPHI}
{$DEFINE DELPHI5}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$DEFINE DELPHI5UP}
{$ENDIF}
{ defines for C++Builder 5.0 }
{$IFDEF VER135}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$DEFINE DELPHI5UP}
{$DEFINE CBUILDER}
{$DEFINE CBUILDER5}
{$DEFINE CBUILDER1UP}
{$DEFINE CBUILDER3UP}
{$DEFINE CBUILDER4UP}
{$DEFINE CBUILDER5UP}
{$ENDIF}
{ defines for Delphi 6.0 }
{$IFDEF VER140}
{$DEFINE VER140UP}
{$DEFINE DELPHI}
{$DEFINE DELPHI6}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$DEFINE DELPHI5UP}
{$DEFINE DELPHI6UP}
{$ENDIF}
{ defines for Delphi 7.0 }
{$IFDEF VER150}
{$DEFINE VER140UP}
{$DEFINE DELPHI}
{$DEFINE DELPHI7}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$DEFINE DELPHI5UP}
{$DEFINE DELPHI6UP}
{$DEFINE DELPHI7UP}
{$ENDIF}
{ defines for Delphi 2005 }
{$IFDEF VER170}
{$DEFINE VER140UP}
{$DEFINE DELPHI}
{$DEFINE DELPHI9}
{$DEFINE DELPHI2005}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$DEFINE DELPHI5UP}
{$DEFINE DELPHI6UP}
{$DEFINE DELPHI7UP}
{$DEFINE DELPHI9UP}
{$DEFINE DELPHI2005UP}
{$DEFINE BDS}
{$DEFINE BDS3}
{$DEFINE BDS3UP}
{$ENDIF}
{ defines for Delphi 2006 }
{$IFDEF VER180}
{$DEFINE VER140UP}
{$DEFINE DELPHI}
{$DEFINE DELPHI10}
{$DEFINE DELPHI10A}
{$DEFINE DELPHI2006}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$DEFINE DELPHI5UP}
{$DEFINE DELPHI6UP}
{$DEFINE DELPHI7UP}
{$DEFINE DELPHI9UP}
{$DEFINE DELPHI10UP}
{$DEFINE DELPHI2005UP}
{$DEFINE DELPHI2006UP}
{$DEFINE BDS}
{$DEFINE BDS4}
{$DEFINE BDS3UP}
{$DEFINE BDS4UP}
{$ENDIF}
{ defines for Delphi 2007 }
{$IFDEF VER185}
{$UNDEF DELPHI10A} // declared in VER180
{$UNDEF DELPHI2006} // declared in VER180
{$UNDEF BDS4} // declared in VER180
{$DEFINE DELPHI10B}
{$DEFINE DELPHI10BUP}
{$DEFINE DELPHI11}
{$DEFINE DELPHI11UP}
{$DEFINE DELPHI2007}
{$DEFINE DELPHI2007UP}
{$DEFINE BDS5}
{$DEFINE BDS5UP}
{$ENDIF}
{ defines for Delphi 2009 }
{$IFDEF VER200}
{$DEFINE VER140UP}
{$DEFINE DELPHI}
{$DEFINE DELPHI12}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$DEFINE DELPHI5UP}
{$DEFINE DELPHI6UP}
{$DEFINE DELPHI7UP}
{$DEFINE DELPHI9UP}
{$DEFINE DELPHI10UP}
{$DEFINE DELPHI11UP}
{$DEFINE DELPHI12UP}
{$DEFINE DELPHI2009}
{$DEFINE DELPHI2005UP}
{$DEFINE DELPHI2006UP}
{$DEFINE DELPHI2007UP}
{$DEFINE DELPHI2009UP}
{$DEFINE BDS}
{$DEFINE BDS6}
{$DEFINE BDS3UP}
{$DEFINE BDS4UP}
{$DEFINE BDS5UP}
{$DEFINE BDS6UP}
{$ENDIF}
{ defines for Delphi 2010 }
{$IFDEF VER210}
{$DEFINE VER140UP}
{$DEFINE DELPHI}
{$DEFINE DELPHI14}
{$DEFINE DELPHI1UP}
{$DEFINE DELPHI2UP}
{$DEFINE DELPHI3UP}
{$DEFINE DELPHI4UP}
{$DEFINE DELPHI5UP}
{$DEFINE DELPHI6UP}
{$DEFINE DELPHI7UP}
{$DEFINE DELPHI9UP}
{$DEFINE DELPHI10UP}
{$DEFINE DELPHI11UP}
{$DEFINE DELPHI12UP}
{$DEFINE DELPHI14UP}
{$DEFINE DELPHI2010}
{$DEFINE DELPHI2005UP}
{$DEFINE DELPHI2006UP}
{$DEFINE DELPHI2007UP}
{$DEFINE DELPHI2009UP}
{$DEFINE DELPHI2010UP}
{$DEFINE BDS}
{$DEFINE BDS7}
{$DEFINE BDS3UP}
{$DEFINE BDS4UP}
{$DEFINE BDS5UP}
{$DEFINE BDS6UP}
{$DEFINE BDS7UP}
{$ENDIF}
{$IFDEF WIN32}
{$DEFINE MSWINDOWS} //not automatically defined for Delphi 2 thru 5
{$DEFINE 32BIT}
{$DEFINE CPU32}
{$ENDIF}
{$ENDIF MSWINDOWS}
{ defines for "Delphi for .NET" }
{$IFDEF CLR}
{$DEFINE DOTNET}
{$ENDIF}
{$IFDEF DELPHI}
{$IFDEF DELPHI2UP}
{$DEFINE DELPHI_32BIT}
{$ENDIF}
{$ENDIF}
{$IFDEF CBUILDER}
{$DEFINE CBUILDER_32BIT}
{$ENDIF}
{$IFNDEF FPC}
{ Kylix 1.0 thru 3.0 }
{$IFDEF LINUX}
{$DEFINE VER140UP}
{ Any Kylix }
{$DEFINE 32BIT}
{$DEFINE LINUX32}
{$DEFINE KYLIX_32BIT}
{$DEFINE KYLIX}
{$DEFINE KYLIX1UP}
{$IFDEF CONDITIONALEXPRESSIONS}
{$IF Declared(CompilerVersion)}
{ Kylix 2.0 }
{$IF Declared(RTLVersion) and (RTLVersion = 14.1)}
{$DEFINE KYLIX2}
{$DEFINE KYLIX1UP}
{$DEFINE KYLIX2UP}
{$IFEND}
{ Kylix 3.0 - Delphi portion }
{$IF Declared(RTLVersion) and (RTLVersion = 14.5)}
{$DEFINE KYLIX3}
{$DEFINE KYLIX1UP}
{$DEFINE KYLIX2UP}
{$DEFINE KYLIX3UP}
{$IFEND}
{ Kylix 1.0 }
{$ELSE}
{$DEFINE KYLIX1}
{$IFEND}
{$ENDIF CONDITIONALEXPRESSIONS}
{$ENDIF LINUX}
{$ENDIF}
{ CPU }
{$IFDEF FPC}
{$IFDEF MSWINDOWS}
{$IFDEF CPU64}
{$DEFINE WIN64}
{$ENDIF}
{$ENDIF}
{$IFDEF LINUX}
{$IFDEF CPU32}
{$DEFINE LINUX32}
{$ENDIF}
{$IFDEF CPU64}
{$DEFINE LINUX64}
{$ENDIF}
{$ENDIF}
{$IFDEF DARWIN}
{$IFDEF CPU32}
{$DEFINE DARWIN32}
{$ENDIF}
{$IFDEF CPU64}
{$DEFINE DARWIN64}
{$ENDIF}
{$ENDIF}
{$ENDIF}

29
Units/PascalScript/pascalscript.pas Normal file
View File

@ -0,0 +1,29 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit PascalScript;
interface
uses
uPSRuntime, PascalScript_Core_Reg, uPSC_buttons, uPSC_classes, uPSC_controls,
uPSC_dateutils, uPSC_DB, uPSC_dll, uPSC_extctrls, uPSC_forms,
uPSC_graphics, uPSC_menus, uPSC_std, uPSC_stdctrls, uPSCompiler,
uPSComponent, uPSComponent_Controls, uPSComponent_DB, uPSComponent_Default,
uPSComponent_Forms, uPSComponent_StdCtrls, uPSComponentExt, uPSDebugger,
uPSDisassembly, uPSPreProcessor, uPSR_buttons, uPSR_classes, uPSR_controls,
uPSR_dateutils, uPSR_DB, uPSR_dll, uPSR_extctrls, uPSR_forms,
uPSR_graphics, uPSR_menus, uPSR_std, uPSR_stdctrls, uPSUtils,
LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('PascalScript_Core_Reg', @PascalScript_Core_Reg.Register);
end;
initialization
RegisterPackage('PascalScript', @Register);
end.

343
Units/PascalScript/powerpc.inc Normal file
View File

@ -0,0 +1,343 @@
{ implementation of the powerpc osx abi for function calls in pascal script
Copyright (c) 2007 by Henry Vermaak (henry.vermaak@gmail.com) }
{$ifndef darwin}
{$fatal This code is Darwin specific at the moment!}
{$endif}
{$ifndef cpu32}
{$fatal This code is 32bit specific at the moment!}
{$endif}
const
rtINT = 0;
rtINT64 = 1;
rtFLOAT = 2;
type
Trint = array[1..8] of dword;
Trfloat = array[1..13] of double;
{$goto on}
{ define labels }
label
rfloat_loop,
stack_loop,
load_regs,
int_result,
int64_result,
float_result,
asmcall_end;
{ call a function from a pointer }
{ resulttype: 0 = int, 1 = int64, 2 = float }
function ppcasmcall(rint: Trint; rfloat: Trfloat; proc, stack: pointer; stacksize, resulttype: integer): pointer; assembler; nostackframe;
asm
mflr r0
stw r0, 8(r1)
{ save non-volatile register/s - make sure the stack size is sufficient! }
stw r31, -4(r1) { stacksize }
stwu r1, -240(r1) { create stack }
{ get all the params into the stack }
stw r3, 48(r1) { rint }
stw r4, 52(r1) { rfloat }
stw r5, 56(r1) { proc }
stw r6, 60(r1) { stack }
stw r7, 64(r1) { stacksize }
stw r8, 68(r1) { resulttype }
{ result is stored in 72(r1) and 76(r1) (if returning int64) }
{ write rint array into stack }
lwz r2, 48(r1) { rint }
lfd f0, 0(r2)
stfd f0, 80(r1) { rint[1], rint[2] }
lfd f0, 8(r2)
stfd f0, 88(r1) { rint[3], rint[4] }
lfd f0, 16(r2)
stfd f0, 96(r1) { rint[5], rint[6] }
lfd f0, 24(r2)
stfd f0, 104(r1) { rint[7], rint[8] }
{ write rfloat array into stack }
lwz r2, 52(r1) { rfloat }
addi r4, r1, 112 { rfloat[1] from here upwards (8 bytes apart) }
subi r2, r2, 8 { src }
subi r4, r4, 8 { dest }
li r3, 13 { counter }
rfloat_loop:
subic. r3, r3, 1 { dec counter }
lfdu f0, 8(r2) { load rfloat[x] + update }
stfdu f0, 8(r4) { store rfloat[x] + update }
bne cr0, rfloat_loop
{ create new stack }
mflr r0
stw r0, 8(r1)
mr r12, r1 { remember previous stack to fill in regs later }
lwz r31, 64(r12) { load stacksize into r31 }
neg r3, r31 { negate }
stwux r1, r1, r3 { create new stack }
{ build up the stack here }
mr r3, r31 { counter }
subic. r3, r3, 24 { don't write first 24 }
blt cr0, load_regs { don't fill in stack if there is none }
lwz r2, 60(r12) { pointer to stack }
addi r2, r2, 24 { start of params }
subi r2, r2, 1 { src }
addi r4, r1, 24 { start of params }
subi r4, r4, 1 { dest }
stack_loop:
subic. r3, r3, 1 { dec counter }
lbzu r5, 1(r2) { load stack + update }
stbu r5, 1(r4) { store stack + update }
bne cr0, stack_loop
load_regs: { now load the registers from the previous stack in r12 }
lwz r3, 80(r12)
lwz r4, 84(r12)
lwz r5, 88(r12)
lwz r6, 92(r12)
lwz r7, 96(r12)
lwz r8, 100(r12)
lwz r9, 104(r12)
lwz r10, 108(r12)
lfd f1, 112(r12)
lfd f2, 120(r12)
lfd f3, 128(r12)
lfd f4, 136(r12)
lfd f5, 144(r12)
lfd f6, 152(r12)
lfd f7, 160(r12)
lfd f8, 168(r12)
lfd f9, 176(r12)
lfd f10, 184(r12)
lfd f11, 192(r12)
lfd f12, 200(r12)
lfd f13, 208(r12)
{ now call this function }
lwz r2, 56(r12) { proc }
mtctr r2 { move to ctr }
bctrl { branch and link to ctr }
{ restore stack - use stacksize in r31 }
add r1, r1, r31
lwz r0, 8(r1)
mtlr r0
{ check resulttype and put appropriate pointer into r3 }
lwz r2, 68(r1) { resulttype }
cmpwi cr0, r2, 0 { int result? }
beq cr0, int_result { branch if equal }
cmpwi cr0, r2, 1 { single result? }
beq cr0, int64_result { branch if equal }
float_result: { the result is a double}
stfd f1, 72(r1) { write f1 to result on stack }
b asmcall_end
int64_result: { the result is a single }
stw r3, 72(r1) { write high dword to result on stack }
stw r4, 76(r1) { write low dword to result on stack }
b asmcall_end
int_result: { the result is dword }
stw r3, 72(r1) { write r3 to result on stack }
asmcall_end: { epilogue }
addi r3, r1, 72 { pointer to result on the stack }
addi r1, r1, 240 { restore stack }
{ restore non-volatile register/s }
lwz r31, -4(r1)
lwz r0, 8(r1)
mtlr r0
blr
end;
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
var
rint: Trint; { registers r3 to r10 }
rfloat: Trfloat; { registers f1 to f13 }
st: packed array of byte; { stack }
i, j, rindex, findex, stindex: integer;
fvar: PPSVariantIFC;
IsConstructor: Boolean;
{ add a dword to stack }
procedure addstackdword(value: dword);
begin
setlength(st, stindex+4);
pdword(@st[stindex])^ := value;
inc(stindex, 4);
end;
{ add a float to stack }
procedure addstackfloat(value: pointer; size: integer);
begin
setlength(st, stindex + (size * 4));
if size = 1
then psingle(@st[stindex])^ := single(value^)
else pdouble(@st[stindex])^ := double(value^);
inc(stindex, size*4);
end;
{ add to the general registers or overflow to stack }
procedure addgen(value: dword);
begin
if rindex <= 8
then begin
rint[rindex] := value;
inc(rindex);
addstackdword(value);
end
else begin
addstackdword(value);
end;
end;
{ add to the float registers or overflow to stack }
{ size = 1 for single, 2 for double }
procedure addfloat(value: pointer; size: integer);
begin
if findex <= 13
then begin
if size = 1
then rfloat[findex] := single(value^)
else rfloat[findex] := double(value^);
inc(findex);
inc(rindex, size);
addstackfloat(value, size);
end
else begin
addstackfloat(value, size);
end;
end;
begin
if (Integer(CallingConv) and 64) <> 0 then begin
IsConstructor := true;
CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64);
end else IsConstructor := false;
rindex := 1;
findex := 1;
stindex := 24;
setlength(st, stindex);
Result := False;
{ the pointer of the result needs to be passed first in the case of some result types }
if assigned(res)
then begin
case res.atype.basetype of
btStaticArray, btRecord: addgen(dword(res.dta));
end;
end;
{ process all parameters }
for i := 0 to Params.Count-1 do begin
if Params[i] = nil
then Exit;
fvar := Params[i];
{ cook dynamic arrays - fpc stores size-1 at @array-4 }
if (fvar.aType.BaseType = btArray)
then dec(pdword(pointer(fvar.dta^)-4)^);
if fvar.varparam
then begin { var param }
case fvar.aType.BaseType of
{ add var params here }
btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: addgen(dword(fvar.dta)); { TODO: test all }
else begin
writeln(stderr, 'Parameter type not recognised!');
Exit;
end;
end; { case }
end else begin { not a var param }
case fvar.aType.BaseType of
// btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
// btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
// {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: writeln('normal param');
{ add normal params here }
btString: addgen(dword(pstring(fvar.dta)^));
btU8, btS8: addgen(dword(pbyte(fvar.dta)^));
btU16, BtS16: addgen(dword(pword(fvar.dta)^));
btU32, btS32: addgen(dword(pdword(fvar.dta)^));
btSingle: addfloat(fvar.dta, 1);
btDouble, btExtended: addfloat(fvar.dta, 2);
btPChar: addgen(dword(ppchar(fvar.dta)^));
btChar: addgen(dword(pchar(fvar.dta)^));
{$IFNDEF PS_NOINT64}bts64:{$ENDIF} begin
addgen(dword(pint64(fvar.dta)^ shr 32));
addgen(dword(pint64(fvar.dta)^ and $ffffffff));
end;
btStaticArray: addgen(dword(fvar.dta));
btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do
addgen(pdword(fvar.dta + j*4)^);
btArray: addgen(dword(fvar.dta^));
{ TODO add and test }
{ btVariant, btSet, btInterface, btClass }
else begin
writeln(stderr, 'Parameter type not implemented!');
Exit;
end;
end; { case }
end; { else }
end; { for }
if not assigned(res)
then begin
ppcasmcall(rint, rfloat, address, st, stindex, rtINT); { ignore return }
end
else begin
case res.atype.basetype of
{ add result types here }
btString: pstring(res.dta)^ := pstring(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^;
btU8, btS8: pbyte(res.dta)^ := byte(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
btU16, btS16: pword(res.dta)^ := word(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
btU32, btS32: pdword(res.dta)^ := pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^;
btSingle: psingle(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
btDouble, btExtended: pdouble(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
btPChar: ppchar(res.dta)^ := pchar(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
btChar: pchar(res.dta)^ := char(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
btStaticArray, btRecord: ppcasmcall(rint, rfloat, address, st, stindex, rtINT);
btArray: res.dta := ppcasmcall(rint, rfloat, address, st, stindex, rtINT);
{ TODO add and test }
else begin
writeln(stderr, 'Result type not implemented!');
exit;
end; { else }
end; { case }
end;
{ cook dynamic arrays - fpc stores size-1 at @array-4 }
for i := 0 to Params.Count-1 do begin
fvar := Params[i];
if (fvar.aType.BaseType = btArray)
then inc(pdword(pointer(fvar.dta^)-4)^);
end;
Result := True;
end;

892
Units/PascalScript/uPSC_DB.pas Normal file
View File

@ -0,0 +1,892 @@
{ Compiletime DB support }
Unit uPSC_DB;
{
This file has been generated by UnitParser v0.4, written by M. Knight.
Source Code from Carlo Kok has been used to implement various sections of
UnitParser. Components of ifps3 are used in the construction of UnitParser,
code implementing the class wrapper is taken from Carlo Kok''s conv unility
Licence :
This software is provided 'as-is', without any expressed or implied
warranty. In no event will the author be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any kind of
application, and to alter it and redistribute it freely, subject to
the following restrictions:
1. The origin of this software must not be misrepresented, you must
not claim that you wrote the original software.
2. Altered source versions must be plainly marked as such, and must
not be misrepresented as being the original software.
3. You may not create a library that uses this library as a main part
of the program and sell that library.
4. You must have a visible line in your programs aboutbox or
documentation that it is made using Innerfuse Script and where
Innerfuse Pascal Script can be found.
5. This notice may not be removed or altered from any source
distribution.
If you have any questions concerning this license write to Carlo Kok:
ck@carlo-kok.com or try the newsserver:
news://news.carlo-kok.com/
}
{$I PascalScript.inc}
Interface
uses
uPSCompiler;
procedure SIRegisterTDATASET(CL: TPSPascalCompiler);
procedure SIRegisterTPARAMS(CL: TPSPascalCompiler);
procedure SIRegisterTPARAM(CL: TPSPascalCompiler);
procedure SIRegisterTGUIDFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTVARIANTFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTREFERENCEFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTDATASETFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTARRAYFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTADTFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTOBJECTFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTGRAPHICFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTMEMOFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTBLOBFIELD(CL: TPSPascalCompiler);
{$IFDEF DELPHI6UP}
procedure SIRegisterTFMTBCDFIELD(CL: TPSPascalCompiler);
{$ENDIF}
procedure SIRegisterTBCDFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTVARBYTESFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTBYTESFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTBINARYFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTTIMEFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTDATEFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTDATETIMEFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTBOOLEANFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTCURRENCYFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTFLOATFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTAUTOINCFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTWORDFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTLARGEINTFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTSMALLINTFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTINTEGERFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTNUMERICFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTWIDESTRINGFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTSTRINGFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTFIELD(CL: TPSPascalCompiler);
procedure SIRegisterTLOOKUPLIST(CL: TPSPascalCompiler);
procedure SIRegisterTFIELDS(CL: TPSPascalCompiler);
procedure SIRegisterTFIELDLIST(CL: TPSPascalCompiler);
procedure SIRegisterTFIELDDEFLIST(CL: TPSPascalCompiler);
procedure SIRegisterTFLATLIST(CL: TPSPascalCompiler);
procedure SIRegisterTINDEXDEFS(CL: TPSPascalCompiler);
procedure SIRegisterTINDEXDEF(CL: TPSPascalCompiler);
procedure SIRegisterTFIELDDEFS(CL: TPSPascalCompiler);
procedure SIRegisterTFIELDDEF(CL: TPSPascalCompiler);
procedure SIRegisterTDEFCOLLECTION(CL: TPSPascalCompiler);
procedure SIRegisterTNAMEDITEM(CL: TPSPascalCompiler);
procedure SIRegister_DB(Cl: TPSPascalCompiler);
implementation
Uses Sysutils;
Function RegClassS(cl : TPSPascalCompiler;Const InheritsFrom,Classname : String) : TPSCompileTimeClass;
begin
Result := cl.FindClass(Classname);
if Result = nil then
Result := cl.AddClassN(cl.FindClass(InheritsFrom),Classname)
else
Result.ClassInheritsFrom := cl.FindClass(InheritsFrom);
end;
procedure SIRegisterTDATASET(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TCOMPONENT','TDATASET') do
begin
RegisterMethod('Function ACTIVEBUFFER : PCHAR');
RegisterMethod('Procedure APPEND');
RegisterMethod('Procedure APPENDRECORD( const VALUES : array of const)');
// RegisterMethod('Function BOOKMARKVALID( BOOKMARK : TBOOKMARK) : BOOLEAN');
RegisterMethod('Procedure CANCEL');
RegisterMethod('Procedure CHECKBROWSEMODE');
RegisterMethod('Procedure CLEARFIELDS');
RegisterMethod('Procedure CLOSE');
RegisterMethod('Function CONTROLSDISABLED : BOOLEAN');
// RegisterMethod('Function COMPAREBOOKMARKS( BOOKMARK1, BOOKMARK2 : TBOOKMARK) : INTEGER');
RegisterMethod('Function CREATEBLOBSTREAM( FIELD : TFIELD; MODE : TBLOBSTREAMMODE) : TSTREAM');
RegisterMethod('Procedure CURSORPOSCHANGED');
RegisterMethod('Procedure DELETE');
RegisterMethod('Procedure DISABLECONTROLS');
RegisterMethod('Procedure EDIT');
RegisterMethod('Procedure ENABLECONTROLS');
{$IFDEF DELPHI2006UP}
RegisterMethod('Function FIELDBYNAME( const FIELDNAME : WIDESTRING) : TFIELD');
RegisterMethod('Function FINDFIELD( const FIELDNAME : WideString) : TFIELD');
{$ELSE}
RegisterMethod('Function FIELDBYNAME( const FIELDNAME : STRING) : TFIELD');
RegisterMethod('Function FINDFIELD( const FIELDNAME : STRING) : TFIELD');
{$ENDIF}
RegisterMethod('Function FINDFIRST : BOOLEAN');
RegisterMethod('Function FINDLAST : BOOLEAN');
RegisterMethod('Function FINDNEXT : BOOLEAN');
RegisterMethod('Function FINDPRIOR : BOOLEAN');
RegisterMethod('Procedure FIRST');
// RegisterMethod('Procedure FREEBOOKMARK( BOOKMARK : TBOOKMARK)');
// RegisterMethod('Function GETBOOKMARK : TBOOKMARK');
RegisterMethod('Function GETCURRENTRECORD( BUFFER : PCHAR) : BOOLEAN');
// RegisterMethod('Procedure GETDETAILDATASETS( LIST : TLIST)');
// RegisterMethod('Procedure GETFIELDLIST( LIST : TLIST; const FIELDNAMES : STRING)');
// RegisterMethod('Procedure GETDETAILLINKFIELDS( MASTERFIELDS, DETAILFIELDS : TLIST)');
// RegisterMethod('Function GETBLOBFIELDDATA( FIELDNO : INTEGER; var BUFFER : TBLOBBYTEDATA) : INTEGER');
RegisterMethod('Procedure GETFIELDNAMES( LIST : TSTRINGS)');
// RegisterMethod('Procedure GOTOBOOKMARK( BOOKMARK : TBOOKMARK)');
RegisterMethod('Procedure INSERT');
RegisterMethod('Procedure INSERTRECORD( const VALUES : array of const)');
RegisterMethod('Function ISEMPTY : BOOLEAN');
RegisterMethod('Function ISLINKEDTO( DATASOURCE : TDATASOURCE) : BOOLEAN');
RegisterMethod('Function ISSEQUENCED : BOOLEAN');
RegisterMethod('Procedure LAST');
RegisterMethod('Function LOCATE( const KEYFIELDS : String; const KEYVALUES : VARIANT; OPTIONS : TLOCATEOPTIONS) : BOOLEAN');
RegisterMethod('Function LOOKUP( const KEYFIELDS : String; const KEYVALUES : VARIANT; const RESULTFIELDS : String) : VARIANT');
RegisterMethod('Function MOVEBY( DISTANCE : INTEGER) : INTEGER');
RegisterMethod('Procedure NEXT');
RegisterMethod('Procedure OPEN');
RegisterMethod('Procedure POST');
RegisterMethod('Procedure PRIOR');
RegisterMethod('Procedure REFRESH');
// RegisterMethod('Procedure RESYNC( MODE : TRESYNCMODE)');
RegisterMethod('Procedure SETFIELDS( const VALUES : array of const)');
RegisterMethod('Function TRANSLATE( SRC, DEST : PCHAR; TOOEM : BOOLEAN) : INTEGER');
RegisterMethod('Procedure UPDATECURSORPOS');
RegisterMethod('Procedure UPDATERECORD');
RegisterMethod('Function UPDATESTATUS : TUPDATESTATUS');
RegisterProperty('AGGFIELDS', 'TFIELDS', iptr);
RegisterProperty('BOF', 'BOOLEAN', iptr);
// RegisterProperty('BOOKMARK', 'TBOOKMARKSTR', iptrw);
RegisterProperty('CANMODIFY', 'BOOLEAN', iptr);
RegisterProperty('DATASETFIELD', 'TDATASETFIELD', iptrw);
RegisterProperty('DATASOURCE', 'TDATASOURCE', iptr);
RegisterProperty('DEFAULTFIELDS', 'BOOLEAN', iptr);
RegisterProperty('DESIGNER', 'TDATASETDESIGNER', iptr);
RegisterProperty('EOF', 'BOOLEAN', iptr);
RegisterProperty('BLOCKREADSIZE', 'INTEGER', iptrw);
RegisterProperty('FIELDCOUNT', 'INTEGER', iptr);
RegisterProperty('FIELDDEFS', 'TFIELDDEFS', iptrw);
RegisterProperty('FIELDDEFLIST', 'TFIELDDEFLIST', iptr);
RegisterProperty('FIELDS', 'TFIELDS', iptr);
RegisterProperty('FIELDLIST', 'TFIELDLIST', iptr);
RegisterProperty('FIELDVALUES', 'VARIANT String', iptrw);
RegisterProperty('FOUND', 'BOOLEAN', iptr);
{$IFDEF DELPHI6UP}
RegisterProperty('ISUNIDIRECTIONAL', 'BOOLEAN', iptr);
{$ENDIF}
RegisterProperty('MODIFIED', 'BOOLEAN', iptr);
RegisterProperty('OBJECTVIEW', 'BOOLEAN', iptrw);
RegisterProperty('RECORDCOUNT', 'INTEGER', iptr);
RegisterProperty('RECNO', 'INTEGER', iptrw);
RegisterProperty('RECORDSIZE', 'WORD', iptr);
RegisterProperty('SPARSEARRAYS', 'BOOLEAN', iptrw);
RegisterProperty('STATE', 'TDATASETSTATE', iptr);
RegisterProperty('FILTER', 'String', iptrw);
RegisterProperty('FILTERED', 'BOOLEAN', iptrw);
RegisterProperty('FILTEROPTIONS', 'TFILTEROPTIONS', iptrw);
RegisterProperty('ACTIVE', 'BOOLEAN', iptrw);
RegisterProperty('AUTOCALCFIELDS', 'BOOLEAN', iptrw);
RegisterProperty('BEFOREOPEN', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('AFTEROPEN', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('BEFORECLOSE', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('AFTERCLOSE', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('BEFOREINSERT', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('AFTERINSERT', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('BEFOREEDIT', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('AFTEREDIT', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('BEFOREPOST', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('AFTERPOST', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('BEFORECANCEL', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('AFTERCANCEL', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('BEFOREDELETE', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('AFTERDELETE', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('BEFORESCROLL', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('AFTERSCROLL', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('BEFOREREFRESH', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('AFTERREFRESH', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('ONCALCFIELDS', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('ONDELETEERROR', 'TDATASETERROREVENT', iptrw);
RegisterProperty('ONEDITERROR', 'TDATASETERROREVENT', iptrw);
RegisterProperty('ONFILTERRECORD', 'TFILTERRECORDEVENT', iptrw);
RegisterProperty('ONNEWRECORD', 'TDATASETNOTIFYEVENT', iptrw);
RegisterProperty('ONPOSTERROR', 'TDATASETERROREVENT', iptrw);
end;
end;
procedure SIRegisterTPARAMS(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TCOLLECTION','TPARAMS') do
begin
RegisterMethod('Procedure ASSIGNVALUES( VALUE : TPARAMS)');
RegisterMethod('Procedure ADDPARAM( VALUE : TPARAM)');
RegisterMethod('Procedure REMOVEPARAM( VALUE : TPARAM)');
RegisterMethod('Function CREATEPARAM( FLDTYPE : TFIELDTYPE; const PARAMNAME : String; PARAMTYPE : TPARAMTYPE) : TPARAM');
// RegisterMethod('Procedure GETPARAMLIST( LIST : TLIST; const PARAMNAMES : STRING)');
RegisterMethod('Function ISEQUAL( VALUE : TPARAMS) : BOOLEAN');
RegisterMethod('Function PARSESQL( SQL : String; DOCREATE : BOOLEAN) : String');
RegisterMethod('Function PARAMBYNAME( const VALUE : String) : TPARAM');
RegisterMethod('Function FINDPARAM( const VALUE : String) : TPARAM');
RegisterProperty('ITEMS', 'TPARAM INTEGER', iptrw);
RegisterProperty('PARAMVALUES', 'VARIANT String', iptrw);
end;
end;
procedure SIRegisterTPARAM(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TCOLLECTIONITEM','TPARAM') do
begin
RegisterMethod('Procedure ASSIGNFIELD( FIELD : TFIELD)');
RegisterMethod('Procedure ASSIGNFIELDVALUE( FIELD : TFIELD; const VALUE : VARIANT)');
RegisterMethod('Procedure CLEAR');
// RegisterMethod('Procedure GETDATA( BUFFER : POINTER)');
RegisterMethod('Function GETDATASIZE : INTEGER');
RegisterMethod('Procedure LOADFROMFILE( const FILENAME : String; BLOBTYPE : TBLOBTYPE)');
RegisterMethod('Procedure LOADFROMSTREAM( STREAM : TSTREAM; BLOBTYPE : TBLOBTYPE)');
// RegisterMethod('Procedure SETBLOBDATA( BUFFER : POINTER; SIZE : INTEGER)');
// RegisterMethod('Procedure SETDATA( BUFFER : POINTER)');
{$IFDEF DELPHI6UP}
RegisterProperty('ASBCD', 'CURRENCY', iptrw);
{$ENDIF}
{$IFDEF DELPHI6UP}
RegisterProperty('ASFMTBCD', 'TBCD', iptrw);
{$ENDIF}
RegisterProperty('ASBLOB', 'TBLOBDATA', iptrw);
RegisterProperty('ASBOOLEAN', 'BOOLEAN', iptrw);
RegisterProperty('ASCURRENCY', 'CURRENCY', iptrw);
RegisterProperty('ASDATE', 'TDATETIME', iptrw);
RegisterProperty('ASDATETIME', 'TDATETIME', iptrw);
RegisterProperty('ASFLOAT', 'DOUBLE', iptrw);
RegisterProperty('ASINTEGER', 'LONGINT', iptrw);
RegisterProperty('ASSMALLINT', 'LONGINT', iptrw);
RegisterProperty('ASMEMO', 'String', iptrw);
RegisterProperty('ASSTRING', 'String', iptrw);
RegisterProperty('ASTIME', 'TDATETIME', iptrw);
RegisterProperty('ASWORD', 'LONGINT', iptrw);
RegisterProperty('BOUND', 'BOOLEAN', iptrw);
RegisterProperty('ISNULL', 'BOOLEAN', iptr);
RegisterProperty('NATIVESTR', 'String', iptrw);
RegisterProperty('TEXT', 'String', iptrw);
RegisterProperty('DATATYPE', 'TFIELDTYPE', iptrw);
{$IFDEF DELPHI6UP}
RegisterProperty('PRECISION', 'INTEGER', iptrw);
RegisterProperty('NUMERICSCALE', 'INTEGER', iptrw);
RegisterProperty('SIZE', 'INTEGER', iptrw);
{$ENDIF}
RegisterProperty('NAME', 'String', iptrw);
RegisterProperty('PARAMTYPE', 'TPARAMTYPE', iptrw);
RegisterProperty('VALUE', 'VARIANT', iptrw);
end;
end;
procedure SIRegisterTGUIDFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFIELD','TGUIDFIELD') do
begin
end;
end;
procedure SIRegisterTVARIANTFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFIELD','TVARIANTFIELD') do
begin
end;
end;
procedure SIRegisterTREFERENCEFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TDATASETFIELD','TREFERENCEFIELD') do
begin
RegisterProperty('REFERENCETABLENAME', 'String', iptrw);
end;
end;
procedure SIRegisterTDATASETFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TOBJECTFIELD','TDATASETFIELD') do
begin
RegisterProperty('NESTEDDATASET', 'TDATASET', iptr);
RegisterProperty('INCLUDEOBJECTFIELD', 'BOOLEAN', iptrw);
end;
end;
procedure SIRegisterTARRAYFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TOBJECTFIELD','TARRAYFIELD') do
begin
end;
end;
procedure SIRegisterTADTFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TOBJECTFIELD','TADTFIELD') do
begin
end;
end;
procedure SIRegisterTOBJECTFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFIELD','TOBJECTFIELD') do
begin
RegisterProperty('FIELDCOUNT', 'INTEGER', iptr);
RegisterProperty('FIELDS', 'TFIELDS', iptr);
RegisterProperty('FIELDVALUES', 'VARIANT INTEGER', iptrw);
RegisterProperty('UNNAMED', 'BOOLEAN', iptr);
RegisterProperty('OBJECTTYPE', 'String', iptrw);
end;
end;
procedure SIRegisterTGRAPHICFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TBLOBFIELD','TGRAPHICFIELD') do
begin
end;
end;
procedure SIRegisterTMEMOFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TBLOBFIELD','TMEMOFIELD') do
begin
end;
end;
procedure SIRegisterTBLOBFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFIELD','TBLOBFIELD') do
begin
RegisterMethod('Procedure LOADFROMFILE( const FILENAME : String)');
RegisterMethod('Procedure LOADFROMSTREAM( STREAM : TSTREAM)');
RegisterMethod('Procedure SAVETOFILE( const FILENAME : String)');
RegisterMethod('Procedure SAVETOSTREAM( STREAM : TSTREAM)');
RegisterProperty('BLOBSIZE', 'INTEGER', iptr);
RegisterProperty('MODIFIED', 'BOOLEAN', iptrw);
RegisterProperty('VALUE', 'String', iptrw);
RegisterProperty('TRANSLITERATE', 'BOOLEAN', iptrw);
RegisterProperty('BLOBTYPE', 'TBLOBTYPE', iptrw);
{$IFDEF DELPHI6UP}
RegisterProperty('GRAPHICHEADER', 'BOOLEAN', iptrw);
{$ENDIF}
end;
end;
{$IFDEF DELPHI6UP}
procedure SIRegisterTFMTBCDFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TNUMERICFIELD','TFMTBCDFIELD') do
begin
RegisterProperty('VALUE', 'TBCD', iptrw);
RegisterProperty('CURRENCY', 'BOOLEAN', iptrw);
RegisterProperty('MAXVALUE', 'String', iptrw);
RegisterProperty('MINVALUE', 'String', iptrw);
RegisterProperty('PRECISION', 'INTEGER', iptrw);
end;
end;
{$ENDIF}
procedure SIRegisterTBCDFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TNUMERICFIELD','TBCDFIELD') do
begin
RegisterProperty('VALUE', 'CURRENCY', iptrw);
RegisterProperty('CURRENCY', 'BOOLEAN', iptrw);
RegisterProperty('MAXVALUE', 'CURRENCY', iptrw);
RegisterProperty('MINVALUE', 'CURRENCY', iptrw);
RegisterProperty('PRECISION', 'INTEGER', iptrw);
end;
end;
procedure SIRegisterTVARBYTESFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TBYTESFIELD','TVARBYTESFIELD') do
begin
end;
end;
procedure SIRegisterTBYTESFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TBINARYFIELD','TBYTESFIELD') do
begin
end;
end;
procedure SIRegisterTBINARYFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFIELD','TBINARYFIELD') do
begin
end;
end;
procedure SIRegisterTTIMEFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TDATETIMEFIELD','TTIMEFIELD') do
begin
end;
end;
procedure SIRegisterTDATEFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TDATETIMEFIELD','TDATEFIELD') do
begin
end;
end;
procedure SIRegisterTDATETIMEFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFIELD','TDATETIMEFIELD') do
begin
RegisterProperty('VALUE', 'TDATETIME', iptrw);
RegisterProperty('DISPLAYFORMAT', 'String', iptrw);
end;
end;
procedure SIRegisterTBOOLEANFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFIELD','TBOOLEANFIELD') do
begin
RegisterProperty('VALUE', 'BOOLEAN', iptrw);
RegisterProperty('DISPLAYVALUES', 'String', iptrw);
end;
end;
procedure SIRegisterTCURRENCYFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFLOATFIELD','TCURRENCYFIELD') do
begin
end;
end;
procedure SIRegisterTFLOATFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TNUMERICFIELD','TFLOATFIELD') do
begin
RegisterProperty('VALUE', 'DOUBLE', iptrw);
RegisterProperty('CURRENCY', 'BOOLEAN', iptrw);
RegisterProperty('MAXVALUE', 'DOUBLE', iptrw);
RegisterProperty('MINVALUE', 'DOUBLE', iptrw);
RegisterProperty('PRECISION', 'INTEGER', iptrw);
end;
end;
procedure SIRegisterTAUTOINCFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TINTEGERFIELD','TAUTOINCFIELD') do
begin
end;
end;
procedure SIRegisterTWORDFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TINTEGERFIELD','TWORDFIELD') do
begin
end;
end;
procedure SIRegisterTLARGEINTFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TNUMERICFIELD','TLARGEINTFIELD') do
begin
RegisterProperty('ASLARGEINT', 'LARGEINT', iptrw);
RegisterProperty('VALUE', 'LARGEINT', iptrw);
RegisterProperty('MAXVALUE', 'LARGEINT', iptrw);
RegisterProperty('MINVALUE', 'LARGEINT', iptrw);
end;
end;
procedure SIRegisterTSMALLINTFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TINTEGERFIELD','TSMALLINTFIELD') do
begin
end;
end;
procedure SIRegisterTINTEGERFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TNUMERICFIELD','TINTEGERFIELD') do
begin
RegisterProperty('VALUE', 'LONGINT', iptrw);
RegisterProperty('MAXVALUE', 'LONGINT', iptrw);
RegisterProperty('MINVALUE', 'LONGINT', iptrw);
end;
end;
procedure SIRegisterTNUMERICFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFIELD','TNUMERICFIELD') do
begin
RegisterProperty('DISPLAYFORMAT', 'String', iptrw);
RegisterProperty('EDITFORMAT', 'String', iptrw);
end;
end;
procedure SIRegisterTWIDESTRINGFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TSTRINGFIELD','TWIDESTRINGFIELD') do
begin
RegisterProperty('VALUE', 'WIDESTRING', iptrw);
end;
end;
procedure SIRegisterTSTRINGFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFIELD','TSTRINGFIELD') do
begin
RegisterProperty('VALUE', 'String', iptrw);
RegisterProperty('FIXEDCHAR', 'BOOLEAN', iptrw);
RegisterProperty('TRANSLITERATE', 'BOOLEAN', iptrw);
end;
end;
procedure SIRegisterTFIELD(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TCOMPONENT','TFIELD') do
begin
//RegisterMethod('Procedure ASSIGNVALUE( const VALUE : TVARREC)');
RegisterMethod('Procedure CLEAR');
RegisterMethod('Procedure FOCUSCONTROL');
// RegisterMethod('Function GETDATA( BUFFER : POINTER; NATIVEFORMAT : BOOLEAN) : BOOLEAN');
RegisterMethod('Function ISVALIDCHAR( INPUTCHAR : CHAR) : BOOLEAN');
RegisterMethod('Procedure REFRESHLOOKUPLIST');
// RegisterMethod('Procedure SETDATA( BUFFER : POINTER; NATIVEFORMAT : BOOLEAN)');
RegisterMethod('Procedure SETFIELDTYPE( VALUE : TFIELDTYPE)');
// RegisterMethod('Procedure VALIDATE( BUFFER : POINTER)');
{$IFDEF DELPHI6UP}
RegisterProperty('ASBCD', 'TBCD', iptrw);
{$ENDIF}
RegisterProperty('ASBOOLEAN', 'BOOLEAN', iptrw);
RegisterProperty('ASCURRENCY', 'CURRENCY', iptrw);
RegisterProperty('ASDATETIME', 'TDATETIME', iptrw);
RegisterProperty('ASFLOAT', 'DOUBLE', iptrw);
RegisterProperty('ASINTEGER', 'LONGINT', iptrw);
RegisterProperty('ASSTRING', 'String', iptrw);
RegisterProperty('ASVARIANT', 'VARIANT', iptrw);
RegisterProperty('ATTRIBUTESET', 'String', iptrw);
RegisterProperty('CALCULATED', 'BOOLEAN', iptrw);
RegisterProperty('CANMODIFY', 'BOOLEAN', iptr);
RegisterProperty('CURVALUE', 'VARIANT', iptr);
RegisterProperty('DATASET', 'TDATASET', iptrw);
RegisterProperty('DATASIZE', 'INTEGER', iptr);
RegisterProperty('DATATYPE', 'TFIELDTYPE', iptr);
RegisterProperty('DISPLAYNAME', 'String', iptr);
RegisterProperty('DISPLAYTEXT', 'String', iptr);
RegisterProperty('EDITMASK', 'TEDITMASK', iptrw);
RegisterProperty('EDITMASKPTR', 'TEDITMASK', iptr);
RegisterProperty('EDITMASK', 'String', iptrw);
RegisterProperty('EDITMASKPTR', 'String', iptr);
RegisterProperty('FIELDNO', 'INTEGER', iptr);
RegisterProperty('FULLNAME', 'String', iptr);
RegisterProperty('ISINDEXFIELD', 'BOOLEAN', iptr);
RegisterProperty('ISNULL', 'BOOLEAN', iptr);
RegisterProperty('LOOKUP', 'BOOLEAN', iptrw);
RegisterProperty('LOOKUPLIST', 'TLOOKUPLIST', iptr);
RegisterProperty('NEWVALUE', 'VARIANT', iptrw);
RegisterProperty('OFFSET', 'INTEGER', iptr);
RegisterProperty('OLDVALUE', 'VARIANT', iptr);
RegisterProperty('PARENTFIELD', 'TOBJECTFIELD', iptrw);
RegisterProperty('SIZE', 'INTEGER', iptrw);
RegisterProperty('TEXT', 'String', iptrw);
RegisterProperty('VALIDCHARS', 'TFIELDCHARS', iptrw);
RegisterProperty('VALUE', 'VARIANT', iptrw);
RegisterProperty('ALIGNMENT', 'TALIGNMENT', iptrw);
RegisterProperty('AUTOGENERATEVALUE', 'TAUTOREFRESHFLAG', iptrw);
RegisterProperty('CUSTOMCONSTRAINT', 'String', iptrw);
RegisterProperty('CONSTRAINTERRORMESSAGE', 'String', iptrw);
RegisterProperty('DEFAULTEXPRESSION', 'String', iptrw);
RegisterProperty('DISPLAYLABEL', 'String', iptrw);
RegisterProperty('DISPLAYWIDTH', 'INTEGER', iptrw);
RegisterProperty('FIELDKIND', 'TFIELDKIND', iptrw);
RegisterProperty('FIELDNAME', 'String', iptrw);
RegisterProperty('HASCONSTRAINTS', 'BOOLEAN', iptr);
RegisterProperty('INDEX', 'INTEGER', iptrw);
RegisterProperty('IMPORTEDCONSTRAINT', 'String', iptrw);
RegisterProperty('LOOKUPDATASET', 'TDATASET', iptrw);
RegisterProperty('LOOKUPKEYFIELDS', 'String', iptrw);
RegisterProperty('LOOKUPRESULTFIELD', 'String', iptrw);
RegisterProperty('KEYFIELDS', 'String', iptrw);
RegisterProperty('LOOKUPCACHE', 'BOOLEAN', iptrw);
RegisterProperty('ORIGIN', 'String', iptrw);
RegisterProperty('PROVIDERFLAGS', 'TPROVIDERFLAGS', iptrw);
RegisterProperty('READONLY', 'BOOLEAN', iptrw);
RegisterProperty('REQUIRED', 'BOOLEAN', iptrw);
RegisterProperty('VISIBLE', 'BOOLEAN', iptrw);
RegisterProperty('ONCHANGE', 'TFIELDNOTIFYEVENT', iptrw);
RegisterProperty('ONGETTEXT', 'TFIELDGETTEXTEVENT', iptrw);
RegisterProperty('ONSETTEXT', 'TFIELDSETTEXTEVENT', iptrw);
RegisterProperty('ONVALIDATE', 'TFIELDNOTIFYEVENT', iptrw);
end;
end;
procedure SIRegisterTLOOKUPLIST(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TOBJECT','TLOOKUPLIST') do
begin
RegisterMethod('Constructor CREATE');
RegisterMethod('Procedure ADD( const AKEY, AVALUE : VARIANT)');
RegisterMethod('Procedure CLEAR');
RegisterMethod('Function VALUEOFKEY( const AKEY : VARIANT) : VARIANT');
end;
end;
procedure SIRegisterTFIELDS(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TOBJECT','TFIELDS') do
begin
RegisterMethod('Constructor CREATE( ADATASET : TDATASET)');
RegisterMethod('Procedure ADD( FIELD : TFIELD)');
RegisterMethod('Procedure CHECKFIELDNAME( const FIELDNAME : String)');
RegisterMethod('Procedure CHECKFIELDNAMES( const FIELDNAMES : String)');
RegisterMethod('Procedure CLEAR');
RegisterMethod('Function FINDFIELD( const FIELDNAME : String) : TFIELD');
RegisterMethod('Function FIELDBYNAME( const FIELDNAME : String) : TFIELD');
RegisterMethod('Function FIELDBYNUMBER( FIELDNO : INTEGER) : TFIELD');
RegisterMethod('Procedure GETFIELDNAMES( LIST : TSTRINGS)');
RegisterMethod('Function INDEXOF( FIELD : TFIELD) : INTEGER');
RegisterMethod('Procedure REMOVE( FIELD : TFIELD)');
RegisterProperty('COUNT', 'INTEGER', iptr);
RegisterProperty('DATASET', 'TDATASET', iptr);
RegisterProperty('FIELDS', 'TFIELD INTEGER', iptrw);
end;
end;
procedure SIRegisterTFIELDLIST(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFLATLIST','TFIELDLIST') do
begin
RegisterMethod('Function FIELDBYNAME( const NAME : String) : TFIELD');
RegisterMethod('Function FIND( const NAME : String) : TFIELD');
RegisterProperty('FIELDS', 'TFIELD INTEGER', iptr);
end;
end;
procedure SIRegisterTFIELDDEFLIST(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TFLATLIST','TFIELDDEFLIST') do
begin
RegisterMethod('Function FIELDBYNAME( const NAME : String) : TFIELDDEF');
RegisterMethod('Function FIND( const NAME : String) : TFIELDDEF');
RegisterProperty('FIELDDEFS', 'TFIELDDEF INTEGER', iptr);
end;
end;
procedure SIRegisterTFLATLIST(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TSTRINGLIST','TFLATLIST') do
begin
RegisterMethod('Constructor CREATE( ADATASET : TDATASET)');
RegisterMethod('Procedure UPDATE');
RegisterProperty('DATASET', 'TDATASET', iptr);
end;
end;
procedure SIRegisterTINDEXDEFS(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TDEFCOLLECTION','TINDEXDEFS') do
begin
RegisterMethod('Constructor CREATE( ADATASET : TDATASET)');
RegisterMethod('Function ADDINDEXDEF : TINDEXDEF');
RegisterMethod('Function FIND( const NAME : String) : TINDEXDEF');
RegisterMethod('Procedure UPDATE');
RegisterMethod('Function FINDINDEXFORFIELDS( const FIELDS : String) : TINDEXDEF');
RegisterMethod('Function GETINDEXFORFIELDS( const FIELDS : String; CASEINSENSITIVE : BOOLEAN) : TINDEXDEF');
RegisterMethod('Procedure ADD( const NAME, FIELDS : String; OPTIONS : TINDEXOPTIONS)');
RegisterProperty('ITEMS', 'TINDEXDEF INTEGER', iptrw);
end;
end;
procedure SIRegisterTINDEXDEF(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TNAMEDITEM','TINDEXDEF') do
begin
RegisterMethod('Constructor CREATE( OWNER : TINDEXDEFS; const NAME, FIELDS : String; OPTIONS : TINDEXOPTIONS)');
RegisterProperty('FIELDEXPRESSION', 'String', iptr);
RegisterProperty('CASEINSFIELDS', 'String', iptrw);
RegisterProperty('DESCFIELDS', 'String', iptrw);
RegisterProperty('EXPRESSION', 'String', iptrw);
RegisterProperty('FIELDS', 'String', iptrw);
RegisterProperty('OPTIONS', 'TINDEXOPTIONS', iptrw);
RegisterProperty('SOURCE', 'String', iptrw);
RegisterProperty('GROUPINGLEVEL', 'INTEGER', iptrw);
end;
end;
procedure SIRegisterTFIELDDEFS(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TDEFCOLLECTION','TFIELDDEFS') do
begin
RegisterMethod('Constructor CREATE( AOWNER : TPERSISTENT)');
RegisterMethod('Function ADDFIELDDEF : TFIELDDEF');
RegisterMethod('Function FIND( const NAME : String) : TFIELDDEF');
RegisterMethod('Procedure UPDATE');
RegisterMethod('Procedure ADD( const NAME : String; DATATYPE : TFIELDTYPE; SIZE : INTEGER; REQUIRED : BOOLEAN)');
RegisterProperty('HIDDENFIELDS', 'BOOLEAN', iptrw);
RegisterProperty('ITEMS', 'TFIELDDEF INTEGER', iptrw);
RegisterProperty('PARENTDEF', 'TFIELDDEF', iptr);
end;
end;
procedure SIRegisterTFIELDDEF(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TNAMEDITEM','TFIELDDEF') do
begin
// RegisterMethod('Constructor CREATE( OWNER : TFIELDDEFS; const NAME : STRING; DATATYPE : TFIELDTYPE; SIZE : INTEGER; REQUIRED : BOOLEAN; FIELDNO : INTEGER)');
RegisterMethod('Function ADDCHILD : TFIELDDEF');
RegisterMethod('Function CREATEFIELD( OWNER : TCOMPONENT; PARENTFIELD : TOBJECTFIELD; const FIELDNAME : String; CREATECHILDREN : BOOLEAN) : TFIELD');
RegisterMethod('Function HASCHILDDEFS : BOOLEAN');
RegisterProperty('FIELDCLASS', 'TFIELDCLASS', iptr);
RegisterProperty('FIELDNO', 'INTEGER', iptrw);
RegisterProperty('INTERNALCALCFIELD', 'BOOLEAN', iptrw);
RegisterProperty('PARENTDEF', 'TFIELDDEF', iptr);
RegisterProperty('REQUIRED', 'BOOLEAN', iptrw);
RegisterProperty('ATTRIBUTES', 'TFIELDATTRIBUTES', iptrw);
RegisterProperty('CHILDDEFS', 'TFIELDDEFS', iptrw);
RegisterProperty('DATATYPE', 'TFIELDTYPE', iptrw);
RegisterProperty('PRECISION', 'INTEGER', iptrw);
RegisterProperty('SIZE', 'INTEGER', iptrw);
end;
end;
procedure SIRegisterTDEFCOLLECTION(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TOWNEDCOLLECTION','TDEFCOLLECTION') do
begin
// RegisterMethod('Constructor CREATE( ADATASET : TDATASET; AOWNER : TPERSISTENT; ACLASS : TCOLLECTIONITEMCLASS)');
RegisterMethod('Function FIND( const ANAME : String) : TNAMEDITEM');
RegisterMethod('Procedure GETITEMNAMES( LIST : TSTRINGS)');
RegisterMethod('Function INDEXOF( const ANAME : String) : INTEGER');
RegisterProperty('DATASET', 'TDATASET', iptr);
RegisterProperty('UPDATED', 'BOOLEAN', iptrw);
end;
end;
procedure SIRegisterTNAMEDITEM(CL: TPSPascalCompiler);
Begin
With RegClassS(cl,'TCOLLECTIONITEM','TNAMEDITEM') do
begin
RegisterProperty('NAME', 'String', iptrw);
end;
end;
procedure SIRegister_DB(Cl: TPSPascalCompiler);
Begin
cl.AddTypeS('TFieldType', '(ftUnknown, ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,'+
'ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,'+
'ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd)');
CL.AddTypeS('TDataSetState', '(dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter, dsNewValue, dsOldValue, dsCurValue, dsBlockRead, dsInternalCalc, dsOpening)');
cl.addTypeS('TLocateOption','(loCaseInsensitive, loPartialKey)');
cl.addtypes('TLocateOptions','set of TLocateOption');
cl.addtypes('TUpdateStatus','(usUnmodified, usModified, usInserted, usDeleted)');
cl.addtypes('TUpdateStatusSet', 'set of TUpdateStatus');
cl.addTypeS('TPARAMTYPE', 'BYTE');
RegClassS(cl,'TComponent','TDATASET');
RegClassS(cl,'TComponent','TFIELD');
RegClassS(cl,'TComponent','TFIELDDEFS');
RegClassS(cl,'TComponent','TINDEXDEFS');
RegClassS(cl, 'TComponent', 'TObjectField');
RegClassS(cl, 'TComponent', 'TDataLink');
RegClassS(cl, 'TComponent', 'TDataSource');
RegClassS(cl, 'TComponent', 'TParam');
SIRegisterTNAMEDITEM(Cl);
Cl.addTypeS('TDEFUPDATEMETHOD', 'Procedure');
SIRegisterTDEFCOLLECTION(Cl);
cl.AddConstantN('FAHIDDENCOL','LONGINT').Value.tu32 := 1;
cl.AddConstantN('FAREADONLY','LONGINT').Value.tu32 := 2;
cl.AddConstantN('FAREQUIRED','LONGINT').Value.tu32 := 4;
cl.AddConstantN('FALINK','LONGINT').Value.tu32 := 8;
cl.AddConstantN('FAUNNAMED','LONGINT').Value.tu32 := 16;
cl.AddConstantN('FAFIXED','LONGINT').Value.tu32 := 32;
cl.addTypeS('TFIELDATTRIBUTES', 'BYTE');
SIRegisterTFIELDDEF(Cl);
SIRegisterTFIELDDEFS(Cl);
cl.AddConstantN('IXPRIMARY','LONGINT').Value.tu32 := 1;
cl.AddConstantN('IXUNIQUE','LONGINT').Value.tu32 := 2;
cl.AddConstantN('IXDESCENDING','LONGINT').Value.tu32 := 4;
cl.AddConstantN('IXCASEINSENSITIVE','LONGINT').Value.tu32 := 8;
cl.AddConstantN('IXEXPRESSION','LONGINT').Value.tu32 := 16;
cl.AddConstantN('IXNONMAINTAINED','LONGINT').Value.tu32 := 32;
cl.addTypeS('TINDEXOPTIONS', 'BYTE');
SIRegisterTINDEXDEF(Cl);
SIRegisterTINDEXDEFS(Cl);
SIRegisterTFLATLIST(Cl);
SIRegisterTFIELDDEFLIST(Cl);
SIRegisterTFIELDLIST(Cl);
cl.AddConstantN('FKDATA','LONGINT').Value.tu32 := 1;
cl.AddConstantN('FKCALCULATED','LONGINT').Value.tu32 := 2;
cl.AddConstantN('FKLOOKUP','LONGINT').Value.tu32 := 4;
cl.AddConstantN('FKINTERNALCALC','LONGINT').Value.tu32 := 8;
cl.AddConstantN('FKAGGREGATE','LONGINT').Value.tu32 := 16;
cl.addTypeS('TFIELDKINDS', 'BYTE');
SIRegisterTFIELDS(Cl);
cl.AddConstantN('PFINUPDATE','LONGINT').Value.tu32 := 1;
cl.AddConstantN('PFINWHERE','LONGINT').Value.tu32 := 2;
cl.AddConstantN('PFINKEY','LONGINT').Value.tu32 := 4;
cl.AddConstantN('PFHIDDEN','LONGINT').Value.tu32 :=8;
cl.addTypeS('TPROVIDERFLAGS', 'BYTE');
cl.addTypeS('TFIELDNOTIFYEVENT', 'Procedure ( SENDER : TFIELD)');
cl.addTypeS('TFIELDGETTEXTEVENT', 'Procedure ( SENDER : TFIELD; var TEXT : S'
+'TRING; DISPLAYTEXT : BOOLEAN)');
cl.addTypeS('TFIELDSETTEXTEVENT', 'Procedure ( SENDER : TFIELD; const TEXT :'
+' String)');
cl.addTypeS('TAUTOREFRESHFLAG', '( ARNONE, ARAUTOINC, ARDEFAULT )');
SIRegisterTLOOKUPLIST(Cl);
SIRegisterTFIELD(Cl);
SIRegisterTSTRINGFIELD(Cl);
SIRegisterTWIDESTRINGFIELD(Cl);
SIRegisterTNUMERICFIELD(Cl);
SIRegisterTINTEGERFIELD(Cl);
SIRegisterTSMALLINTFIELD(Cl);
cl.addTypeS('LARGEINT', 'INT64');
SIRegisterTLARGEINTFIELD(Cl);
SIRegisterTWORDFIELD(Cl);
SIRegisterTAUTOINCFIELD(Cl);
SIRegisterTFLOATFIELD(Cl);
SIRegisterTCURRENCYFIELD(Cl);
SIRegisterTBOOLEANFIELD(Cl);
SIRegisterTDATETIMEFIELD(Cl);
SIRegisterTDATEFIELD(Cl);
SIRegisterTTIMEFIELD(Cl);
SIRegisterTBINARYFIELD(Cl);
SIRegisterTBYTESFIELD(Cl);
SIRegisterTVARBYTESFIELD(Cl);
SIRegisterTBCDFIELD(Cl);
{$IFDEF DELPHI6UP}
SIRegisterTFMTBCDFIELD(Cl);
{$ENDIF}
cl.addTypeS('TBLOBTYPE', 'BYTE');
SIRegisterTBLOBFIELD(Cl);
SIRegisterTMEMOFIELD(Cl);
SIRegisterTGRAPHICFIELD(Cl);
SIRegisterTOBJECTFIELD(Cl);
SIRegisterTADTFIELD(Cl);
SIRegisterTARRAYFIELD(Cl);
SIRegisterTDATASETFIELD(Cl);
SIRegisterTREFERENCEFIELD(Cl);
SIRegisterTVARIANTFIELD(Cl);
SIRegisterTGUIDFIELD(Cl);
cl.addTypeS('TBLOBDATA', 'STRING');
cl.AddConstantN('PTUNKNOWN','LONGINT').Value.tu32 := 1;
cl.AddConstantN('PTINPUT','LONGINT').Value.tu32 := 2;
cl.AddConstantN('PTOUTPUT','LONGINT').Value.tu32 := 4;
cl.AddConstantN('PTINPUTOUTPUT','LONGINT').Value.tu32 := 8;
cl.AddConstantN('PTRESULT','LONGINT').Value.tu32 := 16;
RegClassS(cl,'TObject','TPARAMS');
SIRegisterTPARAM(Cl);
SIRegisterTPARAMS(Cl);
cl.addTypeS('TDATAACTION', '( DAFAIL, DAABORT, DARETRY )');
cl.addTypeS('TBLOBSTREAMMODE', '( BMREAD, BMWRITE, BMREADWRITE )');
cl.addTypeS('TDATAOPERATION', 'Procedure');
cl.addTypeS('TDATASETNOTIFYEVENT', 'Procedure ( DATASET : TDATASET)');
cl.addTypeS('TDATASETERROREVENT', 'Procedure ( DATASET : TDATASET; E : TObject'
+'; var ACTION : TDATAACTION)');
cl.addTypeS('TFILTERRECORDEVENT', 'Procedure ( DATASET : TDATASET; var ACCEP'
+'T : BOOLEAN)');
SIRegisterTDATASET(Cl);
end;
{$IFDEF USEIMPORTER}
initialization
CIImporter.AddCallBack(@SIRegister_DB,PT_ClassImport);
{$ENDIF}
end.

87
Units/PascalScript/uPSC_buttons.pas Normal file
View File

@ -0,0 +1,87 @@
{ Compiletime Buttons support }
unit uPSC_buttons;
{$I PascalScript.inc}
interface
uses
uPSCompiler, uPSUtils;
{
Will register files from:
Buttons
Requires
STD, classes, controls and graphics and StdCtrls
}
procedure SIRegister_Buttons_TypesAndConsts(Cl: TPSPascalCompiler);
procedure SIRegisterTSPEEDBUTTON(Cl: TPSPascalCompiler);
procedure SIRegisterTBITBTN(Cl: TPSPascalCompiler);
procedure SIRegister_Buttons(Cl: TPSPascalCompiler);
implementation
procedure SIRegisterTSPEEDBUTTON(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TSPEEDBUTTON') do
begin
RegisterProperty('ALLOWALLUP', 'BOOLEAN', iptrw);
RegisterProperty('GROUPINDEX', 'INTEGER', iptrw);
RegisterProperty('DOWN', 'BOOLEAN', iptrw);
RegisterProperty('CAPTION', 'String', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('GLYPH', 'TBITMAP', iptrw);
RegisterProperty('LAYOUT', 'TBUTTONLAYOUT', iptrw);
RegisterProperty('MARGIN', 'INTEGER', iptrw);
RegisterProperty('NUMGLYPHS', 'BYTE', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('SPACING', 'INTEGER', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
end;
end;
procedure SIRegisterTBITBTN(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TBUTTON'), 'TBITBTN') do
begin
RegisterProperty('GLYPH', 'TBITMAP', iptrw);
RegisterProperty('KIND', 'TBITBTNKIND', iptrw);
RegisterProperty('LAYOUT', 'TBUTTONLAYOUT', iptrw);
RegisterProperty('MARGIN', 'INTEGER', iptrw);
RegisterProperty('NUMGLYPHS', 'BYTE', iptrw);
RegisterProperty('STYLE', 'TBUTTONSTYLE', iptrw);
RegisterProperty('SPACING', 'INTEGER', iptrw);
end;
end;
procedure SIRegister_Buttons_TypesAndConsts(Cl: TPSPascalCompiler);
begin
Cl.AddTypeS('TButtonLayout', '(blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom)');
Cl.AddTypeS('TButtonState', '(bsUp, bsDisabled, bsDown, bsExclusive)');
Cl.AddTypeS('TButtonStyle', '(bsAutoDetect, bsWin31, bsNew)');
Cl.AddTypeS('TBitBtnKind', '(bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose, bkAbort, bkRetry, bkIgnore, bkAll)');
end;
procedure SIRegister_Buttons(Cl: TPSPascalCompiler);
begin
SIRegister_Buttons_TypesAndConsts(cl);
SIRegisterTSPEEDBUTTON(cl);
SIRegisterTBITBTN(cl);
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

320
Units/PascalScript/uPSC_classes.pas Normal file
View File

@ -0,0 +1,320 @@
{ Compiletime Classes support }
unit uPSC_classes;
{$I PascalScript.inc}
interface
uses
uPSCompiler, uPSUtils;
{
Will register files from:
Classes (exception TPersistent and TComponent)
Register STD first
}
procedure SIRegister_Classes_TypesAndConsts(Cl: TPSPascalCompiler);
procedure SIRegisterTStrings(cl: TPSPascalCompiler; Streams: Boolean);
procedure SIRegisterTStringList(cl: TPSPascalCompiler);
{$IFNDEF PS_MINIVCL}
procedure SIRegisterTBITS(Cl: TPSPascalCompiler);
{$ENDIF}
procedure SIRegisterTSTREAM(Cl: TPSPascalCompiler);
procedure SIRegisterTHANDLESTREAM(Cl: TPSPascalCompiler);
{$IFNDEF PS_MINIVCL}
procedure SIRegisterTMEMORYSTREAM(Cl: TPSPascalCompiler);
{$ENDIF}
procedure SIRegisterTFILESTREAM(Cl: TPSPascalCompiler);
{$IFNDEF PS_MINIVCL}
procedure SIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSPascalCompiler);
procedure SIRegisterTRESOURCESTREAM(Cl: TPSPascalCompiler);
procedure SIRegisterTPARSER(Cl: TPSPascalCompiler);
procedure SIRegisterTCOLLECTIONITEM(CL: TPSPascalCompiler);
procedure SIRegisterTCOLLECTION(CL: TPSPascalCompiler);
{$IFDEF DELPHI3UP}
procedure SIRegisterTOWNEDCOLLECTION(CL: TPSPascalCompiler);
{$ENDIF}
{$ENDIF}
procedure SIRegister_Classes(Cl: TPSPascalCompiler; Streams: Boolean{$IFDEF D4PLUS}=True{$ENDIF});
implementation
procedure SIRegisterTStrings(cl: TPSPascalCompiler; Streams: Boolean); // requires TPersistent
begin
with Cl.AddClassN(cl.FindClass('TPersistent'), 'TStrings') do
begin
IsAbstract := True;
RegisterMethod('function Add(S: string): Integer;');
RegisterMethod('procedure Append(S: string);');
RegisterMethod('procedure AddStrings(Strings: TStrings);');
RegisterMethod('procedure Clear;');
RegisterMethod('procedure Delete(Index: Integer);');
RegisterMethod('function IndexOf(const S: string): Integer; ');
RegisterMethod('procedure Insert(Index: Integer; S: string); ');
RegisterProperty('Count', 'Integer', iptR);
RegisterProperty('Text', 'String', iptrw);
RegisterProperty('CommaText', 'String', iptrw);
if Streams then
begin
RegisterMethod('procedure LoadFromFile(FileName: string); ');
RegisterMethod('procedure SaveToFile(FileName: string); ');
end;
RegisterProperty('Strings', 'String Integer', iptRW);
SetDefaultPropery('Strings');
RegisterProperty('Objects', 'TObject Integer', iptRW);
{$IFNDEF PS_MINIVCL}
RegisterMethod('procedure BeginUpdate;');
RegisterMethod('procedure EndUpdate;');
RegisterMethod('function Equals(Strings: TStrings): Boolean;');
RegisterMethod('procedure Exchange(Index1, Index2: Integer);');
RegisterMethod('function IndexOfName(Name: string): Integer;');
if Streams then
RegisterMethod('procedure LoadFromStream(Stream: TStream); ');
RegisterMethod('procedure Move(CurIndex, NewIndex: Integer); ');
if Streams then
RegisterMethod('procedure SaveToStream(Stream: TStream); ');
RegisterMethod('procedure SetText(Text: PChar); ');
RegisterProperty('Names', 'String Integer', iptr);
RegisterProperty('Values', 'String String', iptRW);
RegisterMethod('function AddObject(S:String;AObject:TObject):integer');
RegisterMethod('function GetText:PChar');
RegisterMethod('function IndexofObject(AObject:tObject):Integer');
RegisterMethod('procedure InsertObject(Index:Integer;S:String;AObject:TObject)');
{$ENDIF}
end;
end;
procedure SIRegisterTSTRINGLIST(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TStrings'), 'TStringList') do
begin
RegisterMethod('function Find(S:String;var Index:Integer):Boolean');
RegisterMethod('procedure Sort');
RegisterProperty('Duplicates', 'TDuplicates', iptrw);
RegisterProperty('Sorted', 'Boolean', iptrw);
RegisterProperty('OnChange', 'TNotifyEvent', iptrw);
RegisterProperty('OnChanging', 'TNotifyEvent', iptrw);
end;
end;
{$IFNDEF PS_MINIVCL}
procedure SIRegisterTBITS(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TObject'), 'TBits') do
begin
RegisterMethod('function OpenBit:Integer');
RegisterProperty('Bits', 'Boolean Integer', iptrw);
RegisterProperty('Size', 'Integer', iptrw);
end;
end;
{$ENDIF}
procedure SIRegisterTSTREAM(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TOBJECT'), 'TStream') do
begin
IsAbstract := True;
RegisterMethod('function Read(Buffer:String;Count:LongInt):LongInt');
RegisterMethod('function Write(Buffer:String;Count:LongInt):LongInt');
RegisterMethod('function Seek(Offset:LongInt;Origin:Word):LongInt');
RegisterMethod('procedure ReadBuffer(Buffer:String;Count:LongInt)');
RegisterMethod('procedure WriteBuffer(Buffer:String;Count:LongInt)');
{$IFDEF DELPHI4UP}
RegisterMethod('function CopyFrom(Source:TStream;Count:Int64):LongInt');
{$ELSE}
RegisterMethod('function CopyFrom(Source:TStream;Count:Integer):LongInt');
{$ENDIF}
RegisterProperty('Position', 'LongInt', iptrw);
RegisterProperty('Size', 'LongInt', iptrw);
end;
end;
procedure SIRegisterTHANDLESTREAM(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TSTREAM'), 'THandleStream') do
begin
RegisterMethod('constructor Create(AHandle:Integer)');
RegisterProperty('Handle', 'Integer', iptr);
end;
end;
{$IFNDEF PS_MINIVCL}
procedure SIRegisterTMEMORYSTREAM(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMMEMORYSTREAM'), 'TMemoryStream') do
begin
RegisterMethod('procedure Clear');
RegisterMethod('procedure LoadFromStream(Stream:TStream)');
RegisterMethod('procedure LoadFromFile(FileName:String)');
RegisterMethod('procedure SetSize(NewSize:LongInt)');
end;
end;
{$ENDIF}
procedure SIRegisterTFILESTREAM(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('THandleStream'), 'TFileStream') do
begin
RegisterMethod('constructor Create(FileName:String;Mode:Word)');
end;
end;
{$IFNDEF PS_MINIVCL}
procedure SIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TSTREAM'), 'TCustomMemoryStream') do
begin
IsAbstract := True;
RegisterMethod('procedure SaveToStream(Stream:TStream)');
RegisterMethod('procedure SaveToFile(FileName:String)');
end;
end;
procedure SIRegisterTRESOURCESTREAM(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMMEMORYSTREAM'), 'TResourceStream') do
begin
RegisterMethod('constructor Create(Instance:THandle;ResName:String;ResType:PChar)');
RegisterMethod('constructor CreateFromId(Instance:THandle;ResId:Integer;ResType:PChar)');
end;
end;
procedure SIRegisterTPARSER(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TOBJECT'), 'TParser') do
begin
RegisterMethod('constructor Create(Stream:TStream)');
RegisterMethod('procedure CheckToken(t:char)');
RegisterMethod('procedure CheckTokenSymbol(s:string)');
RegisterMethod('procedure Error(Ident:Integer)');
RegisterMethod('procedure ErrorStr(Message:String)');
RegisterMethod('procedure HexToBinary(Stream:TStream)');
RegisterMethod('function NextToken:Char');
RegisterMethod('function SourcePos:LongInt');
RegisterMethod('function TokenComponentIdent:String');
RegisterMethod('function TokenFloat:Extended');
RegisterMethod('function TokenInt:LongInt');
RegisterMethod('function TokenString:String');
RegisterMethod('function TokenSymbolIs(S:String):Boolean');
RegisterProperty('SourceLine', 'Integer', iptr);
RegisterProperty('Token', 'Char', iptr);
end;
end;
procedure SIRegisterTCOLLECTIONITEM(CL: TPSPascalCompiler);
Begin
if cl.FindClass('TCOLLECTION') = nil then cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TCollection');
With cl.AddClassN(cl.FindClass('TPERSISTENT'),'TCollectionItem') do
begin
RegisterMethod('Constructor Create( Collection : TCollection)');
RegisterProperty('Collection', 'TCollection', iptrw);
{$IFDEF DELPHI3UP} RegisterProperty('Id', 'Integer', iptr); {$ENDIF}
RegisterProperty('Index', 'Integer', iptrw);
{$IFDEF DELPHI3UP} RegisterProperty('DisplayName', 'String', iptrw); {$ENDIF}
end;
end;
procedure SIRegisterTCOLLECTION(CL: TPSPascalCompiler);
var
cr: TPSCompileTimeClass;
Begin
cr := CL.FindClass('TCOLLECTION');
if cr = nil then cr := cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TCollection');
With cr do
begin
// RegisterMethod('constructor Create( ItemClass : TCollectionItemClass)');
{$IFDEF DELPHI3UP} RegisterMethod('function Owner : TPersistent'); {$ENDIF}
RegisterMethod('function Add : TCollectionItem');
RegisterMethod('procedure BeginUpdate');
RegisterMethod('procedure Clear');
{$IFDEF DELPHI5UP} RegisterMethod('procedure Delete( Index : Integer)'); {$ENDIF}
RegisterMethod('procedure EndUpdate');
{$IFDEF DELPHI3UP} RegisterMethod('function FindItemId( Id : Integer) : TCollectionItem'); {$ENDIF}
{$IFDEF DELPHI3UP} RegisterMethod('function Insert( Index : Integer) : TCollectionItem'); {$ENDIF}
RegisterProperty('Count', 'Integer', iptr);
{$IFDEF DELPHI3UP} RegisterProperty('ItemClass', 'TCollectionItemClass', iptr); {$ENDIF}
RegisterProperty('Items', 'TCollectionItem Integer', iptrw);
end;
end;
{$IFDEF DELPHI3UP}
procedure SIRegisterTOWNEDCOLLECTION(CL: TPSPascalCompiler);
Begin
With Cl.AddClassN(cl.FindClass('TCOLLECTION'),'TOwnedCollection') do
begin
// RegisterMethod('Constructor CREATE( AOWNER : TPERSISTENT; ITEMCLASS : TCOLLECTIONITEMCLASS)');
end;
end;
{$ENDIF}
{$ENDIF}
procedure SIRegister_Classes_TypesAndConsts(Cl: TPSPascalCompiler);
begin
cl.AddConstantN('soFromBeginning', 'Longint').Value.ts32 := 0;
cl.AddConstantN('soFromCurrent', 'Longint').Value.ts32 := 1;
cl.AddConstantN('soFromEnd', 'Longint').Value.ts32 := 2;
cl.AddConstantN('toEOF', 'Char').SetString(#0);
cl.AddConstantN('toSymbol', 'Char').SetString(#1);
cl.AddConstantN('toString', 'Char').SetString(#2);
cl.AddConstantN('toInteger', 'Char').SetString(#3);
cl.AddConstantN('toFloat', 'Char').SetString(#4);
cl.AddConstantN('fmCreate', 'Longint').Value.ts32 := $FFFF;
cl.AddConstantN('fmOpenRead', 'Longint').Value.ts32 := 0;
cl.AddConstantN('fmOpenWrite', 'Longint').Value.ts32 := 1;
cl.AddConstantN('fmOpenReadWrite', 'Longint').Value.ts32 := 2;
cl.AddConstantN('fmShareCompat', 'Longint').Value.ts32 := 0;
cl.AddConstantN('fmShareExclusive', 'Longint').Value.ts32 := $10;
cl.AddConstantN('fmShareDenyWrite', 'Longint').Value.ts32 := $20;
cl.AddConstantN('fmShareDenyRead', 'Longint').Value.ts32 := $30;
cl.AddConstantN('fmShareDenyNone', 'Longint').Value.ts32 := $40;
cl.AddConstantN('SecsPerDay', 'Longint').Value.ts32 := 86400;
cl.AddConstantN('MSecPerDay', 'Longint').Value.ts32 := 86400000;
cl.AddConstantN('DateDelta', 'Longint').Value.ts32 := 693594;
cl.AddTypeS('TAlignment', '(taLeftJustify, taRightJustify, taCenter)');
cl.AddTypeS('THelpEvent', 'function (Command: Word; Data: Longint; var CallHelp: Boolean): Boolean');
cl.AddTypeS('TGetStrProc', 'procedure(const S: string)');
cl.AddTypeS('TDuplicates', '(dupIgnore, dupAccept, dupError)');
cl.AddTypeS('TOperation', '(opInsert, opRemove)');
cl.AddTypeS('THANDLE', 'Longint');
cl.AddTypeS('TNotifyEvent', 'procedure (Sender: TObject)');
end;
procedure SIRegister_Classes(Cl: TPSPascalCompiler; Streams: Boolean);
begin
SIRegister_Classes_TypesAndConsts(Cl);
if Streams then
SIRegisterTSTREAM(Cl);
SIRegisterTStrings(cl, Streams);
SIRegisterTStringList(cl);
{$IFNDEF PS_MINIVCL}
SIRegisterTBITS(cl);
{$ENDIF}
if Streams then
begin
SIRegisterTHANDLESTREAM(Cl);
SIRegisterTFILESTREAM(Cl);
{$IFNDEF PS_MINIVCL}
SIRegisterTCUSTOMMEMORYSTREAM(Cl);
SIRegisterTMEMORYSTREAM(Cl);
SIRegisterTRESOURCESTREAM(Cl);
{$ENDIF}
end;
{$IFNDEF PS_MINIVCL}
SIRegisterTPARSER(Cl);
SIRegisterTCOLLECTIONITEM(Cl);
SIRegisterTCOLLECTION(Cl);
{$IFDEF DELPHI3UP}
SIRegisterTOWNEDCOLLECTION(Cl);
{$ENDIF}
{$ENDIF}
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

28
Units/PascalScript/uPSC_comobj.pas Normal file
View File

@ -0,0 +1,28 @@
{ compiletime ComObj support }
unit uPSC_comobj;
{$I PascalScript.inc}
interface
uses
uPSCompiler, uPSUtils;
{
Will register:
function CreateOleObject(const ClassName: String): IDispatch;
function GetActiveOleObject(const ClassName: String): IDispatch;
}
procedure SIRegister_ComObj(cl: TPSPascalCompiler);
implementation
procedure SIRegister_ComObj(cl: TPSPascalCompiler);
begin
cl.AddDelphiFunction('function CreateOleObject(const ClassName: String): IDispatch;');
cl.AddDelphiFunction('function GetActiveOleObject(const ClassName: String): IDispatch;');
end;
end.

236
Units/PascalScript/uPSC_controls.pas Normal file
View File

@ -0,0 +1,236 @@
{ Compiletime Controls support }
unit uPSC_controls;
{$I PascalScript.inc}
interface
uses
uPSCompiler, uPSUtils;
{
Will register files from:
Controls
Register the STD, Classes (at least the types&consts) and Graphics libraries first
}
procedure SIRegister_Controls_TypesAndConsts(Cl: TPSPascalCompiler);
procedure SIRegisterTControl(Cl: TPSPascalCompiler);
procedure SIRegisterTWinControl(Cl: TPSPascalCompiler);
procedure SIRegisterTGraphicControl(cl: TPSPascalCompiler);
procedure SIRegisterTCustomControl(cl: TPSPascalCompiler);
procedure SIRegisterTDragObject(cl: TPSPascalCompiler);
procedure SIRegister_Controls(Cl: TPSPascalCompiler);
implementation
procedure SIRegisterTControl(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TComponent'), 'TCONTROL') do
begin
RegisterMethod('constructor Create(AOwner: TComponent);');
RegisterMethod('procedure BringToFront;');
RegisterMethod('procedure Hide;');
RegisterMethod('procedure Invalidate;virtual;');
RegisterMethod('procedure refresh;');
RegisterMethod('procedure Repaint;virtual;');
RegisterMethod('procedure SendToBack;');
RegisterMethod('procedure Show;');
RegisterMethod('procedure Update;virtual;');
RegisterMethod('procedure SetBounds(x,y,w,h: Integer);virtual;');
RegisterProperty('Left', 'Integer', iptRW);
RegisterProperty('Top', 'Integer', iptRW);
RegisterProperty('Width', 'Integer', iptRW);
RegisterProperty('Height', 'Integer', iptRW);
RegisterProperty('Hint', 'String', iptRW);
RegisterProperty('Align', 'TAlign', iptRW);
RegisterProperty('ClientHeight', 'Longint', iptRW);
RegisterProperty('ClientWidth', 'Longint', iptRW);
RegisterProperty('ShowHint', 'Boolean', iptRW);
RegisterProperty('Visible', 'Boolean', iptRW);
RegisterProperty('ENABLED', 'BOOLEAN', iptrw);
RegisterProperty('CURSOR', 'TCURSOR', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterMethod('function Dragging: Boolean;');
RegisterMethod('function HasParent: Boolean');
RegisterMethod('procedure BEGINDRAG(IMMEDIATE:BOOLEAN)');
RegisterMethod('function CLIENTTOSCREEN(POINT:TPOINT):TPOINT');
RegisterMethod('procedure ENDDRAG(DROP:BOOLEAN)');
{$IFNDEF CLX}
RegisterMethod('function GETTEXTBUF(BUFFER:PCHAR;BUFSIZE:INTEGER):INTEGER');
RegisterMethod('function GETTEXTLEN:INTEGER');
RegisterMethod('procedure SETTEXTBUF(BUFFER:PCHAR)');
RegisterMethod('function PERFORM(MSG:CARDINAL;WPARAM,LPARAM:LONGINT):LONGINT');
{$ENDIF}
RegisterMethod('function SCREENTOCLIENT(POINT:TPOINT):TPOINT');
{$ENDIF}
end;
end;
procedure SIRegisterTWinControl(Cl: TPSPascalCompiler); // requires TControl
begin
with Cl.AddClassN(cl.FindClass('TControl'), 'TWINCONTROL') do
begin
with Cl.FindClass('TControl') do
begin
RegisterProperty('Parent', 'TWinControl', iptRW);
end;
{$IFNDEF CLX}
RegisterProperty('Handle', 'Longint', iptR);
{$ENDIF}
RegisterProperty('Showing', 'Boolean', iptR);
RegisterProperty('TabOrder', 'Integer', iptRW);
RegisterProperty('TabStop', 'Boolean', iptRW);
RegisterMethod('function CANFOCUS:BOOLEAN');
RegisterMethod('function FOCUSED:BOOLEAN');
RegisterProperty('CONTROLS', 'TCONTROL INTEGER', iptr);
RegisterProperty('CONTROLCOUNT', 'INTEGER', iptr);
{$IFNDEF PS_MINIVCL}
RegisterMethod('function HandleAllocated: Boolean;');
RegisterMethod('procedure HandleNeeded;');
RegisterMethod('procedure EnableAlign;');
RegisterMethod('procedure RemoveControl(AControl: TControl);');
RegisterMethod('procedure InsertControl(AControl: TControl);');
RegisterMethod('procedure Realign;');
RegisterMethod('procedure ScaleBy(M, D: Integer);');
RegisterMethod('procedure ScrollBy(DeltaX, DeltaY: Integer);');
RegisterMethod('procedure SetFocus; virtual;');
{$IFNDEF CLX}
RegisterMethod('procedure PAINTTO(DC:Longint;X,Y:INTEGER)');
{$ENDIF}
RegisterMethod('function CONTAINSCONTROL(CONTROL:TCONTROL):BOOLEAN');
RegisterMethod('procedure DISABLEALIGN');
RegisterMethod('procedure UPDATECONTROLSTATE');
RegisterProperty('BRUSH', 'TBRUSH', iptr);
RegisterProperty('HELPCONTEXT', 'LONGINT', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTGraphicControl(cl: TPSPascalCompiler); // requires TControl
begin
Cl.AddClassN(cl.FindClass('TControl'), 'TGRAPHICCONTROL');
end;
procedure SIRegisterTCustomControl(cl: TPSPascalCompiler); // requires TWinControl
begin
Cl.AddClassN(cl.FindClass('TWinControl'), 'TCUSTOMCONTROL');
end;
procedure SIRegister_Controls_TypesAndConsts(Cl: TPSPascalCompiler);
begin
{$IFNDEF FPC}
Cl.addTypeS('TEShiftState','(ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble)');
{$ELSE}
Cl.addTypeS('TEShiftState','(ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble,' +
'ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum,ssScroll,ssTriple,ssQuad)');
{$ENDIF}
Cl.addTypeS('TShiftState','set of TEShiftState');
cl.AddTypeS('TMouseButton', '(mbLeft, mbRight, mbMiddle)');
cl.AddTypeS('TDragMode', '(dmManual, dmAutomatic)');
cl.AddTypeS('TDragState', '(dsDragEnter, dsDragLeave, dsDragMove)');
cl.AddTypeS('TDragKind', '(dkDrag, dkDock)');
cl.AddTypeS('TMouseEvent', 'procedure (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);');
cl.AddTypeS('TMouseMoveEvent', 'procedure(Sender: TObject; Shift: TShiftState; X, Y: Integer);');
cl.AddTypeS('TKeyEvent', 'procedure (Sender: TObject; var Key: Word; Shift: TShiftState);');
cl.AddTypeS('TKeyPressEvent', 'procedure(Sender: TObject; var Key: Char);');
cl.AddTypeS('TDragOverEvent', 'procedure(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean)');
cl.AddTypeS('TDragDropEvent', 'procedure(Sender, Source: TObject;X, Y: Integer)');
cl.AddTypeS('HWND', 'Longint');
cl.AddTypeS('TEndDragEvent', 'procedure(Sender, Target: TObject; X, Y: Integer)');
cl.addTypeS('TAlign', '(alNone, alTop, alBottom, alLeft, alRight, alClient)');
cl.addTypeS('TAnchorKind', '(akTop, akLeft, akRight, akBottom)');
cl.addTypeS('TAnchors','set of TAnchorKind');
cl.AddTypeS('TModalResult', 'Integer');
cl.AddTypeS('TCursor', 'Integer');
cl.AddTypeS('TPoint', 'record x,y: Longint; end;');
cl.AddConstantN('mrNone', 'Integer').Value.ts32 := 0;
cl.AddConstantN('mrOk', 'Integer').Value.ts32 := 1;
cl.AddConstantN('mrCancel', 'Integer').Value.ts32 := 2;
cl.AddConstantN('mrAbort', 'Integer').Value.ts32 := 3;
cl.AddConstantN('mrRetry', 'Integer').Value.ts32 := 4;
cl.AddConstantN('mrIgnore', 'Integer').Value.ts32 := 5;
cl.AddConstantN('mrYes', 'Integer').Value.ts32 := 6;
cl.AddConstantN('mrNo', 'Integer').Value.ts32 := 7;
cl.AddConstantN('mrAll', 'Integer').Value.ts32 := 8;
cl.AddConstantN('mrNoToAll', 'Integer').Value.ts32 := 9;
cl.AddConstantN('mrYesToAll', 'Integer').Value.ts32 := 10;
cl.AddConstantN('crDefault', 'Integer').Value.ts32 := 0;
cl.AddConstantN('crNone', 'Integer').Value.ts32 := -1;
cl.AddConstantN('crArrow', 'Integer').Value.ts32 := -2;
cl.AddConstantN('crCross', 'Integer').Value.ts32 := -3;
cl.AddConstantN('crIBeam', 'Integer').Value.ts32 := -4;
cl.AddConstantN('crSizeNESW', 'Integer').Value.ts32 := -6;
cl.AddConstantN('crSizeNS', 'Integer').Value.ts32 := -7;
cl.AddConstantN('crSizeNWSE', 'Integer').Value.ts32 := -8;
cl.AddConstantN('crSizeWE', 'Integer').Value.ts32 := -9;
cl.AddConstantN('crUpArrow', 'Integer').Value.ts32 := -10;
cl.AddConstantN('crHourGlass', 'Integer').Value.ts32 := -11;
cl.AddConstantN('crDrag', 'Integer').Value.ts32 := -12;
cl.AddConstantN('crNoDrop', 'Integer').Value.ts32 := -13;
cl.AddConstantN('crHSplit', 'Integer').Value.ts32 := -14;
cl.AddConstantN('crVSplit', 'Integer').Value.ts32 := -15;
cl.AddConstantN('crMultiDrag', 'Integer').Value.ts32 := -16;
cl.AddConstantN('crSQLWait', 'Integer').Value.ts32 := -17;
cl.AddConstantN('crNo', 'Integer').Value.ts32 := -18;
cl.AddConstantN('crAppStart', 'Integer').Value.ts32 := -19;
cl.AddConstantN('crHelp', 'Integer').Value.ts32 := -20;
{$IFDEF DELPHI3UP}
cl.AddConstantN('crHandPoint', 'Integer').Value.ts32 := -21;
{$ENDIF}
{$IFDEF DELPHI4UP}
cl.AddConstantN('crSizeAll', 'Integer').Value.ts32 := -22;
{$ENDIF}
end;
procedure SIRegisterTDragObject(cl: TPSPascalCompiler);
begin
with CL.AddClassN(CL.FindClass('TObject'),'TDragObject') do
begin
{$IFNDEF PS_MINIVCL}
{$IFDEF DELPHI4UP}
RegisterMethod('Procedure Assign( Source : TDragObject)');
{$ENDIF}
{$IFNDEF FPC}
RegisterMethod('Function GetName : String');
RegisterMethod('Function Instance : Longint');
{$ENDIF}
RegisterMethod('Procedure HideDragImage');
RegisterMethod('Procedure ShowDragImage');
{$IFDEF DELPHI4UP}
RegisterProperty('Cancelling', 'Boolean', iptrw);
RegisterProperty('DragHandle', 'Longint', iptrw);
RegisterProperty('DragPos', 'TPoint', iptrw);
RegisterProperty('DragTargetPos', 'TPoint', iptrw);
RegisterProperty('MouseDeltaX', 'Double', iptr);
RegisterProperty('MouseDeltaY', 'Double', iptr);
{$ENDIF}
{$ENDIF}
end;
Cl.AddTypeS('TStartDragEvent', 'procedure (Sender: TObject; var DragObject: TDragObject)');
end;
procedure SIRegister_Controls(Cl: TPSPascalCompiler);
begin
SIRegister_Controls_TypesAndConsts(cl);
SIRegisterTDragObject(cl);
SIRegisterTControl(Cl);
SIRegisterTWinControl(Cl);
SIRegisterTGraphicControl(cl);
SIRegisterTCustomControl(cl);
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

34
Units/PascalScript/uPSC_dateutils.pas Normal file
View File

@ -0,0 +1,34 @@
{ Compile time Date Time library }
unit uPSC_dateutils;
interface
uses
SysUtils, uPSCompiler, uPSUtils;
procedure RegisterDateTimeLibrary_C(S: TPSPascalCompiler);
implementation
procedure RegisterDatetimeLibrary_C(S: TPSPascalCompiler);
begin
s.AddType('TDateTime', btDouble).ExportName := True;
s.AddDelphiFunction('function EncodeDate(Year, Month, Day: Word): TDateTime;');
s.AddDelphiFunction('function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;');
s.AddDelphiFunction('function TryEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean;');
s.AddDelphiFunction('function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;');
s.AddDelphiFunction('procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word);');
s.AddDelphiFunction('procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word);');
s.AddDelphiFunction('function DayOfWeek(const DateTime: TDateTime): Word;');
s.AddDelphiFunction('function Date: TDateTime;');
s.AddDelphiFunction('function Time: TDateTime;');
s.AddDelphiFunction('function Now: TDateTime;');
s.AddDelphiFunction('function DateTimeToUnix(D: TDateTime): Int64;');
s.AddDelphiFunction('function UnixToDateTime(U: Int64): TDateTime;');
s.AddDelphiFunction('function DateToStr(D: TDateTime): String;');
s.AddDelphiFunction('function StrToDate(const s: String): TDateTime;');
s.AddDelphiFunction('function FormatDateTime(const fmt: String; D: TDateTime): String;');
end;
end.

158
Units/PascalScript/uPSC_dll.pas Normal file
View File

@ -0,0 +1,158 @@
{ Compiletime DLL importing support }
unit uPSC_dll;
{$I PascalScript.inc}
interface
{
Function FindWindow(c1, c2: PChar): Cardinal; external 'FindWindow@user32.dll stdcall';
}
uses
uPSCompiler, uPSUtils;
{$IFDEF DELPHI3UP }
resourceString
{$ELSE }
const
{$ENDIF }
RPS_Invalid_External = 'Invalid External';
RPS_InvalidCallingConvention = 'Invalid Calling Convention';
function DllExternalProc(Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const OriginalName, FExternal: tbtstring): TPSRegProc;
type
TDllCallingConvention = (clRegister
, clPascal
, ClCdecl
, ClStdCall
);
var
DefaultCC: TDllCallingConvention;
procedure RegisterDll_Compiletime(cs: TPSPascalCompiler);
implementation
function rpos(ch: tbtchar; const s: tbtstring): Longint;
var
i: Longint;
begin
for i := length(s) downto 1 do
if s[i] = ch then begin Result := i; exit; end;
result := 0;
end;
function RemoveQuotes(s: tbtstring): tbtstring;
begin
result := s;
if result = '' then exit;
if Result[1] = '"' then delete(result ,1,1);
if (Result <> '') and (Result[Length(result)] = '"') then delete(result, length(result), 1);
end;
function DllExternalProc(Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const OriginalName, FExternal: tbtstring): TPSRegProc;
var
FuncName,
Name,
FuncCC, s, s2: AnsiString;
CC: TDllCallingConvention;
DelayLoad, LoadWithAlteredSearchPath: Boolean;
begin
Name := FastUpperCase(OriginalName);
DelayLoad := False;
LoadWithAlteredSearchPath := false;
FuncCC := FExternal;
if (pos(tbtChar('@'), FuncCC) = 0) then
begin
Sender.MakeError('', ecCustomError, tbtString(RPS_Invalid_External));
Result := nil;
exit;
end;
FuncName := copy(FuncCC, 1, rpos('@', FuncCC)-1)+#0;
delete(FuncCc, 1, length(FuncName));
if pos(tbtchar(' '), Funccc) <> 0 then
begin
if FuncCC[1] = '"' then
begin
Delete(FuncCC, 1, 1);
FuncName := RemoveQuotes(copy(FuncCC, 1, pos(tbtchar('"'), FuncCC)-1))+#0+FuncName;
Delete(FuncCC,1, pos(tbtchar('"'), FuncCC));
if (FuncCC <> '') and( FuncCC[1] = ' ') then delete(FuncCC,1,1);
end else
begin
FuncName := copy(FuncCc, 1, pos(tbtchar(' '),FuncCC)-1)+#0+FuncName;
Delete(FuncCC, 1, pos(tbtchar(' '), FuncCC));
end;
if pos(tbtchar(' '), FuncCC) > 0 then
begin
s := Copy(FuncCC, pos(tbtchar(' '), Funccc)+1, MaxInt);
FuncCC := FastUpperCase(Copy(FuncCC, 1, pos(tbtchar(' '), FuncCC)-1));
Delete(FuncCC, pos(tbtchar(' '), Funccc), MaxInt);
repeat
if pos(tbtchar(' '), s) > 0 then begin
s2 := Copy(s, 1, pos(tbtchar(' '), s)-1);
delete(s, 1, pos(tbtchar(' '), s));
end else begin
s2 := s;
s := '';
end;
if FastUppercase(s2) = 'DELAYLOAD' then
DelayLoad := True
{$IFNDEF LINUX}
else
if FastUppercase(s2) = 'LOADWITHALTEREDSEARCHPATH' then
LoadWithAlteredSearchPath := True
{$ENDIF}
else
begin
Sender.MakeError('', ecCustomError, 'Invalid External');
Result := nil;
exit;
end;
until s = '';
end else
FuncCC := FastUpperCase(FuncCC);
if FuncCC = 'STDCALL' then cc := ClStdCall else
if FuncCC = 'CDECL' then cc := ClCdecl else
if FuncCC = 'REGISTER' then cc := clRegister else
if FuncCC = 'PASCAL' then cc := clPascal else
begin
Sender.MakeError('', ecCustomError, tbtstring(RPS_InvalidCallingConvention));
Result := nil;
exit;
end;
end else
begin
FuncName := RemoveQuotes(FuncCC)+#0+FuncName;
FuncCC := '';
cc := DefaultCC;
end;
FuncName := 'dll:'+FuncName+tbtchar(cc)+tbtchar(bytebool(DelayLoad)) +tbtchar(bytebool(LoadWithAlteredSearchPath))+ declToBits(Decl);
Result := TPSRegProc.Create;
Result.ImportDecl := FuncName;
Result.Decl.Assign(Decl);
Result.Name := Name;
Result.OrgName := OriginalName;
Result.ExportName := False;
end;
procedure RegisterDll_Compiletime(cs: TPSPascalCompiler);
begin
cs.OnExternalProc := DllExternalProc;
cs.AddFunction('procedure UnloadDll(s: string)');
cs.AddFunction('function DLLGetLastError: Longint');
end;
begin
DefaultCc := clRegister;
end.

327
Units/PascalScript/uPSC_extctrls.pas Normal file
View File

@ -0,0 +1,327 @@
{ Compiletime Extctrls support }
unit uPSC_extctrls;
{$I PascalScript.inc}
interface
uses
uPSCompiler, uPSUtils;
(*
Will register files from:
ExtCtrls
Requires:
STD, classes, controls, graphics {$IFNDEF PS_MINIVCL}, stdctrls {$ENDIF}
*)
procedure SIRegister_ExtCtrls_TypesAndConsts(cl: TPSPascalCompiler);
procedure SIRegisterTSHAPE(Cl: TPSPascalCompiler);
procedure SIRegisterTIMAGE(Cl: TPSPascalCompiler);
procedure SIRegisterTPAINTBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTBEVEL(Cl: TPSPascalCompiler);
procedure SIRegisterTTIMER(Cl: TPSPascalCompiler);
procedure SIRegisterTCUSTOMPANEL(Cl: TPSPascalCompiler);
procedure SIRegisterTPANEL(Cl: TPSPascalCompiler);
{$IFNDEF CLX}
procedure SIRegisterTPAGE(Cl: TPSPascalCompiler);
procedure SIRegisterTNOTEBOOK(Cl: TPSPascalCompiler);
procedure SIRegisterTHEADER(Cl: TPSPascalCompiler);
{$ENDIF}
procedure SIRegisterTCUSTOMRADIOGROUP(Cl: TPSPascalCompiler);
procedure SIRegisterTRADIOGROUP(Cl: TPSPascalCompiler);
procedure SIRegister_ExtCtrls(cl: TPSPascalCompiler);
implementation
procedure SIRegisterTSHAPE(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TSHAPE') do
begin
RegisterProperty('BRUSH', 'TBRUSH', iptrw);
RegisterProperty('PEN', 'TPEN', iptrw);
RegisterProperty('SHAPE', 'TSHAPETYPE', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterMethod('procedure STYLECHANGED(SENDER:TOBJECT)');
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTIMAGE(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TIMAGE') do
begin
RegisterProperty('CANVAS', 'TCANVAS', iptr);
RegisterProperty('AUTOSIZE', 'BOOLEAN', iptrw);
RegisterProperty('CENTER', 'BOOLEAN', iptrw);
RegisterProperty('PICTURE', 'TPICTURE', iptrw);
RegisterProperty('STRETCH', 'BOOLEAN', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTPAINTBOX(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TPAINTBOX') do
begin
RegisterProperty('CANVAS', 'TCanvas', iptr);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONPAINT', 'TNOTIFYEVENT', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTBEVEL(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TBEVEL') do
begin
RegisterProperty('SHAPE', 'TBEVELSHAPE', iptrw);
RegisterProperty('STYLE', 'TBEVELSTYLE', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTTIMER(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCOMPONENT'), 'TTIMER') do
begin
RegisterProperty('ENABLED', 'BOOLEAN', iptrw);
RegisterProperty('INTERVAL', 'CARDINAL', iptrw);
RegisterProperty('ONTIMER', 'TNOTIFYEVENT', iptrw);
end;
end;
procedure SIRegisterTCUSTOMPANEL(Cl: TPSPascalCompiler);
begin
Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TCUSTOMPANEL');
end;
procedure SIRegisterTPANEL(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMPANEL'), 'TPANEL') do
begin
RegisterProperty('ALIGNMENT', 'TAlignment', iptrw);
RegisterProperty('BEVELINNER', 'TPanelBevel', iptrw);
RegisterProperty('BEVELOUTER', 'TPanelBevel', iptrw);
RegisterProperty('BEVELWIDTH', 'TBevelWidth', iptrw);
RegisterProperty('BORDERWIDTH', 'TBorderWidth', iptrw);
RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw);
RegisterProperty('CAPTION', 'String', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('LOCKED', 'Boolean', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONRESIZE', 'TNotifyEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
{$IFNDEF CLX}
procedure SIRegisterTPAGE(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TPAGE') do
begin
RegisterProperty('CAPTION', 'String', iptrw);
end;
end;
procedure SIRegisterTNOTEBOOK(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TNOTEBOOK') do
begin
RegisterProperty('ACTIVEPAGE', 'String', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('PAGEINDEX', 'INTEGER', iptrw);
RegisterProperty('PAGES', 'TSTRINGS', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
RegisterProperty('ONPAGECHANGED', 'TNOTIFYEVENT', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTHEADER(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'THEADER') do
begin
RegisterProperty('SECTIONWIDTH', 'INTEGER INTEGER', iptrw);
RegisterProperty('ALLOWRESIZE', 'BOOLEAN', iptrw);
RegisterProperty('BORDERSTYLE', 'TBORDERSTYLE', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('SECTIONS', 'TSTRINGS', iptrw);
RegisterProperty('ONSIZING', 'TSECTIONEVENT', iptrw);
RegisterProperty('ONSIZED', 'TSECTIONEVENT', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
{$ENDIF}
end;
end;
{$ENDIF}
procedure SIRegisterTCUSTOMRADIOGROUP(Cl: TPSPascalCompiler);
begin
Cl.AddClassN(cl.FindClass('TCUSTOMGROUPBOX'), 'TCUSTOMRADIOGROUP');
end;
procedure SIRegisterTRADIOGROUP(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMRADIOGROUP'), 'TRADIOGROUP') do
begin
RegisterProperty('CAPTION', 'String', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('COLUMNS', 'Integer', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('ITEMINDEX', 'Integer', iptrw);
RegisterProperty('ITEMS', 'TStrings', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegister_ExtCtrls_TypesAndConsts(cl: TPSPascalCompiler);
begin
cl.AddTypeS('TShapeType', '(stRectangle, stSquare, stRoundRect, stRoundSquare, stEllipse, stCircle)');
cl.AddTypeS('TBevelStyle', '(bsLowered, bsRaised)');
cl.AddTypeS('TBevelShape', '(bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine, bsRightLine,bsSpacer)');
cl.AddTypeS('TPanelBevel', '(bvNone, bvLowered, bvRaised,bvSpace)');
cl.AddTypeS('TBevelWidth', 'Longint');
cl.AddTypeS('TBorderWidth', 'Longint');
cl.AddTypeS('TSectionEvent', 'procedure(Sender: TObject; ASection, AWidth: Integer)');
end;
procedure SIRegister_ExtCtrls(cl: TPSPascalCompiler);
begin
SIRegister_ExtCtrls_TypesAndConsts(cl);
{$IFNDEF PS_MINIVCL}
SIRegisterTSHAPE(Cl);
SIRegisterTIMAGE(Cl);
SIRegisterTPAINTBOX(Cl);
{$ENDIF}
SIRegisterTBEVEL(Cl);
{$IFNDEF PS_MINIVCL}
SIRegisterTTIMER(Cl);
{$ENDIF}
SIRegisterTCUSTOMPANEL(Cl);
SIRegisterTPANEL(Cl);
{$IFNDEF PS_MINIVCL}
{$IFNDEF CLX}
SIRegisterTPAGE(Cl);
SIRegisterTNOTEBOOK(Cl);
SIRegisterTHEADER(Cl);
{$ENDIF}
SIRegisterTCUSTOMRADIOGROUP(Cl);
SIRegisterTRADIOGROUP(Cl);
{$ENDIF}
end;
end.

271
Units/PascalScript/uPSC_forms.pas Normal file
View File

@ -0,0 +1,271 @@
{ Compiletime Forms support }
unit uPSC_forms;
{$I PascalScript.inc}
interface
uses
uPSCompiler, uPSUtils;
procedure SIRegister_Forms_TypesAndConsts(Cl: TPSPascalCompiler);
procedure SIRegisterTCONTROLSCROLLBAR(Cl: TPSPascalCompiler);
procedure SIRegisterTSCROLLINGWINCONTROL(Cl: TPSPascalCompiler);
procedure SIRegisterTSCROLLBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTFORM(Cl: TPSPascalCompiler);
procedure SIRegisterTAPPLICATION(Cl: TPSPascalCompiler);
procedure SIRegister_Forms(Cl: TPSPascalCompiler);
implementation
procedure SIRegisterTCONTROLSCROLLBAR(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TCONTROLSCROLLBAR') do
begin
RegisterProperty('KIND', 'TSCROLLBARKIND', iptr);
RegisterProperty('SCROLLPOS', 'INTEGER', iptr);
RegisterProperty('MARGIN', 'WORD', iptrw);
RegisterProperty('INCREMENT', 'TSCROLLBARINC', iptrw);
RegisterProperty('RANGE', 'INTEGER', iptrw);
RegisterProperty('POSITION', 'INTEGER', iptrw);
RegisterProperty('TRACKING', 'BOOLEAN', iptrw);
RegisterProperty('VISIBLE', 'BOOLEAN', iptrw);
end;
end;
procedure SIRegisterTSCROLLINGWINCONTROL(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TSCROLLINGWINCONTROL') do
begin
RegisterMethod('procedure SCROLLINVIEW(ACONTROL:TCONTROL)');
RegisterProperty('HORZSCROLLBAR', 'TCONTROLSCROLLBAR', iptrw);
RegisterProperty('VERTSCROLLBAR', 'TCONTROLSCROLLBAR', iptrw);
end;
end;
procedure SIRegisterTSCROLLBOX(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TSCROLLINGWINCONTROL'), 'TSCROLLBOX') do
begin
RegisterProperty('BORDERSTYLE', 'TBORDERSTYLE', iptrw);
RegisterProperty('COLOR', 'TCOLOR', iptrw);
RegisterProperty('FONT', 'TFONT', iptrw);
RegisterProperty('AUTOSCROLL', 'BOOLEAN', iptrw);
RegisterProperty('PARENTCOLOR', 'BOOLEAN', iptrw);
RegisterProperty('PARENTFONT', 'BOOLEAN', iptrw);
RegisterProperty('ONCLICK', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONDBLCLICK', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONENTER', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONEXIT', 'TNOTIFYEVENT', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('ONRESIZE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('DRAGCURSOR', 'TCURSOR', iptrw);
RegisterProperty('DRAGMODE', 'TDRAGMODE', iptrw);
RegisterProperty('PARENTSHOWHINT', 'BOOLEAN', iptrw);
RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptrw);
RegisterProperty('CTL3D', 'BOOLEAN', iptrw);
RegisterProperty('PARENTCTL3D', 'BOOLEAN', iptrw);
RegisterProperty('ONDRAGDROP', 'TDRAGDROPEVENT', iptrw);
RegisterProperty('ONDRAGOVER', 'TDRAGOVEREVENT', iptrw);
RegisterProperty('ONENDDRAG', 'TENDDRAGEVENT', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMOUSEEVENT', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMOUSEMOVEEVENT', iptrw);
RegisterProperty('ONMOUSEUP', 'TMOUSEEVENT', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTFORM(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TSCROLLINGWINCONTROL'), 'TFORM') do
begin
{$IFDEF DELPHI4UP}
RegisterMethod('constructor CREATENEW(AOWNER:TCOMPONENT; Dummy: Integer)');
{$ELSE}
RegisterMethod('constructor CREATENEW(AOWNER:TCOMPONENT)');
{$ENDIF}
RegisterMethod('procedure CLOSE');
RegisterMethod('procedure HIDE');
RegisterMethod('procedure SHOW');
RegisterMethod('function SHOWMODAL:INTEGER');
RegisterMethod('procedure RELEASE');
RegisterProperty('ACTIVE', 'BOOLEAN', iptr);
RegisterProperty('ACTIVECONTROL', 'TWINCONTROL', iptrw);
RegisterProperty('BORDERICONS', 'TBorderIcons', iptrw);
RegisterProperty('BORDERSTYLE', 'TFORMBORDERSTYLE', iptrw);
RegisterProperty('CAPTION', 'NativeString', iptrw);
RegisterProperty('AUTOSCROLL', 'BOOLEAN', iptrw);
RegisterProperty('COLOR', 'TCOLOR', iptrw);
RegisterProperty('FONT', 'TFONT', iptrw);
RegisterProperty('FORMSTYLE', 'TFORMSTYLE', iptrw);
RegisterProperty('KEYPREVIEW', 'BOOLEAN', iptrw);
RegisterProperty('POSITION', 'TPOSITION', iptrw);
RegisterProperty('ONACTIVATE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONCLICK', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONDBLCLICK', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONCLOSE', 'TCLOSEEVENT', iptrw);
RegisterProperty('ONCLOSEQUERY', 'TCLOSEQUERYEVENT', iptrw);
RegisterProperty('ONCREATE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONDESTROY', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONDEACTIVATE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONHIDE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONKEYDOWN', 'TKEYEVENT', iptrw);
RegisterProperty('ONKEYPRESS', 'TKEYPRESSEVENT', iptrw);
RegisterProperty('ONKEYUP', 'TKEYEVENT', iptrw);
RegisterProperty('ONRESIZE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONSHOW', 'TNOTIFYEVENT', iptrw);
{$IFNDEF PS_MINIVCL}
{$IFNDEF CLX}
RegisterMethod('procedure ARRANGEICONS');
// RegisterMethod('function GETFORMIMAGE:TBITMAP');
RegisterMethod('procedure PRINT');
RegisterMethod('procedure SENDCANCELMODE(SENDER:TCONTROL)');
RegisterProperty('ACTIVEOLECONTROL', 'TWINCONTROL', iptrw);
RegisterProperty('OLEFORMOBJECT', 'TOLEFORMOBJECT', iptrw);
RegisterProperty('CLIENTHANDLE', 'LONGINT', iptr);
RegisterProperty('TILEMODE', 'TTILEMODE', iptrw);
{$ENDIF}
RegisterMethod('procedure CASCADE');
RegisterMethod('function CLOSEQUERY:BOOLEAN');
RegisterMethod('procedure DEFOCUSCONTROL(CONTROL:TWINCONTROL;REMOVING:BOOLEAN)');
RegisterMethod('procedure FOCUSCONTROL(CONTROL:TWINCONTROL)');
RegisterMethod('procedure NEXT');
RegisterMethod('procedure PREVIOUS');
RegisterMethod('function SETFOCUSEDCONTROL(CONTROL:TWINCONTROL):BOOLEAN');
RegisterMethod('procedure TILE');
RegisterProperty('ACTIVEMDICHILD', 'TFORM', iptr);
RegisterProperty('CANVAS', 'TCANVAS', iptr);
RegisterProperty('DROPTARGET', 'BOOLEAN', iptrw);
RegisterProperty('MODALRESULT', 'Longint', iptrw);
RegisterProperty('MDICHILDCOUNT', 'INTEGER', iptr);
RegisterProperty('MDICHILDREN', 'TFORM INTEGER', iptr);
RegisterProperty('ICON', 'TICON', iptrw);
RegisterProperty('MENU', 'TMAINMENU', iptrw);
RegisterProperty('OBJECTMENUITEM', 'TMENUITEM', iptrw);
RegisterProperty('PIXELSPERINCH', 'INTEGER', iptrw);
RegisterProperty('PRINTSCALE', 'TPRINTSCALE', iptrw);
RegisterProperty('SCALED', 'BOOLEAN', iptrw);
RegisterProperty('WINDOWSTATE', 'TWINDOWSTATE', iptrw);
RegisterProperty('WINDOWMENU', 'TMENUITEM', iptrw);
RegisterProperty('CTL3D', 'BOOLEAN', iptrw);
RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptrw);
RegisterProperty('ONDRAGDROP', 'TDRAGDROPEVENT', iptrw);
RegisterProperty('ONDRAGOVER', 'TDRAGOVEREVENT', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMOUSEEVENT', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMOUSEMOVEEVENT', iptrw);
RegisterProperty('ONMOUSEUP', 'TMOUSEEVENT', iptrw);
RegisterProperty('ONPAINT', 'TNOTIFYEVENT', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTAPPLICATION(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCOMPONENT'), 'TAPPLICATION') do
begin
RegisterMethod('procedure BRINGTOFRONT');
{$IFDEF PS_PANSICHAR}
RegisterMethod('function MESSAGEBOX(TEXT,CAPTION:PANSICHAR;FLAGS:WORD):INTEGER');
{$ELSE}
RegisterMethod('function MESSAGEBOX(TEXT,CAPTION:PCHAR;FLAGS:WORD):INTEGER');
{$ENDIF}
RegisterMethod('procedure MINIMIZE');
RegisterMethod('procedure PROCESSMESSAGES');
RegisterMethod('procedure RESTORE');
RegisterMethod('procedure TERMINATE');
RegisterProperty('ACTIVE', 'BOOLEAN', iptr);
RegisterProperty('EXENAME', 'NativeString', iptr);
{$IFNDEF CLX}
RegisterProperty('HANDLE', 'LONGINT', iptrw);
RegisterProperty('UPDATEFORMATSETTINGS', 'BOOLEAN', iptrw);
{$ENDIF}
RegisterProperty('HINT', 'NativeString', iptrw);
RegisterProperty('MAINFORM', 'TFORM', iptr);
RegisterProperty('SHOWHINT', 'BOOLEAN', iptrw);
RegisterProperty('SHOWMAINFORM', 'BOOLEAN', iptrw);
RegisterProperty('TERMINATED', 'BOOLEAN', iptr);
RegisterProperty('TITLE', 'NativeString', iptrw);
RegisterProperty('ONACTIVATE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONDEACTIVATE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONIDLE', 'TIDLEEVENT', iptrw);
RegisterProperty('ONHINT', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONMINIMIZE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONRESTORE', 'TNOTIFYEVENT', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterMethod('procedure CONTROLDESTROYED(CONTROL:TCONTROL)');
RegisterMethod('procedure CANCELHINT');
RegisterMethod('procedure HANDLEEXCEPTION(SENDER:TOBJECT)');
RegisterMethod('procedure HANDLEMESSAGE');
RegisterMethod('procedure HIDEHINT');
// RegisterMethod('procedure HINTMOUSEMESSAGE(CONTROL:TCONTROL;var MESSAGE:TMESSAGE)');
RegisterMethod('procedure INITIALIZE');
RegisterMethod('procedure NORMALIZETOPMOSTS');
RegisterMethod('procedure RESTORETOPMOSTS');
RegisterMethod('procedure RUN');
// RegisterMethod('procedure SHOWEXCEPTION(E:EXCEPTION)');
{$IFNDEF CLX}
RegisterMethod('function HELPCOMMAND(COMMAND:INTEGER;DATA:LONGINT):BOOLEAN');
RegisterMethod('function HELPCONTEXT(CONTEXT:THELPCONTEXT):BOOLEAN');
RegisterMethod('function HELPJUMP(JUMPID:NativeString):BOOLEAN');
RegisterProperty('DIALOGHANDLE', 'LONGINT', iptrw);
RegisterMethod('procedure CREATEHANDLE');
// RegisterMethod('procedure HOOKMAINWINDOW(HOOK:TWINDOWHOOK)');
// RegisterMethod('procedure UNHOOKMAINWINDOW(HOOK:TWINDOWHOOK)');
{$ENDIF}
RegisterProperty('HELPFILE', 'NativeString', iptrw);
RegisterProperty('HINTCOLOR', 'TCOLOR', iptrw);
RegisterProperty('HINTPAUSE', 'INTEGER', iptrw);
RegisterProperty('HINTSHORTPAUSE', 'INTEGER', iptrw);
RegisterProperty('HINTHIDEPAUSE', 'INTEGER', iptrw);
RegisterProperty('ICON', 'TICON', iptrw);
RegisterProperty('ONHELP', 'THELPEVENT', iptrw);
{$ENDIF}
end;
end;
procedure SIRegister_Forms_TypesAndConsts(Cl: TPSPascalCompiler);
begin
Cl.AddTypeS('TIdleEvent', 'procedure (Sender: TObject; var Done: Boolean)');
cl.AddTypeS('TScrollBarKind', '(sbHorizontal, sbVertical)');
cl.AddTypeS('TScrollBarInc', 'SmallInt');
cl.AddTypeS('TFormBorderStyle', '(bsNone, bsSingle, bsSizeable, bsDialog, bsToolWindow, bsSizeToolWin)');
cl.AddTypeS('TBorderStyle', 'TFormBorderStyle');
cl.AddTypeS('TWindowState', '(wsNormal, wsMinimized, wsMaximized)');
cl.AddTypeS('TFormStyle', '(fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop)');
cl.AddTypeS('TPosition', '(poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly, poScreenCenter, poDesktopCenter, poMainFormCenter, poOwnerFormCenter)');
cl.AddTypeS('TPrintScale', '(poNone, poProportional, poPrintToFit)');
cl.AddTypeS('TCloseAction', '(caNone, caHide, caFree, caMinimize)');
cl.AddTypeS('TCloseEvent' ,'procedure(Sender: TObject; var Action: TCloseAction)');
cl.AddTypeS('TCloseQueryEvent' ,'procedure(Sender: TObject; var CanClose: Boolean)');
cl.AddTypeS('TBorderIcon' ,'(biSystemMenu, biMinimize, biMaximize, biHelp)');
cl.AddTypeS('TBorderIcons', 'set of TBorderIcon');
cl.AddTypeS('THELPCONTEXT', 'Longint');
end;
procedure SIRegister_Forms(Cl: TPSPascalCompiler);
begin
SIRegister_Forms_TypesAndConsts(cl);
{$IFNDEF PS_MINIVCL}
SIRegisterTCONTROLSCROLLBAR(cl);
{$ENDIF}
SIRegisterTScrollingWinControl(cl);
{$IFNDEF PS_MINIVCL}
SIRegisterTSCROLLBOX(cl);
{$ENDIF}
SIRegisterTForm(Cl);
{$IFNDEF PS_MINIVCL}
SIRegisterTApplication(Cl);
{$ENDIF}
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

275
Units/PascalScript/uPSC_graphics.pas Normal file
View File

@ -0,0 +1,275 @@
{ Compiletime Graphics support }
unit uPSC_graphics;
{$I PascalScript.inc}
interface
uses
uPSCompiler, uPSUtils;
procedure SIRegister_Graphics_TypesAndConsts(Cl: TPSPascalCompiler);
procedure SIRegisterTGRAPHICSOBJECT(Cl: TPSPascalCompiler);
procedure SIRegisterTFont(Cl: TPSPascalCompiler);
procedure SIRegisterTPEN(Cl: TPSPascalCompiler);
procedure SIRegisterTBRUSH(Cl: TPSPascalCompiler);
procedure SIRegisterTCanvas(cl: TPSPascalCompiler);
procedure SIRegisterTGraphic(CL: TPSPascalCompiler);
procedure SIRegisterTBitmap(CL: TPSPascalCompiler; Streams: Boolean);
procedure SIRegister_Graphics(Cl: TPSPascalCompiler; Streams: Boolean);
implementation
{$IFNDEF PS_NOGRAPHCONST}
uses
{$IFDEF CLX}QGraphics{$ELSE}Graphics{$ENDIF};
{$ELSE}
{$IFNDEF CLX}
{$IFNDEF FPC}
uses
Windows;
{$ENDIF}
{$ENDIF}
{$ENDIF}
procedure SIRegisterTGRAPHICSOBJECT(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TGRAPHICSOBJECT') do
begin
RegisterProperty('ONCHANGE', 'TNOTIFYEVENT', iptrw);
end;
end;
procedure SIRegisterTFont(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TGraphicsObject'), 'TFONT') do
begin
RegisterMethod('constructor Create;');
{$IFNDEF CLX}
RegisterProperty('Handle', 'Integer', iptRW);
{$ENDIF}
RegisterProperty('Color', 'TColor', iptRW);
RegisterProperty('Height', 'Integer', iptRW);
RegisterProperty('Name', 'String', iptRW);
RegisterProperty('Pitch', 'Byte', iptRW);
RegisterProperty('Size', 'Integer', iptRW);
RegisterProperty('PixelsPerInch', 'Integer', iptRW);
RegisterProperty('Style', 'TFontStyles', iptrw);
end;
end;
procedure SIRegisterTCanvas(cl: TPSPascalCompiler); // requires TPersistent
begin
with Cl.AddClassN(cl.FindClass('TPersistent'), 'TCANVAS') do
begin
RegisterMethod('procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);');
RegisterMethod('procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);');
// RegisterMethod('procedure Draw(X, Y: Integer; Graphic: TGraphic);');
RegisterMethod('procedure Ellipse(X1, Y1, X2, Y2: Integer);');
RegisterMethod('procedure FillRect(const Rect: TRect);');
{$IFNDEF CLX}
RegisterMethod('procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: Byte);');
{$ENDIF}
RegisterMethod('procedure LineTo(X, Y: Integer);');
RegisterMethod('procedure MoveTo(X, Y: Integer);');
RegisterMethod('procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);');
RegisterMethod('procedure Rectangle(X1, Y1, X2, Y2: Integer);');
RegisterMethod('procedure Refresh;');
RegisterMethod('procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);');
RegisterMethod('function TextHeight(Text: String): Integer;');
RegisterMethod('procedure TextOut(X, Y: Integer; Text: String);');
RegisterMethod('function TextWidth(Text: String): Integer;');
{$IFNDEF CLX}
RegisterProperty('Handle', 'Integer', iptRw);
{$ENDIF}
RegisterProperty('Pixels', 'Integer Integer Integer', iptRW);
RegisterProperty('Brush', 'TBrush', iptR);
RegisterProperty('CopyMode', 'Byte', iptRw);
RegisterProperty('Font', 'TFont', iptR);
RegisterProperty('Pen', 'TPen', iptR);
end;
end;
procedure SIRegisterTPEN(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TGRAPHICSOBJECT'), 'TPEN') do
begin
RegisterMethod('constructor CREATE');
RegisterProperty('COLOR', 'TCOLOR', iptrw);
RegisterProperty('MODE', 'TPENMODE', iptrw);
RegisterProperty('STYLE', 'TPENSTYLE', iptrw);
RegisterProperty('WIDTH', 'INTEGER', iptrw);
end;
end;
procedure SIRegisterTBRUSH(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TGRAPHICSOBJECT'), 'TBRUSH') do
begin
RegisterMethod('constructor CREATE');
RegisterProperty('COLOR', 'TCOLOR', iptrw);
RegisterProperty('STYLE', 'TBRUSHSTYLE', iptrw);
end;
end;
procedure SIRegister_Graphics_TypesAndConsts(Cl: TPSPascalCompiler);
{$IFDEF PS_NOGRAPHCONST}
const
clSystemColor = {$IFDEF DELPHI7UP} $FF000000 {$ELSE} $80000000 {$ENDIF};
{$ENDIF}
begin
{$IFNDEF PS_NOGRAPHCONST}
cl.AddConstantN('clScrollBar', 'Integer').Value.ts32 := clScrollBar;
cl.AddConstantN('clBackground', 'Integer').Value.ts32 := clBackground;
cl.AddConstantN('clActiveCaption', 'Integer').Value.ts32 := clActiveCaption;
cl.AddConstantN('clInactiveCaption', 'Integer').Value.ts32 := clInactiveCaption;
cl.AddConstantN('clMenu', 'Integer').Value.ts32 := clMenu;
cl.AddConstantN('clWindow', 'Integer').Value.ts32 := clWindow;
cl.AddConstantN('clWindowFrame', 'Integer').Value.ts32 := clWindowFrame;
cl.AddConstantN('clMenuText', 'Integer').Value.ts32 := clMenuText;
cl.AddConstantN('clWindowText', 'Integer').Value.ts32 := clWindowText;
cl.AddConstantN('clCaptionText', 'Integer').Value.ts32 := clCaptionText;
cl.AddConstantN('clActiveBorder', 'Integer').Value.ts32 := clActiveBorder;
cl.AddConstantN('clInactiveBorder', 'Integer').Value.ts32 := clInactiveCaption;
cl.AddConstantN('clAppWorkSpace', 'Integer').Value.ts32 := clAppWorkSpace;
cl.AddConstantN('clHighlight', 'Integer').Value.ts32 := clHighlight;
cl.AddConstantN('clHighlightText', 'Integer').Value.ts32 := clHighlightText;
cl.AddConstantN('clBtnFace', 'Integer').Value.ts32 := clBtnFace;
cl.AddConstantN('clBtnShadow', 'Integer').Value.ts32 := clBtnShadow;
cl.AddConstantN('clGrayText', 'Integer').Value.ts32 := clGrayText;
cl.AddConstantN('clBtnText', 'Integer').Value.ts32 := clBtnText;
cl.AddConstantN('clInactiveCaptionText', 'Integer').Value.ts32 := clInactiveCaptionText;
cl.AddConstantN('clBtnHighlight', 'Integer').Value.ts32 := clBtnHighlight;
cl.AddConstantN('cl3DDkShadow', 'Integer').Value.ts32 := cl3DDkShadow;
cl.AddConstantN('cl3DLight', 'Integer').Value.ts32 := cl3DLight;
cl.AddConstantN('clInfoText', 'Integer').Value.ts32 := clInfoText;
cl.AddConstantN('clInfoBk', 'Integer').Value.ts32 := clInfoBk;
{$ELSE}
{$IFNDEF CLX} // These are VCL-only; CLX uses different constant values
cl.AddConstantN('clScrollBar', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_SCROLLBAR);
cl.AddConstantN('clBackground', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BACKGROUND);
cl.AddConstantN('clActiveCaption', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_ACTIVECAPTION);
cl.AddConstantN('clInactiveCaption', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INACTIVECAPTION);
cl.AddConstantN('clMenu', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_MENU);
cl.AddConstantN('clWindow', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_WINDOW);
cl.AddConstantN('clWindowFrame', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_WINDOWFRAME);
cl.AddConstantN('clMenuText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_MENUTEXT);
cl.AddConstantN('clWindowText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_WINDOWTEXT);
cl.AddConstantN('clCaptionText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_CAPTIONTEXT);
cl.AddConstantN('clActiveBorder', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_ACTIVEBORDER);
cl.AddConstantN('clInactiveBorder', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INACTIVEBORDER);
cl.AddConstantN('clAppWorkSpace', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_APPWORKSPACE);
cl.AddConstantN('clHighlight', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_HIGHLIGHT);
cl.AddConstantN('clHighlightText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_HIGHLIGHTTEXT);
cl.AddConstantN('clBtnFace', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNFACE);
cl.AddConstantN('clBtnShadow', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNSHADOW);
cl.AddConstantN('clGrayText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_GRAYTEXT);
cl.AddConstantN('clBtnText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNTEXT);
cl.AddConstantN('clInactiveCaptionText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INACTIVECAPTIONTEXT);
cl.AddConstantN('clBtnHighlight', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNHIGHLIGHT);
cl.AddConstantN('cl3DDkShadow', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_3DDKSHADOW);
cl.AddConstantN('cl3DLight', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_3DLIGHT);
cl.AddConstantN('clInfoText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INFOTEXT);
cl.AddConstantN('clInfoBk', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INFOBK);
{$ENDIF}
{$ENDIF}
cl.AddConstantN('clBlack', 'Integer').Value.ts32 := $000000;
cl.AddConstantN('clMaroon', 'Integer').Value.ts32 := $000080;
cl.AddConstantN('clGreen', 'Integer').Value.ts32 := $008000;
cl.AddConstantN('clOlive', 'Integer').Value.ts32 := $008080;
cl.AddConstantN('clNavy', 'Integer').Value.ts32 := $800000;
cl.AddConstantN('clPurple', 'Integer').Value.ts32 := $800080;
cl.AddConstantN('clTeal', 'Integer').Value.ts32 := $808000;
cl.AddConstantN('clGray', 'Integer').Value.ts32 := $808080;
cl.AddConstantN('clSilver', 'Integer').Value.ts32 := $C0C0C0;
cl.AddConstantN('clRed', 'Integer').Value.ts32 := $0000FF;
cl.AddConstantN('clLime', 'Integer').Value.ts32 := $00FF00;
cl.AddConstantN('clYellow', 'Integer').Value.ts32 := $00FFFF;
cl.AddConstantN('clBlue', 'Integer').Value.ts32 := $FF0000;
cl.AddConstantN('clFuchsia', 'Integer').Value.ts32 := $FF00FF;
cl.AddConstantN('clAqua', 'Integer').Value.ts32 := $FFFF00;
cl.AddConstantN('clLtGray', 'Integer').Value.ts32 := $C0C0C0;
cl.AddConstantN('clDkGray', 'Integer').Value.ts32 := $808080;
cl.AddConstantN('clWhite', 'Integer').Value.ts32 := $FFFFFF;
cl.AddConstantN('clNone', 'Integer').Value.ts32 := $1FFFFFFF;
cl.AddConstantN('clDefault', 'Integer').Value.ts32 := $20000000;
Cl.addTypeS('TFONTSTYLE', '(FSBOLD, FSITALIC, FSUNDERLINE, FSSTRIKEOUT)');
Cl.addTypeS('TFONTSTYLES', 'set of TFONTSTYLE');
cl.AddTypeS('TFontPitch', '(fpDefault, fpVariable, fpFixed)');
cl.AddTypeS('TPenStyle', '(psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideFrame)');
cl.AddTypeS('TPenMode', '(pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy, pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge, pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor)');
cl.AddTypeS('TBrushStyle', '(bsSolid, bsClear, bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross)');
cl.addTypeS('TColor', 'integer');
{$IFNDEF CLX}
cl.addTypeS('HBITMAP', 'Integer');
cl.addTypeS('HPALETTE', 'Integer');
{$ENDIF}
end;
procedure SIRegisterTGraphic(CL: TPSPascalCompiler);
begin
with CL.AddClassN(CL.FindClass('TPersistent'),'TGraphic') do
begin
RegisterMethod('constructor Create');
RegisterMethod('Procedure LoadFromFile( const Filename : String)');
RegisterMethod('Procedure SaveToFile( const Filename : String)');
RegisterProperty('Empty', 'Boolean', iptr);
RegisterProperty('Height', 'Integer', iptrw);
RegisterProperty('Modified', 'Boolean', iptrw);
RegisterProperty('Width', 'Integer', iptrw);
RegisterProperty('OnChange', 'TNotifyEvent', iptrw);
end;
end;
procedure SIRegisterTBitmap(CL: TPSPascalCompiler; Streams: Boolean);
begin
with CL.AddClassN(CL.FindClass('TGraphic'),'TBitmap') do
begin
if Streams then begin
RegisterMethod('Procedure LoadFromStream( Stream : TStream)');
RegisterMethod('Procedure SaveToStream( Stream : TStream)');
end;
RegisterProperty('Canvas', 'TCanvas', iptr);
{$IFNDEF CLX}
RegisterProperty('Handle', 'HBITMAP', iptrw);
{$ENDIF}
{$IFNDEF IFPS_MINIVCL}
RegisterMethod('Procedure Dormant');
RegisterMethod('Procedure FreeImage');
{$IFNDEF CLX}
RegisterMethod('Procedure LoadFromClipboardFormat( AFormat : Word; AData : THandle; APalette : HPALETTE)');
{$ENDIF}
RegisterMethod('Procedure LoadFromResourceName( Instance : THandle; const ResName : String)');
RegisterMethod('Procedure LoadFromResourceID( Instance : THandle; ResID : Integer)');
{$IFNDEF CLX}
RegisterMethod('Function ReleaseHandle : HBITMAP');
RegisterMethod('Function ReleasePalette : HPALETTE');
RegisterMethod('Procedure SaveToClipboardFormat( var Format : Word; var Data : THandle; var APalette : HPALETTE)');
RegisterProperty('Monochrome', 'Boolean', iptrw);
RegisterProperty('Palette', 'HPALETTE', iptrw);
RegisterProperty('IgnorePalette', 'Boolean', iptrw);
{$ENDIF}
RegisterProperty('TransparentColor', 'TColor', iptr);
{$ENDIF}
end;
end;
procedure SIRegister_Graphics(Cl: TPSPascalCompiler; Streams: Boolean);
begin
SIRegister_Graphics_TypesAndConsts(Cl);
SIRegisterTGRAPHICSOBJECT(Cl);
SIRegisterTFont(Cl);
SIRegisterTPEN(cl);
SIRegisterTBRUSH(cl);
SIRegisterTCanvas(cl);
SIRegisterTGraphic(Cl);
SIRegisterTBitmap(Cl, Streams);
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
End.

214
Units/PascalScript/uPSC_menus.pas Normal file
View File

@ -0,0 +1,214 @@
{ Menus Import Unit }
Unit uPSC_menus;
{$I PascalScript.inc}
Interface
Uses uPSCompiler;
procedure SIRegisterTMENUITEMSTACK(CL: TPSPascalCompiler);
procedure SIRegisterTPOPUPLIST(CL: TPSPascalCompiler);
procedure SIRegisterTPOPUPMENU(CL: TPSPascalCompiler);
procedure SIRegisterTMAINMENU(CL: TPSPascalCompiler);
procedure SIRegisterTMENU(CL: TPSPascalCompiler);
procedure SIRegisterTMENUITEM(CL: TPSPascalCompiler);
procedure SIRegister_Menus(Cl: TPSPascalCompiler);
implementation
procedure SIRegisterTMENUITEMSTACK(CL: TPSPascalCompiler);
begin
With cl.AddClassN(Cl.FindClass('TSTACK'),'TMENUITEMSTACK') do
begin
RegisterMethod('Procedure CLEARITEM( AITEM : TMENUITEM)');
end;
end;
procedure SIRegisterTPOPUPLIST(CL: TPSPascalCompiler);
begin
With cl.AddClassN(Cl.FindClass('TLIST'),'TPOPUPLIST') do
begin
RegisterProperty('WINDOW', 'HWND', iptr);
RegisterMethod('Procedure ADD( POPUP : TPOPUPMENU)');
RegisterMethod('Procedure REMOVE( POPUP : TPOPUPMENU)');
end;
end;
procedure SIRegisterTPOPUPMENU(CL: TPSPascalCompiler);
var
cc: TPSCompileTimeClass;
begin
With cl.AddClassN(Cl.FindClass('TMENU'),'TPOPUPMENU') do
begin
cc := Cl.FindClass('TLabel');
if cc <> nil then
RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptRW);
with Cl.FindClass('TForm') do
begin
RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptRW);
end;
RegisterMethod('Constructor CREATE( AOWNER : TCOMPONENT)');
RegisterMethod('Procedure POPUP( X, Y : INTEGER)');
RegisterProperty('POPUPCOMPONENT', 'TCOMPONENT', iptrw);
RegisterProperty('ALIGNMENT', 'TPOPUPALIGNMENT', iptrw);
RegisterProperty('AUTOPOPUP', 'BOOLEAN', iptrw);
RegisterProperty('HELPCONTEXT', 'THELPCONTEXT', iptrw);
RegisterProperty('MENUANIMATION', 'TMENUANIMATION', iptrw);
RegisterProperty('TRACKBUTTON', 'TTRACKBUTTON', iptrw);
RegisterProperty('ONPOPUP', 'TNOTIFYEVENT', iptrw);
end;
end;
procedure SIRegisterTMAINMENU(CL: TPSPascalCompiler);
begin
With cl.AddClassN(Cl.FindClass('TMENU'),'TMAINMENU') do
begin
RegisterMethod('Procedure MERGE( MENU : TMAINMENU)');
RegisterMethod('Procedure UNMERGE( MENU : TMAINMENU)');
RegisterMethod('Procedure POPULATEOLE2MENU( SHAREDMENU : HMENU; GROUPS : array of INTEGER; var WIDTHS : array of LONGINT)');
RegisterMethod('Procedure GETOLE2ACCELERATORTABLE( var ACCELTABLE : HACCEL; var ACCELCOUNT : INTEGER; GROUPS : array of INTEGER)');
RegisterMethod('Procedure SETOLE2MENUHANDLE( HANDLE : HMENU)');
RegisterProperty('AUTOMERGE', 'BOOLEAN', iptrw);
end;
end;
procedure SIRegisterTMENU(CL: TPSPascalCompiler);
begin
With cl.AddClassN(Cl.FindClass('TCOMPONENT'),'TMENU') do
begin
RegisterMethod('Constructor CREATE( AOWNER : TCOMPONENT)');
RegisterMethod('Function DISPATCHCOMMAND( ACOMMAND : WORD) : BOOLEAN');
RegisterMethod('Function DISPATCHPOPUP( AHANDLE : HMENU) : BOOLEAN');
RegisterMethod('Function FINDITEM( VALUE : INTEGER; KIND : TFINDITEMKIND) : TMENUITEM');
RegisterMethod('Function GETHELPCONTEXT( VALUE : INTEGER; BYCOMMAND : BOOLEAN) : THELPCONTEXT');
RegisterProperty('IMAGES', 'TCUSTOMIMAGELIST', iptrw);
RegisterMethod('Function ISRIGHTTOLEFT : BOOLEAN');
RegisterMethod('Procedure PARENTBIDIMODECHANGED( ACONTROL : TOBJECT)');
RegisterMethod('Procedure PROCESSMENUCHAR( var MESSAGE : TWMMENUCHAR)');
RegisterProperty('AUTOHOTKEYS', 'TMENUAUTOFLAG', iptrw);
RegisterProperty('AUTOLINEREDUCTION', 'TMENUAUTOFLAG', iptrw);
RegisterProperty('BIDIMODE', 'TBIDIMODE', iptrw);
RegisterProperty('HANDLE', 'HMENU', iptr);
RegisterProperty('OWNERDRAW', 'BOOLEAN', iptrw);
RegisterProperty('PARENTBIDIMODE', 'BOOLEAN', iptrw);
RegisterProperty('WINDOWHANDLE', 'HWND', iptrw);
RegisterProperty('ITEMS', 'TMENUITEM', iptr);
end;
end;
procedure SIRegisterTMENUITEM(CL: TPSPascalCompiler);
begin
With cl.AddClassN(Cl.FindClass('TCOMPONENT'),'TMENUITEM') do
begin
RegisterMethod('Constructor CREATE( AOWNER : TCOMPONENT)');
RegisterMethod('Procedure INITIATEACTION');
RegisterMethod('Procedure INSERT( INDEX : INTEGER; ITEM : TMENUITEM)');
RegisterMethod('Procedure DELETE( INDEX : INTEGER)');
RegisterMethod('Procedure CLEAR');
RegisterMethod('Procedure CLICK');
RegisterMethod('Function FIND( ACAPTION : String) : TMENUITEM');
RegisterMethod('Function INDEXOF( ITEM : TMENUITEM) : INTEGER');
RegisterMethod('Function ISLINE : BOOLEAN');
RegisterMethod('Function GETIMAGELIST : TCUSTOMIMAGELIST');
RegisterMethod('Function GETPARENTCOMPONENT : TCOMPONENT');
RegisterMethod('Function GETPARENTMENU : TMENU');
RegisterMethod('Function HASPARENT : BOOLEAN');
RegisterMethod('Function NEWTOPLINE : INTEGER');
RegisterMethod('Function NEWBOTTOMLINE : INTEGER');
RegisterMethod('Function INSERTNEWLINEBEFORE( AITEM : TMENUITEM) : INTEGER');
RegisterMethod('Function INSERTNEWLINEAFTER( AITEM : TMENUITEM) : INTEGER');
RegisterMethod('Procedure ADD( ITEM : TMENUITEM)');
RegisterMethod('Procedure REMOVE( ITEM : TMENUITEM)');
RegisterMethod('Function RETHINKHOTKEYS : BOOLEAN');
RegisterMethod('Function RETHINKLINES : BOOLEAN');
RegisterProperty('COMMAND', 'WORD', iptr);
RegisterProperty('HANDLE', 'HMENU', iptr);
RegisterProperty('COUNT', 'INTEGER', iptr);
RegisterProperty('ITEMS', 'TMENUITEM INTEGER', iptr);
RegisterProperty('MENUINDEX', 'INTEGER', iptrw);
RegisterProperty('PARENT', 'TMENUITEM', iptr);
{$IFDEF DELPHI5UP}
RegisterProperty('ACTION', 'TBASICACTION', iptrw);
{$ENDIF}
RegisterProperty('AUTOHOTKEYS', 'TMENUITEMAUTOFLAG', iptrw);
RegisterProperty('AUTOLINEREDUCTION', 'TMENUITEMAUTOFLAG', iptrw);
RegisterProperty('BITMAP', 'TBITMAP', iptrw);
RegisterProperty('CAPTION', 'String', iptrw);
RegisterProperty('CHECKED', 'BOOLEAN', iptrw);
RegisterProperty('SUBMENUIMAGES', 'TCUSTOMIMAGELIST', iptrw);
RegisterProperty('DEFAULT', 'BOOLEAN', iptrw);
RegisterProperty('ENABLED', 'BOOLEAN', iptrw);
RegisterProperty('GROUPINDEX', 'BYTE', iptrw);
RegisterProperty('HELPCONTEXT', 'THELPCONTEXT', iptrw);
RegisterProperty('HINT', 'String', iptrw);
RegisterProperty('IMAGEINDEX', 'TIMAGEINDEX', iptrw);
RegisterProperty('RADIOITEM', 'BOOLEAN', iptrw);
RegisterProperty('SHORTCUT', 'TSHORTCUT', iptrw);
RegisterProperty('VISIBLE', 'BOOLEAN', iptrw);
RegisterProperty('ONCLICK', 'TNOTIFYEVENT', iptrw);
{$IFNDEF FPC} RegisterProperty('ONDRAWITEM', 'TMENUDRAWITEMEVENT', iptrw);
RegisterProperty('ONADVANCEDDRAWITEM', 'TADVANCEDMENUDRAWITEMEVENT', iptrw);
RegisterProperty('ONMEASUREITEM', 'TMENUMEASUREITEMEVENT', iptrw);{$ENDIF}
end;
end;
procedure SIRegister_Menus(Cl: TPSPascalCompiler);
begin
Cl.AddTypeS('HMenu', 'Cardinal');
Cl.AddTypeS('HACCEL', 'Cardinal');
cl.addClassN(cl.FindClass('EXCEPTION'),'EMENUERROR');
Cl.addTypeS('TMENUBREAK', '( MBNONE, MBBREAK, MBBARBREAK )');
{$IFNDEF FPC}
Cl.addTypeS('TMENUDRAWITEMEVENT', 'Procedure ( SENDER : TOBJECT; ACANVAS : TC'
+'ANVAS; ARECT : TRECT; SELECTED : BOOLEAN)');
Cl.addTypeS('TADVANCEDMENUDRAWITEMEVENT', 'Procedure ( SENDER : TOBJECT; ACAN'
+'VAS : TCANVAS; ARECT : TRECT; STATE : TOWNERDRAWSTATE)');
Cl.addTypeS('TMENUMEASUREITEMEVENT', 'Procedure ( SENDER : TOBJECT; ACANVAS :'
+' TCANVAS; var WIDTH, HEIGHT : INTEGER)');
{$ENDIF}
Cl.addTypeS('TMENUITEMAUTOFLAG', '( MAAUTOMATIC, MAMANUAL, MAPARENT )');
Cl.AddTypeS('TMenuAutoFlag', 'TMENUITEMAUTOFLAG');
Cl.addTypeS('TSHORTCUT', 'WORD');
cl.addClassN(cl.FindClass('TACTIONLINK'),'TMENUACTIONLINK');
SIRegisterTMENUITEM(Cl);
Cl.addTypeS('TMENUCHANGEEVENT', 'Procedure ( SENDER : TOBJECT; SOURCE : TMENU'
+'ITEM; REBUILD : BOOLEAN)');
Cl.addTypeS('TFINDITEMKIND', '( FKCOMMAND, FKHANDLE, FKSHORTCUT )');
SIRegisterTMENU(Cl);
SIRegisterTMAINMENU(Cl);
Cl.addTypeS('TPOPUPALIGNMENT', '( PALEFT, PARIGHT, PACENTER )');
Cl.addTypeS('TTRACKBUTTON', '( TBRIGHTBUTTON, TBLEFTBUTTON )');
Cl.addTypeS('TMENUANIMATIONS', '( MALEFTTORIGHT, MARIGHTTOLEFT, MATOPTOBOTTOM'
+', MABOTTOMTOTOP, MANONE )');
Cl.addTypeS('TMENUANIMATION', 'set of TMENUANIMATIONS');
SIRegisterTPOPUPMENU(Cl);
SIRegisterTPOPUPLIST(Cl);
SIRegisterTMENUITEMSTACK(Cl);
Cl.addTypeS('TCMENUITEM', 'TMENUITEM');
{$IFNDEF FPC}
//TODO: it should work,but somehow TShiftState is not defined
Cl.AddDelphiFunction('Function SHORTCUT( KEY : WORD; SHIFT : TSHIFTSTATE) : T'
+'SHORTCUT');
Cl.AddDelphiFunction('Procedure SHORTCUTTOKEY( SHORTCUT : TSHORTCUT; var KEY '
+': WORD; var SHIFT : TSHIFTSTATE)');
{$ENDIF}
Cl.AddDelphiFunction('Function SHORTCUTTOTEXT( SHORTCUT : TSHORTCUT) : String'
+'');
Cl.AddDelphiFunction('Function TEXTTOSHORTCUT( TEXT : String) : TSHORTCUT');
Cl.AddDelphiFunction('Function NEWMENU( OWNER : TCOMPONENT; const ANAME : STR'
+'ING; ITEMS : array of TMenuItem) : TMAINMENU');
Cl.AddDelphiFunction('Function NEWPOPUPMENU( OWNER : TCOMPONENT; const ANAME '
+': String; ALIGNMENT : TPOPUPALIGNMENT; AUTOPOPUP : BOOLEAN; const ITEMS : array of '
+'TCMENUITEM) : TPOPUPMENU');
Cl.AddDelphiFunction('Function NEWSUBMENU( const ACAPTION : String; HCTX : WO'
+'RD; const ANAME : String; ITEMS : array of TMenuItem; AENABLED : BOOLEAN) : TMENUITEM');
Cl.AddDelphiFunction('Function NEWITEM( const ACAPTION : String; ASHORTCUT : '
+'TSHORTCUT; ACHECKED, AENABLED : BOOLEAN; AONCLICK : TNOTIFYEVENT; HCTX : W'
+'ORD; const ANAME : String) : TMENUITEM');
Cl.AddDelphiFunction('Function NEWLINE : TMENUITEM');
{$IFNDEF FPC}
Cl.AddDelphiFunction('Procedure DRAWMENUITEM( MENUITEM : TMENUITEM; ACANVAS :'
+' TCANVAS; ARECT : TRECT; STATE : TOWNERDRAWSTATE)');
{$ENDIF}
end;
end.

87
Units/PascalScript/uPSC_std.pas Normal file
View File

@ -0,0 +1,87 @@
{ Compiletime TObject, TPersistent and TComponent definitions }
unit uPSC_std;
{$I PascalScript.inc}
interface
uses
uPSCompiler, uPSUtils;
{
Will register files from:
System
Classes (Only TComponent and TPersistent)
}
procedure SIRegister_Std_TypesAndConsts(Cl: TPSPascalCompiler);
procedure SIRegisterTObject(CL: TPSPascalCompiler);
procedure SIRegisterTPersistent(Cl: TPSPascalCompiler);
procedure SIRegisterTComponent(Cl: TPSPascalCompiler);
procedure SIRegister_Std(Cl: TPSPascalCompiler);
implementation
procedure SIRegisterTObject(CL: TPSPascalCompiler);
begin
with Cl.AddClassN(nil, 'TObject') do
begin
RegisterMethod('constructor Create');
RegisterMethod('procedure Free');
end;
end;
procedure SIRegisterTPersistent(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TObject'), 'TPersistent') do
begin
RegisterMethod('procedure Assign(Source: TPersistent)');
end;
end;
procedure SIRegisterTComponent(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TPersistent'), 'TComponent') do
begin
RegisterMethod('function FindComponent(AName: String): TComponent;');
RegisterMethod('constructor Create(AOwner: TComponent); virtual;');
RegisterProperty('Owner', 'TComponent', iptRW);
RegisterMethod('procedure DestroyComponents');
RegisterMethod('procedure Destroying');
RegisterMethod('procedure FreeNotification(AComponent:TComponent)');
RegisterMethod('procedure InsertComponent(AComponent:TComponent)');
RegisterMethod('procedure RemoveComponent(AComponent:TComponent)');
RegisterProperty('Components', 'TComponent Integer', iptr);
RegisterProperty('ComponentCount', 'Integer', iptr);
RegisterProperty('ComponentIndex', 'Integer', iptrw);
RegisterProperty('ComponentState', 'Byte', iptr);
RegisterProperty('Designinfo', 'LongInt', iptrw);
RegisterProperty('Name', 'String', iptrw);
RegisterProperty('Tag', 'LongInt', iptrw);
end;
end;
procedure SIRegister_Std_TypesAndConsts(Cl: TPSPascalCompiler);
begin
Cl.AddTypeS('TComponentStateE', '(csLoading, csReading, csWriting, csDestroying, csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification, csInline, csDesignInstance)');
cl.AddTypeS('TComponentState', 'set of TComponentStateE');
Cl.AddTypeS('TRect', 'record Left, Top, Right, Bottom: Integer; end;');
end;
procedure SIRegister_Std(Cl: TPSPascalCompiler);
begin
SIRegister_Std_TypesAndConsts(Cl);
SIRegisterTObject(CL);
SIRegisterTPersistent(Cl);
SIRegisterTComponent(Cl);
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
End.


633
Units/PascalScript/uPSC_stdctrls.pas Normal file
View File

@ -0,0 +1,633 @@
{ Compiletime STDCtrls support }
unit uPSC_stdctrls;
{$I PascalScript.inc}
interface
uses
uPSCompiler, uPSUtils;
{
Will register files from:
stdctrls
Requires:
STD, classes, controls and graphics
}
procedure SIRegister_StdCtrls_TypesAndConsts(cl: TPSPascalCompiler);
procedure SIRegisterTCUSTOMGROUPBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTGROUPBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTCUSTOMLABEL(Cl: TPSPascalCompiler);
procedure SIRegisterTLABEL(Cl: TPSPascalCompiler);
procedure SIRegisterTCUSTOMEDIT(Cl: TPSPascalCompiler);
procedure SIRegisterTEDIT(Cl: TPSPascalCompiler);
procedure SIRegisterTCUSTOMMEMO(Cl: TPSPascalCompiler);
procedure SIRegisterTMEMO(Cl: TPSPascalCompiler);
procedure SIRegisterTCUSTOMCOMBOBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTCOMBOBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTBUTTONCONTROL(Cl: TPSPascalCompiler);
procedure SIRegisterTBUTTON(Cl: TPSPascalCompiler);
procedure SIRegisterTCUSTOMCHECKBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTCHECKBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTRADIOBUTTON(Cl: TPSPascalCompiler);
procedure SIRegisterTCUSTOMLISTBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTLISTBOX(Cl: TPSPascalCompiler);
procedure SIRegisterTSCROLLBAR(Cl: TPSPascalCompiler);
procedure SIRegister_StdCtrls(cl: TPSPascalCompiler);
implementation
procedure SIRegisterTCUSTOMGROUPBOX(Cl: TPSPascalCompiler);
begin
Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TCUSTOMGROUPBOX');
end;
procedure SIRegisterTGROUPBOX(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMGROUPBOX'), 'TGROUPBOX') do
begin
RegisterProperty('CAPTION', 'String', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTCUSTOMLABEL(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TCUSTOMLABEL') do
begin
{$IFNDEF PS_MINIVCL}
{$IFNDEF CLX}
RegisterProperty('CANVAS', 'TCANVAS', iptr);
{$ENDIF}
{$ENDIF}
end;
end;
procedure SIRegisterTLABEL(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMLABEL'), 'TLABEL') do
begin
RegisterProperty('ALIGNMENT', 'TAlignment', iptrw);
RegisterProperty('AUTOSIZE', 'Boolean', iptrw);
RegisterProperty('CAPTION', 'String', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('FOCUSCONTROL', 'TWinControl', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('LAYOUT', 'TTextLayout', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('SHOWACCELCHAR', 'Boolean', iptrw);
RegisterProperty('TRANSPARENT', 'Boolean', iptrw);
RegisterProperty('WORDWRAP', 'Boolean', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
end;
end;
procedure SIRegisterTCUSTOMEDIT(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TCUSTOMEDIT') do
begin
RegisterMethod('procedure CLEAR');
RegisterMethod('procedure CLEARSELECTION');
RegisterMethod('procedure SELECTALL');
RegisterProperty('MODIFIED', 'BOOLEAN', iptrw);
RegisterProperty('SELLENGTH', 'INTEGER', iptrw);
RegisterProperty('SELSTART', 'INTEGER', iptrw);
RegisterProperty('SELTEXT', 'String', iptrw);
RegisterProperty('TEXT', 'String', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterMethod('procedure COPYTOCLIPBOARD');
RegisterMethod('procedure CUTTOCLIPBOARD');
RegisterMethod('procedure PASTEFROMCLIPBOARD');
RegisterMethod('function GETSELTEXTBUF(BUFFER:PCHAR;BUFSIZE:INTEGER):INTEGER');
RegisterMethod('procedure SETSELTEXTBUF(BUFFER:PCHAR)');
{$ENDIF}
end;
end;
procedure SIRegisterTEDIT(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMEDIT'), 'TEDIT') do
begin
RegisterProperty('AUTOSELECT', 'Boolean', iptrw);
RegisterProperty('AUTOSIZE', 'Boolean', iptrw);
RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw);
RegisterProperty('CHARCASE', 'TEditCharCase', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('HIDESELECTION', 'Boolean', iptrw);
RegisterProperty('MAXLENGTH', 'Integer', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('PASSWORDCHAR', 'Char', iptrw);
RegisterProperty('READONLY', 'Boolean', iptrw);
RegisterProperty('TEXT', 'String', iptrw);
RegisterProperty('ONCHANGE', 'TNotifyEvent', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('OEMCONVERT', 'Boolean', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTCUSTOMMEMO(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMEDIT'), 'TCUSTOMMEMO') do
begin
{$IFNDEF CLX}
RegisterProperty('LINES', 'TSTRINGS', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTMEMO(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMMEMO'), 'TMEMO') do
begin
{$IFDEF CLX}
RegisterProperty('LINES', 'TSTRINGS', iptrw);
{$ENDIF}
RegisterProperty('ALIGNMENT', 'TAlignment', iptrw);
RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('HIDESELECTION', 'Boolean', iptrw);
RegisterProperty('MAXLENGTH', 'Integer', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('READONLY', 'Boolean', iptrw);
RegisterProperty('SCROLLBARS', 'TScrollStyle', iptrw);
RegisterProperty('WANTRETURNS', 'Boolean', iptrw);
RegisterProperty('WANTTABS', 'Boolean', iptrw);
RegisterProperty('WORDWRAP', 'Boolean', iptrw);
RegisterProperty('ONCHANGE', 'TNotifyEvent', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('OEMCONVERT', 'Boolean', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTCUSTOMCOMBOBOX(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TCUSTOMCOMBOBOX') do
begin
RegisterProperty('DROPPEDDOWN', 'BOOLEAN', iptrw);
RegisterProperty('ITEMS', 'TSTRINGS', iptrw);
RegisterProperty('ITEMINDEX', 'INTEGER', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterMethod('procedure CLEAR');
RegisterMethod('procedure SELECTALL');
RegisterProperty('CANVAS', 'TCANVAS', iptr);
RegisterProperty('SELLENGTH', 'INTEGER', iptrw);
RegisterProperty('SELSTART', 'INTEGER', iptrw);
RegisterProperty('SELTEXT', 'String', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTCOMBOBOX(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMCOMBOBOX'), 'TCOMBOBOX') do
begin
RegisterProperty('STYLE', 'TComboBoxStyle', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('DROPDOWNCOUNT', 'Integer', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('MAXLENGTH', 'Integer', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('SORTED', 'Boolean', iptrw);
RegisterProperty('TEXT', 'String', iptrw);
RegisterProperty('ONCHANGE', 'TNotifyEvent', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDROPDOWN', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('ITEMHEIGHT', 'Integer', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONDRAWITEM', 'TDrawItemEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMEASUREITEM', 'TMeasureItemEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTBUTTONCONTROL(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TBUTTONCONTROL') do
begin
end;
end;
procedure SIRegisterTBUTTON(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TBUTTONCONTROL'), 'TBUTTON') do
begin
RegisterProperty('CANCEL', 'BOOLEAN', iptrw);
RegisterProperty('CAPTION', 'String', iptrw);
RegisterProperty('DEFAULT', 'BOOLEAN', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('MODALRESULT', 'LONGINT', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTCUSTOMCHECKBOX(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TBUTTONCONTROL'), 'TCUSTOMCHECKBOX') do
begin
end;
end;
procedure SIRegisterTCHECKBOX(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMCHECKBOX'), 'TCHECKBOX') do
begin
RegisterProperty('ALIGNMENT', 'TAlignment', iptrw);
RegisterProperty('ALLOWGRAYED', 'Boolean', iptrw);
RegisterProperty('CAPTION', 'String', iptrw);
RegisterProperty('CHECKED', 'Boolean', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('STATE', 'TCheckBoxState', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTRADIOBUTTON(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TBUTTONCONTROL'), 'TRADIOBUTTON') do
begin
RegisterProperty('ALIGNMENT', 'TALIGNMENT', iptrw);
RegisterProperty('CAPTION', 'String', iptrw);
RegisterProperty('CHECKED', 'BOOLEAN', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTCUSTOMLISTBOX(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TCUSTOMLISTBOX') do
begin
RegisterProperty('ITEMS', 'TSTRINGS', iptrw);
RegisterProperty('ITEMINDEX', 'INTEGER', iptrw);
RegisterProperty('SELCOUNT', 'INTEGER', iptr);
RegisterProperty('SELECTED', 'BOOLEAN INTEGER', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterMethod('procedure CLEAR');
RegisterMethod('function ITEMATPOS(POS:TPOINT;EXISTING:BOOLEAN):INTEGER');
RegisterMethod('function ITEMRECT(INDEX:INTEGER):TRECT');
RegisterProperty('CANVAS', 'TCANVAS', iptr);
RegisterProperty('TOPINDEX', 'INTEGER', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTLISTBOX(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TCUSTOMLISTBOX'), 'TLISTBOX') do
begin
RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw);
RegisterProperty('COLOR', 'TColor', iptrw);
RegisterProperty('FONT', 'TFont', iptrw);
RegisterProperty('MULTISELECT', 'Boolean', iptrw);
RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
RegisterProperty('PARENTFONT', 'Boolean', iptrw);
RegisterProperty('SORTED', 'Boolean', iptrw);
RegisterProperty('STYLE', 'TListBoxStyle', iptrw);
RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterProperty('COLUMNS', 'Integer', iptrw);
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('EXTENDEDSELECT', 'Boolean', iptrw);
RegisterProperty('INTEGRALHEIGHT', 'Boolean', iptrw);
RegisterProperty('ITEMHEIGHT', 'Integer', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('TABWIDTH', 'Integer', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONDRAWITEM', 'TDrawItemEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONMEASUREITEM', 'TMeasureItemEvent', iptrw);
RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegisterTSCROLLBAR(Cl: TPSPascalCompiler);
begin
with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TSCROLLBAR') do
begin
RegisterProperty('KIND', 'TSCROLLBARKIND', iptrw);
RegisterProperty('MAX', 'INTEGER', iptrw);
RegisterProperty('MIN', 'INTEGER', iptrw);
RegisterProperty('POSITION', 'INTEGER', iptrw);
RegisterProperty('ONCHANGE', 'TNOTIFYEVENT', iptrw);
RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
{$IFNDEF PS_MINIVCL}
RegisterMethod('procedure SETPARAMS(APOSITION,AMIN,AMAX:INTEGER)');
RegisterProperty('CTL3D', 'Boolean', iptrw);
RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
RegisterProperty('LARGECHANGE', 'TSCROLLBARINC', iptrw);
RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
RegisterProperty('SMALLCHANGE', 'TSCROLLBARINC', iptrw);
RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
RegisterProperty('ONSCROLL', 'TSCROLLEVENT', iptrw);
RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
{$ENDIF}
end;
end;
procedure SIRegister_StdCtrls_TypesAndConsts(cl: TPSPascalCompiler);
begin
cl.AddTypeS('TEditCharCase', '(ecNormal, ecUpperCase, ecLowerCase)');
cl.AddTypeS('TScrollStyle', '(ssNone, ssHorizontal, ssVertical, ssBoth)');
cl.AddTypeS('TComboBoxStyle', '(csDropDown, csSimple, csDropDownList, csOwnerDrawFixed, csOwnerDrawVariable)');
cl.AddTypeS('TDrawItemEvent', 'procedure(Control: TWinControl; Index: Integer; Rect: TRect; State: Byte)');
cl.AddTypeS('TMeasureItemEvent', 'procedure(Control: TWinControl; Index: Integer; var Height: Integer)');
cl.AddTypeS('TCheckBoxState', '(cbUnchecked, cbChecked, cbGrayed)');
cl.AddTypeS('TListBoxStyle', '(lbStandard, lbOwnerDrawFixed, lbOwnerDrawVariable)');
cl.AddTypeS('TScrollCode', '(scLineUp, scLineDown, scPageUp, scPageDown, scPosition, scTrack, scTop, scBottom, scEndScroll)');
cl.AddTypeS('TScrollEvent', 'procedure(Sender: TObject; ScrollCode: TScrollCode;var ScrollPos: Integer)');
Cl.addTypeS('TEOwnerDrawState', '(odSelected, odGrayed, odDisabled, odChecked,'
+' odFocused, odDefault, odHotLight, odInactive, odNoAccel, odNoFocusRect,'
+' odReserved1, odReserved2, odComboBoxEdit)');
cl.AddTypeS('TTextLayout', '( tlTop, tlCenter, tlBottom )');
cl.AddTypeS('TOwnerDrawState', 'set of TEOwnerDrawState');
end;
procedure SIRegister_stdctrls(cl: TPSPascalCompiler);
begin
SIRegister_StdCtrls_TypesAndConsts(cl);
{$IFNDEF PS_MINIVCL}
SIRegisterTCUSTOMGROUPBOX(Cl);
SIRegisterTGROUPBOX(Cl);
{$ENDIF}
SIRegisterTCUSTOMLABEL(Cl);
SIRegisterTLABEL(Cl);
SIRegisterTCUSTOMEDIT(Cl);
SIRegisterTEDIT(Cl);
SIRegisterTCUSTOMMEMO(Cl);
SIRegisterTMEMO(Cl);
SIRegisterTCUSTOMCOMBOBOX(Cl);
SIRegisterTCOMBOBOX(Cl);
SIRegisterTBUTTONCONTROL(Cl);
SIRegisterTBUTTON(Cl);
SIRegisterTCUSTOMCHECKBOX(Cl);
SIRegisterTCHECKBOX(Cl);
SIRegisterTRADIOBUTTON(Cl);
SIRegisterTCUSTOMLISTBOX(Cl);
SIRegisterTLISTBOX(Cl);
{$IFNDEF PS_MINIVCL}
SIRegisterTSCROLLBAR(Cl);
{$ENDIF}
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

15397
Units/PascalScript/uPSCompiler.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1511
Units/PascalScript/uPSComponent.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1010
Units/PascalScript/uPSComponentExt.pas Normal file
View File

File diff suppressed because it is too large Load Diff

38
Units/PascalScript/uPSComponent_COM.pas Normal file
View File

@ -0,0 +1,38 @@
unit uPSComponent_COM;
interface
uses
SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
type
TPSImport_ComObj = class(TPSPlugin)
private
public
procedure CompileImport1(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
end;
TIFPS3CE_ComObj = class(TPSImport_ComObj);
implementation
uses
uPSC_comobj,
uPSR_comobj;
{ TPSImport_ComObj }
procedure TPSImport_ComObj.CompileImport1(CompExec: TPSScript);
begin
SIRegister_ComObj(CompExec.Comp);
end;
procedure TPSImport_ComObj.ExecImport1(CompExec: TPSScript;
const ri: TPSRuntimeClassImporter);
begin
RIRegister_ComObj(CompExec.Exec);
end;
end.

65
Units/PascalScript/uPSComponent_Controls.pas Normal file
View File

@ -0,0 +1,65 @@
unit uPSComponent_Controls;
interface
uses
SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
type
TPSImport_Controls = class(TPSPlugin)
private
FEnableStreams: Boolean;
FEnableGraphics: Boolean;
FEnableControls: Boolean;
public
procedure CompileImport1(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
public
constructor Create(AOwner: TComponent); override;
published
property EnableStreams: Boolean read FEnableStreams write FEnableStreams;
property EnableGraphics: Boolean read FEnableGraphics write FEnableGraphics;
property EnableControls: Boolean read FEnableControls write FEnableControls;
end;
TIFPS3CE_Controls = class(TPSImport_Controls);
implementation
uses
uPSC_graphics,
uPSC_controls,
uPSR_graphics,
uPSR_controls;
{ TPSImport_Controls }
procedure TPSImport_Controls.CompileImport1(CompExec: TPSScript);
begin
if FEnableGraphics then
SIRegister_Graphics(CompExec.Comp, FEnableStreams);
if FEnableControls then
SIRegister_Controls(CompExec.Comp);
end;
constructor TPSImport_Controls.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FEnableStreams := True;
FEnableGraphics := True;
FEnableControls := True;
end;
procedure TPSImport_Controls.ExecImport1(CompExec: TPSScript;
const ri: TPSRuntimeClassImporter);
begin
if FEnableGraphics then
RIRegister_Graphics(ri, FEnableStreams);
if FEnableControls then
RIRegister_Controls(ri);
end;
end.

36
Units/PascalScript/uPSComponent_DB.pas Normal file
View File

@ -0,0 +1,36 @@
unit uPSComponent_DB;
interface
{$I PascalScript.inc}
uses
SysUtils, Classes, uPSComponent, uPSRuntime, uPSCompiler;
type
TPSImport_DB = class(TPSPlugin)
public
procedure CompileImport1(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
public
end;
TIFPS3CE_DB = class(TPSImport_DB);
implementation
uses
uPSC_DB,
uPSR_DB;
{ TPSImport_DB }
procedure TPSImport_DB.CompileImport1(CompExec: TPSScript);
begin
SIRegister_DB(CompExec.Comp);
end;
procedure TPSImport_DB.ExecImport1(CompExec: TPSScript;
const ri: TPSRuntimeClassImporter);
begin
RIRegister_DB(RI);
end;
end.

81
Units/PascalScript/uPSComponent_Default.pas Normal file
View File

@ -0,0 +1,81 @@
unit uPSComponent_Default;
{$I PascalScript.inc}
interface
uses
SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
type
TPSImport_DateUtils = class(TPSPlugin)
public
procedure CompOnUses(CompExec: TPSScript); override;
procedure ExecOnUses(CompExec: TPSScript); override;
end;
TPSImport_Classes = class(TPSPlugin)
private
FEnableStreams: Boolean;
FEnableClasses: Boolean;
public
procedure CompileImport1(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
public
constructor Create(AOwner: TComponent); override;
published
property EnableStreams: Boolean read FEnableStreams write FEnableStreams;
property EnableClasses: Boolean read FEnableClasses write FEnableClasses;
end;
TIFPS3CE_Std = class(TPSImport_Classes);
TIFPS3CE_DateUtils = class(TPSImport_DateUtils);
implementation
uses
uPSC_std,
uPSR_std,
uPSC_classes,
uPSR_classes,
uPSC_dateutils,
uPSR_dateutils;
{ TPSImport_Classes }
procedure TPSImport_Classes.CompileImport1(CompExec: TPSScript);
begin
SIRegister_Std(CompExec.Comp);
if FEnableClasses then
SIRegister_Classes(CompExec.Comp, FEnableStreams);
end;
procedure TPSImport_Classes.ExecImport1(CompExec: TPSScript;
const ri: TPSRuntimeClassImporter);
begin
RIRegister_Std(Ri);
if FEnableClasses then
RIRegister_Classes(ri, FEnableStreams);
end;
constructor TPSImport_Classes.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FEnableStreams := True;
FEnableClasses := True;
end;
{ TPSImport_DateUtils }
procedure TPSImport_DateUtils.CompOnUses(CompExec: TPSScript);
begin
RegisterDateTimeLibrary_C(CompExec.Comp);
end;
procedure TPSImport_DateUtils.ExecOnUses(CompExec: TPSScript);
begin
RegisterDateTimeLibrary_R(CompExec.Exec);
end;
end.

65
Units/PascalScript/uPSComponent_Forms.pas Normal file
View File

@ -0,0 +1,65 @@
unit uPSComponent_Forms;
interface
uses
SysUtils, Classes, uPSRuntime, uPSCompiler, uPSComponent;
type
TPSImport_Forms = class(TPSPlugin)
private
FEnableForms: Boolean;
FEnableMenus: Boolean;
public
procedure CompileImport1(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
public
constructor Create(AOwner: TComponent); override;
published
property EnableForms: Boolean read FEnableForms write FEnableForms;
property EnableMenus: Boolean read FEnableMenus write FEnableMenus;
end;
TIFPS3CE_Forms = class(TPSImport_Forms);
implementation
uses
uPSC_forms,
uPSC_menus,
uPSR_forms,
uPSR_menus;
{ TPSImport_Forms }
procedure TPSImport_Forms.CompileImport1(CompExec: TPSScript);
begin
if FEnableForms then
SIRegister_Forms(CompExec.comp);
if FEnableMenus then
SIRegister_Menus(CompExec.comp);
end;
constructor TPSImport_Forms.Create(AOwner: TComponent);
begin
inherited Create(Aowner);
FEnableForms := True;
FEnableMenus := True;
end;
procedure TPSImport_Forms.ExecImport1(CompExec: TPSScript;
const ri: TPSRuntimeClassImporter);
begin
if FEnableForms then
RIRegister_Forms(ri);
if FEnableMenus then
begin
RIRegister_Menus(ri);
RIRegister_Menus_Routines(compexec.Exec);
end;
end;
end.

65
Units/PascalScript/uPSComponent_StdCtrls.pas Normal file
View File

@ -0,0 +1,65 @@
unit uPSComponent_StdCtrls;
interface
uses
SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
type
TPSImport_StdCtrls = class(TPSPlugin)
private
FEnableButtons: Boolean;
FEnableExtCtrls: Boolean;
public
procedure CompileImport1(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
public
constructor Create(AOwner: TComponent); override;
published
property EnableExtCtrls: Boolean read FEnableExtCtrls write FEnableExtCtrls;
property EnableButtons: Boolean read FEnableButtons write FEnableButtons;
end;
TIFPS3CE_StdCtrls = class(TPSImport_StdCtrls);
implementation
uses
uPSC_buttons,
uPSC_stdctrls,
uPSC_extctrls,
uPSR_buttons,
uPSR_stdctrls,
uPSR_extctrls;
{ TPSImport_StdCtrls }
procedure TPSImport_StdCtrls.CompileImport1(CompExec: TPSScript);
begin
SIRegister_stdctrls(CompExec.Comp);
if FEnableExtCtrls then
SIRegister_ExtCtrls(CompExec.Comp);
if FEnableButtons then
SIRegister_Buttons(CompExec.Comp);
end;
constructor TPSImport_StdCtrls.Create(AOwner: TComponent);
begin
inherited Create(Aowner);
FEnableButtons := True;
FEnableExtCtrls := True;
end;
procedure TPSImport_StdCtrls.ExecImport1(CompExec: TPSScript;
const ri: TPSRuntimeClassImporter);
begin
RIRegister_stdctrls(RI);
if FEnableExtCtrls then
RIRegister_ExtCtrls(RI);
if FEnableButtons then
RIRegister_Buttons(RI);
end;
end.

654
Units/PascalScript/uPSDebugger.pas Normal file
View File

@ -0,0 +1,654 @@
unit uPSDebugger;
{$I PascalScript.inc}
interface
uses
SysUtils, uPSRuntime, uPSUtils;
type
TDebugMode = (dmRun
, dmStepOver
, dmStepInto
, dmPaused
);
TPSCustomDebugExec = class(TPSExec)
protected
FDebugDataForProcs: TIfList;
FLastProc: TPSProcRec;
FCurrentDebugProc: Pointer;
FProcNames: TIFStringList;
FGlobalVarNames: TIfStringList;
FCurrentSourcePos, FCurrentRow, FCurrentCol: Cardinal;
FCurrentFile: tbtstring;
function GetCurrentProcParams: TIfStringList;
function GetCurrentProcVars: TIfStringList;
protected
procedure ClearDebug; virtual;
public
function GetCurrentProcNo: Cardinal;
function GetCurrentPosition: Cardinal;
function TranslatePosition(Proc, Position: Cardinal): Cardinal;
function TranslatePositionEx(Proc, Position: Cardinal; var Pos, Row, Col: Cardinal; var Fn: tbtstring): Boolean;
procedure LoadDebugData(const Data: tbtstring);
procedure Clear; override;
property GlobalVarNames: TIfStringList read FGlobalVarNames;
property ProcNames: TIfStringList read FProcNames;
property CurrentProcVars: TIfStringList read GetCurrentProcVars;
property CurrentProcParams: TIfStringList read GetCurrentProcParams;
function GetGlobalVar(I: Cardinal): PIfVariant;
function GetProcVar(I: Cardinal): PIfVariant;
function GetProcParam(I: Cardinal): PIfVariant;
constructor Create;
destructor Destroy; override;
end;
TPSDebugExec = class;
TOnSourceLine = procedure (Sender: TPSDebugExec; const Name: tbtstring; Position, Row, Col: Cardinal);
TOnIdleCall = procedure (Sender: TPSDebugExec);
TPSDebugExec = class(TPSCustomDebugExec)
private
FDebugMode: TDebugMode;
FStepOverProc: TPSInternalProcRec;
FStepOverStackBase: Cardinal;
FOnIdleCall: TOnIdleCall;
FOnSourceLine: TOnSourceLine;
FDebugEnabled: Boolean;
protected
procedure SourceChanged;
procedure ClearDebug; override;
procedure RunLine; override;
public
constructor Create;
function LoadData(const s: tbtstring): Boolean; override;
procedure Pause; override;
procedure Run;
procedure StepInto;
procedure StepOver;
procedure Stop; override;
property DebugMode: TDebugMode read FDebugMode;
property OnSourceLine: TOnSourceLine read FOnSourceLine write FOnSourceLine;
property OnIdleCall: TOnIdleCall read FOnIdleCall write FOnIdleCall;
property DebugEnabled: Boolean read FDebugEnabled write FDebugEnabled;
end;
TIFPSDebugExec = TPSDebugExec;
implementation
{$IFDEF DELPHI3UP }
resourceString
{$ELSE }
const
{$ENDIF }
RPS_ExpectedReturnAddressStackBase = 'Expected return address at stack base';
type
PPositionData = ^TPositionData;
TPositionData = packed record
FileName: tbtstring;
Position,
Row,
Col,
SourcePosition: Cardinal;
end;
PFunctionInfo = ^TFunctionInfo;
TFunctionInfo = packed record
Func: TPSProcRec;
FParamNames: TIfStringList;
FVariableNames: TIfStringList;
FPositionTable: TIfList;
end;
{ TPSCustomDebugExec }
procedure TPSCustomDebugExec.Clear;
begin
inherited Clear;
if FGlobalVarNames <> nil then ClearDebug;
end;
procedure TPSCustomDebugExec.ClearDebug;
var
i, j: Longint;
p: PFunctionInfo;
begin
FCurrentDebugProc := nil;
FLastProc := nil;
FProcNames.Clear;
FGlobalVarNames.Clear;
FCurrentSourcePos := 0;
FCurrentRow := 0;
FCurrentCol := 0;
FCurrentFile := '';
for i := 0 to FDebugDataForProcs.Count -1 do
begin
p := FDebugDataForProcs[I];
for j := 0 to p^.FPositionTable.Count -1 do
begin
Dispose(PPositionData(P^.FPositionTable[J]));
end;
p^.FPositionTable.Free;
p^.FParamNames.Free;
p^.FVariableNames.Free;
Dispose(p);
end;
FDebugDataForProcs.Clear;
end;
constructor TPSCustomDebugExec.Create;
begin
inherited Create;
FCurrentSourcePos := 0;
FCurrentRow := 0;
FCurrentCol := 0;
FCurrentFile := '';
FDebugDataForProcs := TIfList.Create;
FLastProc := nil;
FCurrentDebugProc := nil;
FProcNames := TIFStringList.Create;
FGlobalVarNames := TIfStringList.Create;
end;
destructor TPSCustomDebugExec.Destroy;
begin
Clear;
FDebugDataForProcs.Free;
FProcNames.Free;
FGlobalVarNames.Free;
FGlobalVarNames := nil;
inherited Destroy;
end;
function TPSCustomDebugExec.GetCurrentPosition: Cardinal;
begin
Result := TranslatePosition(GetCurrentProcNo, 0);
end;
function TPSCustomDebugExec.GetCurrentProcNo: Cardinal;
var
i: Longint;
begin
for i := 0 to FProcs.Count -1 do
begin
if FProcs[i]= FCurrProc then
begin
Result := I;
Exit;
end;
end;
Result := Cardinal(-1);
end;
function TPSCustomDebugExec.GetCurrentProcParams: TIfStringList;
begin
if FCurrentDebugProc <> nil then
begin
Result := PFunctionInfo(FCurrentDebugProc)^.FParamNames;
end else Result := nil;
end;
function TPSCustomDebugExec.GetCurrentProcVars: TIfStringList;
begin
if FCurrentDebugProc <> nil then
begin
Result := PFunctionInfo(FCurrentDebugProc)^.FVariableNames;
end else Result := nil;
end;
function TPSCustomDebugExec.GetGlobalVar(I: Cardinal): PIfVariant;
begin
Result := FGlobalVars[I];
end;
function TPSCustomDebugExec.GetProcParam(I: Cardinal): PIfVariant;
begin
Result := FStack[Cardinal(Longint(FCurrStackBase) - Longint(I) - 1)];
end;
function TPSCustomDebugExec.GetProcVar(I: Cardinal): PIfVariant;
begin
Result := FStack[Cardinal(Longint(FCurrStackBase) + Longint(I) + 1)];
end;
function GetProcDebugInfo(FProcs: TIFList; Proc: TPSProcRec): PFunctionInfo;
var
i: Longint;
c: PFunctionInfo;
begin
if Proc = nil then
begin
Result := nil;
exit;
end;
for i := FProcs.Count -1 downto 0 do
begin
c := FProcs.Data^[I];
if c^.Func = Proc then
begin
Result := c;
exit;
end;
end;
new(c);
c^.Func := Proc;
c^.FPositionTable := TIfList.Create;
c^.FVariableNames := TIfStringList.Create;
c^.FParamNames := TIfStringList.Create;
FProcs.Add(c);
REsult := c;
end;
procedure TPSCustomDebugExec.LoadDebugData(const Data: tbtstring);
var
CP, I: Longint;
c: tbtchar;
CurrProcNo, LastProcNo: Cardinal;
LastProc: PFunctionInfo;
NewLoc: PPositionData;
s: tbtstring;
begin
ClearDebug;
if FStatus = isNotLoaded then exit;
CP := 1;
LastProcNo := Cardinal(-1);
LastProc := nil;
while CP <= length(Data) do
begin
c := Data[CP];
inc(cp);
case c of
#0:
begin
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
FProcNames.Add(Copy(Data, cp, i-cp));
cp := I + 1;
end;
inc(I);
if I > length(data) then exit;
end;
cp := i + 1;
end;
#1:
begin
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
FGlobalVarNames.Add(Copy(Data, cp, i-cp));
cp := I + 1;
end;
inc(I);
if I > length(data) then exit;
end;
cp := i + 1;
end;
#2:
begin
if cp + 4 > Length(data) then exit;
CurrProcNo := Cardinal((@Data[cp])^);
if CurrProcNo = Cardinal(-1) then Exit;
if CurrProcNo <> LastProcNo then
begin
LastProcNo := CurrProcNo;
LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]);
if LastProc = nil then exit;
end;
inc(cp, 4);
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
LastProc^.FParamNames.Add(Copy(Data, cp, i-cp));
cp := I + 1;
end;
inc(I);
if I > length(data) then exit;
end;
cp := i + 1;
end;
#3:
begin
if cp + 4 > Length(data) then exit;
CurrProcNo := Cardinal((@Data[cp])^);
if CurrProcNo = Cardinal(-1) then Exit;
if CurrProcNo <> LastProcNo then
begin
LastProcNo := CurrProcNo;
LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]);
if LastProc = nil then exit;
end;
inc(cp, 4);
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
LastProc^.FVariableNames.Add(Copy(Data, cp, i-cp));
cp := I + 1;
end;
inc(I);
if I > length(data) then exit;
end;
cp := i + 1;
end;
#4:
begin
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
s := Copy(Data, cp, i-cp);
cp := I + 1;
Break;
end;
inc(I);
if I > length(data) then exit;
end;
if cp + 4 > Length(data) then exit;
CurrProcNo := Cardinal((@Data[cp])^);
if CurrProcNo = Cardinal(-1) then Exit;
if CurrProcNo <> LastProcNo then
begin
LastProcNo := CurrProcNo;
LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]);
if LastProc = nil then exit;
end;
inc(cp, 4);
if cp + 16 > Length(data) then exit;
new(NewLoc);
NewLoc^.Position := Cardinal((@Data[Cp])^);
NewLoc^.FileName := s;
NewLoc^.SourcePosition := Cardinal((@Data[Cp+4])^);
NewLoc^.Row := Cardinal((@Data[Cp+8])^);
NewLoc^.Col := Cardinal((@Data[Cp+12])^);
inc(cp, 16);
LastProc^.FPositionTable.Add(NewLoc);
end;
else
begin
ClearDebug;
Exit;
end;
end;
end;
end;
function TPSCustomDebugExec.TranslatePosition(Proc, Position: Cardinal): Cardinal;
var
D1, D2: Cardinal;
s: tbtstring;
begin
if not TranslatePositionEx(Proc, Position, Result, D1, D2, s) then
Result := 0;
end;
function TPSCustomDebugExec.TranslatePositionEx(Proc, Position: Cardinal;
var Pos, Row, Col: Cardinal; var Fn: tbtstring): Boolean;
// Made by Martijn Laan (mlaan@wintax.nl)
var
i: LongInt;
fi: PFunctionInfo;
pt: TIfList;
r: PPositionData;
lastfn: tbtstring;
LastPos, LastRow, LastCol: Cardinal;
pp: TPSProcRec;
begin
fi := nil;
pp := FProcs[Proc];
for i := 0 to FDebugDataForProcs.Count -1 do
begin
fi := FDebugDataForProcs[i];
if fi^.Func = pp then
Break;
fi := nil;
end;
LastPos := 0;
LastRow := 0;
LastCol := 0;
if fi <> nil then begin
pt := fi^.FPositionTable;
for i := 0 to pt.Count -1 do
begin
r := pt[I];
if r^.Position >= Position then
begin
if r^.Position = Position then
begin
Pos := r^.SourcePosition;
Row := r^.Row;
Col := r^.Col;
Fn := r^.Filename;
end
else
begin
Pos := LastPos;
Row := LastRow;
Col := LastCol;
Fn := LastFn;
end;
Result := True;
exit;
end else
begin
LastPos := r^.SourcePosition;
LastRow := r^.Row;
LastCol := r^.Col;
LastFn := r^.FileName;
end;
end;
Pos := LastPos;
Row := LastRow;
Col := LastCol;
Result := True;
end else
begin
Result := False;
end;
end;
{ TPSDebugExec }
procedure TPSDebugExec.ClearDebug;
begin
inherited;
FDebugMode := dmRun;
end;
function TPSDebugExec.LoadData(const s: tbtstring): Boolean;
begin
Result := inherited LoadData(s);
FDebugMode := dmRun;
end;
procedure TPSDebugExec.RunLine;
var
i: Longint;
pt: TIfList;
r: PPositionData;
begin
inherited RunLine;
if not DebugEnabled then exit;
if FCurrProc <> FLastProc then
begin
FLastProc := FCurrProc;
FCurrentDebugProc := nil;
for i := 0 to FDebugDataForProcs.Count -1 do
begin
if PFunctionInfo(FDebugDataForProcs[I])^.Func = FLastProc then
begin
FCurrentDebugProc := FDebugDataForProcs[I];
break;
end;
end;
end;
if FCurrentDebugProc <> nil then
begin
pt := PFunctionInfo(FCurrentDebugProc)^.FPositionTable;
for i := 0 to pt.Count -1 do
begin
r := pt[I];
if r^.Position = FCurrentPosition then
begin
FCurrentSourcePos := r^.SourcePosition;
FCurrentRow := r^.Row;
FCurrentCol := r^.Col;
FCurrentFile := r^.FileName;
SourceChanged;
break;
end;
end;
end else
begin
FCurrentSourcePos := 0;
FCurrentRow := 0;
FCurrentCol := 0;
FCurrentFile := '';
end;
while FDebugMode = dmPaused do
begin
if @FOnIdleCall <> nil then
begin
FOnIdleCall(Self);
end else break; // endless loop
end;
end;
procedure TPSDebugExec.SourceChanged;
function StepOverShouldPause: Boolean;
var
I: Cardinal;
V: PPSVariant;
begin
if (FCurrProc <> FStepOverProc) or (FCurrStackBase <> FStepOverStackBase) then
begin
{ We're not inside the function being stepped, so scan the call stack to
see if we're inside a function called by the function being stepped }
I := FCurrStackBase;
while Longint(I) > Longint(FStepOverStackBase) do
begin
V := FStack.Items[I];
if (V = nil) or (V.FType <> FReturnAddressType) then
raise Exception.Create(RPS_ExpectedReturnAddressStackBase);
if (PPSVariantReturnAddress(V).Addr.ProcNo = FStepOverProc) and
(PPSVariantReturnAddress(V).Addr.StackBase = FStepOverStackBase) then
begin
{ We are, so don't pause }
Result := False;
Exit;
end;
I := PPSVariantReturnAddress(V).Addr.StackBase;
end;
end;
Result := True;
end;
begin
case FDebugMode of
dmStepInto:
begin
FDebugMode := dmPaused;
end;
dmStepOver:
begin
if StepOverShouldPause then
begin
FDebugMode := dmPaused;
end;
end;
end;
if @FOnSourceLine <> nil then
FOnSourceLine(Self, FCurrentFile, FCurrentSourcePos, FCurrentRow, FCurrentCol);
end;
procedure TPSDebugExec.Pause;
begin
FDebugMode := dmPaused;
end;
procedure TPSDebugExec.Stop;
begin
FDebugMode := dmRun;
inherited Stop;
end;
procedure TPSDebugExec.Run;
begin
FDebugMode := dmRun;
end;
procedure TPSDebugExec.StepInto;
begin
FDebugMode := dmStepInto;
end;
procedure TPSDebugExec.StepOver;
begin
FStepOverProc := FCurrProc;
FStepOverStackBase := FCurrStackBase;
FDebugMode := dmStepOver;
end;
constructor TPSDebugExec.Create;
begin
inherited Create;
FDebugEnabled := True;
end;
end.

499
Units/PascalScript/uPSDisassembly.pas Normal file
View File

@ -0,0 +1,499 @@
unit uPSDisassembly;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils, sysutils;
function IFPS3DataToText(const Input: tbtstring; var Output: string): Boolean;
implementation
type
TMyPSExec = class(TPSExec)
function ImportProc(const Name: ShortString; proc: TIFExternalProcRec): Boolean; override;
end;
function Debug2Str(const s: string): string;
var
i: Integer;
begin
result := '';
for i := 1 to length(s) do
begin
if (s[i] < #32) or (s[i] > #128) then
result := result + '\'+inttohex(ord(s[i]), 2)
else if s[i] = '\' then
result := result + '\\'
else
result := result + s[i];
end;
end;
function SpecImportProc(Sender: TObject; p: TIFExternalProcRec): Boolean; forward;
function FloatToStr(Value: Extended): string;
begin
try
Result := SysUtils.FloatToStr(Value);
except
Result := 'NaNa';
end;
end;
function IFPS3DataToText(const Input: tbtstring; var Output: string): Boolean;
var
I: TMyPSExec;
procedure Writeln(const s: string);
begin
Output := Output + s + #13#10;
end;
function BT2S(P: PIFTypeRec): string;
var
i: Longint;
begin
case p.BaseType of
btU8: Result := 'U8';
btS8: Result := 'S8';
btU16: Result := 'U16';
btS16: Result := 'S16';
btU32: Result := 'U32';
btS32: Result := 'S32';
{$IFNDEF PS_NOINT64}bts64: Result := 'S64'; {$ENDIF}
btChar: Result := {$IFDEF UNICODE}'AnsiChar'{$ELSE}'Char'{$ENDIF};
{$IFNDEF PS_NOWIDESTRING}
btWideChar: Result := 'WideChar';
btWideString: Result := 'WideString';
{$ENDIF}
btSet: Result := 'Set';
btSingle: Result := 'Single';
btDouble: Result := 'Double';
btExtended: Result := 'Extended';
btString: Result := 'String';
btRecord:
begin
Result := 'Record(';
for i := 0 to TPSTypeRec_Record(p).FieldTypes.Count-1 do
begin
if i <> 0 then Result := Result+',';
Result := Result + BT2S(PIFTypeRec(TPSTypeRec_Record(p).FieldTypes[i]));
end;
Result := Result + ')';
end;
btArray: Result := 'Array of '+BT2S(TPSTypeRec_Array(p).ArrayType);
btResourcePointer: Result := 'ResourcePointer';
btPointer: Result := 'Pointer';
btVariant: Result := 'Variant';
btClass: Result := 'Class';
btProcPtr: Result := 'ProcPtr';
btStaticArray: Result := 'StaticArray['+inttostR(TPSTypeRec_StaticArray(p).Size)+'] of '+BT2S(TPSTypeRec_Array(p).ArrayType);
else
Result := 'Unknown '+inttostr(p.BaseType);
end;
end;
procedure WriteTypes;
var
T: Longint;
begin
Writeln('[TYPES]');
for T := 0 to i.FTypes.Count -1 do
begin
if PIFTypeRec(i.FTypes[t]).ExportName <> '' then
Writeln('Type ['+inttostr(t)+']: '+bt2s(PIFTypeRec(i.FTypes[t]))+' Export: '+PIFTypeRec(i.FTypes[t]).ExportName)
else
Writeln('Type ['+inttostr(t)+']: '+bt2s(PIFTypeRec(i.FTypes[t])));
end;
end;
procedure WriteVars;
var
T: Longint;
function FindType(p: Pointer): Cardinal;
var
T: Longint;
begin
Result := Cardinal(-1);
for T := 0 to i.FTypes.Count -1 do
begin
if p = i.FTypes[t] then begin
result := t;
exit;
end;
end;
end;
begin
Writeln('[VARS]');
for t := 0 to i.FGlobalVars.count -1 do
begin
Writeln('Var ['+inttostr(t)+']: '+ IntToStr(FindType(PIFVariant(i.FGlobalVars[t])^.FType)) + ' '+ bt2s(PIFVariant(i.FGlobalVars[t])^.Ftype) + ' '+ PIFVariant(i.FGlobalVars[t])^.Ftype.ExportName);
end;
end;
procedure WriteProcs;
var
t: Longint;
procedure WriteProc(proc: TPSProcRec);
var
sc, CP: Cardinal;
function ReadData(var Data; Len: Cardinal): Boolean;
begin
if CP + Len <= TPSInternalProcRec(PROC).Length then begin
Move(TPSInternalProcRec(Proc).Data[CP], Data, Len);
CP := CP + Len;
Result := True;
end else Result := False;
end;
function ReadByte(var B: Byte): Boolean;
begin
if CP < TPSInternalProcRec(Proc).Length then begin
b := TPSInternalProcRec(Proc).Data^[cp];
Inc(CP);
Result := True;
end else Result := False;
end;
function ReadLong(var B: Cardinal): Boolean;
begin
if CP + 3 < TPSInternalProcRec(Proc).Length then begin
b := Cardinal((@TPSInternalProcRec(Proc).Data[CP])^);
Inc(CP, 4);
Result := True;
end else Result := False;
end;
function ReadWriteVariable: string;
var
VarType: byte;
L1, L2: Cardinal;
function ReadVar(FType: Cardinal): string;
var
F: PIFTypeRec;
b: byte;
w: word;
l: Cardinal;
{$IFNDEF PS_NOINT64}ff: Int64;{$ENDIF}
e: extended;
ss: single;
d: double;
s: ansistring;
c: char;
{$IFNDEF PS_NOWIDESTRING}
wc: WideChar;
ws: WideString;
{$ENDIF}
begin
result := '';
F:= i.FTypes[Ftype];
if f = nil then exit;
case f.BaseType of
btProcPtr: begin if not ReadData(l, 4) then exit; Result := 'PROC: '+inttostr(l); end;
btU8: begin if not ReadData(b, 1) then exit; Result := IntToStr(tbtu8(B)); end;
btS8: begin if not ReadData(b, 1) then exit; Result := IntToStr(tbts8(B)); end;
btU16: begin if not ReadData(w, 2) then exit; Result := IntToStr(tbtu16(w)); end;
btS16: begin if not ReadData(w, 2) then exit; Result := IntToStr(tbts16(w)); end;
btU32: begin if not ReadData(l, 4) then exit; Result := IntToStr(tbtu32(l)); end;
btS32: begin if not ReadData(l, 4) then exit; Result := IntToStr(tbts32(l)); end;
{$IFNDEF PS_NOINT64}bts64: begin if not ReadData(ff, 8) then exit; Result := IntToStr(ff); end;{$ENDIF}
btSingle: begin if not ReadData(ss, Sizeof(tbtsingle)) then exit; Result := FloatToStr(ss); end;
btDouble: begin if not ReadData(d, Sizeof(tbtdouble)) then exit; Result := FloatToStr(d); end;
btExtended: begin if not ReadData(e, Sizeof(tbtextended)) then exit; Result := FloatToStr(e); end;
btPChar, btString: begin if not ReadData(l, 4) then exit; SetLength(s, l); if not readData(s[1], l) then exit; Result := MakeString(s); end;
btSet:
begin
SetLength(s, TPSTypeRec_Set(f).aByteSize);
if not ReadData(s[1], length(s)) then exit;
result := MakeString(s);
end;
btChar: begin if not ReadData(c, 1) then exit; Result := '#'+IntToStr(ord(c)); end;
{$IFNDEF PS_NOWIDESTRING}
btWideChar: begin if not ReadData(wc, 2) then exit; Result := '#'+IntToStr(ord(wc)); end;
btWideString: begin if not ReadData(l, 4) then exit; SetLength(ws, l); if not readData(ws[1], l*2) then exit; Result := MakeWString(ws); end;
{$ENDIF}
end;
end;
function AddressToStr(a: Cardinal): String;
begin
if a < PSAddrNegativeStackStart then
Result := 'GlobalVar['+inttostr(a)+']'
else
Result := 'Base['+inttostr(Longint(A-PSAddrStackStart))+']';
end;
begin
Result := '';
if not ReadByte(VarType) then Exit;
case VarType of
0:
begin
if not ReadLong(L1) then Exit;
Result := AddressToStr(L1);
end;
1:
begin
if not ReadLong(L1) then Exit;
Result := '['+ReadVar(l1)+']';
end;
2:
begin
if not ReadLong(L1) then Exit;
if not ReadLong(L2) then Exit;
Result := AddressToStr(L1)+'.['+inttostr(l2)+']';
end;
3:
begin
if not ReadLong(l1) then Exit;
if not ReadLong(l2) then Exit;
Result := AddressToStr(L1)+'.'+AddressToStr(l2);
end;
end;
end;
var
b: Byte;
s: string;
DP, D1, D2, d3, d4: Cardinal;
begin
CP := 0;
sc := 0;
while true do
begin
DP := cp;
if not ReadByte(b) then Exit;
case b of
CM_A:
begin
{$IFDEF FPC}
Output := Output + ' ['+inttostr(dp)+'] ASSIGN '+ ReadWriteVariable;
Output := Output + ', ' + ReadWriteVariable + #13#10;
{$ELSE}
Writeln(' ['+inttostr(dp)+'] ASSIGN '+ReadWriteVariable+ ', ' + ReadWriteVariable);
{$ENDIF}
end;
CM_CA:
begin
if not ReadByte(b) then exit;
case b of
0: s:= '+';
1: s := '-';
2: s := '*';
3: s:= '/';
4: s:= 'MOD';
5: s:= 'SHL';
6: s:= 'SHR';
7: s:= 'AND';
8: s:= 'OR';
9: s:= 'XOR';
else
exit;
end;
Writeln(' ['+inttostr(dp)+'] CALC '+ReadWriteVariable+ ' '+s+' ' + ReadWriteVariable);
end;
CM_P:
begin
Inc(sc);
Writeln(' ['+inttostr(dp)+'] PUSH '+ReadWriteVariable + ' // '+inttostr(sc));
end;
CM_PV:
begin
Inc(sc);
Writeln(' ['+inttostr(dp)+'] PUSHVAR '+ReadWriteVariable + ' // '+inttostr(sc));
end;
CM_PO:
begin
Dec(Sc);
Writeln(' ['+inttostr(dp)+'] POP // '+inttostr(sc));
end;
Cm_C:
begin
if not ReadLong(D1) then exit;
Writeln(' ['+inttostr(dp)+'] CALL '+inttostr(d1));
end;
Cm_PG:
begin
if not ReadLong(D1) then exit;
Writeln(' ['+inttostr(dp)+'] POP/GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
end;
Cm_P2G:
begin
if not ReadLong(D1) then exit;
Writeln(' ['+inttostr(dp)+'] POP2/GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
end;
Cm_G:
begin
if not ReadLong(D1) then exit;
Writeln(' ['+inttostr(dp)+'] GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
end;
Cm_CG:
begin
if not ReadLong(D1) then exit;
Writeln(' ['+inttostr(dp)+'] COND_GOTO currpos + '+IntToStr(d1)+' '+ReadWriteVariable+' ['+IntToStr(CP+d1)+']');
end;
Cm_CNG:
begin
if not ReadLong(D1) then exit;
Writeln(' ['+inttostr(dp)+'] COND_NOT_GOTO currpos + '+IntToStr(d1)+' '+ReadWriteVariable+' ['+IntToStr(CP+d1)+']');
end;
Cm_R: Writeln(' ['+inttostr(dp)+'] RET');
Cm_ST:
begin
if not ReadLong(d1) or not readLong(d2) then exit;
Writeln(' ['+inttostr(dp)+'] SETSTACKTYPE Base['+inttostr(d1)+'] '+inttostr(d2));
end;
Cm_Pt:
begin
Inc(sc);
if not ReadLong(D1) then exit;
Writeln(' ['+inttostr(dp)+'] PUSHTYPE '+inttostr(d1) + '('+BT2S(TPSTypeRec(I.FTypes[d1]))+') // '+inttostr(sc));
end;
CM_CO:
begin
if not readByte(b) then exit;
case b of
0: s := '>=';
1: s := '<=';
2: s := '>';
3: s := '<';
4: s := '<>';
5: s := '=';
else exit;
end;
Writeln(' ['+inttostr(dp)+'] COMPARE into '+ReadWriteVariable+': '+ReadWriteVariable+' '+s+' '+ReadWriteVariable);
end;
Cm_cv:
begin
Writeln(' ['+inttostr(dp)+'] CALLVAR '+ReadWriteVariable);
end;
Cm_inc:
begin
Writeln(' ['+inttostr(dp)+'] INC '+ReadWriteVariable);
end;
Cm_dec:
begin
Writeln(' ['+inttostr(dp)+'] DEC '+ReadWriteVariable);
end;
cm_sp:
begin
Writeln(' ['+inttostr(dp)+'] SETPOINTER '+ReadWriteVariable+': '+ReadWriteVariable);
end;
cm_spc:
begin
Writeln(' ['+inttostr(dp)+'] SETCOPYPOINTER '+ReadWriteVariable+': '+ReadWriteVariable);
end;
cm_in:
begin
Writeln(' ['+inttostr(dp)+'] INOT '+ReadWriteVariable);
end;
cm_bn:
begin
Writeln(' ['+inttostr(dp)+'] BNOT '+ReadWriteVariable);
end;
cm_vm:
begin
Writeln(' ['+inttostr(dp)+'] MINUS '+ReadWriteVariable);
end;
cm_sf:
begin
s := ReadWriteVariable;
if not ReadByte(b) then exit;
if b = 0 then
Writeln(' ['+inttostr(dp)+'] SETFLAG '+s)
else
Writeln(' ['+inttostr(dp)+'] SETFLAG NOT '+s);
end;
cm_fg:
begin
if not ReadLong(D1) then exit;
Writeln(' ['+inttostr(dp)+'] FLAGGOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
end;
cm_puexh:
begin
if not ReadLong(D1) then exit;
if not ReadLong(D2) then exit;
if not ReadLong(D3) then exit;
if not ReadLong(D4) then exit;
Writeln(' ['+inttostr(dp)+'] PUSHEXCEPTION '+inttostr(d1)+' '+inttostr(d2)+' '+inttostr(d3)+' '+inttostr(d4));
end;
cm_poexh:
begin
if not ReadByte(b) then exit;
Writeln(' ['+inttostr(dp)+'] POPEXCEPTION '+inttostr(b));
end;
else
begin
Writeln(' Disasm Error');
Break;
end;
end;
end;
end;
begin
Writeln('[PROCS]');
for t := 0 to i.FProcs.Count -1 do
begin
if TPSProcRec(i.FProcs[t]).ClassType = TIFExternalProcRec then
begin
if TPSExternalProcRec(i.FProcs[t]). Decl = '' then
Writeln('Proc ['+inttostr(t)+']: External: '+TPSExternalProcRec(i.FProcs[t]).Name)
else
Writeln('Proc ['+inttostr(t)+']: External Decl: '+Debug2Str(TIFExternalProcRec(i.FProcs[t]).Decl) + ' ' + TIFExternalProcRec(i.FProcs[t]).Name);
end else begin
if TPSInternalProcRec(i.FProcs[t]).ExportName <> '' then
begin
Writeln('Proc ['+inttostr(t)+'] Export: '+TPSInternalProcRec(i.FProcs[t]).ExportName+' '+TPSInternalProcRec(i.FProcs[t]).ExportDecl);
end else
Writeln('Proc ['+inttostr(t)+']');
Writeproc(i.FProcs[t]);
end;
end;
end;
begin
Result := False;
try
I := TMyPSExec.Create;
I.AddSpecialProcImport('', @SpecImportProc, nil);
if not I.LoadData(Input) then begin
I.Free;
Exit;
end;
Output := '';
WriteTypes;
WriteVars;
WriteProcs;
I.Free;
except
exit;
end;
result := true;
end;
{ TMyIFPSExec }
function MyDummyProc(Caller: TPSExec; p: TIFExternalProcRec; Global, Stack: TPSStack): Boolean;
begin
Result := False;
end;
function TMyPSExec.ImportProc(const Name: ShortString;
proc: TIFExternalProcRec): Boolean;
begin
Proc.ProcPtr := MyDummyProc;
result := true;
end;
function SpecImportProc(Sender: TObject; p: TIFExternalProcRec): Boolean;
begin
p.ProcPtr := MyDummyProc;
Result := True;
end;
end.

741
Units/PascalScript/uPSI_Dialogs.pas Normal file
View File

@ -0,0 +1,741 @@
unit uPSI_Dialogs;
{
This file has been generated by UnitParser v0.5, written by M. Knight
and updated by NP. v/d Spek.
Source Code from Carlo Kok has been used to implement various sections of
UnitParser. Components of ifps3 are used in the construction of UnitParser,
code implementing the class wrapper is taken from Carlo Kok''s conv unility
}
interface
uses
SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
type
(*----------------------------------------------------------------------------*)
TPSImport_Dialogs = class(TPSPlugin)
protected
procedure CompOnUses(CompExec: TPSScript); override;
procedure ExecOnUses(CompExec: TPSScript); override;
procedure CompileImport1(CompExec: TPSScript); override;
procedure CompileImport2(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
end;
implementation
uses
Windows ,Messages ,CommDlg ,Graphics ,Controls ,Forms ,StdCtrls ,Dialogs;
(* === compile-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure SIRegister_TReplaceDialog(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TFindDialog', 'TReplaceDialog') do
with CL.AddClassN(CL.FindClass('TFindDialog'),'TReplaceDialog') do
begin
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TFindDialog(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCommonDialog', 'TFindDialog') do
with CL.AddClassN(CL.FindClass('TCommonDialog'),'TFindDialog') do
begin
RegisterMethod('Procedure CloseDialog');
RegisterProperty('Left', 'Integer', iptrw);
RegisterProperty('Position', 'TPoint', iptrw);
RegisterProperty('Top', 'Integer', iptrw);
RegisterProperty('FindText', 'string', iptrw);
RegisterProperty('Options', 'TFindOptions', iptrw);
RegisterProperty('OnFind', 'TNotifyEvent', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TPrintDialog(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCommonDialog', 'TPrintDialog') do
with CL.AddClassN(CL.FindClass('TCommonDialog'),'TPrintDialog') do
begin
RegisterProperty('Collate', 'Boolean', iptrw);
RegisterProperty('Copies', 'Integer', iptrw);
RegisterProperty('FromPage', 'Integer', iptrw);
RegisterProperty('MinPage', 'Integer', iptrw);
RegisterProperty('MaxPage', 'Integer', iptrw);
RegisterProperty('Options', 'TPrintDialogOptions', iptrw);
RegisterProperty('PrintToFile', 'Boolean', iptrw);
RegisterProperty('PrintRange', 'TPrintRange', iptrw);
RegisterProperty('ToPage', 'Integer', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TPrinterSetupDialog(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCommonDialog', 'TPrinterSetupDialog') do
with CL.AddClassN(CL.FindClass('TCommonDialog'),'TPrinterSetupDialog') do
begin
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TFontDialog(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCommonDialog', 'TFontDialog') do
with CL.AddClassN(CL.FindClass('TCommonDialog'),'TFontDialog') do
begin
RegisterProperty('Font', 'TFont', iptrw);
RegisterProperty('Device', 'TFontDialogDevice', iptrw);
RegisterProperty('MinFontSize', 'Integer', iptrw);
RegisterProperty('MaxFontSize', 'Integer', iptrw);
RegisterProperty('Options', 'TFontDialogOptions', iptrw);
RegisterProperty('OnApply', 'TFDApplyEvent', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TColorDialog(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCommonDialog', 'TColorDialog') do
with CL.AddClassN(CL.FindClass('TCommonDialog'),'TColorDialog') do
begin
RegisterProperty('Color', 'TColor', iptrw);
RegisterProperty('CustomColors', 'TStrings', iptrw);
RegisterProperty('Options', 'TColorDialogOptions', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TSaveDialog(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TOpenDialog', 'TSaveDialog') do
with CL.AddClassN(CL.FindClass('TOpenDialog'),'TSaveDialog') do
begin
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TOpenDialog(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCommonDialog', 'TOpenDialog') do
with CL.AddClassN(CL.FindClass('TCommonDialog'),'TOpenDialog') do
begin
RegisterProperty('FileEditStyle', 'TFileEditStyle', iptrw);
RegisterProperty('Files', 'TStrings', iptr);
RegisterProperty('HistoryList', 'TStrings', iptrw);
RegisterProperty('DefaultExt', 'string', iptrw);
RegisterProperty('FileName', 'TFileName', iptrw);
RegisterProperty('Filter', 'string', iptrw);
RegisterProperty('FilterIndex', 'Integer', iptrw);
RegisterProperty('InitialDir', 'string', iptrw);
RegisterProperty('Options', 'TOpenOptions', iptrw);
RegisterProperty('Title', 'string', iptrw);
RegisterProperty('OnCanClose', 'TCloseQueryEvent', iptrw);
RegisterProperty('OnFolderChange', 'TNotifyEvent', iptrw);
RegisterProperty('OnSelectionChange', 'TNotifyEvent', iptrw);
RegisterProperty('OnTypeChange', 'TNotifyEvent', iptrw);
RegisterProperty('OnIncludeItem', 'TIncludeItemEvent', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TCommonDialog(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TComponent', 'TCommonDialog') do
with CL.AddClassN(CL.FindClass('TComponent'),'TCommonDialog') do
begin
RegisterProperty('Handle', 'HWnd', iptr);
RegisterProperty('Ctl3D', 'Boolean', iptrw);
RegisterProperty('HelpContext', 'THelpContext', iptrw);
RegisterProperty('OnClose', 'TNotifyEvent', iptrw);
RegisterProperty('OnShow', 'TNotifyEvent', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_Dialogs(CL: TPSPascalCompiler);
begin
CL.AddConstantN('MaxCustomColors','LongInt').SetInt( 16);
SIRegister_TCommonDialog(CL);
CL.AddTypeS('TOpenOption', '( ofReadOnly, ofOverwritePrompt, ofHideReadOnly, '
+'ofNoChangeDir, ofShowHelp, ofNoValidate, ofAllowMultiSelect, ofExtensionDi'
+'fferent, ofPathMustExist, ofFileMustExist, ofCreatePrompt, ofShareAware, o'
+'fNoReadOnlyReturn, ofNoTestFileCreate, ofNoNetworkButton, ofNoLongNames, o'
+'fOldStyleDialog, ofNoDereferenceLinks, ofEnableIncludeNotify, ofEnableSizi'
+'ng )');
CL.AddTypeS('TOpenOptions', 'set of TOpenOption');
CL.AddTypeS('TFileEditStyle', '( fsEdit, fsComboBox )');
CL.AddTypeS('TIncludeItemEvent', 'Procedure ( const OFN : TOFNotifyEx; var In'
+'clude : Boolean)');
SIRegister_TOpenDialog(CL);
SIRegister_TSaveDialog(CL);
CL.AddTypeS('TColorDialogOption', '( cdFullOpen, cdPreventFullOpen, cdShowHel'
+'p, cdSolidColor, cdAnyColor )');
CL.AddTypeS('TColorDialogOptions', 'set of TColorDialogOption');
SIRegister_TColorDialog(CL);
CL.AddTypeS('TFontDialogOption', '( fdAnsiOnly, fdTrueTypeOnly, fdEffects, fd'
+'FixedPitchOnly, fdForceFontExist, fdNoFaceSel, fdNoOEMFonts, fdNoSimulatio'
+'ns, fdNoSizeSel, fdNoStyleSel, fdNoVectorFonts, fdShowHelp, fdWysiwyg, fdL'
+'imitSize, fdScalableOnly, fdApplyButton )');
CL.AddTypeS('TFontDialogOptions', 'set of TFontDialogOption');
CL.AddTypeS('TFontDialogDevice', '( fdScreen, fdPrinter, fdBoth )');
CL.AddTypeS('TFDApplyEvent', 'Procedure ( Sender : TObject; Wnd : HWND)');
SIRegister_TFontDialog(CL);
SIRegister_TPrinterSetupDialog(CL);
CL.AddTypeS('TPrintRange', '( prAllPages, prSelection, prPageNums )');
CL.AddTypeS('TPrintDialogOption', '( poPrintToFile, poPageNums, poSelection, '
+'poWarning, poHelp, poDisablePrintToFile )');
CL.AddTypeS('TPrintDialogOptions', 'set of TPrintDialogOption');
SIRegister_TPrintDialog(CL);
CL.AddTypeS('TFindOption', '( frDown, frFindNext, frHideMatchCase, frHideWhol'
+'eWord, frHideUpDown, frMatchCase, frDisableMatchCase, frDisableUpDown, frD'
+'isableWholeWord, frReplace, frReplaceAll, frWholeWord, frShowHelp )');
CL.AddTypeS('TFindOptions', 'set of TFindOption');
SIRegister_TFindDialog(CL);
SIRegister_TReplaceDialog(CL);
CL.AddTypeS('TMsgDlgType', '( mtWarning, mtError, mtInformation, mtConfirmati'
+'on, mtCustom )');
CL.AddTypeS('TMsgDlgBtn', '( mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, m'
+'bIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp )');
CL.AddTypeS('TMsgDlgButtons', 'set of TMsgDlgBtn');
CL.AddConstantN('mbYesNoCancel','LongInt').Value.ts32 := ord(mbYes) or ord(mbNo) or ord(mbCancel);
CL.AddConstantN('mbOKCancel','LongInt').Value.ts32 := ord(mbOK) or ord(mbCancel);
CL.AddConstantN('mbAbortRetryIgnore','LongInt').Value.ts32 := ord(mbAbort) or ord(mbRetry) or ord(mbIgnore);
CL.AddDelphiFunction('Function CreateMessageDialog( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons) : TForm');
CL.AddDelphiFunction('Function MessageDlg( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; HelpCtx : Longint) : Integer');
CL.AddDelphiFunction('Function MessageDlgPos( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; HelpCtx : Longint; X, Y : Integer) : Integer');
CL.AddDelphiFunction('Function MessageDlgPosHelp( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; HelpCtx : Longint; X, Y : Integer; const HelpFileName : string) : Integer');
CL.AddDelphiFunction('Procedure ShowMessage( const Msg : string)');
CL.AddDelphiFunction('Procedure ShowMessagePos( const Msg : string; X, Y : Integer)');
CL.AddDelphiFunction('Function InputBox( const ACaption, APrompt, ADefault : string) : string');
CL.AddDelphiFunction('Function InputQuery( const ACaption, APrompt : string; var Value : string) : Boolean');
end;
(* === run-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure TFindDialogOnFind_W(Self: TFindDialog; const T: TNotifyEvent);
begin Self.OnFind := T; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogOnFind_R(Self: TFindDialog; var T: TNotifyEvent);
begin T := Self.OnFind; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogOptions_W(Self: TFindDialog; const T: TFindOptions);
begin Self.Options := T; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogOptions_R(Self: TFindDialog; var T: TFindOptions);
begin T := Self.Options; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogFindText_W(Self: TFindDialog; const T: string);
begin Self.FindText := T; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogFindText_R(Self: TFindDialog; var T: string);
begin T := Self.FindText; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogTop_W(Self: TFindDialog; const T: Integer);
begin Self.Top := T; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogTop_R(Self: TFindDialog; var T: Integer);
begin T := Self.Top; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogPosition_W(Self: TFindDialog; const T: TPoint);
begin Self.Position := T; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogPosition_R(Self: TFindDialog; var T: TPoint);
begin T := Self.Position; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogLeft_W(Self: TFindDialog; const T: Integer);
begin Self.Left := T; end;
(*----------------------------------------------------------------------------*)
procedure TFindDialogLeft_R(Self: TFindDialog; var T: Integer);
begin T := Self.Left; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogToPage_W(Self: TPrintDialog; const T: Integer);
begin Self.ToPage := T; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogToPage_R(Self: TPrintDialog; var T: Integer);
begin T := Self.ToPage; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogPrintRange_W(Self: TPrintDialog; const T: TPrintRange);
begin Self.PrintRange := T; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogPrintRange_R(Self: TPrintDialog; var T: TPrintRange);
begin T := Self.PrintRange; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogPrintToFile_W(Self: TPrintDialog; const T: Boolean);
begin Self.PrintToFile := T; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogPrintToFile_R(Self: TPrintDialog; var T: Boolean);
begin T := Self.PrintToFile; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogOptions_W(Self: TPrintDialog; const T: TPrintDialogOptions);
begin Self.Options := T; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogOptions_R(Self: TPrintDialog; var T: TPrintDialogOptions);
begin T := Self.Options; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogMaxPage_W(Self: TPrintDialog; const T: Integer);
begin Self.MaxPage := T; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogMaxPage_R(Self: TPrintDialog; var T: Integer);
begin T := Self.MaxPage; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogMinPage_W(Self: TPrintDialog; const T: Integer);
begin Self.MinPage := T; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogMinPage_R(Self: TPrintDialog; var T: Integer);
begin T := Self.MinPage; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogFromPage_W(Self: TPrintDialog; const T: Integer);
begin Self.FromPage := T; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogFromPage_R(Self: TPrintDialog; var T: Integer);
begin T := Self.FromPage; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogCopies_W(Self: TPrintDialog; const T: Integer);
begin Self.Copies := T; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogCopies_R(Self: TPrintDialog; var T: Integer);
begin T := Self.Copies; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogCollate_W(Self: TPrintDialog; const T: Boolean);
begin Self.Collate := T; end;
(*----------------------------------------------------------------------------*)
procedure TPrintDialogCollate_R(Self: TPrintDialog; var T: Boolean);
begin T := Self.Collate; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogOnApply_W(Self: TFontDialog; const T: TFDApplyEvent);
begin Self.OnApply := T; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogOnApply_R(Self: TFontDialog; var T: TFDApplyEvent);
begin T := Self.OnApply; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogOptions_W(Self: TFontDialog; const T: TFontDialogOptions);
begin Self.Options := T; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogOptions_R(Self: TFontDialog; var T: TFontDialogOptions);
begin T := Self.Options; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogMaxFontSize_W(Self: TFontDialog; const T: Integer);
begin Self.MaxFontSize := T; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogMaxFontSize_R(Self: TFontDialog; var T: Integer);
begin T := Self.MaxFontSize; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogMinFontSize_W(Self: TFontDialog; const T: Integer);
begin Self.MinFontSize := T; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogMinFontSize_R(Self: TFontDialog; var T: Integer);
begin T := Self.MinFontSize; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogDevice_W(Self: TFontDialog; const T: TFontDialogDevice);
begin Self.Device := T; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogDevice_R(Self: TFontDialog; var T: TFontDialogDevice);
begin T := Self.Device; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogFont_W(Self: TFontDialog; const T: TFont);
begin Self.Font := T; end;
(*----------------------------------------------------------------------------*)
procedure TFontDialogFont_R(Self: TFontDialog; var T: TFont);
begin T := Self.Font; end;
(*----------------------------------------------------------------------------*)
procedure TColorDialogOptions_W(Self: TColorDialog; const T: TColorDialogOptions);
begin Self.Options := T; end;
(*----------------------------------------------------------------------------*)
procedure TColorDialogOptions_R(Self: TColorDialog; var T: TColorDialogOptions);
begin T := Self.Options; end;
(*----------------------------------------------------------------------------*)
procedure TColorDialogCustomColors_W(Self: TColorDialog; const T: TStrings);
begin Self.CustomColors := T; end;
(*----------------------------------------------------------------------------*)
procedure TColorDialogCustomColors_R(Self: TColorDialog; var T: TStrings);
begin T := Self.CustomColors; end;
(*----------------------------------------------------------------------------*)
procedure TColorDialogColor_W(Self: TColorDialog; const T: TColor);
begin Self.Color := T; end;
(*----------------------------------------------------------------------------*)
procedure TColorDialogColor_R(Self: TColorDialog; var T: TColor);
begin T := Self.Color; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnIncludeItem_W(Self: TOpenDialog; const T: TIncludeItemEvent);
begin Self.OnIncludeItem := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnIncludeItem_R(Self: TOpenDialog; var T: TIncludeItemEvent);
begin T := Self.OnIncludeItem; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnTypeChange_W(Self: TOpenDialog; const T: TNotifyEvent);
begin Self.OnTypeChange := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnTypeChange_R(Self: TOpenDialog; var T: TNotifyEvent);
begin T := Self.OnTypeChange; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnSelectionChange_W(Self: TOpenDialog; const T: TNotifyEvent);
begin Self.OnSelectionChange := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnSelectionChange_R(Self: TOpenDialog; var T: TNotifyEvent);
begin T := Self.OnSelectionChange; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnFolderChange_W(Self: TOpenDialog; const T: TNotifyEvent);
begin Self.OnFolderChange := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnFolderChange_R(Self: TOpenDialog; var T: TNotifyEvent);
begin T := Self.OnFolderChange; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnCanClose_W(Self: TOpenDialog; const T: TCloseQueryEvent);
begin Self.OnCanClose := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOnCanClose_R(Self: TOpenDialog; var T: TCloseQueryEvent);
begin T := Self.OnCanClose; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogTitle_W(Self: TOpenDialog; const T: string);
begin Self.Title := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogTitle_R(Self: TOpenDialog; var T: string);
begin T := Self.Title; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOptions_W(Self: TOpenDialog; const T: TOpenOptions);
begin Self.Options := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogOptions_R(Self: TOpenDialog; var T: TOpenOptions);
begin T := Self.Options; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogInitialDir_W(Self: TOpenDialog; const T: string);
begin Self.InitialDir := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogInitialDir_R(Self: TOpenDialog; var T: string);
begin T := Self.InitialDir; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogFilterIndex_W(Self: TOpenDialog; const T: Integer);
begin Self.FilterIndex := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogFilterIndex_R(Self: TOpenDialog; var T: Integer);
begin T := Self.FilterIndex; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogFilter_W(Self: TOpenDialog; const T: string);
begin Self.Filter := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogFilter_R(Self: TOpenDialog; var T: string);
begin T := Self.Filter; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogFileName_W(Self: TOpenDialog; const T: TFileName);
begin Self.FileName := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogFileName_R(Self: TOpenDialog; var T: TFileName);
begin T := Self.FileName; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogDefaultExt_W(Self: TOpenDialog; const T: string);
begin Self.DefaultExt := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogDefaultExt_R(Self: TOpenDialog; var T: string);
begin T := Self.DefaultExt; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogHistoryList_W(Self: TOpenDialog; const T: TStrings);
begin Self.HistoryList := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogHistoryList_R(Self: TOpenDialog; var T: TStrings);
begin T := Self.HistoryList; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogFiles_R(Self: TOpenDialog; var T: TStrings);
begin T := Self.Files; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogFileEditStyle_W(Self: TOpenDialog; const T: TFileEditStyle);
begin Self.FileEditStyle := T; end;
(*----------------------------------------------------------------------------*)
procedure TOpenDialogFileEditStyle_R(Self: TOpenDialog; var T: TFileEditStyle);
begin T := Self.FileEditStyle; end;
(*----------------------------------------------------------------------------*)
procedure TCommonDialogOnShow_W(Self: TCommonDialog; const T: TNotifyEvent);
begin Self.OnShow := T; end;
(*----------------------------------------------------------------------------*)
procedure TCommonDialogOnShow_R(Self: TCommonDialog; var T: TNotifyEvent);
begin T := Self.OnShow; end;
(*----------------------------------------------------------------------------*)
procedure TCommonDialogOnClose_W(Self: TCommonDialog; const T: TNotifyEvent);
begin Self.OnClose := T; end;
(*----------------------------------------------------------------------------*)
procedure TCommonDialogOnClose_R(Self: TCommonDialog; var T: TNotifyEvent);
begin T := Self.OnClose; end;
(*----------------------------------------------------------------------------*)
procedure TCommonDialogHelpContext_W(Self: TCommonDialog; const T: THelpContext);
begin Self.HelpContext := T; end;
(*----------------------------------------------------------------------------*)
procedure TCommonDialogHelpContext_R(Self: TCommonDialog; var T: THelpContext);
begin T := Self.HelpContext; end;
(*----------------------------------------------------------------------------*)
procedure TCommonDialogCtl3D_W(Self: TCommonDialog; const T: Boolean);
begin Self.Ctl3D := T; end;
(*----------------------------------------------------------------------------*)
procedure TCommonDialogCtl3D_R(Self: TCommonDialog; var T: Boolean);
begin T := Self.Ctl3D; end;
(*----------------------------------------------------------------------------*)
procedure TCommonDialogHandle_R(Self: TCommonDialog; var T: HWnd);
begin T := Self.Handle; end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_Dialogs_Routines(S: TPSExec);
begin
S.RegisterDelphiFunction(@CreateMessageDialog, 'CreateMessageDialog', cdRegister);
S.RegisterDelphiFunction(@MessageDlg, 'MessageDlg', cdRegister);
S.RegisterDelphiFunction(@MessageDlgPos, 'MessageDlgPos', cdRegister);
S.RegisterDelphiFunction(@MessageDlgPosHelp, 'MessageDlgPosHelp', cdRegister);
S.RegisterDelphiFunction(@ShowMessage, 'ShowMessage', cdRegister);
S.RegisterDelphiFunction(@ShowMessagePos, 'ShowMessagePos', cdRegister);
S.RegisterDelphiFunction(@InputBox, 'InputBox', cdRegister);
S.RegisterDelphiFunction(@InputQuery, 'InputQuery', cdRegister);
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TReplaceDialog(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TReplaceDialog) do
begin
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TFindDialog(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TFindDialog) do
begin
RegisterMethod(@TFindDialog.CloseDialog, 'CloseDialog');
RegisterPropertyHelper(@TFindDialogLeft_R,@TFindDialogLeft_W,'Left');
RegisterPropertyHelper(@TFindDialogPosition_R,@TFindDialogPosition_W,'Position');
RegisterPropertyHelper(@TFindDialogTop_R,@TFindDialogTop_W,'Top');
RegisterPropertyHelper(@TFindDialogFindText_R,@TFindDialogFindText_W,'FindText');
RegisterPropertyHelper(@TFindDialogOptions_R,@TFindDialogOptions_W,'Options');
RegisterPropertyHelper(@TFindDialogOnFind_R,@TFindDialogOnFind_W,'OnFind');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TPrintDialog(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TPrintDialog) do
begin
RegisterPropertyHelper(@TPrintDialogCollate_R,@TPrintDialogCollate_W,'Collate');
RegisterPropertyHelper(@TPrintDialogCopies_R,@TPrintDialogCopies_W,'Copies');
RegisterPropertyHelper(@TPrintDialogFromPage_R,@TPrintDialogFromPage_W,'FromPage');
RegisterPropertyHelper(@TPrintDialogMinPage_R,@TPrintDialogMinPage_W,'MinPage');
RegisterPropertyHelper(@TPrintDialogMaxPage_R,@TPrintDialogMaxPage_W,'MaxPage');
RegisterPropertyHelper(@TPrintDialogOptions_R,@TPrintDialogOptions_W,'Options');
RegisterPropertyHelper(@TPrintDialogPrintToFile_R,@TPrintDialogPrintToFile_W,'PrintToFile');
RegisterPropertyHelper(@TPrintDialogPrintRange_R,@TPrintDialogPrintRange_W,'PrintRange');
RegisterPropertyHelper(@TPrintDialogToPage_R,@TPrintDialogToPage_W,'ToPage');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TPrinterSetupDialog(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TPrinterSetupDialog) do
begin
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TFontDialog(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TFontDialog) do
begin
RegisterPropertyHelper(@TFontDialogFont_R,@TFontDialogFont_W,'Font');
RegisterPropertyHelper(@TFontDialogDevice_R,@TFontDialogDevice_W,'Device');
RegisterPropertyHelper(@TFontDialogMinFontSize_R,@TFontDialogMinFontSize_W,'MinFontSize');
RegisterPropertyHelper(@TFontDialogMaxFontSize_R,@TFontDialogMaxFontSize_W,'MaxFontSize');
RegisterPropertyHelper(@TFontDialogOptions_R,@TFontDialogOptions_W,'Options');
RegisterPropertyHelper(@TFontDialogOnApply_R,@TFontDialogOnApply_W,'OnApply');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TColorDialog(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TColorDialog) do
begin
RegisterPropertyHelper(@TColorDialogColor_R,@TColorDialogColor_W,'Color');
RegisterPropertyHelper(@TColorDialogCustomColors_R,@TColorDialogCustomColors_W,'CustomColors');
RegisterPropertyHelper(@TColorDialogOptions_R,@TColorDialogOptions_W,'Options');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TSaveDialog(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TSaveDialog) do
begin
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TOpenDialog(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TOpenDialog) do
begin
RegisterPropertyHelper(@TOpenDialogFileEditStyle_R,@TOpenDialogFileEditStyle_W,'FileEditStyle');
RegisterPropertyHelper(@TOpenDialogFiles_R,nil,'Files');
RegisterPropertyHelper(@TOpenDialogHistoryList_R,@TOpenDialogHistoryList_W,'HistoryList');
RegisterPropertyHelper(@TOpenDialogDefaultExt_R,@TOpenDialogDefaultExt_W,'DefaultExt');
RegisterPropertyHelper(@TOpenDialogFileName_R,@TOpenDialogFileName_W,'FileName');
RegisterPropertyHelper(@TOpenDialogFilter_R,@TOpenDialogFilter_W,'Filter');
RegisterPropertyHelper(@TOpenDialogFilterIndex_R,@TOpenDialogFilterIndex_W,'FilterIndex');
RegisterPropertyHelper(@TOpenDialogInitialDir_R,@TOpenDialogInitialDir_W,'InitialDir');
RegisterPropertyHelper(@TOpenDialogOptions_R,@TOpenDialogOptions_W,'Options');
RegisterPropertyHelper(@TOpenDialogTitle_R,@TOpenDialogTitle_W,'Title');
RegisterPropertyHelper(@TOpenDialogOnCanClose_R,@TOpenDialogOnCanClose_W,'OnCanClose');
RegisterPropertyHelper(@TOpenDialogOnFolderChange_R,@TOpenDialogOnFolderChange_W,'OnFolderChange');
RegisterPropertyHelper(@TOpenDialogOnSelectionChange_R,@TOpenDialogOnSelectionChange_W,'OnSelectionChange');
RegisterPropertyHelper(@TOpenDialogOnTypeChange_R,@TOpenDialogOnTypeChange_W,'OnTypeChange');
RegisterPropertyHelper(@TOpenDialogOnIncludeItem_R,@TOpenDialogOnIncludeItem_W,'OnIncludeItem');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TCommonDialog(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TCommonDialog) do
begin
RegisterPropertyHelper(@TCommonDialogHandle_R,nil,'Handle');
RegisterPropertyHelper(@TCommonDialogCtl3D_R,@TCommonDialogCtl3D_W,'Ctl3D');
RegisterPropertyHelper(@TCommonDialogHelpContext_R,@TCommonDialogHelpContext_W,'HelpContext');
RegisterPropertyHelper(@TCommonDialogOnClose_R,@TCommonDialogOnClose_W,'OnClose');
RegisterPropertyHelper(@TCommonDialogOnShow_R,@TCommonDialogOnShow_W,'OnShow');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_Dialogs(CL: TPSRuntimeClassImporter);
begin
RIRegister_TCommonDialog(CL);
RIRegister_TOpenDialog(CL);
RIRegister_TSaveDialog(CL);
RIRegister_TColorDialog(CL);
RIRegister_TFontDialog(CL);
RIRegister_TPrinterSetupDialog(CL);
RIRegister_TPrintDialog(CL);
RIRegister_TFindDialog(CL);
RIRegister_TReplaceDialog(CL);
end;
{ TPSImport_Dialogs }
(*----------------------------------------------------------------------------*)
procedure TPSImport_Dialogs.CompOnUses(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Dialogs.ExecOnUses(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Dialogs.CompileImport1(CompExec: TPSScript);
begin
SIRegister_Dialogs(CompExec.Comp);
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Dialogs.CompileImport2(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Dialogs.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
RIRegister_Dialogs(ri);
RIRegister_Dialogs_Routines(CompExec.Exec); // comment it if no routines
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Dialogs.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
{ nothing }
end;
end.

2153
Units/PascalScript/uPSI_IBX.pas Normal file
View File

File diff suppressed because it is too large Load Diff

373
Units/PascalScript/uPSI_JvMail.pas Normal file
View File

@ -0,0 +1,373 @@
unit uPSI_JvMail;
{
This file has been generated by UnitParser v0.4b, written by M. Knight
and updated by NP. v/d Spek.
Source Code from Carlo Kok has been used to implement various sections of
UnitParser. Components of ifps3 are used in the construction of UnitParser,
code implementing the class wrapper is taken from Carlo Kok''s conv unility
}
interface
uses
SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
type
(*----------------------------------------------------------------------------*)
TPSImport_JvMail = class(TPSPlugin)
protected
procedure CompOnUses(CompExec: TPSScript); override;
procedure ExecOnUses(CompExec: TPSScript); override;
procedure CompileImport1(CompExec: TPSScript); override;
procedure CompileImport2(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
end;
implementation
uses
Windows
,Controls
,Forms
,Mapi
,JclBase
,JclMapi
,JvComponent
,JvMail
;
(* === compile-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure SIRegister_TJvMail(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TJvComponent', 'TJvMail') do
with CL.AddClassN(CL.FindClass('TComponent'),'TJvMail') do
begin
RegisterMethod('Function Address( const Caption : string; EditFields : Integer) : Boolean');
RegisterMethod('Procedure Clear');
RegisterMethod('Function ErrorCheck( Res : DWORD) : DWORD');
RegisterMethod('Function FindFirstMail : Boolean');
RegisterMethod('Function FindNextMail : Boolean');
RegisterMethod('Procedure FreeSimpleMapi');
RegisterMethod('Procedure LogOff');
RegisterMethod('Procedure LogOn');
RegisterMethod('Procedure ReadMail');
RegisterMethod('Function ResolveName( const Name : string) : string');
RegisterMethod('Function SaveMail( const MessageID : string) : string');
RegisterMethod('Procedure SendMail( ShowDialog : Boolean)');
RegisterProperty('ReadedMail', 'TJvMailReadedData', iptr);
RegisterProperty('SeedMessageID', 'string', iptrw);
RegisterProperty('SessionHandle', 'THandle', iptr);
RegisterProperty('SimpleMAPI', 'TJclSimpleMapi', iptr);
RegisterProperty('UserLogged', 'Boolean', iptr);
RegisterProperty('Attachment', 'TStrings', iptrw);
RegisterProperty('BlindCopy', 'TJvMailRecipients', iptrw);
RegisterProperty('Body', 'TStrings', iptrw);
RegisterProperty('CarbonCopy', 'TJvMailRecipients', iptrw);
RegisterProperty('LogonOptions', 'TJvMailLogonOptions', iptrw);
RegisterProperty('LongMsgId', 'Boolean', iptrw);
RegisterProperty('Password', 'string', iptrw);
RegisterProperty('ProfileName', 'string', iptrw);
RegisterProperty('ReadOptions', 'TJvMailReadOptions', iptrw);
RegisterProperty('Recipient', 'TJvMailRecipients', iptrw);
RegisterProperty('Subject', 'string', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TJvMailRecipients(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCollection', 'TJvMailRecipients') do
with CL.AddClassN(CL.FindClass('TCollection'),'TJvMailRecipients') do
begin
RegisterMethod('Constructor Create( AOwner : TJvMail; ARecipientClass : DWORD)');
RegisterMethod('Function Add : TJvMailRecipient');
RegisterMethod('Function AddRecipient( const Address : string; const Name : string) : Integer');
RegisterProperty('Items', 'TJvMailRecipient Integer', iptrw);
SetDefaultPropery('Items');
RegisterProperty('RecipientClass', 'DWORD', iptr);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TJvMailRecipient(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCollectionItem', 'TJvMailRecipient') do
with CL.AddClassN(CL.FindClass('TCollectionItem'),'TJvMailRecipient') do
begin
RegisterProperty('AddressAndName', 'string', iptr);
RegisterProperty('Address', 'string', iptrw);
RegisterProperty('Name', 'string', iptrw);
RegisterProperty('Valid', 'Boolean', iptr);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_JvMail(CL: TPSPascalCompiler);
begin
CL.AddClassN(CL.FindClass('TOBJECT'),'TJvMail');
SIRegister_TJvMailRecipient(CL);
SIRegister_TJvMailRecipients(CL);
CL.AddTypeS('TJvMailLogonOption', '( loLogonUI, loNewSession )');
CL.AddTypeS('TJvMailReadOption', '( roUnreadOnly, roFifo, roPeek, roHeaderOnl'
+'y, roAttachments )');
CL.AddTypeS('TJvMailLogonOptions', 'set of TJvMailLogonOption');
CL.AddTypeS('TJvMailReadOptions', 'set of TJvMailReadOption');
CL.AddTypeS('TJvMailReadedData', 'record RecipientAddress : string; Recipient'
+'Name : string; ConversationID : string; DateReceived : TDateTime; end');
SIRegister_TJvMail(CL);
end;
(* === run-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure TJvMailSubject_W(Self: TJvMail; const T: string);
begin Self.Subject := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailSubject_R(Self: TJvMail; var T: string);
begin T := Self.Subject; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipient_W(Self: TJvMail; const T: TJvMailRecipients);
begin Self.Recipient := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipient_R(Self: TJvMail; var T: TJvMailRecipients);
begin T := Self.Recipient; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailReadOptions_W(Self: TJvMail; const T: TJvMailReadOptions);
begin Self.ReadOptions := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailReadOptions_R(Self: TJvMail; var T: TJvMailReadOptions);
begin T := Self.ReadOptions; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailProfileName_W(Self: TJvMail; const T: string);
begin Self.ProfileName := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailProfileName_R(Self: TJvMail; var T: string);
begin T := Self.ProfileName; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailPassword_W(Self: TJvMail; const T: string);
begin Self.Password := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailPassword_R(Self: TJvMail; var T: string);
begin T := Self.Password; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailLongMsgId_W(Self: TJvMail; const T: Boolean);
begin Self.LongMsgId := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailLongMsgId_R(Self: TJvMail; var T: Boolean);
begin T := Self.LongMsgId; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailLogonOptions_W(Self: TJvMail; const T: TJvMailLogonOptions);
begin Self.LogonOptions := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailLogonOptions_R(Self: TJvMail; var T: TJvMailLogonOptions);
begin T := Self.LogonOptions; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailCarbonCopy_W(Self: TJvMail; const T: TJvMailRecipients);
begin Self.CarbonCopy := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailCarbonCopy_R(Self: TJvMail; var T: TJvMailRecipients);
begin T := Self.CarbonCopy; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailBody_W(Self: TJvMail; const T: TStrings);
begin Self.Body := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailBody_R(Self: TJvMail; var T: TStrings);
begin T := Self.Body; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailBlindCopy_W(Self: TJvMail; const T: TJvMailRecipients);
begin Self.BlindCopy := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailBlindCopy_R(Self: TJvMail; var T: TJvMailRecipients);
begin T := Self.BlindCopy; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailAttachment_W(Self: TJvMail; const T: TStrings);
begin Self.Attachment := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailAttachment_R(Self: TJvMail; var T: TStrings);
begin T := Self.Attachment; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailUserLogged_R(Self: TJvMail; var T: Boolean);
begin T := Self.UserLogged; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailSimpleMAPI_R(Self: TJvMail; var T: TJclSimpleMapi);
begin T := Self.SimpleMAPI; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailSessionHandle_R(Self: TJvMail; var T: THandle);
begin T := Self.SessionHandle; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailSeedMessageID_W(Self: TJvMail; const T: string);
begin Self.SeedMessageID := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailSeedMessageID_R(Self: TJvMail; var T: string);
begin T := Self.SeedMessageID; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailReadedMail_R(Self: TJvMail; var T: TJvMailReadedData);
begin T := Self.ReadedMail; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipientsRecipientClass_R(Self: TJvMailRecipients; var T: DWORD);
begin T := Self.RecipientClass; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipientsItems_W(Self: TJvMailRecipients; const T: TJvMailRecipient; const t1: Integer);
begin Self.Items[t1] := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipientsItems_R(Self: TJvMailRecipients; var T: TJvMailRecipient; const t1: Integer);
begin T := Self.Items[t1]; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipientValid_R(Self: TJvMailRecipient; var T: Boolean);
begin T := Self.Valid; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipientName_W(Self: TJvMailRecipient; const T: string);
begin Self.Name := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipientName_R(Self: TJvMailRecipient; var T: string);
begin T := Self.Name; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipientAddress_W(Self: TJvMailRecipient; const T: string);
begin Self.Address := T; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipientAddress_R(Self: TJvMailRecipient; var T: string);
begin T := Self.Address; end;
(*----------------------------------------------------------------------------*)
procedure TJvMailRecipientAddressAndName_R(Self: TJvMailRecipient; var T: string);
begin T := Self.AddressAndName; end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TJvMail(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TJvMail) do
begin
RegisterMethod(@TJvMail.Address, 'Address');
RegisterMethod(@TJvMail.Clear, 'Clear');
RegisterMethod(@TJvMail.ErrorCheck, 'ErrorCheck');
RegisterMethod(@TJvMail.FindFirstMail, 'FindFirstMail');
RegisterMethod(@TJvMail.FindNextMail, 'FindNextMail');
RegisterMethod(@TJvMail.FreeSimpleMapi, 'FreeSimpleMapi');
RegisterMethod(@TJvMail.LogOff, 'LogOff');
RegisterMethod(@TJvMail.LogOn, 'LogOn');
RegisterMethod(@TJvMail.ReadMail, 'ReadMail');
RegisterMethod(@TJvMail.ResolveName, 'ResolveName');
RegisterMethod(@TJvMail.SaveMail, 'SaveMail');
RegisterMethod(@TJvMail.SendMail, 'SendMail');
RegisterPropertyHelper(@TJvMailReadedMail_R,nil,'ReadedMail');
RegisterPropertyHelper(@TJvMailSeedMessageID_R,@TJvMailSeedMessageID_W,'SeedMessageID');
RegisterPropertyHelper(@TJvMailSessionHandle_R,nil,'SessionHandle');
RegisterPropertyHelper(@TJvMailSimpleMAPI_R,nil,'SimpleMAPI');
RegisterPropertyHelper(@TJvMailUserLogged_R,nil,'UserLogged');
RegisterPropertyHelper(@TJvMailAttachment_R,@TJvMailAttachment_W,'Attachment');
RegisterPropertyHelper(@TJvMailBlindCopy_R,@TJvMailBlindCopy_W,'BlindCopy');
RegisterPropertyHelper(@TJvMailBody_R,@TJvMailBody_W,'Body');
RegisterPropertyHelper(@TJvMailCarbonCopy_R,@TJvMailCarbonCopy_W,'CarbonCopy');
RegisterPropertyHelper(@TJvMailLogonOptions_R,@TJvMailLogonOptions_W,'LogonOptions');
RegisterPropertyHelper(@TJvMailLongMsgId_R,@TJvMailLongMsgId_W,'LongMsgId');
RegisterPropertyHelper(@TJvMailPassword_R,@TJvMailPassword_W,'Password');
RegisterPropertyHelper(@TJvMailProfileName_R,@TJvMailProfileName_W,'ProfileName');
RegisterPropertyHelper(@TJvMailReadOptions_R,@TJvMailReadOptions_W,'ReadOptions');
RegisterPropertyHelper(@TJvMailRecipient_R,@TJvMailRecipient_W,'Recipient');
RegisterPropertyHelper(@TJvMailSubject_R,@TJvMailSubject_W,'Subject');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TJvMailRecipients(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TJvMailRecipients) do
begin
RegisterConstructor(@TJvMailRecipients.Create, 'Create');
RegisterMethod(@TJvMailRecipients.Add, 'Add');
RegisterMethod(@TJvMailRecipients.AddRecipient, 'AddRecipient');
RegisterPropertyHelper(@TJvMailRecipientsItems_R,@TJvMailRecipientsItems_W,'Items');
RegisterPropertyHelper(@TJvMailRecipientsRecipientClass_R,nil,'RecipientClass');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TJvMailRecipient(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TJvMailRecipient) do
begin
RegisterPropertyHelper(@TJvMailRecipientAddressAndName_R,nil,'AddressAndName');
RegisterPropertyHelper(@TJvMailRecipientAddress_R,@TJvMailRecipientAddress_W,'Address');
RegisterPropertyHelper(@TJvMailRecipientName_R,@TJvMailRecipientName_W,'Name');
RegisterPropertyHelper(@TJvMailRecipientValid_R,nil,'Valid');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_JvMail(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TJvMail) do
RIRegister_TJvMailRecipient(CL);
RIRegister_TJvMailRecipients(CL);
RIRegister_TJvMail(CL);
end;
{ TPSImport_JvMail }
(*----------------------------------------------------------------------------*)
procedure TPSImport_JvMail.CompOnUses(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_JvMail.ExecOnUses(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_JvMail.CompileImport1(CompExec: TPSScript);
begin
SIRegister_JvMail(CompExec.Comp);
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_JvMail.CompileImport2(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_JvMail.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
RIRegister_JvMail(ri);
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_JvMail.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
{ nothing }
end;
end.

187
Units/PascalScript/uPSI_Mask.pas Normal file
View File

@ -0,0 +1,187 @@
unit uPSI_Mask;
{
This file has been generated by UnitParser v0.5, written by M. Knight
and updated by NP. v/d Spek.
Source Code from Carlo Kok has been used to implement various sections of
UnitParser. Components of ifps3 are used in the construction of UnitParser,
code implementing the class wrapper is taken from Carlo Kok''s conv unility
}
interface
uses
SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
type
(*----------------------------------------------------------------------------*)
TPSImport_Mask = class(TPSPlugin)
protected
procedure CompOnUses(CompExec: TPSScript); override;
procedure ExecOnUses(CompExec: TPSScript); override;
procedure CompileImport1(CompExec: TPSScript); override;
procedure CompileImport2(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
end;
implementation
uses
Windows ,StdCtrls ,Controls ,Messages ,Forms ,Graphics ,Menus ,Mask;
(* === compile-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure SIRegister_TMaskEdit(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCustomMaskEdit', 'TMaskEdit') do
with CL.AddClassN(CL.FindClass('TCustomMaskEdit'),'TMaskEdit') do
begin
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TCustomMaskEdit(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCustomEdit', 'TCustomMaskEdit') do
with CL.AddClassN(CL.FindClass('TCustomEdit'),'TCustomMaskEdit') do
begin
RegisterMethod('Procedure ValidateEdit');
RegisterMethod('Function GetTextLen : Integer');
RegisterProperty('IsMasked', 'Boolean', iptr);
RegisterProperty('EditText', 'string', iptrw);
RegisterProperty('Text', 'string', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_Mask(CL: TPSPascalCompiler);
begin
CL.AddConstantN('DefaultBlank','Char').SetString( '_');
CL.AddConstantN('MaskFieldSeparator','Char').SetString( ';');
CL.AddConstantN('MaskNoSave','Char').SetString( '0');
CL.AddConstantN('mDirReverse','String').SetString( '!');
CL.AddConstantN('mDirUpperCase','String').SetString( '>');
CL.AddConstantN('mDirLowerCase','String').SetString( '<');
CL.AddConstantN('mDirLiteral','String').SetString( '\');
CL.AddConstantN('mMskAlpha','String').SetString( 'L');
CL.AddConstantN('mMskAlphaOpt','String').SetString( 'l');
CL.AddConstantN('mMskAlphaNum','String').SetString( 'A');
CL.AddConstantN('mMskAlphaNumOpt','String').SetString( 'a');
CL.AddConstantN('mMskAscii','String').SetString( 'C');
CL.AddConstantN('mMskAsciiOpt','String').SetString( 'c');
CL.AddConstantN('mMskNumeric','String').SetString( '0');
CL.AddConstantN('mMskNumericOpt','String').SetString( '9');
CL.AddConstantN('mMskNumSymOpt','String').SetString( '#');
CL.AddConstantN('mMskTimeSeparator','String').SetString( ':');
CL.AddConstantN('mMskDateSeparator','String').SetString( '/');
CL.AddTypeS('TMaskCharType', '( mcNone, mcLiteral, mcIntlLiteral, mcDirective'
+', mcMask, mcMaskOpt, mcFieldSeparator, mcField )');
CL.AddTypeS('TMaskDirective', '( mdReverseDir, mdUpperCase, mdLowerCa'
+'se, mdLiteralChar )');
CL.AddTypeS('TMaskDirectives', 'set of TMaskDirective');
CL.AddClassN(CL.FindClass('TOBJECT'),'EDBEditError');
CL.AddTypeS('TMaskedStatex', '( msMasked, msReEnter, msDBSetText )');
CL.AddTypeS('TMaskedState', 'set of TMaskedStatex');
SIRegister_TCustomMaskEdit(CL);
SIRegister_TMaskEdit(CL);
CL.AddDelphiFunction('Function FormatMaskText( const EditMask : string; const Value : string) : string');
CL.AddDelphiFunction('Function MaskGetMaskSave( const EditMask : string) : Boolean');
CL.AddDelphiFunction('Function MaskGetMaskBlank( const EditMask : string) : Char');
CL.AddDelphiFunction('Function MaskGetFldSeparator( const EditMask : string) : Integer');
end;
(* === run-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure TCustomMaskEditText_W(Self: TCustomMaskEdit; const T: string);
begin Self.Text := T; end;
(*----------------------------------------------------------------------------*)
procedure TCustomMaskEditText_R(Self: TCustomMaskEdit; var T: string);
begin T := Self.Text; end;
(*----------------------------------------------------------------------------*)
procedure TCustomMaskEditEditText_W(Self: TCustomMaskEdit; const T: string);
begin Self.EditText := T; end;
(*----------------------------------------------------------------------------*)
procedure TCustomMaskEditEditText_R(Self: TCustomMaskEdit; var T: string);
begin T := Self.EditText; end;
(*----------------------------------------------------------------------------*)
procedure TCustomMaskEditIsMasked_R(Self: TCustomMaskEdit; var T: Boolean);
begin T := Self.IsMasked; end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_Mask_Routines(S: TPSExec);
begin
S.RegisterDelphiFunction(@FormatMaskText, 'FormatMaskText', cdRegister);
S.RegisterDelphiFunction(@MaskGetMaskSave, 'MaskGetMaskSave', cdRegister);
S.RegisterDelphiFunction(@MaskGetMaskBlank, 'MaskGetMaskBlank', cdRegister);
S.RegisterDelphiFunction(@MaskGetFldSeparator, 'MaskGetFldSeparator', cdRegister);
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TMaskEdit(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TMaskEdit) do
begin
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TCustomMaskEdit(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TCustomMaskEdit) do
begin
RegisterVirtualMethod(@TCustomMaskEdit.ValidateEdit, 'ValidateEdit');
RegisterMethod(@TCustomMaskEdit.GetTextLen, 'GetTextLen');
RegisterPropertyHelper(@TCustomMaskEditIsMasked_R,nil,'IsMasked');
RegisterPropertyHelper(@TCustomMaskEditEditText_R,@TCustomMaskEditEditText_W,'EditText');
RegisterPropertyHelper(@TCustomMaskEditText_R,@TCustomMaskEditText_W,'Text');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_Mask(CL: TPSRuntimeClassImporter);
begin
with CL.Add(EDBEditError) do
RIRegister_TCustomMaskEdit(CL);
RIRegister_TMaskEdit(CL);
end;
{ TPSImport_Mask }
(*----------------------------------------------------------------------------*)
procedure TPSImport_Mask.CompOnUses(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Mask.ExecOnUses(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Mask.CompileImport1(CompExec: TPSScript);
begin
SIRegister_Mask(CompExec.Comp);
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Mask.CompileImport2(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Mask.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
RIRegister_Mask(ri);
RIRegister_Mask_Routines(CompExec.Exec); // comment it if no routines
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Mask.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
{ nothing }
end;
end.

478
Units/PascalScript/uPSI_Registry.pas Normal file
View File

@ -0,0 +1,478 @@
unit uPSI_Registry;
{
This file has been generated by UnitParser v0.4b, written by M. Knight
and updated by NP. v/d Spek.
Source Code from Carlo Kok has been used to implement various sections of
UnitParser. Components of ifps3 are used in the construction of UnitParser,
code implementing the class wrapper is taken from Carlo Kok''s conv unility
}
interface
uses
SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
type
(*----------------------------------------------------------------------------*)
TPSImport_Registry = class(TPSPlugin)
protected
procedure CompOnUses(CompExec: TPSScript); override;
procedure ExecOnUses(CompExec: TPSScript); override;
procedure CompileImport1(CompExec: TPSScript); override;
procedure CompileImport2(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
end;
implementation
uses
Windows ,IniFiles ,Registry ;
(* === compile-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure SIRegister_TRegistryIniFile(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCustomIniFile', 'TRegistryIniFile') do
with CL.AddClassN(CL.FindClass('TCustomIniFile'),'TRegistryIniFile') do
begin
RegisterMethod('Constructor Create( const FileName : string);');
RegisterMethod('Constructor CreateA( const FileName : string; AAccess : LongWord);');
RegisterProperty('RegIniFile', 'TRegIniFile', iptr);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TRegIniFile(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TRegistry', 'TRegIniFile') do
with CL.AddClassN(CL.FindClass('TRegistry'),'TRegIniFile') do
begin
RegisterMethod('Constructor Create( const FileName : string);');
RegisterMethod('Constructor CreateA( const FileName : string; AAccess : LongWord);');
RegisterMethod('Function ReadString( const Section, Ident, Default : string) : string');
RegisterMethod('Function ReadInteger( const Section, Ident : string; Default : Longint) : Longint');
RegisterMethod('Procedure WriteInteger( const Section, Ident : string; Value : Longint)');
RegisterMethod('Procedure WriteString( const Section, Ident, Value : String)');
RegisterMethod('Function ReadBool( const Section, Ident : string; Default : Boolean) : Boolean');
RegisterMethod('Procedure WriteBool( const Section, Ident : string; Value : Boolean)');
RegisterMethod('Procedure ReadSection( const Section : string; Strings : TStrings)');
RegisterMethod('Procedure ReadSections( Strings : TStrings)');
RegisterMethod('Procedure ReadSectionValues( const Section : string; Strings : TStrings)');
RegisterMethod('Procedure EraseSection( const Section : string)');
RegisterMethod('Procedure DeleteKey( const Section, Ident : String)');
RegisterProperty('FileName', 'string', iptr);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TRegistry(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TObject', 'TRegistry') do
with CL.AddClassN(CL.FindClass('TObject'),'TRegistry') do
begin
RegisterMethod('Constructor Create;');
RegisterMethod('Constructor CreateA( AAccess : LongWord);');
RegisterMethod('Procedure CloseKey');
RegisterMethod('Function CreateKey( const Key : string) : Boolean');
RegisterMethod('Function DeleteKey( const Key : string) : Boolean');
RegisterMethod('Function DeleteValue( const Name : string) : Boolean');
RegisterMethod('Function GetDataInfo( const ValueName : string; var Value : TRegDataInfo) : Boolean');
RegisterMethod('Function GetDataSize( const ValueName : string) : Integer');
RegisterMethod('Function GetDataType( const ValueName : string) : TRegDataType');
RegisterMethod('Function GetKeyInfo( var Value : TRegKeyInfo) : Boolean');
RegisterMethod('Procedure GetKeyNames( Strings : TStrings)');
RegisterMethod('Procedure GetValueNames( Strings : TStrings)');
RegisterMethod('Function HasSubKeys : Boolean');
RegisterMethod('Function KeyExists( const Key : string) : Boolean');
RegisterMethod('Function LoadKey( const Key, FileName : string) : Boolean');
RegisterMethod('Procedure MoveKey( const OldName, NewName : string; Delete : Boolean)');
RegisterMethod('Function OpenKey( const Key : string; CanCreate : Boolean) : Boolean');
RegisterMethod('Function OpenKeyReadOnly( const Key : String) : Boolean');
RegisterMethod('Function ReadCurrency( const Name : string) : Currency');
RegisterMethod('Function ReadBool( const Name : string) : Boolean');
RegisterMethod('Function ReadDate( const Name : string) : TDateTime');
RegisterMethod('Function ReadDateTime( const Name : string) : TDateTime');
RegisterMethod('Function ReadFloat( const Name : string) : Double');
RegisterMethod('Function ReadInteger( const Name : string) : Integer');
RegisterMethod('Function ReadString( const Name : string) : string');
RegisterMethod('Function ReadTime( const Name : string) : TDateTime');
RegisterMethod('Function RegistryConnect( const UNCName : string) : Boolean');
RegisterMethod('Procedure RenameValue( const OldName, NewName : string)');
RegisterMethod('Function ReplaceKey( const Key, FileName, BackUpFileName : string) : Boolean');
RegisterMethod('Function RestoreKey( const Key, FileName : string) : Boolean');
RegisterMethod('Function SaveKey( const Key, FileName : string) : Boolean');
RegisterMethod('Function UnLoadKey( const Key : string) : Boolean');
RegisterMethod('Function ValueExists( const Name : string) : Boolean');
RegisterMethod('Procedure WriteCurrency( const Name : string; Value : Currency)');
RegisterMethod('Procedure WriteBool( const Name : string; Value : Boolean)');
RegisterMethod('Procedure WriteDate( const Name : string; Value : TDateTime)');
RegisterMethod('Procedure WriteDateTime( const Name : string; Value : TDateTime)');
RegisterMethod('Procedure WriteFloat( const Name : string; Value : Double)');
RegisterMethod('Procedure WriteInteger( const Name : string; Value : Integer)');
RegisterMethod('Procedure WriteString( const Name, Value : string)');
RegisterMethod('Procedure WriteExpandString( const Name, Value : string)');
RegisterMethod('Procedure WriteTime( const Name : string; Value : TDateTime)');
RegisterProperty('CurrentKey', 'HKEY', iptr);
RegisterProperty('CurrentPath', 'string', iptr);
RegisterProperty('LazyWrite', 'Boolean', iptrw);
RegisterProperty('RootKey', 'HKEY', iptrw);
RegisterProperty('Access', 'LongWord', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_Registry(CL: TPSPascalCompiler);
begin
CL.AddClassN(CL.FindClass('TOBJECT'),'ERegistryException');
SIRegister_TRegistry(CL);
SIRegister_TRegIniFile(CL);
SIRegister_TRegistryIniFile(CL);
end;
(* === run-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure TRegistryIniFileRegIniFile_R(Self: TRegistryIniFile; var T: TRegIniFile);
begin T := Self.RegIniFile; end;
(*----------------------------------------------------------------------------*)
Function TRegistryIniFileCreateA_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string; AAccess : LongWord):TObject;
Begin Result := TRegistryIniFile.Create(FileName, AAccess); END;
(*----------------------------------------------------------------------------*)
Function TRegistryIniFileCreate_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string):TObject;
Begin Result := TRegistryIniFile.Create(FileName); END;
(*----------------------------------------------------------------------------*)
procedure TRegIniFileFileName_R(Self: TRegIniFile; var T: string);
begin T := Self.FileName; end;
(*----------------------------------------------------------------------------*)
Function TRegIniFileCreateA_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string; AAccess : LongWord):TObject;
Begin Result := TRegIniFile.Create(FileName, AAccess); END;
(*----------------------------------------------------------------------------*)
Function TRegIniFileCreate_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string):TObject;
Begin Result := TRegIniFile.Create(FileName); END;
(*----------------------------------------------------------------------------*)
procedure TRegistryAccess_W(Self: TRegistry; const T: LongWord);
begin Self.Access := T; end;
(*----------------------------------------------------------------------------*)
procedure TRegistryAccess_R(Self: TRegistry; var T: LongWord);
begin T := Self.Access; end;
(*----------------------------------------------------------------------------*)
procedure TRegistryRootKey_W(Self: TRegistry; const T: HKEY);
begin Self.RootKey := T; end;
(*----------------------------------------------------------------------------*)
procedure TRegistryRootKey_R(Self: TRegistry; var T: HKEY);
begin T := Self.RootKey; end;
(*----------------------------------------------------------------------------*)
procedure TRegistryLazyWrite_W(Self: TRegistry; const T: Boolean);
begin Self.LazyWrite := T; end;
(*----------------------------------------------------------------------------*)
procedure TRegistryLazyWrite_R(Self: TRegistry; var T: Boolean);
begin T := Self.LazyWrite; end;
(*----------------------------------------------------------------------------*)
procedure TRegistryCurrentPath_R(Self: TRegistry; var T: string);
begin T := Self.CurrentPath; end;
(*----------------------------------------------------------------------------*)
procedure TRegistryCurrentKey_R(Self: TRegistry; var T: HKEY);
begin T := Self.CurrentKey; end;
(*----------------------------------------------------------------------------*)
Function TRegistryCreateA_P(Self: TClass; CreateNewInstance: Boolean; AAccess : LongWord):TObject;
Begin Result := TRegistry.Create(AAccess); END;
(*----------------------------------------------------------------------------*)
Function TRegistryCreate_P(Self: TClass; CreateNewInstance: Boolean):TObject;
Begin Result := TRegistry.Create; END;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TRegistryIniFile(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TRegistryIniFile) do
begin
RegisterConstructor(@TRegistryIniFileCreate_P, 'Create');
RegisterConstructor(@TRegistryIniFileCreateA_P, 'CreateA');
RegisterPropertyHelper(@TRegistryIniFileRegIniFile_R,nil,'RegIniFile');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TRegIniFile(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TRegIniFile) do
begin
RegisterConstructor(@TRegIniFileCreate_P, 'Create');
RegisterConstructor(@TRegIniFileCreateA_P, 'CreateA');
RegisterMethod(@TRegIniFile.ReadString, 'ReadString');
RegisterMethod(@TRegIniFile.ReadInteger, 'ReadInteger');
RegisterMethod(@TRegIniFile.WriteInteger, 'WriteInteger');
RegisterMethod(@TRegIniFile.WriteString, 'WriteString');
RegisterMethod(@TRegIniFile.ReadBool, 'ReadBool');
RegisterMethod(@TRegIniFile.WriteBool, 'WriteBool');
RegisterMethod(@TRegIniFile.ReadSection, 'ReadSection');
RegisterMethod(@TRegIniFile.ReadSections, 'ReadSections');
RegisterMethod(@TRegIniFile.ReadSectionValues, 'ReadSectionValues');
RegisterMethod(@TRegIniFile.EraseSection, 'EraseSection');
RegisterMethod(@TRegIniFile.DeleteKey, 'DeleteKey');
RegisterPropertyHelper(@TRegIniFileFileName_R,nil,'FileName');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TRegistry(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TRegistry) do
begin
RegisterConstructor(@TRegistryCreateA_P, 'CreateA');
RegisterConstructor(@TRegistryCreate_P, 'Create');
RegisterMethod(@TRegistry.CloseKey, 'CloseKey');
RegisterMethod(@TRegistry.CreateKey, 'CreateKey');
RegisterMethod(@TRegistry.DeleteKey, 'DeleteKey');
RegisterMethod(@TRegistry.DeleteValue, 'DeleteValue');
RegisterMethod(@TRegistry.GetDataInfo, 'GetDataInfo');
RegisterMethod(@TRegistry.GetDataSize, 'GetDataSize');
RegisterMethod(@TRegistry.GetDataType, 'GetDataType');
RegisterMethod(@TRegistry.GetKeyInfo, 'GetKeyInfo');
RegisterMethod(@TRegistry.GetKeyNames, 'GetKeyNames');
RegisterMethod(@TRegistry.GetValueNames, 'GetValueNames');
RegisterMethod(@TRegistry.HasSubKeys, 'HasSubKeys');
RegisterMethod(@TRegistry.KeyExists, 'KeyExists');
RegisterMethod(@TRegistry.LoadKey, 'LoadKey');
RegisterMethod(@TRegistry.MoveKey, 'MoveKey');
RegisterMethod(@TRegistry.OpenKey, 'OpenKey');
RegisterMethod(@TRegistry.OpenKeyReadOnly, 'OpenKeyReadOnly');
RegisterMethod(@TRegistry.ReadCurrency, 'ReadCurrency');
RegisterMethod(@TRegistry.ReadBool, 'ReadBool');
RegisterMethod(@TRegistry.ReadDate, 'ReadDate');
RegisterMethod(@TRegistry.ReadDateTime, 'ReadDateTime');
RegisterMethod(@TRegistry.ReadFloat, 'ReadFloat');
RegisterMethod(@TRegistry.ReadInteger, 'ReadInteger');
RegisterMethod(@TRegistry.ReadString, 'ReadString');
RegisterMethod(@TRegistry.ReadTime, 'ReadTime');
RegisterMethod(@TRegistry.RegistryConnect, 'RegistryConnect');
RegisterMethod(@TRegistry.RenameValue, 'RenameValue');
RegisterMethod(@TRegistry.ReplaceKey, 'ReplaceKey');
RegisterMethod(@TRegistry.RestoreKey, 'RestoreKey');
RegisterMethod(@TRegistry.SaveKey, 'SaveKey');
RegisterMethod(@TRegistry.UnLoadKey, 'UnLoadKey');
RegisterMethod(@TRegistry.ValueExists, 'ValueExists');
RegisterMethod(@TRegistry.WriteCurrency, 'WriteCurrency');
RegisterMethod(@TRegistry.WriteBool, 'WriteBool');
RegisterMethod(@TRegistry.WriteDate, 'WriteDate');
RegisterMethod(@TRegistry.WriteDateTime, 'WriteDateTime');
RegisterMethod(@TRegistry.WriteFloat, 'WriteFloat');
RegisterMethod(@TRegistry.WriteInteger, 'WriteInteger');
RegisterMethod(@TRegistry.WriteString, 'WriteString');
RegisterMethod(@TRegistry.WriteExpandString, 'WriteExpandString');
RegisterMethod(@TRegistry.WriteTime, 'WriteTime');
RegisterPropertyHelper(@TRegistryCurrentKey_R,nil,'CurrentKey');
RegisterPropertyHelper(@TRegistryCurrentPath_R,nil,'CurrentPath');
RegisterPropertyHelper(@TRegistryLazyWrite_R,@TRegistryLazyWrite_W,'LazyWrite');
RegisterPropertyHelper(@TRegistryRootKey_R,@TRegistryRootKey_W,'RootKey');
RegisterPropertyHelper(@TRegistryAccess_R,@TRegistryAccess_W,'Access');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_Registry(CL: TPSRuntimeClassImporter);
begin
with CL.Add(ERegistryException) do
RIRegister_TRegistry(CL);
RIRegister_TRegIniFile(CL);
RIRegister_TRegistryIniFile(CL);
end;
(* === compile-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure SIRegister_TMemIniFile(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCustomIniFile', 'TMemIniFile') do
with CL.AddClassN(CL.FindClass('TCustomIniFile'),'TMemIniFile') do
begin
RegisterMethod('Constructor Create( const FileName : string)');
RegisterMethod('Procedure Clear');
RegisterMethod('Procedure GetStrings( List : TStrings)');
RegisterMethod('Procedure Rename( const FileName : string; Reload : Boolean)');
RegisterMethod('Procedure SetStrings( List : TStrings)');
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TIniFile(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TCustomIniFile', 'TIniFile') do
with CL.AddClassN(CL.FindClass('TCustomIniFile'),'TIniFile') do
begin
RegisterMethod('Function ReadString( const Section, Ident, Default : string) : string');
RegisterMethod('Procedure WriteString( const Section, Ident, Value : String)');
RegisterMethod('Procedure ReadSection( const Section : string; Strings : TStrings)');
RegisterMethod('Procedure ReadSections( Strings : TStrings)');
RegisterMethod('Procedure ReadSectionValues( const Section : string; Strings : TStrings)');
RegisterMethod('Procedure EraseSection( const Section : string)');
RegisterMethod('Procedure DeleteKey( const Section, Ident : String)');
RegisterMethod('Procedure UpdateFile');
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_TCustomIniFile(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TObject', 'TCustomIniFile') do
with CL.AddClassN(CL.FindClass('TObject'),'TCustomIniFile') do
begin
RegisterMethod('Constructor Create( const FileName : string)');
RegisterMethod('Function SectionExists( const Section : string) : Boolean');
// RegisterMethod('Function ReadString( const Section, Ident, Default : string) : string');
// RegisterMethod('Procedure WriteString( const Section, Ident, Value : String)');
RegisterMethod('Function ReadInteger( const Section, Ident : string; Default : Longint) : Longint');
RegisterMethod('Procedure WriteInteger( const Section, Ident : string; Value : Longint)');
RegisterMethod('Function ReadBool( const Section, Ident : string; Default : Boolean) : Boolean');
RegisterMethod('Procedure WriteBool( const Section, Ident : string; Value : Boolean)');
RegisterMethod('Function ReadDate( const Section, Name : string; Default : TDateTime) : TDateTime');
RegisterMethod('Function ReadDateTime( const Section, Name : string; Default : TDateTime) : TDateTime');
RegisterMethod('Function ReadFloat( const Section, Name : string; Default : Double) : Double');
RegisterMethod('Function ReadTime( const Section, Name : string; Default : TDateTime) : TDateTime');
RegisterMethod('Procedure WriteDate( const Section, Name : string; Value : TDateTime)');
RegisterMethod('Procedure WriteDateTime( const Section, Name : string; Value : TDateTime)');
RegisterMethod('Procedure WriteFloat( const Section, Name : string; Value : Double)');
RegisterMethod('Procedure WriteTime( const Section, Name : string; Value : TDateTime)');
// RegisterMethod('Procedure ReadSection( const Section : string; Strings : TStrings)');
// RegisterMethod('Procedure ReadSections( Strings : TStrings)');
// RegisterMethod('Procedure ReadSectionValues( const Section : string; Strings : TStrings)');
// RegisterMethod('Procedure EraseSection( const Section : string)');
// RegisterMethod('Procedure DeleteKey( const Section, Ident : String)');
// RegisterMethod('Procedure UpdateFile');
RegisterMethod('Function ValueExists( const Section, Ident : string) : Boolean');
RegisterProperty('FileName', 'string', iptr);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_IniFiles(CL: TPSPascalCompiler);
begin
SIRegister_TCustomIniFile(CL);
SIRegister_TIniFile(CL);
SIRegister_TMemIniFile(CL);
end;
(* === run-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure TCustomIniFileFileName_R(Self: TCustomIniFile; var T: string);
begin T := Self.FileName; end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TMemIniFile(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TMemIniFile) do
begin
RegisterConstructor(@TMemIniFile.Create, 'Create');
RegisterMethod(@TMemIniFile.Clear, 'Clear');
RegisterMethod(@TMemIniFile.GetStrings, 'GetStrings');
RegisterMethod(@TMemIniFile.Rename, 'Rename');
RegisterMethod(@TMemIniFile.SetStrings, 'SetStrings');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TIniFile(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TIniFile) do
begin
RegisterMethod(@TIniFile.ReadString, 'ReadString');
RegisterMethod(@TIniFile.WriteString, 'WriteString');
RegisterMethod(@TIniFile.ReadSection, 'ReadSection');
RegisterMethod(@TIniFile.ReadSections, 'ReadSections');
RegisterMethod(@TIniFile.ReadSectionValues, 'ReadSectionValues');
RegisterMethod(@TIniFile.EraseSection, 'EraseSection');
RegisterMethod(@TIniFile.DeleteKey, 'DeleteKey');
RegisterMethod(@TIniFile.UpdateFile, 'UpdateFile');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TCustomIniFile(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TCustomIniFile) do
begin
RegisterConstructor(@TCustomIniFile.Create, 'Create');
RegisterMethod(@TCustomIniFile.SectionExists, 'SectionExists');
// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadString, 'ReadString');
// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.WriteString, 'WriteString');
RegisterVirtualMethod(@TCustomIniFile.ReadInteger, 'ReadInteger');
RegisterVirtualMethod(@TCustomIniFile.WriteInteger, 'WriteInteger');
RegisterVirtualMethod(@TCustomIniFile.ReadBool, 'ReadBool');
RegisterVirtualMethod(@TCustomIniFile.WriteBool, 'WriteBool');
RegisterVirtualMethod(@TCustomIniFile.ReadDate, 'ReadDate');
RegisterVirtualMethod(@TCustomIniFile.ReadDateTime, 'ReadDateTime');
RegisterVirtualMethod(@TCustomIniFile.ReadFloat, 'ReadFloat');
RegisterVirtualMethod(@TCustomIniFile.ReadTime, 'ReadTime');
RegisterVirtualMethod(@TCustomIniFile.WriteDate, 'WriteDate');
RegisterVirtualMethod(@TCustomIniFile.WriteDateTime, 'WriteDateTime');
RegisterVirtualMethod(@TCustomIniFile.WriteFloat, 'WriteFloat');
RegisterVirtualMethod(@TCustomIniFile.WriteTime, 'WriteTime');
// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadSection, 'ReadSection');
// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadSections, 'ReadSections');
// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadSectionValues, 'ReadSectionValues');
// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.EraseSection, 'EraseSection');
// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.DeleteKey, 'DeleteKey');
// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.UpdateFile, 'UpdateFile');
RegisterMethod(@TCustomIniFile.ValueExists, 'ValueExists');
RegisterPropertyHelper(@TCustomIniFileFileName_R,nil,'FileName');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_IniFiles(CL: TPSRuntimeClassImporter);
begin
RIRegister_TCustomIniFile(CL);
RIRegister_TIniFile(CL);
RIRegister_TMemIniFile(CL);
end;
{ TPSImport_Registry }
(*----------------------------------------------------------------------------*)
procedure TPSImport_Registry.CompOnUses(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Registry.ExecOnUses(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Registry.CompileImport1(CompExec: TPSScript);
begin
SIRegister_Registry(CompExec.Comp);
SIRegister_IniFiles(CompExec.Comp);
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Registry.CompileImport2(CompExec: TPSScript);
begin
{ nothing }
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Registry.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
RIRegister_Registry(ri);
RIRegister_IniFiles(ri);
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Registry.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
{ nothing }
end;
end.

800
Units/PascalScript/uPSPreProcessor.pas Normal file
View File

@ -0,0 +1,800 @@
unit uPSPreProcessor;
{$I PascalScript.inc}
interface
uses
Classes, SysUtils, uPSCompiler, uPSUtils;
type
EPSPreProcessor = class(Exception); //- jgv
TPSPreProcessor = class;
TPSPascalPreProcessorParser = class;
TPSOnNeedFile = function (Sender: TPSPreProcessor; const callingfilename: tbtstring; var FileName, Output: tbtstring): Boolean;
TPSOnProcessDirective = procedure (
Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser;
const Active: Boolean;
const DirectiveName, DirectiveParam: tbtString;
Var Continue: Boolean); //- jgv - application set continue to false to stop the normal directive processing
TPSLineInfo = class(TObject)
private
function GetLineOffset(I: Integer): Cardinal;
function GetLineOffsetCount: Longint;
protected
FEndPos: Cardinal;
FStartPos: Cardinal;
FFileName: tbtstring;
FLineOffsets: TIfList;
public
property FileName: tbtstring read FFileName;
property StartPos: Cardinal read FStartPos;
property EndPos: Cardinal read FEndPos;
property LineOffsetCount: Longint read GetLineOffsetCount;
property LineOffset[I: Longint]: Cardinal read GetLineOffset;
constructor Create;
destructor Destroy; override;
end;
TPSLineInfoResults = record
Row,
Col,
Pos: Cardinal;
Name: tbtstring;
end;
TPSLineInfoList = class(TObject)
private
FItems: TIfList;
FCurrent: Longint;
function GetCount: Longint;
function GetItem(I: Integer): TPSLineInfo;
protected
function Add: TPSLineInfo;
public
property Count: Longint read GetCount;
property Items[I: Longint]: TPSLineInfo read GetItem; default;
procedure Clear;
function GetLineInfo(const ModuleName: tbtstring; Pos: Cardinal; var Res: TPSLineInfoResults): Boolean;
property Current: Longint read FCurrent write FCurrent;
constructor Create;
destructor Destroy; override;
end;
TPSDefineStates = class;
TPSPreProcessor = class(TObject)
private
FID: Pointer;
FCurrentDefines, FDefines: TStringList;
FCurrentLineInfo: TPSLineInfoList;
FOnNeedFile: TPSOnNeedFile;
FAddedPosition: Cardinal;
FDefineState: TPSDefineStates;
FMaxLevel: Longint;
FMainFileName: tbtstring;
FMainFile: tbtstring;
FOnProcessDirective: TPSOnProcessDirective;
FOnProcessUnknowDirective: TPSOnProcessDirective;
procedure ParserNewLine(Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal);
procedure IntPreProcess(Level: Integer; const OrgFileName: tbtstring; FileName: tbtstring; Dest: TStream);
protected
procedure doAddStdPredefines; virtual; // jgv
public
{The maximum number of levels deep the parser will go, defaults to 20}
property MaxLevel: Longint read FMaxLevel write FMaxLevel;
property CurrentLineInfo: TPSLineInfoList read FCurrentLineInfo;
property OnNeedFile: TPSOnNeedFile read FOnNeedFile write FOnNeedFile;
property Defines: TStringList read FDefines write FDefines;
property MainFile: tbtstring read FMainFile write FMainFile;
property MainFileName: tbtstring read FMainFileName write FMainFileName;
property ID: Pointer read FID write FID;
procedure AdjustMessages(Comp: TPSPascalCompiler);
procedure AdjustMessage(Msg: TPSPascalCompilerMessage); //-jgv
procedure PreProcess(const Filename: tbtstring; var Output: tbtstring);
procedure Clear;
constructor Create;
destructor Destroy; override;
property OnProcessDirective: TPSOnProcessDirective read fOnProcessDirective write fOnProcessDirective;
property OnProcessUnknowDirective: TPSOnProcessDirective read fOnProcessUnknowDirective write fOnProcessUnknowDirective;
end;
TPSPascalPreProcessorType = (ptEOF, ptOther, ptDefine);
TPSOnNewLine = procedure (Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal) of object;
TPSPascalPreProcessorParser = class(TObject)
private
FData: tbtstring;
FText: PAnsichar;
FToken: tbtstring;
FTokenId: TPSPascalPreProcessorType;
FLastEnterPos, FLen, FRow, FCol, FPos: Cardinal;
FOnNewLine: TPSOnNewLine;
public
procedure SetText(const dta: tbtstring);
procedure Next;
property Token: tbtstring read FToken;
property TokenId: TPSPascalPreProcessorType read FTokenId;
property Row: Cardinal read FRow;
property Col: Cardinal read FCol;
property Pos: Cardinal read FPos;
property OnNewLine: TPSOnNewLine read FOnNewLine write FOnNewLine;
end;
TPSDefineState = class(TObject)
private
FInElse: Boolean;
FDoWrite: Boolean;
public
property InElse: Boolean read FInElse write FInElse;
property DoWrite: Boolean read FDoWrite write FDoWrite;
end;
TPSDefineStates = class(TObject)
private
FItems: TIfList;
function GetCount: Longint;
function GetItem(I: Integer): TPSDefineState;
function GetWrite: Boolean;
function GetPrevWrite: Boolean; //JeromeWelsh - nesting fix
public
property Count: Longint read GetCount;
property Item[I: Longint]: TPSDefineState read GetItem; default;
function Add: TPSDefineState;
procedure Delete(I: Longint);
constructor Create;
destructor Destroy; override;
procedure Clear;
property DoWrite: Boolean read GetWrite;
property DoPrevWrite: Boolean read GetPrevWrite; //JeromeWelsh - nesting fix
end;
implementation
{$IFDEF DELPHI3UP }
resourceString
{$ELSE }
const
{$ENDIF }
RPS_TooManyNestedInclude = 'Too many nested include files while processing ''%s'' from ''%s''';
RPS_IncludeNotFound = 'Unable to find file ''%s'' used from ''%s''';
RPS_DefineTooManyParameters = 'Too many parameters at %d:%d';
RPS_NoIfdefForEndif = 'No IFDEF for ENDIF at %d:%d';
RPS_NoIfdefForElse = 'No IFDEF for ELSE at %d:%d';
RPS_ElseTwice = 'Can''t use ELSE twice at %d:%d';
RPS_UnknownCompilerDirective = 'Unknown compiler directives at %d:%d';
RPs_DefineNotClosed = 'Define not closed';
{ TPSLineInfoList }
function TPSLineInfoList.Add: TPSLineInfo;
begin
Result := TPSLineInfo.Create;
FItems.Add(Result);
end;
procedure TPSLineInfoList.Clear;
var
i: Longint;
begin
for i := FItems.count -1 downto 0 do
TPSLineInfo(FItems[i]).Free;
FItems.Clear;
end;
constructor TPSLineInfoList.Create;
begin
inherited Create;
FItems := TIfList.Create;
end;
destructor TPSLineInfoList.Destroy;
begin
Clear;
FItems.Free;
inherited Destroy;
end;
function TPSLineInfoList.GetCount: Longint;
begin
Result := FItems.Count;
end;
function TPSLineInfoList.GetItem(I: Integer): TPSLineInfo;
begin
Result := TPSLineInfo(FItems[i]);
end;
function TPSLineInfoList.GetLineInfo(const ModuleName: tbtstring; Pos: Cardinal; var Res: TPSLineInfoResults): Boolean;
var
i,j: Longint;
linepos: Cardinal;
Item: TPSLineInfo;
lModuleName: tbtstring;
begin
lModuleName := FastUpperCase(ModuleName);
for i := FItems.Count -1 downto 0 do
begin
Item := FItems[i];
if (Pos >= Item.StartPos) and (Pos < Item.EndPos) and
(lModuleName = '') or (lModuleName = Item.FileName) then
begin
Res.Name := Item.FileName;
Pos := Pos - Item.StartPos;
Res.Pos := Pos;
Res.Col := 1;
Res.Row := 1;
LinePos := 0;
for j := 0 to Item.LineOffsetCount -1 do
begin
if Pos >= Item.LineOffset[j] then
begin
linepos := Item.LineOffset[j];
end else
begin
Res.Row := j; // j -1, but line counting starts at 1
Res.Col := pos - linepos + 1;
Break;
end;
end;
Result := True;
exit;
end;
end;
Result := False;
end;
{ TPSLineInfo }
constructor TPSLineInfo.Create;
begin
inherited Create;
FLineOffsets := TIfList.Create;
end;
destructor TPSLineInfo.Destroy;
begin
FLineOffsets.Free;
inherited Destroy;
end;
function TPSLineInfo.GetLineOffset(I: Integer): Cardinal;
begin
Result := Longint(FLineOffsets[I]);
end;
function TPSLineInfo.GetLineOffsetCount: Longint;
begin
result := FLineOffsets.Count;
end;
{ TPSPascalPreProcessorParser }
procedure TPSPascalPreProcessorParser.Next;
var
ci: Cardinal;
begin
FPos := FPos + FLen;
case FText[FPos] of
#0:
begin
FLen := 0;
FTokenId := ptEof;
end;
'''':
begin
ci := FPos;
while (FText[ci] <> #0) do
begin
Inc(ci);
while FText[ci] = '''' do
begin
if FText[ci+1] <> '''' then Break;
inc(ci);
inc(ci);
end;
if FText[ci] = '''' then Break;
if FText[ci] = #13 then
begin
inc(FRow);
if FText[ci] = #10 then
inc(ci);
FLastEnterPos := ci -1;
if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
end else if FText[ci] = #10 then
begin
inc(FRow);
FLastEnterPos := ci -1;
if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
end;
end;
FLen := ci - FPos + 1;
FTokenId := ptOther;
end;
'(':
begin
if FText[FPos + 1] = '*' then
begin
ci := FPos + 1;
while (FText[ci] <> #0) do begin
if (FText[ci] = '*') and (FText[ci + 1] = ')') then
Break;
if FText[ci] = #13 then
begin
inc(FRow);
if FText[ci+1] = #10 then
inc(ci);
FLastEnterPos := ci -1;
if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
end else if FText[ci] = #10 then
begin
inc(FRow);
FLastEnterPos := ci -1;
if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
end;
Inc(ci);
end;
FTokenId := ptOther;
if (FText[ci] <> #0) then
Inc(ci, 2);
FLen := ci - FPos;
end
else
begin
FTokenId := ptOther;
FLen := 1;
end;
end;
'/':
begin
if FText[FPos + 1] = '/' then
begin
ci := FPos + 1;
while (FText[ci] <> #0) and (FText[ci] <> #13) and
(FText[ci] <> #10) do begin
Inc(ci);
end;
FTokenId := ptOther;
FLen := ci - FPos;
end else
begin
FTokenId := ptOther;
FLen := 1;
end;
end;
'{':
begin
ci := FPos + 1;
while (FText[ci] <> #0) and (FText[ci] <> '}') do begin
if FText[ci] = #13 then
begin
inc(FRow);
if FText[ci+1] = #10 then
inc(ci);
FLastEnterPos := ci - 1;
if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
end else if FText[ci] = #10 then
begin
inc(FRow);
FLastEnterPos := ci - 1;
if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
end;
Inc(ci);
end;
if (FText[FPos + 1] = '$') or (FText[FPos + 1] = '.') then
FTokenId := ptDefine
else
FTokenId := ptOther;
FLen := ci - FPos + 1;
end;
else
begin
ci := FPos + 1;
while not (FText[ci] in [#0,'{', '(', '''', '/']) do
begin
if FText[ci] = #13 then
begin
inc(FRow);
if FText[ci+1] = #10 then
inc(ci);
FLastEnterPos := ci - 1;
if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
end else if FText[ci] = #10 then
begin
inc(FRow);
FLastEnterPos := ci -1 ;
if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
end;
Inc(Ci);
end;
FTokenId := ptOther;
FLen := ci - FPos;
end;
end;
FCol := FPos - FLastEnterPos + 1;
FToken := Copy(FData, FPos +1, FLen);
end;
procedure TPSPascalPreProcessorParser.SetText(const dta: tbtstring);
begin
FData := dta;
FText := pAnsichar(FData);
FLen := 0;
FPos := 0;
FCol := 1;
FLastEnterPos := 0;
FRow := 1;
if @FOnNewLine <> nil then FOnNewLine(Self, 1, 1, 0);
Next;
end;
{ TPSPreProcessor }
procedure TPSPreProcessor.AdjustMessage(Msg: TPSPascalCompilerMessage);
var
Res: TPSLineInfoResults;
begin
if CurrentLineInfo.GetLineInfo(Msg.ModuleName, Msg.Pos, Res) then
begin
Msg.SetCustomPos(res.Pos, Res.Row, Res.Col);
Msg.ModuleName := Res.Name;
end;
end;
procedure TPSPreProcessor.AdjustMessages(Comp: TPSPascalCompiler);
var
i: Longint;
begin
for i := 0 to Comp.MsgCount -1 do
AdjustMessage (Comp.Msg[i]);
end;
procedure TPSPreProcessor.Clear;
begin
FDefineState.Clear;
FDefines.Clear;
FCurrentDefines.Clear;
FCurrentLineInfo.Clear;
FMainFile := '';
end;
constructor TPSPreProcessor.Create;
begin
inherited Create;
FDefines := TStringList.Create;
FCurrentLineInfo := TPSLineInfoList.Create;
FCurrentDefines := TStringList.Create;
FDefines.Duplicates := dupIgnore;
FCurrentDefines.Duplicates := dupIgnore;
FDefineState := TPSDefineStates.Create;
FMaxLevel := 20;
doAddStdPredefines;
end;
destructor TPSPreProcessor.Destroy;
begin
FDefineState.Free;
FCurrentDefines.Free;
FDefines.Free;
FCurrentLineInfo.Free;
inherited Destroy;
end;
procedure TPSPreProcessor.doAddStdPredefines;
begin
//--- 20050708_jgv
FCurrentDefines.Add (Format ('VER%d', [PSCurrentBuildNo]));
{$IFDEF CPU386 }
FCurrentDefines.Add ('CPU386');
{$ENDIF }
{$IFDEF MSWINDOWS }
FCurrentDefines.Add ('MSWINDOWS');
FCurrentDefines.Add ('WIN32');
{$ENDIF }
{$IFDEF LINUX }
FCurrentDefines.Add ('LINUX');
{$ENDIF }
end;
procedure TPSPreProcessor.IntPreProcess(Level: Integer; const OrgFileName: tbtstring; FileName: tbtstring; Dest: TStream);
var
Parser: TPSPascalPreProcessorParser;
dta: tbtstring;
item: TPSLineInfo;
s, name: tbtstring;
current, i: Longint;
ds: TPSDefineState;
AppContinue: Boolean;
begin
if Level > MaxLevel then raise EPSPreProcessor.CreateFmt(RPS_TooManyNestedInclude, [FileName, OrgFileName]);
Parser := TPSPascalPreProcessorParser.Create;
try
Parser.OnNewLine := ParserNewLine;
if FileName = MainFileName then
begin
dta := MainFile;
end else
if (@OnNeedFile = nil) or (not OnNeedFile(Self, OrgFileName, FileName, dta)) then
raise EPSPreProcessor.CreateFmt(RPS_IncludeNotFound, [FileName, OrgFileName]);
Item := FCurrentLineInfo.Add;
current := FCurrentLineInfo.Count -1;
FCurrentLineInfo.Current := current;
Item.FStartPos := Dest.Position;
Item.FFileName := FileName;
Parser.SetText(dta);
while Parser.TokenId <> ptEOF do
begin
s := Parser.Token;
if Parser.TokenId = ptDefine then
begin
Delete(s,1,2); // delete the {$
Delete(s,length(s), 1); // delete the }
//-- 20050707_jgv trim right
i := length (s);
while (i > 0) and (s[i] = ' ') do begin
Delete (s, i, 1);
Dec (i);
end;
//-- end_jgv
if pos(tbtChar(' '), s) = 0 then
begin
name := uppercase(s);
s := '';
end else
begin
Name := uppercase(copy(s,1,pos(' ', s)-1));
Delete(s, 1, pos(' ', s));
end;
//-- 20050707_jgv - ask the application
AppContinue := True;
If @OnProcessDirective <> Nil then OnProcessDirective (Self, Parser, FDefineState.DoWrite, name, s, AppContinue);
If AppContinue then
//-- end jgv
if (Name = 'I') or (Name = 'INCLUDE') or (Name = '.INCLUDE') then
begin
if FDefineState.DoWrite then
begin
FAddedPosition := 0;
IntPreProcess(Level +1, FileName, s, Dest);
FCurrentLineInfo.Current := current;
FAddedPosition := Cardinal(Dest.Position) - Item.StartPos - Parser.Pos;
end;
end else if (Name = 'DEFINE') then
begin
if FDefineState.DoWrite then
begin
if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
FCurrentDefines.Add(Uppercase(S));
end;
end else if (Name = 'UNDEF') then
begin
if FDefineState.DoWrite then
begin
if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
i := FCurrentDefines.IndexOf(Uppercase(s));
if i <> -1 then
FCurrentDefines.Delete(i);
end;
end else if (Name = 'IFDEF') then
begin
if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
//JeromeWelsh - nesting fix
if (FDefineState.DoWrite and (FCurrentDefines.IndexOf(Uppercase(s)) <> -1)) then
FDefineState.Add.DoWrite := True
else
FDefineState.Add.DoWrite := False;
end else if (Name = 'IFNDEF') then
begin
if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
//JeromeWelsh - nesting fix
if (FCurrentDefines.IndexOf(Uppercase(s)) = -1) and FDefineState.DoWrite then
FDefineState.Add.DoWrite := True
else
FDefineState.Add.DoWrite := False;
end else if (Name = 'ENDIF') then
begin
//- jgv remove - borland use it (sysutils.pas)
//- if s <> '' then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
if FDefineState.Count = 0 then
raise EPSPreProcessor.CreateFmt(RPS_NoIfdefForEndif, [Parser.Row, Parser.Col]);
FDefineState.Delete(FDefineState.Count -1); // remove define from list
end else if (Name = 'ELSE') then
begin
if s<> '' then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
if FDefineState.Count = 0 then
raise EPSPreProcessor.CreateFmt(RPS_NoIfdefForElse, [Parser.Row, Parser.Col]);
ds := FDefineState[FDefineState.Count -1];
if ds.InElse then
raise EPSPreProcessor.CreateFmt(RPS_ElseTwice, [Parser.Row, Parser.Col]);
ds.FInElse := True;
//JeromeWelsh - nesting fix
ds.DoWrite := not ds.DoWrite and FDefineState.DoPrevWrite;
end
//-- 20050710_jgv custom application error process
else if Parser.Token[2] <> '.' then begin
If @OnProcessUnknowDirective <> Nil then begin
OnProcessUnknowDirective (Self, Parser, FDefineState.DoWrite, name, s, AppContinue);
end;
If AppContinue then
//-- end jgv
raise EPSPreProcessor.CreateFmt(RPS_UnknownCompilerDirective, [Parser.Row, Parser.Col]);
end;
end;
if (not FDefineState.DoWrite) or (Parser.TokenId = ptDefine) then
begin
SetLength(s, Length(Parser.Token));
for i := length(s) downto 1 do
s[i] := #32; // space
end;
Dest.Write(s[1], length(s));
Parser.Next;
end;
Item.FEndPos := Dest.Position;
finally
Parser.Free;
end;
end;
procedure TPSPreProcessor.ParserNewLine(Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal);
begin
if FCurrentLineInfo.Current >= FCurrentLineInfo.Count then exit; //errr ???
with FCurrentLineInfo.Items[FCurrentLineInfo.Current] do
begin
Pos := Pos + FAddedPosition;
FLineOffsets.Add(Pointer(Pos));
end;
end;
procedure TPSPreProcessor.PreProcess(const Filename: tbtstring; var Output: tbtstring);
var
Stream: TMemoryStream;
begin
FAddedPosition := 0;
FCurrentDefines.Assign(FDefines);
Stream := TMemoryStream.Create;
try
IntPreProcess(0, '', FileName, Stream);
Stream.Position := 0;
SetLength(Output, Stream.Size);
Stream.Read(Output[1], Length(Output));
finally
Stream.Free;
end;
if FDefineState.Count <> 0 then
raise EPSPreProcessor.Create(RPs_DefineNotClosed);
end;
{ TPSDefineStates }
function TPSDefineStates.Add: TPSDefineState;
begin
Result := TPSDefineState.Create;
FItems.Add(Result);
end;
procedure TPSDefineStates.Clear;
var
i: Longint;
begin
for i := Longint(FItems.Count) -1 downto 0 do
TPSDefineState(FItems[i]).Free;
FItems.Clear;
end;
constructor TPSDefineStates.Create;
begin
inherited Create;
FItems := TIfList.Create;
end;
procedure TPSDefineStates.Delete(I: Integer);
begin
TPSDefineState(FItems[i]).Free;
FItems.Delete(i);
end;
destructor TPSDefineStates.Destroy;
var
i: Longint;
begin
for i := Longint(FItems.Count) -1 downto 0 do
TPSDefineState(FItems[i]).Free;
FItems.Free;
inherited Destroy;
end;
function TPSDefineStates.GetCount: Longint;
begin
Result := FItems.Count;
end;
function TPSDefineStates.GetItem(I: Integer): TPSDefineState;
begin
Result := FItems[i];
end;
function TPSDefineStates.GetWrite: Boolean;
begin
if FItems.Count = 0 then
result := true
else Result := TPSDefineState(FItems[FItems.Count -1]).DoWrite;
end;
//JeromeWelsh - nesting fix
function TPSDefineStates.GetPrevWrite: Boolean;
begin
if FItems.Count < 2 then
result := true
else Result := TPSDefineState(FItems[FItems.Count -2]).DoWrite;
end;
end.

2094
Units/PascalScript/uPSR_DB.pas Normal file
View File

File diff suppressed because it is too large Load Diff

38
Units/PascalScript/uPSR_buttons.pas Normal file
View File

@ -0,0 +1,38 @@
unit uPSR_buttons;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegisterTSPEEDBUTTON(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTBITBTN(Cl: TPSRuntimeClassImporter);
procedure RIRegister_Buttons(Cl: TPSRuntimeClassImporter);
implementation
uses
Classes{$IFDEF CLX}, QControls, QButtons{$ELSE}, Controls, Buttons{$ENDIF};
procedure RIRegisterTSPEEDBUTTON(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TSPEEDBUTTON);
end;
procedure RIRegisterTBITBTN(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TBITBTN);
end;
procedure RIRegister_Buttons(Cl: TPSRuntimeClassImporter);
begin
RIRegisterTSPEEDBUTTON(cl);
RIRegisterTBITBTN(cl);
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

383
Units/PascalScript/uPSR_classes.pas Normal file
View File

@ -0,0 +1,383 @@
unit uPSR_classes;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegisterTStrings(cl: TPSRuntimeClassImporter; Streams: Boolean);
procedure RIRegisterTStringList(cl: TPSRuntimeClassImporter);
{$IFNDEF PS_MINIVCL}
procedure RIRegisterTBITS(Cl: TPSRuntimeClassImporter);
{$ENDIF}
procedure RIRegisterTSTREAM(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTHANDLESTREAM(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTFILESTREAM(Cl: TPSRuntimeClassImporter);
{$IFNDEF PS_MINIVCL}
procedure RIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTRESOURCESTREAM(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTPARSER(Cl: TPSRuntimeClassImporter);
{$IFDEF DELPHI3UP}
procedure RIRegisterTOWNEDCOLLECTION(Cl: TPSRuntimeClassImporter);
{$ENDIF}
procedure RIRegisterTCOLLECTION(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCOLLECTIONITEM(Cl: TPSRuntimeClassImporter);
{$ENDIF}
procedure RIRegister_Classes(Cl: TPSRuntimeClassImporter; Streams: Boolean{$IFDEF D4PLUS}=True{$ENDIF});
implementation
uses
Classes;
procedure TStringsCountR(Self: TStrings; var T: Longint); begin T := Self.Count; end;
procedure TStringsTextR(Self: TStrings; var T: string); begin T := Self.Text; end;
procedure TStringsTextW(Self: TStrings; T: string); begin Self.Text:= T; end;
procedure TStringsCommaTextR(Self: TStrings; var T: string); begin T := Self.CommaText; end;
procedure TStringsCommaTextW(Self: TStrings; T: string); begin Self.CommaText:= T; end;
procedure TStringsObjectsR(Self: TStrings; var T: TObject; I: Longint);
begin
T := Self.Objects[I];
end;
procedure TStringsObjectsW(Self: TStrings; const T: TObject; I: Longint);
begin
Self.Objects[I]:= T;
end;
procedure TStringsStringsR(Self: TStrings; var T: string; I: Longint);
begin
T := Self.Strings[I];
end;
procedure TStringsStringsW(Self: TStrings; const T: string; I: Longint);
begin
Self.Strings[I]:= T;
end;
procedure TStringsNamesR(Self: TStrings; var T: string; I: Longint);
begin
T := Self.Names[I];
end;
procedure TStringsValuesR(Self: TStrings; var T: string; const I: string);
begin
T := Self.Values[I];
end;
procedure TStringsValuesW(Self: TStrings; Const T, I: String);
begin
Self.Values[I]:= T;
end;
procedure RIRegisterTStrings(cl: TPSRuntimeClassImporter; Streams: Boolean); // requires TPersistent
begin
with Cl.Add(TStrings) do
begin
RegisterVirtualMethod(@TStrings.Add, 'ADD');
RegisterMethod(@TStrings.Append, 'APPEND');
RegisterVirtualMethod(@TStrings.AddStrings, 'ADDSTRINGS');
RegisterVirtualAbstractMethod(TStringList, @TStringList.Clear, 'CLEAR');
RegisterVirtualAbstractMethod(TStringList, @TStringList.Delete, 'DELETE');
RegisterVirtualMethod(@TStrings.IndexOf, 'INDEXOF');
RegisterVirtualAbstractMethod(TStringList, @TStringList.Insert, 'INSERT');
RegisterPropertyHelper(@TStringsCountR, nil, 'COUNT');
RegisterPropertyHelper(@TStringsTextR, @TStringsTextW, 'TEXT');
RegisterPropertyHelper(@TStringsCommaTextR, @TStringsCommatextW, 'COMMATEXT');
if Streams then
begin
RegisterVirtualMethod(@TStrings.LoadFromFile, 'LOADFROMFILE');
RegisterVirtualMethod(@TStrings.SaveToFile, 'SAVETOFILE');
end;
RegisterPropertyHelper(@TStringsStringsR, @TStringsStringsW, 'STRINGS');
RegisterPropertyHelper(@TStringsObjectsR, @TStringsObjectsW, 'OBJECTS');
{$IFNDEF PS_MINIVCL}
RegisterMethod(@TStrings.BeginUpdate, 'BEGINUPDATE');
RegisterMethod(@TStrings.EndUpdate, 'ENDUPDATE');
RegisterMethod(@TStrings.Equals, 'EQUALS');
RegisterVirtualMethod(@TStrings.Exchange, 'EXCHANGE');
RegisterMethod(@TStrings.IndexOfName, 'INDEXOFNAME');
if Streams then
RegisterVirtualMethod(@TStrings.LoadFromStream, 'LOADFROMSTREAM');
RegisterVirtualMethod(@TStrings.Move, 'MOVE');
if Streams then
RegisterVirtualMethod(@TStrings.SaveToStream, 'SAVETOSTREAM');
RegisterVirtualMethod(@TStrings.SetText, 'SETTEXT');
RegisterPropertyHelper(@TStringsNamesR, nil, 'NAMES');
RegisterPropertyHelper(@TStringsValuesR, @TStringsValuesW, 'VALUES');
RegisterVirtualMethod(@TSTRINGS.ADDOBJECT, 'ADDOBJECT');
RegisterVirtualMethod(@TSTRINGS.GETTEXT, 'GETTEXT');
RegisterMethod(@TSTRINGS.INDEXOFOBJECT, 'INDEXOFOBJECT');
RegisterMethod(@TSTRINGS.INSERTOBJECT, 'INSERTOBJECT');
{$ENDIF}
end;
end;
procedure TSTRINGLISTDUPLICATES_R(Self: TSTRINGLIST; var T: TDUPLICATES); begin T := Self.DUPLICATES; end;
procedure TSTRINGLISTDUPLICATES_W(Self: TSTRINGLIST; const T: TDUPLICATES); begin Self.DUPLICATES := T; end;
procedure TSTRINGLISTSORTED_R(Self: TSTRINGLIST; var T: BOOLEAN); begin T := Self.SORTED; end;
procedure TSTRINGLISTSORTED_W(Self: TSTRINGLIST; const T: BOOLEAN); begin Self.SORTED := T; end;
procedure TSTRINGLISTONCHANGE_R(Self: TSTRINGLIST; var T: TNOTIFYEVENT);
begin
T := Self.ONCHANGE; end;
procedure TSTRINGLISTONCHANGE_W(Self: TSTRINGLIST; const T: TNOTIFYEVENT);
begin
Self.ONCHANGE := T; end;
procedure TSTRINGLISTONCHANGING_R(Self: TSTRINGLIST; var T: TNOTIFYEVENT); begin T := Self.ONCHANGING; end;
procedure TSTRINGLISTONCHANGING_W(Self: TSTRINGLIST; const T: TNOTIFYEVENT); begin Self.ONCHANGING := T; end;
procedure RIRegisterTSTRINGLIST(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TSTRINGLIST) do
begin
RegisterVirtualMethod(@TSTRINGLIST.FIND, 'FIND');
RegisterVirtualMethod(@TSTRINGLIST.SORT, 'SORT');
RegisterPropertyHelper(@TSTRINGLISTDUPLICATES_R, @TSTRINGLISTDUPLICATES_W, 'DUPLICATES');
RegisterPropertyHelper(@TSTRINGLISTSORTED_R, @TSTRINGLISTSORTED_W, 'SORTED');
RegisterEventPropertyHelper(@TSTRINGLISTONCHANGE_R, @TSTRINGLISTONCHANGE_W, 'ONCHANGE');
RegisterEventPropertyHelper(@TSTRINGLISTONCHANGING_R, @TSTRINGLISTONCHANGING_W, 'ONCHANGING');
end;
end;
{$IFNDEF PS_MINIVCL}
procedure TBITSBITS_W(Self: TBITS; T: BOOLEAN; t1: INTEGER); begin Self.BITS[t1] := T; end;
procedure TBITSBITS_R(Self: TBITS; var T: BOOLEAN; t1: INTEGER); begin T := Self.Bits[t1]; end;
procedure TBITSSIZE_R(Self: TBITS; T: INTEGER); begin Self.SIZE := T; end;
procedure TBITSSIZE_W(Self: TBITS; var T: INTEGER); begin T := Self.SIZE; end;
procedure RIRegisterTBITS(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TBITS) do
begin
RegisterMethod(@TBITS.OPENBIT, 'OPENBIT');
RegisterPropertyHelper(@TBITSBITS_R, @TBITSBITS_W, 'BITS');
RegisterPropertyHelper(@TBITSSIZE_R, @TBITSSIZE_W, 'SIZE');
end;
end;
{$ENDIF}
procedure TSTREAMPOSITION_R(Self: TSTREAM; var T: LONGINT); begin t := Self.POSITION; end;
procedure TSTREAMPOSITION_W(Self: TSTREAM; T: LONGINT); begin Self.POSITION := t; end;
procedure TSTREAMSIZE_R(Self: TSTREAM; var T: LONGINT); begin t := Self.SIZE; end;
{$IFDEF DELPHI3UP}
procedure TSTREAMSIZE_W(Self: TSTREAM; T: LONGINT); begin Self.SIZE := t; end;
{$ENDIF}
procedure RIRegisterTSTREAM(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TSTREAM) do
begin
RegisterVirtualAbstractMethod(TMemoryStream, @TMemoryStream.READ, 'READ');
RegisterVirtualAbstractMethod(TMemoryStream, @TMemoryStream.WRITE, 'WRITE');
RegisterVirtualAbstractMethod(TMemoryStream, @TMemoryStream.SEEK, 'SEEK');
RegisterMethod(@TSTREAM.READBUFFER, 'READBUFFER');
RegisterMethod(@TSTREAM.WRITEBUFFER, 'WRITEBUFFER');
RegisterMethod(@TSTREAM.COPYFROM, 'COPYFROM');
RegisterPropertyHelper(@TSTREAMPOSITION_R, @TSTREAMPOSITION_W, 'POSITION');
RegisterPropertyHelper(@TSTREAMSIZE_R, {$IFDEF DELPHI3UP}@TSTREAMSIZE_W, {$ELSE}nil, {$ENDIF}'SIZE');
end;
end;
procedure THANDLESTREAMHANDLE_R(Self: THANDLESTREAM; var T: INTEGER); begin T := Self.HANDLE; end;
procedure RIRegisterTHANDLESTREAM(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(THANDLESTREAM) do
begin
RegisterConstructor(@THANDLESTREAM.CREATE, 'CREATE');
RegisterPropertyHelper(@THANDLESTREAMHANDLE_R, nil, 'HANDLE');
end;
end;
{$IFDEF FPC}
// mh: because FPC doesn't handle pointers to overloaded functions
function TFileStreamCreate(filename: string; mode: word): TFileStream;
begin
result := TFilestream.Create(filename, mode);
end;
{$ENDIF}
procedure RIRegisterTFILESTREAM(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TFILESTREAM) do
begin
{$IFDEF FPC}
RegisterConstructor(@TFileStreamCreate, 'CREATE');
{$ELSE}
RegisterConstructor(@TFILESTREAM.CREATE, 'CREATE');
{$ENDIF}
end;
end;
{$IFNDEF PS_MINIVCL}
procedure RIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TCUSTOMMEMORYSTREAM) do
begin
RegisterMethod(@TCUSTOMMEMORYSTREAM.SAVETOSTREAM, 'SAVETOSTREAM');
RegisterMethod(@TCUSTOMMEMORYSTREAM.SAVETOFILE, 'SAVETOFILE');
end;
end;
procedure RIRegisterTMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TMEMORYSTREAM) do
begin
RegisterMethod(@TMEMORYSTREAM.CLEAR, 'CLEAR');
RegisterMethod(@TMEMORYSTREAM.LOADFROMSTREAM, 'LOADFROMSTREAM');
RegisterMethod(@TMEMORYSTREAM.LOADFROMFILE, 'LOADFROMFILE');
RegisterMethod(@TMEMORYSTREAM.SETSIZE, 'SETSIZE');
end;
end;
procedure RIRegisterTRESOURCESTREAM(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TRESOURCESTREAM) do
begin
RegisterConstructor(@TRESOURCESTREAM.CREATE, 'CREATE');
RegisterConstructor(@TRESOURCESTREAM.CREATEFROMID, 'CREATEFROMID');
end;
end;
procedure TPARSERSOURCELINE_R(Self: TPARSER; var T: INTEGER); begin T := Self.SOURCELINE; end;
procedure TPARSERTOKEN_R(Self: TPARSER; var T: CHAR); begin T := Self.TOKEN; end;
procedure RIRegisterTPARSER(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TPARSER) do
begin
RegisterConstructor(@TPARSER.CREATE, 'CREATE');
RegisterMethod(@TPARSER.CHECKTOKEN, 'CHECKTOKEN');
RegisterMethod(@TPARSER.CHECKTOKENSYMBOL, 'CHECKTOKENSYMBOL');
RegisterMethod(@TPARSER.ERROR, 'ERROR');
RegisterMethod(@TPARSER.ERRORSTR, 'ERRORSTR');
RegisterMethod(@TPARSER.HEXTOBINARY, 'HEXTOBINARY');
RegisterMethod(@TPARSER.NEXTTOKEN, 'NEXTTOKEN');
RegisterMethod(@TPARSER.SOURCEPOS, 'SOURCEPOS');
RegisterMethod(@TPARSER.TOKENCOMPONENTIDENT, 'TOKENCOMPONENTIDENT');
RegisterMethod(@TPARSER.TOKENFLOAT, 'TOKENFLOAT');
RegisterMethod(@TPARSER.TOKENINT, 'TOKENINT');
RegisterMethod(@TPARSER.TOKENSTRING, 'TOKENSTRING');
RegisterMethod(@TPARSER.TOKENSYMBOLIS, 'TOKENSYMBOLIS');
RegisterPropertyHelper(@TPARSERSOURCELINE_R, nil, 'SOURCELINE');
RegisterPropertyHelper(@TPARSERTOKEN_R, nil, 'TOKEN');
end;
end;
procedure TCOLLECTIONITEMS_W(Self: TCOLLECTION; const T: TCOLLECTIONITEM; const t1: INTEGER);
begin Self.ITEMS[t1] := T; end;
procedure TCOLLECTIONITEMS_R(Self: TCOLLECTION; var T: TCOLLECTIONITEM; const t1: INTEGER);
begin T := Self.ITEMS[t1]; end;
{$IFDEF DELPHI3UP}
procedure TCOLLECTIONITEMCLASS_R(Self: TCOLLECTION; var T: TCOLLECTIONITEMCLASS);
begin T := Self.ITEMCLASS; end;
{$ENDIF}
procedure TCOLLECTIONCOUNT_R(Self: TCOLLECTION; var T: INTEGER);
begin T := Self.COUNT; end;
{$IFDEF DELPHI3UP}
procedure TCOLLECTIONITEMDISPLAYNAME_W(Self: TCOLLECTIONITEM; const T: STRING);
begin Self.DISPLAYNAME := T; end;
{$ENDIF}
{$IFDEF DELPHI3UP}
procedure TCOLLECTIONITEMDISPLAYNAME_R(Self: TCOLLECTIONITEM; var T: STRING);
begin T := Self.DISPLAYNAME; end;
{$ENDIF}
procedure TCOLLECTIONITEMINDEX_W(Self: TCOLLECTIONITEM; const T: INTEGER);
begin Self.INDEX := T; end;
procedure TCOLLECTIONITEMINDEX_R(Self: TCOLLECTIONITEM; var T: INTEGER);
begin T := Self.INDEX; end;
{$IFDEF DELPHI3UP}
procedure TCOLLECTIONITEMID_R(Self: TCOLLECTIONITEM; var T: INTEGER);
begin T := Self.ID; end;
{$ENDIF}
procedure TCOLLECTIONITEMCOLLECTION_W(Self: TCOLLECTIONITEM; const T: TCOLLECTION);
begin Self.COLLECTION := T; end;
procedure TCOLLECTIONITEMCOLLECTION_R(Self: TCOLLECTIONITEM; var T: TCOLLECTION);
begin T := Self.COLLECTION; end;
{$IFDEF DELPHI3UP}
procedure RIRegisterTOWNEDCOLLECTION(Cl: TPSRuntimeClassImporter);
Begin
with Cl.Add(TOWNEDCOLLECTION) do
begin
RegisterConstructor(@TOWNEDCOLLECTION.CREATE, 'CREATE');
end;
end;
{$ENDIF}
procedure RIRegisterTCOLLECTION(Cl: TPSRuntimeClassImporter);
Begin
with Cl.Add(TCOLLECTION) do
begin
RegisterConstructor(@TCOLLECTION.CREATE, 'CREATE');
{$IFDEF DELPHI6UP} {$IFNDEF FPC} RegisterMethod(@TCOLLECTION.OWNER, 'OWNER'); {$ENDIF} {$ENDIF} // no owner in FPC
RegisterMethod(@TCOLLECTION.ADD, 'ADD');
RegisterVirtualMethod(@TCOLLECTION.BEGINUPDATE, 'BEGINUPDATE');
RegisterMethod(@TCOLLECTION.CLEAR, 'CLEAR');
{$IFDEF DELPHI5UP} RegisterMethod(@TCOLLECTION.DELETE, 'DELETE'); {$ENDIF}
RegisterVirtualMethod(@TCOLLECTION.ENDUPDATE, 'ENDUPDATE');
{$IFDEF DELPHI3UP} RegisterMethod(@TCOLLECTION.FINDITEMID, 'FINDITEMID'); {$ENDIF}
{$IFDEF DELPHI3UP} RegisterMethod(@TCOLLECTION.INSERT, 'INSERT'); {$ENDIF}
RegisterPropertyHelper(@TCOLLECTIONCOUNT_R,nil,'COUNT');
{$IFDEF DELPHI3UP} RegisterPropertyHelper(@TCOLLECTIONITEMCLASS_R,nil,'ITEMCLASS'); {$ENDIF}
RegisterPropertyHelper(@TCOLLECTIONITEMS_R,@TCOLLECTIONITEMS_W,'ITEMS');
end;
end;
procedure RIRegisterTCOLLECTIONITEM(Cl: TPSRuntimeClassImporter);
Begin
with Cl.Add(TCOLLECTIONITEM) do
begin
RegisterVirtualConstructor(@TCOLLECTIONITEM.CREATE, 'CREATE');
RegisterPropertyHelper(@TCOLLECTIONITEMCOLLECTION_R,@TCOLLECTIONITEMCOLLECTION_W,'COLLECTION');
{$IFDEF DELPHI3UP} RegisterPropertyHelper(@TCOLLECTIONITEMID_R,nil,'ID'); {$ENDIF}
RegisterPropertyHelper(@TCOLLECTIONITEMINDEX_R,@TCOLLECTIONITEMINDEX_W,'INDEX');
{$IFDEF DELPHI3UP} RegisterPropertyHelper(@TCOLLECTIONITEMDISPLAYNAME_R,@TCOLLECTIONITEMDISPLAYNAME_W,'DISPLAYNAME'); {$ENDIF}
end;
end;
{$ENDIF}
procedure RIRegister_Classes(Cl: TPSRuntimeClassImporter; Streams: Boolean);
begin
if Streams then
RIRegisterTSTREAM(Cl);
RIRegisterTStrings(cl, Streams);
RIRegisterTStringList(cl);
{$IFNDEF PS_MINIVCL}
RIRegisterTBITS(cl);
{$ENDIF}
if Streams then
begin
RIRegisterTHANDLESTREAM(Cl);
RIRegisterTFILESTREAM(Cl);
{$IFNDEF PS_MINIVCL}
RIRegisterTCUSTOMMEMORYSTREAM(Cl);
RIRegisterTMEMORYSTREAM(Cl);
RIRegisterTRESOURCESTREAM(Cl);
{$ENDIF}
end;
{$IFNDEF PS_MINIVCL}
RIRegisterTPARSER(Cl);
RIRegisterTCOLLECTIONITEM(Cl);
RIRegisterTCOLLECTION(Cl);
{$IFDEF DELPHI3UP}
RIRegisterTOWNEDCOLLECTION(Cl);
{$ENDIF}
{$ENDIF}
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

96
Units/PascalScript/uPSR_comobj.pas Normal file
View File

@ -0,0 +1,96 @@
unit uPSR_comobj;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegister_ComObj(cl: TPSExec);
implementation
uses
{$IFDEF DELPHI3UP}
ComObj;
{$ELSE}
SysUtils, Ole2;
{$ENDIF}
{$IFNDEF DELPHI3UP}
{$IFDEF DELPHI3UP }
resourceString
{$ELSE }
const
{$ENDIF }
RPS_OLEError = 'OLE error %.8x';
function OleErrorMessage(ErrorCode: HResult): String;
begin
Result := SysErrorMessage(ErrorCode);
if Result = '' then
Result := Format(RPS_OLEError, [ErrorCode]);
end;
procedure OleError(ErrorCode: HResult);
begin
raise Exception.Create(OleErrorMessage(ErrorCode));
end;
procedure OleCheck(Result: HResult);
begin
if Result < 0 then OleError(Result);
end;
procedure CreateOleObject(const ClassName: string; var Disp: IDispatch);
var
OldDisp: IDispatch;
ClassID: TCLSID;
WideCharBuf: array[0..127] of WideChar;
begin
StringToWideChar(ClassName, WideCharBuf, SizeOf(WideCharBuf) div SizeOf(WideCharBuf[0]));
OleCheck(CLSIDFromProgID(WideCharBuf, ClassID));
if Disp <> nil then
begin
OldDisp := Disp;
Disp := nil;
OldDisp.Release;
end;
OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
CLSCTX_LOCAL_SERVER, IID_IDispatch, Disp));
end;
procedure GetActiveOleObject(const ClassName: string; var Disp: IDispatch);
var
Unknown: IUnknown;
OldDisp: IDispatch;
ClassID: TCLSID;
WideCharBuf: array[0..127] of WideChar;
begin
StringToWideChar(ClassName, WideCharBuf, SizeOf(WideCharBuf) div SizeOf(WideCharBuf[0]));
OleCheck(CLSIDFromProgID(WideCharBuf, ClassID));
OleCheck(GetActiveObject(ClassID, nil, Unknown));
try
if Disp <> nil then
begin
OldDisp := Disp;
Disp := nil;
OldDisp.Release;
end;
OleCheck(Unknown.QueryInterface(IID_IDispatch, Disp));
finally
Unknown.Release;
end;
end;
{$ENDIF}
procedure RIRegister_ComObj(cl: TPSExec);
begin
cl.RegisterDelphiFunction(@CreateOleObject, 'CREATEOLEOBJECT', cdRegister);
cl.RegisterDelphiFunction(@GetActiveOleObject, 'GETACTIVEOLEOBJECT', cdRegister);
end;
end.

249
Units/PascalScript/uPSR_controls.pas Normal file
View File

@ -0,0 +1,249 @@
unit uPSR_controls;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegisterTControl(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTWinControl(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTGraphicControl(cl: TPSRuntimeClassImporter);
procedure RIRegisterTCustomControl(cl: TPSRuntimeClassImporter);
procedure RIRegister_TDragObject(CL: TPSRuntimeClassImporter);
procedure RIRegister_Controls(Cl: TPSRuntimeClassImporter);
implementation
{$IFNDEF FPC}
uses
Classes{$IFDEF CLX}, QControls, QGraphics{$ELSE}, Controls, Graphics, Windows{$ENDIF};
{$ELSE}
uses
Classes, Controls, Graphics;
{$ENDIF}
procedure TControlAlignR(Self: TControl; var T: Byte); begin T := Byte(Self.Align); end;
procedure TControlAlignW(Self: TControl; T: Byte); begin Self.Align:= TAlign(T); end;
procedure TControlClientHeightR(Self: TControl; var T: Longint); begin T := Self.ClientHeight; end;
procedure TControlClientHeightW(Self: TControl; T: Longint); begin Self.ClientHeight := T; end;
procedure TControlClientWidthR(Self: TControl; var T: Longint); begin T := Self.ClientWidth; end;
procedure TControlClientWidthW(Self: TControl; T: Longint); begin Self.ClientWidth:= T; end;
procedure TControlShowHintR(Self: TControl; var T: Boolean); begin T := Self.ShowHint; end;
procedure TControlShowHintW(Self: TControl; T: Boolean); begin Self.ShowHint:= T; end;
procedure TControlVisibleR(Self: TControl; var T: Boolean); begin T := Self.Visible; end;
procedure TControlVisibleW(Self: TControl; T: Boolean); begin Self.Visible:= T; end;
procedure TControlParentR(Self: TControl; var T: TWinControl); begin T := Self.Parent; end;
procedure TControlParentW(Self: TControl; T: TWinControl); begin Self.Parent:= T; end;
procedure TCONTROLSHOWHINT_W(Self: TCONTROL; T: BOOLEAN); begin Self.SHOWHINT := T; end;
procedure TCONTROLSHOWHINT_R(Self: TCONTROL; var T: BOOLEAN); begin T := Self.SHOWHINT; end;
procedure TCONTROLENABLED_W(Self: TCONTROL; T: BOOLEAN); begin Self.ENABLED := T; end;
procedure TCONTROLENABLED_R(Self: TCONTROL; var T: BOOLEAN); begin T := Self.ENABLED; end;
procedure RIRegisterTControl(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TControl) do
begin
RegisterVirtualConstructor(@TControl.Create, 'CREATE');
RegisterMethod(@TControl.BRingToFront, 'BRINGTOFRONT');
RegisterMethod(@TControl.Hide, 'HIDE');
RegisterVirtualMethod(@TControl.Invalidate, 'INVALIDATE');
RegisterMethod(@TControl.Refresh, 'REFRESH');
RegisterVirtualMethod(@TControl.Repaint, 'REPAINT');
RegisterMethod(@TControl.SendToBack, 'SENDTOBACK');
RegisterMethod(@TControl.Show, 'SHOW');
RegisterVirtualMethod(@TControl.Update, 'UPDATE');
RegisterVirtualMethod(@TControl.SetBounds, 'SETBOUNDS');
RegisterPropertyHelper(@TControlShowHintR, @TControlShowHintW, 'SHOWHINT');
RegisterPropertyHelper(@TControlAlignR, @TControlAlignW, 'ALIGN');
RegisterPropertyHelper(@TControlClientHeightR, @TControlClientHeightW, 'CLIENTHEIGHT');
RegisterPropertyHelper(@TControlClientWidthR, @TControlClientWidthW, 'CLIENTWIDTH');
RegisterPropertyHelper(@TControlVisibleR, @TControlVisibleW, 'VISIBLE');
RegisterPropertyHelper(@TCONTROLENABLED_R, @TCONTROLENABLED_W, 'ENABLED');
RegisterPropertyHelper(@TControlParentR, @TControlParentW, 'PARENT');
{$IFNDEF PS_MINIVCL}
RegisterMethod(@TControl.Dragging, 'DRAGGING');
RegisterMethod(@TControl.HasParent, 'HASPARENT');
RegisterMethod(@TCONTROL.CLIENTTOSCREEN, 'CLIENTTOSCREEN');
RegisterMethod(@TCONTROL.DRAGGING, 'DRAGGING');
{$IFNDEF FPC}
RegisterMethod(@TCONTROL.BEGINDRAG, 'BEGINDRAG');
RegisterMethod(@TCONTROL.ENDDRAG, 'ENDDRAG');
{$ENDIF}
{$IFNDEF CLX}
RegisterMethod(@TCONTROL.GETTEXTBUF, 'GETTEXTBUF');
RegisterMethod(@TCONTROL.GETTEXTLEN, 'GETTEXTLEN');
RegisterMethod(@TCONTROL.PERFORM, 'PERFORM');
RegisterMethod(@TCONTROL.SETTEXTBUF, 'SETTEXTBUF');
{$ENDIF}
RegisterMethod(@TCONTROL.SCREENTOCLIENT, 'SCREENTOCLIENT');
{$ENDIF}
end;
end;
{$IFNDEF CLX}
procedure TWinControlHandleR(Self: TWinControl; var T: Longint); begin T := Self.Handle; end;
{$ENDIF}
procedure TWinControlShowingR(Self: TWinControl; var T: Boolean); begin T := Self.Showing; end;
procedure TWinControlTabOrderR(Self: TWinControl; var T: Longint); begin T := Self.TabOrder; end;
procedure TWinControlTabOrderW(Self: TWinControl; T: Longint); begin Self.TabOrder:= T; end;
procedure TWinControlTabStopR(Self: TWinControl; var T: Boolean); begin T := Self.TabStop; end;
procedure TWinControlTabStopW(Self: TWinControl; T: Boolean); begin Self.TabStop:= T; end;
procedure TWINCONTROLBRUSH_R(Self: TWINCONTROL; var T: TBRUSH); begin T := Self.BRUSH; end;
procedure TWINCONTROLCONTROLS_R(Self: TWINCONTROL; var T: TCONTROL; t1: INTEGER); begin t := Self.CONTROLS[t1]; end;
procedure TWINCONTROLCONTROLCOUNT_R(Self: TWINCONTROL; var T: INTEGER); begin t := Self.CONTROLCOUNT; end;
procedure RIRegisterTWinControl(Cl: TPSRuntimeClassImporter); // requires TControl
begin
with Cl.Add(TWinControl) do
begin
{$IFNDEF CLX}
RegisterPropertyHelper(@TWinControlHandleR, nil, 'HANDLE');
{$ENDIF}
RegisterPropertyHelper(@TWinControlShowingR, nil, 'SHOWING');
RegisterPropertyHelper(@TWinControlTabOrderR, @TWinControlTabOrderW, 'TABORDER');
RegisterPropertyHelper(@TWinControlTabStopR, @TWinControlTabStopW, 'TABSTOP');
RegisterMethod(@TWINCONTROL.CANFOCUS, 'CANFOCUS');
RegisterMethod(@TWINCONTROL.FOCUSED, 'FOCUSED');
RegisterPropertyHelper(@TWINCONTROLCONTROLS_R, nil, 'CONTROLS');
RegisterPropertyHelper(@TWINCONTROLCONTROLCOUNT_R, nil, 'CONTROLCOUNT');
{$IFNDEF PS_MINIVCL}
RegisterMethod(@TWinControl.HandleAllocated, 'HANDLEALLOCATED');
RegisterMethod(@TWinControl.HandleNeeded, 'HANDLENEEDED');
RegisterMethod(@TWinControl.EnableAlign, 'ENABLEALIGN');
RegisterMethod(@TWinControl.RemoveControl, 'REMOVECONTROL');
{$IFNDEF FPC}
RegisterMethod(@TWinControl.InsertControl, 'INSERTCONTROL');
RegisterMethod(@TWinControl.ScaleBy, 'SCALEBY');
RegisterMethod(@TWinControl.ScrollBy, 'SCROLLBY');
{$IFNDEF CLX}
RegisterMethod(@TWINCONTROL.PAINTTO, 'PAINTTO');
{$ENDIF}
{$ENDIF}{FPC}
RegisterMethod(@TWinControl.Realign, 'REALIGN');
RegisterVirtualMethod(@TWinControl.SetFocus, 'SETFOCUS');
RegisterMethod(@TWINCONTROL.CONTAINSCONTROL, 'CONTAINSCONTROL');
RegisterMethod(@TWINCONTROL.DISABLEALIGN, 'DISABLEALIGN');
RegisterMethod(@TWINCONTROL.UPDATECONTROLSTATE, 'UPDATECONTROLSTATE');
RegisterPropertyHelper(@TWINCONTROLBRUSH_R, nil, 'BRUSH');
{$ENDIF}
end;
end;
procedure RIRegisterTGraphicControl(cl: TPSRuntimeClassImporter); // requires TControl
begin
Cl.Add(TGraphicControl);
end;
procedure RIRegisterTCustomControl(cl: TPSRuntimeClassImporter); // requires TControl
begin
Cl.Add(TCustomControl);
end;
{$IFDEF DELPHI4UP}
(* === run-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure TDragObjectMouseDeltaY_R(Self: TDragObject; var T: Double);
begin T := Self.MouseDeltaY; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectMouseDeltaX_R(Self: TDragObject; var T: Double);
begin T := Self.MouseDeltaX; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectDragTarget_W(Self: TDragObject; const T: Pointer);
begin Self.DragTarget := T; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectDragTarget_R(Self: TDragObject; var T: Pointer);
begin T := Self.DragTarget; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectDragTargetPos_W(Self: TDragObject; const T: TPoint);
begin Self.DragTargetPos := T; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectDragTargetPos_R(Self: TDragObject; var T: TPoint);
begin T := Self.DragTargetPos; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectDragPos_W(Self: TDragObject; const T: TPoint);
begin Self.DragPos := T; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectDragPos_R(Self: TDragObject; var T: TPoint);
begin T := Self.DragPos; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectDragHandle_W(Self: TDragObject; const T: HWND);
begin Self.DragHandle := T; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectDragHandle_R(Self: TDragObject; var T: HWND);
begin T := Self.DragHandle; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectCancelling_W(Self: TDragObject; const T: Boolean);
begin Self.Cancelling := T; end;
(*----------------------------------------------------------------------------*)
procedure TDragObjectCancelling_R(Self: TDragObject; var T: Boolean);
begin T := Self.Cancelling; end;
{$ENDIF}
(*----------------------------------------------------------------------------*)
procedure RIRegister_TDragObject(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TDragObject) do
begin
{$IFNDEF PS_MINIVCL}
{$IFDEF DELPHI4UP}
RegisterVirtualMethod(@TDragObject.Assign, 'Assign');
{$ENDIF}
{$IFNDEF FPC}
RegisterVirtualMethod(@TDragObject.GetName, 'GetName');
RegisterVirtualMethod(@TDragObject.Instance, 'Instance');
{$ENDIF}
RegisterVirtualMethod(@TDragObject.HideDragImage, 'HideDragImage');
RegisterVirtualMethod(@TDragObject.ShowDragImage, 'ShowDragImage');
{$IFDEF DELPHI4UP}
RegisterPropertyHelper(@TDragObjectCancelling_R,@TDragObjectCancelling_W,'Cancelling');
RegisterPropertyHelper(@TDragObjectDragHandle_R,@TDragObjectDragHandle_W,'DragHandle');
RegisterPropertyHelper(@TDragObjectDragPos_R,@TDragObjectDragPos_W,'DragPos');
RegisterPropertyHelper(@TDragObjectDragTargetPos_R,@TDragObjectDragTargetPos_W,'DragTargetPos');
RegisterPropertyHelper(@TDragObjectDragTarget_R,@TDragObjectDragTarget_W,'DragTarget');
RegisterPropertyHelper(@TDragObjectMouseDeltaX_R,nil,'MouseDeltaX');
RegisterPropertyHelper(@TDragObjectMouseDeltaY_R,nil,'MouseDeltaY');
{$ENDIF}
{$ENDIF}
end;
end;
procedure RIRegister_Controls(Cl: TPSRuntimeClassImporter);
begin
RIRegisterTControl(Cl);
RIRegisterTWinControl(Cl);
RIRegisterTGraphicControl(cl);
RIRegisterTCustomControl(cl);
RIRegister_TDragObject(cl);
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

63
Units/PascalScript/uPSR_dateutils.pas Normal file
View File

@ -0,0 +1,63 @@
unit uPSR_dateutils;
{$I PascalScript.inc}
interface
uses
SysUtils, uPSRuntime;
procedure RegisterDateTimeLibrary_R(S: TPSExec);
implementation
function TryEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean;
begin
try
Date := EncodeDate(Year, Month, Day);
Result := true;
except
Result := false;
end;
end;
function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;
begin
try
Time := EncodeTime(hour, Min, Sec, MSec);
Result := true;
except
Result := false;
end;
end;
function DateTimeToUnix(D: TDateTime): Int64;
begin
Result := Round((D - 25569) * 86400);
end;
function UnixToDateTime(U: Int64): TDateTime;
begin
Result := U / 86400 + 25569;
end;
procedure RegisterDateTimeLibrary_R(S: TPSExec);
begin
S.RegisterDelphiFunction(@EncodeDate, 'ENCODEDATE', cdRegister);
S.RegisterDelphiFunction(@EncodeTime, 'ENCODETIME', cdRegister);
S.RegisterDelphiFunction(@TryEncodeDate, 'TRYENCODEDATE', cdRegister);
S.RegisterDelphiFunction(@TryEncodeTime, 'TRYENCODETIME', cdRegister);
S.RegisterDelphiFunction(@DecodeDate, 'DECODEDATE', cdRegister);
S.RegisterDelphiFunction(@DecodeTime, 'DECODETIME', cdRegister);
S.RegisterDelphiFunction(@DayOfWeek, 'DAYOFWEEK', cdRegister);
S.RegisterDelphiFunction(@Date, 'DATE', cdRegister);
S.RegisterDelphiFunction(@Time, 'TIME', cdRegister);
S.RegisterDelphiFunction(@Now, 'NOW', cdRegister);
S.RegisterDelphiFunction(@DateTimeToUnix, 'DATETIMETOUNIX', cdRegister);
S.RegisterDelphiFunction(@UnixToDateTime, 'UNIXTODATETIME', cdRegister);
S.RegisterDelphiFunction(@DateToStr, 'DATETOSTR', cdRegister);
S.RegisterDelphiFunction(@FormatDateTime, 'FORMATDATETIME', cdRegister);
S.RegisterDelphiFunction(@StrToDate, 'STRTODATE', cdRegister);
end;
end.

312
Units/PascalScript/uPSR_dll.pas Normal file
View File

@ -0,0 +1,312 @@
unit uPSR_dll;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RegisterDLLRuntime(Caller: TPSExec);
procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean);
function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean;
function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean;
function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
implementation
uses
{$IFDEF UNIX}
{$IFDEF Darwin}
LCLIntf, Unix, baseunix, dynlibs, termio, sockets;
{$ELSE}
LibC{$IFNDEF FPC}, Windows{$ENDIF};
{$ENDIF}
{$ELSE}
Windows;
{$ENDIF}
{
p^.Ext1 contains the pointer to the Proc function
p^.ExportDecl:
'dll:'+DllName+#0+FunctionName+#0+chr(Cc)+Chr(DelayLoad)+Chr(AlternateSearchPath)+VarParams
}
type
PLoadedDll = ^TLoadedDll;
TLoadedDll = record
dllnamehash: Longint;
dllname: tbtstring;
{$IFDEF LINUX}
dllhandle: Pointer;
{$ELSE}
dllhandle: THandle;
{$ENDIF}
end;
TMyExec = class(TPSExec);
PInteger = ^Integer;
procedure LAstErrorFree(Sender: TPSExec; P: PInteger);
begin
dispose(p);
end;
procedure DLLSetLastError(Sender: TPSExec; P: Integer);
var
pz: PInteger;
begin
pz := Sender.FindProcResource(@LastErrorFree);
if pz = nil then
begin
new(pz);
Sender.AddResource(@LastErrorFree, PZ);
end;
pz^ := p;
end;
function DLLGetLastError(Sender: TPSExec): Integer;
var
pz: PInteger;
begin
pz := Sender.FindProcResource(@LastErrorFree);
if pz = nil then
result := 0
else
result := pz^;
end;
procedure DllFree(Sender: TPSExec; P: PLoadedDll);
begin
{$IFDEF LINUX}
dlclose(p^.dllhandle);
{$ELSE}
FreeLibrary(p^.dllhandle);
{$ENDIF}
Dispose(p);
end;
function LoadDll(Caller: TPSExec; P: TPSExternalProcRec): Boolean;
var
s, s2, s3: tbtstring;
h, i: Longint;
ph: PLoadedDll;
{$IFDEF LINUX}
dllhandle: Pointer;
{$ELSE}
dllhandle: THandle;
{$ENDIF}
loadwithalteredsearchpath: Boolean;
begin
s := p.Decl;
Delete(s, 1, 4);
s2 := copy(s, 1, pos(tbtchar(#0), s)-1);
delete(s, 1, length(s2)+1);
h := makehash(s2);
s3 := copy(s, 1, pos(tbtchar(#0), s)-1);
delete(s, 1, length(s3)+1);
loadwithalteredsearchpath := bytebool(s[3]);
i := 2147483647; // maxint
dllhandle := 0;
repeat
ph := Caller.FindProcResource2(@dllFree, i);
if (ph = nil) then
begin
if s2 = '' then
begin
// don't pass an empty filename to LoadLibrary, just treat it as uncallable
p.Ext2 := Pointer(1);
Result := False;
exit;
end;
{$IFDEF UNIX}
{$IFDEF DARWIN}
dllhandle := LoadLibrary(PChar(s2));
{$ELSE}
dllhandle := dlopen(PChar(s2), RTLD_LAZY);
{$ENDIF}
{$ELSE}
if loadwithalteredsearchpath then
dllhandle := LoadLibraryExA(PAnsiChar(AnsiString(s2)), 0, LOAD_WITH_ALTERED_SEARCH_PATH)
else
dllhandle := LoadLibraryA(PAnsiChar(AnsiString(s2)));
{$ENDIF}
if dllhandle = {$IFDEF LINUX}nil{$ELSE}0{$ENDIF}then
begin
p.Ext2 := Pointer(1);
Result := False;
exit;
end;
new(ph);
ph^.dllnamehash := h;
ph^.dllname := s2;
ph^.dllhandle := dllhandle;
Caller.AddResource(@DllFree, ph);
end;
if (ph^.dllnamehash = h) and (ph^.dllname = s2) then
begin
dllhandle := ph^.dllhandle;
end;
until dllhandle <> {$IFDEF LINUX}nil{$ELSE}0{$ENDIF};
{$IFDEF LINUX}
p.Ext1 := dlsym(dllhandle, pchar(s3));
{$ELSE}
p.Ext1 := GetProcAddress(dllhandle, pansichar(s3));
{$ENDIF}
if p.Ext1 = nil then
begin
p.Ext2 := Pointer(1);
Result := false;
exit;
end;
Result := True;
end;
function DllProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
var
i: Longint;
MyList: TIfList;
n: PPSVariantIFC;
CurrStack: Cardinal;
cc: TPSCallingConvention;
s: tbtstring;
begin
if p.Ext2 <> nil then // error
begin
Result := false;
exit;
end;
if p.Ext1 = nil then
begin
if not LoadDll(Caller, P) then
begin
Result := false;
exit;
end;
end;
s := p.Decl;
delete(S, 1, pos(tbtchar(#0), s));
delete(S, 1, pos(tbtchar(#0), s));
if length(S) < 2 then
begin
Result := False;
exit;
end;
cc := TPSCallingConvention(s[1]);
delete(s, 1, 3); // cc + delayload + alternatesearchpath (delayload might also be forced!)
CurrStack := Cardinal(Stack.Count) - Cardinal(length(s));
if s[1] = #0 then inc(CurrStack);
MyList := tIfList.Create;
for i := 2 to length(s) do
begin
MyList.Add(nil);
end;
for i := length(s) downto 2 do
begin
MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0);
inc(CurrStack);
end;
if s[1] <> #0 then
begin
n := NewPPSVariantIFC(Stack[CurrStack], true);
end else n := nil;
try
TMYExec(Caller).InnerfuseCall(nil, p.Ext1, cc, MyList, n);
{$IFNDEF LINUX}
DLLSetLastError(Caller, GetLastError);
{$ENDIF}
finally
DisposePPSvariantIFC(n);
DisposePPSVariantIFCList(MyList);
end;
result := true;
end;
function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean;
begin
Result := ProcessDllImportEx(Caller, P, False);
end;
function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean;
var
DelayLoad: Boolean;
s: tbtstring;
begin
if not ForceDelayLoad then begin
s := p.Decl;
Delete(s,1,pos(tbtchar(#0), s));
Delete(s,1,pos(tbtchar(#0), s));
DelayLoad := bytebool(s[2]);
end else
DelayLoad := True;
if DelayLoad then begin
p.ProcPtr := DllProc;
Result := True;
end else begin
p.ProcPtr := DllProc;
Result := LoadDll(Caller, p);
end;
end;
function GetLastErrorProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
begin
Stack.SetInt(-1, DLLGetLastError(Caller));
Result := true;
end;
function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
var
h, i: Longint;
pv: TPSProcRec;
ph: PLoadedDll;
sname, s: tbtstring;
begin
sname := Stack.GetAnsiString(-1);
for i := Caller.GetProcCount -1 downto 0 do
begin
pv := Caller.GetProcNo(i);
if not (pv is TPSExternalProcRec) then continue;
if @TPSExternalProcRec(pv).ProcPtr <> @DllProc then continue;
s := (TPSExternalProcRec(pv).Decl);
delete(s,1,4);
if copy(s,1,pos(tbtchar(#0),s)-1) = sname then
begin
TPSExternalProcRec(pv).Ext1 := nil;
end;
end;
h := MakeHash(sname);
i := 2147483647; // maxint
repeat
ph := Caller.FindProcResource2(@dllFree, i);
if (ph = nil) then break;
if (ph.dllnamehash = h) and (ph.dllname = sname) then
begin
{$IFDEF LINUX}
dlclose(ph^.dllhandle);
{$ELSE}
FreeLibrary(ph^.dllhandle);
{$ENDIF}
Caller.DeleteResource(ph);
dispose(ph);
end;
until false;
result := true;
end;
procedure RegisterDLLRuntime(Caller: TPSExec);
begin
RegisterDLLRuntimeEx(Caller, True);
end;
procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean);
begin
if AddDllProcImport then
Caller.AddSpecialProcImport('dll', @ProcessDllImport, nil);
Caller.RegisterFunctionName('UNLOADDLL', UnloadProc, nil, nil);
Caller.RegisterFunctionName('DLLGETLASTERROR', GetLastErrorProc, nil, nil);
end;
end.

150
Units/PascalScript/uPSR_extctrls.pas Normal file
View File

@ -0,0 +1,150 @@
unit uPSR_extctrls;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegister_ExtCtrls(cl: TPSRuntimeClassImporter);
procedure RIRegisterTSHAPE(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTIMAGE(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTPAINTBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTBEVEL(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTTIMER(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCUSTOMPANEL(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTPANEL(Cl: TPSRuntimeClassImporter);
{$IFNDEF CLX}
procedure RIRegisterTPAGE(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTNOTEBOOK(Cl: TPSRuntimeClassImporter);
{$IFNDEF FPC}procedure RIRegisterTHEADER(Cl: TPSRuntimeClassImporter);{$ENDIF}
{$ENDIF}
procedure RIRegisterTCUSTOMRADIOGROUP(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTRADIOGROUP(Cl: TPSRuntimeClassImporter);
implementation
uses
{$IFDEF CLX}
QExtCtrls, QGraphics;
{$ELSE}
ExtCtrls, Graphics;
{$ENDIF}
procedure RIRegisterTSHAPE(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TSHAPE) do
begin
{$IFNDEF PS_MINIVCL}
RegisterMethod(@TSHAPE.STYLECHANGED, 'STYLECHANGED');
{$ENDIF}
end;
end;
procedure TIMAGECANVAS_R(Self: TIMAGE; var T: TCANVAS); begin T := Self.CANVAS; end;
procedure RIRegisterTIMAGE(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TIMAGE) do
begin
RegisterPropertyHelper(@TIMAGECANVAS_R, nil, 'CANVAS');
end;
end;
procedure TPAINTBOXCANVAS_R(Self: TPAINTBOX; var T: TCanvas); begin T := Self.CANVAS; end;
procedure RIRegisterTPAINTBOX(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TPAINTBOX) do
begin
RegisterPropertyHelper(@TPAINTBOXCANVAS_R, nil, 'CANVAS');
end;
end;
procedure RIRegisterTBEVEL(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TBEVEL);
end;
procedure RIRegisterTTIMER(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TTIMER);
end;
procedure RIRegisterTCUSTOMPANEL(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TCUSTOMPANEL);
end;
procedure RIRegisterTPANEL(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TPANEL);
end;
{$IFNDEF CLX}
procedure RIRegisterTPAGE(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TPAGE);
end;
procedure RIRegisterTNOTEBOOK(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TNOTEBOOK);
end;
{$IFNDEF FPC}
procedure THEADERSECTIONWIDTH_R(Self: THEADER; var T: INTEGER; t1: INTEGER); begin T := Self.SECTIONWIDTH[t1]; end;
procedure THEADERSECTIONWIDTH_W(Self: THEADER; T: INTEGER; t1: INTEGER); begin Self.SECTIONWIDTH[t1] := T; end;
procedure RIRegisterTHEADER(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(THEADER) do
begin
RegisterPropertyHelper(@THEADERSECTIONWIDTH_R, @THEADERSECTIONWIDTH_W, 'SECTIONWIDTH');
end;
end;
{$ENDIF}
{$ENDIF}
procedure RIRegisterTCUSTOMRADIOGROUP(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TCUSTOMRADIOGROUP);
end;
procedure RIRegisterTRADIOGROUP(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TRADIOGROUP);
end;
procedure RIRegister_ExtCtrls(cl: TPSRuntimeClassImporter);
begin
{$IFNDEF PS_MINIVCL}
RIRegisterTSHAPE(Cl);
RIRegisterTIMAGE(Cl);
RIRegisterTPAINTBOX(Cl);
{$ENDIF}
RIRegisterTBEVEL(Cl);
{$IFNDEF PS_MINIVCL}
RIRegisterTTIMER(Cl);
{$ENDIF}
RIRegisterTCUSTOMPANEL(Cl);
{$IFNDEF CLX}
RIRegisterTPANEL(Cl);
{$ENDIF}
{$IFNDEF PS_MINIVCL}
{$IFNDEF CLX}
RIRegisterTPAGE(Cl);
RIRegisterTNOTEBOOK(Cl);
{$IFNDEF FPC}
RIRegisterTHEADER(Cl);
{$ENDIF}{FPC}
{$ENDIF}
RIRegisterTCUSTOMRADIOGROUP(Cl);
RIRegisterTRADIOGROUP(Cl);
{$ENDIF}
end;
end.

264
Units/PascalScript/uPSR_forms.pas Normal file
View File

@ -0,0 +1,264 @@
unit uPSR_forms;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegisterTCONTROLSCROLLBAR(Cl: TPSRuntimeClassImporter);
{$IFNDEF FPC} procedure RIRegisterTSCROLLINGWINCONTROL(Cl: TPSRuntimeClassImporter);{$ENDIF}
procedure RIRegisterTSCROLLBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTFORM(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTAPPLICATION(Cl: TPSRuntimeClassImporter);
procedure RIRegister_Forms(Cl: TPSRuntimeClassImporter);
implementation
uses
sysutils, classes, {$IFDEF CLX}QControls, QForms, QGraphics{$ELSE}Controls, Forms, Graphics{$ENDIF};
procedure TCONTROLSCROLLBARKIND_R(Self: TCONTROLSCROLLBAR; var T: TSCROLLBARKIND); begin T := Self.KIND; end;
procedure TCONTROLSCROLLBARSCROLLPOS_R(Self: TCONTROLSCROLLBAR; var T: INTEGER); begin t := Self.SCROLLPOS; end;
procedure RIRegisterTCONTROLSCROLLBAR(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TCONTROLSCROLLBAR) do
begin
RegisterPropertyHelper(@TCONTROLSCROLLBARKIND_R, nil, 'KIND');
RegisterPropertyHelper(@TCONTROLSCROLLBARSCROLLPOS_R, nil, 'SCROLLPOS');
end;
end;
{$IFNDEF FPC}
procedure RIRegisterTSCROLLINGWINCONTROL(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TSCROLLINGWINCONTROL) do
begin
RegisterMethod(@TSCROLLINGWINCONTROL.SCROLLINVIEW, 'SCROLLINVIEW');
end;
end;
{$ENDIF}
procedure RIRegisterTSCROLLBOX(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TSCROLLBOX);
end;
{$IFNDEF FPC}
{$IFNDEF CLX}
procedure TFORMACTIVEOLECONTROL_W(Self: TFORM; T: TWINCONTROL); begin Self.ACTIVEOLECONTROL := T; end;
procedure TFORMACTIVEOLECONTROL_R(Self: TFORM; var T: TWINCONTROL); begin T := Self.ACTIVEOLECONTROL;
end;
procedure TFORMTILEMODE_W(Self: TFORM; T: TTILEMODE); begin Self.TILEMODE := T; end;
procedure TFORMTILEMODE_R(Self: TFORM; var T: TTILEMODE); begin T := Self.TILEMODE; end;
{$ENDIF}{CLX}
procedure TFORMACTIVEMDICHILD_R(Self: TFORM; var T: TFORM); begin T := Self.ACTIVEMDICHILD; end;
procedure TFORMDROPTARGET_W(Self: TFORM; T: BOOLEAN); begin Self.DROPTARGET := T; end;
procedure TFORMDROPTARGET_R(Self: TFORM; var T: BOOLEAN); begin T := Self.DROPTARGET; end;
procedure TFORMMDICHILDCOUNT_R(Self: TFORM; var T: INTEGER); begin T := Self.MDICHILDCOUNT; end;
procedure TFORMMDICHILDREN_R(Self: TFORM; var T: TFORM; t1: INTEGER); begin T := Self.MDICHILDREN[T1];
end;
{$ENDIF}{FPC}
procedure TFORMMODALRESULT_W(Self: TFORM; T: TMODALRESULT); begin Self.MODALRESULT := T; end;
procedure TFORMMODALRESULT_R(Self: TFORM; var T: TMODALRESULT); begin T := Self.MODALRESULT; end;
procedure TFORMACTIVE_R(Self: TFORM; var T: BOOLEAN); begin T := Self.ACTIVE; end;
procedure TFORMCANVAS_R(Self: TFORM; var T: TCANVAS); begin T := Self.CANVAS; end;
{$IFNDEF CLX}
procedure TFORMCLIENTHANDLE_R(Self: TFORM; var T: Longint); begin T := Self.CLIENTHANDLE; end;
{$ENDIF}
{ Innerfuse Pascal Script Class Import Utility (runtime) }
procedure RIRegisterTFORM(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TFORM) do
begin
{$IFDEF DELPHI4UP}
RegisterVirtualConstructor(@TFORM.CREATENEW, 'CREATENEW');
{$ELSE}
RegisterConstructor(@TFORM.CREATENEW, 'CREATENEW');
{$ENDIF}
RegisterMethod(@TFORM.CLOSE, 'CLOSE');
RegisterMethod(@TFORM.HIDE, 'HIDE');
RegisterMethod(@TFORM.SHOW, 'SHOW');
RegisterMethod(@TFORM.SHOWMODAL, 'SHOWMODAL');
RegisterMethod(@TFORM.RELEASE, 'RELEASE');
RegisterPropertyHelper(@TFORMACTIVE_R, nil, 'ACTIVE');
{$IFNDEF PS_MINIVCL}
{$IFNDEF FPC}
{$IFNDEF CLX}
RegisterMethod(@TFORM.ARRANGEICONS, 'ARRANGEICONS');
RegisterMethod(@TFORM.GETFORMIMAGE, 'GETFORMIMAGE');
RegisterMethod(@TFORM.PRINT, 'PRINT');
RegisterMethod(@TFORM.SENDCANCELMODE, 'SENDCANCELMODE');
RegisterPropertyHelper(@TFORMACTIVEOLECONTROL_R, @TFORMACTIVEOLECONTROL_W, 'ACTIVEOLECONTROL');
RegisterPropertyHelper(@TFORMCLIENTHANDLE_R, nil, 'CLIENTHANDLE');
RegisterPropertyHelper(@TFORMTILEMODE_R, @TFORMTILEMODE_W, 'TILEMODE');
{$ENDIF}{CLX}
RegisterMethod(@TFORM.CASCADE, 'CASCADE');
RegisterMethod(@TFORM.NEXT, 'NEXT');
RegisterMethod(@TFORM.PREVIOUS, 'PREVIOUS');
RegisterMethod(@TFORM.TILE, 'TILE');
RegisterPropertyHelper(@TFORMACTIVEMDICHILD_R, nil, 'ACTIVEMDICHILD');
RegisterPropertyHelper(@TFORMDROPTARGET_R, @TFORMDROPTARGET_W, 'DROPTARGET');
RegisterPropertyHelper(@TFORMMDICHILDCOUNT_R, nil, 'MDICHILDCOUNT');
RegisterPropertyHelper(@TFORMMDICHILDREN_R, nil, 'MDICHILDREN');
{$ENDIF}{FPC}
RegisterMethod(@TFORM.CLOSEQUERY, 'CLOSEQUERY');
RegisterMethod(@TFORM.DEFOCUSCONTROL, 'DEFOCUSCONTROL');
RegisterMethod(@TFORM.FOCUSCONTROL, 'FOCUSCONTROL');
RegisterMethod(@TFORM.SETFOCUSEDCONTROL, 'SETFOCUSEDCONTROL');
RegisterPropertyHelper(@TFORMCANVAS_R, nil, 'CANVAS');
RegisterPropertyHelper(@TFORMMODALRESULT_R, @TFORMMODALRESULT_W, 'MODALRESULT');
{$ENDIF}{PS_MINIVCL}
end;
end;
{$IFNDEF FPC}
procedure TAPPLICATIONACTIVE_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.ACTIVE; end;
{$IFNDEF CLX}
procedure TAPPLICATIONDIALOGHANDLE_R(Self: TAPPLICATION; var T: Longint); begin T := Self.DIALOGHANDLE; end;
procedure TAPPLICATIONDIALOGHANDLE_W(Self: TAPPLICATION; T: Longint); begin Self.DIALOGHANDLE := T; end;
procedure TAPPLICATIONHANDLE_R(Self: TAPPLICATION; var T: Longint); begin T := Self.HANDLE; end;
procedure TAPPLICATIONHANDLE_W(Self: TAPPLICATION; T: Longint); begin Self.HANDLE := T; end;
procedure TAPPLICATIONUPDATEFORMATSETTINGS_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.UPDATEFORMATSETTINGS; end;
procedure TAPPLICATIONUPDATEFORMATSETTINGS_W(Self: TAPPLICATION; T: BOOLEAN); begin Self.UPDATEFORMATSETTINGS := T; end;
{$ENDIF}
{$ENDIF}{FPC}
procedure TAPPLICATIONEXENAME_R(Self: TAPPLICATION; var T: STRING); begin T := Self.EXENAME; end;
procedure TAPPLICATIONHELPFILE_R(Self: TAPPLICATION; var T: STRING); begin T := Self.HELPFILE; end;
procedure TAPPLICATIONHELPFILE_W(Self: TAPPLICATION; T: STRING); begin Self.HELPFILE := T; end;
procedure TAPPLICATIONHINT_R(Self: TAPPLICATION; var T: STRING); begin T := Self.HINT; end;
procedure TAPPLICATIONHINT_W(Self: TAPPLICATION; T: STRING); begin Self.HINT := T; end;
procedure TAPPLICATIONHINTCOLOR_R(Self: TAPPLICATION; var T: TCOLOR); begin T := Self.HINTCOLOR; end;
procedure TAPPLICATIONHINTCOLOR_W(Self: TAPPLICATION; T: TCOLOR); begin Self.HINTCOLOR := T; end;
procedure TAPPLICATIONHINTPAUSE_R(Self: TAPPLICATION; var T: INTEGER); begin T := Self.HINTPAUSE; end;
procedure TAPPLICATIONHINTPAUSE_W(Self: TAPPLICATION; T: INTEGER); begin Self.HINTPAUSE := T; end;
procedure TAPPLICATIONHINTSHORTPAUSE_R(Self: TAPPLICATION; var T: INTEGER); begin T := Self.HINTSHORTPAUSE; end;
procedure TAPPLICATIONHINTSHORTPAUSE_W(Self: TAPPLICATION; T: INTEGER); begin Self.HINTSHORTPAUSE := T; end;
procedure TAPPLICATIONHINTHIDEPAUSE_R(Self: TAPPLICATION; var T: INTEGER); begin T := Self.HINTHIDEPAUSE; end;
procedure TAPPLICATIONHINTHIDEPAUSE_W(Self: TAPPLICATION; T: INTEGER); begin Self.HINTHIDEPAUSE := T; end;
procedure TAPPLICATIONMAINFORM_R(Self: TAPPLICATION; var T: {$IFDEF DELPHI3UP}TCustomForm{$ELSE}TFORM{$ENDIF}); begin T := Self.MAINFORM; end;
procedure TAPPLICATIONSHOWHINT_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.SHOWHINT; end;
procedure TAPPLICATIONSHOWHINT_W(Self: TAPPLICATION; T: BOOLEAN); begin Self.SHOWHINT := T; end;
procedure TAPPLICATIONSHOWMAINFORM_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.SHOWMAINFORM; end;
procedure TAPPLICATIONSHOWMAINFORM_W(Self: TAPPLICATION; T: BOOLEAN); begin Self.SHOWMAINFORM := T; end;
procedure TAPPLICATIONTERMINATED_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.TERMINATED; end;
procedure TAPPLICATIONTITLE_R(Self: TAPPLICATION; var T: STRING); begin T := Self.TITLE; end;
procedure TAPPLICATIONTITLE_W(Self: TAPPLICATION; T: STRING); begin Self.TITLE := T; end;
{$IFNDEF FPC}
procedure TAPPLICATIONONACTIVATE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONACTIVATE; end;
procedure TAPPLICATIONONACTIVATE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONACTIVATE := T; end;
procedure TAPPLICATIONONDEACTIVATE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONDEACTIVATE; end;
procedure TAPPLICATIONONDEACTIVATE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONDEACTIVATE := T; end;
{$ENDIF}
procedure TAPPLICATIONONIDLE_R(Self: TAPPLICATION; var T: TIDLEEVENT); begin T := Self.ONIDLE; end;
procedure TAPPLICATIONONIDLE_W(Self: TAPPLICATION; T: TIDLEEVENT); begin Self.ONIDLE := T; end;
procedure TAPPLICATIONONHELP_R(Self: TAPPLICATION; var T: THELPEVENT); begin T := Self.ONHELP; end;
procedure TAPPLICATIONONHELP_W(Self: TAPPLICATION; T: THELPEVENT); begin Self.ONHELP := T; end;
procedure TAPPLICATIONONHINT_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONHINT; end;
procedure TAPPLICATIONONHINT_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONHINT := T; end;
{$IFNDEF FPC}
procedure TAPPLICATIONONMINIMIZE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONMINIMIZE; end;
procedure TAPPLICATIONONMINIMIZE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONMINIMIZE := T; end;
procedure TAPPLICATIONONRESTORE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONRESTORE; end;
procedure TAPPLICATIONONRESTORE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONRESTORE := T; end;
{$ENDIF}
procedure RIRegisterTAPPLICATION(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TAPPLICATION) do
begin
{$IFNDEF FPC}
RegisterMethod(@TAPPLICATION.MINIMIZE, 'MINIMIZE');
RegisterMethod(@TAPPLICATION.RESTORE, 'RESTORE');
RegisterPropertyHelper(@TAPPLICATIONACTIVE_R, nil, 'ACTIVE');
RegisterPropertyHelper(@TAPPLICATIONONACTIVATE_R, @TAPPLICATIONONACTIVATE_W, 'ONACTIVATE');
RegisterPropertyHelper(@TAPPLICATIONONDEACTIVATE_R, @TAPPLICATIONONDEACTIVATE_W, 'ONDEACTIVATE');
RegisterPropertyHelper(@TAPPLICATIONONMINIMIZE_R, @TAPPLICATIONONMINIMIZE_W, 'ONMINIMIZE');
RegisterPropertyHelper(@TAPPLICATIONONRESTORE_R, @TAPPLICATIONONRESTORE_W, 'ONRESTORE');
RegisterPropertyHelper(@TAPPLICATIONDIALOGHANDLE_R, @TAPPLICATIONDIALOGHANDLE_W, 'DIALOGHANDLE');
RegisterMethod(@TAPPLICATION.CREATEHANDLE, 'CREATEHANDLE');
RegisterMethod(@TAPPLICATION.NORMALIZETOPMOSTS, 'NORMALIZETOPMOSTS');
RegisterMethod(@TAPPLICATION.RESTORETOPMOSTS, 'RESTORETOPMOSTS');
{$IFNDEF CLX}
RegisterPropertyHelper(@TAPPLICATIONHANDLE_R, @TAPPLICATIONHANDLE_W, 'HANDLE');
RegisterPropertyHelper(@TAPPLICATIONUPDATEFORMATSETTINGS_R, @TAPPLICATIONUPDATEFORMATSETTINGS_W, 'UPDATEFORMATSETTINGS');
{$ENDIF}
{$ENDIF}
RegisterMethod(@TAPPLICATION.BRINGTOFRONT, 'BRINGTOFRONT');
RegisterMethod(@TAPPLICATION.MESSAGEBOX, 'MESSAGEBOX');
RegisterMethod(@TAPPLICATION.PROCESSMESSAGES, 'PROCESSMESSAGES');
RegisterMethod(@TAPPLICATION.TERMINATE, 'TERMINATE');
RegisterPropertyHelper(@TAPPLICATIONEXENAME_R, nil, 'EXENAME');
RegisterPropertyHelper(@TAPPLICATIONHINT_R, @TAPPLICATIONHINT_W, 'HINT');
RegisterPropertyHelper(@TAPPLICATIONMAINFORM_R, nil, 'MAINFORM');
RegisterPropertyHelper(@TAPPLICATIONSHOWHINT_R, @TAPPLICATIONSHOWHINT_W, 'SHOWHINT');
RegisterPropertyHelper(@TAPPLICATIONSHOWMAINFORM_R, @TAPPLICATIONSHOWMAINFORM_W, 'SHOWMAINFORM');
RegisterPropertyHelper(@TAPPLICATIONTERMINATED_R, nil, 'TERMINATED');
RegisterPropertyHelper(@TAPPLICATIONTITLE_R, @TAPPLICATIONTITLE_W, 'TITLE');
RegisterPropertyHelper(@TAPPLICATIONONIDLE_R, @TAPPLICATIONONIDLE_W, 'ONIDLE');
RegisterPropertyHelper(@TAPPLICATIONONHINT_R, @TAPPLICATIONONHINT_W, 'ONHINT');
{$IFNDEF PS_MINIVCL}
RegisterMethod(@TAPPLICATION.CONTROLDESTROYED, 'CONTROLDESTROYED');
RegisterMethod(@TAPPLICATION.CANCELHINT, 'CANCELHINT');
{$IFNDEF CLX}
{$IFNDEF FPC}
RegisterMethod(@TAPPLICATION.HELPCOMMAND, 'HELPCOMMAND');
{$ENDIF}
RegisterMethod(@TAPPLICATION.HELPCONTEXT, 'HELPCONTEXT');
{$IFNDEF FPC}
RegisterMethod(@TAPPLICATION.HELPJUMP, 'HELPJUMP');
{$ENDIF}
{$ENDIF}
// RegisterMethod(@TAPPLICATION.HANDLEEXCEPTION, 'HANDLEEXCEPTION');
// RegisterMethod(@TAPPLICATION.HOOKMAINWINDOW, 'HOOKMAINWINDOW');
// RegisterMethod(@TAPPLICATION.UNHOOKMAINWINDOW, 'UNHOOKMAINWINDOW');
RegisterMethod(@TAPPLICATION.HANDLEMESSAGE, 'HANDLEMESSAGE');
RegisterMethod(@TAPPLICATION.HIDEHINT, 'HIDEHINT');
RegisterMethod(@TAPPLICATION.HINTMOUSEMESSAGE, 'HINTMOUSEMESSAGE');
RegisterMethod(@TAPPLICATION.INITIALIZE, 'INITIALIZE');
RegisterMethod(@TAPPLICATION.RUN, 'RUN');
// RegisterMethod(@TAPPLICATION.SHOWEXCEPTION, 'SHOWEXCEPTION');
RegisterPropertyHelper(@TAPPLICATIONHELPFILE_R, @TAPPLICATIONHELPFILE_W, 'HELPFILE');
RegisterPropertyHelper(@TAPPLICATIONHINTCOLOR_R, @TAPPLICATIONHINTCOLOR_W, 'HINTCOLOR');
RegisterPropertyHelper(@TAPPLICATIONHINTPAUSE_R, @TAPPLICATIONHINTPAUSE_W, 'HINTPAUSE');
RegisterPropertyHelper(@TAPPLICATIONHINTSHORTPAUSE_R, @TAPPLICATIONHINTSHORTPAUSE_W, 'HINTSHORTPAUSE');
RegisterPropertyHelper(@TAPPLICATIONHINTHIDEPAUSE_R, @TAPPLICATIONHINTHIDEPAUSE_W, 'HINTHIDEPAUSE');
RegisterPropertyHelper(@TAPPLICATIONONHELP_R, @TAPPLICATIONONHELP_W, 'ONHELP');
{$ENDIF}
end;
end;
procedure RIRegister_Forms(Cl: TPSRuntimeClassImporter);
begin
{$IFNDEF PS_MINIVCL}
RIRegisterTCONTROLSCROLLBAR(cl);
RIRegisterTSCROLLBOX(cl);
{$ENDIF}
{$IFNDEF FPC} RIRegisterTScrollingWinControl(cl);{$ENDIF}
RIRegisterTForm(Cl);
{$IFNDEF PS_MINIVCL}
RIRegisterTApplication(Cl);
{$ENDIF}
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
// FPC changes by Boguslaw brandys (brandys at o2 _dot_ pl)
end.

218
Units/PascalScript/uPSR_graphics.pas Normal file
View File

@ -0,0 +1,218 @@
unit uPSR_graphics;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegisterTGRAPHICSOBJECT(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTFont(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTPEN(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTBRUSH(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCanvas(cl: TPSRuntimeClassImporter);
procedure RIRegisterTGraphic(CL: TPSRuntimeClassImporter);
procedure RIRegisterTBitmap(CL: TPSRuntimeClassImporter; Streams: Boolean);
procedure RIRegister_Graphics(Cl: TPSRuntimeClassImporter; Streams: Boolean);
implementation
{$IFNDEF FPC}
uses
Classes{$IFDEF CLX}, QGraphics{$ELSE}, Windows, Graphics{$ENDIF};
{$ELSE}
uses
Classes, Graphics,LCLType;
{$ENDIF}
{$IFNDEF CLX}
procedure TFontHandleR(Self: TFont; var T: Longint); begin T := Self.Handle; end;
procedure TFontHandleW(Self: TFont; T: Longint); begin Self.Handle := T; end;
{$ENDIF}
procedure TFontPixelsPerInchR(Self: TFont; var T: Longint); begin T := Self.PixelsPerInch; end;
procedure TFontPixelsPerInchW(Self: TFont; T: Longint); begin {$IFNDEF FPC} Self.PixelsPerInch := T;{$ENDIF} end;
procedure TFontStyleR(Self: TFont; var T: TFontStyles); begin T := Self.Style; end;
procedure TFontStyleW(Self: TFont; T: TFontStyles); begin Self.Style:= T; end;
procedure RIRegisterTFont(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TFont) do
begin
RegisterConstructor(@TFont.Create, 'CREATE');
{$IFNDEF CLX}
RegisterPropertyHelper(@TFontHandleR, @TFontHandleW, 'HANDLE');
{$ENDIF}
RegisterPropertyHelper(@TFontPixelsPerInchR, @TFontPixelsPerInchW, 'PIXELSPERINCH');
RegisterPropertyHelper(@TFontStyleR, @TFontStyleW, 'STYLE');
end;
end;
{$IFNDEF CLX}
procedure TCanvasHandleR(Self: TCanvas; var T: Longint); begin T := Self.Handle; end;
procedure TCanvasHandleW(Self: TCanvas; T: Longint); begin Self.Handle:= T; end;
{$ENDIF}
procedure TCanvasPixelsR(Self: TCanvas; var T: Longint; X,Y: Longint); begin T := Self.Pixels[X,Y]; end;
procedure TCanvasPixelsW(Self: TCanvas; T, X, Y: Longint); begin Self.Pixels[X,Y]:= T; end;
procedure RIRegisterTCanvas(cl: TPSRuntimeClassImporter); // requires TPersistent
begin
with Cl.Add(TCanvas) do
begin
{$IFNDEF FPC}
RegisterMethod(@TCanvas.Arc, 'ARC');
RegisterMethod(@TCanvas.Chord, 'CHORD');
RegisterMethod(@TCanvas.Rectangle, 'RECTANGLE');
RegisterMethod(@TCanvas.RoundRect, 'ROUNDRECT');
RegisterMethod(@TCanvas.Ellipse, 'ELLIPSE');
RegisterMethod(@TCanvas.FillRect, 'FILLRECT');
{$ENDIF}
RegisterMethod(@TCanvas.Draw, 'DRAW');
{$IFNDEF CLX}
RegisterMethod(@TCanvas.FloodFill, 'FLOODFILL');
{$ENDIF}
RegisterMethod(@TCanvas.Lineto, 'LINETO');
RegisterMethod(@TCanvas.Moveto, 'MOVETO');
RegisterMethod(@TCanvas.Pie, 'PIE');
RegisterMethod(@TCanvas.Refresh, 'REFRESH');
RegisterMethod(@TCanvas.TextHeight, 'TEXTHEIGHT');
RegisterMethod(@TCanvas.TextOut, 'TEXTOUT');
RegisterMethod(@TCanvas.TextWidth, 'TEXTWIDTH');
{$IFNDEF CLX}
RegisterPropertyHelper(@TCanvasHandleR, @TCanvasHandleW, 'HANDLE');
{$ENDIF}
RegisterPropertyHelper(@TCanvasPixelsR, @TCanvasPixelsW, 'PIXELS');
end;
end;
procedure TGRAPHICSOBJECTONCHANGE_W(Self: TGraphicsObject; T: TNotifyEvent); begin Self.OnChange := t; end;
procedure TGRAPHICSOBJECTONCHANGE_R(Self: TGraphicsObject; var T: TNotifyEvent); begin T :=Self.OnChange; end;
procedure RIRegisterTGRAPHICSOBJECT(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TGRAPHICSOBJECT) do
begin
RegisterPropertyHelper(@TGRAPHICSOBJECTONCHANGE_R, @TGRAPHICSOBJECTONCHANGE_W, 'ONCHANGE');
end;
end;
procedure RIRegisterTPEN(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TPEN) do
begin
RegisterConstructor(@TPEN.CREATE, 'CREATE');
end;
end;
procedure RIRegisterTBRUSH(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TBRUSH) do
begin
RegisterConstructor(@TBRUSH.CREATE, 'CREATE');
end;
end;
procedure TGraphicOnChange_W(Self: TGraphic; const T: TNotifyEvent); begin Self.OnChange := T; end;
procedure TGraphicOnChange_R(Self: TGraphic; var T: TNotifyEvent); begin T := Self.OnChange; end;
procedure TGraphicWidth_W(Self: TGraphic; const T: Integer); begin Self.Width := T; end;
procedure TGraphicWidth_R(Self: TGraphic; var T: Integer); begin T := Self.Width; end;
procedure TGraphicModified_W(Self: TGraphic; const T: Boolean); begin Self.Modified := T; end;
procedure TGraphicModified_R(Self: TGraphic; var T: Boolean); begin T := Self.Modified; end;
procedure TGraphicHeight_W(Self: TGraphic; const T: Integer); begin Self.Height := T; end;
procedure TGraphicHeight_R(Self: TGraphic; var T: Integer); begin T := Self.Height; end;
procedure TGraphicEmpty_R(Self: TGraphic; var T: Boolean); begin T := Self.Empty; end;
procedure RIRegisterTGraphic(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TGraphic) do
begin
RegisterVirtualConstructor(@TGraphic.Create, 'Create');
RegisterVirtualMethod(@TGraphic.LoadFromFile, 'LoadFromFile');
RegisterVirtualMethod(@TGraphic.SaveToFile, 'SaveToFile');
RegisterPropertyHelper(@TGraphicEmpty_R,nil,'Empty');
RegisterPropertyHelper(@TGraphicHeight_R,@TGraphicHeight_W,'Height');
RegisterPropertyHelper(@TGraphicWidth_R,@TGraphicWidth_W,'Width');
RegisterPropertyHelper(@TGraphicOnChange_R,@TGraphicOnChange_W,'OnChange');
{$IFNDEF PS_MINIVCL}
RegisterPropertyHelper(@TGraphicModified_R,@TGraphicModified_W,'Modified');
{$ENDIF}
end;
end;
procedure TBitmapTransparentColor_R(Self: TBitmap; var T: TColor); begin T := Self.TransparentColor; end;
{$IFNDEF CLX}
{$IFNDEF FPC}
procedure TBitmapIgnorePalette_W(Self: TBitmap; const T: Boolean); begin Self.IgnorePalette := T; end;
procedure TBitmapIgnorePalette_R(Self: TBitmap; var T: Boolean); begin T := Self.IgnorePalette; end;
{$ENDIF}
procedure TBitmapPalette_W(Self: TBitmap; const T: HPALETTE); begin Self.Palette := T; end;
procedure TBitmapPalette_R(Self: TBitmap; var T: HPALETTE); begin T := Self.Palette; end;
{$ENDIF}
procedure TBitmapMonochrome_W(Self: TBitmap; const T: Boolean); begin Self.Monochrome := T; end;
procedure TBitmapMonochrome_R(Self: TBitmap; var T: Boolean); begin T := Self.Monochrome; end;
{$IFNDEF CLX}
procedure TBitmapHandle_W(Self: TBitmap; const T: HBITMAP); begin Self.Handle := T; end;
procedure TBitmapHandle_R(Self: TBitmap; var T: HBITMAP); begin T := Self.Handle; end;
{$ENDIF}
procedure TBitmapCanvas_R(Self: TBitmap; var T: TCanvas); begin T := Self.Canvas; end;
procedure RIRegisterTBitmap(CL: TPSRuntimeClassImporter; Streams: Boolean);
begin
with CL.Add(TBitmap) do
begin
if Streams then begin
RegisterMethod(@TBitmap.LoadFromStream, 'LoadFromStream');
RegisterMethod(@TBitmap.SaveToStream, 'SaveToStream');
end;
RegisterPropertyHelper(@TBitmapCanvas_R,nil,'Canvas');
{$IFNDEF CLX}
RegisterPropertyHelper(@TBitmapHandle_R,@TBitmapHandle_W,'Handle');
{$ENDIF}
{$IFNDEF PS_MINIVCL}
{$IFNDEF FPC}
RegisterMethod(@TBitmap.Dormant, 'Dormant');
{$ENDIF}
RegisterMethod(@TBitmap.FreeImage, 'FreeImage');
{$IFNDEF CLX}
RegisterMethod(@TBitmap.LoadFromClipboardFormat, 'LoadFromClipboardFormat');
{$ENDIF}
RegisterMethod(@TBitmap.LoadFromResourceName, 'LoadFromResourceName');
RegisterMethod(@TBitmap.LoadFromResourceID, 'LoadFromResourceID');
{$IFNDEF CLX}
RegisterMethod(@TBitmap.ReleaseHandle, 'ReleaseHandle');
RegisterMethod(@TBitmap.ReleasePalette, 'ReleasePalette');
RegisterMethod(@TBitmap.SaveToClipboardFormat, 'SaveToClipboardFormat');
RegisterPropertyHelper(@TBitmapMonochrome_R,@TBitmapMonochrome_W,'Monochrome');
RegisterPropertyHelper(@TBitmapPalette_R,@TBitmapPalette_W,'Palette');
{$IFNDEF FPC}
RegisterPropertyHelper(@TBitmapIgnorePalette_R,@TBitmapIgnorePalette_W,'IgnorePalette');
{$ENDIF}
{$ENDIF}
RegisterPropertyHelper(@TBitmapTransparentColor_R,nil,'TransparentColor');
{$ENDIF}
end;
end;
procedure RIRegister_Graphics(Cl: TPSRuntimeClassImporter; Streams: Boolean);
begin
RIRegisterTGRAPHICSOBJECT(cl);
RIRegisterTFont(Cl);
RIRegisterTCanvas(cl);
RIRegisterTPEN(cl);
RIRegisterTBRUSH(cl);
RIRegisterTGraphic(CL);
RIRegisterTBitmap(CL, Streams);
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

460
Units/PascalScript/uPSR_menus.pas Normal file
View File

@ -0,0 +1,460 @@
Unit uPSR_menus;
{$I PascalScript.inc}
Interface
Uses uPSRuntime;
procedure RIRegister_Menus_Routines(S: TPSExec);
{$IFNDEF FPC}
procedure RIRegisterTMENUITEMSTACK(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTPOPUPLIST(Cl: TPSRuntimeClassImporter);
{$ENDIF}
procedure RIRegisterTPOPUPMENU(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTMAINMENU(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTMENU(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTMENUITEM(Cl: TPSRuntimeClassImporter);
procedure RIRegister_Menus(CL: TPSRuntimeClassImporter);
implementation
{$IFDEF LINUX}
{$IFNDEF FPC}
Uses
Libc, SysUtils, Classes, QControls, QMenus, QGraphics;
{$ELSE}
Uses
Libc, SysUtils, Classes, Controls, Menus, Graphics, LCLType, ImgList;
{$ENDIF}
{$ELSE}
Uses {$IFNDEF FPC}WINDOWS,{$ELSE} LCLType,{$ENDIF} SYSUTILS, CLASSES, CONTNRS, MESSAGES, GRAPHICS, IMGLIST, ACTNLIST, Menus;
{$ENDIF}
{$IFNDEF FPC}
procedure TPOPUPLISTWINDOW_R(Self: TPOPUPLIST; var T: HWND);
begin T := Self.WINDOW; end;
{$ENDIF}
procedure TPOPUPMENUONPOPUP_W(Self: TPOPUPMENU; const T: TNOTIFYEVENT);
begin Self.ONPOPUP := T; end;
procedure TPOPUPMENUONPOPUP_R(Self: TPOPUPMENU; var T: TNOTIFYEVENT);
begin T := Self.ONPOPUP; end;
{$IFNDEF FPC}
procedure TPOPUPMENUTRACKBUTTON_W(Self: TPOPUPMENU; const T: TTRACKBUTTON);
begin Self.TRACKBUTTON := T; end;
procedure TPOPUPMENUTRACKBUTTON_R(Self: TPOPUPMENU; var T: TTRACKBUTTON);
begin T := Self.TRACKBUTTON; end;
procedure TPOPUPMENUMENUANIMATION_W(Self: TPOPUPMENU; const T: TMENUANIMATION);
begin Self.MENUANIMATION := T; end;
procedure TPOPUPMENUMENUANIMATION_R(Self: TPOPUPMENU; var T: TMENUANIMATION);
begin T := Self.MENUANIMATION; end;
procedure TPOPUPMENUHELPCONTEXT_W(Self: TPOPUPMENU; const T: THELPCONTEXT);
begin Self.HELPCONTEXT := T; end;
procedure TPOPUPMENUHELPCONTEXT_R(Self: TPOPUPMENU; var T: THELPCONTEXT);
begin T := Self.HELPCONTEXT; end;
{$ENDIF}
procedure TPOPUPMENUAUTOPOPUP_W(Self: TPOPUPMENU; const T: BOOLEAN);
begin Self.AUTOPOPUP := T; end;
procedure TPOPUPMENUAUTOPOPUP_R(Self: TPOPUPMENU; var T: BOOLEAN);
begin T := Self.AUTOPOPUP; end;
{$IFNDEF FPC}
procedure TPOPUPMENUALIGNMENT_W(Self: TPOPUPMENU; const T: TPOPUPALIGNMENT);
begin Self.ALIGNMENT := T; end;
procedure TPOPUPMENUALIGNMENT_R(Self: TPOPUPMENU; var T: TPOPUPALIGNMENT);
begin T := Self.ALIGNMENT; end;
{$ENDIF}
procedure TPOPUPMENUPOPUPCOMPONENT_W(Self: TPOPUPMENU; const T: TCOMPONENT);
begin Self.POPUPCOMPONENT := T; end;
procedure TPOPUPMENUPOPUPCOMPONENT_R(Self: TPOPUPMENU; var T: TCOMPONENT);
begin T := Self.POPUPCOMPONENT; end;
{$IFNDEF FPC}
procedure TMAINMENUAUTOMERGE_W(Self: TMAINMENU; const T: BOOLEAN);
begin Self.AUTOMERGE := T; end;
procedure TMAINMENUAUTOMERGE_R(Self: TMAINMENU; var T: BOOLEAN);
begin T := Self.AUTOMERGE; end;
{$ENDIF}
procedure TMENUITEMS_R(Self: TMENU; var T: TMENUITEM);
begin T := Self.ITEMS; end;
{$IFNDEF FPC}
procedure TMENUWINDOWHANDLE_W(Self: TMENU; const T: HWND);
begin Self.WINDOWHANDLE := T; end;
procedure TMENUWINDOWHANDLE_R(Self: TMENU; var T: HWND);
begin T := Self.WINDOWHANDLE; end;
procedure TMENUPARENTBIDIMODE_W(Self: TMENU; const T: BOOLEAN);
begin Self.PARENTBIDIMODE := T; end;
procedure TMENUPARENTBIDIMODE_R(Self: TMENU; var T: BOOLEAN);
begin T := Self.PARENTBIDIMODE; end;
procedure TMENUOWNERDRAW_W(Self: TMENU; const T: BOOLEAN);
begin Self.OWNERDRAW := T; end;
procedure TMENUOWNERDRAW_R(Self: TMENU; var T: BOOLEAN);
begin T := Self.OWNERDRAW; end;
procedure TMENUBIDIMODE_W(Self: TMENU; const T: TBIDIMODE);
begin Self.BIDIMODE := T; end;
procedure TMENUBIDIMODE_R(Self: TMENU; var T: TBIDIMODE);
begin T := Self.BIDIMODE; end;
procedure TMENUAUTOLINEREDUCTION_W(Self: TMENU; const T: TMENUAUTOFLAG);
begin Self.AUTOLINEREDUCTION := T; end;
procedure TMENUAUTOLINEREDUCTION_R(Self: TMENU; var T: TMENUAUTOFLAG);
begin T := Self.AUTOLINEREDUCTION; end;
procedure TMENUAUTOHOTKEYS_W(Self: TMENU; const T: TMENUAUTOFLAG);
begin Self.AUTOHOTKEYS := T; end;
procedure TMENUAUTOHOTKEYS_R(Self: TMENU; var T: TMENUAUTOFLAG);
begin T := Self.AUTOHOTKEYS; end;
{$ENDIF}
procedure TMENUHANDLE_R(Self: TMENU; var T: HMENU);
begin T := Self.HANDLE; end;
procedure TMENUIMAGES_W(Self: TMENU; const T: TCUSTOMIMAGELIST);
begin Self.IMAGES := T; end;
procedure TMENUIMAGES_R(Self: TMENU; var T: TCUSTOMIMAGELIST);
begin T := Self.IMAGES; end;
{$IFNDEF FPC}
procedure TMENUITEMONMEASUREITEM_W(Self: TMENUITEM; const T: TMENUMEASUREITEMEVENT);
begin Self.ONMEASUREITEM := T; end;
procedure TMENUITEMONMEASUREITEM_R(Self: TMENUITEM; var T: TMENUMEASUREITEMEVENT);
begin T := Self.ONMEASUREITEM; end;
procedure TMENUITEMONADVANCEDDRAWITEM_W(Self: TMENUITEM; const T: TADVANCEDMENUDRAWITEMEVENT);
begin Self.ONADVANCEDDRAWITEM := T; end;
procedure TMENUITEMONADVANCEDDRAWITEM_R(Self: TMENUITEM; var T: TADVANCEDMENUDRAWITEMEVENT);
begin T := Self.ONADVANCEDDRAWITEM; end;
procedure TMENUITEMONDRAWITEM_W(Self: TMENUITEM; const T: TMENUDRAWITEMEVENT);
begin Self.ONDRAWITEM := T; end;
procedure TMENUITEMONDRAWITEM_R(Self: TMENUITEM; var T: TMENUDRAWITEMEVENT);
begin T := Self.ONDRAWITEM; end;
{$ENDIF}
procedure TMENUITEMONCLICK_W(Self: TMENUITEM; const T: TNOTIFYEVENT);
begin Self.ONCLICK := T; end;
procedure TMENUITEMONCLICK_R(Self: TMENUITEM; var T: TNOTIFYEVENT);
begin T := Self.ONCLICK; end;
procedure TMENUITEMVISIBLE_W(Self: TMENUITEM; const T: BOOLEAN);
begin Self.VISIBLE := T; end;
procedure TMENUITEMVISIBLE_R(Self: TMENUITEM; var T: BOOLEAN);
begin T := Self.VISIBLE; end;
procedure TMENUITEMSHORTCUT_W(Self: TMENUITEM; const T: TSHORTCUT);
begin Self.SHORTCUT := T; end;
procedure TMENUITEMSHORTCUT_R(Self: TMENUITEM; var T: TSHORTCUT);
begin T := Self.SHORTCUT; end;
procedure TMENUITEMRADIOITEM_W(Self: TMENUITEM; const T: BOOLEAN);
begin Self.RADIOITEM := T; end;
procedure TMENUITEMRADIOITEM_R(Self: TMENUITEM; var T: BOOLEAN);
begin T := Self.RADIOITEM; end;
procedure TMENUITEMIMAGEINDEX_W(Self: TMENUITEM; const T: TIMAGEINDEX);
begin Self.IMAGEINDEX := T; end;
procedure TMENUITEMIMAGEINDEX_R(Self: TMENUITEM; var T: TIMAGEINDEX);
begin T := Self.IMAGEINDEX; end;
procedure TMENUITEMHINT_W(Self: TMENUITEM; const T: STRING);
begin Self.HINT := T; end;
procedure TMENUITEMHINT_R(Self: TMENUITEM; var T: STRING);
begin T := Self.HINT; end;
procedure TMENUITEMHELPCONTEXT_W(Self: TMENUITEM; const T: THELPCONTEXT);
begin Self.HELPCONTEXT := T; end;
procedure TMENUITEMHELPCONTEXT_R(Self: TMENUITEM; var T: THELPCONTEXT);
begin T := Self.HELPCONTEXT; end;
procedure TMENUITEMGROUPINDEX_W(Self: TMENUITEM; const T: BYTE);
begin Self.GROUPINDEX := T; end;
procedure TMENUITEMGROUPINDEX_R(Self: TMENUITEM; var T: BYTE);
begin T := Self.GROUPINDEX; end;
procedure TMENUITEMENABLED_W(Self: TMENUITEM; const T: BOOLEAN);
begin Self.ENABLED := T; end;
procedure TMENUITEMENABLED_R(Self: TMENUITEM; var T: BOOLEAN);
begin T := Self.ENABLED; end;
procedure TMENUITEMDEFAULT_W(Self: TMENUITEM; const T: BOOLEAN);
begin Self.DEFAULT := T; end;
procedure TMENUITEMDEFAULT_R(Self: TMENUITEM; var T: BOOLEAN);
begin T := Self.DEFAULT; end;
procedure TMENUITEMSUBMENUIMAGES_W(Self: TMENUITEM; const T: TCUSTOMIMAGELIST);
begin Self.SUBMENUIMAGES := T; end;
procedure TMENUITEMSUBMENUIMAGES_R(Self: TMENUITEM; var T: TCUSTOMIMAGELIST);
begin T := Self.SUBMENUIMAGES; end;
procedure TMENUITEMCHECKED_W(Self: TMENUITEM; const T: BOOLEAN);
begin Self.CHECKED := T; end;
procedure TMENUITEMCHECKED_R(Self: TMENUITEM; var T: BOOLEAN);
begin T := Self.CHECKED; end;
procedure TMENUITEMCAPTION_W(Self: TMENUITEM; const T: STRING);
begin Self.CAPTION := T; end;
procedure TMENUITEMCAPTION_R(Self: TMENUITEM; var T: STRING);
begin T := Self.CAPTION; end;
procedure TMENUITEMBITMAP_W(Self: TMENUITEM; const T: TBITMAP);
begin Self.BITMAP := T; end;
procedure TMENUITEMBITMAP_R(Self: TMENUITEM; var T: TBITMAP);
begin T := Self.BITMAP; end;
{$IFNDEF FPC}
procedure TMENUITEMAUTOLINEREDUCTION_W(Self: TMENUITEM; const T: TMENUITEMAUTOFLAG);
begin Self.AUTOLINEREDUCTION := T; end;
procedure TMENUITEMAUTOLINEREDUCTION_R(Self: TMENUITEM; var T: TMENUITEMAUTOFLAG);
begin T := Self.AUTOLINEREDUCTION; end;
procedure TMENUITEMAUTOHOTKEYS_W(Self: TMENUITEM; const T: TMENUITEMAUTOFLAG);
begin Self.AUTOHOTKEYS := T; end;
procedure TMENUITEMAUTOHOTKEYS_R(Self: TMENUITEM; var T: TMENUITEMAUTOFLAG);
begin T := Self.AUTOHOTKEYS; end;
{$ENDIF}
procedure TMENUITEMACTION_W(Self: TMENUITEM; const T: TBASICACTION);
begin Self.ACTION := T; end;
procedure TMENUITEMACTION_R(Self: TMENUITEM; var T: TBASICACTION);
begin T := Self.ACTION; end;
procedure TMENUITEMPARENT_R(Self: TMENUITEM; var T: TMENUITEM);
begin T := Self.PARENT; end;
procedure TMENUITEMMENUINDEX_W(Self: TMENUITEM; const T: INTEGER);
begin Self.MENUINDEX := T; end;
procedure TMENUITEMMENUINDEX_R(Self: TMENUITEM; var T: INTEGER);
begin T := Self.MENUINDEX; end;
procedure TMENUITEMITEMS_R(Self: TMENUITEM; var T: TMENUITEM; const t1: INTEGER);
begin T := Self.ITEMS[t1]; end;
procedure TMENUITEMCOUNT_R(Self: TMENUITEM; var T: INTEGER);
begin T := Self.COUNT; end;
procedure TMENUITEMHANDLE_R(Self: TMENUITEM; var T: HMENU);
begin T := Self.HANDLE; end;
procedure TMENUITEMCOMMAND_R(Self: TMENUITEM; var T: WORD);
begin T := Self.COMMAND; end;
procedure RIRegister_Menus_Routines(S: TPSExec);
begin
S.RegisterDelphiFunction(@SHORTCUT, 'SHORTCUT', cdRegister);
S.RegisterDelphiFunction(@SHORTCUTTOKEY, 'SHORTCUTTOKEY', cdRegister);
{$IFNDEF FPC}
S.RegisterDelphiFunction(@SHORTCUTTOTEXT, 'SHORTCUTTOTEXT', cdRegister);
S.RegisterDelphiFunction(@TEXTTOSHORTCUT, 'TEXTTOSHORTCUT', cdRegister);
S.RegisterDelphiFunction(@NEWMENU, 'NEWMENU', cdRegister);
S.RegisterDelphiFunction(@NEWPOPUPMENU, 'NEWPOPUPMENU', cdRegister);
S.RegisterDelphiFunction(@NEWSUBMENU, 'NEWSUBMENU', cdRegister);
S.RegisterDelphiFunction(@NEWITEM, 'NEWITEM', cdRegister);
S.RegisterDelphiFunction(@NEWLINE, 'NEWLINE', cdRegister);
S.RegisterDelphiFunction(@DRAWMENUITEM, 'DRAWMENUITEM', cdRegister);
{$ENDIF}
end;
{$IFNDEF FPC}
procedure RIRegisterTMENUITEMSTACK(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TMENUITEMSTACK) do
begin
RegisterMethod(@TMENUITEMSTACK.CLEARITEM, 'CLEARITEM');
end;
end;
procedure RIRegisterTPOPUPLIST(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TPOPUPLIST) do
begin
RegisterPropertyHelper(@TPOPUPLISTWINDOW_R,nil,'WINDOW');
RegisterMethod(@TPOPUPLIST.ADD, 'ADD');
RegisterMethod(@TPOPUPLIST.REMOVE, 'REMOVE');
end;
end;
{$ENDIF}
procedure RIRegisterTPOPUPMENU(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TPOPUPMENU) do
begin
RegisterConstructor(@TPOPUPMENU.CREATE, 'CREATE');
RegisterVirtualMethod(@TPOPUPMENU.POPUP, 'POPUP');
RegisterPropertyHelper(@TPOPUPMENUPOPUPCOMPONENT_R,@TPOPUPMENUPOPUPCOMPONENT_W,'POPUPCOMPONENT');
RegisterEventPropertyHelper(@TPOPUPMENUONPOPUP_R,@TPOPUPMENUONPOPUP_W,'ONPOPUP');
{$IFNDEF FPC}
RegisterPropertyHelper(@TPOPUPMENUALIGNMENT_R,@TPOPUPMENUALIGNMENT_W,'ALIGNMENT');
RegisterPropertyHelper(@TPOPUPMENUAUTOPOPUP_R,@TPOPUPMENUAUTOPOPUP_W,'AUTOPOPUP');
RegisterPropertyHelper(@TPOPUPMENUHELPCONTEXT_R,@TPOPUPMENUHELPCONTEXT_W,'HELPCONTEXT');
RegisterPropertyHelper(@TPOPUPMENUMENUANIMATION_R,@TPOPUPMENUMENUANIMATION_W,'MENUANIMATION');
RegisterPropertyHelper(@TPOPUPMENUTRACKBUTTON_R,@TPOPUPMENUTRACKBUTTON_W,'TRACKBUTTON');
{$ENDIF}
end;
end;
procedure RIRegisterTMAINMENU(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TMAINMENU) do
begin
{$IFNDEF FPC}
RegisterMethod(@TMAINMENU.MERGE, 'MERGE');
RegisterMethod(@TMAINMENU.UNMERGE, 'UNMERGE');
RegisterMethod(@TMAINMENU.POPULATEOLE2MENU, 'POPULATEOLE2MENU');
RegisterMethod(@TMAINMENU.GETOLE2ACCELERATORTABLE, 'GETOLE2ACCELERATORTABLE');
RegisterMethod(@TMAINMENU.SETOLE2MENUHANDLE, 'SETOLE2MENUHANDLE');
RegisterPropertyHelper(@TMAINMENUAUTOMERGE_R,@TMAINMENUAUTOMERGE_W,'AUTOMERGE');
{$ENDIF}
end;
end;
procedure RIRegisterTMENU(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TMENU) do
begin
RegisterConstructor(@TMENU.CREATE, 'CREATE');
RegisterMethod(@TMENU.DISPATCHCOMMAND, 'DISPATCHCOMMAND');
RegisterMethod(@TMENU.FINDITEM, 'FINDITEM');
RegisterPropertyHelper(@TMENUIMAGES_R,@TMENUIMAGES_W,'IMAGES');
RegisterMethod(@TMENU.ISRIGHTTOLEFT, 'ISRIGHTTOLEFT');
RegisterPropertyHelper(@TMENUHANDLE_R,nil,'HANDLE');
RegisterPropertyHelper(@TMENUITEMS_R,nil,'ITEMS');
{$IFNDEF FPC}
RegisterMethod(@TMENU.DISPATCHPOPUP, 'DISPATCHPOPUP');
RegisterMethod(@TMENU.PARENTBIDIMODECHANGED, 'PARENTBIDIMODECHANGED');
RegisterMethod(@TMENU.PROCESSMENUCHAR, 'PROCESSMENUCHAR');
RegisterPropertyHelper(@TMENUAUTOHOTKEYS_R,@TMENUAUTOHOTKEYS_W,'AUTOHOTKEYS');
RegisterPropertyHelper(@TMENUAUTOLINEREDUCTION_R,@TMENUAUTOLINEREDUCTION_W,'AUTOLINEREDUCTION');
RegisterPropertyHelper(@TMENUBIDIMODE_R,@TMENUBIDIMODE_W,'BIDIMODE');
RegisterMethod(@TMENU.GETHELPCONTEXT, 'GETHELPCONTEXT');
RegisterPropertyHelper(@TMENUOWNERDRAW_R,@TMENUOWNERDRAW_W,'OWNERDRAW');
RegisterPropertyHelper(@TMENUPARENTBIDIMODE_R,@TMENUPARENTBIDIMODE_W,'PARENTBIDIMODE');
RegisterPropertyHelper(@TMENUWINDOWHANDLE_R,@TMENUWINDOWHANDLE_W,'WINDOWHANDLE');
{$ENDIF}
end;
end;
procedure RIRegisterTMENUITEM(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TMENUITEM) do
begin
RegisterConstructor(@TMENUITEM.CREATE, 'CREATE');
RegisterVirtualMethod(@TMENUITEM.INITIATEACTION, 'INITIATEACTION');
RegisterMethod(@TMENUITEM.INSERT, 'INSERT');
RegisterMethod(@TMENUITEM.DELETE, 'DELETE');
RegisterMethod(@TMENUITEM.CLEAR, 'CLEAR');
RegisterVirtualMethod(@TMENUITEM.CLICK, 'CLICK');
{$IFNDEF FPC}
RegisterMethod(@TMENUITEM.FIND, 'FIND');
RegisterMethod(@TMENUITEM.NEWTOPLINE, 'NEWTOPLINE');
RegisterMethod(@TMENUITEM.NEWBOTTOMLINE, 'NEWBOTTOMLINE');
RegisterMethod(@TMENUITEM.INSERTNEWLINEBEFORE, 'INSERTNEWLINEBEFORE');
RegisterMethod(@TMENUITEM.INSERTNEWLINEAFTER, 'INSERTNEWLINEAFTER');
RegisterMethod(@TMENUITEM.RETHINKHOTKEYS, 'RETHINKHOTKEYS');
RegisterMethod(@TMENUITEM.RETHINKLINES, 'RETHINKLINES');
RegisterMethod(@TMENUITEM.ISLINE, 'ISLINE');
{$ENDIF}
RegisterMethod(@TMENUITEM.INDEXOF, 'INDEXOF');
RegisterMethod(@TMENUITEM.GETIMAGELIST, 'GETIMAGELIST');
RegisterMethod(@TMENUITEM.GETPARENTCOMPONENT, 'GETPARENTCOMPONENT');
RegisterMethod(@TMENUITEM.GETPARENTMENU, 'GETPARENTMENU');
RegisterMethod(@TMENUITEM.HASPARENT, 'HASPARENT');
RegisterMethod(@TMENUITEM.ADD, 'ADD');
RegisterMethod(@TMENUITEM.REMOVE, 'REMOVE');
{$IFNDEF FPC}
RegisterPropertyHelper(@TMENUITEMAUTOHOTKEYS_R,@TMENUITEMAUTOHOTKEYS_W,'AUTOHOTKEYS');
RegisterPropertyHelper(@TMENUITEMAUTOLINEREDUCTION_R,@TMENUITEMAUTOLINEREDUCTION_W,'AUTOLINEREDUCTION');
RegisterEventPropertyHelper(@TMENUITEMONDRAWITEM_R,@TMENUITEMONDRAWITEM_W,'ONDRAWITEM');
RegisterEventPropertyHelper(@TMENUITEMONADVANCEDDRAWITEM_R,@TMENUITEMONADVANCEDDRAWITEM_W,'ONADVANCEDDRAWITEM');
RegisterEventPropertyHelper(@TMENUITEMONMEASUREITEM_R,@TMENUITEMONMEASUREITEM_W,'ONMEASUREITEM');
{$ENDIF}
RegisterPropertyHelper(@TMENUITEMCOMMAND_R,nil,'COMMAND');
RegisterPropertyHelper(@TMENUITEMHANDLE_R,nil,'HANDLE');
RegisterPropertyHelper(@TMENUITEMCOUNT_R,nil,'COUNT');
RegisterPropertyHelper(@TMENUITEMITEMS_R,nil,'ITEMS');
RegisterPropertyHelper(@TMENUITEMMENUINDEX_R,@TMENUITEMMENUINDEX_W,'MENUINDEX');
RegisterPropertyHelper(@TMENUITEMPARENT_R,nil,'PARENT');
RegisterPropertyHelper(@TMENUITEMACTION_R,@TMENUITEMACTION_W,'ACTION');
RegisterPropertyHelper(@TMENUITEMBITMAP_R,@TMENUITEMBITMAP_W,'BITMAP');
RegisterPropertyHelper(@TMENUITEMCAPTION_R,@TMENUITEMCAPTION_W,'CAPTION');
RegisterPropertyHelper(@TMENUITEMCHECKED_R,@TMENUITEMCHECKED_W,'CHECKED');
RegisterPropertyHelper(@TMENUITEMSUBMENUIMAGES_R,@TMENUITEMSUBMENUIMAGES_W,'SUBMENUIMAGES');
RegisterPropertyHelper(@TMENUITEMDEFAULT_R,@TMENUITEMDEFAULT_W,'DEFAULT');
RegisterPropertyHelper(@TMENUITEMENABLED_R,@TMENUITEMENABLED_W,'ENABLED');
RegisterPropertyHelper(@TMENUITEMGROUPINDEX_R,@TMENUITEMGROUPINDEX_W,'GROUPINDEX');
RegisterPropertyHelper(@TMENUITEMHELPCONTEXT_R,@TMENUITEMHELPCONTEXT_W,'HELPCONTEXT');
RegisterPropertyHelper(@TMENUITEMHINT_R,@TMENUITEMHINT_W,'HINT');
RegisterPropertyHelper(@TMENUITEMIMAGEINDEX_R,@TMENUITEMIMAGEINDEX_W,'IMAGEINDEX');
RegisterPropertyHelper(@TMENUITEMRADIOITEM_R,@TMENUITEMRADIOITEM_W,'RADIOITEM');
RegisterPropertyHelper(@TMENUITEMSHORTCUT_R,@TMENUITEMSHORTCUT_W,'SHORTCUT');
RegisterPropertyHelper(@TMENUITEMVISIBLE_R,@TMENUITEMVISIBLE_W,'VISIBLE');
RegisterEventPropertyHelper(@TMENUITEMONCLICK_R,@TMENUITEMONCLICK_W,'ONCLICK');
end;
end;
procedure RIRegister_Menus(CL: TPSRuntimeClassImporter);
begin
RIRegisterTMENUITEM(Cl);
RIRegisterTMENU(Cl);
RIRegisterTPOPUPMENU(Cl);
RIRegisterTMAINMENU(Cl);
{$IFNDEF FPC}
RIRegisterTPOPUPLIST(Cl);
RIRegisterTMENUITEMSTACK(Cl);
{$ENDIF}
end;
end.

85
Units/PascalScript/uPSR_std.pas Normal file
View File

@ -0,0 +1,85 @@
unit uPSR_std;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegisterTObject(CL: TPSRuntimeClassImporter);
procedure RIRegisterTPersistent(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTComponent(Cl: TPSRuntimeClassImporter);
procedure RIRegister_Std(Cl: TPSRuntimeClassImporter);
implementation
uses
Classes;
procedure RIRegisterTObject(CL: TPSRuntimeClassImporter);
begin
with cl.Add(TObject) do
begin
RegisterConstructor(@TObject.Create, 'CREATE');
RegisterMethod(@TObject.Free, 'FREE');
end;
end;
procedure RIRegisterTPersistent(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TPersistent) do
begin
RegisterVirtualMethod(@TPersistent.Assign, 'ASSIGN');
end;
end;
procedure TComponentOwnerR(Self: TComponent; var T: TComponent); begin T := Self.Owner; end;
procedure TCOMPONENTCOMPONENTS_R(Self: TCOMPONENT; var T: TCOMPONENT; t1: INTEGER); begin T := Self.COMPONENTS[t1]; end;
procedure TCOMPONENTCOMPONENTCOUNT_R(Self: TCOMPONENT; var T: INTEGER); begin t := Self.COMPONENTCOUNT; end;
procedure TCOMPONENTCOMPONENTINDEX_R(Self: TCOMPONENT; var T: INTEGER); begin t := Self.COMPONENTINDEX; end;
procedure TCOMPONENTCOMPONENTINDEX_W(Self: TCOMPONENT; T: INTEGER); begin Self.COMPONENTINDEX := t; end;
procedure TCOMPONENTCOMPONENTSTATE_R(Self: TCOMPONENT; var T: TCOMPONENTSTATE); begin t := Self.COMPONENTSTATE; end;
procedure TCOMPONENTDESIGNINFO_R(Self: TCOMPONENT; var T: LONGINT); begin t := Self.DESIGNINFO; end;
procedure TCOMPONENTDESIGNINFO_W(Self: TCOMPONENT; T: LONGINT); begin Self.DESIGNINFO := t; end;
procedure RIRegisterTComponent(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TComponent) do
begin
RegisterMethod(@TComponent.FindComponent, 'FINDCOMPONENT');
RegisterVirtualConstructor(@TComponent.Create, 'CREATE');
RegisterPropertyHelper(@TComponentOwnerR, nil, 'OWNER');
RegisterMethod(@TCOMPONENT.DESTROYCOMPONENTS, 'DESTROYCOMPONENTS');
RegisterPropertyHelper(@TCOMPONENTCOMPONENTS_R, nil, 'COMPONENTS');
RegisterPropertyHelper(@TCOMPONENTCOMPONENTCOUNT_R, nil, 'COMPONENTCOUNT');
RegisterPropertyHelper(@TCOMPONENTCOMPONENTINDEX_R, @TCOMPONENTCOMPONENTINDEX_W, 'COMPONENTINDEX');
RegisterPropertyHelper(@TCOMPONENTCOMPONENTSTATE_R, nil, 'COMPONENTSTATE');
RegisterPropertyHelper(@TCOMPONENTDESIGNINFO_R, @TCOMPONENTDESIGNINFO_W, 'DESIGNINFO');
end;
end;
procedure RIRegister_Std(Cl: TPSRuntimeClassImporter);
begin
RIRegisterTObject(CL);
RIRegisterTPersistent(Cl);
RIRegisterTComponent(Cl);
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

287
Units/PascalScript/uPSR_stdctrls.pas Normal file
View File

@ -0,0 +1,287 @@
{ STDCtrls import unit }
unit uPSR_stdctrls;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegisterTCUSTOMGROUPBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTGROUPBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCUSTOMLABEL(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTLABEL(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCUSTOMEDIT(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTEDIT(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCUSTOMMEMO(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTMEMO(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCUSTOMCOMBOBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCOMBOBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTBUTTONCONTROL(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTBUTTON(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCUSTOMCHECKBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCHECKBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTRADIOBUTTON(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCUSTOMLISTBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTLISTBOX(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTSCROLLBAR(Cl: TPSRuntimeClassImporter);
procedure RIRegister_stdctrls(cl: TPSRuntimeClassImporter);
implementation
uses
sysutils, classes{$IFDEF CLX}, QControls, QStdCtrls, QGraphics{$ELSE}, controls, stdctrls, Graphics{$ENDIF}{$IFDEF FPC},buttons{$ENDIF};
procedure RIRegisterTCUSTOMGROUPBOX(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TCUSTOMGROUPBOX);
end;
procedure RIRegisterTGROUPBOX(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TGROUPBOX);
end;
{$IFNDEF CLX}
procedure TCUSTOMLABELCANVAS_R(Self: TCUSTOMLABEL; var T: TCanvas); begin T := Self.CANVAS; end;
{$ENDIF}
procedure RIRegisterTCUSTOMLABEL(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TCUSTOMLABEL) do
begin
{$IFNDEF PS_MINIVCL}
{$IFNDEF CLX}
RegisterPropertyHelper(@TCUSTOMLABELCANVAS_R, nil, 'CANVAS');
{$ENDIF}
{$ENDIF}
end;
end;
procedure RIRegisterTLABEL(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TLABEL);
end;
procedure TCUSTOMEDITMODIFIED_R(Self: TCUSTOMEDIT; var T: BOOLEAN); begin T := Self.MODIFIED; end;
procedure TCUSTOMEDITMODIFIED_W(Self: TCUSTOMEDIT; T: BOOLEAN); begin Self.MODIFIED := T; end;
procedure TCUSTOMEDITSELLENGTH_R(Self: TCUSTOMEDIT; var T: INTEGER); begin T := Self.SELLENGTH; end;
procedure TCUSTOMEDITSELLENGTH_W(Self: TCUSTOMEDIT; T: INTEGER); begin Self.SELLENGTH := T; end;
procedure TCUSTOMEDITSELSTART_R(Self: TCUSTOMEDIT; var T: INTEGER); begin T := Self.SELSTART; end;
procedure TCUSTOMEDITSELSTART_W(Self: TCUSTOMEDIT; T: INTEGER); begin Self.SELSTART := T; end;
procedure TCUSTOMEDITSELTEXT_R(Self: TCUSTOMEDIT; var T: STRING); begin T := Self.SELTEXT; end;
procedure TCUSTOMEDITSELTEXT_W(Self: TCUSTOMEDIT; T: STRING); begin Self.SELTEXT := T; end;
procedure TCUSTOMEDITTEXT_R(Self: TCUSTOMEDIT; var T: string); begin T := Self.TEXT; end;
procedure TCUSTOMEDITTEXT_W(Self: TCUSTOMEDIT; T: string); begin Self.TEXT := T; end;
procedure RIRegisterTCUSTOMEDIT(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TCUSTOMEDIT) do
begin
RegisterMethod(@TCUSTOMEDIT.CLEAR, 'CLEAR');
RegisterMethod(@TCUSTOMEDIT.CLEARSELECTION, 'CLEARSELECTION');
RegisterMethod(@TCUSTOMEDIT.SELECTALL, 'SELECTALL');
RegisterPropertyHelper(@TCUSTOMEDITMODIFIED_R, @TCUSTOMEDITMODIFIED_W, 'MODIFIED');
RegisterPropertyHelper(@TCUSTOMEDITSELLENGTH_R, @TCUSTOMEDITSELLENGTH_W, 'SELLENGTH');
RegisterPropertyHelper(@TCUSTOMEDITSELSTART_R, @TCUSTOMEDITSELSTART_W, 'SELSTART');
RegisterPropertyHelper(@TCUSTOMEDITSELTEXT_R, @TCUSTOMEDITSELTEXT_W, 'SELTEXT');
RegisterPropertyHelper(@TCUSTOMEDITTEXT_R, @TCUSTOMEDITTEXT_W, 'TEXT');
{$IFNDEF PS_MINIVCL}
RegisterMethod(@TCUSTOMEDIT.COPYTOCLIPBOARD, 'COPYTOCLIPBOARD');
RegisterMethod(@TCUSTOMEDIT.CUTTOCLIPBOARD, 'CUTTOCLIPBOARD');
RegisterMethod(@TCUSTOMEDIT.PASTEFROMCLIPBOARD, 'PASTEFROMCLIPBOARD');
{$IFNDEF FPC}
RegisterMethod(@TCUSTOMEDIT.GETSELTEXTBUF, 'GETSELTEXTBUF');
RegisterMethod(@TCUSTOMEDIT.SETSELTEXTBUF, 'SETSELTEXTBUF');
{$ENDIF}{FPC}
{$ENDIF}
end;
end;
procedure RIRegisterTEDIT(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TEDIT);
end;
procedure TCUSTOMMEMOLINES_R(Self: {$IFDEF CLX}TMemo{$ELSE}TCUSTOMMEMO{$ENDIF}; var T: TSTRINGS); begin T := Self.LINES; end;
procedure TCUSTOMMEMOLINES_W(Self: {$IFDEF CLX}TMemo{$ELSE}TCUSTOMMEMO{$ENDIF}; T: TSTRINGS); begin Self.LINES := T; end;
procedure RIRegisterTCUSTOMMEMO(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TCUSTOMMEMO) do
begin
{$IFNDEF CLX}
RegisterPropertyHelper(@TCUSTOMMEMOLINES_R, @TCUSTOMMEMOLINES_W, 'LINES');
{$ENDIF}
end;
end;
procedure RIRegisterTMEMO(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TMEMO) do
begin
{$IFDEF CLX}
RegisterPropertyHelper(@TCUSTOMMEMOLINES_R, @TCUSTOMMEMOLINES_W, 'LINES');
{$ENDIF}
end;
end;
procedure TCUSTOMCOMBOBOXCANVAS_R(Self: TCUSTOMCOMBOBOX; var T: TCANVAS); begin T := Self.CANVAS; end;
procedure TCUSTOMCOMBOBOXDROPPEDDOWN_R(Self: TCUSTOMCOMBOBOX; var T: BOOLEAN); begin T := Self.DROPPEDDOWN; end;
procedure TCUSTOMCOMBOBOXDROPPEDDOWN_W(Self: TCUSTOMCOMBOBOX; T: BOOLEAN); begin Self.DROPPEDDOWN := T; end;
procedure TCUSTOMCOMBOBOXITEMS_R(Self: TCUSTOMCOMBOBOX; var T: TSTRINGS); begin T := Self.ITEMS; end;
procedure TCUSTOMCOMBOBOXITEMS_W(Self: TCUSTOMCOMBOBOX; T: TSTRINGS); begin Self.ITEMS := T; end;
procedure TCUSTOMCOMBOBOXITEMINDEX_R(Self: TCUSTOMCOMBOBOX; var T: INTEGER); begin T := Self.ITEMINDEX; end;
procedure TCUSTOMCOMBOBOXITEMINDEX_W(Self: TCUSTOMCOMBOBOX; T: INTEGER); begin Self.ITEMINDEX := T; end;
procedure TCUSTOMCOMBOBOXSELLENGTH_R(Self: TCUSTOMCOMBOBOX; var T: INTEGER); begin T := Self.SELLENGTH; end;
procedure TCUSTOMCOMBOBOXSELLENGTH_W(Self: TCUSTOMCOMBOBOX; T: INTEGER); begin Self.SELLENGTH := T; end;
procedure TCUSTOMCOMBOBOXSELSTART_R(Self: TCUSTOMCOMBOBOX; var T: INTEGER); begin T := Self.SELSTART; end;
procedure TCUSTOMCOMBOBOXSELSTART_W(Self: TCUSTOMCOMBOBOX; T: INTEGER); begin Self.SELSTART := T; end;
procedure TCUSTOMCOMBOBOXSELTEXT_R(Self: TCUSTOMCOMBOBOX; var T: STRING); begin T := Self.SELTEXT; end;
procedure TCUSTOMCOMBOBOXSELTEXT_W(Self: TCUSTOMCOMBOBOX; T: STRING); begin Self.SELTEXT := T; end;
procedure RIRegisterTCUSTOMCOMBOBOX(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TCUSTOMCOMBOBOX) do
begin
RegisterPropertyHelper(@TCUSTOMCOMBOBOXDROPPEDDOWN_R, @TCUSTOMCOMBOBOXDROPPEDDOWN_W, 'DROPPEDDOWN');
RegisterPropertyHelper(@TCUSTOMCOMBOBOXITEMS_R, @TCUSTOMCOMBOBOXITEMS_W, 'ITEMS');
RegisterPropertyHelper(@TCUSTOMCOMBOBOXITEMINDEX_R, @TCUSTOMCOMBOBOXITEMINDEX_W, 'ITEMINDEX');
{$IFNDEF PS_MINIVCL}
RegisterMethod(@TCUSTOMCOMBOBOX.CLEAR, 'CLEAR');
RegisterMethod(@TCUSTOMCOMBOBOX.SELECTALL, 'SELECTALL');
RegisterPropertyHelper(@TCUSTOMCOMBOBOXCANVAS_R, nil, 'CANVAS');
RegisterPropertyHelper(@TCUSTOMCOMBOBOXSELLENGTH_R, @TCUSTOMCOMBOBOXSELLENGTH_W, 'SELLENGTH');
RegisterPropertyHelper(@TCUSTOMCOMBOBOXSELSTART_R, @TCUSTOMCOMBOBOXSELSTART_W, 'SELSTART');
RegisterPropertyHelper(@TCUSTOMCOMBOBOXSELTEXT_R, @TCUSTOMCOMBOBOXSELTEXT_W, 'SELTEXT');
{$ENDIF}
end;
end;
procedure RIRegisterTCOMBOBOX(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TCOMBOBOX);
end;
procedure RIRegisterTBUTTONCONTROL(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TBUTTONCONTROL);
end;
procedure RIRegisterTBUTTON(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TBUTTON);
end;
procedure RIRegisterTCUSTOMCHECKBOX(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TCUSTOMCHECKBOX);
end;
procedure RIRegisterTCHECKBOX(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TCHECKBOX);
end;
procedure RIRegisterTRADIOBUTTON(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TRADIOBUTTON);
end;
procedure TCUSTOMLISTBOXCANVAS_R(Self: TCUSTOMLISTBOX; var T: TCANVAS); begin T := Self.CANVAS; end;
procedure TCUSTOMLISTBOXITEMS_R(Self: TCUSTOMLISTBOX; var T: TSTRINGS); begin T := Self.ITEMS; end;
procedure TCUSTOMLISTBOXITEMS_W(Self: TCUSTOMLISTBOX; T: TSTRINGS); begin Self.ITEMS := T; end;
procedure TCUSTOMLISTBOXITEMINDEX_R(Self: TCUSTOMLISTBOX; var T: INTEGER); begin T := Self.ITEMINDEX; end;
procedure TCUSTOMLISTBOXITEMINDEX_W(Self: TCUSTOMLISTBOX; T: INTEGER); begin Self.ITEMINDEX := T; end;
procedure TCUSTOMLISTBOXSELCOUNT_R(Self: TCUSTOMLISTBOX; var T: INTEGER); begin T := Self.SELCOUNT; end;
procedure TCUSTOMLISTBOXSELECTED_R(Self: TCUSTOMLISTBOX; var T: BOOLEAN; t1: INTEGER); begin T := Self.SELECTED[t1]; end;
procedure TCUSTOMLISTBOXSELECTED_W(Self: TCUSTOMLISTBOX; T: BOOLEAN; t1: INTEGER); begin Self.SELECTED[t1] := T; end;
procedure TCUSTOMLISTBOXTOPINDEX_R(Self: TCUSTOMLISTBOX; var T: INTEGER); begin T := Self.TOPINDEX; end;
procedure TCUSTOMLISTBOXTOPINDEX_W(Self: TCUSTOMLISTBOX; T: INTEGER); begin Self.TOPINDEX := T; end;
procedure RIRegisterTCUSTOMLISTBOX(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TCUSTOMLISTBOX) do
begin
RegisterPropertyHelper(@TCUSTOMLISTBOXITEMS_R, @TCUSTOMLISTBOXITEMS_W, 'ITEMS');
RegisterPropertyHelper(@TCUSTOMLISTBOXITEMINDEX_R, @TCUSTOMLISTBOXITEMINDEX_W, 'ITEMINDEX');
RegisterPropertyHelper(@TCUSTOMLISTBOXSELCOUNT_R, nil, 'SELCOUNT');
RegisterPropertyHelper(@TCUSTOMLISTBOXSELECTED_R, @TCUSTOMLISTBOXSELECTED_W, 'SELECTED');
{$IFNDEF PS_MINIVCL}
RegisterMethod(@TCUSTOMLISTBOX.CLEAR, 'CLEAR');
RegisterMethod(@TCUSTOMLISTBOX.ITEMATPOS, 'ITEMATPOS');
RegisterMethod(@TCUSTOMLISTBOX.ITEMRECT, 'ITEMRECT');
RegisterPropertyHelper(@TCUSTOMLISTBOXCANVAS_R, nil, 'CANVAS');
RegisterPropertyHelper(@TCUSTOMLISTBOXTOPINDEX_R, @TCUSTOMLISTBOXTOPINDEX_W, 'TOPINDEX');
{$ENDIF}
end;
end;
procedure RIRegisterTLISTBOX(Cl: TPSRuntimeClassImporter);
begin
Cl.Add(TLISTBOX);
end;
procedure RIRegisterTSCROLLBAR(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TSCROLLBAR) do
begin
RegisterMethod(@TSCROLLBAR.SETPARAMS, 'SETPARAMS');
end;
end;
procedure RIRegister_stdctrls(cl: TPSRuntimeClassImporter);
begin
{$IFNDEF PS_MINIVCL}
RIRegisterTCUSTOMGROUPBOX(Cl);
RIRegisterTGROUPBOX(Cl);
{$ENDIF}
RIRegisterTCUSTOMLABEL(Cl);
RIRegisterTLABEL(Cl);
RIRegisterTCUSTOMEDIT(Cl);
RIRegisterTEDIT(Cl);
RIRegisterTCUSTOMMEMO(Cl);
RIRegisterTMEMO(Cl);
RIRegisterTCUSTOMCOMBOBOX(Cl);
RIRegisterTCOMBOBOX(Cl);
RIRegisterTBUTTONCONTROL(Cl);
RIRegisterTBUTTON(Cl);
RIRegisterTCUSTOMCHECKBOX(Cl);
RIRegisterTCHECKBOX(Cl);
RIRegisterTRADIOBUTTON(Cl);
RIRegisterTCUSTOMLISTBOX(Cl);
RIRegisterTLISTBOX(Cl);
{$IFNDEF PS_MINIVCL}
RIRegisterTSCROLLBAR(Cl);
{$ENDIF}
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.

12454
Units/PascalScript/uPSRuntime.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1592
Units/PascalScript/uPSUtils.pas Normal file
View File

File diff suppressed because it is too large Load Diff

17
Units/PascalScript/uPS_ExtReg.pas Normal file
View File

@ -0,0 +1,17 @@
unit uPS_ExtReg;
interface
procedure Register;
implementation
uses classes, uPSI_IBX, uPSI_Mask, upSI_JvMail, uPSI_Dialogs, uPSI_Registry;
procedure Register;
begin
RegisterComponents('Pascal Script', [TPSImport_IBX, TPSImport_Mask, TPSImport_JvMail,
TPSImport_Dialogs, TPSImport_Registry]);
end;
end.

366
Units/PascalScript/uROPSImports.pas Normal file
View File

@ -0,0 +1,366 @@
unit uROPSImports;
interface
uses
uPSCompiler, uPSRuntime, uROBINMessage, uROIndyHTTPChannel,
uROXMLSerializer, uROIndyTCPChannel, idTcpClient,
uROPSServerLink, uROWinInetHttpChannel;
procedure SIRegisterTROBINMESSAGE(CL: TIFPSPascalCompiler);
procedure SIRegisterTROINDYHTTPCHANNEL(CL: TIFPSPascalCompiler);
procedure SIRegisterTROINDYTCPCHANNEL(CL: TIFPSPascalCompiler);
procedure SIRegisterTIDTCPCLIENT(CL: TIFPSPascalCompiler);
procedure SIRegisterRODLImports(Cl: TIFPSPascalCompiler);
procedure RIRegisterTROBINMESSAGE(Cl: TIFPSRuntimeClassImporter);
procedure RIRegisterTROINDYHTTPCHANNEL(Cl: TIFPSRuntimeClassImporter);
procedure RIRegisterTROINDYTCPCHANNEL(Cl: TIFPSRuntimeClassImporter);
procedure RIRegisterTIDTCPCLIENT(Cl: TIFPSRuntimeClassImporter);
procedure RIRegisterRODLImports(CL: TIFPSRuntimeClassImporter);
(*
Todo:
TROWinInetHTTPChannel = class(TROTransportChannel, IROTransport, IROTCPTransport, IROHTTPTransport)
published
property UserAgent:string read GetUserAgent write SetUserAgent;
property TargetURL : string read fTargetURL write SetTargetURL;
property StoreConnected:boolean read fStoreConnected write fStoreConnected default false;
property KeepConnection:boolean read fKeepConnection write fKeepConnection default false;
end;
*)
type
TPSROIndyTCPModule = class(TPSROModule)
protected
class procedure ExecImp(exec: TIFPSExec; ri: TIFPSRuntimeClassImporter); override;
class procedure CompImp(comp: TIFPSPascalCompiler); override;
end;
TPSROIndyHTTPModule = class(TPSROModule)
protected
class procedure ExecImp(exec: TIFPSExec; ri: TIFPSRuntimeClassImporter); override;
class procedure CompImp(comp: TIFPSPascalCompiler); override;
end;
TPSROBinModule = class(TPSROModule)
protected
class procedure ExecImp(exec: TIFPSExec; ri: TIFPSRuntimeClassImporter); override;
class procedure CompImp(comp: TIFPSPascalCompiler); override;
end;
implementation
{procedure TROSOAPMESSAGESERIALIZATIONOPTIONS_W(Self: TROSOAPMESSAGE;
const T: TXMLSERIALIZATIONOPTIONS);
begin
Self.SERIALIZATIONOPTIONS := T;
end;
procedure TROSOAPMESSAGESERIALIZATIONOPTIONS_R(Self: TROSOAPMESSAGE;
var T: TXMLSERIALIZATIONOPTIONS);
begin
T := Self.SERIALIZATIONOPTIONS;
end;
procedure TROSOAPMESSAGECUSTOMLOCATION_W(Self: TROSOAPMESSAGE; const T: string);
begin
Self.CUSTOMLOCATION := T;
end;
procedure TROSOAPMESSAGECUSTOMLOCATION_R(Self: TROSOAPMESSAGE; var T: string);
begin
T := Self.CUSTOMLOCATION;
end;
procedure TROSOAPMESSAGELIBRARYNAME_W(Self: TROSOAPMESSAGE; const T: string);
begin
Self.LIBRARYNAME := T;
end;
procedure TROSOAPMESSAGELIBRARYNAME_R(Self: TROSOAPMESSAGE; var T: string);
begin
T := Self.LIBRARYNAME;
end; }
procedure TROBINMESSAGEUSECOMPRESSION_W(Self: TROBINMESSAGE; const T: boolean);
begin
Self.USECOMPRESSION := T;
end;
procedure TROBINMESSAGEUSECOMPRESSION_R(Self: TROBINMESSAGE; var T: boolean);
begin
T := Self.USECOMPRESSION;
end;
procedure TROINDYHTTPCHANNELTARGETURL_W(Self: TROINDYHTTPCHANNEL; const T: string);
begin
Self.TARGETURL := T;
end;
procedure TROINDYHTTPCHANNELTARGETURL_R(Self: TROINDYHTTPCHANNEL; var T: string);
begin
T := Self.TARGETURL;
end;
procedure TROINDYTCPCHANNELINDYCLIENT_R(Self: TROINDYTCPCHANNEL; var T: TIdTCPClientBaseClass);
begin
T := Self.INDYCLIENT;
end;
procedure TIDTCPCLIENTPORT_W(Self: TIDTCPCLIENT; const T: integer);
begin
Self.PORT := T;
end;
procedure TIDTCPCLIENTPORT_R(Self: TIdTCPClientBaseClass; var T: integer);
begin
T := TIdIndy10HackClient(Self).PORT;
end;
procedure TIDTCPCLIENTHOST_W(Self: TIdTCPClientBaseClass; const T: string);
begin
TIdIndy10HackClient(Self).HOST := T;
end;
procedure TIDTCPCLIENTHOST_R(Self: TIdTCPClientBaseClass; var T: string);
begin
T := TIdIndy10HackClient(Self).HOST;
end;
{procedure TIDTCPCLIENTBOUNDPORT_W(Self: TIdTCPClientBaseClass; const T: integer);
begin
Self.BOUNDPORT := T;
end;
procedure TIDTCPCLIENTBOUNDPORT_R(Self: TIdTCPClientBaseClass; var T: integer);
begin
T := Self.BOUNDPORT;
end;
procedure TIDTCPCLIENTBOUNDIP_W(Self: TIdTCPClientBaseClass; const T: string);
begin
Self.BOUNDIP := T;
end;
procedure TIDTCPCLIENTBOUNDIP_R(Self: TIdTCPClientBaseClass; var T: string);
begin
T := Self.BOUNDIP;
end;]
procedure TIDTCPCLIENTBOUNDPORTMIN_W(Self: TIdTCPClientBaseClass; const T: integer);
begin
Self.BOUNDPORTMIN := T;
end;
procedure TIDTCPCLIENTBOUNDPORTMIN_R(Self: TIdTCPClientBaseClass; var T: integer);
begin
T := Self.BOUNDPORTMIN;
end;
procedure TIDTCPCLIENTBOUNDPORTMAX_W(Self: TIdTCPClientBaseClass; const T: integer);
begin
Self.BOUNDPORTMAX := T;
end;
procedure TIDTCPCLIENTBOUNDPORTMAX_R(Self: TIdTCPClientBaseClass; var T: integer);
begin
T := Self.BOUNDPORTMAX;
end;
{procedure RIRegisterTROSOAPMESSAGE(Cl: TIFPSRuntimeClassImporter);
begin
with Cl.Add(TROSOAPMESSAGE) do
begin
RegisterPropertyHelper(@TROSOAPMESSAGELIBRARYNAME_R, @TROSOAPMESSAGELIBRARYNAME_W,
'LIBRARYNAME');
RegisterPropertyHelper(@TROSOAPMESSAGECUSTOMLOCATION_R,
@TROSOAPMESSAGECUSTOMLOCATION_W, 'CUSTOMLOCATION');
RegisterPropertyHelper(@TROSOAPMESSAGESERIALIZATIONOPTIONS_R,
@TROSOAPMESSAGESERIALIZATIONOPTIONS_W, 'SERIALIZATIONOPTIONS');
end;
end; }
procedure RIRegisterTROBINMESSAGE(Cl: TIFPSRuntimeClassImporter);
begin
with Cl.Add(TROBINMESSAGE) do
begin
RegisterPropertyHelper(@TROBINMESSAGEUSECOMPRESSION_R,
@TROBINMESSAGEUSECOMPRESSION_W, 'USECOMPRESSION');
end;
end;
procedure RIRegisterTROINDYHTTPCHANNEL(Cl: TIFPSRuntimeClassImporter);
begin
with Cl.Add(TROINDYHTTPCHANNEL) do
begin
RegisterPropertyHelper(@TROINDYHTTPCHANNELTARGETURL_R,
@TROINDYHTTPCHANNELTARGETURL_W, 'TARGETURL');
end;
end;
procedure RIRegisterTROINDYTCPCHANNEL(Cl: TIFPSRuntimeClassImporter);
begin
with Cl.Add(TROINDYTCPCHANNEL) do
begin
RegisterPropertyHelper(@TROINDYTCPCHANNELINDYCLIENT_R, nil, 'INDYCLIENT');
end;
end;
procedure RIRegisterTIDTCPCLIENT(Cl: TIFPSRuntimeClassImporter);
begin
with Cl.Add(TIdTCPClientBaseClass) do
begin
{RegisterPropertyHelper(@TIDTCPCLIENTBOUNDPORTMAX_R, @TIDTCPCLIENTBOUNDPORTMAX_W,
'BOUNDPORTMAX');
RegisterPropertyHelper(@TIDTCPCLIENTBOUNDPORTMIN_R, @TIDTCPCLIENTBOUNDPORTMIN_W,
'BOUNDPORTMIN');
RegisterPropertyHelper(@TIDTCPCLIENTBOUNDIP_R, @TIDTCPCLIENTBOUNDIP_W, 'BOUNDIP');
RegisterPropertyHelper(@TIDTCPCLIENTBOUNDPORT_R, @TIDTCPCLIENTBOUNDPORT_W,
'BOUNDPORT');}
RegisterPropertyHelper(@TIDTCPCLIENTHOST_R, @TIDTCPCLIENTHOST_W, 'HOST');
RegisterPropertyHelper(@TIDTCPCLIENTPORT_R, @TIDTCPCLIENTPORT_W, 'PORT');
end;
end;
procedure RIRegisterRODLImports(CL: TIFPSRuntimeClassImporter);
begin
RIRegisterTIDTCPCLIENT(Cl);
RIRegisterTROINDYTCPCHANNEL(Cl);
RIRegisterTROINDYHTTPCHANNEL(Cl);
RIRegisterTROBINMESSAGE(Cl);
//RIRegisterTROSOAPMESSAGE(Cl);
end;
function RegClassS(cl: TIFPSPascalCompiler; const InheritsFrom,
ClassName: string): TPSCompileTimeClass;
begin
Result := cl.FindClass(ClassName);
if Result = nil then
Result := cl.AddClassN(cl.FindClass(InheritsFrom), ClassName)
else
Result.ClassInheritsFrom := cl.FindClass(InheritsFrom);
end;
{procedure SIRegisterTROSOAPMESSAGE(CL: TIFPSPascalCompiler);
begin
Cl.addTypeS('TXMLSERIALIZATIONOPTIONS', 'BYTE');
Cl.AddConstantN('XSOWRITEMULTIREFARRAY', 'BYTE').SetInt(1);
Cl.AddConstantN('XSOWRITEMULTIREFOBJECT', 'BYTE').SetInt(2);
Cl.AddConstantN('XSOSENDUNTYPED', 'BYTE').SetInt(4);
with RegClassS(cl, 'TROMESSAGE', 'TROSOAPMESSAGE') do
begin
RegisterProperty('LIBRARYNAME', 'STRING', iptrw);
RegisterProperty('CUSTOMLOCATION', 'STRING', iptrw);
RegisterProperty('SERIALIZATIONOPTIONS', 'TXMLSERIALIZATIONOPTIONS', iptrw);
end;
end;}
procedure SIRegisterTROBINMESSAGE(CL: TIFPSPascalCompiler);
begin
with RegClassS(cl, 'TROMESSAGE', 'TROBINMESSAGE') do
begin
RegisterProperty('USECOMPRESSION', 'BOOLEAN', iptrw);
end;
end;
procedure SIRegisterTROINDYHTTPCHANNEL(CL: TIFPSPascalCompiler);
begin
with RegClassS(cl, 'TROINDYTCPCHANNEL', 'TROINDYHTTPCHANNEL') do
begin
RegisterProperty('TARGETURL', 'STRING', iptrw);
end;
end;
procedure SIRegisterTROINDYTCPCHANNEL(CL: TIFPSPascalCompiler);
begin
with RegClassS(cl, 'TROTRANSPORTCHANNEL', 'TROINDYTCPCHANNEL') do
begin
RegisterProperty('INDYCLIENT', 'TIdTCPClientBaseClass', iptr);
end;
end;
procedure SIRegisterTIDTCPCLIENT(CL: TIFPSPascalCompiler);
begin
with RegClassS(cl, 'TCOMPONENT', 'TIdTCPClientBaseClass') do
begin
RegisterProperty('BOUNDPORTMAX', 'INTEGER', iptrw);
RegisterProperty('BOUNDPORTMIN', 'INTEGER', iptrw);
RegisterProperty('BOUNDIP', 'STRING', iptrw);
RegisterProperty('BOUNDPORT', 'INTEGER', iptrw);
RegisterProperty('HOST', 'STRING', iptrw);
RegisterProperty('PORT', 'INTEGER', iptrw);
end;
end;
procedure SIRegisterRODLImports(Cl: TIFPSPascalCompiler);
begin
SIRegisterTIDTCPCLIENT(Cl);
SIRegisterTROINDYTCPCHANNEL(Cl);
SIRegisterTROINDYHTTPCHANNEL(Cl);
SIRegisterTROBINMESSAGE(Cl);
//SIRegisterTROSOAPMESSAGE(Cl);
end;
{ TPSROIndyTCPModule }
class procedure TPSROIndyTCPModule.CompImp(comp: TIFPSPascalCompiler);
begin
SIRegisterTIDTCPCLIENT(Comp);
SIRegisterTROINDYTCPCHANNEL(Comp);
end;
class procedure TPSROIndyTCPModule.ExecImp(exec: TIFPSExec;
ri: TIFPSRuntimeClassImporter);
begin
RIRegisterTIDTCPCLIENT(ri);
RIRegisterTROINDYTCPCHANNEL(ri);
end;
{ TPSROIndyHTTPModule }
class procedure TPSROIndyHTTPModule.CompImp(comp: TIFPSPascalCompiler);
begin
if Comp.FindClass('TROINDYTCPCHANNEL') = nil then
TPSROIndyTCPModule.CompImp(Comp);
SIRegisterTROINDYHTTPCHANNEL(Comp);
end;
class procedure TPSROIndyHTTPModule.ExecImp(exec: TIFPSExec;
ri: TIFPSRuntimeClassImporter);
begin
if ri.FindClass('TROINDYTCPCHANNEL') = nil then
TPSROIndyTCPModule.ExecImp(exec, ri);
RIRegisterTROINDYHTTPCHANNEL(ri);
end;
{ TPSROSoapModule }
{class procedure TPSROSoapModule.CompImp(comp: TIFPSPascalCompiler);
begin
SIRegisterTROSOAPMESSAGE(comp);
end;
class procedure TPSROSoapModule.ExecImp(exec: TIFPSExec;
ri: TIFPSRuntimeClassImporter);
begin
RIRegisterTROSOAPMESSAGE(ri);
end;}
{ TPSROBinModule }
class procedure TPSROBinModule.CompImp(comp: TIFPSPascalCompiler);
begin
SIRegisterTROBINMESSAGE(Comp);
end;
class procedure TPSROBinModule.ExecImp(exec: TIFPSExec;
ri: TIFPSRuntimeClassImporter);
begin
RIRegisterTROBINMESSAGE(ri);
end;
end.

1231
Units/PascalScript/uROPSServerLink.pas Normal file
View File

File diff suppressed because it is too large Load Diff

513
Units/PascalScript/x64.inc Normal file
View File

@ -0,0 +1,513 @@
{ implementation of x64 abi }
//procedure DebugBreak; external 'Kernel32.dll';
const
EmptyPchar: array[0..0] of char = #0;
{$ASMMODE INTEL}
{$IFDEF WINDOWS}
procedure x64call(
Address: Pointer;
out _RAX: IPointer;
_RCX, _RDX, _R8, _R9: IPointer;
var _XMM0: Double;
_XMM1, _XMM2, _XMM3: Double;
aStack: Pointer; aItems: Integer); assembler; nostackframe;
asm
(* Registers:
RCX: Address
RDX: *_RAX
R8: _RCX
R9: _RDX
fpc inserts an 20h emty space
*)
push ebp
mov ebp,esp
// call debugbreak
push rcx // address
push rdx // _rax
push r8 // _rcx
push r9 // _rdx
mov rcx, aItems
mov rdx, aStack
jmp @compareitems
@work:
push [rdx]
dec rcx
sub rdx,8
@compareitems:
or rcx, rcx
jnz @work
// copy registers
movd xmm0,[_XMM0]
movd xmm1,_XMM1
movd xmm2,_XMM2
movd xmm3,_XMM3
mov RAX, [rbp-8]
mov RCX, [rbp-24]
mov RDX, [rbp-32]
mov R8, _R8
mov R9, _R9
// weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in
sub RSP, 32
call RAX
add RSP, 32 // undo the damage done earlier
// copy result back
mov RDX, [rbp-16]
mov [RDX], RAX
movd [_XMM0],xmm0
pop r9
pop r8
pop rdx
pop rcx
leave
ret
end;
{$ELSE}
procedure x64call(
Address: Pointer;
out _RAX: IPointer;
_RDI, _RSI, _RDX, _RCX, _R8, _R9: IPointer;
var _XMM0: Double;
_XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7: Double;
aStack: Pointer; aItems: Integer); assembler; nostackframe;
asm
(* Registers:
RDI: Address
RSI: _RAX
RDX: _RDI
RCX: _RSI
R8: _RDX
R9: _RCX
*)
push ebp
mov ebp,esp
push rdi // address
push rsi // _rax
push rdx // _rdi
push rcx // _rsi
push r8 // _rdx
push r9 // _rcx
mov rcx, aItems
mov rdx, aStack
jmp @compareitems
@work:
push [rdx]
dec rcx
sub rdx,8
@compareitems:
or rcx, rcx
jnz @work
// copy registers
movd xmm0,[_XMM0]
movd xmm1,_XMM1
movd xmm2,_XMM2
movd xmm3,_XMM3
movd xmm4,_XMM4
movd xmm5,_XMM5
movd xmm6,_XMM6
movd xmm7,_XMM7
mov RAX, [rbp-8]
mov RDI, [rbp-24]
mov RSI, [rbp-32]
mov RDX, [rbp-40]
mov RCX, [rbp-48]
mov R8, _R8
mov R9, _R9
// weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in; not sure about linux
//sub RSP, 32
call RAX
// add RSP, 32 // undo the damage done earlier
// copy result back
mov RDX, [rbp-16]
mov [RDX], RAX
movd [_XMM0],xmm0
pop r9
pop r8
pop rdx
pop rcx
pop rsi
pop rdi
leave
ret
end;
{$ENDIF}
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
var
Stack: array of Byte;
_RAX,
{$IFDEF WINDOWS}
_RCX, _RDX, _R8, _R9: IPointer;
_XMM0, _XMM1, _XMM2, _XMM3: Double;
{$ELSE}
_RDI, _RSI, _RDX, _RCX, _R8, _R9: IPointer;
_XMM0, _XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7: Double;
RegUsageFloat: Byte;
{$ENDIF}
RegUsage: Byte;
CallData: TPSList;
I: Integer;
pp: ^Byte;
function rp(p: PPSVariantIFC): PPSVariantIFC;
begin
if p = nil then
begin
result := nil;
exit;
end;
if p.aType.BaseType = btPointer then
begin
p^.aType := Pointer(Pointer(IPointer(p^.dta) + PointerSize)^);
p^.Dta := Pointer(p^.dta^);
end;
Result := p;
end;
{$IFDEF WINDOWS}
procedure StoreReg(data: IPointer); overload;
var p: Pointer;
begin
case RegUsage of
0: begin inc(RegUsage); _RCX:=Data; end;
1: begin inc(RegUsage); _RDX:=Data; end;
2: begin inc(RegUsage); _R8:=Data; end;
3: begin inc(RegUsage); _R9:=Data; end;
else begin
SetLength(Stack, Length(Stack)+8);
p := @Stack[LEngth(Stack)-8];
IPointer(p^) := data;
end;
end;
end;
{$ELSE}
procedure StoreReg(data: IPointer); overload;
var p: Pointer;
begin
case RegUsage of
0: begin inc(RegUsage); _RDI:=Data; end;
1: begin inc(RegUsage); _RSI:=Data; end;
2: begin inc(RegUsage); _RDX:=Data; end;
3: begin inc(RegUsage); _RCX:=Data; end;
4: begin inc(RegUsage); _R8:=Data; end;
5: begin inc(RegUsage); _R9:=Data; end;
else begin
SetLength(Stack, Length(Stack)+8);
p := @Stack[LEngth(Stack)-8];
IPointer(p^) := data;
end;
end;
end;
{$ENDIF}
procedure StoreStack(const aData; Len: Integer);
var
p: Pointer;
begin
if Len > 8 then
if Length(Stack) mod 16 <> 0 then begin
SetLength(Stack, Length(Stack)+ (16-(Length(Stack) mod 16)));
end;
SetLength(Stack, Length(Stack)+Len);
p := @Stack[Length(Stack)-Len];
Move(aData, p^, Len);
end;
{$IFDEF WINDOWS}
procedure StoreReg(data: Double); overload;
var p: Pointer;
begin
case RegUsage of
0: begin inc(RegUsage); _XMM0:=Data; end;
1: begin inc(RegUsage); _XMM1:=Data; end;
2: begin inc(RegUsage); _XMM2:=Data; end;
3: begin inc(RegUsage); _XMM3:=Data; end;
else begin
SetLength(Stack, Length(Stack)+8);
p := @Stack[LEngth(Stack)-8];
Double(p^) := data;
end;
end;
end;
{$ELSE}
procedure StoreReg(data: Double); overload;
var p: Pointer;
begin
case RegUsageFloat of
0: begin inc(RegUsageFloat); _XMM0:=Data; end;
1: begin inc(RegUsageFloat); _XMM1:=Data; end;
2: begin inc(RegUsageFloat); _XMM2:=Data; end;
3: begin inc(RegUsageFloat); _XMM3:=Data; end;
4: begin inc(RegUsageFloat); _XMM4:=Data; end;
5: begin inc(RegUsageFloat); _XMM5:=Data; end;
6: begin inc(RegUsageFloat); _XMM6:=Data; end;
7: begin inc(RegUsageFloat); _XMM7:=Data; end;
else begin
SetLength(Stack, Length(Stack)+8);
p := @Stack[LEngth(Stack)-8];
Double(p^) := data;
end;
end;
end;
{$ENDIF}
function GetPtr(fVar: PPSVariantIFC): Boolean;
var
varPtr: Pointer;
//UseReg: Boolean;
//tempstr: tbtstring;
p: Pointer;
begin
Result := False;
if FVar = nil then exit;
if fVar.VarParam then
begin
case fvar.aType.BaseType of
btArray:
begin
if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then
begin
p := CreateOpenArray(True, Self, FVar);
if p = nil then exit;
CallData.Add(p);
StoreReg(IPointer(POpenArray(p)^.Data));
StoreReg(IPointer(POpenArray(p)^.ItemCount -1));
Result := True;
Exit;
end else begin
varptr := fvar.Dta;
// Exit;
end;
end;
btVariant,
btSet,
btStaticArray,
btRecord,
btInterface,
btClass,
{$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16,
btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
{$IFNDEF PS_NOINT64}, bts64{$ENDIF}:
begin
Varptr := fvar.Dta;
end;
else begin
exit; //invalid type
end;
end; {case}
StoreReg(IPointer(VarPtr));
end else begin
// UseReg := True;
case fVar^.aType.BaseType of
btSet:
begin
case TPSTypeRec_Set(fvar.aType).aByteSize of
1: StoreReg(IPointer(byte(fvar.dta^)));
2: StoreReg(IPointer(word(fvar.dta^)));
3, 4: StoreReg(IPointer(cardinal(fvar.dta^)));
5,6,7,8: StoreReg(IPointer(fVar.Dta^));
else
StoreReg(IPointer(fvar.Dta));
end;
end;
btArray:
begin
if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then
begin
p := CreateOpenArray(False, SElf, FVar);
if p =nil then exit;
CallData.Add(p);
StoreReg(IPointer(POpenArray(p)^.Data));
StoreReg(IPointer(POpenArray(p)^.ItemCount -1));
Result := True;
exit;
end else begin
StoreReg(IPointer(FVar.Dta^));
end;
end;
btVariant
, btStaticArray, btRecord:
begin
StoreReg(IPointer(fVar.Dta));
end;
btExtended, btDouble: {8 bytes} begin
StoreReg(double(fvar.dta^));
end;
btCurrency: {8 bytes} begin
StoreReg(IPointer(fvar.dta^));
end;
btSingle: {4 bytes} begin
StoreReg(single(fvar.dta^));
end;
btChar,
btU8,
btS8: begin
StoreReg(IPointer(byte(fVar^.dta^)));
end;
btWideChar,
btu16, btS16: begin
StoreReg(IPointer(word(fVar^.dta^)));
end;
btu32, bts32: begin
StoreReg(IPointer(cardinal(fVar^.dta^)));
end;
btPchar:
begin
if pointer(fvar^.dta^) = nil then
StoreReg(IPointer(@EmptyPchar))
else
StoreReg(IPointer(fvar^.dta^));
end;
btclass, btinterface, btString:
begin
StoreReg(IPointer(fvar^.dta^));
end;
btWideString: begin
StoreReg(IPointer(fvar^.dta^));
end;
btUnicodeString: begin
StoreReg(IPointer(fvar^.dta^));
end;
btProcPtr:
begin
GetMem(p, PointerSize2);
TMethod(p^) := MKMethod(Self, Longint(FVar.Dta^));
StoreStack(p^, Pointersize2);
FreeMem(p);
end;
bts64:
begin
StoreReg(IPointer(int64(fvar^.dta^)));
end;
end; {case}
end;
Result := True;
end;
begin
InnerfuseCall := False;
if Address = nil then
exit; // need address
SetLength(Stack, 0);
CallData := TPSList.Create;
res := rp(res);
if res <> nil then
res.VarParam := true;
try
{$IFNDEF WINDOWS}
_RSI := 0;
_RDI := 0;
_XMM4 := 0;
_XMM5 := 0;
_XMM6 := 0;
_XMM7 := 0;
RegUsageFloat := 0;
{$ENDIF}
_RCX := 0;
_RDX := 0;
_R8 := 0;
_R9 := 0;
_XMM0 := 0;
_XMM1 := 0;
_XMM2 := 0;
_XMM3 := 0;
RegUsage := 0;
if assigned(_Self) then begin
RegUsage := 1;
_RCX := IPointer(_Self);
end;
for I := 0 to Params.Count - 1 do
begin
if not GetPtr(rp(Params[I])) then Exit;
end;
if assigned(res) then begin
case res^.aType.BaseType of
{$IFDEF x64_string_result_as_varparameter}
btstring, btWideString, btUnicodeString,
{$ENDIF}
btInterface, btArray, btrecord, btVariant, btStaticArray: GetPtr(res);
btSet:
begin
if TPSTypeRec_Set(res.aType).aByteSize > PointerSize then GetPtr(res);
end;
end;
if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8];
{$IFDEF WINDOWS}
x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, pp, Length(Stack) div 8);
{$ELSE}
x64call(Address, _RAX, _RDI, _RSI, _RDX, _RCX, _R8, _R9,_XMM0,_XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7, pp, Length(Stack) div 8);
{$ENDIF}
case res^.aType.BaseType of
btSet:
begin
case TPSTypeRec_Set(res.aType).aByteSize of
1: byte(res.Dta^) := _RAX;
2: word(res.Dta^) := _RAX;
3,
4: Longint(res.Dta^) := _RAX;
5,6,7,8: IPointer(res.dta^) := _RAX;
end;
end;
btSingle: tbtsingle(res.Dta^) := _XMM0;
btDouble: tbtdouble(res.Dta^) := _XMM0;
btExtended: tbtextended(res.Dta^) := _XMM0;
btchar,btU8, btS8: tbtu8(res.dta^) := _RAX;
btWideChar, btu16, bts16: tbtu16(res.dta^) := _RAX;
btClass : IPointer(res.dta^) := _RAX;
btu32,bts32: tbtu32(res.dta^) := _RAX;
btPChar: pansichar(res.dta^) := Pansichar(_RAX);
bts64: tbts64(res.dta^) := Int64(_RAX);
btCurrency: tbtCurrency(res.Dta^) := Int64(_RAX);
btInterface,
btVariant,
{$IFDEF x64_string_result_as_varparameter}
btWidestring,btUnicodestring, btstring ,
{$ENDIF}
btStaticArray, btArray, btrecord:;
{$IFNDEF x64_string_result_as_varparameter}
btUnicodeString, btWideString, btstring: Int64(res.dta^) := _RAX;
{$ENDIF}
else
exit;
end;
end else begin
if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8];
{$IFDEF WINDOWS}
x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, pp, Length(Stack) div 8);
{$ELSE}
x64call(Address, _RAX, _RDI, _RSI, _RDX, _RCX, _R8, _R9,_XMM0,_XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7, pp, Length(Stack) div 8);
{$ENDIF}
end;
Result := True;
finally
for i := CallData.Count -1 downto 0 do
begin
pp := CallData[i];
case pp^ of
0: DestroyOpenArray(Self, Pointer(pp));
end;
end;
CallData.Free;
end;
end;

739
Units/PascalScript/x86.inc Normal file
View File

@ -0,0 +1,739 @@
{ implementation of x86 abi }
{$ifdef FPC}
{$define PS_ARRAY_ON_STACK}
{$endif}
function RealFloatCall_Register(p: Pointer;
_EAX, _EDX, _ECX: Cardinal;
StackData: Pointer;
StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
): Extended; Stdcall; // make sure all things are on stack
var
E: Extended;
begin
asm
mov ecx, stackdatalen
jecxz @@2
mov eax, stackdata
@@1:
mov edx, [eax]
push edx
sub eax, 4
dec ecx
or ecx, ecx
jnz @@1
@@2:
mov eax,_EAX
mov edx,_EDX
mov ecx,_ECX
call p
fstp tbyte ptr [e]
end;
Result := E;
end;
function RealFloatCall_Other(p: Pointer;
StackData: Pointer;
StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
): Extended; Stdcall; // make sure all things are on stack
var
E: Extended;
begin
asm
mov ecx, stackdatalen
jecxz @@2
mov eax, stackdata
@@1:
mov edx, [eax]
push edx
sub eax, 4
dec ecx
or ecx, ecx
jnz @@1
@@2:
call p
fstp tbyte ptr [e]
end;
Result := E;
end;
function RealFloatCall_CDecl(p: Pointer;
StackData: Pointer;
StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
): Extended; Stdcall; // make sure all things are on stack
var
E: Extended;
begin
asm
mov ecx, stackdatalen
jecxz @@2
mov eax, stackdata
@@1:
mov edx, [eax]
push edx
sub eax, 4
dec ecx
or ecx, ecx
jnz @@1
@@2:
call p
fstp tbyte ptr [e]
@@5:
mov ecx, stackdatalen
jecxz @@2
@@6:
pop edx
dec ecx
or ecx, ecx
jnz @@6
end;
Result := E;
end;
function RealCall_Register(p: Pointer;
_EAX, _EDX, _ECX: Cardinal;
StackData: Pointer;
StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
var
r: Longint;
begin
asm
mov ecx, stackdatalen
jecxz @@2
mov eax, stackdata
@@1:
mov edx, [eax]
push edx
sub eax, 4
dec ecx
or ecx, ecx
jnz @@1
@@2:
mov eax,_EAX
mov edx,_EDX
mov ecx,_ECX
call p
mov ecx, resultlength
cmp ecx, 0
je @@5
cmp ecx, 1
je @@3
cmp ecx, 2
je @@4
mov r, eax
jmp @@5
@@3:
xor ecx, ecx
mov cl, al
mov r, ecx
jmp @@5
@@4:
xor ecx, ecx
mov cx, ax
mov r, ecx
@@5:
mov ecx, resedx
jecxz @@6
mov [ecx], edx
@@6:
end;
Result := r;
end;
function RealCall_Other(p: Pointer;
StackData: Pointer;
StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
var
r: Longint;
begin
asm
mov ecx, stackdatalen
jecxz @@2
mov eax, stackdata
@@1:
mov edx, [eax]
push edx
sub eax, 4
dec ecx
or ecx, ecx
jnz @@1
@@2:
call p
mov ecx, resultlength
cmp ecx, 0
je @@5
cmp ecx, 1
je @@3
cmp ecx, 2
je @@4
mov r, eax
jmp @@5
@@3:
xor ecx, ecx
mov cl, al
mov r, ecx
jmp @@5
@@4:
xor ecx, ecx
mov cx, ax
mov r, ecx
@@5:
mov ecx, resedx
jecxz @@6
mov [ecx], edx
@@6:
end;
Result := r;
end;
function RealCall_CDecl(p: Pointer;
StackData: Pointer;
StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
var
r: Longint;
begin
asm
mov ecx, stackdatalen
jecxz @@2
mov eax, stackdata
@@1:
mov edx, [eax]
push edx
sub eax, 4
dec ecx
or ecx, ecx
jnz @@1
@@2:
call p
mov ecx, resultlength
cmp ecx, 0
je @@5
cmp ecx, 1
je @@3
cmp ecx, 2
je @@4
mov r, eax
jmp @@5
@@3:
xor ecx, ecx
mov cl, al
mov r, ecx
jmp @@5
@@4:
xor ecx, ecx
mov cx, ax
mov r, ecx
@@5:
mov ecx, stackdatalen
jecxz @@7
@@6:
pop eax
dec ecx
or ecx, ecx
jnz @@6
mov ecx, resedx
jecxz @@7
mov [ecx], edx
@@7:
end;
Result := r;
end;
const
EmptyPchar: array[0..0] of char = #0;
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
var
Stack: ansistring;
I: Longint;
RegUsage: Byte;
CallData: TPSList;
pp: ^Byte;
IsConstructor: Boolean;
EAX, EDX, ECX: Longint;
function rp(p: PPSVariantIFC): PPSVariantIFC;
begin
if p = nil then
begin
result := nil;
exit;
end;
if p.aType.BaseType = btPointer then
begin
p^.aType := Pointer(Pointer(IPointer(p^.dta) + 4)^);
p^.Dta := Pointer(p^.dta^);
end;
Result := p;
end;
function GetPtr(fVar: PPSVariantIFC): Boolean;
var
varPtr: Pointer;
UseReg: Boolean;
tempstr: tbtstring;
p: Pointer;
begin
Result := False;
if FVar = nil then exit;
if fVar.VarParam then
begin
case fvar.aType.BaseType of
btArray:
begin
if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then
begin
p := CreateOpenArray(True, Self, FVar);
if p = nil then exit;
CallData.Add(p);
case RegUsage of
0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Pointer((@Stack[1])^) := POpenArray(p)^.Data;
end;
end;
case RegUsage of
0: begin EAX := Longint(POpenArray(p)^.ItemCount - 1); Inc(RegUsage); end;
1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
end;
end;
Result := True;
Exit;
end else begin
{$IFDEF PS_DYNARRAY}
varptr := fvar.Dta;
{$ELSE}
Exit;
{$ENDIF}
end;
end;
btVariant,
btSet,
btStaticArray,
btRecord,
btInterface,
btClass,
{$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16,
btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
{$IFNDEF PS_NOINT64}, bts64{$ENDIF}:
begin
Varptr := fvar.Dta;
end;
else begin
exit; //invalid type
end;
end; {case}
case RegUsage of
0: begin EAX := Longint(VarPtr); Inc(RegUsage); end;
1: begin EDX := Longint(VarPtr); Inc(RegUsage); end;
2: begin ECX := Longint(VarPtr); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Pointer((@Stack[1])^) := VarPtr;
end;
end;
end else begin
UseReg := True;
case fVar^.aType.BaseType of
btSet:
begin
tempstr := StringOfChar(AnsiChar(#0),4);
case TPSTypeRec_Set(fvar.aType).aByteSize of
1: Byte((@tempstr[1])^) := byte(fvar.dta^);
2: word((@tempstr[1])^) := word(fvar.dta^);
3, 4: cardinal((@tempstr[1])^) := cardinal(fvar.dta^);
else
pointer((@tempstr[1])^) := fvar.dta;
end;
end;
btArray:
begin
if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then
begin
p := CreateOpenArray(False, SElf, FVar);
if p =nil then exit;
CallData.Add(p);
case RegUsage of
0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Pointer((@Stack[1])^) := POpenArray(p)^.Data;
end;
end;
case RegUsage of
0: begin EAX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
else begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
end;
end;
Result := True;
exit;
end else begin
{$IFDEF PS_DYNARRAY}
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := Pointer(fvar.Dta^);
{$IFDEF PS_ARRAY_ON_STACK}
UseReg := false;
{$ENDIF}
{$ELSE}
Exit;
{$ENDIF}
end;
end;
btVariant
, btStaticArray, btRecord:
begin
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := Pointer(fvar.Dta);
end;
btDouble: {8 bytes} begin
TempStr := StringOfChar(AnsiChar(#0),8);
UseReg := False;
double((@TempStr[1])^) := double(fvar.dta^);
end;
btCurrency: {8 bytes} begin
TempStr := StringOfChar(AnsiChar(#0),8);
UseReg := False;
currency((@TempStr[1])^) := currency(fvar.dta^);
end;
btSingle: {4 bytes} begin
TempStr := StringOfChar(AnsiChar(#0),4);;
UseReg := False;
Single((@TempStr[1])^) := single(fvar.dta^);
end;
btExtended: {10 bytes} begin
UseReg := False;
TempStr:= StringOfChar(AnsiChar(#0),12);
Extended((@TempStr[1])^) := extended(fvar.dta^);
end;
btChar,
btU8,
btS8: begin
TempStr := tbtchar(fVar^.dta^) + tbtstring(StringOfChar(AnsiChar(#0),3));
end;
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}
btu16, btS16: begin
TempStr := StringOfChar(AnsiChar(#0),4);
Word((@TempStr[1])^) := word(fVar^.dta^);
end;
btu32, bts32: begin
TempStr := StringOfChar(AnsiChar(#0),4);
Longint((@TempStr[1])^) := Longint(fVar^.dta^);
end;
btPchar:
begin
TempStr := StringOfChar(AnsiChar(#0),4);
if pointer(fvar^.dta^) = nil then
Pointer((@TempStr[1])^) := @EmptyPchar
else
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
end;
btclass, btinterface, btString:
begin
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
end;
{$IFNDEF PS_NOWIDESTRING}
btWideString: begin
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
end;
btUnicodeString: begin
TempStr := StringOfChar(AnsiChar(#0),4);
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
end;
{$ENDIF}
btProcPtr:
begin
tempstr := StringOfChar(AnsiChar(#0),8);
TMethod((@TempStr[1])^) := MKMethod(Self, Longint(FVar.Dta^));
UseReg := false;
end;
{$IFNDEF PS_NOINT64}bts64:
begin
TempStr:= StringOfChar(AnsiChar(#0),8);
Int64((@TempStr[1])^) := int64(fvar^.dta^);
UseReg := False;
end;{$ENDIF}
end; {case}
if UseReg then
begin
case RegUsage of
0: begin EAX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
1: begin EDX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
2: begin ECX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
else begin
{$IFDEF FPC_OLD_FIX}
if CallingConv = cdRegister then
Stack := Stack + TempStr
else
{$ENDIF}
Stack := TempStr + Stack;
end;
end;
end else begin
{$IFDEF FPC_OLD_FIX}
if CallingConv = cdRegister then
Stack := Stack + TempStr
else
{$ENDIF}
Stack := TempStr + Stack;
end;
end;
Result := True;
end;
begin
if (Integer(CallingConv) and 64) <> 0 then begin
IsConstructor := true;
CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64);
end else IsConstructor := false;
InnerfuseCall := False;
if Address = nil then
exit; // need address
Stack := '';
CallData := TPSList.Create;
res := rp(res);
if res <> nil then
res.VarParam := true;
try
case CallingConv of
cdRegister: begin
EAX := 0;
EDX := 0;
ECX := 0;
RegUsage := 0;
{$IFDEF FPC} // FIX FOR FPC constructor calls
if IsConstructor then begin
if not GetPtr(rp(Params[0])) then exit; // this goes first
RegUsage := 2;
EDX := Longint(_Self);
Params.Delete(0);
end else
{$ENDIF}
if assigned(_Self) then begin
RegUsage := 1;
EAX := Longint(_Self);
end;
for I := 0 to Params.Count - 1 do
begin
if not GetPtr(rp(Params[I])) then Exit;
end;
if assigned(res) then begin
case res^.aType.BaseType of
{$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}
btInterface, btArray, btrecord, {$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btVariant, btStaticArray: GetPtr(res);
btSet:
begin
if TPSTypeRec_Set(res.aType).aByteSize >4 then GetPtr(res);
end;
end;
case res^.aType.BaseType of
btSet:
begin
case TPSTypeRec_Set(res.aType).aByteSize of
1: byte(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
2: word(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
3,
4: Longint(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
else RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil)
end;
end;
btSingle: tbtsingle(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
btDouble: tbtdouble(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
btExtended: tbtextended(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
btchar,btU8, btS8: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
btClass :
{$IFDEF FPC_OLD_FIX}
tbtu32(res.dta^) := RealCall_Register(Address, EDX, EAX, ECX,
@Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil);
{$ELSE}
tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX,
@Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil);
{$ENDIF}
btu32,bts32: tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
btPChar: pansichar(res.dta^) := Pansichar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
{$IFNDEF PS_NOINT64}bts64:
begin
EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
tbts64(res.dta^) := Int64(Cardinal(EDX)) shl 32 or Cardinal(EAX);
end;
{$ENDIF}
btCurrency: tbtCurrency(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000;
btInterface,
btVariant,
{$IFNDEF PS_NOWIDESTRING}btWidestring,btUnicodestring, {$ENDIF}
btStaticArray, btArray, btrecord{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring {$ENDIF}: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
{$IFDEF PS_FPCSTRINGWORKAROUND}
btstring: begin
eax := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
Longint(res.dta^) := eax;
end;
{$ENDIF}
else
exit;
end;
end else
RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
Result := True;
end;
cdPascal: begin
RegUsage := 3;
for I := 0 to Params.Count - 1 do begin
if not GetPtr(Params[i]) then Exit;
end;
if assigned(res) then begin
case res^.aType.BaseType of
{$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}btInterface, btArray, btrecord, btstring, btVariant: GetPtr(res);
end;
end;
if assigned(_Self) then begin
Stack := StringOfChar(AnsiChar(#0),4) +Stack;
Pointer((@Stack[1])^) := _Self;
end;
if assigned(res) then begin
case res^.aType.BaseType of
btSingle: tbtsingle(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btDouble: tbtdouble(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btExtended: tbtextended(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btChar, btU8, btS8: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
btClass, btu32, bts32: tbtu32(res^.Dta^):= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
{$IFNDEF PS_NOINT64}bts64:
begin
EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
end;
{$ENDIF}
btVariant,
btInterface, btrecord, btstring: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
else
exit;
end;
end else
RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
Result := True;
end;
cdSafeCall: begin
RegUsage := 3;
if assigned(res) then begin
GetPtr(res);
end;
for I := Params.Count - 1 downto 0 do begin
if not GetPtr(Params[i]) then Exit;
end;
if assigned(_Self) then begin
Stack := StringOfChar(AnsiChar(#0),4) +Stack;
Pointer((@Stack[1])^) := _Self;
end;
OleCheck(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
Result := True;
end;
CdCdecl: begin
RegUsage := 3;
if assigned(_Self) then begin
Stack := StringOfChar(AnsiChar(#0),4);
Pointer((@Stack[1])^) := _Self;
end;
for I := Params.Count - 1 downto 0 do begin
if not GetPtr(Params[I]) then Exit;
end;
if assigned(res) then begin
case res^.aType.BaseType of
btSingle: tbtsingle(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btDouble: tbtdouble(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btExtended: tbtextended(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btCHar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
btClass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
{$IFNDEF PS_NOINT64}bts64:
begin
EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
tbts64(res^.Dta^) := Int64(EAX) shl 32 or EDX;
end;
{$ENDIF}
btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}
btInterface,
btArray, btrecord, btstring: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
else
exit;
end;
end else begin
RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
end;
Result := True;
end;
CdStdCall: begin
RegUsage := 3;
for I := Params.Count - 1 downto 0 do begin
if not GetPtr(Params[I]) then exit;
end;
if assigned(_Self) then begin
Stack := StringOfChar(AnsiChar(#0),4) + Stack;
Pointer((@Stack[1])^) := _Self;
end;
if assigned(res) then begin
case res^.aType.BaseType of
btSingle: tbtsingle(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btDouble: tbtdouble(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btExtended: tbtextended(res^.dta^):= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
btChar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
btclass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
{$IFNDEF PS_NOINT64}bts64:
begin
EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
end;
{$ENDIF}
btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}
btInterface, btArray, btrecord, btstring: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
else
exit;
end;
end else begin
RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
end;
Result := True;
end;
end;
finally
for i := CallData.Count -1 downto 0 do
begin
pp := CallData[i];
case pp^ of
0: DestroyOpenArray(Self, Pointer(pp));
end;
end;
CallData.Free;
end;
end;