source upload
This commit is contained in:
Razor12911
@@ -0,0 +1,307 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<jmeterTestPlan version="1.2" properties="2.9" jmeter="3.0 r1743807">
|
||||
<hashTree>
|
||||
<TestPlan guiclass="TestPlanGui" testclass="TestPlan" testname="Test Plan - MormotREST.exe" enabled="true">
|
||||
<stringProp name="TestPlan.comments"></stringProp>
|
||||
<boolProp name="TestPlan.functional_mode">false</boolProp>
|
||||
<boolProp name="TestPlan.serialize_threadgroups">false</boolProp>
|
||||
<elementProp name="TestPlan.user_defined_variables" elementType="Arguments" guiclass="ArgumentsPanel" testclass="Arguments" testname="User Defined Variables" enabled="true">
|
||||
<collectionProp name="Arguments.arguments"/>
|
||||
</elementProp>
|
||||
<stringProp name="TestPlan.user_define_classpath"></stringProp>
|
||||
</TestPlan>
|
||||
<hashTree>
|
||||
<ThreadGroup guiclass="ThreadGroupGui" testclass="ThreadGroup" testname="Thread Group" enabled="true">
|
||||
<stringProp name="ThreadGroup.on_sample_error">continue</stringProp>
|
||||
<elementProp name="ThreadGroup.main_controller" elementType="LoopController" guiclass="LoopControlPanel" testclass="LoopController" testname="Loop Controller" enabled="true">
|
||||
<boolProp name="LoopController.continue_forever">false</boolProp>
|
||||
<stringProp name="LoopController.loops">1</stringProp>
|
||||
</elementProp>
|
||||
<stringProp name="ThreadGroup.num_threads">1</stringProp>
|
||||
<stringProp name="ThreadGroup.ramp_time">1</stringProp>
|
||||
<longProp name="ThreadGroup.start_time">1464256651000</longProp>
|
||||
<longProp name="ThreadGroup.end_time">1464256651000</longProp>
|
||||
<boolProp name="ThreadGroup.scheduler">false</boolProp>
|
||||
<stringProp name="ThreadGroup.duration"></stringProp>
|
||||
<stringProp name="ThreadGroup.delay"></stringProp>
|
||||
</ThreadGroup>
|
||||
<hashTree>
|
||||
<HeaderManager guiclass="HeaderPanel" testclass="HeaderManager" testname="HTTP Headers" enabled="true">
|
||||
<collectionProp name="HeaderManager.headers">
|
||||
<elementProp name="" elementType="Header">
|
||||
<stringProp name="Header.name">Cache-Control</stringProp>
|
||||
<stringProp name="Header.value">no-cache</stringProp>
|
||||
</elementProp>
|
||||
<elementProp name="" elementType="Header">
|
||||
<stringProp name="Header.name">Pragma</stringProp>
|
||||
<stringProp name="Header.value">no-cache</stringProp>
|
||||
</elementProp>
|
||||
<elementProp name="" elementType="Header">
|
||||
<stringProp name="Header.name">Content-Type</stringProp>
|
||||
<stringProp name="Header.value">application/json; charset=UTF-8</stringProp>
|
||||
</elementProp>
|
||||
</collectionProp>
|
||||
</HeaderManager>
|
||||
<hashTree/>
|
||||
<HTTPSamplerProxy guiclass="HttpTestSampleGui" testclass="HTTPSamplerProxy" testname="/service/RestMethods.HelloWorld" enabled="true">
|
||||
<elementProp name="HTTPsampler.Arguments" elementType="Arguments" guiclass="HTTPArgumentsPanel" testclass="Arguments" testname="User Defined Variables" enabled="true">
|
||||
<collectionProp name="Arguments.arguments"/>
|
||||
</elementProp>
|
||||
<stringProp name="HTTPSampler.domain">127.0.0.1</stringProp>
|
||||
<stringProp name="HTTPSampler.port">777</stringProp>
|
||||
<stringProp name="HTTPSampler.connect_timeout">500</stringProp>
|
||||
<stringProp name="HTTPSampler.response_timeout"></stringProp>
|
||||
<stringProp name="HTTPSampler.protocol"></stringProp>
|
||||
<stringProp name="HTTPSampler.contentEncoding">UTF-8</stringProp>
|
||||
<stringProp name="HTTPSampler.path">/service/RestMethods.HelloWorld</stringProp>
|
||||
<stringProp name="HTTPSampler.method">POST</stringProp>
|
||||
<boolProp name="HTTPSampler.follow_redirects">true</boolProp>
|
||||
<boolProp name="HTTPSampler.auto_redirects">false</boolProp>
|
||||
<boolProp name="HTTPSampler.use_keepalive">true</boolProp>
|
||||
<boolProp name="HTTPSampler.DO_MULTIPART_POST">false</boolProp>
|
||||
<stringProp name="HTTPSampler.implementation">HttpClient4</stringProp>
|
||||
<boolProp name="HTTPSampler.monitor">false</boolProp>
|
||||
<stringProp name="HTTPSampler.embedded_url_re"></stringProp>
|
||||
</HTTPSamplerProxy>
|
||||
<hashTree/>
|
||||
<HTTPSamplerProxy guiclass="HttpTestSampleGui" testclass="HTTPSamplerProxy" testname="/service/RestMethods.Sum" enabled="true">
|
||||
<boolProp name="HTTPSampler.postBodyRaw">true</boolProp>
|
||||
<elementProp name="HTTPsampler.Arguments" elementType="Arguments">
|
||||
<collectionProp name="Arguments.arguments">
|
||||
<elementProp name="" elementType="HTTPArgument">
|
||||
<boolProp name="HTTPArgument.always_encode">false</boolProp>
|
||||
<stringProp name="Argument.value">[78.6,13.3]</stringProp>
|
||||
<stringProp name="Argument.metadata">=</stringProp>
|
||||
</elementProp>
|
||||
</collectionProp>
|
||||
</elementProp>
|
||||
<stringProp name="HTTPSampler.domain">127.0.0.1</stringProp>
|
||||
<stringProp name="HTTPSampler.port">777</stringProp>
|
||||
<stringProp name="HTTPSampler.connect_timeout">500</stringProp>
|
||||
<stringProp name="HTTPSampler.response_timeout"></stringProp>
|
||||
<stringProp name="HTTPSampler.protocol"></stringProp>
|
||||
<stringProp name="HTTPSampler.contentEncoding">UTF-8</stringProp>
|
||||
<stringProp name="HTTPSampler.path">/service/RestMethods.Sum</stringProp>
|
||||
<stringProp name="HTTPSampler.method">POST</stringProp>
|
||||
<boolProp name="HTTPSampler.follow_redirects">true</boolProp>
|
||||
<boolProp name="HTTPSampler.auto_redirects">false</boolProp>
|
||||
<boolProp name="HTTPSampler.use_keepalive">true</boolProp>
|
||||
<boolProp name="HTTPSampler.DO_MULTIPART_POST">false</boolProp>
|
||||
<stringProp name="HTTPSampler.implementation">HttpClient4</stringProp>
|
||||
<boolProp name="HTTPSampler.monitor">false</boolProp>
|
||||
<stringProp name="HTTPSampler.embedded_url_re"></stringProp>
|
||||
</HTTPSamplerProxy>
|
||||
<hashTree/>
|
||||
<HTTPSamplerProxy guiclass="HttpTestSampleGui" testclass="HTTPSamplerProxy" testname="/service/RestMethods.GetCustomRecord" enabled="true">
|
||||
<boolProp name="HTTPSampler.postBodyRaw">true</boolProp>
|
||||
<elementProp name="HTTPsampler.Arguments" elementType="Arguments">
|
||||
<collectionProp name="Arguments.arguments">
|
||||
<elementProp name="" elementType="HTTPArgument">
|
||||
<boolProp name="HTTPArgument.always_encode">false</boolProp>
|
||||
<stringProp name="Argument.value"></stringProp>
|
||||
<stringProp name="Argument.metadata">=</stringProp>
|
||||
</elementProp>
|
||||
</collectionProp>
|
||||
</elementProp>
|
||||
<stringProp name="HTTPSampler.domain">127.0.0.1</stringProp>
|
||||
<stringProp name="HTTPSampler.port">777</stringProp>
|
||||
<stringProp name="HTTPSampler.connect_timeout">500</stringProp>
|
||||
<stringProp name="HTTPSampler.response_timeout"></stringProp>
|
||||
<stringProp name="HTTPSampler.protocol"></stringProp>
|
||||
<stringProp name="HTTPSampler.contentEncoding">UTF-8</stringProp>
|
||||
<stringProp name="HTTPSampler.path">/service/RestMethods.GetCustomRecord</stringProp>
|
||||
<stringProp name="HTTPSampler.method">POST</stringProp>
|
||||
<boolProp name="HTTPSampler.follow_redirects">true</boolProp>
|
||||
<boolProp name="HTTPSampler.auto_redirects">false</boolProp>
|
||||
<boolProp name="HTTPSampler.use_keepalive">true</boolProp>
|
||||
<boolProp name="HTTPSampler.DO_MULTIPART_POST">false</boolProp>
|
||||
<stringProp name="HTTPSampler.implementation">HttpClient4</stringProp>
|
||||
<boolProp name="HTTPSampler.monitor">false</boolProp>
|
||||
<stringProp name="HTTPSampler.embedded_url_re"></stringProp>
|
||||
</HTTPSamplerProxy>
|
||||
<hashTree/>
|
||||
<HTTPSamplerProxy guiclass="HttpTestSampleGui" testclass="HTTPSamplerProxy" testname="/service/RestMethods.SendCustomRecord" enabled="true">
|
||||
<boolProp name="HTTPSampler.postBodyRaw">true</boolProp>
|
||||
<elementProp name="HTTPsampler.Arguments" elementType="Arguments">
|
||||
<collectionProp name="Arguments.arguments">
|
||||
<elementProp name="" elementType="HTTPArgument">
|
||||
<boolProp name="HTTPArgument.always_encode">false</boolProp>
|
||||
<stringProp name="Argument.value">[ 
|
||||
{ 
|
||||
"ResultCode":200,
|
||||
"ResultStr":"Awesome",
|
||||
"ResultArray":[ 
|
||||
"str_0",
|
||||
"str_1",
|
||||
"str_2"
|
||||
],
|
||||
"ResultTimeStamp":"2016-06-01T19:42:14"
|
||||
}
|
||||
]</stringProp>
|
||||
<stringProp name="Argument.metadata">=</stringProp>
|
||||
</elementProp>
|
||||
</collectionProp>
|
||||
</elementProp>
|
||||
<stringProp name="HTTPSampler.domain">127.0.0.1</stringProp>
|
||||
<stringProp name="HTTPSampler.port">777</stringProp>
|
||||
<stringProp name="HTTPSampler.connect_timeout">500</stringProp>
|
||||
<stringProp name="HTTPSampler.response_timeout"></stringProp>
|
||||
<stringProp name="HTTPSampler.protocol"></stringProp>
|
||||
<stringProp name="HTTPSampler.contentEncoding">UTF-8</stringProp>
|
||||
<stringProp name="HTTPSampler.path">/service/RestMethods.SendCustomRecord</stringProp>
|
||||
<stringProp name="HTTPSampler.method">POST</stringProp>
|
||||
<boolProp name="HTTPSampler.follow_redirects">true</boolProp>
|
||||
<boolProp name="HTTPSampler.auto_redirects">false</boolProp>
|
||||
<boolProp name="HTTPSampler.use_keepalive">true</boolProp>
|
||||
<boolProp name="HTTPSampler.DO_MULTIPART_POST">false</boolProp>
|
||||
<stringProp name="HTTPSampler.implementation">HttpClient4</stringProp>
|
||||
<boolProp name="HTTPSampler.monitor">false</boolProp>
|
||||
<stringProp name="HTTPSampler.embedded_url_re"></stringProp>
|
||||
</HTTPSamplerProxy>
|
||||
<hashTree/>
|
||||
<HTTPSamplerProxy guiclass="HttpTestSampleGui" testclass="HTTPSamplerProxy" testname="/service/RestMethods.SendMultipleCustomRecords" enabled="true">
|
||||
<boolProp name="HTTPSampler.postBodyRaw">true</boolProp>
|
||||
<elementProp name="HTTPsampler.Arguments" elementType="Arguments">
|
||||
<collectionProp name="Arguments.arguments">
|
||||
<elementProp name="" elementType="HTTPArgument">
|
||||
<boolProp name="HTTPArgument.always_encode">false</boolProp>
|
||||
<stringProp name="Argument.value">[ 
|
||||
{ 
|
||||
"ResultCode":200,
|
||||
"ResultStr":"Awesome",
|
||||
"ResultArray":[ 
|
||||
"str_0",
|
||||
"str_1",
|
||||
"str_2"
|
||||
],
|
||||
"ResultTimeStamp":"2016-06-01T19:42:14"
|
||||
},
|
||||
{
|
||||
"SimpleString": "Simple string, Простая строка",
|
||||
"SimpleInteger":100500,
|
||||
"AnotherRecord": {
|
||||
"ResultCode":200,
|
||||
"ResultStr":"Awesome",
|
||||
"ResultArray":[ 
|
||||
"str_0",
|
||||
"str_1",
|
||||
"str_2"
|
||||
],
|
||||
"ResultTimeStamp":"2016-06-01T19:42:14" 
|
||||
}
|
||||
}
|
||||
]</stringProp>
|
||||
<stringProp name="Argument.metadata">=</stringProp>
|
||||
</elementProp>
|
||||
</collectionProp>
|
||||
</elementProp>
|
||||
<stringProp name="HTTPSampler.domain">127.0.0.1</stringProp>
|
||||
<stringProp name="HTTPSampler.port">777</stringProp>
|
||||
<stringProp name="HTTPSampler.connect_timeout">500</stringProp>
|
||||
<stringProp name="HTTPSampler.response_timeout"></stringProp>
|
||||
<stringProp name="HTTPSampler.protocol"></stringProp>
|
||||
<stringProp name="HTTPSampler.contentEncoding">UTF-8</stringProp>
|
||||
<stringProp name="HTTPSampler.path">/service/RestMethods.SendMultipleCustomRecords</stringProp>
|
||||
<stringProp name="HTTPSampler.method">POST</stringProp>
|
||||
<boolProp name="HTTPSampler.follow_redirects">true</boolProp>
|
||||
<boolProp name="HTTPSampler.auto_redirects">false</boolProp>
|
||||
<boolProp name="HTTPSampler.use_keepalive">true</boolProp>
|
||||
<boolProp name="HTTPSampler.DO_MULTIPART_POST">false</boolProp>
|
||||
<stringProp name="HTTPSampler.implementation">HttpClient4</stringProp>
|
||||
<boolProp name="HTTPSampler.monitor">false</boolProp>
|
||||
<stringProp name="HTTPSampler.embedded_url_re"></stringProp>
|
||||
</HTTPSamplerProxy>
|
||||
<hashTree/>
|
||||
<HTTPSamplerProxy guiclass="HttpTestSampleGui" testclass="HTTPSamplerProxy" testname="/service/RestMethods.GetMethodCustomResult" enabled="true">
|
||||
<elementProp name="HTTPsampler.Arguments" elementType="Arguments" guiclass="HTTPArgumentsPanel" testclass="Arguments" testname="User Defined Variables" enabled="true">
|
||||
<collectionProp name="Arguments.arguments"/>
|
||||
</elementProp>
|
||||
<stringProp name="HTTPSampler.domain">127.0.0.1</stringProp>
|
||||
<stringProp name="HTTPSampler.port">777</stringProp>
|
||||
<stringProp name="HTTPSampler.connect_timeout">500</stringProp>
|
||||
<stringProp name="HTTPSampler.response_timeout"></stringProp>
|
||||
<stringProp name="HTTPSampler.protocol"></stringProp>
|
||||
<stringProp name="HTTPSampler.contentEncoding">UTF-8</stringProp>
|
||||
<stringProp name="HTTPSampler.path">/service/RestMethods.GetMethodCustomResult</stringProp>
|
||||
<stringProp name="HTTPSampler.method">POST</stringProp>
|
||||
<boolProp name="HTTPSampler.follow_redirects">true</boolProp>
|
||||
<boolProp name="HTTPSampler.auto_redirects">false</boolProp>
|
||||
<boolProp name="HTTPSampler.use_keepalive">true</boolProp>
|
||||
<boolProp name="HTTPSampler.DO_MULTIPART_POST">false</boolProp>
|
||||
<stringProp name="HTTPSampler.implementation">HttpClient4</stringProp>
|
||||
<boolProp name="HTTPSampler.monitor">false</boolProp>
|
||||
<stringProp name="HTTPSampler.embedded_url_re"></stringProp>
|
||||
</HTTPSamplerProxy>
|
||||
<hashTree/>
|
||||
</hashTree>
|
||||
<ResultCollector guiclass="ViewResultsFullVisualizer" testclass="ResultCollector" testname="View Results Tree" enabled="true">
|
||||
<boolProp name="ResultCollector.error_logging">false</boolProp>
|
||||
<objProp>
|
||||
<name>saveConfig</name>
|
||||
<value class="SampleSaveConfiguration">
|
||||
<time>true</time>
|
||||
<latency>true</latency>
|
||||
<timestamp>true</timestamp>
|
||||
<success>true</success>
|
||||
<label>true</label>
|
||||
<code>true</code>
|
||||
<message>true</message>
|
||||
<threadName>true</threadName>
|
||||
<dataType>true</dataType>
|
||||
<encoding>false</encoding>
|
||||
<assertions>true</assertions>
|
||||
<subresults>true</subresults>
|
||||
<responseData>false</responseData>
|
||||
<samplerData>false</samplerData>
|
||||
<xml>false</xml>
|
||||
<fieldNames>true</fieldNames>
|
||||
<responseHeaders>false</responseHeaders>
|
||||
<requestHeaders>false</requestHeaders>
|
||||
<responseDataOnError>false</responseDataOnError>
|
||||
<saveAssertionResultsFailureMessage>true</saveAssertionResultsFailureMessage>
|
||||
<assertionsResultsToSave>0</assertionsResultsToSave>
|
||||
<bytes>true</bytes>
|
||||
<threadCounts>true</threadCounts>
|
||||
<idleTime>true</idleTime>
|
||||
</value>
|
||||
</objProp>
|
||||
<stringProp name="filename"></stringProp>
|
||||
</ResultCollector>
|
||||
<hashTree/>
|
||||
<ResultCollector guiclass="SummaryReport" testclass="ResultCollector" testname="Summary Report" enabled="false">
|
||||
<boolProp name="ResultCollector.error_logging">false</boolProp>
|
||||
<objProp>
|
||||
<name>saveConfig</name>
|
||||
<value class="SampleSaveConfiguration">
|
||||
<time>true</time>
|
||||
<latency>true</latency>
|
||||
<timestamp>true</timestamp>
|
||||
<success>true</success>
|
||||
<label>true</label>
|
||||
<code>true</code>
|
||||
<message>true</message>
|
||||
<threadName>true</threadName>
|
||||
<dataType>true</dataType>
|
||||
<encoding>false</encoding>
|
||||
<assertions>true</assertions>
|
||||
<subresults>true</subresults>
|
||||
<responseData>false</responseData>
|
||||
<samplerData>false</samplerData>
|
||||
<xml>false</xml>
|
||||
<fieldNames>true</fieldNames>
|
||||
<responseHeaders>false</responseHeaders>
|
||||
<requestHeaders>false</requestHeaders>
|
||||
<responseDataOnError>false</responseDataOnError>
|
||||
<saveAssertionResultsFailureMessage>true</saveAssertionResultsFailureMessage>
|
||||
<assertionsResultsToSave>0</assertionsResultsToSave>
|
||||
<bytes>true</bytes>
|
||||
<threadCounts>true</threadCounts>
|
||||
<idleTime>true</idleTime>
|
||||
</value>
|
||||
</objProp>
|
||||
<stringProp name="filename"></stringProp>
|
||||
</ResultCollector>
|
||||
<hashTree/>
|
||||
</hashTree>
|
||||
</hashTree>
|
||||
</jmeterTestPlan>
|
||||
@@ -0,0 +1,64 @@
|
||||
# mORMot.REST
|
||||
Testing mORMot REST capabilities, a project from George.
|
||||
|
||||
FPC version by Alf, retrieved from https://github.com/LongDirtyAnimAlf/mORMot.REST
|
||||
|
||||
# Presentation
|
||||
|
||||
It's my first meeting with mORMot, so, something may be unoptimized or implemented wrong.
|
||||
Feel free to post your suggestions. Don't forget that this is not final build, there is a lot to do.
|
||||
|
||||
I use REST services via interfaces, IMO it's more friendly for developers.
|
||||
You may find that project group contain both server and client projects.
|
||||
In addition, you can use .jmx files with apache jmeter to simulate multiclient heavy load via HTTP connection.
|
||||
|
||||
|
||||
|
||||
# 2do
|
||||
Category / Status | Feature
|
||||
--- | ---
|
||||
**mORMot REST architecture** |
|
||||
`done` | Services via interfaces
|
||||
**Protocol usage** |
|
||||
`done` | HTTP (socket)
|
||||
`done` | › HTTP (http.sys)
|
||||
`done` | ›› HTTPS (http.sys + SSL)
|
||||
`done` | › HTTP (http.sys + AES-CFB 256)
|
||||
`done` | HTTP (web socket)
|
||||
`done` | › WebSocket (bidirectional, JSON)
|
||||
`done` | › WebSocket (bidirectional, Binary)
|
||||
`done` | › WebSocket (bidirectional, Binary + AES)
|
||||
`done` | Named pipe (on local PC or LAN network)
|
||||
**Method interfaces** |
|
||||
`done` | IRestMethods (no session support).
|
||||
`.` | IRestMethodsEx (session support, callback support).
|
||||
**Authentication schemes** |
|
||||
`done` | No authentication
|
||||
`done` | Default
|
||||
`done` | None
|
||||
`done` | HTTP Basic
|
||||
`done` | SSPI
|
||||
**Authorization** |
|
||||
`done` | Allow all to execute any method
|
||||
`done` | Deny all to execute any method
|
||||
`done` | Follow method / group settings
|
||||
**jmx test plan** (without authentication) |
|
||||
`done` | Method call via URL
|
||||
`done` | Send parameters via body
|
||||
`done` | Method result as JSON object
|
||||
`done` | Send JSON objects via body
|
||||
`done` | Send multiple JSON objects via body
|
||||
`done` | Custom method result
|
||||
`done` | Detect empty parameters from server side
|
||||
**Other** |
|
||||
`done` | Improve certificate installation to support windows 7 (for https).
|
||||
`.` | HTTP/s proxy bypass
|
||||
`.` | Improve speed while log output enabled
|
||||
`?` | Apply roles and groups without restart (if possible, not sure, need check)
|
||||
`(optional)` | Refactoring
|
||||
|
||||
Official Synopse mORMot repository [available here][mormot-repo].
|
||||
Official Synopse mORMot documentation [available here][mormot-docs].
|
||||
|
||||
[mormot-repo]: <https://github.com/synopse/mORMot>
|
||||
[mormot-docs]: <http://synopse.info/files/html/Synopse%20mORMot%20Framework%20SAD%201.18.html>
|
||||
@@ -0,0 +1,261 @@
|
||||
object Form1: TForm1
|
||||
Left = 0
|
||||
Top = 0
|
||||
Caption = 'CL.mORMot REST test'
|
||||
ClientHeight = 469
|
||||
ClientWidth = 1174
|
||||
Color = clBtnFace
|
||||
Constraints.MinHeight = 205
|
||||
Constraints.MinWidth = 815
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = []
|
||||
OldCreateOrder = False
|
||||
Position = poScreenCenter
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
DesignSize = (
|
||||
1174
|
||||
469)
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 13
|
||||
object LabelAuthenticationMode: TLabel
|
||||
Left = 37
|
||||
Top = 38
|
||||
Width = 74
|
||||
Height = 13
|
||||
Caption = 'Authentication:'
|
||||
end
|
||||
object LabelProtocol: TLabel
|
||||
Left = 68
|
||||
Top = 11
|
||||
Width = 43
|
||||
Height = 13
|
||||
Caption = 'Protocol:'
|
||||
end
|
||||
object Label1: TLabel
|
||||
Left = 799
|
||||
Top = 11
|
||||
Width = 80
|
||||
Height = 13
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Server and port:'
|
||||
end
|
||||
object Label2: TLabel
|
||||
Left = 780
|
||||
Top = 38
|
||||
Width = 99
|
||||
Height = 13
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Login and password:'
|
||||
end
|
||||
object EditServerAdress: TEdit
|
||||
Left = 885
|
||||
Top = 8
|
||||
Width = 99
|
||||
Height = 21
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 0
|
||||
Text = '127.0.0.1'
|
||||
TextHint = 'Server adress (IP or HostName)'
|
||||
end
|
||||
object EditServerPort: TEdit
|
||||
Left = 990
|
||||
Top = 8
|
||||
Width = 65
|
||||
Height = 21
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 1
|
||||
Text = '777'
|
||||
TextHint = 'Port'
|
||||
end
|
||||
object ButtonStartStop: TButton
|
||||
Left = 1061
|
||||
Top = 16
|
||||
Width = 105
|
||||
Height = 33
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Start client'
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = [fsBold]
|
||||
ParentFont = False
|
||||
TabOrder = 2
|
||||
OnClick = ButtonStartStopClick
|
||||
end
|
||||
object GroupBoxIRestMethods: TGroupBox
|
||||
Left = 8
|
||||
Top = 75
|
||||
Width = 720
|
||||
Height = 54
|
||||
Caption = 'IRestMethods (InstanceImplementation = sicSingle)'
|
||||
TabOrder = 3
|
||||
object ButtonMethHelloWorld: TButton
|
||||
Left = 8
|
||||
Top = 19
|
||||
Width = 81
|
||||
Height = 23
|
||||
Caption = 'HelloWorld'
|
||||
TabOrder = 0
|
||||
OnClick = ButtonMethHelloWorldClick
|
||||
end
|
||||
object ButtonMethSum: TButton
|
||||
Left = 95
|
||||
Top = 19
|
||||
Width = 50
|
||||
Height = 23
|
||||
Caption = 'Sum'
|
||||
TabOrder = 1
|
||||
OnClick = ButtonMethSumClick
|
||||
end
|
||||
object ButtonGetCustomRecord: TButton
|
||||
Left = 151
|
||||
Top = 19
|
||||
Width = 137
|
||||
Height = 23
|
||||
Caption = 'GetCustomRecord'
|
||||
TabOrder = 2
|
||||
OnClick = ButtonGetCustomRecordClick
|
||||
end
|
||||
object ButtonMethSendCustomRecord: TButton
|
||||
Left = 294
|
||||
Top = 19
|
||||
Width = 115
|
||||
Height = 23
|
||||
Caption = 'SendCustomRecord'
|
||||
TabOrder = 3
|
||||
OnClick = ButtonMethSendCustomRecordClick
|
||||
end
|
||||
object ButtonMethSendMultipleCustomRecords: TButton
|
||||
Left = 415
|
||||
Top = 19
|
||||
Width = 154
|
||||
Height = 23
|
||||
Caption = 'SendMultipleCustomRecords'
|
||||
TabOrder = 4
|
||||
OnClick = ButtonMethSendMultipleCustomRecordsClick
|
||||
end
|
||||
object ButtonMethGetMethodCustomResult: TButton
|
||||
Left = 572
|
||||
Top = 19
|
||||
Width = 141
|
||||
Height = 23
|
||||
Caption = 'GetMethodCustomResult'
|
||||
TabOrder = 5
|
||||
OnClick = ButtonMethGetMethodCustomResultClick
|
||||
end
|
||||
end
|
||||
object ComboBoxAuthentication: TComboBox
|
||||
Left = 117
|
||||
Top = 35
|
||||
Width = 388
|
||||
Height = 21
|
||||
Style = csDropDownList
|
||||
ItemIndex = 1
|
||||
TabOrder = 4
|
||||
Text = 'Default'
|
||||
OnChange = ComboBoxAuthenticationChange
|
||||
Items.Strings = (
|
||||
'No authentication'
|
||||
'Default'
|
||||
'None'
|
||||
'HttpBasic'
|
||||
'SSPI')
|
||||
end
|
||||
object MemoLog: TMemo
|
||||
Left = 8
|
||||
Top = 135
|
||||
Width = 1158
|
||||
Height = 298
|
||||
Anchors = [akLeft, akTop, akRight, akBottom]
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -12
|
||||
Font.Name = 'Consolas'
|
||||
Font.Style = []
|
||||
ParentFont = False
|
||||
ScrollBars = ssVertical
|
||||
TabOrder = 5
|
||||
end
|
||||
object ButtonCLS: TButton
|
||||
Left = 10
|
||||
Top = 439
|
||||
Width = 38
|
||||
Height = 22
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'CLS'
|
||||
TabOrder = 6
|
||||
OnClick = ButtonCLSClick
|
||||
end
|
||||
object CheckBoxAutoScroll: TCheckBox
|
||||
Left = 57
|
||||
Top = 441
|
||||
Width = 69
|
||||
Height = 17
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'auto scroll'
|
||||
Checked = True
|
||||
State = cbChecked
|
||||
TabOrder = 7
|
||||
end
|
||||
object CheckBoxDisableLog: TCheckBox
|
||||
Left = 133
|
||||
Top = 441
|
||||
Width = 203
|
||||
Height = 17
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'disable log (for max performance test)'
|
||||
TabOrder = 8
|
||||
OnClick = CheckBoxDisableLogClick
|
||||
end
|
||||
object ComboBoxProtocol: TComboBox
|
||||
Left = 117
|
||||
Top = 8
|
||||
Width = 388
|
||||
Height = 21
|
||||
Style = csDropDownList
|
||||
ItemIndex = 7
|
||||
TabOrder = 9
|
||||
Text = ' '#8250' WebSocket ( bidirectional, binary + AES-CFB 256)'
|
||||
OnChange = ComboBoxProtocolChange
|
||||
Items.Strings = (
|
||||
'HTTP ( socket )'
|
||||
' '#8250' HTTP ( fast http.sys )'
|
||||
' '#8250#8250' HTTPS ( fast http.sys + SSL )'
|
||||
' '#8250#8250' HTTP ( fast http.sys + AES-CFB 256 )'
|
||||
'HTTP ( web socket )'
|
||||
' '#8250' WebSocket ( bidirectional, JSON )'
|
||||
' '#8250' WebSocket ( bidirectional, binary )'
|
||||
' '#8250' WebSocket ( bidirectional, binary + AES-CFB 256)'
|
||||
'Named pipe')
|
||||
end
|
||||
object EditUserLogin: TEdit
|
||||
Left = 885
|
||||
Top = 35
|
||||
Width = 99
|
||||
Height = 21
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 10
|
||||
Text = 'George'
|
||||
TextHint = 'Login'
|
||||
end
|
||||
object EditUserPassword: TEdit
|
||||
Left = 990
|
||||
Top = 35
|
||||
Width = 65
|
||||
Height = 21
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 11
|
||||
Text = '123'
|
||||
TextHint = 'Password'
|
||||
end
|
||||
object TimerRefreshLogMemo: TTimer
|
||||
OnTimer = TimerRefreshLogMemoTimer
|
||||
Left = 56
|
||||
Top = 144
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,263 @@
|
||||
object Form1: TForm1
|
||||
Left = 250
|
||||
Height = 265
|
||||
Top = 247
|
||||
Width = 815
|
||||
Caption = 'CL.mORMot REST test'
|
||||
ClientHeight = 265
|
||||
ClientWidth = 815
|
||||
Color = clBtnFace
|
||||
Constraints.MinHeight = 205
|
||||
Constraints.MinWidth = 815
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
Position = poScreenCenter
|
||||
LCLVersion = '1.7'
|
||||
object LabelAuthenticationMode: TLabel
|
||||
Left = 37
|
||||
Height = 13
|
||||
Top = 38
|
||||
Width = 74
|
||||
Caption = 'Authentication:'
|
||||
ParentColor = False
|
||||
end
|
||||
object LabelProtocol: TLabel
|
||||
Left = 68
|
||||
Height = 13
|
||||
Top = 11
|
||||
Width = 43
|
||||
Caption = 'Protocol:'
|
||||
ParentColor = False
|
||||
end
|
||||
object Label1: TLabel
|
||||
Left = 440
|
||||
Height = 13
|
||||
Top = 11
|
||||
Width = 80
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Server and port:'
|
||||
ParentColor = False
|
||||
end
|
||||
object Label2: TLabel
|
||||
Left = 421
|
||||
Height = 13
|
||||
Top = 38
|
||||
Width = 99
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Login and password:'
|
||||
ParentColor = False
|
||||
end
|
||||
object EditServerAdress: TEdit
|
||||
Left = 526
|
||||
Height = 21
|
||||
Top = 8
|
||||
Width = 99
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 0
|
||||
Text = '127.0.0.1'
|
||||
TextHint = 'Server adress (IP or HostName)'
|
||||
end
|
||||
object EditServerPort: TEdit
|
||||
Left = 631
|
||||
Height = 21
|
||||
Top = 8
|
||||
Width = 65
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 1
|
||||
Text = '777'
|
||||
TextHint = 'Port'
|
||||
end
|
||||
object ButtonStartStop: TButton
|
||||
Left = 702
|
||||
Height = 33
|
||||
Top = 16
|
||||
Width = 105
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Start client'
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = [fsBold]
|
||||
OnClick = ButtonStartStopClick
|
||||
ParentFont = False
|
||||
TabOrder = 2
|
||||
end
|
||||
object GroupBoxIRestMethods: TGroupBox
|
||||
Left = 8
|
||||
Height = 69
|
||||
Top = 75
|
||||
Width = 720
|
||||
Caption = 'IRestMethods (InstanceImplementation = sicSingle)'
|
||||
ClientHeight = 51
|
||||
ClientWidth = 716
|
||||
TabOrder = 3
|
||||
object ButtonMethHelloWorld: TButton
|
||||
Left = 8
|
||||
Height = 23
|
||||
Top = 19
|
||||
Width = 81
|
||||
Caption = 'HelloWorld'
|
||||
OnClick = ButtonMethHelloWorldClick
|
||||
TabOrder = 0
|
||||
end
|
||||
object ButtonMethSum: TButton
|
||||
Left = 95
|
||||
Height = 23
|
||||
Top = 19
|
||||
Width = 50
|
||||
Caption = 'Sum'
|
||||
OnClick = ButtonMethSumClick
|
||||
TabOrder = 1
|
||||
end
|
||||
object ButtonGetCustomRecord: TButton
|
||||
Left = 151
|
||||
Height = 23
|
||||
Top = 19
|
||||
Width = 137
|
||||
Caption = 'GetCustomRecord'
|
||||
OnClick = ButtonGetCustomRecordClick
|
||||
TabOrder = 2
|
||||
end
|
||||
object ButtonMethSendCustomRecord: TButton
|
||||
Left = 294
|
||||
Height = 23
|
||||
Top = 19
|
||||
Width = 115
|
||||
Caption = 'SendCustomRecord'
|
||||
OnClick = ButtonMethSendCustomRecordClick
|
||||
TabOrder = 3
|
||||
end
|
||||
object ButtonMethSendMultipleCustomRecords: TButton
|
||||
Left = 415
|
||||
Height = 23
|
||||
Top = 19
|
||||
Width = 154
|
||||
Caption = 'SendMultipleCustomRecords'
|
||||
OnClick = ButtonMethSendMultipleCustomRecordsClick
|
||||
TabOrder = 4
|
||||
end
|
||||
object ButtonMethGetMethodCustomResult: TButton
|
||||
Left = 572
|
||||
Height = 23
|
||||
Top = 19
|
||||
Width = 141
|
||||
Caption = 'GetMethodCustomResult'
|
||||
OnClick = ButtonMethGetMethodCustomResultClick
|
||||
TabOrder = 5
|
||||
end
|
||||
end
|
||||
object ComboBoxAuthentication: TComboBox
|
||||
Left = 117
|
||||
Height = 21
|
||||
Top = 35
|
||||
Width = 292
|
||||
ItemHeight = 13
|
||||
ItemIndex = 1
|
||||
Items.Strings = (
|
||||
'No authentication'
|
||||
'Default'
|
||||
'None'
|
||||
'HttpBasic'
|
||||
'SSPI'
|
||||
)
|
||||
OnChange = ComboBoxAuthenticationChange
|
||||
Style = csDropDownList
|
||||
TabOrder = 4
|
||||
Text = 'Default'
|
||||
end
|
||||
object MemoLog: TMemo
|
||||
Left = 8
|
||||
Height = 77
|
||||
Top = 152
|
||||
Width = 799
|
||||
Anchors = [akTop, akLeft, akRight, akBottom]
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -12
|
||||
Font.Name = 'Consolas'
|
||||
ParentFont = False
|
||||
ScrollBars = ssVertical
|
||||
TabOrder = 5
|
||||
end
|
||||
object ButtonCLS: TButton
|
||||
Left = 10
|
||||
Height = 22
|
||||
Top = 235
|
||||
Width = 38
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'CLS'
|
||||
OnClick = ButtonCLSClick
|
||||
TabOrder = 6
|
||||
end
|
||||
object CheckBoxAutoScroll: TCheckBox
|
||||
Left = 57
|
||||
Height = 19
|
||||
Top = 235
|
||||
Width = 69
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'auto scroll'
|
||||
Checked = True
|
||||
State = cbChecked
|
||||
TabOrder = 7
|
||||
end
|
||||
object CheckBoxDisableLog: TCheckBox
|
||||
Left = 133
|
||||
Height = 19
|
||||
Top = 235
|
||||
Width = 204
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'disable log (for max performance test)'
|
||||
OnClick = CheckBoxDisableLogClick
|
||||
TabOrder = 8
|
||||
end
|
||||
object ComboBoxProtocol: TComboBox
|
||||
Left = 117
|
||||
Height = 21
|
||||
Top = 8
|
||||
Width = 292
|
||||
ItemHeight = 13
|
||||
ItemIndex = 7
|
||||
Items.Strings = (
|
||||
'HTTP ( socket )'
|
||||
' › HTTP ( fast http.sys )'
|
||||
' ›› HTTPS ( fast http.sys + SSL )'
|
||||
' ›› HTTP ( fast http.sys + AES-CFB 256 )'
|
||||
'HTTP ( web socket )'
|
||||
' › WebSocket ( bidirectional, JSON )'
|
||||
' › WebSocket ( bidirectional, binary )'
|
||||
' › WebSocket ( bidirectional, binary + AES-CFB 256)'
|
||||
'Named pipe'
|
||||
)
|
||||
OnChange = ComboBoxProtocolChange
|
||||
Style = csDropDownList
|
||||
TabOrder = 9
|
||||
Text = ' › WebSocket ( bidirectional, binary + AES-CFB 256)'
|
||||
end
|
||||
object EditUserLogin: TEdit
|
||||
Left = 526
|
||||
Height = 21
|
||||
Top = 35
|
||||
Width = 99
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 10
|
||||
Text = 'George'
|
||||
TextHint = 'Login'
|
||||
end
|
||||
object EditUserPassword: TEdit
|
||||
Left = 631
|
||||
Height = 21
|
||||
Top = 35
|
||||
Width = 65
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 11
|
||||
Text = '123'
|
||||
TextHint = 'Password'
|
||||
end
|
||||
object TimerRefreshLogMemo: TTimer
|
||||
OnTimer = TimerRefreshLogMemoTimer
|
||||
left = 56
|
||||
top = 144
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,356 @@
|
||||
unit RestClientFormUnit;
|
||||
|
||||
// mORMot RESTful API test case 1.02
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
// RTL
|
||||
{$IFDEF MSWINDOWS}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
{$ifdef FPC}
|
||||
LCLType,
|
||||
{$endif}
|
||||
Messages,
|
||||
SysUtils,
|
||||
Classes,
|
||||
Generics.Collections,
|
||||
Forms,
|
||||
Dialogs,
|
||||
Controls,
|
||||
StdCtrls,
|
||||
ExtCtrls,
|
||||
// mORMot
|
||||
mORMot,
|
||||
SynLog,
|
||||
SynCommons,
|
||||
mORMotHttpClient, // tmp
|
||||
// Custom
|
||||
RestClientUnit,
|
||||
RestMethodsInterfaceUnit;
|
||||
|
||||
type
|
||||
|
||||
TCustomRecord = record helper for rCustomRecord
|
||||
procedure FillFromClient();
|
||||
end;
|
||||
|
||||
lClientAction = (Auto, Start, Stop, Restart);
|
||||
|
||||
TForm1 = class(TForm)
|
||||
EditServerAdress: TEdit;
|
||||
EditServerPort: TEdit;
|
||||
ButtonStartStop: TButton;
|
||||
TimerRefreshLogMemo: TTimer;
|
||||
GroupBoxIRestMethods: TGroupBox;
|
||||
ButtonMethHelloWorld: TButton;
|
||||
ButtonMethSum: TButton;
|
||||
ButtonGetCustomRecord: TButton;
|
||||
LabelAuthenticationMode: TLabel;
|
||||
ComboBoxAuthentication: TComboBox;
|
||||
ButtonMethSendCustomRecord: TButton;
|
||||
MemoLog: TMemo;
|
||||
ButtonCLS: TButton;
|
||||
CheckBoxAutoScroll: TCheckBox;
|
||||
CheckBoxDisableLog: TCheckBox;
|
||||
ButtonMethSendMultipleCustomRecords: TButton;
|
||||
LabelProtocol: TLabel;
|
||||
ComboBoxProtocol: TComboBox;
|
||||
EditUserLogin: TEdit;
|
||||
EditUserPassword: TEdit;
|
||||
Label1: TLabel;
|
||||
Label2: TLabel;
|
||||
ButtonMethGetMethodCustomResult: TButton;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure ButtonStartStopClick(Sender: TObject);
|
||||
procedure ButtonCLSClick(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
procedure TimerRefreshLogMemoTimer(Sender: TObject);
|
||||
procedure ButtonMethHelloWorldClick(Sender: TObject);
|
||||
procedure ButtonMethSumClick(Sender: TObject);
|
||||
procedure ButtonGetCustomRecordClick(Sender: TObject);
|
||||
procedure ComboBoxAuthenticationChange(Sender: TObject);
|
||||
procedure ButtonMethSendCustomRecordClick(Sender: TObject);
|
||||
procedure CheckBoxDisableLogClick(Sender: TObject);
|
||||
procedure ButtonMethSendMultipleCustomRecordsClick(Sender: TObject);
|
||||
procedure ComboBoxProtocolChange(Sender: TObject);
|
||||
procedure ButtonMethGetMethodCustomResultClick(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
function LogEvent(Sender: TTextWriter; Level: TSynLogInfo; const Text: RawUTF8): boolean;
|
||||
procedure StartStopClient(ClientAction: lClientAction = Auto);
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
TLocalLog = class
|
||||
Level: TSynLogInfo;
|
||||
Text: RawUTF8;
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
{$ifdef FPC}
|
||||
LogThreadSafeList: TList<TLocalLog>;
|
||||
{$else}
|
||||
LogThreadSafeList: TThreadList<TLocalLog>;
|
||||
{$endif}
|
||||
|
||||
implementation
|
||||
|
||||
{$ifdef FPC}
|
||||
{$R *.lfm}
|
||||
{$else}
|
||||
{$R *.dfm}
|
||||
{$endif}
|
||||
{ TCustomResult }
|
||||
|
||||
procedure TCustomRecord.FillFromClient();
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
ResultCode := 200;
|
||||
ResultStr := 'Awesome';
|
||||
ResultTimeStamp := Now();
|
||||
SetLength(ResultArray, 3);
|
||||
for i := 0 to 2 do
|
||||
ResultArray[i] := 'str_' + i.ToString();
|
||||
end;
|
||||
|
||||
{ Form1 }
|
||||
|
||||
// On Form1 create
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
// Create thread safe List with log data class
|
||||
{$ifdef FPC}
|
||||
LogThreadSafeList := TList<TLocalLog>.Create();
|
||||
{$else}
|
||||
LogThreadSafeList := TThreadList<TLocalLog>.Create();
|
||||
{$endif}
|
||||
// Enable logging
|
||||
with TSQLLog.Family do
|
||||
begin
|
||||
Level := LOG_VERBOSE;
|
||||
EchoCustom := LogEvent;
|
||||
NoFile := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
// On Form1 destory
|
||||
procedure TForm1.FormDestroy(Sender: TObject);
|
||||
var
|
||||
i: Integer;
|
||||
List: TList<TLocalLog>;
|
||||
begin
|
||||
// Clear and destroy LogThreadSafeList
|
||||
{$ifdef FPC}
|
||||
List := LogThreadSafeList;
|
||||
{$else}
|
||||
List := LogThreadSafeList.LockList();
|
||||
{$endif}
|
||||
for i := 0 to List.Count - 1 do
|
||||
List.Items[i].Free;
|
||||
List.Clear;
|
||||
{$ifndef FPC}
|
||||
LogThreadSafeList.UnlockList();
|
||||
{$endif}
|
||||
FreeAndNil(LogThreadSafeList);
|
||||
end;
|
||||
|
||||
{ CLIENT EVENTS, START / STOP }
|
||||
|
||||
// Depends on the client status, start or stop client (create or destroy objects)
|
||||
procedure TForm1.StartStopClient(ClientAction: lClientAction = Auto);
|
||||
var
|
||||
pClientCreated: boolean;
|
||||
ClientSettings: rClientSettings;
|
||||
begin
|
||||
pClientCreated := RestClient.Initialized;
|
||||
// Unload current client if required
|
||||
RestClient.DeInitialize();
|
||||
// Create client if required
|
||||
if ((ClientAction = lClientAction.Auto) and not pClientCreated) or ((ClientAction = lClientAction.Restart) and pClientCreated) or (ClientAction = lClientAction.Start) then
|
||||
begin
|
||||
ClientSettings.Protocol := lProtocol(ComboBoxProtocol.ItemIndex);
|
||||
ClientSettings.AuthMode := lAuthenticationMode(ComboBoxAuthentication.ItemIndex);;
|
||||
ClientSettings.HostOrIP := EditServerAdress.Text;
|
||||
ClientSettings.Port := EditServerPort.Text;
|
||||
ClientSettings.UserLogin := StringToUTF8(EditUserLogin.Text);
|
||||
ClientSettings.UserPassword := StringToUTF8(EditUserPassword.Text);
|
||||
RestClient.Initialize(ClientSettings);
|
||||
end;
|
||||
end;
|
||||
|
||||
// Processing mORMot log event
|
||||
function TForm1.LogEvent(Sender: TTextWriter; Level: TSynLogInfo; const Text: RawUTF8): boolean;
|
||||
var
|
||||
List: TList<TLocalLog>;
|
||||
LogEventData: TLocalLog;
|
||||
begin
|
||||
Result := False;
|
||||
if Assigned(LogThreadSafeList) then
|
||||
begin
|
||||
{$ifdef FPC}
|
||||
List := LogThreadSafeList;
|
||||
{$else}
|
||||
List := LogThreadSafeList.LockList;
|
||||
{$endif}
|
||||
try
|
||||
LogEventData := TLocalLog.Create();
|
||||
LogEventData.Level := Level;
|
||||
LogEventData.Text := Text;
|
||||
List.Add(LogEventData);
|
||||
Result := True;
|
||||
finally
|
||||
{$ifndef FPC}
|
||||
LogThreadSafeList.UnlockList();
|
||||
{$endif}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ UI }
|
||||
|
||||
// Grabbing new events from thread safe list
|
||||
procedure TForm1.TimerRefreshLogMemoTimer(Sender: TObject);
|
||||
var
|
||||
List: TList<TLocalLog>;
|
||||
i: Integer;
|
||||
begin
|
||||
if Assigned(LogThreadSafeList) then
|
||||
begin
|
||||
{$ifdef FPC}
|
||||
List := LogThreadSafeList;
|
||||
{$else}
|
||||
List := LogThreadSafeList.LockList;
|
||||
{$endif}
|
||||
try
|
||||
if Assigned(Form1) and not Application.Terminated and (List.Count > 0) then
|
||||
begin
|
||||
for i := 0 to List.Count - 1 do
|
||||
begin
|
||||
Form1.MemoLog.Lines.BeginUpdate();
|
||||
Form1.MemoLog.Lines.Add(string(List.Items[i].Text));
|
||||
Form1.MemoLog.Lines.EndUpdate();
|
||||
List.Items[i].Free;
|
||||
end;
|
||||
List.Clear();
|
||||
{$IFDEF MSWINDOWS}
|
||||
if CheckBoxAutoScroll.Checked then
|
||||
SendMessage(Form1.MemoLog.Handle, WM_VSCROLL, SB_BOTTOM, 0);
|
||||
{$ENDIF}
|
||||
end;
|
||||
finally
|
||||
{$ifndef FPC}
|
||||
LogThreadSafeList.UnlockList();
|
||||
{$endif}
|
||||
end;
|
||||
end;
|
||||
if RestClient.Initialized then
|
||||
ButtonStartStop.Caption := 'Stop client'
|
||||
else
|
||||
ButtonStartStop.Caption := 'Start client';
|
||||
end;
|
||||
|
||||
// Changing client protocol
|
||||
procedure TForm1.ComboBoxProtocolChange(Sender: TObject);
|
||||
begin
|
||||
{$IFDEF MSWINDOWS}
|
||||
EditServerPort.Enabled := lProtocol(ComboBoxProtocol.ItemIndex) <> lProtocol.NamedPipe;
|
||||
{$endif}
|
||||
StartStopClient(Restart);
|
||||
end;
|
||||
|
||||
// Changing client authentication mode
|
||||
procedure TForm1.ComboBoxAuthenticationChange(Sender: TObject);
|
||||
begin
|
||||
{$IFDEF MSWINDOWS}
|
||||
if lAuthenticationMode(ComboBoxAuthentication.ItemIndex) = lAuthenticationMode.SSPI then
|
||||
begin
|
||||
EditUserLogin.Text := '';
|
||||
EditUserPassword.Text := '';
|
||||
end;
|
||||
{$endif}
|
||||
StartStopClient(Restart);
|
||||
end;
|
||||
|
||||
// Clears log memo
|
||||
procedure TForm1.ButtonCLSClick(Sender: TObject);
|
||||
begin
|
||||
MemoLog.Clear;
|
||||
end;
|
||||
|
||||
// Button start stop client
|
||||
procedure TForm1.ButtonStartStopClick(Sender: TObject);
|
||||
begin
|
||||
StartStopClient();
|
||||
end;
|
||||
|
||||
// Checkbox Enable/Disable logging to memo (slow down performance when enabled)
|
||||
procedure TForm1.CheckBoxDisableLogClick(Sender: TObject);
|
||||
begin
|
||||
if not CheckBoxDisableLog.Checked then
|
||||
TSQLLog.Family.Level := LOG_VERBOSE
|
||||
else
|
||||
TSQLLog.Family.Level := [];
|
||||
end;
|
||||
|
||||
{ IRestMethods execution }
|
||||
|
||||
procedure TForm1.ButtonMethHelloWorldClick(Sender: TObject);
|
||||
begin
|
||||
if Assigned(RestClient.RestMethods) then
|
||||
RestClient.RestMethods.HelloWorld();
|
||||
end;
|
||||
|
||||
procedure TForm1.ButtonMethSendCustomRecordClick(Sender: TObject);
|
||||
var
|
||||
CustomResult: rCustomRecord;
|
||||
begin
|
||||
if Assigned(RestClient.RestMethods) then
|
||||
begin
|
||||
CustomResult.FillFromClient();
|
||||
RestClient.RestMethods.SendCustomRecord(CustomResult);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.ButtonMethSumClick(Sender: TObject);
|
||||
begin
|
||||
if Assigned(RestClient.RestMethods) then
|
||||
RestClient.RestMethods.Sum(Random(100) + 0.6, Random(100) + 0.3);
|
||||
end;
|
||||
|
||||
procedure TForm1.ButtonGetCustomRecordClick(Sender: TObject);
|
||||
var
|
||||
CustomResult: rCustomRecord;
|
||||
begin
|
||||
if Assigned(RestClient.RestMethods) then
|
||||
CustomResult := RestClient.RestMethods.GetCustomRecord();
|
||||
end;
|
||||
|
||||
procedure TForm1.ButtonMethSendMultipleCustomRecordsClick(Sender: TObject);
|
||||
var
|
||||
cr: rCustomRecord;
|
||||
ccr: rCustomComplicatedRecord;
|
||||
begin
|
||||
if Assigned(RestClient.RestMethods) then
|
||||
begin
|
||||
cr.FillFromClient();
|
||||
ccr.SimpleString := 'Simple string, Простая строка, 単純な文字列';
|
||||
ccr.SimpleInteger := 100500;
|
||||
ccr.AnotherRecord := cr;
|
||||
RestClient.RestMethods.SendMultipleCustomRecords(cr, ccr);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.ButtonMethGetMethodCustomResultClick(Sender: TObject);
|
||||
var
|
||||
ServiceCustomAnswer: TServiceCustomAnswer;
|
||||
begin
|
||||
if Assigned(RestClient.RestMethods) then
|
||||
ServiceCustomAnswer := RestClient.RestMethods.GetMethodCustomResult();
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,250 @@
|
||||
unit RestClientUnit;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
// RTL
|
||||
SysUtils,
|
||||
Classes,
|
||||
StrUtils,
|
||||
Dialogs,
|
||||
// mORMot
|
||||
mORMot,
|
||||
mORMotHttpClient,
|
||||
SynCommons,
|
||||
// Custom
|
||||
RestMethodsInterfaceUnit;
|
||||
|
||||
type
|
||||
{$ifndef MSWINDOWS}
|
||||
TSQLHttpClientWinHTTP=TSQLHttpClientWinSock;
|
||||
{$endif}
|
||||
|
||||
lProtocol = (HTTP_Socket, HTTP_HTTPsys{$ifdef MSWINDOWS}, HTTPsys_SSL{$endif}, HTTPsys_AES, HTTP_WebSocket, WebSocketBidir_JSON, WebSocketBidir_Binary, WebSocketBidir_BinaryAES{$ifdef MSWINDOWS}, NamedPipe{$endif});
|
||||
lAuthenticationMode = (NoAuthentication, Default, None, HttpBasic{$ifdef MSWINDOWS}, SSPI{$endif});
|
||||
|
||||
rClientSettings = record
|
||||
Protocol: lProtocol;
|
||||
AuthMode: lAuthenticationMode;
|
||||
HostOrIP: string;
|
||||
Port: string;
|
||||
UserLogin: RawUTF8;
|
||||
UserPassword: RawUTF8;
|
||||
end;
|
||||
|
||||
rConnectionSettings = record
|
||||
SendTimeout: Cardinal;
|
||||
ReceiveTimeout: Cardinal;
|
||||
ConnectTimeout: Cardinal;
|
||||
procedure LanNetworkPreset();
|
||||
end;
|
||||
|
||||
tRestClient = class
|
||||
private
|
||||
fModel: TSQLModel;
|
||||
fClientSettings: rClientSettings;
|
||||
fConnectionSettings: rConnectionSettings;
|
||||
fInitialized: boolean;
|
||||
public
|
||||
fClient: TSQLRestClientURI;
|
||||
RestMethods: IRestMethods;
|
||||
property Initialized: boolean read fInitialized;
|
||||
constructor Create();
|
||||
destructor Destroy(); override;
|
||||
function Initialize(ClSettings: rClientSettings; ConSettings: rConnectionSettings): boolean; overload;
|
||||
function Initialize(ClSettings: rClientSettings): boolean; overload;
|
||||
procedure DeInitialize();
|
||||
end;
|
||||
|
||||
var
|
||||
RestClient: tRestClient;
|
||||
|
||||
implementation
|
||||
|
||||
{ rConnectionSettings }
|
||||
|
||||
procedure rConnectionSettings.LanNetworkPreset();
|
||||
begin
|
||||
SendTimeout := 5000;
|
||||
ReceiveTimeout := 5000;
|
||||
ConnectTimeout := 10000;
|
||||
end;
|
||||
|
||||
{ tRestClient }
|
||||
|
||||
constructor tRestClient.Create();
|
||||
begin
|
||||
fConnectionSettings.LanNetworkPreset();
|
||||
end;
|
||||
|
||||
destructor tRestClient.Destroy();
|
||||
begin
|
||||
DeInitialize();
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function tRestClient.Initialize(ClSettings: rClientSettings; ConSettings: rConnectionSettings): boolean;
|
||||
begin
|
||||
fConnectionSettings := ConSettings;
|
||||
Result := Initialize(ClSettings);
|
||||
end;
|
||||
|
||||
function tRestClient.Initialize(ClSettings: rClientSettings): boolean;
|
||||
begin
|
||||
Result := False;
|
||||
// Destroy current object
|
||||
DeInitialize();
|
||||
// Client initialization (for better understanding, each section contain separate code, later should be refactored)
|
||||
fClientSettings := ClSettings;
|
||||
fModel := TSQLModel.Create([], ROOT_NAME);
|
||||
case fClientSettings.Protocol of
|
||||
HTTP_Socket:
|
||||
begin
|
||||
fClient := TSQLHttpClientWinSock.Create(AnsiString(fClientSettings.HostOrIP),
|
||||
AnsiString(fClientSettings.Port), fModel, false, '', '',
|
||||
fConnectionSettings.SendTimeout, fConnectionSettings.ReceiveTimeout,
|
||||
fConnectionSettings.ConnectTimeout);
|
||||
TSQLHttpClientWinSock(fClient).KeepAliveMS := CONNECTION_TIMEOUT;
|
||||
end;
|
||||
HTTP_HTTPsys:
|
||||
begin
|
||||
fClient := TSQLHttpClientWinHTTP.Create(AnsiString(fClientSettings.HostOrIP),
|
||||
AnsiString(fClientSettings.Port), fModel, false, '', '',
|
||||
fConnectionSettings.SendTimeout, fConnectionSettings.ReceiveTimeout,
|
||||
fConnectionSettings.ConnectTimeout);
|
||||
TSQLHttpClientWinHTTP(fClient).KeepAliveMS := CONNECTION_TIMEOUT;
|
||||
TSQLHttpClientWinHTTP(fClient).Compression := [hcSynShaAes];
|
||||
end;
|
||||
{$ifdef MSWINDOWS}
|
||||
HTTPsys_SSL:
|
||||
begin
|
||||
fClient := TSQLHttpClientWinHTTP.Create(AnsiString(fClientSettings.HostOrIP),
|
||||
AnsiString(fClientSettings.Port), fModel, True, '', '', fConnectionSettings.SendTimeout,
|
||||
fConnectionSettings.ReceiveTimeout, fConnectionSettings.ConnectTimeout);
|
||||
TSQLHttpClientWinHTTP(fClient).KeepAliveMS := CONNECTION_TIMEOUT;
|
||||
TSQLHttpClientWinHTTP(fClient).Compression := [hcSynShaAes];
|
||||
end;
|
||||
{$endif}
|
||||
HTTPsys_AES:
|
||||
begin
|
||||
fClient := TSQLHttpClientWinHTTP.Create(AnsiString(fClientSettings.HostOrIP),
|
||||
AnsiString(fClientSettings.Port), fModel, false, '', '',
|
||||
fConnectionSettings.SendTimeout, fConnectionSettings.ReceiveTimeout,
|
||||
fConnectionSettings.ConnectTimeout);
|
||||
TSQLHttpClientWinHTTP(fClient).KeepAliveMS := CONNECTION_TIMEOUT;
|
||||
TSQLHttpClientWinHTTP(fClient).Compression := [hcSynShaAes];
|
||||
end;
|
||||
HTTP_WebSocket:
|
||||
begin
|
||||
fClient := TSQLHttpClientWebsockets.Create(AnsiString(fClientSettings.HostOrIP),
|
||||
AnsiString(fClientSettings.Port), fModel, false, '', '',
|
||||
fConnectionSettings.SendTimeout, fConnectionSettings.ReceiveTimeout,
|
||||
fConnectionSettings.ConnectTimeout);
|
||||
TSQLHttpClientWebsockets(fClient).KeepAliveMS := CONNECTION_TIMEOUT;
|
||||
end;
|
||||
WebSocketBidir_JSON:
|
||||
begin
|
||||
fClient := TSQLHttpClientWebsockets.Create(AnsiString(fClientSettings.HostOrIP),
|
||||
AnsiString(fClientSettings.Port), fModel, false, '', '',
|
||||
fConnectionSettings.SendTimeout, fConnectionSettings.ReceiveTimeout,
|
||||
fConnectionSettings.ConnectTimeout);
|
||||
TSQLHttpClientWebsockets(fClient).KeepAliveMS := CONNECTION_TIMEOUT;
|
||||
(fClient as TSQLHttpClientWebsockets).WebSocketsUpgrade('', True);
|
||||
end;
|
||||
WebSocketBidir_Binary:
|
||||
begin
|
||||
fClient := TSQLHttpClientWebsockets.Create(AnsiString(fClientSettings.HostOrIP),
|
||||
AnsiString(fClientSettings.Port), fModel, false, '', '',
|
||||
fConnectionSettings.SendTimeout, fConnectionSettings.ReceiveTimeout,
|
||||
fConnectionSettings.ConnectTimeout);
|
||||
TSQLHttpClientWebsockets(fClient).KeepAliveMS := CONNECTION_TIMEOUT;
|
||||
(fClient as TSQLHttpClientWebsockets).WebSocketsUpgrade('', False);
|
||||
end;
|
||||
WebSocketBidir_BinaryAES:
|
||||
begin
|
||||
fClient := TSQLHttpClientWebsockets.Create(AnsiString(fClientSettings.HostOrIP),
|
||||
AnsiString(fClientSettings.Port), fModel, false, '', '',
|
||||
fConnectionSettings.SendTimeout, fConnectionSettings.ReceiveTimeout,
|
||||
fConnectionSettings.ConnectTimeout);
|
||||
TSQLHttpClientWebsockets(fClient).KeepAliveMS := CONNECTION_TIMEOUT;
|
||||
(fClient as TSQLHttpClientWebsockets).WebSocketsUpgrade('2141D32ADAD54D9A9DB56000CC9A4A70', False);
|
||||
end;
|
||||
{$ifdef MSWINDOWS}
|
||||
NamedPipe:
|
||||
begin
|
||||
fClient := TSQLRestClientURINamedPipe.Create(fModel, '\\' + fClientSettings.HostOrIP + '\pipe\mORMot_' + NAMED_PIPE_NAME);
|
||||
end;
|
||||
{$endif}
|
||||
else
|
||||
begin
|
||||
DeInitialize();
|
||||
raise Exception.Create('Selected protocol not available in this build.');
|
||||
end;
|
||||
end;
|
||||
case fClientSettings.AuthMode of
|
||||
// NoAuthentication
|
||||
NoAuthentication:
|
||||
begin
|
||||
// nothing to do here
|
||||
end;
|
||||
// TSQLRestServerAuthenticationDefault
|
||||
Default:
|
||||
begin
|
||||
fClient.SetUser(fClientSettings.UserLogin, fClientSettings.UserPassword);
|
||||
end;
|
||||
// TSQLRestServerAuthenticationNone
|
||||
None:
|
||||
begin
|
||||
TSQLRestServerAuthenticationNone.ClientSetUser(fClient, fClientSettings.UserLogin, fClientSettings.UserPassword);
|
||||
end;
|
||||
// TSQLRestServerAuthenticationHttpBasic
|
||||
HttpBasic:
|
||||
begin
|
||||
TSQLRestServerAuthenticationHttpBasic.ClientSetUser(fClient, fClientSettings.UserLogin, fClientSettings.UserPassword);
|
||||
end;
|
||||
// TSQLRestServerAuthenticationSSPI
|
||||
{$ifdef MSWINDOWS}
|
||||
SSPI:
|
||||
begin
|
||||
TSQLRestServerAuthenticationSSPI.ClientSetUser(fClient, fClientSettings.UserLogin, fClientSettings.UserPassword);
|
||||
end;
|
||||
{$endif}
|
||||
else
|
||||
begin
|
||||
DeInitialize();
|
||||
raise Exception.Create('Selected Authentication mode not available in this build.');
|
||||
end;
|
||||
end;
|
||||
// Preparing
|
||||
if not fClient.ServerTimeStampSynchronize() then
|
||||
begin
|
||||
ShowMessage(UTF8ToString(fClient.LastErrorMessage));
|
||||
exit;
|
||||
end;
|
||||
// Service initialization
|
||||
fClient.ServiceDefine([IRestMethods], SERVICE_INSTANCE_IMPLEMENTATION);
|
||||
// Result := Client.Services['RestMethods'].Get(RestServerMethods);
|
||||
Result := fClient.Services.Resolve(IRestMethods, RestMethods); // same result, but no chance to make mistake with service name
|
||||
fInitialized := Result;
|
||||
end;
|
||||
|
||||
procedure tRestClient.DeInitialize();
|
||||
begin
|
||||
RestMethods := nil;
|
||||
if Assigned(fClient) then
|
||||
FreeAndNil(fClient);
|
||||
if Assigned(fModel) then
|
||||
FreeAndNil(fModel);
|
||||
fInitialized := False;
|
||||
end;
|
||||
|
||||
initialization
|
||||
|
||||
RestClient := tRestClient.Create();
|
||||
|
||||
finalization
|
||||
|
||||
if Assigned(RestClient) then
|
||||
FreeAndNil(RestClient);
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,45 @@
|
||||
unit RestMethodsInterfaceUnit;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
mORMot;
|
||||
|
||||
type
|
||||
rCustomRecord = record
|
||||
ResultCode: integer;
|
||||
ResultStr: string;
|
||||
ResultArray: array of string;
|
||||
ResultTimeStamp: TDateTime;
|
||||
end;
|
||||
|
||||
rCustomComplicatedRecord = record
|
||||
SimpleString: string;
|
||||
SimpleInteger: integer;
|
||||
AnotherRecord: rCustomRecord;
|
||||
end;
|
||||
|
||||
IRestMethods = interface(IInvokable)
|
||||
['{4EB49814-A4A9-40D2-B85A-137DDF43C72C}']
|
||||
function HelloWorld(): string;
|
||||
function Sum(val1, val2: Double): Double;
|
||||
function GetCustomRecord(): rCustomRecord;
|
||||
function SendCustomRecord(const CustomResult: rCustomRecord): Boolean;
|
||||
function SendMultipleCustomRecords(const CustomResult: rCustomRecord; const CustomComplicatedRecord: rCustomComplicatedRecord): Boolean;
|
||||
function GetMethodCustomResult(): TServiceCustomAnswer; // without default {result:[]}
|
||||
// function ProperErrorHanding(): boolean;
|
||||
end;
|
||||
|
||||
const
|
||||
ROOT_NAME = 'service';
|
||||
SERVICE_INSTANCE_IMPLEMENTATION = TServiceInstanceImplementation.sicSingle;
|
||||
NAMED_PIPE_NAME = 'Rest_Test.0001';
|
||||
CONNECTION_TIMEOUT = 3000; // Default mORMot value
|
||||
|
||||
implementation
|
||||
|
||||
initialization
|
||||
|
||||
TInterfaceFactory.RegisterInterfaces([TypeInfo(IRestMethods)]); // to use directly IRestMethods instead of TypeInfo(IRestMethods)
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,378 @@
|
||||
object Form1: TForm1
|
||||
Left = 0
|
||||
Top = 0
|
||||
Caption = 'SRV.mORMot REST test'
|
||||
ClientHeight = 661
|
||||
ClientWidth = 1084
|
||||
Color = clBtnFace
|
||||
Constraints.MinHeight = 325
|
||||
Constraints.MinWidth = 1100
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = []
|
||||
OldCreateOrder = False
|
||||
Position = poScreenCenter
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
DesignSize = (
|
||||
1084
|
||||
661)
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 13
|
||||
object LabelPortCap: TLabel
|
||||
Left = 867
|
||||
Top = 28
|
||||
Width = 24
|
||||
Height = 13
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Port:'
|
||||
ExplicitLeft = 866
|
||||
end
|
||||
object LabelAuthenticationMode: TLabel
|
||||
Left = 37
|
||||
Top = 38
|
||||
Width = 74
|
||||
Height = 13
|
||||
Caption = 'Authentication:'
|
||||
end
|
||||
object LabelProtocol: TLabel
|
||||
Left = 68
|
||||
Top = 11
|
||||
Width = 43
|
||||
Height = 13
|
||||
Caption = 'Protocol:'
|
||||
end
|
||||
object LabelHTTPSnote: TLabel
|
||||
Left = 511
|
||||
Top = 11
|
||||
Width = 235
|
||||
Height = 13
|
||||
Caption = 'Don'#39't forget enable https support (check exe dir)'
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = 136
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = []
|
||||
ParentFont = False
|
||||
Visible = False
|
||||
StyleElements = [seClient, seBorder]
|
||||
end
|
||||
object EditPort: TEdit
|
||||
Left = 897
|
||||
Top = 25
|
||||
Width = 60
|
||||
Height = 21
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 0
|
||||
Text = '777'
|
||||
end
|
||||
object ButtonStartStop: TButton
|
||||
Left = 969
|
||||
Top = 19
|
||||
Width = 105
|
||||
Height = 33
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Start server'
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = [fsBold]
|
||||
ParentFont = False
|
||||
TabOrder = 1
|
||||
OnClick = ButtonStartStopClick
|
||||
end
|
||||
object MemoLog: TMemo
|
||||
Left = 8
|
||||
Top = 255
|
||||
Width = 1066
|
||||
Height = 370
|
||||
Anchors = [akLeft, akTop, akRight, akBottom]
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -12
|
||||
Font.Name = 'Consolas'
|
||||
Font.Style = []
|
||||
ParentFont = False
|
||||
ScrollBars = ssVertical
|
||||
TabOrder = 2
|
||||
end
|
||||
object ButtonCLS: TButton
|
||||
Left = 10
|
||||
Top = 631
|
||||
Width = 38
|
||||
Height = 22
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'CLS'
|
||||
TabOrder = 3
|
||||
OnClick = ButtonCLSClick
|
||||
end
|
||||
object CheckBoxAutoScroll: TCheckBox
|
||||
Left = 57
|
||||
Top = 633
|
||||
Width = 69
|
||||
Height = 17
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'auto scroll'
|
||||
Checked = True
|
||||
State = cbChecked
|
||||
TabOrder = 4
|
||||
end
|
||||
object ComboBoxAuthentication: TComboBox
|
||||
Left = 117
|
||||
Top = 35
|
||||
Width = 388
|
||||
Height = 21
|
||||
Style = csDropDownList
|
||||
ItemIndex = 1
|
||||
TabOrder = 5
|
||||
Text = 'Default'
|
||||
OnChange = ComboBoxAuthenticationChange
|
||||
Items.Strings = (
|
||||
'No authentication'
|
||||
'Default'
|
||||
'None'
|
||||
'HttpBasic'
|
||||
'SSPI')
|
||||
end
|
||||
object ButtonShowAuthorizationInfo: TButton
|
||||
Left = 511
|
||||
Top = 36
|
||||
Width = 42
|
||||
Height = 19
|
||||
Caption = 'Info'
|
||||
TabOrder = 6
|
||||
OnClick = ButtonShowAuthorizationInfoClick
|
||||
end
|
||||
object CheckBoxDisableLog: TCheckBox
|
||||
Left = 133
|
||||
Top = 633
|
||||
Width = 203
|
||||
Height = 17
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'disable log (for max performance test)'
|
||||
TabOrder = 7
|
||||
OnClick = CheckBoxDisableLogClick
|
||||
end
|
||||
object ComboBoxProtocol: TComboBox
|
||||
Left = 117
|
||||
Top = 8
|
||||
Width = 388
|
||||
Height = 21
|
||||
Style = csDropDownList
|
||||
DropDownCount = 10
|
||||
ItemIndex = 7
|
||||
TabOrder = 8
|
||||
Text = ' '#8250' WebSocket ( bidirectional, binary + AES-CFB 256)'
|
||||
OnChange = ComboBoxProtocolChange
|
||||
Items.Strings = (
|
||||
'HTTP ( socket )'
|
||||
|
||||
' '#8250' HTTP ( fast http.sys // require admin rights else s' +
|
||||
'ocket )'
|
||||
' '#8250#8250' HTTPS ( fast http.sys + SSL // require admin rights )'
|
||||
|
||||
' '#8250' HTTP ( fast http.sys + AES-CFB 256 // require admin' +
|
||||
' rights )'
|
||||
'HTTP ( web socket )'
|
||||
' '#8250' WebSocket ( bidirectional, JSON )'
|
||||
' '#8250' WebSocket ( bidirectional, binary )'
|
||||
' '#8250' WebSocket ( bidirectional, binary + AES-CFB 256)'
|
||||
'Named pipe')
|
||||
end
|
||||
object GroupBoxMethodGroupConfiguration: TGroupBox
|
||||
Left = 164
|
||||
Top = 62
|
||||
Width = 520
|
||||
Height = 187
|
||||
Caption = 'Method / Group configuration'
|
||||
TabOrder = 9
|
||||
object ListViewMethodGroups: TListView
|
||||
Left = 10
|
||||
Top = 16
|
||||
Width = 503
|
||||
Height = 133
|
||||
Columns = <
|
||||
item
|
||||
Caption = ' Method'
|
||||
Width = 150
|
||||
end
|
||||
item
|
||||
Caption = ' Allow group by name'
|
||||
Width = 160
|
||||
end
|
||||
item
|
||||
Caption = ' Deny group by name'
|
||||
Width = 160
|
||||
end>
|
||||
Groups = <
|
||||
item
|
||||
Header = 'IRestMethods'
|
||||
GroupID = 0
|
||||
State = [lgsNormal]
|
||||
HeaderAlign = taLeftJustify
|
||||
FooterAlign = taLeftJustify
|
||||
Subtitle = 'InstanceImplementation = sicSingle'
|
||||
TitleImage = -1
|
||||
end>
|
||||
HideSelection = False
|
||||
Items.ItemData = {
|
||||
05860200000600000000000000FFFFFFFFFFFFFFFF0200000000000000000000
|
||||
000A480065006C006C006F0057006F0072006C00640014550073006500720073
|
||||
002C00410064006D0069006E006900730074007200610074006F007200730068
|
||||
0674240B53006F006D0065006F006E00650045006C007300650068FF73240000
|
||||
0000FFFFFFFFFFFFFFFF02000000000000000000000003530075006D00145500
|
||||
73006500720073002C00410064006D0069006E00690073007400720061007400
|
||||
6F0072007300686F7424008054742400000000FFFFFFFFFFFFFFFF0200000000
|
||||
000000000000000F47006500740043007500730074006F006D00520065006300
|
||||
6F00720064000E410064006D0069006E006900730074007200610074006F0072
|
||||
0073005013742400985C742400000000FFFFFFFFFFFFFFFF0200000000000000
|
||||
0000000010530065006E00640043007500730074006F006D005200650063006F
|
||||
00720064000E410064006D0069006E006900730074007200610074006F007200
|
||||
7300588F7424004041742400000000FFFFFFFFFFFFFFFF020000000000000000
|
||||
00000019530065006E0064004D0075006C007400690070006C00650043007500
|
||||
730074006F006D005200650063006F007200640073000E410064006D0069006E
|
||||
006900730074007200610074006F00720073003812742400E887742400000000
|
||||
FFFFFFFFFFFFFFFF020000000000000000000000154700650074004D00650074
|
||||
0068006F00640043007500730074006F006D0052006500730075006C00740014
|
||||
550073006500720073002C00410064006D0069006E0069007300740072006100
|
||||
74006F0072007300B08774240010387424FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFF}
|
||||
GroupView = True
|
||||
ReadOnly = True
|
||||
RowSelect = True
|
||||
TabOrder = 0
|
||||
ViewStyle = vsReport
|
||||
OnClick = ListViewMethodGroupsClick
|
||||
OnSelectItem = ListViewMethodGroupsSelectItem
|
||||
end
|
||||
object ButtonSaveRoleConfiguration: TButton
|
||||
Left = 463
|
||||
Top = 155
|
||||
Width = 50
|
||||
Height = 25
|
||||
Caption = 'Save'
|
||||
TabOrder = 1
|
||||
OnClick = ButtonSaveRoleConfigurationClick
|
||||
end
|
||||
object EditAllowGroupNames: TEdit
|
||||
Left = 136
|
||||
Top = 157
|
||||
Width = 160
|
||||
Height = 21
|
||||
TabOrder = 2
|
||||
TextHint = 'Allow group names (sep by ",")'
|
||||
end
|
||||
object EditDenyAllowGroupNames: TEdit
|
||||
Left = 298
|
||||
Top = 157
|
||||
Width = 159
|
||||
Height = 21
|
||||
TabOrder = 3
|
||||
TextHint = 'Deny group names (sep by ",")'
|
||||
end
|
||||
end
|
||||
object RadioGroupAuthorizationPolicy: TRadioGroup
|
||||
Left = 8
|
||||
Top = 62
|
||||
Width = 150
|
||||
Height = 73
|
||||
Caption = 'Authorization policy'
|
||||
ItemIndex = 2
|
||||
Items.Strings = (
|
||||
'Allow all'
|
||||
'Deny all'
|
||||
'Follow groups settings')
|
||||
TabOrder = 10
|
||||
OnClick = RadioGroupAuthorizationPolicyClick
|
||||
end
|
||||
object GroupBoxUsers: TGroupBox
|
||||
Left = 690
|
||||
Top = 62
|
||||
Width = 383
|
||||
Height = 187
|
||||
Caption = 'Users'
|
||||
TabOrder = 11
|
||||
object ListViewUsers: TListView
|
||||
Left = 9
|
||||
Top = 16
|
||||
Width = 365
|
||||
Height = 133
|
||||
Columns = <
|
||||
item
|
||||
Caption = ' User'
|
||||
Width = 110
|
||||
end
|
||||
item
|
||||
Caption = ' Password'
|
||||
Width = 110
|
||||
end
|
||||
item
|
||||
Caption = ' Group'
|
||||
Width = 110
|
||||
end>
|
||||
HideSelection = False
|
||||
Items.ItemData = {
|
||||
05960000000200000000000000FFFFFFFFFFFFFFFF02000000FFFFFFFF000000
|
||||
0006470065006F0072006700650003310032003300B8EB761B0E410064006D00
|
||||
69006E006900730074007200610074006F007200730058EE761B00000000FFFF
|
||||
FFFFFFFFFFFF02000000FFFFFFFF000000000441006C00650078000333003200
|
||||
310090EE761B0555007300650072007300C8EE761BFFFFFFFFFFFFFFFF}
|
||||
ReadOnly = True
|
||||
RowSelect = True
|
||||
TabOrder = 0
|
||||
ViewStyle = vsReport
|
||||
OnClick = ListViewUsersClick
|
||||
OnSelectItem = ListViewUsersSelectItem
|
||||
end
|
||||
object EditUserGroup: TEdit
|
||||
Left = 223
|
||||
Top = 157
|
||||
Width = 83
|
||||
Height = 21
|
||||
TabOrder = 1
|
||||
TextHint = 'Group'
|
||||
end
|
||||
object ButtonSaveUsers: TButton
|
||||
Left = 312
|
||||
Top = 155
|
||||
Width = 62
|
||||
Height = 25
|
||||
Caption = 'Save/Add'
|
||||
TabOrder = 2
|
||||
OnClick = ButtonSaveUsersClick
|
||||
end
|
||||
object EditUserName: TEdit
|
||||
Left = 53
|
||||
Top = 157
|
||||
Width = 83
|
||||
Height = 21
|
||||
TabOrder = 3
|
||||
TextHint = 'User'
|
||||
end
|
||||
object ButtonDeleteUser: TButton
|
||||
Left = 9
|
||||
Top = 155
|
||||
Width = 38
|
||||
Height = 25
|
||||
Caption = 'DeL'
|
||||
TabOrder = 4
|
||||
OnClick = ButtonDeleteUserClick
|
||||
end
|
||||
object EditUserPassword: TEdit
|
||||
Left = 138
|
||||
Top = 157
|
||||
Width = 83
|
||||
Height = 21
|
||||
TabOrder = 5
|
||||
TextHint = 'Password'
|
||||
end
|
||||
end
|
||||
object TimerRefreshLogMemo: TTimer
|
||||
OnTimer = TimerRefreshLogMemoTimer
|
||||
Left = 56
|
||||
Top = 264
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,368 @@
|
||||
object Form1: TForm1
|
||||
Left = 238
|
||||
Height = 377
|
||||
Top = 103
|
||||
Width = 1100
|
||||
Caption = 'SRV.mORMot REST test'
|
||||
ClientHeight = 377
|
||||
ClientWidth = 1100
|
||||
Color = clBtnFace
|
||||
Constraints.MinHeight = 325
|
||||
Constraints.MinWidth = 1100
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
Position = poScreenCenter
|
||||
LCLVersion = '1.7'
|
||||
object LabelPortCap: TLabel
|
||||
Left = 883
|
||||
Height = 13
|
||||
Top = 28
|
||||
Width = 24
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Port:'
|
||||
ParentColor = False
|
||||
end
|
||||
object LabelAuthenticationMode: TLabel
|
||||
Left = 37
|
||||
Height = 13
|
||||
Top = 38
|
||||
Width = 74
|
||||
Caption = 'Authentication:'
|
||||
ParentColor = False
|
||||
end
|
||||
object LabelProtocol: TLabel
|
||||
Left = 68
|
||||
Height = 13
|
||||
Top = 11
|
||||
Width = 43
|
||||
Caption = 'Protocol:'
|
||||
ParentColor = False
|
||||
end
|
||||
object LabelHTTPSnote: TLabel
|
||||
Left = 511
|
||||
Height = 13
|
||||
Top = 11
|
||||
Width = 235
|
||||
Caption = 'Don''t forget enable https support (check exe dir)'
|
||||
Font.Color = 136
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
ParentColor = False
|
||||
ParentFont = False
|
||||
Visible = False
|
||||
end
|
||||
object EditPort: TEdit
|
||||
Left = 913
|
||||
Height = 21
|
||||
Top = 25
|
||||
Width = 60
|
||||
Anchors = [akTop, akRight]
|
||||
TabOrder = 0
|
||||
Text = '777'
|
||||
end
|
||||
object ButtonStartStop: TButton
|
||||
Left = 985
|
||||
Height = 33
|
||||
Top = 19
|
||||
Width = 105
|
||||
Anchors = [akTop, akRight]
|
||||
Caption = 'Start server'
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = [fsBold]
|
||||
OnClick = ButtonStartStopClick
|
||||
ParentFont = False
|
||||
TabOrder = 1
|
||||
end
|
||||
object MemoLog: TMemo
|
||||
Left = 8
|
||||
Height = 69
|
||||
Top = 272
|
||||
Width = 1082
|
||||
Anchors = [akTop, akLeft, akRight, akBottom]
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -12
|
||||
Font.Name = 'Consolas'
|
||||
ParentFont = False
|
||||
ScrollBars = ssVertical
|
||||
TabOrder = 2
|
||||
end
|
||||
object ButtonCLS: TButton
|
||||
Left = 10
|
||||
Height = 22
|
||||
Top = 347
|
||||
Width = 38
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'CLS'
|
||||
OnClick = ButtonCLSClick
|
||||
TabOrder = 3
|
||||
end
|
||||
object CheckBoxAutoScroll: TCheckBox
|
||||
Left = 57
|
||||
Height = 19
|
||||
Top = 347
|
||||
Width = 69
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'auto scroll'
|
||||
Checked = True
|
||||
State = cbChecked
|
||||
TabOrder = 4
|
||||
end
|
||||
object ComboBoxAuthentication: TComboBox
|
||||
Left = 117
|
||||
Height = 21
|
||||
Top = 35
|
||||
Width = 388
|
||||
ItemHeight = 13
|
||||
ItemIndex = 1
|
||||
Items.Strings = (
|
||||
'No authentication'
|
||||
'Default'
|
||||
'None'
|
||||
'HttpBasic'
|
||||
'SSPI'
|
||||
)
|
||||
OnChange = ComboBoxAuthenticationChange
|
||||
Style = csDropDownList
|
||||
TabOrder = 5
|
||||
Text = 'Default'
|
||||
end
|
||||
object ButtonShowAuthorizationInfo: TButton
|
||||
Left = 511
|
||||
Height = 19
|
||||
Top = 36
|
||||
Width = 42
|
||||
Caption = 'Info'
|
||||
OnClick = ButtonShowAuthorizationInfoClick
|
||||
TabOrder = 6
|
||||
end
|
||||
object CheckBoxDisableLog: TCheckBox
|
||||
Left = 133
|
||||
Height = 19
|
||||
Top = 347
|
||||
Width = 204
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'disable log (for max performance test)'
|
||||
OnClick = CheckBoxDisableLogClick
|
||||
TabOrder = 7
|
||||
end
|
||||
object ComboBoxProtocol: TComboBox
|
||||
Left = 117
|
||||
Height = 21
|
||||
Top = 8
|
||||
Width = 388
|
||||
DropDownCount = 10
|
||||
ItemHeight = 13
|
||||
ItemIndex = 7
|
||||
Items.Strings = (
|
||||
'HTTP ( socket )'
|
||||
' › HTTP ( fast http.sys // require admin rights else socket )'
|
||||
' ›› HTTPS ( fast http.sys + SSL // require admin rights )'
|
||||
' › HTTP ( fast http.sys + AES-CFB 256 // require admin rights )'
|
||||
'HTTP ( web socket )'
|
||||
' › WebSocket ( bidirectional, JSON )'
|
||||
' › WebSocket ( bidirectional, binary )'
|
||||
' › WebSocket ( bidirectional, binary + AES-CFB 256)'
|
||||
'Named pipe'
|
||||
)
|
||||
OnChange = ComboBoxProtocolChange
|
||||
Style = csDropDownList
|
||||
TabOrder = 8
|
||||
Text = ' › WebSocket ( bidirectional, binary + AES-CFB 256)'
|
||||
end
|
||||
object GroupBoxMethodGroupConfiguration: TGroupBox
|
||||
Left = 164
|
||||
Height = 203
|
||||
Top = 62
|
||||
Width = 520
|
||||
Caption = 'Method / Group configuration'
|
||||
ClientHeight = 185
|
||||
ClientWidth = 516
|
||||
TabOrder = 9
|
||||
object ListViewMethodGroups: TListView
|
||||
Left = 10
|
||||
Height = 133
|
||||
Top = 16
|
||||
Width = 503
|
||||
Columns = <
|
||||
item
|
||||
Caption = ' Method'
|
||||
Width = 150
|
||||
end
|
||||
item
|
||||
Caption = ' Allow group by name'
|
||||
Width = 160
|
||||
end
|
||||
item
|
||||
Caption = ' Deny group by name'
|
||||
Width = 160
|
||||
end>
|
||||
HideSelection = False
|
||||
Items.LazData = {
|
||||
AB01000006000000FFFFFFFFFFFFFFFFFFFFFFFF020000000A00000048656C6C
|
||||
6F576F726C641400000055736572732C41646D696E6973747261746F72730B00
|
||||
0000536F6D656F6E65456C7365FFFFFFFFFFFFFFFFFFFFFFFF02000000030000
|
||||
0053756D1400000055736572732C41646D696E6973747261746F727300000000
|
||||
FFFFFFFFFFFFFFFFFFFFFFFF020000000F000000476574437573746F6D526563
|
||||
6F72640E00000041646D696E6973747261746F727300000000FFFFFFFFFFFFFF
|
||||
FFFFFFFFFF020000001000000053656E64437573746F6D5265636F72640E0000
|
||||
0041646D696E6973747261746F727300000000FFFFFFFFFFFFFFFFFFFFFFFF02
|
||||
0000001900000053656E644D756C7469706C65437573746F6D5265636F726473
|
||||
0E00000041646D696E6973747261746F727300000000FFFFFFFFFFFFFFFFFFFF
|
||||
FFFF02000000150000004765744D6574686F64437573746F6D526573756C7414
|
||||
00000055736572732C41646D696E6973747261746F727300000000FFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
FFFFFFFFFFFFFFFFFFFFFF
|
||||
}
|
||||
ReadOnly = True
|
||||
RowSelect = True
|
||||
TabOrder = 0
|
||||
ViewStyle = vsReport
|
||||
OnClick = ListViewMethodGroupsClick
|
||||
OnSelectItem = ListViewMethodGroupsSelectItem
|
||||
end
|
||||
object ButtonSaveRoleConfiguration: TButton
|
||||
Left = 463
|
||||
Height = 25
|
||||
Top = 155
|
||||
Width = 50
|
||||
Caption = 'Save'
|
||||
OnClick = ButtonSaveRoleConfigurationClick
|
||||
TabOrder = 1
|
||||
end
|
||||
object EditAllowGroupNames: TEdit
|
||||
Left = 136
|
||||
Height = 21
|
||||
Top = 157
|
||||
Width = 160
|
||||
TabOrder = 2
|
||||
TextHint = 'Allow group names (sep by ",")'
|
||||
end
|
||||
object EditDenyAllowGroupNames: TEdit
|
||||
Left = 298
|
||||
Height = 21
|
||||
Top = 157
|
||||
Width = 159
|
||||
TabOrder = 3
|
||||
TextHint = 'Deny group names (sep by ",")'
|
||||
end
|
||||
end
|
||||
object RadioGroupAuthorizationPolicy: TRadioGroup
|
||||
Left = 8
|
||||
Height = 73
|
||||
Top = 62
|
||||
Width = 150
|
||||
AutoFill = True
|
||||
Caption = 'Authorization policy'
|
||||
ChildSizing.LeftRightSpacing = 6
|
||||
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
|
||||
ChildSizing.EnlargeVertical = crsHomogenousChildResize
|
||||
ChildSizing.ShrinkHorizontal = crsScaleChilds
|
||||
ChildSizing.ShrinkVertical = crsScaleChilds
|
||||
ChildSizing.Layout = cclLeftToRightThenTopToBottom
|
||||
ChildSizing.ControlsPerLine = 1
|
||||
ClientHeight = 55
|
||||
ClientWidth = 146
|
||||
ItemIndex = 2
|
||||
Items.Strings = (
|
||||
'Allow all'
|
||||
'Deny all'
|
||||
'Follow groups settings'
|
||||
)
|
||||
OnClick = RadioGroupAuthorizationPolicyClick
|
||||
TabOrder = 10
|
||||
end
|
||||
object GroupBoxUsers: TGroupBox
|
||||
Left = 690
|
||||
Height = 203
|
||||
Top = 62
|
||||
Width = 383
|
||||
Caption = 'Users'
|
||||
ClientHeight = 185
|
||||
ClientWidth = 379
|
||||
TabOrder = 11
|
||||
object ListViewUsers: TListView
|
||||
Left = 9
|
||||
Height = 133
|
||||
Top = 16
|
||||
Width = 365
|
||||
Columns = <
|
||||
item
|
||||
Caption = ' User'
|
||||
Width = 110
|
||||
end
|
||||
item
|
||||
Caption = ' Password'
|
||||
Width = 110
|
||||
end
|
||||
item
|
||||
Caption = ' Group'
|
||||
Width = 110
|
||||
end>
|
||||
HideSelection = False
|
||||
Items.LazData = {
|
||||
7300000002000000FFFFFFFFFFFFFFFFFFFFFFFF020000000600000047656F72
|
||||
6765030000003132330E00000041646D696E6973747261746F7273FFFFFFFFFF
|
||||
FFFFFFFFFFFFFF0200000004000000416C657803000000333231050000005573
|
||||
657273FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
||||
}
|
||||
ReadOnly = True
|
||||
RowSelect = True
|
||||
TabOrder = 0
|
||||
ViewStyle = vsReport
|
||||
OnClick = ListViewUsersClick
|
||||
OnSelectItem = ListViewUsersSelectItem
|
||||
end
|
||||
object EditUserGroup: TEdit
|
||||
Left = 223
|
||||
Height = 21
|
||||
Top = 157
|
||||
Width = 83
|
||||
TabOrder = 1
|
||||
TextHint = 'Group'
|
||||
end
|
||||
object ButtonSaveUsers: TButton
|
||||
Left = 312
|
||||
Height = 25
|
||||
Top = 155
|
||||
Width = 62
|
||||
Caption = 'Save/Add'
|
||||
OnClick = ButtonSaveUsersClick
|
||||
TabOrder = 2
|
||||
end
|
||||
object EditUserName: TEdit
|
||||
Left = 53
|
||||
Height = 21
|
||||
Top = 157
|
||||
Width = 83
|
||||
TabOrder = 3
|
||||
TextHint = 'User'
|
||||
end
|
||||
object ButtonDeleteUser: TButton
|
||||
Left = 9
|
||||
Height = 25
|
||||
Top = 155
|
||||
Width = 38
|
||||
Caption = 'DeL'
|
||||
OnClick = ButtonDeleteUserClick
|
||||
TabOrder = 4
|
||||
end
|
||||
object EditUserPassword: TEdit
|
||||
Left = 138
|
||||
Height = 21
|
||||
Top = 157
|
||||
Width = 83
|
||||
TabOrder = 5
|
||||
TextHint = 'Password'
|
||||
end
|
||||
end
|
||||
object TimerRefreshLogMemo: TTimer
|
||||
OnTimer = TimerRefreshLogMemoTimer
|
||||
left = 56
|
||||
top = 264
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,102 @@
|
||||
{ This is an automatically generated lazarus resource file }
|
||||
|
||||
LazarusResources.Add('TForm1','FORMDATA',[
|
||||
'TPF0'#6'TForm1'#5'Form1'#4'Left'#2'1'#6'Height'#3'y'#1#3'Top'#2'}'#5'Width'#3
|
||||
+'L'#4#7'Caption'#6#20'SRV.mORMot REST test'#12'ClientHeight'#3'y'#1#11'Clien'
|
||||
+'tWidth'#3'L'#4#5'Color'#7#9'clBtnFace'#21'Constraints.MinHeight'#3'E'#1#20
|
||||
+'Constraints.MinWidth'#3'L'#4#10'Font.Color'#7#12'clWindowText'#11'Font.Heig'
|
||||
+'ht'#2#245#9'Font.Name'#6#6'Tahoma'#8'OnCreate'#7#10'FormCreate'#9'OnDestroy'
|
||||
+#7#11'FormDestroy'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#3'1.7'#0
|
||||
+#6'TLabel'#12'LabelPortCap'#4'Left'#3's'#3#6'Height'#2#13#3'Top'#2#28#5'Widt'
|
||||
+'h'#2#24#7'Anchors'#11#5'akTop'#7'akRight'#0#7'Caption'#6#5'Port:'#11'Parent'
|
||||
+'Color'#8#0#0#6'TLabel'#23'LabelAuthenticationMode'#4'Left'#2'%'#6'Height'#2
|
||||
+#13#3'Top'#2'&'#5'Width'#2'J'#7'Caption'#6#15'Authentication:'#11'ParentColo'
|
||||
+'r'#8#0#0#6'TLabel'#13'LabelProtocol'#4'Left'#2'D'#6'Height'#2#13#3'Top'#2#11
|
||||
+#5'Width'#2'+'#7'Caption'#6#9'Protocol:'#11'ParentColor'#8#0#0#6'TLabel'#14
|
||||
+'LabelHTTPSnote'#4'Left'#3#255#1#6'Height'#2#13#3'Top'#2#11#5'Width'#3#235#0
|
||||
+#7'Caption'#6'1Don''t forget enable https support (check exe dir)'#10'Font.C'
|
||||
+'olor'#3#136#0#11'Font.Height'#2#245#9'Font.Name'#6#6'Tahoma'#11'ParentColor'
|
||||
+#8#10'ParentFont'#8#7'Visible'#8#0#0#5'TEdit'#8'EditPort'#4'Left'#3#145#3#6
|
||||
+'Height'#2#21#3'Top'#2#25#5'Width'#2'<'#7'Anchors'#11#5'akTop'#7'akRight'#0#8
|
||||
+'TabOrder'#2#0#4'Text'#6#3'777'#0#0#7'TButton'#15'ButtonStartStop'#4'Left'#3
|
||||
+#217#3#6'Height'#2'!'#3'Top'#2#19#5'Width'#2'i'#7'Anchors'#11#5'akTop'#7'akR'
|
||||
+'ight'#0#7'Caption'#6#12'Start server'#10'Font.Color'#7#12'clWindowText'#11
|
||||
+'Font.Height'#2#245#9'Font.Name'#6#6'Tahoma'#10'Font.Style'#11#6'fsBold'#0#7
|
||||
+'OnClick'#7#20'ButtonStartStopClick'#10'ParentFont'#8#8'TabOrder'#2#1#0#0#5
|
||||
+'TMemo'#7'MemoLog'#4'Left'#2#8#6'Height'#2'E'#3'Top'#3#16#1#5'Width'#3':'#4#7
|
||||
+'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#8'akBottom'#0#10'Font.Color'#7#12
|
||||
+'clWindowText'#11'Font.Height'#2#244#9'Font.Name'#6#8'Consolas'#10'ParentFon'
|
||||
+'t'#8#10'ScrollBars'#7#10'ssVertical'#8'TabOrder'#2#2#0#0#7'TButton'#9'Butto'
|
||||
+'nCLS'#4'Left'#2#10#6'Height'#2#22#3'Top'#3'['#1#5'Width'#2'&'#7'Anchors'#11
|
||||
+#6'akLeft'#8'akBottom'#0#7'Caption'#6#3'CLS'#7'OnClick'#7#14'ButtonCLSClick'
|
||||
+#8'TabOrder'#2#3#0#0#9'TCheckBox'#18'CheckBoxAutoScroll'#4'Left'#2'9'#6'Heig'
|
||||
+'ht'#2#19#3'Top'#3'['#1#5'Width'#2'E'#7'Anchors'#11#6'akLeft'#8'akBottom'#0#7
|
||||
+'Caption'#6#11'auto scroll'#7'Checked'#9#5'State'#7#9'cbChecked'#8'TabOrder'
|
||||
+#2#4#0#0#9'TComboBox'#22'ComboBoxAuthentication'#4'Left'#2'u'#6'Height'#2#21
|
||||
+#3'Top'#2'#'#5'Width'#3#132#1#10'ItemHeight'#2#13#9'ItemIndex'#2#1#13'Items.'
|
||||
+'Strings'#1#6#17'No authentication'#6#7'Default'#6#4'None'#6#9'HttpBasic'#6#4
|
||||
+'SSPI'#0#8'OnChange'#7#28'ComboBoxAuthenticationChange'#5'Style'#7#14'csDrop'
|
||||
+'DownList'#8'TabOrder'#2#5#4'Text'#6#7'Default'#0#0#7'TButton'#27'ButtonShow'
|
||||
+'AuthorizationInfo'#4'Left'#3#255#1#6'Height'#2#19#3'Top'#2'$'#5'Width'#2'*'
|
||||
+#7'Caption'#6#4'Info'#7'OnClick'#7' ButtonShowAuthorizationInfoClick'#8'TabO'
|
||||
+'rder'#2#6#0#0#9'TCheckBox'#18'CheckBoxDisableLog'#4'Left'#3#133#0#6'Height'
|
||||
+#2#19#3'Top'#3'['#1#5'Width'#3#204#0#7'Anchors'#11#6'akLeft'#8'akBottom'#0#7
|
||||
+'Caption'#6'&disable log (for max performance test)'#7'OnClick'#7#23'CheckBo'
|
||||
+'xDisableLogClick'#8'TabOrder'#2#7#0#0#9'TComboBox'#16'ComboBoxProtocol'#4'L'
|
||||
+'eft'#2'u'#6'Height'#2#21#3'Top'#2#8#5'Width'#3#132#1#13'DropDownCount'#2#10
|
||||
+#10'ItemHeight'#2#13#9'ItemIndex'#2#7#13'Items.Strings'#1#6#28'HTTP '
|
||||
+' ( socket )'#6'I '#226#128#186' HTTP ( fast http.sys // requi'
|
||||
+'re admin rights else socket )'#6'D '#226#128#186#226#128#186' HTTPS '
|
||||
+'( fast http.sys + SSL // require admin rights )'#6'K '#226#128#186' HTTP '
|
||||
+' ( fast http.sys + AES-CFB 256 // require admin rights )'#6' HTTP '
|
||||
+' ( web socket )'#6'& '#226#128#186' WebSocket ( bidirectional, JS'
|
||||
+'ON )'#6'( '#226#128#186' WebSocket ( bidirectional, binary )'#6'5 '#226#128
|
||||
+#186' WebSocket ( bidirectional, binary + AES-CFB 256)'#6#10'Named pipe'#0#8
|
||||
+'OnChange'#7#22'ComboBoxProtocolChange'#5'Style'#7#14'csDropDownList'#8'TabO'
|
||||
+'rder'#2#8#4'Text'#6'5 '#226#128#186' WebSocket ( bidirectional, binary + AE'
|
||||
+'S-CFB 256)'#0#0#9'TGroupBox GroupBoxMethodGroupConfiguration'#4'Left'#3#164
|
||||
+#0#6'Height'#3#203#0#3'Top'#2'>'#5'Width'#3#8#2#7'Caption'#6#28'Method / Gro'
|
||||
+'up configuration'#12'ClientHeight'#3#185#0#11'ClientWidth'#3#4#2#8'TabOrder'
|
||||
+#2#9#0#9'TListView'#20'ListViewMethodGroups'#4'Left'#2#10#6'Height'#3#133#0#3
|
||||
+'Top'#2#16#5'Width'#3#247#1#7'Columns'#14#1#7'Caption'#6#7' Method'#5'Width'
|
||||
+#3#150#0#0#1#7'Caption'#6#20' Allow group by name'#5'Width'#3#160#0#0#1#7'Ca'
|
||||
+'ption'#6#19' Deny group by name'#5'Width'#3#160#0#0#0#13'HideSelection'#8#8
|
||||
+'ReadOnly'#9#9'RowSelect'#9#8'TabOrder'#2#0#9'ViewStyle'#7#8'vsReport'#7'OnC'
|
||||
+'lick'#7#25'ListViewMethodGroupsClick'#12'OnSelectItem'#7#30'ListViewMethodG'
|
||||
+'roupsSelectItem'#0#0#7'TButton'#27'ButtonSaveRoleConfiguration'#4'Left'#3
|
||||
+#207#1#6'Height'#2#25#3'Top'#3#155#0#5'Width'#2'2'#7'Caption'#6#4'Save'#7'On'
|
||||
,'Click'#7' ButtonSaveRoleConfigurationClick'#8'TabOrder'#2#1#0#0#5'TEdit'#19
|
||||
+'EditAllowGroupNames'#4'Left'#3#136#0#6'Height'#2#21#3'Top'#3#157#0#5'Width'
|
||||
+#3#160#0#8'TabOrder'#2#2#8'TextHint'#6#31'Allow group names (sep by ",")'#0
|
||||
+#0#5'TEdit'#23'EditDenyAllowGroupNames'#4'Left'#3'*'#1#6'Height'#2#21#3'Top'
|
||||
+#3#157#0#5'Width'#3#159#0#8'TabOrder'#2#3#8'TextHint'#6#29'Deny group names '
|
||||
+'(sep by ",")'#0#0#0#11'TRadioGroup'#29'RadioGroupAuthorizationPolicy'#4'Lef'
|
||||
+'t'#2#8#6'Height'#2'I'#3'Top'#2'>'#5'Width'#3#150#0#8'AutoFill'#9#7'Caption'
|
||||
+#6#20'Authorization policy'#28'ChildSizing.LeftRightSpacing'#2#6#29'ChildSiz'
|
||||
+'ing.EnlargeHorizontal'#7#24'crsHomogenousChildResize'#27'ChildSizing.Enlarg'
|
||||
+'eVertical'#7#24'crsHomogenousChildResize'#28'ChildSizing.ShrinkHorizontal'#7
|
||||
+#14'crsScaleChilds'#26'ChildSizing.ShrinkVertical'#7#14'crsScaleChilds'#18'C'
|
||||
+'hildSizing.Layout'#7#29'cclLeftToRightThenTopToBottom'#27'ChildSizing.Contr'
|
||||
+'olsPerLine'#2#1#12'ClientHeight'#2'7'#11'ClientWidth'#3#146#0#9'ItemIndex'#2
|
||||
+#2#13'Items.Strings'#1#6#9'Allow all'#6#8'Deny all'#6#22'Follow groups setti'
|
||||
+'ngs'#0#7'OnClick'#7'"RadioGroupAuthorizationPolicyClick'#8'TabOrder'#2#10#0
|
||||
+#0#9'TGroupBox'#13'GroupBoxUsers'#4'Left'#3#178#2#6'Height'#3#203#0#3'Top'#2
|
||||
+'>'#5'Width'#3#127#1#7'Caption'#6#5'Users'#12'ClientHeight'#3#185#0#11'Clien'
|
||||
+'tWidth'#3'{'#1#8'TabOrder'#2#11#0#9'TListView'#13'ListViewUsers'#4'Left'#2#9
|
||||
+#6'Height'#3#133#0#3'Top'#2#16#5'Width'#3'm'#1#7'Columns'#14#1#7'Caption'#6#5
|
||||
+' User'#5'Width'#2'n'#0#1#7'Caption'#6#9' Password'#5'Width'#2'n'#0#1#7'Capt'
|
||||
+'ion'#6#6' Group'#5'Width'#2'n'#0#0#13'HideSelection'#8#8'ReadOnly'#9#9'RowS'
|
||||
+'elect'#9#8'TabOrder'#2#0#9'ViewStyle'#7#8'vsReport'#7'OnClick'#7#18'ListVie'
|
||||
+'wUsersClick'#12'OnSelectItem'#7#23'ListViewUsersSelectItem'#0#0#5'TEdit'#13
|
||||
+'EditUserGroup'#4'Left'#3#223#0#6'Height'#2#21#3'Top'#3#157#0#5'Width'#2'S'#8
|
||||
+'TabOrder'#2#1#8'TextHint'#6#5'Group'#0#0#7'TButton'#15'ButtonSaveUsers'#4'L'
|
||||
+'eft'#3'8'#1#6'Height'#2#25#3'Top'#3#155#0#5'Width'#2'>'#7'Caption'#6#8'Save'
|
||||
+'/Add'#7'OnClick'#7#20'ButtonSaveUsersClick'#8'TabOrder'#2#2#0#0#5'TEdit'#12
|
||||
+'EditUserName'#4'Left'#2'5'#6'Height'#2#21#3'Top'#3#157#0#5'Width'#2'S'#8'Ta'
|
||||
+'bOrder'#2#3#8'TextHint'#6#4'User'#0#0#7'TButton'#16'ButtonDeleteUser'#4'Lef'
|
||||
+'t'#2#9#6'Height'#2#25#3'Top'#3#155#0#5'Width'#2'&'#7'Caption'#6#3'DeL'#7'On'
|
||||
+'Click'#7#21'ButtonDeleteUserClick'#8'TabOrder'#2#4#0#0#5'TEdit'#16'EditUser'
|
||||
+'Password'#4'Left'#3#138#0#6'Height'#2#21#3'Top'#3#157#0#5'Width'#2'S'#8'Tab'
|
||||
+'Order'#2#5#8'TextHint'#6#8'Password'#0#0#0#6'TTimer'#19'TimerRefreshLogMemo'
|
||||
+#7'OnTimer'#7#24'TimerRefreshLogMemoTimer'#4'left'#2'8'#3'top'#3#8#1#0#0#0
|
||||
]);
|
||||
@@ -0,0 +1,552 @@
|
||||
unit RestServerFormUnit;
|
||||
|
||||
// mORMot RESTful API test case 1.02
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
// RTL
|
||||
{$IFDEF MSWINDOWS}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
{$ifdef FPC}
|
||||
LCLType,
|
||||
{$endif}
|
||||
Messages,
|
||||
SysUtils,
|
||||
Classes,
|
||||
Generics.Collections,
|
||||
Forms,
|
||||
Dialogs,
|
||||
Controls,
|
||||
StdCtrls,
|
||||
ExtCtrls,
|
||||
// mORMot
|
||||
mORMot,
|
||||
mORMotHttpServer,
|
||||
SynLog,
|
||||
SynCommons,
|
||||
// Custom
|
||||
RestServerUnit, ComCtrls;
|
||||
|
||||
type
|
||||
lServerAction = (Auto, Start, Stop, Restart);
|
||||
|
||||
TForm1 = class(TForm)
|
||||
EditPort: TEdit;
|
||||
LabelPortCap: TLabel;
|
||||
ButtonStartStop: TButton;
|
||||
MemoLog: TMemo;
|
||||
ButtonCLS: TButton;
|
||||
TimerRefreshLogMemo: TTimer;
|
||||
CheckBoxAutoScroll: TCheckBox;
|
||||
LabelAuthenticationMode: TLabel;
|
||||
ComboBoxAuthentication: TComboBox;
|
||||
ButtonShowAuthorizationInfo: TButton;
|
||||
CheckBoxDisableLog: TCheckBox;
|
||||
LabelProtocol: TLabel;
|
||||
ComboBoxProtocol: TComboBox;
|
||||
ListViewMethodGroups: TListView;
|
||||
GroupBoxMethodGroupConfiguration: TGroupBox;
|
||||
RadioGroupAuthorizationPolicy: TRadioGroup;
|
||||
ButtonSaveRoleConfiguration: TButton;
|
||||
EditAllowGroupNames: TEdit;
|
||||
EditDenyAllowGroupNames: TEdit;
|
||||
GroupBoxUsers: TGroupBox;
|
||||
ListViewUsers: TListView;
|
||||
EditUserGroup: TEdit;
|
||||
ButtonSaveUsers: TButton;
|
||||
EditUserName: TEdit;
|
||||
ButtonDeleteUser: TButton;
|
||||
EditUserPassword: TEdit;
|
||||
LabelHTTPSnote: TLabel;
|
||||
procedure ButtonStartStopClick(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure ButtonCLSClick(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
procedure TimerRefreshLogMemoTimer(Sender: TObject);
|
||||
procedure ComboBoxAuthenticationChange(Sender: TObject);
|
||||
procedure ButtonShowAuthorizationInfoClick(Sender: TObject);
|
||||
procedure CheckBoxDisableLogClick(Sender: TObject);
|
||||
procedure ComboBoxProtocolChange(Sender: TObject);
|
||||
procedure ListViewMethodGroupsSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
|
||||
procedure ListViewUsersSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
|
||||
procedure ButtonSaveRoleConfigurationClick(Sender: TObject);
|
||||
procedure ButtonSaveUsersClick(Sender: TObject);
|
||||
procedure RadioGroupAuthorizationPolicyClick(Sender: TObject);
|
||||
procedure ButtonDeleteUserClick(Sender: TObject);
|
||||
procedure ListViewUsersClick(Sender: TObject);
|
||||
procedure ListViewMethodGroupsClick(Sender: TObject);
|
||||
private
|
||||
function LogEvent(Sender: TTextWriter; Level: TSynLogInfo; const Text: RawUTF8): Boolean;
|
||||
function GetAuthModeDescription(AM: lAuthenticationMode): string;
|
||||
function FillMethodAuthorizationRulesFromUI(RestServerSettings: TRestServerSettings): Boolean;
|
||||
procedure StartStopServer(ServerAction: lServerAction = Auto);
|
||||
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
TLocalLog = class
|
||||
Level: TSynLogInfo;
|
||||
Text: RawUTF8;
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
{$ifdef FPC}
|
||||
LogThreadSafeList: TList<TLocalLog>;
|
||||
{$else}
|
||||
LogThreadSafeList: TThreadList<TLocalLog>;
|
||||
{$endif}
|
||||
|
||||
implementation
|
||||
|
||||
{$ifdef FPC}
|
||||
{$R *.lfm}
|
||||
{$else}
|
||||
{$R *.dfm}
|
||||
{$endif}
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
// On Form1 create
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
// Create thread safe List with log data class
|
||||
{$ifdef FPC}
|
||||
LogThreadSafeList := TList<TLocalLog>.Create();
|
||||
{$else}
|
||||
LogThreadSafeList := TThreadList<TLocalLog>.Create();
|
||||
{$endif}
|
||||
// Enable logging
|
||||
with TSQLLog.Family do
|
||||
begin
|
||||
Level := LOG_VERBOSE;
|
||||
EchoCustom := LogEvent;
|
||||
NoFile := True;
|
||||
end;
|
||||
{$IFNDEF MSWINDOWS}
|
||||
// no named pipes on non-windows
|
||||
ComboBoxProtocol.Items.Delete(ComboBoxProtocol.Items.Count-1);
|
||||
// on Linux, ports below 1000 are priviledged (root only)
|
||||
EditPort.Text:='7777';
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
// On Form1 destory
|
||||
procedure TForm1.FormDestroy(Sender: TObject);
|
||||
var
|
||||
i: integer;
|
||||
List: TList<TLocalLog>;
|
||||
begin
|
||||
// Clear and destroy LogThreadSafeList
|
||||
{$ifdef FPC}
|
||||
List := LogThreadSafeList;
|
||||
{$else}
|
||||
List := LogThreadSafeList.LockList;
|
||||
{$endif}
|
||||
for i := 0 to List.Count - 1 do
|
||||
List.Items[i].Free;
|
||||
List.Clear;
|
||||
{$ifndef FPC}
|
||||
LogThreadSafeList.UnlockList();
|
||||
{$endif}
|
||||
FreeAndNil(LogThreadSafeList);
|
||||
end;
|
||||
|
||||
{ SERVER EVENTS, START / STOP }
|
||||
|
||||
// Fill RestServerSettings object with groups, users and method authorization settings
|
||||
function TForm1.FillMethodAuthorizationRulesFromUI(RestServerSettings: TRestServerSettings): Boolean;
|
||||
var
|
||||
i, j, l: integer;
|
||||
AddedGroups, GroupsToAdd: TStringList;
|
||||
AuthGroup: rAuthGroup;
|
||||
AuthUser: rAuthUser;
|
||||
MethodAuthorizationSettings: rMethodAuthorizationSettings;
|
||||
SQLAccessRights: TSQLAccessRights;
|
||||
GroupName, MethodName, UserName: string;
|
||||
begin
|
||||
Result := True;
|
||||
// Prepare temp objects
|
||||
AddedGroups := TStringList.Create();
|
||||
GroupsToAdd := TStringList.Create();
|
||||
GroupsToAdd.LineBreak := ',';
|
||||
GroupsToAdd.Duplicates := dupIgnore;
|
||||
// For REST service, only one rule required = reService, will be applyed to all groups
|
||||
SQLAccessRights.AllowRemoteExecute := [reService];
|
||||
// Fill group names from columns "Allow" and "Deny"
|
||||
for i := 0 to ListViewMethodGroups.Items.Count - 1 do
|
||||
GroupsToAdd.Text := GroupsToAdd.Text + ListViewMethodGroups.Items[i].SubItems.Strings[0] + ',' + ListViewMethodGroups.Items[i].SubItems.Strings[1];
|
||||
// Add groups
|
||||
for i := 0 to GroupsToAdd.Count - 1 do
|
||||
begin
|
||||
GroupName := GroupsToAdd.Strings[i];
|
||||
if AddedGroups.IndexOf(GroupName) = -1 then
|
||||
begin
|
||||
// Ok, new group here, we must add it before continue
|
||||
AuthGroup.Name := StringToUTF8(GroupName);
|
||||
AuthGroup.SessionTimeout := 10;
|
||||
AuthGroup.SQLAccessRights := SQLAccessRights;
|
||||
if RestServerSettings.AddGroup(AuthGroup) then
|
||||
// Add group to local temp list, to avoid double processing
|
||||
AddedGroups.Add(GroupName)
|
||||
else
|
||||
begin
|
||||
Result := False;
|
||||
ShowMessage('Group "' + GroupName + '" was not added, for some reason.');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
GroupsToAdd.Clear;
|
||||
if Result then
|
||||
begin
|
||||
// Add method authorization settings
|
||||
for i := 0 to ListViewMethodGroups.Items.Count - 1 do
|
||||
begin
|
||||
MethodName := ListViewMethodGroups.Items[i].Caption;
|
||||
MethodAuthorizationSettings.MethodName := StringToUTF8(MethodName);
|
||||
SetLength(MethodAuthorizationSettings.AllowedGroups, 0);
|
||||
SetLength(MethodAuthorizationSettings.DeniedGroups, 0);
|
||||
// Allowed groups
|
||||
GroupsToAdd.Text := ListViewMethodGroups.Items[i].SubItems.Strings[0];
|
||||
for j := 0 to GroupsToAdd.Count - 1 do
|
||||
begin
|
||||
GroupName := GroupsToAdd.Strings[j];
|
||||
if AddedGroups.IndexOf(GroupName) <> -1 then
|
||||
begin
|
||||
l := Length(MethodAuthorizationSettings.AllowedGroups);
|
||||
SetLength(MethodAuthorizationSettings.AllowedGroups, l + 1);
|
||||
MethodAuthorizationSettings.AllowedGroups[l] := StringToUTF8(GroupName);
|
||||
end
|
||||
end;
|
||||
GroupsToAdd.Clear;
|
||||
// Denied groups
|
||||
GroupsToAdd.Text := ListViewMethodGroups.Items[i].SubItems.Strings[1];
|
||||
for j := 0 to GroupsToAdd.Count - 1 do
|
||||
begin
|
||||
GroupName := GroupsToAdd.Strings[j];
|
||||
if AddedGroups.IndexOf(GroupName) <> -1 then
|
||||
begin
|
||||
l := Length(MethodAuthorizationSettings.DeniedGroups);
|
||||
SetLength(MethodAuthorizationSettings.DeniedGroups, l + 1);
|
||||
MethodAuthorizationSettings.DeniedGroups[l] := StringToUTF8(GroupName);
|
||||
end
|
||||
end;
|
||||
if not RestServerSettings.AddMethodAuthorizationSettings(MethodAuthorizationSettings) then
|
||||
begin
|
||||
Result := False;
|
||||
ShowMessage('Method authorization settings for method"' + UTF8ToString(MethodAuthorizationSettings.MethodName) + '" was not added, for some reason.');
|
||||
end;
|
||||
end;
|
||||
GroupsToAdd.Clear;
|
||||
if Result then
|
||||
begin
|
||||
// Add users
|
||||
for i := 0 to ListViewUsers.Items.Count - 1 do
|
||||
begin
|
||||
UserName := ListViewUsers.Items[i].Caption;
|
||||
AuthUser.LogonName := StringToUTF8(UserName);
|
||||
AuthUser.DisplayName := AuthUser.LogonName;
|
||||
AuthUser.PasswordPlain := StringToUTF8(ListViewUsers.Items[i].SubItems.Strings[0]);
|
||||
AuthUser.Group := StringToUTF8(ListViewUsers.Items[i].SubItems.Strings[1]);
|
||||
if not RestServerSettings.AddUser(AuthUser) then
|
||||
begin
|
||||
Result := False;
|
||||
ShowMessage('User "' + UserName + '" was not added, for some reason.');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
// Cleanup
|
||||
AddedGroups.Free;
|
||||
GroupsToAdd.Free;
|
||||
end;
|
||||
|
||||
// Depends on the server status, start or stop server (create or destroy objects)
|
||||
procedure TForm1.StartStopServer(ServerAction: lServerAction = Auto);
|
||||
var
|
||||
pServerCreated: Boolean;
|
||||
RestServerSettings: TRestServerSettings;
|
||||
begin
|
||||
pServerCreated := RestServer.Initialized;
|
||||
// Unload current server if required
|
||||
if pServerCreated then
|
||||
RestServer.DeInitialize();
|
||||
// Create server if required
|
||||
if ((ServerAction = lServerAction.Auto) and not pServerCreated) or ((ServerAction = lServerAction.Restart) and pServerCreated) or (ServerAction = lServerAction.Start) then
|
||||
begin
|
||||
// Create server object with selected Protocol and Auth mode
|
||||
RestServerSettings := TRestServerSettings.Create();
|
||||
RestServerSettings.Protocol := lProtocol(ComboBoxProtocol.ItemIndex);
|
||||
RestServerSettings.Port := EditPort.Text;
|
||||
RestServerSettings.AuthenticationMode := lAuthenticationMode(ComboBoxAuthentication.ItemIndex);
|
||||
RestServerSettings.AuthorizationPolicy := lAuthorizationPolicy(RadioGroupAuthorizationPolicy.ItemIndex);
|
||||
// Fill method authorization rules from UI
|
||||
FillMethodAuthorizationRulesFromUI(RestServerSettings);
|
||||
// Start server
|
||||
RestServer.Initialize(RestServerSettings);
|
||||
end;
|
||||
end;
|
||||
|
||||
// Processing mORMot log event
|
||||
function TForm1.LogEvent(Sender: TTextWriter; Level: TSynLogInfo; const Text: RawUTF8): Boolean;
|
||||
var
|
||||
List: TList<TLocalLog>;
|
||||
LogEventData: TLocalLog;
|
||||
begin
|
||||
Result := False;
|
||||
if Assigned(LogThreadSafeList) then
|
||||
begin
|
||||
{$ifdef FPC}
|
||||
List := LogThreadSafeList;
|
||||
{$else}
|
||||
List := LogThreadSafeList.LockList;
|
||||
{$endif}
|
||||
try
|
||||
LogEventData := TLocalLog.Create();
|
||||
LogEventData.Level := Level;
|
||||
LogEventData.Text := Text;
|
||||
List.Add(LogEventData);
|
||||
Result := True;
|
||||
finally
|
||||
{$ifndef FPC}
|
||||
LogThreadSafeList.UnlockList();
|
||||
{$endif}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ UI }
|
||||
|
||||
// Grabbing new events from thread safe list
|
||||
procedure TForm1.TimerRefreshLogMemoTimer(Sender: TObject);
|
||||
var
|
||||
List: TList<TLocalLog>;
|
||||
i: integer;
|
||||
begin
|
||||
if Assigned(LogThreadSafeList) then
|
||||
begin
|
||||
{$ifdef FPC}
|
||||
List := LogThreadSafeList;
|
||||
{$else}
|
||||
List := LogThreadSafeList.LockList;
|
||||
{$endif}
|
||||
try
|
||||
if Assigned(Form1) and not Application.Terminated and (List.Count > 0) then
|
||||
begin
|
||||
for i := 0 to List.Count - 1 do
|
||||
begin
|
||||
Form1.MemoLog.Lines.BeginUpdate();
|
||||
Form1.MemoLog.Lines.Add(string(List.Items[i].Text));
|
||||
Form1.MemoLog.Lines.EndUpdate();
|
||||
List.Items[i].Free;
|
||||
end;
|
||||
List.Clear();
|
||||
{$IFDEF MSWINDOWS}
|
||||
if CheckBoxAutoScroll.Checked then
|
||||
SendMessage(Form1.MemoLog.Handle, WM_VSCROLL, SB_BOTTOM, 0);
|
||||
{$ENDIF}
|
||||
end;
|
||||
finally
|
||||
{$ifndef FPC}
|
||||
LogThreadSafeList.UnlockList();
|
||||
{$endif}
|
||||
end;
|
||||
end;
|
||||
if RestServer.Initialized then
|
||||
ButtonStartStop.Caption := 'Stop server'
|
||||
else
|
||||
ButtonStartStop.Caption := 'Start server';
|
||||
end;
|
||||
|
||||
// Get description for AuthMode
|
||||
function TForm1.GetAuthModeDescription(AM: lAuthenticationMode): string;
|
||||
begin
|
||||
case AM of
|
||||
NoAuthentication:
|
||||
Result := 'Disabled authentication.';
|
||||
{
|
||||
URI:
|
||||
Result := 'Weak authentication scheme using URL-level parameter';
|
||||
}
|
||||
{
|
||||
SignedURI:
|
||||
Result := 'Secure authentication scheme using URL-level digital signature - expected format of session_signature is:' + #13 + 'Hexa8(SessionID) + Hexa8(TimeStamp) + ' + #13 +
|
||||
'Hexa8(crc32(SessionID + HexaSessionPrivateKey Sha256(salt + PassWord) + Hexa8(TimeStamp) + url))';
|
||||
}
|
||||
Default:
|
||||
Result := 'mORMot secure RESTful authentication scheme, this method will use a password stored via safe SHA-256 hashing in the TSQLAuthUser ORM table';
|
||||
None:
|
||||
Result := 'mORMot weak RESTful authentication scheme, this method will authenticate with a given username, but no signature' + #13 +
|
||||
'on client side, this scheme is not called by TSQLRestClientURI.SetUser() method - so you have to write:' + #13 + 'TSQLRestServerAuthenticationNone.ClientSetUser(Client,''User'','''');';
|
||||
HttpBasic:
|
||||
Result := 'Authentication using HTTP Basic scheme. This protocol send both name and password as clear (just base-64 encoded) so should only be used over SSL / HTTPS' +
|
||||
', or for compatibility reasons. Will rely on TSQLRestServerAuthenticationNone for authorization, on client side, this scheme is not called by TSQLRestClientURI.SetUser() ' +
|
||||
'method - so you have to write: TSQLRestServerAuthenticationHttpBasic.ClientSetUser(Client,''User'',''password'');' + #13 +
|
||||
'for a remote proxy-only authentication (without creating any mORMot session), you can write: TSQLRestServerAuthenticationHttpBasic.ClientSetUserHttpOnly(Client,''proxyUser'',''proxyPass'');';
|
||||
{$IFDEF MSWINDOWS}
|
||||
SSPI:
|
||||
Result := 'authentication of the current logged user using Windows Security Support Provider Interface (SSPI)' + #13 +
|
||||
'- is able to authenticate the currently logged user on the client side, using either NTLM or Kerberos - it would allow to safely authenticate on a mORMot server without prompting' +
|
||||
' the user to enter its password' + #13 + '- if ClientSetUser() receives aUserName as '''', aPassword should be either '''' if you expect NTLM authentication to take place,' +
|
||||
' or contain the SPN registration (e.g. ''mymormotservice/myserver.mydomain.tld'') for Kerberos authentication.' + #13 +
|
||||
'- if ClientSetUser() receives aUserName as ''DomainName\UserName'', then authentication will take place on the specified domain, with aPassword as plain password value.';
|
||||
{$ENDIF}
|
||||
else
|
||||
Result := 'Authentication description';
|
||||
end;
|
||||
end;
|
||||
|
||||
// Changing server protocol
|
||||
procedure TForm1.ComboBoxProtocolChange(Sender: TObject);
|
||||
begin
|
||||
{$IFDEF MSWINDOWS}
|
||||
LabelHTTPSnote.Visible := (lProtocol(ComboBoxProtocol.ItemIndex) = HTTPsys_SSL);
|
||||
{$ENDIF}
|
||||
StartStopServer(Restart);
|
||||
end;
|
||||
|
||||
// Changing server authentication mode
|
||||
procedure TForm1.ComboBoxAuthenticationChange(Sender: TObject);
|
||||
begin
|
||||
StartStopServer(Restart);
|
||||
end;
|
||||
|
||||
// Button clear log
|
||||
procedure TForm1.ButtonCLSClick(Sender: TObject);
|
||||
begin
|
||||
MemoLog.Clear;
|
||||
end;
|
||||
|
||||
// Button show authorization mode description
|
||||
procedure TForm1.ButtonShowAuthorizationInfoClick(Sender: TObject);
|
||||
var
|
||||
AM: lAuthenticationMode;
|
||||
begin
|
||||
AM := lAuthenticationMode(ComboBoxAuthentication.ItemIndex);
|
||||
ShowMessage(GetAuthModeDescription(AM));
|
||||
end;
|
||||
|
||||
// Button start stop server
|
||||
procedure TForm1.ButtonStartStopClick(Sender: TObject);
|
||||
begin
|
||||
StartStopServer();
|
||||
end;
|
||||
|
||||
// Checkbox Enable/Disable logging to memo (slow down performance when enabled)
|
||||
procedure TForm1.CheckBoxDisableLogClick(Sender: TObject);
|
||||
begin
|
||||
if not CheckBoxDisableLog.Checked then
|
||||
TSQLLog.Family.Level := LOG_VERBOSE
|
||||
else
|
||||
TSQLLog.Family.Level := [];
|
||||
end;
|
||||
|
||||
procedure TForm1.ListViewMethodGroupsSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
|
||||
begin
|
||||
if Assigned(Item) then
|
||||
begin
|
||||
EditAllowGroupNames.Text := Item.SubItems.Strings[0];
|
||||
EditDenyAllowGroupNames.Text := Item.SubItems.Strings[1];
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.ButtonSaveRoleConfigurationClick(Sender: TObject);
|
||||
var
|
||||
Item: TListItem;
|
||||
begin
|
||||
Item := ListViewMethodGroups.Selected;
|
||||
if Assigned(Item) then
|
||||
begin
|
||||
Item.SubItems.Strings[0] := EditAllowGroupNames.Text;
|
||||
Item.SubItems.Strings[1] := EditDenyAllowGroupNames.Text;
|
||||
StartStopServer(lServerAction.Restart);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.ListViewUsersSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
|
||||
begin
|
||||
if Assigned(Item) then
|
||||
begin
|
||||
EditUserName.Text := Item.Caption;
|
||||
EditUserPassword.Text := Item.SubItems.Strings[0];
|
||||
EditUserGroup.Text := Item.SubItems.Strings[1];
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.ButtonSaveUsersClick(Sender: TObject);
|
||||
var
|
||||
Item: TListItem;
|
||||
Done: Boolean;
|
||||
begin
|
||||
Done := False;
|
||||
Item := ListViewUsers.Selected;
|
||||
if Assigned(Item) then
|
||||
begin
|
||||
Item.Caption := EditUserName.Text;
|
||||
Item.SubItems.Strings[0] := EditUserPassword.Text;
|
||||
Item.SubItems.Strings[1] := EditUserGroup.Text;
|
||||
Done := True;
|
||||
end
|
||||
else if (EditUserName.Text <> '') and (EditUserGroup.Text <> '') then
|
||||
begin
|
||||
Item := ListViewUsers.Items.Add();
|
||||
Item.Caption := EditUserName.Text;
|
||||
Item.SubItems.Add(EditUserPassword.Text);
|
||||
Item.SubItems.Add(EditUserGroup.Text);
|
||||
Done := True;
|
||||
end
|
||||
else
|
||||
ShowMessage('User name and Group must be filled.');
|
||||
if Done then
|
||||
begin
|
||||
EditUserName.Text := '';
|
||||
EditUserPassword.Text := '';
|
||||
EditUserGroup.Text := '';
|
||||
StartStopServer(lServerAction.Restart);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.RadioGroupAuthorizationPolicyClick(Sender: TObject);
|
||||
begin
|
||||
StartStopServer(lServerAction.Restart);
|
||||
end;
|
||||
|
||||
procedure TForm1.ListViewMethodGroupsClick(Sender: TObject);
|
||||
begin
|
||||
if ListViewMethodGroups.ItemIndex = -1 then
|
||||
begin
|
||||
EditAllowGroupNames.Text := '';
|
||||
EditDenyAllowGroupNames.Text := '';
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.ListViewUsersClick(Sender: TObject);
|
||||
begin
|
||||
if ListViewUsers.ItemIndex = -1 then
|
||||
begin
|
||||
EditUserName.Text := '';
|
||||
EditUserPassword.Text := '';
|
||||
EditUserGroup.Text := '';
|
||||
end;
|
||||
end;
|
||||
|
||||
// Delete user
|
||||
procedure TForm1.ButtonDeleteUserClick(Sender: TObject);
|
||||
var
|
||||
SelUserIndex: integer;
|
||||
begin
|
||||
SelUserIndex := ListViewUsers.ItemIndex;
|
||||
if SelUserIndex <> -1 then
|
||||
begin
|
||||
ListViewUsers.Items.Delete(SelUserIndex);
|
||||
EditUserName.Text := '';
|
||||
EditUserPassword.Text := '';
|
||||
EditUserGroup.Text := '';
|
||||
StartStopServer(lServerAction.Restart);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,90 @@
|
||||
unit RestServerMethodsUnit;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
// RTL
|
||||
SysUtils,
|
||||
Classes,
|
||||
StrUtils,
|
||||
Forms,
|
||||
Dialogs,
|
||||
Controls,
|
||||
StdCtrls,
|
||||
ExtCtrls,
|
||||
// mORMot
|
||||
mORMot,
|
||||
mORMotHttpServer,
|
||||
SynCommons,
|
||||
// Custom
|
||||
RestMethodsInterfaceUnit;
|
||||
|
||||
type
|
||||
|
||||
TCustomRecord = record helper for rCustomRecord
|
||||
procedure FillResultFromServer();
|
||||
end;
|
||||
|
||||
TRestMethods = class(TInjectableObjectRest, IRestMethods)
|
||||
public
|
||||
function HelloWorld(): string;
|
||||
function Sum(val1, val2: Double): Double;
|
||||
function GetCustomRecord(): rCustomRecord;
|
||||
function SendCustomRecord(const CustomResult: rCustomRecord): Boolean;
|
||||
function SendMultipleCustomRecords(const CustomResult: rCustomRecord; const CustomComplicatedRecord: rCustomComplicatedRecord): Boolean;
|
||||
function GetMethodCustomResult(): TServiceCustomAnswer; // without default {result:[]}
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TCustomResultSrv }
|
||||
|
||||
procedure TCustomRecord.FillResultFromServer();
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
ResultCode := 200;
|
||||
ResultStr := 'Awesome';
|
||||
ResultTimeStamp := Now();
|
||||
SetLength(ResultArray, 3);
|
||||
for i := 0 to 2 do
|
||||
ResultArray[i] := 'str_' + i.ToString();
|
||||
end;
|
||||
|
||||
{ TServiceServer }
|
||||
|
||||
// [!] ServiceContext can be used from any method to access low level request data
|
||||
|
||||
function TRestMethods.HelloWorld(): string;
|
||||
begin
|
||||
Result := 'Hello world';
|
||||
end;
|
||||
|
||||
function TRestMethods.Sum(val1, val2: Double): Double;
|
||||
begin
|
||||
Result := val1 + val2;
|
||||
end;
|
||||
|
||||
function TRestMethods.GetCustomRecord(): rCustomRecord;
|
||||
begin
|
||||
Result.FillResultFromServer();
|
||||
end;
|
||||
|
||||
function TRestMethods.SendCustomRecord(const CustomResult: rCustomRecord): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function TRestMethods.SendMultipleCustomRecords(const CustomResult: rCustomRecord; const CustomComplicatedRecord: rCustomComplicatedRecord): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function TRestMethods.GetMethodCustomResult(): TServiceCustomAnswer;
|
||||
begin
|
||||
Result.Header := 'Content-type: UTF-8';
|
||||
Result.Content := 'I am custom result, no "result:[]" used.';
|
||||
Result.Status := 200;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,417 @@
|
||||
unit RestServerUnit;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
// RTL
|
||||
SysUtils,
|
||||
Classes,
|
||||
StrUtils,
|
||||
Generics.Collections,
|
||||
Dialogs,
|
||||
// mORMot
|
||||
mORMot,
|
||||
mORMotHttpServer,
|
||||
SynBidirSock,
|
||||
SynCommons,
|
||||
SynCrtSock,
|
||||
// Custom
|
||||
RestMethodsInterfaceUnit,
|
||||
RestServerMethodsUnit;
|
||||
|
||||
type
|
||||
lProtocol = (HTTP_Socket, HTTPsys, HTTPsys_SSL, HTTPsys_AES, HTTP_WebSocket, WebSocketBidir_JSON, WebSocketBidir_Binary, WebSocketBidir_BinaryAES{$IFDEF MSWINDOWS}, NamedPipe{$ENDIF});
|
||||
lAuthenticationMode = (NoAuthentication, Default, None, HttpBasic{$IFDEF MSWINDOWS},SSPI{$ENDIF});
|
||||
lAuthorizationPolicy = (AllowAll, DenyAll, FollowGroupsSettings);
|
||||
|
||||
rAuthGroup = record
|
||||
Name: RawUTF8;
|
||||
SessionTimeout: integer;
|
||||
SQLAccessRights: TSQLAccessRights;
|
||||
end;
|
||||
|
||||
rAuthUser = record
|
||||
LogonName: RawUTF8;
|
||||
DisplayName: RawUTF8;
|
||||
PasswordPlain: RawUTF8;
|
||||
PasswordHashHexa: RawUTF8;
|
||||
Group: RawUTF8;
|
||||
end;
|
||||
|
||||
rMethodAuthorizationSettings = record
|
||||
MethodName: RawUTF8;
|
||||
AllowedGroups: array of RawUTF8;
|
||||
DeniedGroups: array of RawUTF8;
|
||||
end;
|
||||
|
||||
TRestServerSettings = class
|
||||
private
|
||||
fGroupList: TList<rAuthGroup>;
|
||||
fUserList: TList<rAuthUser>;
|
||||
fMethodAuthorizationSettings: TList<rMethodAuthorizationSettings>;
|
||||
public
|
||||
Protocol: lProtocol;
|
||||
Port: string;
|
||||
AuthenticationMode: lAuthenticationMode;
|
||||
AuthorizationPolicy: lAuthorizationPolicy;
|
||||
constructor Create();
|
||||
destructor Destroy(); override;
|
||||
function AddGroup(AuthGroup: rAuthGroup): boolean;
|
||||
function AddUser(AuthUser: rAuthUser): boolean;
|
||||
function AddMethodAuthorizationSettings(MethodAuthorizationSettings: rMethodAuthorizationSettings): boolean;
|
||||
end;
|
||||
|
||||
tRestServer = class
|
||||
private
|
||||
fModel: TSQLModel;
|
||||
fRestServer: TSQLRestServer;
|
||||
fHTTPServer: TSQLHttpServer;
|
||||
fServerSettings: TRestServerSettings;
|
||||
fInitialized: boolean;
|
||||
procedure ApplyAuthorizationRules(ServiceFactoryServer: TServiceFactoryServer; RestServerSettings: TRestServerSettings);
|
||||
public
|
||||
property Initialized: boolean read fInitialized;
|
||||
constructor Create();
|
||||
destructor Destroy(); override;
|
||||
function Initialize(SrvSettings: TRestServerSettings): boolean;
|
||||
function DeInitialize(): boolean;
|
||||
end;
|
||||
|
||||
const
|
||||
AppID = '{AA4AC37D-B812-46A7-BEFB-A68167A05BA7}';
|
||||
|
||||
var
|
||||
RestServer: tRestServer;
|
||||
|
||||
implementation
|
||||
|
||||
{ TServerSettings }
|
||||
|
||||
constructor TRestServerSettings.Create();
|
||||
begin
|
||||
AuthenticationMode := lAuthenticationMode.NoAuthentication;
|
||||
AuthorizationPolicy := lAuthorizationPolicy.AllowAll;
|
||||
fGroupList := TList<rAuthGroup>.Create();
|
||||
fUserList := TList<rAuthUser>.Create();
|
||||
fMethodAuthorizationSettings := TList<rMethodAuthorizationSettings>.Create();
|
||||
end;
|
||||
|
||||
destructor TRestServerSettings.Destroy();
|
||||
begin
|
||||
fGroupList.Free;
|
||||
fUserList.Free;
|
||||
fMethodAuthorizationSettings.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TRestServerSettings.AddGroup(AuthGroup: rAuthGroup): boolean;
|
||||
begin
|
||||
Result := True;
|
||||
// some checks must be implemented here
|
||||
// ...
|
||||
fGroupList.Add(AuthGroup);
|
||||
end;
|
||||
|
||||
function TRestServerSettings.AddUser(AuthUser: rAuthUser): boolean;
|
||||
begin
|
||||
Result := True;
|
||||
// some checks must be implemented here
|
||||
// ...
|
||||
fUserList.Add(AuthUser);
|
||||
end;
|
||||
|
||||
function TRestServerSettings.AddMethodAuthorizationSettings(MethodAuthorizationSettings: rMethodAuthorizationSettings): boolean;
|
||||
begin
|
||||
Result := True;
|
||||
// some checks must be implemented here
|
||||
// ...
|
||||
fMethodAuthorizationSettings.Add(MethodAuthorizationSettings);
|
||||
end;
|
||||
|
||||
{ tRestServer }
|
||||
|
||||
constructor tRestServer.Create();
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
destructor tRestServer.Destroy();
|
||||
begin
|
||||
DeInitialize();
|
||||
fServerSettings.Free();
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure tRestServer.ApplyAuthorizationRules(ServiceFactoryServer: TServiceFactoryServer; RestServerSettings: TRestServerSettings);
|
||||
var
|
||||
User: TSQLAuthUser;
|
||||
Group: TSQLAuthGroup;
|
||||
GroupID: TID;
|
||||
i, j: integer;
|
||||
AuthGroup: rAuthGroup;
|
||||
AuthUser: rAuthUser;
|
||||
MethodAuthorizationSettings: rMethodAuthorizationSettings;
|
||||
// IDs: TIDDynArray;
|
||||
begin
|
||||
// ID := fRestServer.MainFieldID(TSQLAuthGroup, 'User');
|
||||
|
||||
{ TSQLAuthGroup }
|
||||
// Clear default groups
|
||||
fRestServer.Delete(TSQLAuthGroup, '');
|
||||
for i := 0 to RestServerSettings.fGroupList.Count - 1 do
|
||||
begin
|
||||
AuthGroup := RestServerSettings.fGroupList.Items[i];
|
||||
Group := TSQLAuthGroup.Create();
|
||||
Group.Ident := AuthGroup.Name;
|
||||
Group.SQLAccessRights := AuthGroup.SQLAccessRights;
|
||||
Group.SessionTimeout := AuthGroup.SessionTimeout;
|
||||
// Save object to ORM
|
||||
fRestServer.Add(Group, True);
|
||||
// Cleanup
|
||||
Group.Free;
|
||||
end;
|
||||
|
||||
{ TSQLAuthUser }
|
||||
// Clear default users
|
||||
fRestServer.Delete(TSQLAuthUser, '');
|
||||
for i := 0 to RestServerSettings.fUserList.Count - 1 do
|
||||
begin
|
||||
AuthUser := RestServerSettings.fUserList.Items[i];
|
||||
User := TSQLAuthUser.Create();
|
||||
User.DisplayName := AuthUser.DisplayName;
|
||||
User.LogonName := AuthUser.LogonName;
|
||||
User.PasswordPlain := AuthUser.PasswordPlain;
|
||||
if AuthUser.PasswordHashHexa <> '' then
|
||||
User.PasswordHashHexa := AuthUser.PasswordHashHexa;
|
||||
if AuthUser.Group <> '' then
|
||||
begin
|
||||
GroupID := fRestServer.MainFieldID(TSQLAuthGroup, AuthUser.Group);
|
||||
User.GroupRights := pointer(GroupID);
|
||||
end;
|
||||
// Save object to ORM
|
||||
fRestServer.Add(User, True);
|
||||
// Cleanup
|
||||
User.Free;
|
||||
end;
|
||||
|
||||
{
|
||||
// DEBUG
|
||||
fRestServer.MainFieldIDs(TSQLAuthGroup, ['Administrators', 'Users'], IDs);
|
||||
if Length(IDs) = 0 then
|
||||
ShowMessage('why IDs = []? (((');
|
||||
// WHY IDs empty?
|
||||
Group := TSQLAuthGroup.CreateAndFillPrepare(fRestServer, '');
|
||||
try
|
||||
while Group.FillOne do
|
||||
ShowMessage(Group.Ident);
|
||||
finally
|
||||
Group.Free;
|
||||
end;
|
||||
// DEBUG
|
||||
}
|
||||
|
||||
// Apply Authorization Rules
|
||||
case RestServerSettings.AuthorizationPolicy of
|
||||
AllowAll:
|
||||
ServiceFactoryServer.AllowAll();
|
||||
DenyAll:
|
||||
ServiceFactoryServer.DenyAll();
|
||||
FollowGroupsSettings:
|
||||
begin
|
||||
ServiceFactoryServer.DenyAll();
|
||||
for i := 0 to RestServerSettings.fMethodAuthorizationSettings.Count - 1 do
|
||||
begin
|
||||
MethodAuthorizationSettings := RestServerSettings.fMethodAuthorizationSettings.Items[i];
|
||||
// ServiceFactoryServer.AllowByName([MethodAuthorizationSettings.MethodName], MethodAuthorizationSettings.AllowedGroups); // not work for some reason :(
|
||||
// ServiceFactoryServer.DenyByName([MethodAuthorizationSettings.MethodName], MethodAuthorizationSettings.DeniedGroups);
|
||||
for j := 0 to Length(MethodAuthorizationSettings.AllowedGroups) - 1 do
|
||||
ServiceFactoryServer.AllowByName([MethodAuthorizationSettings.MethodName], MethodAuthorizationSettings.AllowedGroups[j]);
|
||||
for j := 0 to Length(MethodAuthorizationSettings.DeniedGroups) - 1 do
|
||||
ServiceFactoryServer.DenyByName([MethodAuthorizationSettings.MethodName], MethodAuthorizationSettings.DeniedGroups[j]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function tRestServer.Initialize(SrvSettings: TRestServerSettings): boolean;
|
||||
var
|
||||
ServiceFactoryServer: TServiceFactoryServer;
|
||||
{ WebSocketServerRest: TWebSocketServerRest; }
|
||||
begin
|
||||
Result := false;
|
||||
// Destroy current object
|
||||
if DeInitialize() then
|
||||
try
|
||||
// Server initialization (!!! for better understanding, each section contain separate code, later should be refactored)
|
||||
fServerSettings.Free;
|
||||
fServerSettings := SrvSettings;
|
||||
case fServerSettings.AuthenticationMode of
|
||||
// NoAuthentication
|
||||
NoAuthentication:
|
||||
begin
|
||||
fModel := TSQLModel.Create([], ROOT_NAME);
|
||||
fRestServer := TSQLRestServerFullMemory.Create(fModel, false);
|
||||
ServiceFactoryServer := fRestServer.ServiceDefine(TRestMethods, [IRestMethods], SERVICE_INSTANCE_IMPLEMENTATION);
|
||||
ServiceFactoryServer.SetOptions([], [optErrorOnMissingParam]);
|
||||
end;
|
||||
// TSQLRestServerAuthenticationDefault
|
||||
Default:
|
||||
begin
|
||||
fModel := TSQLModel.Create([], ROOT_NAME);
|
||||
fRestServer := TSQLRestServerFullMemory.Create(fModel, false { make AuthenticationSchemesCount = 0 } );
|
||||
ServiceFactoryServer := fRestServer.ServiceDefine(TRestMethods, [IRestMethods], SERVICE_INSTANCE_IMPLEMENTATION);
|
||||
fRestServer.AuthenticationRegister(TSQLRestServerAuthenticationDefault); // register single authentication mode
|
||||
ApplyAuthorizationRules(ServiceFactoryServer, fServerSettings);
|
||||
ServiceFactoryServer.SetOptions([], [optErrorOnMissingParam]);
|
||||
end;
|
||||
// TSQLRestServerAuthenticationNone
|
||||
None:
|
||||
begin
|
||||
fModel := TSQLModel.Create([], ROOT_NAME);
|
||||
fRestServer := TSQLRestServerFullMemory.Create(fModel, false { make AuthenticationSchemesCount = 0 } );
|
||||
ServiceFactoryServer := fRestServer.ServiceDefine(TRestMethods, [IRestMethods], SERVICE_INSTANCE_IMPLEMENTATION);
|
||||
fRestServer.AuthenticationRegister(TSQLRestServerAuthenticationNone); // register single authentication mode
|
||||
ApplyAuthorizationRules(ServiceFactoryServer, fServerSettings);
|
||||
ServiceFactoryServer.SetOptions([], [optErrorOnMissingParam]);
|
||||
end;
|
||||
// TSQLRestServerAuthenticationHttpBasic
|
||||
HttpBasic:
|
||||
begin
|
||||
fModel := TSQLModel.Create([], ROOT_NAME);
|
||||
fRestServer := TSQLRestServerFullMemory.Create(fModel, false { make AuthenticationSchemesCount = 0 } );
|
||||
ServiceFactoryServer := fRestServer.ServiceDefine(TRestMethods, [IRestMethods], SERVICE_INSTANCE_IMPLEMENTATION);
|
||||
fRestServer.AuthenticationRegister(TSQLRestServerAuthenticationHttpBasic); // register single authentication mode
|
||||
ApplyAuthorizationRules(ServiceFactoryServer, fServerSettings);
|
||||
ServiceFactoryServer.SetOptions([], [optErrorOnMissingParam]);
|
||||
end;
|
||||
// TSQLRestServerAuthenticationSSPI
|
||||
{$IFDEF MSWINDOWS}
|
||||
SSPI:
|
||||
begin
|
||||
fModel := TSQLModel.Create([], ROOT_NAME);
|
||||
fRestServer := TSQLRestServerFullMemory.Create(fModel, false { make AuthenticationSchemesCount = 0 } );
|
||||
ServiceFactoryServer := fRestServer.ServiceDefine(TRestMethods, [IRestMethods], SERVICE_INSTANCE_IMPLEMENTATION);
|
||||
fRestServer.AuthenticationRegister(TSQLRestServerAuthenticationSSPI); // register single authentication mode
|
||||
ApplyAuthorizationRules(ServiceFactoryServer, fServerSettings);
|
||||
ServiceFactoryServer.SetOptions([], [optErrorOnMissingParam]);
|
||||
end;
|
||||
{$endif}
|
||||
else
|
||||
begin
|
||||
DeInitialize();
|
||||
raise Exception.Create('Selected Authentication mode not available in this build.');
|
||||
end;
|
||||
end;
|
||||
// protocol initialization
|
||||
case fServerSettings.Protocol of
|
||||
HTTP_Socket:
|
||||
begin
|
||||
fHTTPServer := TSQLHttpServer.Create(AnsiString(fServerSettings.Port), [fRestServer], '+', useHttpSocket);
|
||||
THttpServer(fHTTPServer.HttpServer).ServerKeepAliveTimeOut := CONNECTION_TIMEOUT;
|
||||
end;
|
||||
{
|
||||
// require manual URI registration, we will not use this option in this test project, because this option
|
||||
// should be used with installation program that will unregister all used URIs during sofware uninstallation.
|
||||
HTTPsys:
|
||||
begin
|
||||
HTTPServer := TSQLHttpServer.Create(AnsiString(Options.Port), [RestServer], '+', useHttpApi);
|
||||
THttpServer(fHTTPServer.HttpServer).ServerKeepAliveTimeOut := SERVER_CONNECTION_TIMEOUT;
|
||||
end;
|
||||
}
|
||||
HTTPsys:
|
||||
begin
|
||||
fHTTPServer := TSQLHttpServer.Create(AnsiString(fServerSettings.Port), [fRestServer], '+', HTTP_DEFAULT_MODE);
|
||||
THttpServer(fHTTPServer.HttpServer).ServerKeepAliveTimeOut := CONNECTION_TIMEOUT;
|
||||
end;
|
||||
HTTPsys_SSL:
|
||||
begin
|
||||
fHTTPServer := TSQLHttpServer.Create(AnsiString(fServerSettings.Port), [fRestServer], '+', HTTP_DEFAULT_MODE, 32, TSQLHttpServerSecurity.secSSL);
|
||||
THttpServer(fHTTPServer.HttpServer).ServerKeepAliveTimeOut := CONNECTION_TIMEOUT;
|
||||
end;
|
||||
HTTPsys_AES:
|
||||
begin
|
||||
fHTTPServer := TSQLHttpServer.Create(AnsiString(fServerSettings.Port), [fRestServer], '+', HTTP_DEFAULT_MODE, 32, TSQLHttpServerSecurity.secSynShaAes);
|
||||
THttpServer(fHTTPServer.HttpServer).ServerKeepAliveTimeOut := CONNECTION_TIMEOUT;
|
||||
end;
|
||||
HTTP_WebSocket:
|
||||
begin
|
||||
fHTTPServer := TSQLHttpServer.Create(AnsiString(fServerSettings.Port), [fRestServer], '+', useBidirSocket);
|
||||
TWebSocketServerRest(fHTTPServer.HttpServer).ServerKeepAliveTimeOut := CONNECTION_TIMEOUT;
|
||||
end;
|
||||
WebSocketBidir_JSON:
|
||||
begin
|
||||
fHTTPServer := TSQLHttpServer.Create(AnsiString(fServerSettings.Port), [fRestServer], '+', useBidirSocket);
|
||||
TWebSocketServerRest(fHTTPServer.HttpServer).ServerKeepAliveTimeOut := CONNECTION_TIMEOUT;
|
||||
{ WebSocketServerRest := } fHTTPServer.WebSocketsEnable(fRestServer, '', True);
|
||||
end;
|
||||
WebSocketBidir_Binary:
|
||||
begin
|
||||
fHTTPServer := TSQLHttpServer.Create(AnsiString(fServerSettings.Port), [fRestServer], '+', useBidirSocket);
|
||||
TWebSocketServerRest(fHTTPServer.HttpServer).ServerKeepAliveTimeOut := CONNECTION_TIMEOUT;
|
||||
{ WebSocketServerRest := } fHTTPServer.WebSocketsEnable(fRestServer, '', false);
|
||||
end;
|
||||
WebSocketBidir_BinaryAES:
|
||||
begin
|
||||
fHTTPServer := TSQLHttpServer.Create(AnsiString(fServerSettings.Port), [fRestServer], '+', useBidirSocket);
|
||||
TWebSocketServerRest(fHTTPServer.HttpServer).ServerKeepAliveTimeOut := CONNECTION_TIMEOUT;
|
||||
{ WebSocketServerRest := } fHTTPServer.WebSocketsEnable(fRestServer, '2141D32ADAD54D9A9DB56000CC9A4A70', false);
|
||||
end;
|
||||
{$IFDEF MSWINDOWS}
|
||||
NamedPipe:
|
||||
begin
|
||||
if not fRestServer.ExportServerNamedPipe(NAMED_PIPE_NAME) then
|
||||
Exception.Create('Unable to register server with named pipe channel.');
|
||||
end;
|
||||
{$ENDIF}
|
||||
else
|
||||
begin
|
||||
DeInitialize();
|
||||
raise Exception.Create('Selected protocol not available in this build.');
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
except
|
||||
on E: Exception do
|
||||
begin
|
||||
ShowMessage(E.ToString);
|
||||
DeInitialize();
|
||||
end;
|
||||
end;
|
||||
fInitialized := Result;
|
||||
end;
|
||||
|
||||
function tRestServer.DeInitialize(): boolean;
|
||||
begin
|
||||
Result := True;
|
||||
try
|
||||
// if used HttpApiRegisteringURI then remove registration (require run as admin), but seems not work from here
|
||||
{$IFDEF MSWINDOWS}
|
||||
if Assigned(fHTTPServer) and (fHTTPServer.HttpServer.ClassType = THttpApiServer) then
|
||||
THttpApiServer(fHTTPServer.HttpServer).RemoveUrl(ROOT_NAME, fHTTPServer.Port, fServerSettings.Protocol = HTTPsys_SSL, '+');
|
||||
{$ENDIF}
|
||||
if Assigned(fHTTPServer) then
|
||||
FreeAndNil(fHTTPServer);
|
||||
if Assigned(fRestServer) then
|
||||
FreeAndNil(fRestServer);
|
||||
if Assigned(fModel) then
|
||||
FreeAndNil(fModel);
|
||||
fInitialized := false;
|
||||
except
|
||||
on E: Exception do
|
||||
begin
|
||||
ShowMessage(E.ToString);
|
||||
Result := false;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
|
||||
RestServer := tRestServer.Create();
|
||||
|
||||
finalization
|
||||
|
||||
if Assigned(RestServer) then
|
||||
FreeAndNil(RestServer);
|
||||
|
||||
end.
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,915 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
unit Generics.Hashes;
|
||||
|
||||
{$MODE DELPHI}{$H+}
|
||||
{$POINTERMATH ON}
|
||||
{$MACRO ON}
|
||||
{$COPERATORS ON}
|
||||
{$OVERFLOWCHECKS OFF}
|
||||
{$RANGECHECKS OFF}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
// Original version of Bob Jenkins Hash
|
||||
// http://burtleburtle.net/bob/c/lookup3.c
|
||||
function HashWord(
|
||||
AKey: PLongWord; //* the key, an array of uint32_t values */
|
||||
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
||||
AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */
|
||||
procedure HashWord2 (
|
||||
AKey: PLongWord; //* the key, an array of uint32_t values */
|
||||
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
||||
var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */
|
||||
var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */
|
||||
|
||||
function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32;
|
||||
procedure HashLittle2(
|
||||
AKey: Pointer; //* the key to hash */
|
||||
ALength: SizeInt; //* length of the key */
|
||||
var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */
|
||||
var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */
|
||||
|
||||
function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32;
|
||||
procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32);
|
||||
|
||||
// hash function from fstl
|
||||
function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
|
||||
// some other hashes
|
||||
// http://stackoverflow.com/questions/14409466/simple-hash-functions
|
||||
// http://www.partow.net/programming/hashfunctions/
|
||||
// http://en.wikipedia.org/wiki/List_of_hash_functions
|
||||
// http://www.cse.yorku.ca/~oz/hash.html
|
||||
|
||||
// https://code.google.com/p/hedgewars/source/browse/hedgewars/adler32.pas
|
||||
function Adler32(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
function sdbm(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
|
||||
implementation
|
||||
|
||||
function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
var
|
||||
i: Integer;
|
||||
ABuffer: PUInt8 absolute AKey;
|
||||
begin
|
||||
Result := 0;
|
||||
for i := 0 to ALength - 1 do
|
||||
Inc(Result,ABuffer[i]);
|
||||
end;
|
||||
|
||||
function Adler32(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
const
|
||||
MOD_ADLER = 65521;
|
||||
var
|
||||
ABuffer: PUInt8 absolute AKey;
|
||||
a: UInt32 = 1;
|
||||
b: UInt32 = 0;
|
||||
n: Integer;
|
||||
begin
|
||||
for n := 0 to ALength -1 do
|
||||
begin
|
||||
a := (a + ABuffer[n]) mod MOD_ADLER;
|
||||
b := (b + a) mod MOD_ADLER;
|
||||
end;
|
||||
Result := (b shl 16) or a;
|
||||
end;
|
||||
|
||||
function sdbm(AKey: Pointer; ALength: SizeInt): UInt32;
|
||||
var
|
||||
c: PUInt8 absolute AKey;
|
||||
i: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
c := AKey;
|
||||
for i := 0 to ALength - 1 do
|
||||
begin
|
||||
Result := c^ + (Result shl 6) + (Result shl 16) {%H-}- Result;
|
||||
Inc(c);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ BobJenkinsHash }
|
||||
|
||||
{$define mix_abc :=
|
||||
a -= c; a := a xor (((c)shl(4)) or ((c)shr(32-(4)))); c += b;
|
||||
b -= a; b := b xor (((a)shl(6)) or ((a)shr(32-(6)))); a += c;
|
||||
c -= b; c := c xor (((b)shl(8)) or ((b)shr(32-(8)))); b += a;
|
||||
a -= c; a := a xor (((c)shl(16)) or ((c)shr(32-(16)))); c += b;
|
||||
b -= a; b := b xor (((a)shl(19)) or ((a)shr(32-(19)))); a += c;
|
||||
c -= b; c := c xor (((b)shl(4)) or ((b)shr(32-(4)))); b += a
|
||||
}
|
||||
|
||||
{$define final_abc :=
|
||||
c := c xor b; c -= (((b)shl(14)) or ((b)shr(32-(14))));
|
||||
a := a xor c; a -= (((c)shl(11)) or ((c)shr(32-(11))));
|
||||
b := b xor a; b -= (((a)shl(25)) or ((a)shr(32-(25))));
|
||||
c := c xor b; c -= (((b)shl(16)) or ((b)shr(32-(16))));
|
||||
a := a xor c; a -= (((c)shl(4)) or ((c)shr(32-(4))));
|
||||
b := b xor a; b -= (((a)shl(14)) or ((a)shr(32-(14))));
|
||||
c := c xor b; c -= (((b)shl(24)) or ((b)shr(32-(24))))
|
||||
}
|
||||
|
||||
function HashWord(
|
||||
AKey: PLongWord; //* the key, an array of uint32_t values */
|
||||
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
||||
AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */
|
||||
var
|
||||
a,b,c: UInt32;
|
||||
label
|
||||
Case0, Case1, Case2, Case3;
|
||||
begin
|
||||
//* Set up the internal state */
|
||||
a := $DEADBEEF + (UInt32(ALength) shl 2) + AInitVal;
|
||||
b := a;
|
||||
c := b;
|
||||
|
||||
//*------------------------------------------------- handle most of the key */
|
||||
while ALength > 3 do
|
||||
begin
|
||||
a += AKey[0];
|
||||
b += AKey[1];
|
||||
c += AKey[2];
|
||||
mix_abc;
|
||||
ALength -= 3;
|
||||
AKey += 3;
|
||||
end;
|
||||
|
||||
//*------------------------------------------- handle the last 3 uint32_t's */
|
||||
case ALength of //* all the case statements fall through */
|
||||
3: goto Case3;
|
||||
2: goto Case2;
|
||||
1: goto Case1;
|
||||
0: goto Case0;
|
||||
end;
|
||||
Case3: c+=AKey[2];
|
||||
Case2: b+=AKey[1];
|
||||
Case1: a+=AKey[0];
|
||||
final_abc;
|
||||
Case0: //* case 0: nothing left to add */
|
||||
//*------------------------------------------------------ report the result */
|
||||
Result := c;
|
||||
end;
|
||||
|
||||
procedure HashWord2 (
|
||||
AKey: PLongWord; //* the key, an array of uint32_t values */
|
||||
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
||||
var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */
|
||||
var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */
|
||||
var
|
||||
a,b,c: UInt32;
|
||||
label
|
||||
Case0, Case1, Case2, Case3;
|
||||
begin
|
||||
//* Set up the internal state */
|
||||
a := $deadbeef + (UInt32(ALength shl 2)) + APrimaryHashAndInitVal;
|
||||
b := a;
|
||||
c := b;
|
||||
c += ASecondaryHashAndInitVal;
|
||||
|
||||
//*------------------------------------------------- handle most of the key */
|
||||
while ALength > 3 do
|
||||
begin
|
||||
a += AKey[0];
|
||||
b += AKey[1];
|
||||
c += AKey[2];
|
||||
mix_abc;
|
||||
ALength -= 3;
|
||||
AKey += 3;
|
||||
end;
|
||||
|
||||
//*------------------------------------------- handle the last 3 uint32_t's */
|
||||
case ALength of //* all the case statements fall through */
|
||||
3: goto Case3;
|
||||
2: goto Case2;
|
||||
1: goto Case1;
|
||||
0: goto Case0;
|
||||
end;
|
||||
Case3: c+=AKey[2];
|
||||
Case2: b+=AKey[1];
|
||||
Case1: a+=AKey[0];
|
||||
final_abc;
|
||||
Case0: //* case 0: nothing left to add */
|
||||
//*------------------------------------------------------ report the result */
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
end;
|
||||
|
||||
function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32;
|
||||
var
|
||||
a, b, c: UInt32;
|
||||
u: record case byte of
|
||||
0: (ptr: Pointer);
|
||||
1: (i: PtrUint);
|
||||
end absolute AKey;
|
||||
|
||||
k32: ^UInt32 absolute AKey;
|
||||
k16: ^UInt16 absolute AKey;
|
||||
k8: ^UInt8 absolute AKey;
|
||||
|
||||
label _10, _8, _6, _4, _2;
|
||||
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
||||
|
||||
begin
|
||||
a := $DEADBEEF + UInt32(ALength) + AInitVal;
|
||||
b := a;
|
||||
c := b;
|
||||
|
||||
{$IFDEF ENDIAN_LITTLE}
|
||||
if (u.i and $3) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k32[0];
|
||||
b += k32[1];
|
||||
c += k32[2];
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k32 += 3;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
||||
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
||||
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
||||
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
||||
8 : begin b += k32[1]; a += k32[0]; end;
|
||||
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
||||
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
||||
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
||||
4 : begin a += k32[0]; end;
|
||||
3 : begin a += k32[0] and $ffffff; end;
|
||||
2 : begin a += k32[0] and $ffff; end;
|
||||
1 : begin a += k32[0] and $ff; end;
|
||||
0 : Exit(c); // zero length strings require no mixing
|
||||
end
|
||||
end
|
||||
else
|
||||
if (u.i and $1) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k16[0] + (UInt32(k16[1]) shl 16);
|
||||
b += k16[2] + (UInt32(k16[3]) shl 16);
|
||||
c += k16[4] + (UInt32(k16[5]) shl 16);
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k16 += 6;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12:
|
||||
begin
|
||||
c+=k16[4]+((UInt32(k16[5])) shl 16);
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
11:
|
||||
begin
|
||||
c+=(UInt32(k8[10])) shl 16; //* fall through */
|
||||
goto _10;
|
||||
end;
|
||||
10:
|
||||
begin _10:
|
||||
c+=k16[4];
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
9 :
|
||||
begin
|
||||
c+=k8[8]; //* fall through */
|
||||
goto _8;
|
||||
end;
|
||||
8 :
|
||||
begin _8:
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
7 :
|
||||
begin
|
||||
b+=(UInt32(k8[6])) shl 16; //* fall through */
|
||||
goto _6;
|
||||
end;
|
||||
6 :
|
||||
begin _6:
|
||||
b+=k16[2];
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
5 :
|
||||
begin
|
||||
b+=k8[4]; //* fall through */
|
||||
goto _4;
|
||||
end;
|
||||
4 :
|
||||
begin _4:
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
3 :
|
||||
begin
|
||||
a+=(UInt32(k8[2])) shl 16; //* fall through */
|
||||
goto _2;
|
||||
end;
|
||||
2 :
|
||||
begin _2:
|
||||
a+=k16[0];
|
||||
end;
|
||||
1 :
|
||||
begin
|
||||
a+=k8[0];
|
||||
end;
|
||||
0 : Exit(c); //* zero length requires no mixing */
|
||||
end;
|
||||
end
|
||||
else
|
||||
{$ENDIF}
|
||||
begin
|
||||
while ALength > 12 do
|
||||
begin
|
||||
a += k8[0];
|
||||
a += (UInt32(k8[1])) shl 8;
|
||||
a += (UInt32(k8[2])) shl 16;
|
||||
a += (UInt32(k8[3])) shl 24;
|
||||
b += k8[4];
|
||||
b += (UInt32(k8[5])) shl 8;
|
||||
b += (UInt32(k8[6])) shl 16;
|
||||
b += (UInt32(k8[7])) shl 24;
|
||||
c += k8[8];
|
||||
c += (UInt32(k8[9])) shl 8;
|
||||
c += (UInt32(k8[10])) shl 16;
|
||||
c += (UInt32(k8[11])) shl 24;
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k8 += 12;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: goto Case12;
|
||||
11: goto Case11;
|
||||
10: goto Case10;
|
||||
9 : goto Case9;
|
||||
8 : goto Case8;
|
||||
7 : goto Case7;
|
||||
6 : goto Case6;
|
||||
5 : goto Case5;
|
||||
4 : goto Case4;
|
||||
3 : goto Case3;
|
||||
2 : goto Case2;
|
||||
1 : goto Case1;
|
||||
0 : Exit(c);
|
||||
end;
|
||||
|
||||
Case12: c+=(UInt32(k8[11])) shl 24;
|
||||
Case11: c+=(UInt32(k8[10])) shl 16;
|
||||
Case10: c+=(UInt32(k8[9])) shl 8;
|
||||
Case9: c+=k8[8];
|
||||
Case8: b+=(UInt32(k8[7])) shl 24;
|
||||
Case7: b+=(UInt32(k8[6])) shl 16;
|
||||
Case6: b+=(UInt32(k8[5])) shl 8;
|
||||
Case5: b+=k8[4];
|
||||
Case4: a+=(UInt32(k8[3])) shl 24;
|
||||
Case3: a+=(UInt32(k8[2])) shl 16;
|
||||
Case2: a+=(UInt32(k8[1])) shl 8;
|
||||
Case1: a+=k8[0];
|
||||
end;
|
||||
|
||||
final_abc;
|
||||
Result := c;
|
||||
end;
|
||||
|
||||
(*
|
||||
* hashlittle2: return 2 32-bit hash values
|
||||
*
|
||||
* This is identical to hashlittle(), except it returns two 32-bit hash
|
||||
* values instead of just one. This is good enough for hash table
|
||||
* lookup with 2^^64 buckets, or if you want a second hash if you're not
|
||||
* happy with the first, or if you want a probably-unique 64-bit ID for
|
||||
* the key. *pc is better mixed than *pb, so use *pc first. If you want
|
||||
* a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)".
|
||||
*)
|
||||
procedure HashLittle2(
|
||||
AKey: Pointer; //* the key to hash */
|
||||
ALength: SizeInt; //* length of the key */
|
||||
var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */
|
||||
var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */
|
||||
var
|
||||
a,b,c: UInt32;
|
||||
u: record case byte of
|
||||
0: (ptr: Pointer);
|
||||
1: (i: PtrUint);
|
||||
end absolute AKey;
|
||||
|
||||
k32: ^UInt32 absolute AKey;
|
||||
k16: ^UInt16 absolute AKey;
|
||||
k8: ^UInt8 absolute AKey;
|
||||
|
||||
label _10, _8, _6, _4, _2;
|
||||
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
||||
|
||||
begin
|
||||
//* Set up the internal state */
|
||||
a := $DEADBEEF + UInt32(ALength) + APrimaryHashAndInitVal;
|
||||
b := a;
|
||||
c := b;
|
||||
c += ASecondaryHashAndInitVal;
|
||||
|
||||
{$IFDEF ENDIAN_LITTLE}
|
||||
if (u.i and $3) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k32[0];
|
||||
b += k32[1];
|
||||
c += k32[2];
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k32 += 3;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
||||
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
||||
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
||||
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
||||
8 : begin b += k32[1]; a += k32[0]; end;
|
||||
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
||||
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
||||
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
||||
4 : begin a += k32[0]; end;
|
||||
3 : begin a += k32[0] and $ffffff; end;
|
||||
2 : begin a += k32[0] and $ffff; end;
|
||||
1 : begin a += k32[0] and $ff; end;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end
|
||||
end
|
||||
else
|
||||
if (u.i and $1) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k16[0] + (UInt32(k16[1]) shl 16);
|
||||
b += k16[2] + (UInt32(k16[3]) shl 16);
|
||||
c += k16[4] + (UInt32(k16[5]) shl 16);
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k16 += 6;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12:
|
||||
begin
|
||||
c+=k16[4]+((UInt32(k16[5])) shl 16);
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
11:
|
||||
begin
|
||||
c+=(UInt32(k8[10])) shl 16; //* fall through */
|
||||
goto _10;
|
||||
end;
|
||||
10:
|
||||
begin _10:
|
||||
c+=k16[4];
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
9 :
|
||||
begin
|
||||
c+=k8[8]; //* fall through */
|
||||
goto _8;
|
||||
end;
|
||||
8 :
|
||||
begin _8:
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
7 :
|
||||
begin
|
||||
b+=(UInt32(k8[6])) shl 16; //* fall through */
|
||||
goto _6;
|
||||
end;
|
||||
6 :
|
||||
begin _6:
|
||||
b+=k16[2];
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
5 :
|
||||
begin
|
||||
b+=k8[4]; //* fall through */
|
||||
goto _4;
|
||||
end;
|
||||
4 :
|
||||
begin _4:
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
3 :
|
||||
begin
|
||||
a+=(UInt32(k8[2])) shl 16; //* fall through */
|
||||
goto _2;
|
||||
end;
|
||||
2 :
|
||||
begin _2:
|
||||
a+=k16[0];
|
||||
end;
|
||||
1 :
|
||||
begin
|
||||
a+=k8[0];
|
||||
end;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
{$ENDIF}
|
||||
begin
|
||||
while ALength > 12 do
|
||||
begin
|
||||
a += k8[0];
|
||||
a += (UInt32(k8[1])) shl 8;
|
||||
a += (UInt32(k8[2])) shl 16;
|
||||
a += (UInt32(k8[3])) shl 24;
|
||||
b += k8[4];
|
||||
b += (UInt32(k8[5])) shl 8;
|
||||
b += (UInt32(k8[6])) shl 16;
|
||||
b += (UInt32(k8[7])) shl 24;
|
||||
c += k8[8];
|
||||
c += (UInt32(k8[9])) shl 8;
|
||||
c += (UInt32(k8[10])) shl 16;
|
||||
c += (UInt32(k8[11])) shl 24;
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k8 += 12;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: goto Case12;
|
||||
11: goto Case11;
|
||||
10: goto Case10;
|
||||
9 : goto Case9;
|
||||
8 : goto Case8;
|
||||
7 : goto Case7;
|
||||
6 : goto Case6;
|
||||
5 : goto Case5;
|
||||
4 : goto Case4;
|
||||
3 : goto Case3;
|
||||
2 : goto Case2;
|
||||
1 : goto Case1;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end;
|
||||
|
||||
Case12: c+=(UInt32(k8[11])) shl 24;
|
||||
Case11: c+=(UInt32(k8[10])) shl 16;
|
||||
Case10: c+=(UInt32(k8[9])) shl 8;
|
||||
Case9: c+=k8[8];
|
||||
Case8: b+=(UInt32(k8[7])) shl 24;
|
||||
Case7: b+=(UInt32(k8[6])) shl 16;
|
||||
Case6: b+=(UInt32(k8[5])) shl 8;
|
||||
Case5: b+=k8[4];
|
||||
Case4: a+=(UInt32(k8[3])) shl 24;
|
||||
Case3: a+=(UInt32(k8[2])) shl 16;
|
||||
Case2: a+=(UInt32(k8[1])) shl 8;
|
||||
Case1: a+=k8[0];
|
||||
end;
|
||||
|
||||
final_abc;
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
end;
|
||||
|
||||
procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32);
|
||||
var
|
||||
a,b,c: UInt32;
|
||||
u: record case byte of
|
||||
0: (ptr: Pointer);
|
||||
1: (i: PtrUint);
|
||||
end absolute AKey;
|
||||
|
||||
k32: ^UInt32 absolute AKey;
|
||||
k16: ^UInt16 absolute AKey;
|
||||
k8: ^UInt8 absolute AKey;
|
||||
|
||||
label _10, _8, _6, _4, _2;
|
||||
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
||||
|
||||
begin
|
||||
//* Set up the internal state */
|
||||
a := $DEADBEEF + UInt32(ALength shl 2) + APrimaryHashAndInitVal; // delphi version bug? original version don't have "shl 2"
|
||||
b := a;
|
||||
c := b;
|
||||
c += ASecondaryHashAndInitVal;
|
||||
|
||||
{$IFDEF ENDIAN_LITTLE}
|
||||
if (u.i and $3) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k32[0];
|
||||
b += k32[1];
|
||||
c += k32[2];
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k32 += 3;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
||||
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
||||
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
||||
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
||||
8 : begin b += k32[1]; a += k32[0]; end;
|
||||
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
||||
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
||||
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
||||
4 : begin a += k32[0]; end;
|
||||
3 : begin a += k32[0] and $ffffff; end;
|
||||
2 : begin a += k32[0] and $ffff; end;
|
||||
1 : begin a += k32[0] and $ff; end;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end
|
||||
end
|
||||
else
|
||||
if (u.i and $1) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k16[0] + (UInt32(k16[1]) shl 16);
|
||||
b += k16[2] + (UInt32(k16[3]) shl 16);
|
||||
c += k16[4] + (UInt32(k16[5]) shl 16);
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k16 += 6;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12:
|
||||
begin
|
||||
c+=k16[4]+((UInt32(k16[5])) shl 16);
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
11:
|
||||
begin
|
||||
c+=(UInt32(k8[10])) shl 16; //* fall through */
|
||||
goto _10;
|
||||
end;
|
||||
10:
|
||||
begin _10:
|
||||
c+=k16[4];
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
9 :
|
||||
begin
|
||||
c+=k8[8]; //* fall through */
|
||||
goto _8;
|
||||
end;
|
||||
8 :
|
||||
begin _8:
|
||||
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
7 :
|
||||
begin
|
||||
b+=(UInt32(k8[6])) shl 16; //* fall through */
|
||||
goto _6;
|
||||
end;
|
||||
6 :
|
||||
begin _6:
|
||||
b+=k16[2];
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
5 :
|
||||
begin
|
||||
b+=k8[4]; //* fall through */
|
||||
goto _4;
|
||||
end;
|
||||
4 :
|
||||
begin _4:
|
||||
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
||||
end;
|
||||
3 :
|
||||
begin
|
||||
a+=(UInt32(k8[2])) shl 16; //* fall through */
|
||||
goto _2;
|
||||
end;
|
||||
2 :
|
||||
begin _2:
|
||||
a+=k16[0];
|
||||
end;
|
||||
1 :
|
||||
begin
|
||||
a+=k8[0];
|
||||
end;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
{$ENDIF}
|
||||
begin
|
||||
while ALength > 12 do
|
||||
begin
|
||||
a += k8[0];
|
||||
a += (UInt32(k8[1])) shl 8;
|
||||
a += (UInt32(k8[2])) shl 16;
|
||||
a += (UInt32(k8[3])) shl 24;
|
||||
b += k8[4];
|
||||
b += (UInt32(k8[5])) shl 8;
|
||||
b += (UInt32(k8[6])) shl 16;
|
||||
b += (UInt32(k8[7])) shl 24;
|
||||
c += k8[8];
|
||||
c += (UInt32(k8[9])) shl 8;
|
||||
c += (UInt32(k8[10])) shl 16;
|
||||
c += (UInt32(k8[11])) shl 24;
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k8 += 12;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: goto Case12;
|
||||
11: goto Case11;
|
||||
10: goto Case10;
|
||||
9 : goto Case9;
|
||||
8 : goto Case8;
|
||||
7 : goto Case7;
|
||||
6 : goto Case6;
|
||||
5 : goto Case5;
|
||||
4 : goto Case4;
|
||||
3 : goto Case3;
|
||||
2 : goto Case2;
|
||||
1 : goto Case1;
|
||||
0 :
|
||||
begin
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
Exit; // zero length strings require no mixing
|
||||
end;
|
||||
end;
|
||||
|
||||
Case12: c+=(UInt32(k8[11])) shl 24;
|
||||
Case11: c+=(UInt32(k8[10])) shl 16;
|
||||
Case10: c+=(UInt32(k8[9])) shl 8;
|
||||
Case9: c+=k8[8];
|
||||
Case8: b+=(UInt32(k8[7])) shl 24;
|
||||
Case7: b+=(UInt32(k8[6])) shl 16;
|
||||
Case6: b+=(UInt32(k8[5])) shl 8;
|
||||
Case5: b+=k8[4];
|
||||
Case4: a+=(UInt32(k8[3])) shl 24;
|
||||
Case3: a+=(UInt32(k8[2])) shl 16;
|
||||
Case2: a+=(UInt32(k8[1])) shl 8;
|
||||
Case1: a+=k8[0];
|
||||
end;
|
||||
|
||||
final_abc;
|
||||
APrimaryHashAndInitVal := c;
|
||||
ASecondaryHashAndInitVal := b;
|
||||
end;
|
||||
|
||||
function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32;
|
||||
var
|
||||
a, b, c: UInt32;
|
||||
u: record case byte of
|
||||
0: (ptr: Pointer);
|
||||
1: (i: PtrUint);
|
||||
end absolute AKey;
|
||||
|
||||
k32: ^UInt32 absolute AKey;
|
||||
//k16: ^UInt16 absolute AKey;
|
||||
k8: ^UInt8 absolute AKey;
|
||||
|
||||
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
||||
|
||||
begin
|
||||
a := $DEADBEEF + UInt32(ALength shl 2) + AInitVal; // delphi version bug? original version don't have "shl 2"
|
||||
b := a;
|
||||
c := b;
|
||||
|
||||
{.$IFDEF ENDIAN_LITTLE} // Delphi version don't care
|
||||
if (u.i and $3) = 0 then
|
||||
begin
|
||||
while (ALength > 12) do
|
||||
begin
|
||||
a += k32[0];
|
||||
b += k32[1];
|
||||
c += k32[2];
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k32 += 3;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
||||
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
||||
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
||||
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
||||
8 : begin b += k32[1]; a += k32[0]; end;
|
||||
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
||||
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
||||
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
||||
4 : begin a += k32[0]; end;
|
||||
3 : begin a += k32[0] and $ffffff; end;
|
||||
2 : begin a += k32[0] and $ffff; end;
|
||||
1 : begin a += k32[0] and $ff; end;
|
||||
0 : Exit(c); // zero length strings require no mixing
|
||||
end
|
||||
end
|
||||
else
|
||||
{.$ENDIF}
|
||||
begin
|
||||
while ALength > 12 do
|
||||
begin
|
||||
a += k8[0];
|
||||
a += (UInt32(k8[1])) shl 8;
|
||||
a += (UInt32(k8[2])) shl 16;
|
||||
a += (UInt32(k8[3])) shl 24;
|
||||
b += k8[4];
|
||||
b += (UInt32(k8[5])) shl 8;
|
||||
b += (UInt32(k8[6])) shl 16;
|
||||
b += (UInt32(k8[7])) shl 24;
|
||||
c += k8[8];
|
||||
c += (UInt32(k8[9])) shl 8;
|
||||
c += (UInt32(k8[10])) shl 16;
|
||||
c += (UInt32(k8[11])) shl 24;
|
||||
mix_abc;
|
||||
ALength -= 12;
|
||||
k8 += 12;
|
||||
end;
|
||||
|
||||
case ALength of
|
||||
12: goto Case12;
|
||||
11: goto Case11;
|
||||
10: goto Case10;
|
||||
9 : goto Case9;
|
||||
8 : goto Case8;
|
||||
7 : goto Case7;
|
||||
6 : goto Case6;
|
||||
5 : goto Case5;
|
||||
4 : goto Case4;
|
||||
3 : goto Case3;
|
||||
2 : goto Case2;
|
||||
1 : goto Case1;
|
||||
0 : Exit(c);
|
||||
end;
|
||||
|
||||
Case12: c+=(UInt32(k8[11])) shl 24;
|
||||
Case11: c+=(UInt32(k8[10])) shl 16;
|
||||
Case10: c+=(UInt32(k8[9])) shl 8;
|
||||
Case9: c+=k8[8];
|
||||
Case8: b+=(UInt32(k8[7])) shl 24;
|
||||
Case7: b+=(UInt32(k8[6])) shl 16;
|
||||
Case6: b+=(UInt32(k8[5])) shl 8;
|
||||
Case5: b+=k8[4];
|
||||
Case4: a+=(UInt32(k8[3])) shl 24;
|
||||
Case3: a+=(UInt32(k8[2])) shl 16;
|
||||
Case2: a+=(UInt32(k8[1])) shl 8;
|
||||
Case1: a+=k8[0];
|
||||
end;
|
||||
|
||||
final_abc;
|
||||
Result := Int32(c);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,144 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
unit Generics.Helpers;
|
||||
|
||||
{$MODE DELPHI}{$H+}
|
||||
{$MODESWITCH TYPEHELPERS}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
type
|
||||
{ TValueAnsiStringHelper }
|
||||
|
||||
TValueAnsiStringHelper = record helper for AnsiString
|
||||
function ToLower: AnsiString; inline;
|
||||
end;
|
||||
|
||||
{ TValuewideStringHelper }
|
||||
|
||||
TValueWideStringHelper = record helper for WideString
|
||||
function ToLower: WideString; inline;
|
||||
end;
|
||||
|
||||
{ TValueUnicodeStringHelper }
|
||||
|
||||
TValueUnicodeStringHelper = record helper for UnicodeString
|
||||
function ToLower: UnicodeString; inline;
|
||||
end;
|
||||
|
||||
{ TValueShortStringHelper }
|
||||
|
||||
TValueShortStringHelper = record helper for ShortString
|
||||
function ToLower: ShortString; inline;
|
||||
end;
|
||||
|
||||
{ TValueUTF8StringHelper }
|
||||
|
||||
TValueUTF8StringHelper = record helper for UTF8String
|
||||
function ToLower: UTF8String; inline;
|
||||
end;
|
||||
|
||||
{ TValueRawByteStringHelper }
|
||||
|
||||
TValueRawByteStringHelper = record helper for RawByteString
|
||||
function ToLower: RawByteString; inline;
|
||||
end;
|
||||
|
||||
{ TValueUInt32Helper }
|
||||
|
||||
TValueUInt32Helper = record helper for UInt32
|
||||
class function GetSignMask: UInt32; static; inline;
|
||||
class function GetSizedSignMask(ABits: Byte): UInt32; static; inline;
|
||||
class function GetBitsLength: Byte; static; inline;
|
||||
|
||||
const
|
||||
SIZED_SIGN_MASK: array[1..32] of UInt32 = (
|
||||
$80000000, $C0000000, $E0000000, $F0000000, $F8000000, $FC000000, $FE000000, $FF000000,
|
||||
$FF800000, $FFC00000, $FFE00000, $FFF00000, $FFF80000, $FFFC0000, $FFFE0000, $FFFF0000,
|
||||
$FFFF8000, $FFFFC000, $FFFFE000, $FFFFF000, $FFFFF800, $FFFFFC00, $FFFFFE00, $FFFFFF00,
|
||||
$FFFFFF80, $FFFFFFC0, $FFFFFFE0, $FFFFFFF0, $FFFFFFF8, $FFFFFFFC, $FFFFFFFE, $FFFFFFFF);
|
||||
BITS_LENGTH = 32;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TRawDataStringHelper }
|
||||
|
||||
function TValueAnsiStringHelper.ToLower: AnsiString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueWideStringHelper }
|
||||
|
||||
function TValueWideStringHelper.ToLower: WideString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueUnicodeStringHelper }
|
||||
|
||||
function TValueUnicodeStringHelper.ToLower: UnicodeString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueShortStringHelper }
|
||||
|
||||
function TValueShortStringHelper.ToLower: ShortString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueUTF8StringHelper }
|
||||
|
||||
function TValueUTF8StringHelper.ToLower: UTF8String;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueRawByteStringHelper }
|
||||
|
||||
function TValueRawByteStringHelper.ToLower: RawByteString;
|
||||
begin
|
||||
Result := LowerCase(Self);
|
||||
end;
|
||||
|
||||
{ TValueUInt32Helper }
|
||||
|
||||
class function TValueUInt32Helper.GetSignMask: UInt32;
|
||||
begin
|
||||
Result := $80000000;
|
||||
end;
|
||||
|
||||
class function TValueUInt32Helper.GetSizedSignMask(ABits: Byte): UInt32;
|
||||
begin
|
||||
Result := SIZED_SIGN_MASK[ABits];
|
||||
end;
|
||||
|
||||
class function TValueUInt32Helper.GetBitsLength: Byte;
|
||||
begin
|
||||
Result := BITS_LENGTH;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,236 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
unit Generics.MemoryExpanders;
|
||||
// Memory expanders
|
||||
|
||||
{$mode delphi}
|
||||
{$MACRO ON}
|
||||
{.$WARN 5024 OFF}
|
||||
{.$WARN 4079 OFF}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
type
|
||||
TProbeSequence = class
|
||||
public
|
||||
end;
|
||||
|
||||
{ TLinearProbing }
|
||||
|
||||
TLinearProbing = class(TProbeSequence)
|
||||
public
|
||||
class function Probe(I, {%H-}M, Hash: UInt32): UInt32; static; inline;
|
||||
|
||||
const MAX_LOAD_FACTOR = 1;
|
||||
const DEFAULT_LOAD_FACTOR = 0.75;
|
||||
end;
|
||||
|
||||
{ TQuadraticProbing }
|
||||
|
||||
TQuadraticProbing = class(TProbeSequence)
|
||||
private
|
||||
class constructor Create;
|
||||
public
|
||||
class var C1: UInt32;
|
||||
class var C2: UInt32;
|
||||
|
||||
class function Probe(I, {%H-}M, Hash: UInt32): UInt32; static; inline;
|
||||
|
||||
const MAX_LOAD_FACTOR = 0.5;
|
||||
const DEFAULT_LOAD_FACTOR = 0.5;
|
||||
end;
|
||||
|
||||
{ TDoubleHashing }
|
||||
|
||||
TDoubleHashing = class(TProbeSequence)
|
||||
public
|
||||
class function Probe(I, {%H-}M, Hash1: UInt32; Hash2: UInt32 = 1): UInt32; static; inline;
|
||||
|
||||
const MAX_LOAD_FACTOR = 1;
|
||||
const DEFAULT_LOAD_FACTOR = 0.85;
|
||||
end;
|
||||
|
||||
const
|
||||
// http://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
|
||||
// MultiplyDeBruijnBitPosition[uint32(((numberInt32 and -numberInt32) * $077CB531)) shr 27]
|
||||
MultiplyDeBruijnBitPosition: array[0..31] of Int32 =
|
||||
(
|
||||
0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,
|
||||
31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
|
||||
);
|
||||
|
||||
// http://primes.utm.edu/lists/2small/0bit.html
|
||||
// http://www.math.niu.edu/~rusin/known-math/98/pi_x
|
||||
// http://oeis.org/A014234/
|
||||
PrimaryNumbersJustLessThanPowerOfTwo: array[0..31] of UInt32 =
|
||||
(
|
||||
0, 1, 3, 7, 13, 31, 61, 127, 251, 509, 1021, 2039, 4093, 8191, 16381, 32749, 65521, 131071,
|
||||
262139, 524287, 1048573, 2097143, 4194301, 8388593, 16777213, 33554393, 67108859,
|
||||
134217689, 268435399, 536870909, 1073741789, 2147483647
|
||||
);
|
||||
|
||||
// http://oeis.org/A014210
|
||||
// http://oeis.org/A203074
|
||||
PrimaryNumbersJustBiggerThanPowerOfTwo: array[0..31] of UInt32 = (
|
||||
2,3,5,11,17,37,67,131,257,521,1031,2053,4099,
|
||||
8209,16411,32771,65537,131101,262147,524309,
|
||||
1048583,2097169,4194319,8388617,16777259,33554467,
|
||||
67108879,134217757,268435459,536870923,1073741827,
|
||||
2147483659);
|
||||
|
||||
// Fibonacci numbers
|
||||
FibonacciNumbers: array[0..44] of UInt32 = (
|
||||
{0,1,1,2,3,}0,5,8,13,21,34,55,89,144,233,377,610,987,
|
||||
1597,2584,4181,6765,10946,17711,28657,46368,75025,
|
||||
121393,196418,317811,514229,832040,1346269,
|
||||
2178309,3524578,5702887,9227465,14930352,24157817,
|
||||
39088169, 63245986, 102334155, 165580141, 267914296,
|
||||
433494437, 701408733, 1134903170, 1836311903, 2971215073,
|
||||
{! not fib number - this is memory limit} 4294967295);
|
||||
|
||||
// Largest prime not exceeding Fibonacci(n)
|
||||
// http://oeis.org/A138184/list
|
||||
// http://www.numberempire.com/primenumbers.php
|
||||
PrimaryNumbersJustLessThanFibonacciNumbers: array[0..44] of UInt32 = (
|
||||
{! not correlated to fib number. For empty table} 0,
|
||||
5,7,13,19,31,53,89,139,233,373,607,983,1597,
|
||||
2579,4177,6763,10939,17707,28657,46351,75017,
|
||||
121379,196387,317797,514229,832003,1346249,
|
||||
2178283,3524569,5702867,9227443,14930341,24157811,
|
||||
39088157,63245971,102334123,165580123,267914279,
|
||||
433494437,701408717,1134903127,1836311879,2971215073,
|
||||
{! not correlated to fib number - this is prime memory limit} 4294967291);
|
||||
|
||||
// Smallest prime >= n-th Fibonacci number.
|
||||
// http://oeis.org/A138185
|
||||
PrimaryNumbersJustBiggerThanFibonacciNumbers: array[0..44] of UInt32 = (
|
||||
{! not correlated to fib number. For empty table} 0,
|
||||
5,11,13,23,37,59,89,149,233,379,613,
|
||||
991,1597,2591,4201,6779,10949,17713,28657,46381,
|
||||
75029,121403,196429,317827,514229,832063,1346273,
|
||||
2178313,3524603,5702897,9227479,14930387,24157823,
|
||||
39088193,63245989,102334157,165580147,267914303,
|
||||
433494437,701408753,1134903179,1836311951,2971215073,
|
||||
{! not correlated to fib number - this is prime memory limit} 4294967291);
|
||||
|
||||
type
|
||||
|
||||
{ TCuckooHashingCfg }
|
||||
|
||||
TCuckooHashingCfg = class
|
||||
public
|
||||
const D = 2;
|
||||
const MAX_LOAD_FACTOR = 0.5;
|
||||
|
||||
class function LoadFactor(M: Integer): Integer; virtual;
|
||||
end;
|
||||
|
||||
TStdCuckooHashingCfg = class(TCuckooHashingCfg)
|
||||
public
|
||||
const MAX_LOOP = 1000;
|
||||
end;
|
||||
|
||||
TDeamortizedCuckooHashingCfg = class(TCuckooHashingCfg)
|
||||
public
|
||||
const L = 5;
|
||||
end;
|
||||
|
||||
TDeamortizedCuckooHashingCfg_D2 = TDeamortizedCuckooHashingCfg;
|
||||
|
||||
{ TDeamortizedCuckooHashingCfg_D4 }
|
||||
|
||||
TDeamortizedCuckooHashingCfg_D4 = class(TDeamortizedCuckooHashingCfg)
|
||||
public
|
||||
const D = 4;
|
||||
const L = 20;
|
||||
const MAX_LOAD_FACTOR = 0.9;
|
||||
|
||||
class function LoadFactor(M: Integer): Integer; override;
|
||||
end;
|
||||
|
||||
{ TDeamortizedCuckooHashingCfg_D6 }
|
||||
|
||||
TDeamortizedCuckooHashingCfg_D6 = class(TDeamortizedCuckooHashingCfg)
|
||||
public
|
||||
const D = 6;
|
||||
const L = 170;
|
||||
const MAX_LOAD_FACTOR = 0.99;
|
||||
|
||||
class function LoadFactor(M: Integer): Integer; override;
|
||||
end;
|
||||
|
||||
TL5CuckooHashingCfg = class(TCuckooHashingCfg)
|
||||
public
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TDeamortizedCuckooHashingCfg_D6 }
|
||||
|
||||
class function TDeamortizedCuckooHashingCfg_D6.LoadFactor(M: Integer): Integer;
|
||||
begin
|
||||
Result:=Pred(Round(MAX_LOAD_FACTOR*M));
|
||||
end;
|
||||
|
||||
{ TDeamortizedCuckooHashingCfg_D4 }
|
||||
|
||||
class function TDeamortizedCuckooHashingCfg_D4.LoadFactor(M: Integer): Integer;
|
||||
begin
|
||||
Result:=Pred(Round(MAX_LOAD_FACTOR*M));
|
||||
end;
|
||||
|
||||
{ TCuckooHashingCfg }
|
||||
|
||||
class function TCuckooHashingCfg.LoadFactor(M: Integer): Integer;
|
||||
begin
|
||||
Result := Pred(M shr 1);
|
||||
end;
|
||||
|
||||
{ TLinearProbing }
|
||||
|
||||
class function TLinearProbing.Probe(I, M, Hash: UInt32): UInt32;
|
||||
begin
|
||||
Result := (Hash + I)
|
||||
end;
|
||||
|
||||
{ TQuadraticProbing }
|
||||
|
||||
class constructor TQuadraticProbing.Create;
|
||||
begin
|
||||
C1 := 1;
|
||||
C2 := 1;
|
||||
end;
|
||||
|
||||
class function TQuadraticProbing.Probe(I, M, Hash: UInt32): UInt32;
|
||||
begin
|
||||
Result := (Hash + C1 * I {%H-}+ C2 * Sqr(I));
|
||||
end;
|
||||
|
||||
{ TDoubleHashingNoMod }
|
||||
|
||||
class function TDoubleHashing.Probe(I, M, Hash1: UInt32; Hash2: UInt32): UInt32;
|
||||
begin
|
||||
Result := Hash1 + I * Hash2;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,34 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
unit Generics.Strings;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
resourcestring
|
||||
SArgumentOutOfRange = 'Argument out of range';
|
||||
SDuplicatesNotAllowed = 'Duplicates not allowed in dictionary';
|
||||
SDictionaryKeyDoesNotExist = 'Dictionary key does not exist';
|
||||
SItemNotFound = 'Item not found';
|
||||
|
||||
implementation
|
||||
|
||||
end.
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,533 @@
|
||||
{%MainUnit generics.collections.pas}
|
||||
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2014 by Maciej Izak (hnb)
|
||||
member of the Free Sparta development team (http://freesparta.com)
|
||||
|
||||
Copyright(c) 2004-2014 DaThoX
|
||||
|
||||
It contains the Free Pascal generics library
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{$WARNINGS OFF}
|
||||
type
|
||||
TEmptyRecord = record // special record for Dictionary TValue (Dictionary as Set)
|
||||
end;
|
||||
|
||||
{ TPair }
|
||||
|
||||
TPair<TKey, TValue> = record
|
||||
public
|
||||
Key: TKey;
|
||||
Value: TValue;
|
||||
class function Create(AKey: TKey; AValue: TValue): TPair<TKey, TValue>; static;
|
||||
end;
|
||||
|
||||
{ TCustomDictionary }
|
||||
|
||||
// bug #24283 and #24097 (forward declaration) - should be:
|
||||
// TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS> = class(TEnumerable<TPair<TKey, TValue> >);
|
||||
TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract
|
||||
public type
|
||||
// workaround... no generics types in generics types
|
||||
TDictionaryPair = TPair<TKey, TValue>;
|
||||
PDictionaryPair = ^TDictionaryPair;
|
||||
PKey = ^TKey;
|
||||
PValue = ^TValue;
|
||||
THashFactoryClass = THashFactory;
|
||||
public
|
||||
FItemsLength: SizeInt;
|
||||
FEqualityComparer: IEqualityComparer<TKey>;
|
||||
FKeys: TEnumerable<TKey>;
|
||||
FValues: TEnumerable<TValue>;
|
||||
FMaxLoadFactor: single;
|
||||
protected
|
||||
procedure SetCapacity(ACapacity: SizeInt); virtual; abstract;
|
||||
// bug #24283. workaround for this class because can't inherit from TEnumerable
|
||||
function DoGetEnumerator: TEnumerator<TDictionaryPair>; virtual; abstract; {override;}
|
||||
|
||||
procedure SetMaxLoadFactor(AValue: single); virtual; abstract;
|
||||
function GetLoadFactor: single; virtual; abstract;
|
||||
function GetCapacity: SizeInt; virtual; abstract;
|
||||
public
|
||||
property MaxLoadFactor: single read FMaxLoadFactor write SetMaxLoadFactor;
|
||||
property LoadFactor: single read GetLoadFactor;
|
||||
property Capacity: SizeInt read GetCapacity write SetCapacity;
|
||||
|
||||
property Count: SizeInt read FItemsLength;
|
||||
|
||||
procedure Clear; virtual; abstract;
|
||||
procedure Add(constref APair: TPair<TKey, TValue>); virtual; abstract;
|
||||
strict private // bug #24283. workaround for this class because can't inherit from TEnumerable
|
||||
function ToArray(ACount: SizeInt): TArray<TDictionaryPair>; overload;
|
||||
public
|
||||
function ToArray: TArray<TDictionaryPair>; virtual; final; {override; final; // bug #24283} overload;
|
||||
|
||||
constructor Create; virtual; overload;
|
||||
constructor Create(ACapacity: SizeInt); virtual; overload;
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); virtual; overload;
|
||||
constructor Create(const AComparer: IEqualityComparer<TKey>); overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>); virtual; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); virtual; overload;
|
||||
|
||||
destructor Destroy; override;
|
||||
private
|
||||
FOnKeyNotify: TCollectionNotifyEvent<TKey>;
|
||||
FOnValueNotify: TCollectionNotifyEvent<TValue>;
|
||||
protected
|
||||
procedure UpdateItemsThreshold(ASize: SizeInt); virtual; abstract;
|
||||
|
||||
procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); virtual;
|
||||
procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); virtual;
|
||||
procedure PairNotify(constref APair: TPair<TKey, TValue>; ACollectionNotification: TCollectionNotification); inline;
|
||||
procedure SetValue(var AValue: TValue; constref ANewValue: TValue);
|
||||
public
|
||||
property OnKeyNotify: TCollectionNotifyEvent<TKey> read FOnKeyNotify write FOnKeyNotify;
|
||||
property OnValueNotify: TCollectionNotifyEvent<TValue> read FOnValueNotify write FOnValueNotify;
|
||||
end;
|
||||
|
||||
{ TCustomDictionaryEnumerator }
|
||||
|
||||
TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract(TEnumerator< T >)
|
||||
private
|
||||
FDictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>;
|
||||
FIndex: SizeInt;
|
||||
protected
|
||||
function DoGetCurrent: T; override;
|
||||
function GetCurrent: T; virtual; abstract;
|
||||
public
|
||||
constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
end;
|
||||
|
||||
{ TDictionaryEnumerable }
|
||||
|
||||
TDictionaryEnumerable<TDictionaryEnumerator: TObject; // ... inherits from TCustomDictionaryEnumerator. workaround...
|
||||
T, CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract(TEnumerable<T>)
|
||||
private
|
||||
FDictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>;
|
||||
function GetCount: SizeInt;
|
||||
public
|
||||
constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
function DoGetEnumerator: TDictionaryEnumerator; override;
|
||||
function ToArray: TArray<T>; override; final;
|
||||
property Count: SizeInt read GetCount;
|
||||
end;
|
||||
|
||||
// more info : http://en.wikipedia.org/wiki/Open_addressing
|
||||
|
||||
{ TDictionaryEnumerable }
|
||||
|
||||
TOpenAddressingEnumerator<T, OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>)
|
||||
protected
|
||||
function DoMoveNext: Boolean; override;
|
||||
end;
|
||||
|
||||
TOnGetMemoryLayoutKeyPosition = procedure(Sender: TObject; AKeyPos: UInt32) of object;
|
||||
|
||||
TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>)
|
||||
private type
|
||||
PItem = ^TItem;
|
||||
TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
|
||||
TItemsArray = array of TItem;
|
||||
private var
|
||||
FItemsThreshold: SizeInt;
|
||||
FItems: TItemsArray;
|
||||
|
||||
procedure Resize(ANewSize: SizeInt);
|
||||
function PrepareAddingItem: SizeInt;
|
||||
protected
|
||||
function RealItemsLength: SizeInt; virtual;
|
||||
function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): boolean; virtual;
|
||||
function FindBucketIndex(constref AKey: TKey): SizeInt; overload; inline;
|
||||
function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey; out AHash: UInt32): SizeInt; virtual; abstract; overload;
|
||||
public
|
||||
type
|
||||
// Enumerators
|
||||
TPairEnumerator = class(TOpenAddressingEnumerator<TDictionaryPair, OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TPair<TKey,TValue>; override;
|
||||
end;
|
||||
|
||||
TValueEnumerator = class(TOpenAddressingEnumerator<TValue, OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TValue; override;
|
||||
end;
|
||||
|
||||
TKeyEnumerator = class(TOpenAddressingEnumerator<TKey, OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TKey; override;
|
||||
end;
|
||||
|
||||
// Collections
|
||||
TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
|
||||
TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
|
||||
// bug #24283 - workaround related to lack of DoGetEnumerator
|
||||
function GetEnumerator: TPairEnumerator; reintroduce;
|
||||
private
|
||||
function GetKeys: TKeyCollection;
|
||||
function GetValues: TValueCollection;
|
||||
private
|
||||
function GetItem(const AKey: TKey): TValue; inline;
|
||||
procedure SetItem(const AKey: TKey; const AValue: TValue); inline;
|
||||
procedure AddItem(var AItem: TItem; constref AKey: TKey; constref AValue: TValue; const AHash: UInt32); inline;
|
||||
protected
|
||||
// useful for using dictionary as array
|
||||
function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; virtual;
|
||||
function DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; virtual;
|
||||
|
||||
procedure UpdateItemsThreshold(ASize: SizeInt); override;
|
||||
|
||||
procedure SetCapacity(ACapacity: SizeInt); override;
|
||||
// bug #24283 - can't descadent from TEnumerable
|
||||
function DoGetEnumerator: TEnumerator<TDictionaryPair>; override;
|
||||
procedure SetMaxLoadFactor(AValue: single); override;
|
||||
function GetLoadFactor: single; override;
|
||||
function GetCapacity: SizeInt; override;
|
||||
public
|
||||
// many constructors because bug #25607
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
|
||||
procedure Add(constref APair: TPair<TKey, TValue>); override; overload;
|
||||
procedure Add(constref AKey: TKey; constref AValue: TValue); overload; inline;
|
||||
procedure Remove(constref AKey: TKey);
|
||||
function ExtractPair(constref AKey: TKey): TPair<TKey, TValue>;
|
||||
procedure Clear; override;
|
||||
procedure TrimExcess;
|
||||
function TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean;
|
||||
procedure AddOrSetValue(constref AKey: TKey; constref AValue: TValue);
|
||||
function ContainsKey(constref AKey: TKey): Boolean; inline;
|
||||
function ContainsValue(constref AValue: TValue): Boolean; overload;
|
||||
function ContainsValue(constref AValue: TValue; const AEqualityComparer: IEqualityComparer<TValue>): Boolean; virtual; overload;
|
||||
|
||||
property Items[Index: TKey]: TValue read GetItem write SetItem; default;
|
||||
property Keys: TKeyCollection read GetKeys;
|
||||
property Values: TValueCollection read GetValues;
|
||||
|
||||
procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition);
|
||||
end;
|
||||
|
||||
TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
_TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
protected
|
||||
procedure NotifyIndexChange(AFrom, ATo: SizeInt); virtual;
|
||||
function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; override;
|
||||
function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey; out AHash: UInt32): SizeInt; override; overload;
|
||||
end;
|
||||
|
||||
// More info and TODO
|
||||
// https://github.com/OpenHFT/UntitledCollectionsProject/wiki/Tombstones-purge-from-hashtable:-theory-and-practice
|
||||
|
||||
TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private
|
||||
FTombstonesCount: SizeInt;
|
||||
protected
|
||||
function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): boolean; override;
|
||||
function RealItemsLength: SizeInt; override;
|
||||
|
||||
function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; virtual; abstract;
|
||||
|
||||
function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; override;
|
||||
function DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; override;
|
||||
public
|
||||
property TombstonesCount: SizeInt read FTombstonesCount;
|
||||
procedure ClearTombstones; virtual;
|
||||
procedure Clear; override;
|
||||
end;
|
||||
|
||||
TOpenAddressingSH<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
_TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
protected
|
||||
function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; override; overload;
|
||||
function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; override;
|
||||
end;
|
||||
|
||||
TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
_TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
private
|
||||
R: UInt32;
|
||||
protected
|
||||
procedure UpdateItemsThreshold(ASize: SizeInt); override;
|
||||
function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; override; overload;
|
||||
function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; constref AKey: TKey;
|
||||
out AHash: UInt32): SizeInt; override;
|
||||
strict protected
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
constructor Create(const AComparer: IEqualityComparer<TKey>); reintroduce; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
public // bug #26181 (redundancy of constructors)
|
||||
constructor Create(ACapacity: SizeInt); override; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>); override; overload;
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
|
||||
constructor Create(const AComparer: IExtendedEqualityComparer<TKey>); overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
|
||||
end;
|
||||
|
||||
TDeamortizedDArrayCuckooMapEnumerator<T, CUCKOO_CONSTRAINTS> = class abstract(TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
TItemsArray = array of TItem;
|
||||
private
|
||||
FMainIndex: SizeInt;
|
||||
protected
|
||||
function DoMoveNext: Boolean; override;
|
||||
public
|
||||
constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
end;
|
||||
|
||||
// more info :
|
||||
// http://arxiv.org/abs/0903.0391
|
||||
|
||||
TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS> = class(TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>)
|
||||
private const // Lookup Result
|
||||
LR_NIL = -1;
|
||||
LR_QUEUE = -2;
|
||||
private type
|
||||
PItem = ^TItem;
|
||||
TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValue>;
|
||||
end;
|
||||
TValueForQueue = TItem;
|
||||
|
||||
TQueueDictionary = class(TOpenAddressingLP<TKey, TValueForQueue, TDelphiHashFactory, TLinearProbing>)
|
||||
private type // for workaround Lazarus bug #25613
|
||||
_TItem = record
|
||||
Hash: UInt32;
|
||||
Pair: TPair<TKey, TValueForQueue>;
|
||||
end;
|
||||
private
|
||||
FIdx: TList<UInt32>; // list to keep order
|
||||
protected
|
||||
procedure NotifyIndexChange(AFrom, ATo: SizeInt); override;
|
||||
function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): Boolean; override;
|
||||
public
|
||||
procedure InsertIntoBack(AItem: Pointer);
|
||||
procedure InsertIntoHead(AItem: Pointer);
|
||||
function IsEmpty: Boolean;
|
||||
function Pop: Pointer;
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
// cycle-detection mechanism class
|
||||
TCDM = class(TOpenAddressingSH<TKey, TEmptyRecord, TDelphiHashFactory, TLinearProbing>);
|
||||
TItemsArray = array of TItem;
|
||||
TItemsDArray = array[0..Pred(TCuckooCfg.D)] of TItemsArray;
|
||||
private var
|
||||
FQueue: TQueueDictionary; // probably can be optimized - hash TItem give information from TItem.Hash for cuckoo ...
|
||||
// currently is kept in "TQueueDictionary = class(TOpenAddressingSH<TKey, TItem, ...>"
|
||||
|
||||
FCDM: TCDM; // cycle-detection mechanism
|
||||
FItemsThreshold: SizeInt;
|
||||
FItems: TItemsDArray;
|
||||
// sadly there is bug #24848 for class var ...
|
||||
{class} var
|
||||
CUCKOO_SIGN, CUCKOO_INDEX_SIZE, CUCKOO_HASH_SIGN: UInt32;
|
||||
// CUCKOO_MAX_ITEMS_LENGTH: <- to do : calc max length for items based on CUCKOO sign
|
||||
// maybe some CDM bloom filter?
|
||||
|
||||
procedure UpdateItemsThreshold(ASize: SizeInt); override;
|
||||
procedure Resize(ANewSize: SizeInt);
|
||||
procedure Rehash(ASizePow2: SizeInt);
|
||||
function PrepareAddingItem: SizeInt;
|
||||
protected
|
||||
function Lookup(constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; inline; overload;
|
||||
function Lookup(constref AItems: TItemsDArray; constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; virtual; overload;
|
||||
public
|
||||
type
|
||||
// Enumerators
|
||||
TPairEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TDictionaryPair, CUCKOO_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TPair<TKey,TValue>; override;
|
||||
end;
|
||||
|
||||
TValueEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TValue, CUCKOO_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TValue; override;
|
||||
end;
|
||||
|
||||
TKeyEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TKey, CUCKOO_CONSTRAINTS>)
|
||||
protected
|
||||
function GetCurrent: TKey; override;
|
||||
end;
|
||||
|
||||
// Collections
|
||||
TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
|
||||
TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>);
|
||||
|
||||
// bug #24283 - workaround related to lack of DoGetEnumerator
|
||||
function GetEnumerator: TPairEnumerator; reintroduce;
|
||||
private
|
||||
function GetKeys: TKeyCollection;
|
||||
function GetValues: TValueCollection;
|
||||
private
|
||||
function GetItem(const AKey: TKey): TValue; inline;
|
||||
procedure SetItem(const AKey: TKey; const AValue: TValue); overload; inline;
|
||||
procedure SetItem(constref AValue: TValue; const AHashListOrIndex: PUInt32; ALookupResult: SizeInt); overload;
|
||||
|
||||
procedure AddItem(constref AItems: TItemsDArray; constref AKey: TKey; constref AValue: TValue; const AHashList: PUInt32); overload;
|
||||
procedure DoAdd(constref AKey: TKey; constref AValue: TValue; const AHashList: PUInt32); overload; inline;
|
||||
function DoRemove(const AHashListOrIndex: PUInt32; ALookupResult: SizeInt;
|
||||
ACollectionNotification: TCollectionNotification): TValue;
|
||||
|
||||
function GetQueueCount: SizeInt;
|
||||
protected
|
||||
procedure SetCapacity(ACapacity: SizeInt); override;
|
||||
// bug #24283 - can't descadent from TEnumerable
|
||||
function DoGetEnumerator: TEnumerator<TDictionaryPair>; override;
|
||||
procedure SetMaxLoadFactor(AValue: single); override;
|
||||
function GetLoadFactor: single; override;
|
||||
function GetCapacity: SizeInt; override;
|
||||
strict protected // bug #26181
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
constructor Create(const AComparer: IEqualityComparer<TKey>); reintroduce; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload;
|
||||
public
|
||||
// TODO: function TryFlushQueue(ACount: SizeInt): SizeInt;
|
||||
|
||||
constructor Create; override; overload;
|
||||
constructor Create(ACapacity: SizeInt); override; overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>); override; overload;
|
||||
constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
|
||||
constructor Create(const AComparer: IExtendedEqualityComparer<TKey>); overload;
|
||||
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure Add(constref APair: TPair<TKey, TValue>); override; overload;
|
||||
procedure Add(constref AKey: TKey; constref AValue: TValue); overload;
|
||||
procedure Remove(constref AKey: TKey);
|
||||
function ExtractPair(constref AKey: TKey): TPair<TKey, TValue>;
|
||||
procedure Clear; override;
|
||||
procedure TrimExcess;
|
||||
function TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean;
|
||||
procedure AddOrSetValue(constref AKey: TKey; constref AValue: TValue);
|
||||
function ContainsKey(constref AKey: TKey): Boolean; inline;
|
||||
function ContainsValue(constref AValue: TValue): Boolean; overload;
|
||||
function ContainsValue(constref AValue: TValue; const AEqualityComparer: IEqualityComparer<TValue>): Boolean; virtual; overload;
|
||||
|
||||
property Items[Index: TKey]: TValue read GetItem write SetItem; default;
|
||||
property Keys: TKeyCollection read GetKeys;
|
||||
property Values: TValueCollection read GetValues;
|
||||
|
||||
property QueueCount: SizeInt read GetQueueCount;
|
||||
procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition);
|
||||
end;
|
||||
|
||||
TDictionaryOwnerships = set of (doOwnsKeys, doOwnsValues);
|
||||
|
||||
TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS> = class(TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>)
|
||||
private
|
||||
FOwnerships: TDictionaryOwnerships;
|
||||
protected
|
||||
procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); override;
|
||||
procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); override;
|
||||
public
|
||||
// can't be as "Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt = 0)"
|
||||
// because bug #25607
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships;
|
||||
const AComparer: IExtendedEqualityComparer<TKey>); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt;
|
||||
const AComparer: IExtendedEqualityComparer<TKey>); overload;
|
||||
end;
|
||||
|
||||
TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>)
|
||||
private
|
||||
FOwnerships: TDictionaryOwnerships;
|
||||
protected
|
||||
procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); override;
|
||||
procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); override;
|
||||
public
|
||||
// can't be as "Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt = 0)"
|
||||
// because bug #25607
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships;
|
||||
const AComparer: IEqualityComparer<TKey>); overload;
|
||||
constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt;
|
||||
const AComparer: IEqualityComparer<TKey>); overload;
|
||||
end;
|
||||
|
||||
// useful generics overloads
|
||||
TOpenAddressingLP<TKey, TValue, THashFactory> = class(TOpenAddressingLP<TKey, TValue, THashFactory, TLinearProbing>);
|
||||
TOpenAddressingLP<TKey, TValue> = class(TOpenAddressingLP<TKey, TValue, TDelphiHashFactory, TLinearProbing>);
|
||||
|
||||
TObjectOpenAddressingLP<TKey, TValue, THashFactory> = class(TObjectOpenAddressingLP<TKey, TValue, THashFactory, TLinearProbing>);
|
||||
TObjectOpenAddressingLP<TKey, TValue> = class(TObjectOpenAddressingLP<TKey, TValue, TDelphiHashFactory, TLinearProbing>);
|
||||
|
||||
// Linear Probing with Tombstones (LPT)
|
||||
TOpenAddressingLPT<TKey, TValue, THashFactory> = class(TOpenAddressingSH<TKey, TValue, THashFactory, TLinearProbing>);
|
||||
TOpenAddressingLPT<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDelphiHashFactory, TLinearProbing>);
|
||||
|
||||
TOpenAddressingQP<TKey, TValue, THashFactory> = class(TOpenAddressingSH<TKey, TValue, THashFactory, TQuadraticProbing>);
|
||||
TOpenAddressingQP<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDelphiHashFactory, TQuadraticProbing>);
|
||||
|
||||
TOpenAddressingDH<TKey, TValue, THashFactory> = class(TOpenAddressingDH<TKey, TValue, THashFactory, TDoubleHashing>);
|
||||
TOpenAddressingDH<TKey, TValue> = class(TOpenAddressingDH<TKey, TValue, TDelphiDoubleHashFactory, TDoubleHashing>);
|
||||
|
||||
TCuckooD2<TKey, TValue, THashFactory> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D2>);
|
||||
TCuckooD2<TKey, TValue> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiDoubleHashFactory, TDeamortizedCuckooHashingCfg_D2>);
|
||||
|
||||
TCuckooD4<TKey, TValue, THashFactory> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D4>);
|
||||
TCuckooD4<TKey, TValue> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiQuadrupleHashFactory, TDeamortizedCuckooHashingCfg_D4>);
|
||||
|
||||
TCuckooD6<TKey, TValue, THashFactory> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D6>);
|
||||
TCuckooD6<TKey, TValue> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiSixfoldHashFactory, TDeamortizedCuckooHashingCfg_D6>);
|
||||
|
||||
TObjectCuckooD2<TKey, TValue, THashFactory> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D2>);
|
||||
TObjectCuckooD2<TKey, TValue> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiDoubleHashFactory, TDeamortizedCuckooHashingCfg_D2>);
|
||||
|
||||
TObjectCuckooD4<TKey, TValue, THashFactory> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D4>);
|
||||
TObjectCuckooD4<TKey, TValue> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiQuadrupleHashFactory, TDeamortizedCuckooHashingCfg_D4>);
|
||||
|
||||
TObjectCuckooD6<TKey, TValue, THashFactory> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D6>);
|
||||
TObjectCuckooD6<TKey, TValue> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiSixfoldHashFactory, TDeamortizedCuckooHashingCfg_D6>);
|
||||
|
||||
// for normal programmers to normal use =)
|
||||
TDictionary<TKey, TValue> = class(TOpenAddressingLP<TKey, TValue>);
|
||||
TObjectDictionary<TKey, TValue> = class(TObjectOpenAddressingLP<TKey, TValue>);
|
||||
|
||||
TFastHashMap<TKey, TValue> = class(TCuckooD2<TKey, TValue>);
|
||||
TFastObjectHashMap<TKey, TValue> = class(TObjectCuckooD2<TKey, TValue>);
|
||||
|
||||
THashMap<TKey, TValue> = class(TCuckooD4<TKey, TValue>);
|
||||
TObjectHashMap<TKey, TValue> = class(TObjectCuckooD4<TKey, TValue>);
|
||||
|
||||
var
|
||||
EmptyRecord: TEmptyRecord;
|
||||
@@ -0,0 +1,83 @@
|
||||
/// SOA interface methods definition to circumvent FPC missing RTTI
|
||||
// - generated at 2016-07-27 09:30:40
|
||||
unit mORMotRESTFPCInterfaces;
|
||||
|
||||
{
|
||||
WARNING:
|
||||
This unit has been generated by a mORMot 1.18.2797 server.
|
||||
Any manual modification of this file may be lost after regeneration.
|
||||
|
||||
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
|
||||
Synopse Informatique - https://synopse.info
|
||||
|
||||
This unit is released under a MPL/GPL/LGPL tri-license,
|
||||
and therefore may be freely included in any application.
|
||||
|
||||
This unit is intended to work on older FPC compilers, which lack of RTTI
|
||||
for interfaces - see http://bugs.freepascal.org/view.php?id=26774
|
||||
|
||||
USAGE:
|
||||
|
||||
Add this mORMotRESTFPCInterfaces unit to your uses clause, so that the following
|
||||
interfaces would be defined as expected by mORMot under FPC:
|
||||
|
||||
- IRestMethods
|
||||
|
||||
}
|
||||
|
||||
interface
|
||||
|
||||
{$I Synopse.inc} // needed for setting HASINTERFACERTTI and proper FPC modes
|
||||
|
||||
uses
|
||||
SysUtils,
|
||||
Classes,
|
||||
SynCommons,
|
||||
SynLog,
|
||||
mORMot,
|
||||
RestMethodsInterfaceUnit;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{$ifndef HASINTERFACERTTI} // circumvent old FPC bug of missing RTTI
|
||||
|
||||
{ TInterfaceFactoryDefinition }
|
||||
|
||||
type
|
||||
/// define and manage missing interface RTTI for the following interfaces:
|
||||
// - IRestMethods
|
||||
TInterfaceFactoryDefinition = class(TInterfaceFactoryGenerated)
|
||||
protected
|
||||
procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo); override;
|
||||
end;
|
||||
|
||||
procedure TInterfaceFactoryDefinition.AddMethodsFromTypeInfo(aInterface: PTypeInfo);
|
||||
begin
|
||||
if aInterface=TypeInfo(IRestMethods) then begin
|
||||
AddMethod('HelloWorld',[
|
||||
ord(smdresult),'Result',TypeInfo(AnsiString)]);
|
||||
AddMethod('Sum',[
|
||||
ord(smdconst),'val1',TypeInfo(Double),
|
||||
ord(smdconst),'val2',TypeInfo(Double),
|
||||
ord(smdresult),'Result',TypeInfo(Double)]);
|
||||
AddMethod('GetCustomRecord',[
|
||||
ord(smdresult),'Result',TypeInfo(rCustomRecord)]);
|
||||
AddMethod('SendCustomRecord',[
|
||||
ord(smdconst),'CustomResult',TypeInfo(rCustomRecord),
|
||||
ord(smdresult),'Result',TypeInfo(Boolean)]);
|
||||
AddMethod('SendMultipleCustomRecords',[
|
||||
ord(smdconst),'CustomResult',TypeInfo(rCustomRecord),
|
||||
ord(smdconst),'CustomComplicatedRecord',TypeInfo(rCustomComplicatedRecord),
|
||||
ord(smdresult),'Result',TypeInfo(Boolean)]);
|
||||
AddMethod('GetMethodCustomResult',[
|
||||
ord(smdresult),'Result',TypeInfo(TServiceCustomAnswer)]);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
TInterfaceFactoryDefinition.RegisterInterface(TypeInfo(IRestMethods));
|
||||
|
||||
{$endif HASINTERFACERTTI}
|
||||
end.
|
||||
@@ -0,0 +1,58 @@
|
||||
program mORMotRESTcl;
|
||||
|
||||
{$ifdef Linux}
|
||||
{$ifdef FPC_CROSSCOMPILING}
|
||||
{$ifdef CPUARM}
|
||||
{$linklib GLESv2}
|
||||
{$endif}
|
||||
{$linklib libc_nonshared.a}
|
||||
{$endif}
|
||||
{$endif}
|
||||
|
||||
{$I Synopse.inc}
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
Interfaces,
|
||||
{$ENDIF }
|
||||
Forms,
|
||||
{$ifndef DELPHI5OROLDER}
|
||||
mORMotRESTFPCInterfaces,
|
||||
{$endif}
|
||||
{$ifdef COMPUTEFPCINTERFACES}
|
||||
SynCommons,
|
||||
mORMotWrappers,
|
||||
{$endif}
|
||||
RestClientFormUnit in 'RestClientFormUnit.pas' {Form1} ,
|
||||
RestMethodsInterfaceUnit in 'RestMethodsInterfaceUnit.pas',
|
||||
RestClientUnit in 'RestClientUnit.pas'
|
||||
{$ifndef FPC}
|
||||
,Vcl.Themes
|
||||
,Vcl.Styles
|
||||
{$endif}
|
||||
;
|
||||
|
||||
{$ifndef FPC}
|
||||
{$R *.res}
|
||||
{$endif}
|
||||
|
||||
begin
|
||||
{$IFDEF DEBUG}
|
||||
ReportMemoryLeaksOnShutdown := True;
|
||||
{$ENDIF}
|
||||
Application.Initialize;
|
||||
{$ifdef MSWINDOWS}
|
||||
Application.MainFormOnTaskbar := True;
|
||||
{$endif}
|
||||
{$ifndef FPC}
|
||||
TStyleManager.TrySetStyle('Turquoise Gray');
|
||||
{$endif}
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
{$ifdef COMPUTEFPCINTERFACES}
|
||||
ChDir(ExeVersion.ProgramFilePath);
|
||||
ComputeFPCInterfacesUnit(
|
||||
['..\..\..\..\..\..\CrossPlatform\templates'],
|
||||
'..\..\mORMotRESTFPCInterfaces.pas');
|
||||
{$endif}
|
||||
end.
|
||||
@@ -0,0 +1,110 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasUsesSectionForAllUnits Value="False"/>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="mORMotRESTcl"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="2">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
<Item2 Name="Linux">
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="bin\$(TargetCPU)-$(TargetOS)\mORMotRESTcl"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir);generics-collections\src\inc;..\..\..\..\.."/>
|
||||
<OtherUnitFiles Value="generics-collections\src;..\..\..\..\..;..\..\..\.."/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<SyntaxMode Value="Delphi"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<CodeGeneration>
|
||||
<TargetOS Value="linux"/>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
</Item2>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item1>
|
||||
</RequiredPackages>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="mORMotRESTcl.dpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="bin\$(TargetCPU)-$(TargetOS)\mORMotRESTcl"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir);generics-collections\src\inc;..\..\..\..\.."/>
|
||||
<OtherUnitFiles Value="generics-collections\src;..\..\..\..\..;..\..\..\.."/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<SyntaxMode Value="Delphi"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<Linking>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@@ -0,0 +1,60 @@
|
||||
program mORMotRESTsrv;
|
||||
|
||||
{$ifdef Linux}
|
||||
{$ifdef FPC_CROSSCOMPILING}
|
||||
{$ifdef CPUARM}
|
||||
{$linklib GLESv2}
|
||||
{$endif}
|
||||
{$linklib libc_nonshared.a}
|
||||
{$endif}
|
||||
{$endif}
|
||||
|
||||
{$I Synopse.inc}
|
||||
|
||||
uses
|
||||
{$IFNDEF FPC}
|
||||
{$ELSE}
|
||||
{$IFDEF UNIX}
|
||||
cthreads,
|
||||
{$ENDIF}
|
||||
Interfaces,
|
||||
{$ENDIF }
|
||||
Forms,
|
||||
{$ifndef DELPHI5OROLDER}
|
||||
mORMotRESTFPCInterfaces,
|
||||
{$endif}
|
||||
{$ifdef COMPUTEFPCINTERFACES}
|
||||
SynCommons,
|
||||
mORMotWrappers,
|
||||
{$endif}
|
||||
RestServerFormUnit in 'RestServerFormUnit.pas' {Form1},
|
||||
RestServerUnit in 'RestServerUnit.pas',
|
||||
RestServerMethodsUnit in 'RestServerMethodsUnit.pas',
|
||||
RestMethodsInterfaceUnit in 'RestMethodsInterfaceUnit.pas'
|
||||
{$ifndef FPC}
|
||||
,Vcl.Themes
|
||||
,Vcl.Styles
|
||||
{$endif}
|
||||
;
|
||||
|
||||
{$ifndef FPC}
|
||||
{$R *.res}
|
||||
{$endif}
|
||||
|
||||
begin
|
||||
{$IFDEF DEBUG}
|
||||
ReportMemoryLeaksOnShutdown := True;
|
||||
{$ENDIF}
|
||||
Application.Initialize;
|
||||
{$ifdef MSWINDOWS}
|
||||
Application.MainFormOnTaskbar := True;
|
||||
{$endif}
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
{$ifdef COMPUTEFPCINTERFACES}
|
||||
ChDir(ExeVersion.ProgramFilePath);
|
||||
ComputeFPCInterfacesUnit(
|
||||
['..\..\..\..\..\..\CrossPlatform\templates'],
|
||||
'..\..\mORMotRESTFPCInterfaces.pas');
|
||||
{$endif}
|
||||
end.
|
||||
@@ -0,0 +1,110 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasUsesSectionForAllUnits Value="False"/>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="mORMotRESTsrv"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="2">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
<Item2 Name="Linux">
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="bin\$(TargetCPU)-$(TargetOS)\mORMotRESTsrv"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir);generics-collections\src\inc;..\..\..\..\.."/>
|
||||
<OtherUnitFiles Value="generics-collections\src;..\..\..\..\..;..\..\..\.."/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<SyntaxMode Value="Delphi"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<CodeGeneration>
|
||||
<TargetOS Value="linux"/>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
</Item2>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item1>
|
||||
</RequiredPackages>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="mORMotRESTsrv.dpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="bin\$(TargetCPU)-$(TargetOS)\mORMotRESTsrv"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir);generics-collections\src\inc;..\..\..\..\.."/>
|
||||
<OtherUnitFiles Value="generics-collections\src;..\..\..\..\..;..\..\..\.."/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<SyntaxMode Value="Delphi"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<Linking>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 76 KiB |
Reference in New Issue
Block a user