├── .gitattributes ├── .gitignore ├── AMQP ├── AMQP.groupproj ├── Samples │ ├── Testbench │ │ ├── Testbench.dpr │ │ ├── Testbench.dproj │ │ ├── Testbench.res │ │ ├── TestbenchWin.dfm │ │ └── TestbenchWin.pas │ └── Threads │ │ ├── ThreadSample.dfm │ │ ├── ThreadSample.dpr │ │ ├── ThreadSample.dproj │ │ ├── ThreadSample.pas │ │ ├── ThreadSample.res │ │ ├── ThreadSampleWin.dfm │ │ └── ThreadSampleWin.pas └── Source │ ├── AMQP.Arguments.pas │ ├── AMQP.Channel.pas │ ├── AMQP.Classes.pas │ ├── AMQP.Connection.pas │ ├── AMQP.Frame.pas │ ├── AMQP.Header.pas │ ├── AMQP.Helper.pas │ ├── AMQP.IMessageProperties.pas │ ├── AMQP.Interfaces.pas │ ├── AMQP.Message.pas │ ├── AMQP.MessageProperties.pas │ ├── AMQP.Method.pas │ ├── AMQP.Payload.pas │ ├── AMQP.Protocol.pas │ ├── AMQP.StreamHelper.pas │ └── AMQP.Types.pas ├── EasyDelphiQ ├── EasyDelphiQ.Classes.pas ├── EasyDelphiQ.DTO.pas ├── EasyDelphiQ.Interfaces.pas ├── EasyDelphiQ.pas └── Testbench │ ├── MainWin.dfm │ ├── MainWin.pas │ ├── Neas.PowermanApi.Notifications.DTOs.V1.pas │ ├── QTestbench.dpr │ ├── QTestbench.dproj │ ├── QTestbench.res │ └── Some.namespace.pas ├── JSON ├── DJSON.pas ├── DTO.pas ├── JSON Samples │ └── Nexus.txt ├── JSON2DTO.pas ├── JSONProject.groupproj ├── Project1.dpr ├── Project1.dproj ├── Sample1.dpr ├── Sample1.dproj ├── Sample1.res ├── Sample1Form.dfm ├── Sample1Form.pas ├── Test │ ├── Sample1Tests.dpr │ ├── Sample1Tests.dproj │ ├── TestJSON.pas │ └── TestObjects.pas ├── TimeseriesDTO.pas ├── WinHttp_TLB.pas └── Wizard │ ├── JSON.bmp │ ├── JSON.ico │ ├── JSON.rc │ ├── JSONDTO.txt │ ├── JSONDTOExpt.pas │ ├── JSONDTOWiz.dpk │ ├── JSONDTOWiz.dproj │ ├── JSONFile.ico │ ├── WizardWin.dfm │ └── WizardWin.pas ├── README.md └── XPath ├── HtmlParser.pas ├── TestBench ├── HtmlTest.dpr ├── HtmlTest.dproj ├── HtmlTest.res ├── MainWin.dfm ├── MainWin.pas └── Win32 │ └── Debug │ └── Download.html ├── UnitTest ├── TestHtmlParser.pas ├── TestLexer.pas ├── TestXPath.pas ├── XPathTests.dpr ├── XPathTests.dproj └── XPathTests.res ├── XPath EBNF.txt ├── XPath.pas ├── XPathGroup.groupproj └── XPathLexer.pas /.gitattributes: -------------------------------------------------------------------------------- 1 | # Disable LF normalization for all files 2 | * -text -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.identcache 2 | *.local 3 | *.dcu 4 | *.stat 5 | *.dsk 6 | JSON/__history/ 7 | XPath/UnitTest/Win32/Debug/dunit.ini 8 | XPath/__history/ 9 | XPath/TestBench/__history/ 10 | XPath/UnitTest/__history/ 11 | AMQP/__history/ 12 | AMQP/source/__history/ 13 | AMQP/Samples/Threads/__history/ 14 | AMQP/Samples/Testbench/__history/ 15 | EasyDelphiQ/__history/ 16 | EasyDelphiQ/Testbench/__history 17 | EasyDelphiQ/Testbench/Win32 18 | -------------------------------------------------------------------------------- /AMQP/AMQP.groupproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {08B89F4A-51A1-413B-8DBF-5A5C03F9E91C} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | Default.Personality.12 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /AMQP/Samples/Testbench/Testbench.dpr: -------------------------------------------------------------------------------- 1 | // JCL_DEBUG_EXPERT_GENERATEJDBG OFF 2 | // JCL_DEBUG_EXPERT_INSERTJDBG OFF 3 | program Testbench; 4 | 5 | uses 6 | Vcl.Forms, 7 | TestbenchWin in 'TestbenchWin.pas' {TestbenchForm}, 8 | AMQP.Method in '..\..\Source\AMQP.Method.pas', 9 | AMQP.Types in '..\..\Source\AMQP.Types.pas', 10 | AMQP.Message in '..\..\Source\AMQP.Message.pas', 11 | AMQP.Protocol in '..\..\Source\AMQP.Protocol.pas', 12 | AMQP.Connection in '..\..\Source\AMQP.Connection.pas', 13 | AMQP.Frame in '..\..\Source\AMQP.Frame.pas', 14 | AMQP.Helper in '..\..\Source\AMQP.Helper.pas', 15 | AMQP.Payload in '..\..\Source\AMQP.Payload.pas', 16 | AMQP.MessageProperties in '..\..\Source\AMQP.MessageProperties.pas', 17 | AMQP.Header in '..\..\Source\AMQP.Header.pas', 18 | AMQP.StreamHelper in '..\..\Source\AMQP.StreamHelper.pas', 19 | AMQP.Channel in '..\..\Source\AMQP.Channel.pas', 20 | AMQP.Classes in '..\..\Source\AMQP.Classes.pas', 21 | AMQP.Interfaces in '..\..\Source\AMQP.Interfaces.pas', 22 | AMQP.IMessageProperties in '..\..\Source\AMQP.IMessageProperties.pas', 23 | AMQP.Arguments in '..\..\Source\AMQP.Arguments.pas'; 24 | 25 | {$R *.res} 26 | 27 | begin 28 | Application.Initialize; 29 | Application.MainFormOnTaskbar := True; 30 | Application.CreateForm(TTestbenchForm, TestbenchForm); 31 | Application.Run; 32 | end. 33 | -------------------------------------------------------------------------------- /AMQP/Samples/Testbench/Testbench.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/AMQP/Samples/Testbench/Testbench.res -------------------------------------------------------------------------------- /AMQP/Samples/Testbench/TestbenchWin.dfm: -------------------------------------------------------------------------------- 1 | object TestbenchForm: TTestbenchForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'AMQP Testbench' 5 | ClientHeight = 821 6 | ClientWidth = 1218 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | OnCreate = FormCreate 15 | OnDestroy = FormDestroy 16 | DesignSize = ( 17 | 1218 18 | 821) 19 | PixelsPerInch = 96 20 | TextHeight = 13 21 | object MemoMessages: TMemo 22 | Left = 8 23 | Top = 629 24 | Width = 897 25 | Height = 184 26 | Anchors = [akLeft, akRight, akBottom] 27 | Color = clBlack 28 | Font.Charset = DEFAULT_CHARSET 29 | Font.Color = clWhite 30 | Font.Height = 18 31 | Font.Name = 'Courier New' 32 | Font.Style = [] 33 | ParentFont = False 34 | ScrollBars = ssVertical 35 | TabOrder = 1 36 | end 37 | object ButtonConnect: TButton 38 | Left = 8 39 | Top = 8 40 | Width = 75 41 | Height = 25 42 | Caption = 'Connect' 43 | TabOrder = 0 44 | OnClick = ButtonConnectClick 45 | end 46 | object MemoSent: TMemo 47 | Left = 8 48 | Top = 104 49 | Width = 401 50 | Height = 520 51 | Anchors = [akLeft, akTop, akBottom] 52 | Ctl3D = False 53 | Font.Charset = DEFAULT_CHARSET 54 | Font.Color = clWindowText 55 | Font.Height = 16 56 | Font.Name = 'Courier New' 57 | Font.Style = [] 58 | ParentCtl3D = False 59 | ParentFont = False 60 | ScrollBars = ssBoth 61 | TabOrder = 2 62 | end 63 | object MemoReceived: TMemo 64 | Left = 617 65 | Top = 104 66 | Width = 401 67 | Height = 520 68 | Anchors = [akLeft, akTop, akRight, akBottom] 69 | Ctl3D = False 70 | Font.Charset = DEFAULT_CHARSET 71 | Font.Color = clWindowText 72 | Font.Height = 16 73 | Font.Name = 'Courier New' 74 | Font.Style = [] 75 | ParentCtl3D = False 76 | ParentFont = False 77 | ScrollBars = ssBoth 78 | TabOrder = 3 79 | end 80 | object MemoSentBytes: TMemo 81 | Left = 415 82 | Top = 104 83 | Width = 196 84 | Height = 519 85 | Anchors = [akLeft, akTop, akBottom] 86 | Color = clGreen 87 | Ctl3D = False 88 | Font.Charset = DEFAULT_CHARSET 89 | Font.Color = clWhite 90 | Font.Height = 16 91 | Font.Name = 'Courier New' 92 | Font.Style = [] 93 | ParentCtl3D = False 94 | ParentFont = False 95 | ScrollBars = ssBoth 96 | TabOrder = 4 97 | end 98 | object MemoReceivedBytes: TMemo 99 | Left = 1024 100 | Top = 104 101 | Width = 186 102 | Height = 520 103 | Anchors = [akTop, akRight, akBottom] 104 | Color = clGreen 105 | Ctl3D = False 106 | Font.Charset = DEFAULT_CHARSET 107 | Font.Color = clWhite 108 | Font.Height = 16 109 | Font.Name = 'Courier New' 110 | Font.Style = [] 111 | ParentCtl3D = False 112 | ParentFont = False 113 | ScrollBars = ssBoth 114 | TabOrder = 5 115 | end 116 | object ButtonDisconnect: TButton 117 | Left = 8 118 | Top = 39 119 | Width = 75 120 | Height = 25 121 | Caption = 'Disconnect' 122 | TabOrder = 6 123 | OnClick = ButtonDisconnectClick 124 | end 125 | object ButtonPublishRed: TButton 126 | Left = 600 127 | Top = 8 128 | Width = 75 129 | Height = 25 130 | Caption = 'Publish Red' 131 | TabOrder = 7 132 | OnClick = ButtonPublishRedClick 133 | end 134 | object ButtonOpenChannel: TButton 135 | Left = 95 136 | Top = 8 137 | Width = 90 138 | Height = 25 139 | Caption = 'Open Channel' 140 | TabOrder = 8 141 | OnClick = ButtonOpenChannelClick 142 | end 143 | object ButtonCloseChannel: TButton 144 | Left = 95 145 | Top = 40 146 | Width = 90 147 | Height = 25 148 | Caption = 'Close Channel' 149 | TabOrder = 9 150 | OnClick = ButtonCloseChannelClick 151 | end 152 | object ButtonExchangeDeclare: TButton 153 | Left = 199 154 | Top = 8 155 | Width = 106 156 | Height = 25 157 | Caption = 'Declare Exchange' 158 | TabOrder = 10 159 | OnClick = ButtonExchangeDeclareClick 160 | end 161 | object ButtonExchangeDelete: TButton 162 | Left = 199 163 | Top = 40 164 | Width = 106 165 | Height = 25 166 | Caption = 'Delete Exchange' 167 | TabOrder = 11 168 | OnClick = ButtonExchangeDeleteClick 169 | end 170 | object ButtonQueueDeclare: TButton 171 | Left = 322 172 | Top = 8 173 | Width = 87 174 | Height = 25 175 | Caption = 'Declare Queue' 176 | TabOrder = 12 177 | OnClick = ButtonQueueDeclareClick 178 | end 179 | object ButtonQueueDelete: TButton 180 | Left = 322 181 | Top = 39 182 | Width = 87 183 | Height = 25 184 | Caption = 'Delete Queue' 185 | TabOrder = 13 186 | OnClick = ButtonQueueDeleteClick 187 | end 188 | object ButtonQueueBind: TButton 189 | Left = 415 190 | Top = 8 191 | Width = 82 192 | Height = 25 193 | Caption = 'Bind Queue' 194 | TabOrder = 14 195 | OnClick = ButtonQueueBindClick 196 | end 197 | object ButtonQueueUnbind: TButton 198 | Left = 415 199 | Top = 39 200 | Width = 82 201 | Height = 25 202 | Caption = 'Unbind queue' 203 | TabOrder = 15 204 | OnClick = ButtonQueueUnbindClick 205 | end 206 | object ButtonPublishBlue: TButton 207 | Left = 600 208 | Top = 39 209 | Width = 75 210 | Height = 25 211 | Caption = 'Publish Blue' 212 | TabOrder = 16 213 | OnClick = ButtonPublishBlueClick 214 | end 215 | object ButtonGetRed: TButton 216 | Left = 696 217 | Top = 9 218 | Width = 75 219 | Height = 25 220 | Caption = 'Get red' 221 | TabOrder = 17 222 | OnClick = ButtonGetRedClick 223 | end 224 | object ButtonGetBlue: TButton 225 | Left = 696 226 | Top = 40 227 | Width = 75 228 | Height = 25 229 | Caption = 'Get Blue' 230 | TabOrder = 18 231 | OnClick = ButtonGetBlueClick 232 | end 233 | object ButtonConfirmSelect: TButton 234 | Left = 864 235 | Top = 8 236 | Width = 89 237 | Height = 25 238 | Caption = 'Confirm Select' 239 | TabOrder = 19 240 | OnClick = ButtonConfirmSelectClick 241 | end 242 | object ButtonConsumeBlue: TButton 243 | Left = 976 244 | Top = 8 245 | Width = 91 246 | Height = 25 247 | Caption = 'Consume Blue' 248 | TabOrder = 20 249 | OnClick = ButtonConsumeBlueClick 250 | end 251 | object Panel1: TPanel 252 | Left = 911 253 | Top = 630 254 | Width = 299 255 | Height = 183 256 | Anchors = [akRight, akBottom] 257 | BorderStyle = bsSingle 258 | Caption = 'Panel1' 259 | Ctl3D = False 260 | ParentCtl3D = False 261 | ShowCaption = False 262 | TabOrder = 21 263 | object LabelStatus: TLabel 264 | Left = 8 265 | Top = 8 266 | Width = 56 267 | Height = 13 268 | Caption = 'LabelStatus' 269 | end 270 | end 271 | object ButtonPurgeRed: TButton 272 | Left = 503 273 | Top = 8 274 | Width = 75 275 | Height = 25 276 | Caption = 'Purge Red' 277 | TabOrder = 22 278 | OnClick = ButtonPurgeRedClick 279 | end 280 | object ButtonCancelBlue: TButton 281 | Left = 976 282 | Top = 40 283 | Width = 91 284 | Height = 25 285 | Caption = 'Cancel Blue' 286 | TabOrder = 23 287 | OnClick = ButtonCancelBlueClick 288 | end 289 | object ButtonReject: TButton 290 | Left = 777 291 | Top = 9 292 | Width = 75 293 | Height = 25 294 | Caption = 'Reject red' 295 | TabOrder = 24 296 | OnClick = ButtonRejectClick 297 | end 298 | object ButtonThreadConsume: TButton 299 | Left = 1073 300 | Top = 8 301 | Width = 96 302 | Height = 25 303 | Caption = 'Consume Thread' 304 | TabOrder = 25 305 | OnClick = ButtonThreadConsumeClick 306 | end 307 | object ButtonCancelRed: TButton 308 | Left = 1073 309 | Top = 40 310 | Width = 96 311 | Height = 25 312 | Caption = 'Cancel Red' 313 | TabOrder = 26 314 | OnClick = ButtonCancelRedClick 315 | end 316 | object ButtonBigExchange: TButton 317 | Left = 199 318 | Top = 71 319 | Width = 106 320 | Height = 25 321 | Caption = 'Declare Big Exchange' 322 | TabOrder = 27 323 | OnClick = ButtonBigExchangeClick 324 | end 325 | object Button1: TButton 326 | Left = 322 327 | Top = 70 328 | Width = 87 329 | Height = 25 330 | Caption = 'Declare Big Queue' 331 | TabOrder = 28 332 | OnClick = Button1Click 333 | end 334 | object Button2: TButton 335 | Left = 415 336 | Top = 70 337 | Width = 82 338 | Height = 25 339 | Caption = 'Bind big queue' 340 | TabOrder = 29 341 | OnClick = Button2Click 342 | end 343 | object Button3: TButton 344 | Left = 600 345 | Top = 70 346 | Width = 75 347 | Height = 25 348 | Caption = 'Publish big' 349 | TabOrder = 30 350 | OnClick = Button3Click 351 | end 352 | object Button4: TButton 353 | Left = 696 354 | Top = 71 355 | Width = 75 356 | Height = 25 357 | Caption = 'Get big' 358 | TabOrder = 31 359 | OnClick = Button4Click 360 | end 361 | object Timer1: TTimer 362 | Interval = 200 363 | OnTimer = Timer1Timer 364 | Left = 1167 365 | Top = 613 366 | end 367 | end 368 | -------------------------------------------------------------------------------- /AMQP/Samples/Threads/ThreadSample.dfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 0 3 | Top = 0 4 | Caption = 'Form1' 5 | ClientHeight = 337 6 | ClientWidth = 635 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | PixelsPerInch = 96 15 | TextHeight = 13 16 | end 17 | -------------------------------------------------------------------------------- /AMQP/Samples/Threads/ThreadSample.dpr: -------------------------------------------------------------------------------- 1 | // JCL_DEBUG_EXPERT_GENERATEJDBG OFF 2 | // JCL_DEBUG_EXPERT_INSERTJDBG OFF 3 | program ThreadSample; 4 | 5 | uses 6 | Vcl.Forms, 7 | ThreadSampleWin in 'ThreadSampleWin.pas' {ThreadSampleForm}, 8 | AMQP.Channel in '..\..\Source\AMQP.Channel.pas', 9 | AMQP.Classes in '..\..\Source\AMQP.Classes.pas', 10 | AMQP.Connection in '..\..\Source\AMQP.Connection.pas', 11 | AMQP.Frame in '..\..\Source\AMQP.Frame.pas', 12 | AMQP.Header in '..\..\Source\AMQP.Header.pas', 13 | AMQP.Helper in '..\..\Source\AMQP.Helper.pas', 14 | AMQP.Interfaces in '..\..\Source\AMQP.Interfaces.pas', 15 | AMQP.Message in '..\..\Source\AMQP.Message.pas', 16 | AMQP.MessageProperties in '..\..\Source\AMQP.MessageProperties.pas', 17 | AMQP.Method in '..\..\Source\AMQP.Method.pas', 18 | AMQP.Payload in '..\..\Source\AMQP.Payload.pas', 19 | AMQP.Protocol in '..\..\Source\AMQP.Protocol.pas', 20 | AMQP.StreamHelper in '..\..\Source\AMQP.StreamHelper.pas', 21 | AMQP.Types in '..\..\Source\AMQP.Types.pas', 22 | AMQP.IMessageProperties in '..\..\Source\AMQP.IMessageProperties.pas', 23 | AMQP.Arguments in '..\..\Source\AMQP.Arguments.pas'; 24 | 25 | {$R *.res} 26 | 27 | begin 28 | Application.Initialize; 29 | Application.MainFormOnTaskbar := True; 30 | Application.CreateForm(TThreadSampleForm, ThreadSampleForm); 31 | Application.Run; 32 | end. 33 | -------------------------------------------------------------------------------- /AMQP/Samples/Threads/ThreadSample.pas: -------------------------------------------------------------------------------- 1 | unit ThreadSample; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs; 8 | 9 | type 10 | TForm1 = class(TForm) 11 | private 12 | { Private declarations } 13 | public 14 | { Public declarations } 15 | end; 16 | 17 | var 18 | Form1: TForm1; 19 | 20 | implementation 21 | 22 | {$R *.dfm} 23 | 24 | end. 25 | -------------------------------------------------------------------------------- /AMQP/Samples/Threads/ThreadSample.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/AMQP/Samples/Threads/ThreadSample.res -------------------------------------------------------------------------------- /AMQP/Samples/Threads/ThreadSampleWin.dfm: -------------------------------------------------------------------------------- 1 | object ThreadSampleForm: TThreadSampleForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'Thread sample' 5 | ClientHeight = 433 6 | ClientWidth = 789 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | OnClose = FormClose 15 | OnShow = FormShow 16 | DesignSize = ( 17 | 789 18 | 433) 19 | PixelsPerInch = 96 20 | TextHeight = 13 21 | object Label1: TLabel 22 | Left = 96 23 | Top = 8 24 | Width = 72 25 | Height = 13 26 | Caption = 'Message count' 27 | end 28 | object Label2: TLabel 29 | Left = 192 30 | Top = 8 31 | Width = 38 32 | Height = 13 33 | Caption = 'Interval' 34 | end 35 | object MemoConsumer2: TMemo 36 | Left = 537 37 | Top = 72 38 | Width = 244 39 | Height = 353 40 | Anchors = [akTop, akRight, akBottom] 41 | ScrollBars = ssBoth 42 | TabOrder = 0 43 | end 44 | object MemoProducer: TMemo 45 | Left = 8 46 | Top = 72 47 | Width = 244 48 | Height = 353 49 | Anchors = [akLeft, akTop, akBottom] 50 | ScrollBars = ssBoth 51 | TabOrder = 1 52 | end 53 | object ButtonStartConsumer2: TButton 54 | Left = 537 55 | Top = 8 56 | Width = 75 57 | Height = 25 58 | Anchors = [akTop, akRight] 59 | Caption = 'Consume' 60 | TabOrder = 2 61 | OnClick = ButtonStartConsumer2Click 62 | end 63 | object ButtonStartProducer: TButton 64 | Left = 8 65 | Top = 9 66 | Width = 75 67 | Height = 25 68 | Caption = 'Produce' 69 | TabOrder = 3 70 | OnClick = ButtonStartProducerClick 71 | end 72 | object ButtonStopProducer: TButton 73 | Left = 8 74 | Top = 40 75 | Width = 75 76 | Height = 25 77 | Caption = 'Stop' 78 | TabOrder = 4 79 | OnClick = ButtonStopProducerClick 80 | end 81 | object ButtonStopConsumer2: TButton 82 | Left = 537 83 | Top = 41 84 | Width = 75 85 | Height = 25 86 | Anchors = [akTop, akRight] 87 | Caption = 'Stop' 88 | TabOrder = 5 89 | OnClick = ButtonStopConsumer2Click 90 | end 91 | object SpinEditCount: TSpinEdit 92 | Left = 97 93 | Top = 28 94 | Width = 64 95 | Height = 22 96 | MaxValue = 0 97 | MinValue = 0 98 | TabOrder = 6 99 | Value = 100 100 | end 101 | object SpinEditInterval: TSpinEdit 102 | Left = 188 103 | Top = 28 104 | Width = 64 105 | Height = 22 106 | MaxValue = 0 107 | MinValue = 0 108 | TabOrder = 7 109 | Value = 100 110 | end 111 | object MemoConsumer1: TMemo 112 | Left = 287 113 | Top = 72 114 | Width = 244 115 | Height = 353 116 | Anchors = [akTop, akRight, akBottom] 117 | ScrollBars = ssBoth 118 | TabOrder = 8 119 | end 120 | object ButtonStartConsumer1: TButton 121 | Left = 287 122 | Top = 8 123 | Width = 75 124 | Height = 25 125 | Anchors = [akTop, akRight] 126 | Caption = 'Consume' 127 | TabOrder = 9 128 | OnClick = ButtonStartConsumer1Click 129 | end 130 | object ButtonStopConsumer1: TButton 131 | Left = 287 132 | Top = 41 133 | Width = 75 134 | Height = 25 135 | Anchors = [akTop, akRight] 136 | Caption = 'Stop' 137 | TabOrder = 10 138 | OnClick = ButtonStopConsumer1Click 139 | end 140 | end 141 | -------------------------------------------------------------------------------- /AMQP/Samples/Threads/ThreadSampleWin.pas: -------------------------------------------------------------------------------- 1 | unit ThreadSampleWin; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.StdCtrls, 7 | Vcl.Samples.Spin, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, AMQP.Connection, AMQP.Interfaces, AMQP.Classes; 8 | 9 | type 10 | TProducerThread = Class(TThread) 11 | Strict Private 12 | FAMQP: TAMQPConnection; 13 | FMaxWork: Integer; 14 | FSleepMS: Integer; 15 | Procedure WriteLine( Text: String ); 16 | Protected 17 | Procedure Execute; Override; 18 | Constructor Create( AAMQP: TAMQPConnection; AMaxWork, ASleepMS: Integer ); Reintroduce; 19 | End; 20 | 21 | TConsumerThread = Class(TThread) 22 | Strict Private 23 | FAMQP: TAMQPConnection; 24 | FChannel: IAMQPChannel; 25 | FMemo: TMemo; 26 | Procedure WriteLine( Text: String ); 27 | Protected 28 | Procedure TerminatedSet; Override; 29 | Procedure Execute; Override; 30 | Constructor Create( AAMQP: TAMQPConnection; AMemo: TMemo ); Reintroduce; 31 | End; 32 | 33 | TThreadSampleForm = class(TForm) 34 | MemoConsumer2: TMemo; 35 | MemoProducer: TMemo; 36 | ButtonStartConsumer2: TButton; 37 | ButtonStartProducer: TButton; 38 | ButtonStopProducer: TButton; 39 | ButtonStopConsumer2: TButton; 40 | SpinEditCount: TSpinEdit; 41 | SpinEditInterval: TSpinEdit; 42 | Label1: TLabel; 43 | Label2: TLabel; 44 | MemoConsumer1: TMemo; 45 | ButtonStartConsumer1: TButton; 46 | ButtonStopConsumer1: TButton; 47 | procedure FormShow(Sender: TObject); 48 | procedure FormClose(Sender: TObject; var Action: TCloseAction); 49 | procedure ButtonStartProducerClick(Sender: TObject); 50 | procedure ButtonStopProducerClick(Sender: TObject); 51 | procedure ButtonStartConsumer2Click(Sender: TObject); 52 | procedure ButtonStopConsumer2Click(Sender: TObject); 53 | procedure ButtonStartConsumer1Click(Sender: TObject); 54 | procedure ButtonStopConsumer1Click(Sender: TObject); 55 | private 56 | { Private declarations } 57 | public 58 | AMQP: TAMQPConnection; 59 | Producer: TProducerThread; 60 | Consumer1: TConsumerThread; 61 | Consumer2: TConsumerThread; 62 | end; 63 | 64 | var 65 | ThreadSampleForm: TThreadSampleForm; 66 | 67 | implementation 68 | 69 | Uses 70 | AMQP.Message, AMQP.StreamHelper; 71 | 72 | {$R *.dfm} 73 | 74 | procedure TThreadSampleForm.ButtonStartConsumer1Click(Sender: TObject); 75 | begin 76 | ButtonStopConsumer1.Click; 77 | Consumer1 := TConsumerThread.Create( AMQP, MemoConsumer1 ); 78 | end; 79 | 80 | procedure TThreadSampleForm.ButtonStartConsumer2Click(Sender: TObject); 81 | begin 82 | ButtonStopConsumer2.Click; 83 | Consumer2 := TConsumerThread.Create( AMQP, MemoConsumer2 ); 84 | end; 85 | 86 | procedure TThreadSampleForm.ButtonStartProducerClick(Sender: TObject); 87 | begin 88 | ButtonStopProducer.Click; 89 | Producer := TProducerThread.Create( AMQP, SpinEditCount.Value, SpinEditInterval.Value ); 90 | end; 91 | 92 | procedure TThreadSampleForm.ButtonStopConsumer1Click(Sender: TObject); 93 | begin 94 | If Consumer1 <> nil then 95 | Consumer1.Free; 96 | Consumer1 := nil; 97 | end; 98 | 99 | procedure TThreadSampleForm.ButtonStopConsumer2Click(Sender: TObject); 100 | begin 101 | If Consumer2 <> nil then 102 | Consumer2.Free; 103 | Consumer2 := nil; 104 | end; 105 | 106 | procedure TThreadSampleForm.ButtonStopProducerClick(Sender: TObject); 107 | begin 108 | If Producer <> nil then 109 | Producer.Free; 110 | Producer := nil; 111 | end; 112 | 113 | procedure TThreadSampleForm.FormClose(Sender: TObject; var Action: TCloseAction); 114 | begin 115 | AMQP.Free; 116 | end; 117 | 118 | procedure TThreadSampleForm.FormShow(Sender: TObject); 119 | var 120 | Channel: IAMQPChannel; 121 | begin 122 | Producer := nil; 123 | Consumer1 := nil; 124 | Consumer2 := nil; 125 | AMQP := TAMQPConnection.Create; 126 | AMQP.HeartbeatSecs := 120; 127 | AMQP.Host := 'localhost'; 128 | AMQP.Port := 5672; 129 | AMQP.VirtualHost := '/'; 130 | AMQP.Username := 'TestUser'; 131 | AMQP.Password := 'password'; 132 | AMQP.Connect; 133 | Channel := AMQP.OpenChannel; 134 | Channel.ExchangeDeclare( 'Work', 'direct' ); 135 | Channel.QueueDeclare( 'WorkQueue' ); 136 | Channel.QueueBind( 'WorkQueue', 'Work', 'work.unit' ); 137 | end; 138 | 139 | { TConsumerThread } 140 | 141 | constructor TConsumerThread.Create(AAMQP: TAMQPConnection; AMemo: TMemo); 142 | begin 143 | FAMQP := AAMQP; 144 | FMemo := AMemo; 145 | inherited Create; 146 | end; 147 | 148 | procedure TConsumerThread.Execute; 149 | var 150 | Queue : TAMQPMessageQueue; 151 | Msg : TAMQPMessage; 152 | begin 153 | WriteLine( 'Thread starting' ); 154 | NameThreadForDebugging( 'ConsumerThread' ); 155 | Queue := TAMQPMessageQueue.Create; 156 | FChannel := FAMQP.OpenChannel; 157 | Try 158 | FChannel.BasicConsume( Queue, 'WorkQueue', 'consumer' ); 159 | Repeat 160 | Msg := Queue.Get; 161 | if Msg = nil then 162 | Terminate; 163 | if not Terminated then 164 | Begin 165 | WriteLine( 'Consumed: ' + Msg.Body.AsString[ TEncoding.ASCII ] ); 166 | Msg.Ack; 167 | Msg.Free; 168 | End; 169 | Until Terminated; 170 | Finally 171 | FChannel := nil; 172 | Queue.Free; 173 | End; 174 | WriteLine( 'Thread stopped' ); 175 | end; 176 | 177 | procedure TConsumerThread.TerminatedSet; 178 | begin 179 | inherited; 180 | if FChannel.State = cOpen then 181 | FChannel.Close; 182 | end; 183 | 184 | procedure TConsumerThread.WriteLine(Text: String); 185 | begin 186 | Queue( Procedure 187 | Begin 188 | FMemo.Lines.Add( Text ); 189 | End ); 190 | end; 191 | 192 | { TProducerThread } 193 | 194 | constructor TProducerThread.Create(AAMQP: TAMQPConnection; AMaxWork, ASleepMS: Integer); 195 | begin 196 | FAMQP := AAMQP; 197 | FMaxWork := AMaxWork; 198 | FSleepMS := ASleepMS; 199 | inherited Create; 200 | end; 201 | 202 | procedure TProducerThread.Execute; 203 | var 204 | Channel : IAMQPChannel; 205 | Work : String; 206 | Counter : Integer; 207 | begin 208 | WriteLine( 'Thread starting' ); 209 | NameThreadForDebugging( 'ProducerThread' ); 210 | Counter := 1; 211 | Channel := FAMQP.OpenChannel; 212 | Try 213 | Repeat 214 | Work := 'Work unit ' + Counter.ToString; 215 | WriteLine( 'Produced: ' + Work ); 216 | Channel.BasicPublish( 'Work', 'work.unit', Work ); 217 | Inc( Counter ); 218 | Sleep( FSleepMS ); 219 | Until Terminated or (Counter > FMaxWork); 220 | Finally 221 | Channel := nil; 222 | End; 223 | WriteLine( 'Thread stopped' ); 224 | end; 225 | 226 | procedure TProducerThread.WriteLine(Text: String); 227 | begin 228 | Queue( Procedure 229 | Begin 230 | ThreadSampleForm.MemoProducer.Lines.Add( Text ); 231 | End ); 232 | end; 233 | 234 | end. 235 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.Arguments.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.Arguments; 2 | 3 | interface 4 | 5 | Const 6 | AMQP_TTL_SECOND = 1000; 7 | AMQP_TTL_MINUTE = AMQP_TTL_SECOND * 60; 8 | AMQP_TTL_HOUR = AMQP_TTL_MINUTE * 60; 9 | AMQP_TTL_DAY = AMQP_TTL_HOUR * 24; 10 | 11 | Type 12 | TArgument = Record 13 | Name: String; 14 | Value: Variant; 15 | End; 16 | 17 | TArguments = Array of TArgument; 18 | 19 | TArgumentHelper = Record Helper for TArguments 20 | Function Add( Name: String; Value: Variant ): TArguments; 21 | Function SetMessageTTL( TimeToLiveMS: Int64 ): TArguments; 22 | End; 23 | 24 | Function MakeArguments: TArguments; overload; 25 | Function MakeArguments( Name: String; Value: Variant ): TArguments; overload; 26 | 27 | implementation 28 | 29 | Function MakeArguments( Name: String; Value: Variant ): TArguments; 30 | var 31 | Arg: TArgument; 32 | Begin 33 | Arg.Name := Name; 34 | Arg.Value := Value; 35 | Result := [ Arg ]; 36 | End; 37 | 38 | Function MakeArguments: TArguments; 39 | Begin 40 | Result := []; 41 | End; 42 | 43 | { TArgumentHelper } 44 | 45 | function TArgumentHelper.Add(Name: String; Value: Variant): TArguments; 46 | begin 47 | Result := self + MakeArguments( Name, Value ); 48 | end; 49 | 50 | function TArgumentHelper.SetMessageTTL(TimeToLiveMS: Int64): TArguments; 51 | begin 52 | Result := MakeArguments( 'x-message-ttl', TimeToLiveMS ); 53 | end; 54 | 55 | end. 56 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.Classes.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.Classes; 2 | 3 | interface 4 | 5 | Uses 6 | System.SysUtils, System.Classes, System.SyncObjs, System.Generics.Collections, 7 | AMQP.Frame, AMQP.Message, AMQP.Method, AMQP.Types; 8 | 9 | Type 10 | AMQPException = Class(Exception); 11 | 12 | TAMQPServerProperties = Class 13 | Strict Private 14 | FCapabilities : TStringList; 15 | FMechanisms : TStringList; 16 | FLocales : TStringList; 17 | FClusterName : String; 18 | FCopyright : String; 19 | FInformation : String; 20 | FPlatform : String; 21 | FProduct : String; 22 | FVersion : String; 23 | FKnownHosts : String; 24 | FVersionMajor : Integer; 25 | FVersionMinor : Integer; 26 | FChannelMax : Integer; 27 | FFrameMax : Integer; 28 | FHeartbeat : Integer; 29 | Public 30 | Property Capabilities : TStringList read FCapabilities; 31 | Property Mechanisms : TStringList read FMechanisms; 32 | Property Locales : TStringList read FLocales; 33 | Property ClusterName : String read FClusterName; 34 | Property Copyright : String read FCopyright; 35 | Property Information : String read FInformation; 36 | Property &Platform : String read FPlatform; 37 | Property Product : String read FProduct; 38 | Property Version : String read FVersion; 39 | Property KnownHosts : String read FKnownHosts; 40 | Property ProtocolVersionMajor : Integer read FVersionMajor; 41 | Property ProtocolVersionMinor : Integer read FVersionMinor; 42 | Property ChannelMax : Integer read FChannelMax; 43 | Property FrameMax : Integer read FFrameMax; 44 | Property Heartbeat : Integer read FHeartbeat; 45 | 46 | Procedure ReadConnectionStart( AConnectionStart: TAMQPMethod ); 47 | Procedure ReadConnectionTune( AConnectionTune: TAMQPMethod ); 48 | Procedure ReadConnectionOpenOK( AConnectionOpenOK: TAMQPMethod ); 49 | 50 | Constructor Create; 51 | Destructor Destroy; Override; 52 | End; 53 | 54 | TBlockingQueue = Class 55 | Strict Protected 56 | FGuard : TCriticalSection; 57 | FCondition : TConditionVariableCS; 58 | FQueue : TQueue; 59 | Public 60 | Function Count: Integer; Virtual; 61 | Function Get: T; Virtual; 62 | Procedure Put( Item: T ); Virtual; 63 | 64 | Constructor Create; Virtual; 65 | Destructor Destroy; Override; 66 | End; 67 | 68 | TAMQPQueue = TBlockingQueue; 69 | 70 | TAMQPMessageQueue = TBlockingQueue; 71 | 72 | implementation 73 | 74 | { TAMQPServerProperties } 75 | 76 | constructor TAMQPServerProperties.Create; 77 | begin 78 | FCapabilities := TStringList.Create; 79 | FMechanisms := TStringList.Create; 80 | FLocales := TStringList.Create; 81 | FMechanisms.StrictDelimiter := True; 82 | FMechanisms.Delimiter := ' '; 83 | FLocales.StrictDelimiter := True; 84 | FLocales.Delimiter := ' '; 85 | FClusterName := ''; 86 | FCopyright := ''; 87 | FInformation := ''; 88 | FPlatform := ''; 89 | FProduct := ''; 90 | FVersion := ''; 91 | FKnownHosts := ''; 92 | FVersionMajor := 0; 93 | FVersionMinor := 0; 94 | FChannelMax := 0; 95 | FFrameMax := 0; 96 | FHeartbeat := 0; 97 | end; 98 | 99 | Procedure TAMQPServerProperties.ReadConnectionStart( AConnectionStart: TAMQPMethod ); 100 | var 101 | ServerProperties: TFieldTable; 102 | ServerCapabilities: TFieldTable; 103 | Pair: TFieldValuePair; 104 | begin 105 | FMechanisms.DelimitedText := AConnectionStart.Field['mechanisms'].AsLongString.Value; 106 | FLocales.DelimitedText := AConnectionStart.Field['locales'].AsLongString.Value; 107 | ServerProperties := AConnectionStart.Field['server-properties'].AsFieldTable; 108 | FVersionMajor := AConnectionStart.Field['version-major'].AsShortShortUInt.Value; 109 | FVersionMinor := AConnectionStart.Field['version-minor'].AsShortShortUInt.Value; 110 | FClusterName := ServerProperties.Field['cluster_name'].AsShortString.Value; 111 | FCopyright := ServerProperties.Field['copyright'].AsShortString.Value; 112 | FInformation := ServerProperties.Field['information'].AsShortString.Value; 113 | FPlatform := ServerProperties.Field['platform'].AsShortString.Value; 114 | FProduct := ServerProperties.Field['product'].AsShortString.Value; 115 | FVersion := ServerProperties.Field['version'].AsShortString.Value; 116 | ServerCapabilities := ServerProperties.Field['capabilities'].AsFieldTable; 117 | for Pair in ServerCapabilities do 118 | FCapabilities.Values[ Pair.Name.Value ] := Pair.Value.AsString(''); 119 | end; 120 | 121 | Procedure TAMQPServerProperties.ReadConnectionTune( AConnectionTune: TAMQPMethod ); 122 | begin 123 | FChannelMax := AConnectionTune.Field['channel-max'].AsShortUInt.Value; 124 | FFrameMax := AConnectionTune.Field['frame-max'].AsLongUInt.Value; 125 | FHeartbeat := AConnectionTune.Field['heartbeat'].AsShortUInt.Value; 126 | end; 127 | 128 | Procedure TAMQPServerProperties.ReadConnectionOpenOK( AConnectionOpenOK: TAMQPMethod ); 129 | begin 130 | FKnownHosts := AConnectionOpenOK.Field['known-hosts'].AsShortString.Value; 131 | end; 132 | 133 | destructor TAMQPServerProperties.Destroy; 134 | begin 135 | FCapabilities.Free; 136 | FMechanisms.Free; 137 | FLocales.Free; 138 | inherited; 139 | end; 140 | 141 | { TBlockingQueue } 142 | 143 | function TBlockingQueue.Count: Integer; 144 | begin 145 | FGuard.Acquire; 146 | try 147 | Result := FQueue.Count; 148 | finally 149 | FGuard.Release; 150 | end; 151 | end; 152 | 153 | constructor TBlockingQueue.Create; 154 | begin 155 | inherited; 156 | FGuard := TCriticalSection.Create; 157 | FCondition := TConditionVariableCS.Create; 158 | FQueue := TQueue.Create; 159 | end; 160 | 161 | destructor TBlockingQueue.Destroy; 162 | begin 163 | FQueue.Free; 164 | FQueue := nil; 165 | FCondition.Free; 166 | FCondition := nil; 167 | FGuard.Free; 168 | FGuard := nil; 169 | inherited; 170 | end; 171 | 172 | function TBlockingQueue.Get: T; 173 | begin 174 | FGuard.Acquire; 175 | try 176 | while FQueue.Count = 0 do 177 | begin 178 | FCondition.WaitFor(FGuard); 179 | end; 180 | Result := FQueue.Dequeue; 181 | finally 182 | FGuard.Release; 183 | end; 184 | end; 185 | 186 | procedure TBlockingQueue.Put(Item: T); 187 | begin 188 | FGuard.Acquire; 189 | try 190 | FQueue.Enqueue( Item ); 191 | FCondition.ReleaseAll; 192 | finally 193 | FGuard.Release; 194 | end; 195 | end; 196 | 197 | end. 198 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.Frame.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.Frame; 2 | 3 | interface 4 | 5 | Uses 6 | AMQP.Payload; 7 | 8 | const 9 | FRAME_TYPE_METHOD = 1; 10 | FRAME_TYPE_HEADER = 2; 11 | FRAME_TYPE_CONTENT = 3; 12 | FRAME_TYPE_HEARTBEAT = 8; 13 | FRAME_END = $CE; 14 | FRAME_MIN_SIZE: Word = 4096; 15 | 16 | Type 17 | TFrameKind = ( fkMethod = FRAME_TYPE_METHOD, 18 | fkHeader = FRAME_TYPE_HEADER, 19 | fkBody = FRAME_TYPE_CONTENT, 20 | fkHeartbeat = FRAME_TYPE_HEARTBEAT ); 21 | 22 | IAMQPFrame = interface ['{4BE40EEF-D60D-477D-9315-3005DD6C135E}'] 23 | Function Kind : TFrameKind; 24 | Function Channel : Word; 25 | Function Size : Cardinal; 26 | Function Payload : TAMQPPayload; 27 | Function FrameEnd : Byte; 28 | Procedure SetKind( AKind: TFrameKind ); 29 | Procedure SetChannel( AChannel: Word ); 30 | Procedure SetSize( ASize: Cardinal ); 31 | Procedure SetPayload( APayload: TAMQPPayload ); 32 | Procedure SetFrameEnd( AFrameEnd: Byte ); 33 | end; 34 | 35 | TAMQPFrame = Class( TInterfacedObject, IAMQPFrame ) 36 | Strict Private 37 | FKind : TFrameKind; 38 | FChannel : Word; 39 | FSize : Cardinal; 40 | FPayload : TAMQPPayload; 41 | FFrameEnd : Byte; 42 | Public 43 | Function Kind : TFrameKind; 44 | Function Channel : Word; 45 | Function Size : Cardinal; 46 | Function Payload : TAMQPPayload; 47 | Function FrameEnd : Byte; 48 | 49 | Procedure SetKind( AKind: TFrameKind ); 50 | Procedure SetChannel( AChannel: Word ); 51 | Procedure SetSize( ASize: Cardinal ); 52 | Procedure SetPayload( APayload: TAMQPPayload ); 53 | Procedure SetFrameEnd( AFrameEnd: Byte ); 54 | 55 | Procedure Clear; 56 | Constructor Create; 57 | Destructor Destroy; Override; 58 | End; 59 | 60 | implementation 61 | 62 | { TAMQPFrame } 63 | 64 | function TAMQPFrame.Channel: Word; 65 | begin 66 | Result := FChannel; 67 | end; 68 | 69 | procedure TAMQPFrame.Clear; 70 | begin 71 | Payload.Free; 72 | FKind := fkMethod; 73 | FChannel := 0; 74 | FSize := 0; 75 | FPayload := nil; 76 | FFrameEnd := 0; 77 | end; 78 | 79 | constructor TAMQPFrame.Create; 80 | begin 81 | FKind := fkMethod; 82 | FChannel := 0; 83 | FSize := 0; 84 | FPayload := nil; 85 | FFrameEnd := 0; 86 | end; 87 | 88 | destructor TAMQPFrame.Destroy; 89 | begin 90 | FPayload.Free; 91 | inherited; 92 | end; 93 | 94 | function TAMQPFrame.FrameEnd: Byte; 95 | begin 96 | Result := FFrameEnd; 97 | end; 98 | 99 | function TAMQPFrame.Kind: TFrameKind; 100 | begin 101 | Result := FKind; 102 | end; 103 | 104 | function TAMQPFrame.Payload: TAMQPPayload; 105 | begin 106 | Result := FPayload; 107 | end; 108 | 109 | 110 | procedure TAMQPFrame.SetChannel(AChannel: Word); 111 | begin 112 | FChannel := AChannel; 113 | end; 114 | 115 | procedure TAMQPFrame.SetFrameEnd(AFrameEnd: Byte); 116 | begin 117 | FFrameEnd := AFrameEnd; 118 | end; 119 | 120 | procedure TAMQPFrame.SetKind(AKind: TFrameKind); 121 | begin 122 | FKind := AKind; 123 | end; 124 | 125 | procedure TAMQPFrame.SetPayload(APayload: TAMQPPayload); 126 | begin 127 | FPayload := APayload; 128 | end; 129 | 130 | procedure TAMQPFrame.SetSize(ASize: Cardinal); 131 | begin 132 | FSize := ASize; 133 | end; 134 | 135 | function TAMQPFrame.Size: Cardinal; 136 | begin 137 | Result := FSize; 138 | end; 139 | 140 | end. 141 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.Header.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.Header; 2 | 3 | interface 4 | 5 | Uses 6 | System.Classes, AMQP.Payload, AMQP.IMessageProperties; 7 | 8 | Type 9 | TAMQPHeader = Class(TAMQPPayload) 10 | strict private 11 | FClassID : UInt16; 12 | FWeight : UInt16; 13 | FBodySize : UInt64; 14 | FPropertyList : IAMQPMessageProperties; 15 | Public 16 | Property ClassID : UInt16 read FClassID; 17 | Property Weight : UInt16 read FWeight; 18 | Property BodySize : UInt64 read FBodySize; 19 | Property PropertyList : IAMQPMessageProperties read FPropertyList; 20 | Procedure Assign( AHeader: TAMQPHeader ); 21 | Procedure LoadFromStream( AStream: TStream ); Override; 22 | Constructor Create; Override; 23 | Destructor Destroy; Override; 24 | End; 25 | 26 | implementation 27 | 28 | Uses 29 | AMQP.MessageProperties, AMQP.StreamHelper; 30 | 31 | { TAMQPHeader } 32 | 33 | procedure TAMQPHeader.Assign(AHeader: TAMQPHeader); 34 | begin 35 | FClassID := AHeader.ClassID; 36 | FWeight := AHeader.Weight; 37 | FBodySize := AHeader.BodySize; 38 | FPropertyList.Assign( AHeader.PropertyList ); 39 | end; 40 | 41 | constructor TAMQPHeader.Create; 42 | begin 43 | inherited; 44 | Name := 'Header'; 45 | FClassID := 0; 46 | FWeight := 0; 47 | FBodySize := 0; 48 | FPropertyList := TAMQPMessageProperties.Create( 'Delphi' ); 49 | end; 50 | 51 | destructor TAMQPHeader.Destroy; 52 | begin 53 | FPropertyList := nil; 54 | inherited; 55 | end; 56 | 57 | procedure TAMQPHeader.LoadFromStream(AStream: TStream); 58 | begin 59 | AStream.ReadUInt16( FClassID ); 60 | AStream.ReadUInt16( FWeight ); 61 | AStream.ReadUInt64( FBodySize ); 62 | FPropertyList.LoadFromStream( AStream ); 63 | end; 64 | 65 | end. 66 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.Helper.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.Helper; 2 | 3 | interface 4 | 5 | Uses 6 | AMQP.Payload, AMQP.Header, AMQP.Method; 7 | 8 | Type 9 | TAMQPPayloadHelper = Class Helper for TAMQPPayload 10 | Public 11 | Function AsMethod : TAMQPMethod; 12 | Function AsHeader : TAMQPHeader; 13 | Function AsBody : TAMQPBody; 14 | End; 15 | 16 | implementation 17 | 18 | { TAMQPPayloadHelper } 19 | 20 | function TAMQPPayloadHelper.AsBody: TAMQPBody; 21 | begin 22 | Result := Self as TAMQPBody; 23 | end; 24 | 25 | function TAMQPPayloadHelper.AsHeader: TAMQPHeader; 26 | begin 27 | Result := Self as TAMQPHeader; 28 | end; 29 | 30 | function TAMQPPayloadHelper.AsMethod: TAMQPMethod; 31 | begin 32 | Result := Self as TAMQPMethod; 33 | end; 34 | 35 | end. 36 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.IMessageProperties.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.IMessageProperties; 2 | 3 | interface 4 | 5 | Uses 6 | System.Classes, AMQP.Types; 7 | 8 | Type 9 | IAMQPMessageProperties = interface ['{2E874719-4F4E-4B62-BBD0-4F9E4C56C7CD}'] 10 | Function ContentType : TShortString; 11 | Function ContentEncoding : TShortString; 12 | Function ApplicationHeaders : TFieldTable; 13 | Function DeliveryMode : TShortShortUInt; 14 | Function Priority : TShortShortUInt; 15 | Function CorrelationID : TShortString; 16 | Function ReplyTo : TShortString; 17 | Function Expiration : TShortString; 18 | Function MessageID : TShortString; 19 | Function Timestamp : TTimestamp; 20 | Function &Type : TShortString; 21 | Function UserID : TShortString; 22 | Function AppID : TShortString; 23 | Function Reserved : TShortString; 24 | 25 | Procedure SaveToStream( AStream: TStream ); 26 | Procedure LoadFromStream( AStream: TStream ); 27 | Procedure Assign( AMessageProperties: IAMQPMessageProperties ); 28 | end; 29 | 30 | implementation 31 | 32 | end. 33 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.Interfaces.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.Interfaces; 2 | 3 | interface 4 | 5 | Uses 6 | System.SysUtils, System.Classes, AMQP.Classes, AMQP.Method, AMQP.Message, AMQP.Frame, AMQP.IMessageProperties, AMQP.Arguments; 7 | 8 | Type 9 | TAMQPChannelState = ( cOpen, cClosed ); 10 | 11 | TConsumerMethod = Reference to Procedure( AMQPMessage: TAMQPMessage; var SendAck: Boolean ); 12 | 13 | TExchangeType = ( etDirect, etTopic, etFanout, etHeaders ); 14 | 15 | Const 16 | ExchangeTypeStr : Array[TExchangeType] of string = ( 'direct', 'topic', 'fanout', 'headers' ); 17 | 18 | Type 19 | IAMQPChannel = interface(IAMQPBaseChannel) ['{6620C29F-0354-4C66-A3AC-4D5F7BB7113A}'] 20 | Function GetID : Integer; 21 | Function GetQueue : TAMQPQueue; 22 | Function GetState : TAMQPChannelState; 23 | 24 | Property ID : Integer read GetID; 25 | Property Queue : TAMQPQueue read GetQueue; 26 | Property State : TAMQPChannelState read GetState; 27 | 28 | Procedure ExchangeDeclare( AExchangeName, AType: String; APassive: Boolean = False; ADurable: Boolean = True; ANoWait: Boolean = False ); overload; 29 | Procedure ExchangeDeclare( AExchangeName: String; AType: TExchangeType; APassive: Boolean = False; ADurable: Boolean = True; ANoWait: Boolean = False ); overload; 30 | Procedure ExchangeDelete( AExchangeName: String; AIfUnused: Boolean = True; ANoWait: Boolean = False ); 31 | Procedure QueueDeclare( AQueueName: String; APassive: Boolean = False; ADurable: Boolean = True; AExclusive: Boolean = False; 32 | AAutoDelete: Boolean = False; ANoWait: Boolean = False; Arguments: TArguments = [] ); 33 | Procedure QueueBind( AQueueName, AExchangeName, ARoutingKey: String; ANoWait: Boolean = False ); 34 | Procedure QueuePurge( AQueueName: String; ANoWait: Boolean = False ); 35 | Procedure QueueDelete( AQueueName: String; AIfUnused: Boolean = True; AIfEmpty: Boolean = True; ANoWait: Boolean = False ); 36 | Procedure QueueUnBind( AQueueName, AExchangeName, ARoutingKey: String ); 37 | 38 | Procedure BasicPublish( AExchange, ARoutingKey: String; AData: TStream ); Overload; 39 | Procedure BasicPublish( AExchange, ARoutingKey: String; AData: TStream; AMandatory: Boolean ); Overload; 40 | Procedure BasicPublish( AExchange, ARoutingKey: String; AData: TStream; AMandatory: Boolean; AMessageProperties: IAMQPMessageProperties ); Overload; 41 | Procedure BasicPublish( AExchange, ARoutingKey: String; Const AData: String; AMandatory: Boolean = False ); Overload; 42 | 43 | Function BasicGet( AQueueName: String; ANoAck: Boolean = False ): TAMQPMessage; 44 | Procedure BasicAck( AMessage: TAMQPMessage; AMultiple: Boolean = False ); Overload; 45 | //Procedure BasicAck( ADeliveryTag: UInt64; AMultiple: Boolean = False ); Overload; 46 | Procedure BasicConsume( AMessageHandler: TConsumerMethod; AQueueName, AConsumerTag: String; ANoLocal: Boolean = False; 47 | ANoAck: Boolean = False; AExclusive: Boolean = False; ANoWait: Boolean = False ); Overload; 48 | Procedure BasicConsume( AMessageQueue: TAMQPMessageQueue; AQueueName, AConsumerTag: String; ANoLocal: Boolean = False; 49 | ANoAck: Boolean = False; AExclusive: Boolean = False; ANoWait: Boolean = False ); Overload; 50 | Procedure BasicCancel( AConsumerTag: String; ANoWait: Boolean = False ); 51 | Procedure BasicReject( AMessage: TAMQPMessage; ARequeue: Boolean = True ); overload; 52 | //Procedure BasicReject( ADeliveryTag: UInt64; ARequeue: Boolean = True ); overload; 53 | 54 | Procedure ConfirmSelect( ANoWait: Boolean = False ); 55 | procedure ReceiveFrame( AFrame: TAMQPFrame ); 56 | 57 | Procedure Close; 58 | Procedure ChannelClosed; 59 | end; 60 | 61 | IAMQPConnection = interface ['{4736645E-A4E1-4E3B-B1D5-BC218A6C6CCC}'] 62 | Function IsOpen: Boolean; 63 | Function DefaultMessageProperties: IAMQPMessageProperties; 64 | //Procedure WriteFrame( FrameType: Byte; Channel: Word; Payload: TStream; Size: Integer ); 65 | procedure WriteMethod( Channel: Word; Method: TAMQPMethod ); 66 | procedure WriteContent( Channel, ClassID: Word; Content: TStream; MessageProperties: IAMQPMessageProperties ); 67 | Procedure HeartbeatReceived; 68 | Procedure InternalDisconnect( CloseConnection: Boolean ); 69 | Procedure ServerDisconnect( Msg: String ); 70 | Procedure CloseChannel( Channel: IAMQPChannel ); 71 | end; 72 | 73 | implementation 74 | 75 | end. 76 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.Message.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.Message; 2 | 3 | interface 4 | 5 | Uses 6 | System.Classes, AMQP.Header, AMQP.Frame; 7 | 8 | Type 9 | IAMQPBaseChannel = interface ['{A5198398-B9DC-461B-8ECF-69A0BD0AD49E}'] 10 | Procedure BasicAck( ADeliveryTag: UInt64; AMultiple: Boolean = False ); Overload; 11 | Procedure BasicReject( ADeliveryTag: UInt64; ARequeue: Boolean = True ); overload; 12 | end; 13 | 14 | TAMQPMessage = Class 15 | Private 16 | FChannel : IAMQPBaseChannel; 17 | FDeliveryTag : UInt64; 18 | FRedelivered : Boolean; 19 | FConsumerTag : String; 20 | FExchange : String; 21 | FRoutingKey : String; 22 | FMessageCount : UInt32; 23 | FBody : TMemoryStream; 24 | FHeader : TAMQPHeader; 25 | Public 26 | Property Channel : IAMQPBaseChannel read FChannel write FChannel; 27 | Property ConsumerTag : String read FConsumerTag; 28 | Property DeliveryTag : UInt64 read FDeliveryTag; 29 | Property Redelivered : Boolean read FRedelivered; 30 | Property Exchange : String read FExchange; 31 | Property RoutingKey : String read FRoutingKey; 32 | Property MessageCount : UInt32 read FMessageCount; 33 | Property Header : TAMQPHeader read FHeader; 34 | Property Body : TMemoryStream read FBody; 35 | 36 | Procedure ReadFromData( AMethodFrame, AHeaderFrame: IAMQPFrame; var ABody: TMemoryStream ); 37 | Procedure Ack; 38 | Procedure Reject; 39 | 40 | Constructor Create; 41 | Destructor Destroy; Override; 42 | End; 43 | 44 | implementation 45 | 46 | Uses 47 | System.SysUtils, AMQP.Method, AMQP.Helper; 48 | 49 | { TAMQPMessage } 50 | 51 | procedure TAMQPMessage.Ack; 52 | begin 53 | FChannel.BasicAck( DeliveryTag ); 54 | end; 55 | 56 | constructor TAMQPMessage.Create; 57 | Begin 58 | FConsumerTag := ''; 59 | FDeliveryTag := 0; 60 | FRedelivered := False; 61 | FExchange := ''; 62 | FRoutingKey := ''; 63 | FMessageCount := 0; 64 | FChannel := nil; 65 | FHeader := TAMQPHeader.Create; 66 | FBody := TMemoryStream.Create; 67 | End; 68 | 69 | procedure TAMQPMessage.ReadFromData(AMethodFrame, AHeaderFrame: IAMQPFrame; var ABody: TMemoryStream); 70 | var 71 | AMethod: TAMQPMethod; 72 | begin 73 | //Copy GetOK properties 74 | AMethod := AMethodFrame.Payload.AsMethod; 75 | FDeliveryTag := AMethod.Field[ 'delivery-tag' ].AsLongLongUInt.Value; 76 | FRedelivered := AMethod.Field[ 'redelivered' ].AsBoolean.Value; 77 | FExchange := AMethod.Field[ 'exchange' ].AsShortString.Value; 78 | FRoutingKey := AMethod.Field[ 'routing-key' ].AsShortString.Value; 79 | if AMethod.FindField( 'consumer-tag' ) <> nil then 80 | FConsumerTag := AMethod.Field[ 'consumer-tag' ].AsShortString.Value; 81 | if AMethod.FindField( 'message-count' ) <> nil then 82 | FMessageCount := AMethod.Field[ 'message-count' ].AsLongUInt.Value; 83 | //Steal header (cheaper/faster than copying it) 84 | FHeader.Free; 85 | FHeader := AHeaderFrame.Payload.AsHeader; 86 | AHeaderFrame.SetPayload( nil ); //Steal payload 87 | //Steal body 88 | FBody.Free; 89 | FBody := ABody; 90 | ABody := nil; //Steal body 91 | FBody.Position := 0; 92 | end; 93 | 94 | procedure TAMQPMessage.Reject; 95 | begin 96 | FChannel.BasicReject( DeliveryTag ); 97 | end; 98 | 99 | destructor TAMQPMessage.Destroy; 100 | begin 101 | FBody.Free; 102 | FHeader.Free; 103 | FChannel := nil; 104 | inherited; 105 | end; 106 | 107 | end. 108 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.MessageProperties.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.MessageProperties; 2 | 3 | interface 4 | 5 | Uses 6 | System.Classes, AMQP.Types, AMQP.IMessageProperties; 7 | 8 | Type 9 | TAMQPMessageProperties = class(TInterfacedObject, IAMQPMessageProperties) 10 | Strict Private 11 | FContentType : TShortString; //MIME content type, e.g. 'application/json' 12 | FContentEncoding : TShortString; //MIME content encoding, e.g. 'utf8' 13 | FApplicationHeaders : TFieldTable; //message header field table 14 | FDeliveryMode : TShortShortUInt; //nonpersistent (1) or persistent (2) 15 | FPriority : TShortShortUInt; //message priority, 0 to 9 16 | FCorrelationID : TShortString; //application correlation identifier 17 | FReplyTo : TShortString; //address to reply to 18 | FExpiration : TShortString; //message expiration specification 19 | FMessageID : TShortString; //application message identifier 20 | FTimestamp : TTimestamp; //message timestamp 21 | FType : TShortString; //message type name 22 | FUserID : TShortString; //creating user id 23 | FAppID : TShortString; //creating application id 24 | FReserved : TShortString; //reserved, must be empty (ClusterID ?) 25 | Protected 26 | Function ContentType : TShortString; 27 | Function ContentEncoding : TShortString; 28 | Function ApplicationHeaders : TFieldTable; 29 | Function DeliveryMode : TShortShortUInt; 30 | Function Priority : TShortShortUInt; 31 | Function CorrelationID : TShortString; 32 | Function ReplyTo : TShortString; 33 | Function Expiration : TShortString; 34 | Function MessageID : TShortString; 35 | Function Timestamp : TTimestamp; 36 | Function &Type : TShortString; 37 | Function UserID : TShortString; 38 | Function AppID : TShortString; 39 | Function Reserved : TShortString; 40 | Public 41 | Procedure SaveToStream( AStream: TStream ); 42 | Procedure LoadFromStream( AStream: TStream ); 43 | Procedure Assign( AMessageProperties: IAMQPMessageProperties ); 44 | Constructor Create( const AApplicationID: String ); 45 | Destructor Destroy; Override; 46 | end; 47 | 48 | implementation 49 | 50 | Uses 51 | AMQP.StreamHelper; 52 | 53 | { TAMQPMessageProperties } 54 | 55 | procedure TAMQPMessageProperties.Assign(AMessageProperties: IAMQPMessageProperties); 56 | begin 57 | FContentType.Value := AMessageProperties.ContentType.Value; 58 | FContentEncoding.Value := AMessageProperties.ContentEncoding.Value; 59 | FApplicationHeaders.Assign( AMessageProperties.ApplicationHeaders ); 60 | FDeliveryMode.Value := AMessageProperties.DeliveryMode.Value; 61 | FPriority.Value := AMessageProperties.Priority.Value; 62 | FCorrelationID.Value := AMessageProperties.CorrelationID.Value; 63 | FReplyTo.Value := AMessageProperties.ReplyTo.Value; 64 | FExpiration.Value := AMessageProperties.Expiration.Value; 65 | FMessageID.Value := AMessageProperties.MessageID.Value; 66 | FTimestamp.Value := AMessageProperties.Timestamp.Value; 67 | FType.Value := AMessageProperties.&Type.Value; 68 | FUserID.Value := AMessageProperties.UserID.Value; 69 | FAppID.Value := AMessageProperties.AppID.Value; 70 | FReserved.Value := AMessageProperties.Reserved.Value; 71 | end; 72 | 73 | constructor TAMQPMessageProperties.Create(const AApplicationID: String); 74 | begin 75 | FContentType := TShortString.Create( 'text/plain' ); 76 | FContentEncoding := TShortString.Create( 'utf-8' ); 77 | FApplicationHeaders := TFieldTable.Create; 78 | FDeliveryMode := TShortShortUInt.Create( 2 ); 79 | FPriority := TShortShortUInt.Create( 1 ); 80 | FCorrelationID := TShortString.Create( '' ); 81 | FReplyTo := TShortString.Create( '' ); 82 | FExpiration := TShortString.Create( '' ); 83 | FMessageID := TShortString.Create( '' ); 84 | FTimestamp := TLongLongUInt.Create( 0 ); 85 | FType := TShortString.Create( '' ); 86 | FUserID := TShortString.Create( '' ); 87 | FAppID := TShortString.Create( AApplicationID ); 88 | FReserved := TShortString.Create( '' ); 89 | end; 90 | 91 | destructor TAMQPMessageProperties.Destroy; 92 | begin 93 | FContentType.Free; 94 | FContentEncoding.Free; 95 | FApplicationHeaders.Free; 96 | FDeliveryMode.Free; 97 | FPriority.Free; 98 | FCorrelationID.Free; 99 | FReplyTo.Free; 100 | FExpiration.Free; 101 | FMessageID.Free; 102 | FTimestamp.Free; 103 | FType.Free; 104 | FUserID.Free; 105 | FAppID.Free; 106 | FReserved.Free; 107 | inherited; 108 | end; 109 | 110 | function TAMQPMessageProperties.AppID: TShortString; 111 | begin 112 | Result := FAppID; 113 | end; 114 | 115 | function TAMQPMessageProperties.ApplicationHeaders: TFieldTable; 116 | begin 117 | Result := FApplicationHeaders; 118 | end; 119 | 120 | function TAMQPMessageProperties.ContentEncoding: TShortString; 121 | begin 122 | Result := FContentEncoding; 123 | end; 124 | 125 | function TAMQPMessageProperties.ContentType: TShortString; 126 | begin 127 | Result := FContentType; 128 | end; 129 | 130 | function TAMQPMessageProperties.CorrelationID: TShortString; 131 | begin 132 | Result := FCorrelationID; 133 | end; 134 | 135 | function TAMQPMessageProperties.DeliveryMode: TShortShortUInt; 136 | begin 137 | Result := FDeliveryMode; 138 | end; 139 | 140 | function TAMQPMessageProperties.Expiration: TShortString; 141 | begin 142 | Result := FExpiration; 143 | end; 144 | 145 | function TAMQPMessageProperties.MessageID: TShortString; 146 | begin 147 | Result := FMessageID; 148 | end; 149 | 150 | function TAMQPMessageProperties.Priority: TShortShortUInt; 151 | begin 152 | Result := FPriority; 153 | end; 154 | 155 | function TAMQPMessageProperties.ReplyTo: TShortString; 156 | begin 157 | Result := FReplyTo; 158 | end; 159 | 160 | function TAMQPMessageProperties.Reserved: TShortString; 161 | begin 162 | Result := FReplyTo; 163 | end; 164 | 165 | function TAMQPMessageProperties.Timestamp: TTimestamp; 166 | begin 167 | Result := FTimestamp; 168 | end; 169 | 170 | function TAMQPMessageProperties.&Type: TShortString; 171 | begin 172 | Result := FType; 173 | end; 174 | 175 | function TAMQPMessageProperties.UserID: TShortString; 176 | begin 177 | Result := FUserID; 178 | end; 179 | 180 | procedure TAMQPMessageProperties.LoadFromStream(AStream: TStream); 181 | var 182 | Flags: UInt16; 183 | begin 184 | AStream.ReadUInt16( Flags ); 185 | if Flags and $8000 = $8000 then FContentType.LoadFromStream( AStream ); 186 | if Flags and $4000 = $4000 then FContentEncoding.LoadFromStream( AStream ); 187 | if Flags and $2000 = $2000 then FApplicationHeaders.LoadFromStream( AStream ); 188 | if Flags and $1000 = $1000 then FDeliveryMode.LoadFromStream( AStream ); 189 | if Flags and $0800 = $0800 then FPriority.LoadFromStream( AStream ); 190 | if Flags and $0400 = $0400 then FCorrelationID.LoadFromStream( AStream ); 191 | if Flags and $0200 = $0200 then FReplyTo.LoadFromStream( AStream ); 192 | if Flags and $0100 = $0100 then FExpiration.LoadFromStream( AStream ); 193 | if Flags and $0080 = $0080 then FMessageID.LoadFromStream( AStream ); 194 | if Flags and $0040 = $0040 then FTimestamp.LoadFromStream( AStream ); 195 | if Flags and $0020 = $0020 then FType.LoadFromStream( AStream ); 196 | if Flags and $0010 = $0010 then FUserID.LoadFromStream( AStream ); 197 | if Flags and $0008 = $0008 then FAppID.LoadFromStream( AStream ); 198 | if Flags and $0004 = $0004 then FReserved.LoadFromStream( AStream ); 199 | end; 200 | 201 | procedure TAMQPMessageProperties.SaveToStream(AStream: TStream); 202 | var 203 | PropertyFlags: UInt16; 204 | Data: TMemoryStream; 205 | 206 | Procedure SaveField( ASaveField: Boolean; ABit: Byte; AValue: TAMQPValue ); 207 | Begin 208 | if ASaveField then 209 | Begin 210 | PropertyFlags := PropertyFlags + 1 shl ABit; 211 | AValue.SaveToStream( Data ); 212 | End; 213 | End; 214 | 215 | begin 216 | PropertyFlags := 0; 217 | Data := TMemoryStream.Create; 218 | Try 219 | SaveField( ContentType.Value <> '', 15, ContentType ); 220 | SaveField( ContentEncoding.Value <> '', 14, ContentEncoding ); 221 | SaveField( ApplicationHeaders.Count <> 0, 13, ApplicationHeaders ); 222 | SaveField( DeliveryMode.Value <> 0, 12, DeliveryMode ); 223 | SaveField( Priority.Value <> 0, 11, Priority ); 224 | SaveField( CorrelationID.Value <> '', 10, CorrelationID ); 225 | SaveField( ReplyTo.Value <> '', 9, ReplyTo ); 226 | SaveField( Expiration.Value <> '', 8, Expiration ); 227 | SaveField( MessageID.Value <> '', 7, MessageID ); 228 | SaveField( Timestamp.Value <> 0, 6, Timestamp ); 229 | SaveField( FType.Value <> '', 5, FType ); 230 | SaveField( UserID.Value <> '', 4, UserID ); 231 | SaveField( AppID.Value <> '', 3, AppID ); 232 | SaveField( Reserved.Value <> '', 2, Reserved ); 233 | 234 | AStream.WriteUInt16( PropertyFlags ); 235 | AStream.CopyFrom( Data, 0 ); 236 | Finally 237 | Data.Free; 238 | End; 239 | end; 240 | 241 | end. 242 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.Payload.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.Payload; 2 | 3 | interface 4 | 5 | Uses 6 | System.Classes; 7 | 8 | Type 9 | TAMQPPayload = Class 10 | strict private 11 | FName: String; 12 | Public 13 | Property Name: String read FName write FName; 14 | Procedure LoadFromStream( AStream: TStream ); Virtual; Abstract; 15 | Constructor Create; Virtual; 16 | End; 17 | 18 | TAMQPBody = Class( TAMQPPayload ) 19 | strict private 20 | FStream: TMemoryStream; 21 | Public 22 | Property Stream: TMemoryStream read FStream; 23 | Procedure LoadFromStream( AStream: TStream ); Override; 24 | Constructor Create; Override; 25 | Destructor Destroy; Override; 26 | End; 27 | 28 | implementation 29 | 30 | { TAMQPPayload } 31 | 32 | constructor TAMQPPayload.Create; 33 | begin 34 | FName := ''; 35 | end; 36 | 37 | { TAMQPBody } 38 | 39 | constructor TAMQPBody.Create; 40 | begin 41 | inherited; 42 | FStream := TMemoryStream.Create; 43 | end; 44 | 45 | destructor TAMQPBody.Destroy; 46 | begin 47 | FStream.Free; 48 | inherited; 49 | end; 50 | 51 | procedure TAMQPBody.LoadFromStream(AStream: TStream); 52 | begin 53 | FStream.Clear; 54 | FStream.CopyFrom( AStream, AStream.Size - AStream.Position ); 55 | FStream.Position := 0; 56 | end; 57 | 58 | end. 59 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.Protocol.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.Protocol; 2 | 3 | interface 4 | 5 | Uses 6 | IdGlobal; 7 | 8 | Type 9 | TAMQPMethodID = Record 10 | ClassID : UInt16; 11 | MethodID : UInt16; 12 | End; 13 | 14 | Const 15 | AMQP_Header: TIdBytes = [65, 77, 81, 80, 0, 0, 9, 1]; //'AMQP' + #0 + #0 + #9 + #1 16 | 17 | AMQP_CLASS_CONNECTION = 10; 18 | AMQP_CLASS_CHANNEL = 20; 19 | AMQP_CLASS_EXCHANGE = 40; 20 | AMQP_CLASS_QUEUE = 50; 21 | AMQP_CLASS_BASIC = 60; 22 | AMQP_CLASS_CONFIRM = 85; 23 | AMQP_CLASS_TX = 90; 24 | 25 | AMQP_CONNECTION_START : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 10 ); 26 | AMQP_CONNECTION_START_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 11 ); 27 | AMQP_CONNECTION_SECURE : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 20 ); 28 | AMQP_CONNECTION_SECURE_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 21 ); 29 | AMQP_CONNECTION_TUNE : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 30 ); 30 | AMQP_CONNECTION_TUNE_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 31 ); 31 | AMQP_CONNECTION_OPEN : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 40 ); 32 | AMQP_CONNECTION_OPEN_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 41 ); 33 | AMQP_CONNECTION_CLOSE : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 50 ); 34 | AMQP_CONNECTION_CLOSE_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONNECTION; MethodID: 51 ); 35 | 36 | AMQP_CHANNEL_OPEN : TAMQPMethodID = ( ClassID: AMQP_CLASS_CHANNEL; MethodID: 10 ); 37 | AMQP_CHANNEL_OPEN_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_CHANNEL; MethodID: 11 ); 38 | AMQP_CHANNEL_FLOW : TAMQPMethodID = ( ClassID: AMQP_CLASS_CHANNEL; MethodID: 20 ); //TODO 39 | AMQP_CHANNEL_FLOW_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_CHANNEL; MethodID: 21 ); //TODO 40 | AMQP_CHANNEL_CLOSE : TAMQPMethodID = ( ClassID: AMQP_CLASS_CHANNEL; MethodID: 40 ); 41 | AMQP_CHANNEL_CLOSE_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_CHANNEL; MethodID: 41 ); 42 | 43 | AMQP_EXCHANGE_DECLARE : TAMQPMethodID = ( ClassID: AMQP_CLASS_EXCHANGE; MethodID: 10 ); 44 | AMQP_EXCHANGE_DECLARE_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_EXCHANGE; MethodID: 11 ); 45 | AMQP_EXCHANGE_DELETE : TAMQPMethodID = ( ClassID: AMQP_CLASS_EXCHANGE; MethodID: 20 ); 46 | AMQP_EXCHANGE_DELETE_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_EXCHANGE; MethodID: 21 ); 47 | 48 | AMQP_QUEUE_DECLARE : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 10 ); 49 | AMQP_QUEUE_DECLARE_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 11 ); 50 | AMQP_QUEUE_BIND : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 20 ); 51 | AMQP_QUEUE_BIND_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 21 ); 52 | AMQP_QUEUE_UNBIND : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 50 ); 53 | AMQP_QUEUE_UNBIND_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 51 ); 54 | AMQP_QUEUE_PURGE : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 30 ); 55 | AMQP_QUEUE_PURGE_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 31 ); 56 | AMQP_QUEUE_DELETE : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 40 ); 57 | AMQP_QUEUE_DELETE_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_QUEUE; MethodID: 41 ); 58 | 59 | AMQP_BASIC_QOS : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 10 ); //TODO 60 | AMQP_BASIC_QOS_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 11 ); //TODO 61 | AMQP_BASIC_CONSUME : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 20 ); 62 | AMQP_BASIC_CONSUME_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 21 ); 63 | AMQP_BASIC_CANCEL : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 30 ); 64 | AMQP_BASIC_CANCEL_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 31 ); 65 | AMQP_BASIC_PUBLISH : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 40 ); 66 | AMQP_BASIC_RETURN : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 50 ); 67 | AMQP_BASIC_DELIVER : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 60 ); 68 | AMQP_BASIC_GET : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 70 ); 69 | AMQP_BASIC_GET_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 71 ); 70 | AMQP_BASIC_GET_EMPTY : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 72 ); 71 | AMQP_BASIC_ACK : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 80 ); 72 | AMQP_BASIC_REJECT : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 90 ); 73 | AMQP_BASIC_RECOVER_ASYNC : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 100 ); //TODO 74 | AMQP_BASIC_RECOVER : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 110 ); //TODO 75 | AMQP_BASIC_RECOVER_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_BASIC; MethodID: 111 ); //TODO 76 | 77 | AMQP_CONFIRM_SELECT : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONFIRM; MethodID: 10 ); 78 | AMQP_CONFIRM_SELECT_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_CONFIRM; MethodID: 11 ); 79 | 80 | AMQP_TX_SELECT : TAMQPMethodID = ( ClassID: AMQP_CLASS_TX; MethodID: 10 ); //TODO 81 | AMQP_TX_SELECT_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_TX; MethodID: 11 ); //TODO 82 | AMQP_TX_COMMIT : TAMQPMethodID = ( ClassID: AMQP_CLASS_TX; MethodID: 20 ); //TODO 83 | AMQP_TX_COMMIT_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_TX; MethodID: 21 ); //TODO 84 | AMQP_TX_ROLLBACK : TAMQPMethodID = ( ClassID: AMQP_CLASS_TX; MethodID: 30 ); //TODO 85 | AMQP_TX_ROLLBACK_OK : TAMQPMethodID = ( ClassID: AMQP_CLASS_TX; MethodID: 31 ); //TODO 86 | 87 | // CONTENT_METHODS : array[0..3] of TAMQPMethodID = ( 88 | // AMQP_BASIC_PUBLISH, 89 | // AMQP_BASIC_RETURN, 90 | // AMQP_BASIC_DELIVER, 91 | // AMQP_BASIC_GET_OK 92 | // ); 93 | 94 | implementation 95 | 96 | end. 97 | -------------------------------------------------------------------------------- /AMQP/Source/AMQP.StreamHelper.pas: -------------------------------------------------------------------------------- 1 | unit AMQP.StreamHelper; 2 | 3 | interface 4 | 5 | Uses 6 | System.SysUtils, System.Classes, IdGlobal; 7 | 8 | Type 9 | TStreamHelper = Class helper for TStream 10 | Private 11 | function GetAsString(AEncoding: TEncoding): String; 12 | procedure SetAsString(AEncoding: TEncoding; const Value: String); 13 | Public 14 | Procedure WriteMSB( var Buffer; Count: Cardinal ); 15 | Procedure WriteOctet( B: Byte ); 16 | Procedure WriteUInt8( I: UInt8 ); 17 | Procedure WriteUInt16( I: UInt16 ); 18 | Procedure WriteUInt32( I: UInt32 ); 19 | Procedure WriteUInt64( I: UInt64 ); 20 | Procedure WriteInt8( I: Int8 ); 21 | Procedure WriteInt16( I: Int16 ); 22 | Procedure WriteInt32( I: Int32 ); 23 | Procedure WriteInt64( I: Int64 ); 24 | Procedure WriteShortStr( S: String ); 25 | Procedure ReadMSB( var Buffer; Count: Integer ); 26 | Procedure ReadOctet( var B: Byte ); 27 | Procedure ReadUInt8( var I: UInt8 ); 28 | Procedure ReadUInt16( var I: UInt16 ); 29 | Procedure ReadUInt32( var I: UInt32 ); 30 | Procedure ReadUInt64( var I: UInt64 ); 31 | Procedure ReadInt8( var I: Int8 ); 32 | Procedure ReadInt16( var I: Int16 ); 33 | Procedure ReadInt32( var I: Int32 ); 34 | Procedure ReadInt64( var I: Int64 ); 35 | Procedure ReadShortStr( var S: String ); 36 | Procedure ReadLongStr( var S: String ); 37 | Function AsBytes: TIdBytes; 38 | Property AsString[ Encoding: TEncoding ]: String read GetAsString write SetAsString; 39 | End; 40 | 41 | implementation 42 | 43 | { TStreamHelper } 44 | 45 | function TStreamHelper.AsBytes: TIdBytes; 46 | var 47 | OldPosition: Integer; 48 | begin 49 | OldPosition := Position; 50 | Position := 0; 51 | SetLength( Result, Size ); 52 | ReadBuffer( Result[0], Size ); 53 | Position := OldPosition; 54 | end; 55 | 56 | function TStreamHelper.GetAsString(AEncoding: TEncoding): String; 57 | var 58 | StringStream: TStringStream; 59 | begin 60 | StringStream := TStringStream.Create( '', AEncoding ); 61 | Try 62 | StringStream.CopyFrom( Self, -1 ); 63 | Result := StringStream.DataString; 64 | Finally 65 | StringStream.Free; 66 | End; 67 | end; 68 | 69 | procedure TStreamHelper.ReadInt16(var I: Int16); 70 | begin 71 | ReadMSB( I, 2 ); 72 | end; 73 | 74 | procedure TStreamHelper.ReadInt32(var I: Int32); 75 | begin 76 | ReadMSB( I, 4 ); 77 | end; 78 | 79 | procedure TStreamHelper.ReadInt64(var I: Int64); 80 | begin 81 | ReadMSB( I, 8 ); 82 | end; 83 | 84 | procedure TStreamHelper.ReadInt8(var I: Int8); 85 | begin 86 | Read( I, 1 ); 87 | end; 88 | 89 | procedure TStreamHelper.ReadLongStr(var S: String); 90 | var 91 | Str: AnsiString; 92 | Len: UInt32; 93 | begin 94 | ReadUInt32( Len ); 95 | SetLength( Str, Len ); 96 | if Len > 0 then 97 | Read( Str[1], Len ); 98 | S := String( Str ); 99 | end; 100 | 101 | Procedure TStreamHelper.ReadMSB(var Buffer; Count: Integer); 102 | var 103 | Cnt: Integer; 104 | begin 105 | For Cnt := 0 to Count-1 do 106 | Read( PByteArray(@Buffer)[Count - Cnt - 1], 1 ); 107 | end; 108 | 109 | procedure TStreamHelper.ReadOctet(var B: Byte); 110 | begin 111 | Read( B, 1 ); 112 | end; 113 | 114 | procedure TStreamHelper.ReadShortStr(var S: String); 115 | var 116 | Str: AnsiString; 117 | Len: Byte; 118 | begin 119 | ReadUInt8( Len ); 120 | SetLength( Str, Len ); 121 | if Len > 0 then 122 | Read( Str[1], Len ); 123 | S := String( Str ); 124 | end; 125 | 126 | procedure TStreamHelper.ReadUInt16(var I: UInt16); 127 | begin 128 | ReadMSB( I, 2 ); 129 | end; 130 | 131 | procedure TStreamHelper.ReadUInt32(var I: UInt32); 132 | begin 133 | ReadMSB( I, 4 ); 134 | end; 135 | 136 | procedure TStreamHelper.ReadUInt64(var I: UInt64); 137 | begin 138 | ReadMSB( I, 8 ); 139 | end; 140 | 141 | procedure TStreamHelper.ReadUInt8(var I: UInt8); 142 | begin 143 | Read( I, 1 ); 144 | end; 145 | 146 | procedure TStreamHelper.SetAsString(AEncoding: TEncoding; const Value: String); 147 | var 148 | StringStream: TStringStream; 149 | begin 150 | StringStream := TStringStream.Create( Value, AEncoding ); 151 | Try 152 | Self.CopyFrom( StringStream, -1 ); 153 | Finally 154 | StringStream.Free; 155 | End; 156 | end; 157 | 158 | procedure TStreamHelper.WriteInt16(I: Int16); 159 | begin 160 | WriteMSB( I, 2 ); 161 | end; 162 | 163 | procedure TStreamHelper.WriteInt32(I: Int32); 164 | begin 165 | WriteMSB( I, 4 ); 166 | end; 167 | 168 | procedure TStreamHelper.WriteInt64(I: Int64); 169 | begin 170 | WriteMSB( I, 8 ); 171 | end; 172 | 173 | procedure TStreamHelper.WriteInt8(I: Int8); 174 | begin 175 | WriteMSB( I, 1 ); 176 | end; 177 | 178 | procedure TStreamHelper.WriteMSB(var Buffer; Count: Cardinal); 179 | var 180 | Index: Integer; 181 | begin 182 | For Index := Count-1 downto 0 do 183 | WriteData( PByteArray(@Buffer)[Index], 1 ); 184 | end; 185 | 186 | procedure TStreamHelper.WriteOctet(B: Byte); 187 | begin 188 | WriteMSB( B, 1 ); 189 | end; 190 | 191 | procedure TStreamHelper.WriteShortStr(S: String); 192 | var 193 | Char: AnsiChar; 194 | Str: AnsiString; 195 | B: Byte; 196 | begin 197 | B := S.Length; 198 | Str := AnsiString( S ); 199 | WriteData( B ); 200 | for Char in Str do 201 | WriteData( Char ); 202 | end; 203 | 204 | procedure TStreamHelper.WriteUInt64(I: UInt64); 205 | begin 206 | WriteMSB( I, 8 ); 207 | end; 208 | 209 | procedure TStreamHelper.WriteUInt16(I: UInt16); 210 | begin 211 | WriteMSB( I, 2 ); 212 | end; 213 | 214 | procedure TStreamHelper.WriteUInt32(I: UInt32); 215 | begin 216 | WriteMSB( I, 4 ); 217 | end; 218 | 219 | procedure TStreamHelper.WriteUInt8(I: UInt8); 220 | begin 221 | WriteMSB( I, 1 ); 222 | end; 223 | 224 | end. 225 | -------------------------------------------------------------------------------- /EasyDelphiQ/EasyDelphiQ.Classes.pas: -------------------------------------------------------------------------------- 1 | unit EasyDelphiQ.Classes; 2 | 3 | interface 4 | 5 | Uses 6 | System.SysUtils, AMQP.Interfaces, EasyDelphiQ.Interfaces; 7 | 8 | Type 9 | EEasyDelphiQConnectionFailed = Class(Exception); 10 | 11 | TQueue = class(TInterfacedObject, IQueue) 12 | Private 13 | FChannel: IAMQPChannel; 14 | FName: String; 15 | FTopic: String; 16 | FSubscriberID: String; 17 | FExchange: String; 18 | FClassName: String; 19 | Public 20 | Function Name: String; 21 | Function Topic: String; 22 | Function SubscriberID: String; 23 | Function Exchange: String; 24 | Function ClassName: String; 25 | Procedure Reconnect( Channel: IAMQPChannel ); 26 | Constructor Create( AChannel: IAMQPChannel; AName: String; ATopic: String; ASubscriberID: String; AExchange: String; 27 | AClassName: String ); 28 | End; 29 | 30 | TExchange = class(TInterfacedObject, IExchange) 31 | Private 32 | FChannel: IAMQPChannel; 33 | FName: String; 34 | FExchangeType: TExchangeType; 35 | Public 36 | Function Name: String; 37 | Function ExchangeType: TExchangeType; 38 | Procedure Reconnect( Channel: IAMQPChannel ); 39 | Constructor Create( AChannel: IAMQPChannel; AName: String; AExchangeType: TExchangeType ); 40 | End; 41 | 42 | TSubscriptionResult = Class(TInterfacedObject, ISubscriptionResult) 43 | Private 44 | FChannel: IAMQPChannel; 45 | FQueue: IQueue; 46 | Public 47 | Function Queue: IQueue; 48 | Procedure Cancel; 49 | Constructor Create( AChannel: IAMQPChannel; AQueue: IQueue ); 50 | End; 51 | 52 | implementation 53 | 54 | { TQueue } 55 | 56 | function TQueue.ClassName: String; 57 | begin 58 | Result := FClassName; 59 | end; 60 | 61 | constructor TQueue.Create(AChannel: IAMQPChannel; AName, ATopic, ASubscriberID, AExchange, AClassName: String); 62 | begin 63 | FChannel := AChannel; 64 | FName := AName; 65 | FTopic := ATopic; 66 | FSubscriberID := ASubscriberID; 67 | FExchange := AExchange; 68 | FClassName := AClassName; 69 | end; 70 | 71 | function TQueue.Exchange: String; 72 | begin 73 | Result := FExchange; 74 | end; 75 | 76 | function TQueue.Name: String; 77 | begin 78 | Result := FName; 79 | end; 80 | 81 | procedure TQueue.Reconnect(Channel: IAMQPChannel); 82 | begin 83 | FChannel := nil; 84 | FChannel := Channel; 85 | end; 86 | 87 | function TQueue.SubscriberID: String; 88 | begin 89 | Result := FSubscriberID; 90 | end; 91 | 92 | function TQueue.Topic: String; 93 | begin 94 | Result := FTopic; 95 | end; 96 | 97 | { TExchange } 98 | 99 | constructor TExchange.Create(AChannel: IAMQPChannel; AName: String; AExchangeType: TExchangeType); 100 | begin 101 | FChannel := AChannel; 102 | FName := AName; 103 | FExchangeType := AExchangeType; 104 | end; 105 | 106 | function TExchange.ExchangeType: TExchangeType; 107 | begin 108 | Result := FExchangeType; 109 | end; 110 | 111 | function TExchange.Name: String; 112 | begin 113 | Result := FName; 114 | end; 115 | 116 | procedure TExchange.Reconnect(Channel: IAMQPChannel); 117 | begin 118 | FChannel := nil; 119 | FChannel := Channel; 120 | end; 121 | 122 | { TSubscriptionResult } 123 | 124 | procedure TSubscriptionResult.Cancel; 125 | begin 126 | Try 127 | FChannel.BasicCancel( FQueue.SubscriberID ); 128 | Except 129 | On E: Exception do 130 | ; //If subscription does not exist then ignore (if we, for instance, have been disconnected already) 131 | End; 132 | end; 133 | 134 | constructor TSubscriptionResult.Create(AChannel: IAMQPChannel; AQueue: IQueue); 135 | begin 136 | FChannel := AChannel; 137 | FQueue := AQueue; 138 | end; 139 | 140 | function TSubscriptionResult.Queue: IQueue; 141 | begin 142 | Result := FQueue; 143 | end; 144 | 145 | end. 146 | -------------------------------------------------------------------------------- /EasyDelphiQ/EasyDelphiQ.DTO.pas: -------------------------------------------------------------------------------- 1 | unit EasyDelphiQ.DTO; 2 | 3 | interface 4 | 5 | Type 6 | AssemblyNameAttribute = class(TCustomAttribute) 7 | Private 8 | FName: String; 9 | Public 10 | property Name: String read FName write FName; 11 | constructor create(AName: String); 12 | end; 13 | 14 | TClassInformation = record 15 | Private 16 | FClassName: String; 17 | FUnitName: String; 18 | FAssemblyName: String; 19 | Function GetAssemblyNameFromRTI( Obj: TObject ): String; 20 | Public 21 | Function GetAssemblyName: String; 22 | Function GetQueueName(ASubscriberID: String): String; 23 | Function GetExchangeName: String; 24 | Function GetUnitName: String; 25 | Function GetClassName: String; 26 | Function GetFullyQualifiedClassName: String; 27 | Constructor Create( Obj: TObject ); 28 | end; 29 | 30 | implementation 31 | 32 | uses 33 | System.Rtti; 34 | 35 | { AssemblyNameAttribute } 36 | 37 | constructor AssemblyNameAttribute.create(AName: String); 38 | begin 39 | FName := AName; 40 | end; 41 | 42 | { TClassInformation } 43 | 44 | Function TClassInformation.GetAssemblyNameFromRTI( Obj: TObject ): String; 45 | var 46 | ctx: TRttiContext; 47 | T: TRttiType; 48 | A: TCustomAttribute; 49 | Begin 50 | ctx := TRttiContext.Create; 51 | Try 52 | T := ctx.GetType( obj.ClassInfo ); 53 | For A in T.GetAttributes do 54 | if A is AssemblyNameAttribute then 55 | Result := AssemblyNameAttribute(A).Name; 56 | Finally 57 | ctx.Free; 58 | End; 59 | End; 60 | 61 | constructor TClassInformation.Create(Obj: TObject); 62 | begin 63 | FUnitName := Obj.UnitName; 64 | FClassName := Obj.ClassName; 65 | FAssemblyName := GetAssemblyNameFromRTI( Obj ); 66 | end; 67 | 68 | function TClassInformation.GetAssemblyName: String; 69 | begin 70 | Result := FAssemblyName; 71 | end; 72 | 73 | function TClassInformation.GetClassName: String; 74 | begin 75 | Result := FClassName; 76 | end; 77 | 78 | function TClassInformation.GetExchangeName: String; 79 | begin 80 | Result := GetFullyQualifiedClassName + ':' + FAssemblyName; 81 | end; 82 | 83 | function TClassInformation.GetFullyQualifiedClassName: String; 84 | begin 85 | Result := FUnitName + '.' + FClassName; 86 | end; 87 | 88 | function TClassInformation.GetQueueName(ASubscriberID: String): String; 89 | begin 90 | Result := FUnitName + '_' + FClassName + ':' + FAssemblyName + '_' + ASubscriberID; 91 | end; 92 | 93 | function TClassInformation.GetUnitName: String; 94 | begin 95 | Result := FUnitName; 96 | end; 97 | 98 | end. 99 | -------------------------------------------------------------------------------- /EasyDelphiQ/EasyDelphiQ.Interfaces.pas: -------------------------------------------------------------------------------- 1 | unit EasyDelphiQ.Interfaces; 2 | 3 | interface 4 | 5 | Uses 6 | AMQP.Interfaces; 7 | 8 | Type 9 | IQueue = Interface ['{B6686F6E-3772-47C8-A30C-6FC26AB12084}'] 10 | Function Name: String; 11 | Function Topic: String; 12 | Function SubscriberID: String; 13 | Function Exchange: String; 14 | Function ClassName: String; 15 | Procedure Reconnect( Channel: IAMQPChannel ); 16 | End; 17 | 18 | IExchange = Interface ['{58CB0E85-5E41-475D-BBCE-C7DCFA401AA9}'] 19 | Function Name: String; 20 | Function ExchangeType: TExchangeType; 21 | Procedure Reconnect( Channel: IAMQPChannel ); 22 | End; 23 | 24 | ISubscriptionResult = Interface ['{6B4F0D36-EE7C-47EC-92B9-4A7222476054}'] 25 | Function Queue: IQueue; 26 | Procedure Cancel; 27 | End; 28 | 29 | 30 | implementation 31 | 32 | end. 33 | -------------------------------------------------------------------------------- /EasyDelphiQ/Testbench/MainWin.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'QTestbench' 5 | ClientHeight = 337 6 | ClientWidth = 635 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | OnCreate = FormCreate 15 | OnDestroy = FormDestroy 16 | DesignSize = ( 17 | 635 18 | 337) 19 | PixelsPerInch = 96 20 | TextHeight = 13 21 | object ButtonPublish: TButton 22 | Left = 8 23 | Top = 8 24 | Width = 75 25 | Height = 25 26 | Caption = 'Publish' 27 | TabOrder = 0 28 | OnClick = ButtonPublishClick 29 | end 30 | object Memo1: TMemo 31 | Left = 8 32 | Top = 64 33 | Width = 619 34 | Height = 265 35 | Anchors = [akLeft, akTop, akRight, akBottom] 36 | ScrollBars = ssVertical 37 | TabOrder = 1 38 | end 39 | object ButtonGet: TButton 40 | Left = 89 41 | Top = 8 42 | Width = 75 43 | Height = 25 44 | Caption = 'Get' 45 | TabOrder = 2 46 | OnClick = ButtonGetClick 47 | end 48 | object ButtonSubscribe: TButton 49 | Left = 170 50 | Top = 8 51 | Width = 115 52 | Height = 25 53 | Caption = 'Subscribe TestDTO' 54 | TabOrder = 3 55 | OnClick = ButtonSubscribeClick 56 | end 57 | object ButtonCancelSubscription: TButton 58 | Left = 291 59 | Top = 8 60 | Width = 118 61 | Height = 25 62 | Caption = 'Cancel subscription' 63 | TabOrder = 4 64 | OnClick = ButtonCancelSubscriptionClick 65 | end 66 | object SubscribeTimeseries: TButton 67 | Left = 170 68 | Top = 33 69 | Width = 115 70 | Height = 25 71 | Caption = 'Subscribe Timeseries' 72 | TabOrder = 5 73 | OnClick = SubscribeTimeseriesClick 74 | end 75 | end 76 | -------------------------------------------------------------------------------- /EasyDelphiQ/Testbench/MainWin.pas: -------------------------------------------------------------------------------- 1 | unit MainWin; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, EasyDelphiQ, EasyDelphiQ.Interfaces, Some.namespace, 8 | Neas.PowermanApi.Notifications.DTOs.V1, System.Generics.Collections; 9 | 10 | type 11 | TMainForm = class(TForm) 12 | ButtonPublish: TButton; 13 | Memo1: TMemo; 14 | ButtonGet: TButton; 15 | ButtonSubscribe: TButton; 16 | ButtonCancelSubscription: TButton; 17 | SubscribeTimeseries: TButton; 18 | procedure ButtonPublishClick(Sender: TObject); 19 | procedure FormCreate(Sender: TObject); 20 | procedure FormDestroy(Sender: TObject); 21 | procedure ButtonGetClick(Sender: TObject); 22 | procedure ButtonSubscribeClick(Sender: TObject); 23 | procedure ButtonCancelSubscriptionClick(Sender: TObject); 24 | procedure SubscribeTimeseriesClick(Sender: TObject); 25 | private 26 | FBus: TBus; 27 | FBusPM: TBus; 28 | FSubscription: ISubscriptionResult; 29 | FSubscriptionPM: ISubscriptionResult; 30 | FList: TThreadList; 31 | Procedure BusConnected(Sender: TObject); 32 | Procedure BusDisconnected(Sender: TObject); 33 | Procedure Handler( var Msg: TestDTO ); 34 | Procedure HandlerPM( var Msg: ProductionGroupDataSerieCollectionV1 ); 35 | Procedure WMUSER(var Msg: TMessage); Message WM_USER; 36 | procedure ReadMessagesFromList; 37 | public 38 | end; 39 | 40 | var 41 | MainForm: TMainForm; 42 | 43 | implementation 44 | 45 | Uses 46 | EasyDelphiQ.DTO, AMQP.Arguments, DJSON; 47 | 48 | {$R *.dfm} 49 | 50 | procedure TMainForm.BusConnected(Sender: TObject); 51 | begin 52 | Memo1.Lines.Add( 'Connected' ); 53 | end; 54 | 55 | procedure TMainForm.BusDisconnected(Sender: TObject); 56 | begin 57 | Memo1.Lines.Add( 'Disconnected' ); 58 | end; 59 | 60 | procedure TMainForm.ButtonPublishClick(Sender: TObject); 61 | var 62 | DTO: TestDTO; 63 | begin 64 | DTO := TestDTO.Create; 65 | Try 66 | DTO.ID := 42; 67 | DTO.Name := 'Zaphod'; 68 | FBus.Publish( DTO ); 69 | Memo1.Lines.Add( 'Message published' ); 70 | Finally 71 | DTO.Free; 72 | End; 73 | end; 74 | 75 | procedure TMainForm.ButtonGetClick(Sender: TObject); 76 | var 77 | DTO: TestDTO; 78 | begin 79 | DTO := FBus.Get( 'Testbench' ); 80 | if DTO = nil then 81 | Memo1.Lines.Add( 'No message' ) 82 | else 83 | Try 84 | Memo1.Lines.Add( 'Received:' ); 85 | Memo1.Lines.Add( ' DTO.ID: ' + DTO.ID.ToString ); 86 | Memo1.Lines.Add( ' DTO.Name: ' + DTO.Name ); 87 | Finally 88 | DTO.Free; 89 | End; 90 | end; 91 | 92 | procedure TMainForm.ButtonSubscribeClick(Sender: TObject); 93 | begin 94 | FSubscription := FBus.Subscribe( 'Testbench', Handler, MakeArguments.SetMessageTTL( 30000 ) ); 95 | end; 96 | 97 | procedure TMainForm.ButtonCancelSubscriptionClick(Sender: TObject); 98 | begin 99 | FSubscription.Cancel; 100 | FSubscription := nil; 101 | end; 102 | 103 | procedure TMainForm.FormCreate(Sender: TObject); 104 | begin 105 | ReportMemoryLeaksOnShutdown := True; 106 | FBus := RabbitHutch.CreateBus( 'host=localhost;username=TestUser;password=password' ); 107 | FBus.OnConnected := BusConnected; 108 | FBus.OnDisconnected := BusDisconnected; 109 | FSubscription := nil; 110 | 111 | FBusPM := RabbitHutch.CreateBus( 'host=rabbitmq_test;username=rabbit;password=rabbit' ); 112 | FBusPM.OnConnected := BusConnected; 113 | FBusPM.OnDisconnected := BusDisconnected; 114 | FSubscriptionPM := nil; 115 | 116 | FList := TThreadList.Create; 117 | end; 118 | 119 | procedure TMainForm.FormDestroy(Sender: TObject); 120 | begin 121 | FBus.Free; 122 | FBusPM.Free; 123 | FList.Free; 124 | end; 125 | 126 | procedure TMainForm.Handler(var Msg: TestDTO); 127 | var 128 | DTO: TestDTO; 129 | begin 130 | DTO := Msg; //Necessary to capture the object in the anonymous method below 131 | TThread.Queue( nil, 132 | Procedure 133 | begin 134 | Memo1.Lines.Add( 'Received:' ); 135 | Memo1.Lines.Add( ' DTO.ID: ' + DTO.ID.ToString ); 136 | Memo1.Lines.Add( ' DTO.Name: ' + DTO.Name ); 137 | DTO.Free; //Free the object here - we are done with it 138 | end ); 139 | Msg := nil; //Don't free the object here 140 | end; 141 | 142 | procedure TMainForm.HandlerPM(var Msg: ProductionGroupDataSerieCollectionV1); 143 | begin 144 | FList.Add( Msg ); 145 | Msg := nil; 146 | PostMessage( Handle, WM_USER, 0, 0 ) 147 | end; 148 | 149 | procedure TMainForm.SubscribeTimeseriesClick(Sender: TObject); 150 | begin 151 | FSubscriptionPM := FBusPM.Subscribe( 'NexusDevTest', 'PowermanTest', '', HandlerPM, 152 | MakeArguments.Add( 'x-message-ttl', 20000 ) ); 153 | end; 154 | 155 | procedure TMainForm.WMUSER(var Msg: TMessage); 156 | begin 157 | ReadMessagesFromList; 158 | end; 159 | 160 | procedure TMainForm.ReadMessagesFromList; 161 | var 162 | List: TList; 163 | Msg: ProductionGroupDataSerieCollectionV1; 164 | Dataseries: ProductionGroupDataSerieV1; 165 | begin 166 | List := FList.LockList; 167 | Try 168 | for Msg in List do 169 | Begin 170 | Memo1.Lines.Add( 'Powerman Notification (' + Msg.Count.ToString + ' dataseries)' ); 171 | for Dataseries in Msg do 172 | Memo1.Lines.Add( TJSONSerializer.Serialize(Dataseries) ); 173 | Msg.Free; 174 | End; 175 | List.Clear; 176 | Finally 177 | FList.UnlockList; 178 | End; 179 | end; 180 | 181 | end. 182 | -------------------------------------------------------------------------------- /EasyDelphiQ/Testbench/Neas.PowermanApi.Notifications.DTOs.V1.pas: -------------------------------------------------------------------------------- 1 | unit Neas.PowermanApi.Notifications.DTOs.V1; 2 | 3 | interface 4 | 5 | Uses 6 | System.Generics.Collections, EasyDelphiQ.DTO; 7 | 8 | Type 9 | {$SCOPEDENUMS ON} 10 | TDataSerieTypeV1 = ( ConsPlanNoRegMWh, ConsPrognosisMWh, 11 | IntegrationTest1, IntegrationTest2, IntegrationTest3, 12 | IntradayActivated_MWH_DOWN, IntradayActivated_MWH_UP, 13 | IntradayActivated_VALUE_DOWN, IntradayActivated_VALUE_UP, 14 | ManRsvActivation_Balance_MWH_DOWN, ManRsvActivation_Balance_MWH_UP, 15 | ManRsvActivation_Balance_VALUE_DOWN, ManRsvActivation_Balance_VALUE_UP, 16 | ManRsvActivation_Special_MWH_DOWN, ManRsvActivation_Special_MWH_UP, 17 | ManRsvActivation_Special_VALUE_DOWN, ManRsvActivation_Special_VALUE_UP, 18 | ProdPlanNoRegLowerMWh, ProdPlanNoRegMWh, ProdPlanNoRegUpperMWh, 19 | ProdPrognosisLowerMWh, ProdPrognosisMWh, ProdPrognosisUpperMWh, 20 | SpotBlockConsPlanMWh, SpotBlockProdPlanMWh, 21 | SpotConsPlanMWh, SpotProdPlanMWh, 22 | Undefined ); 23 | 24 | TUnitTypeV1 = ( DKK, MWh, Undefined ); 25 | 26 | TDataStatus = ( Approved, Estimated, Manual, Missing, Undefined ); 27 | {$SCOPEDENUMS OFF} 28 | 29 | TDatapoint = class 30 | Strict Private 31 | private 32 | FStartTime: TDateTime; 33 | FEndTime: TDateTime; 34 | FStatus: TDataStatus; 35 | FValue: Double; 36 | Public 37 | Property StartTime : TDateTime read FStartTime write FStartTime; 38 | Property EndTime : TDateTime read FEndTime write FEndTime; 39 | Property Status : TDataStatus read FStatus write FStatus; 40 | Property Value : Double read FValue write FValue; 41 | Constructor Create; 42 | end; 43 | 44 | TDatapointList = TObjectList; 45 | 46 | ProductionGroupDataSerieV1 = Class 47 | Strict private 48 | FType : TDataSerieTypeV1; 49 | FProductionGroupID : Integer; 50 | FUnitType : TUnitTypeV1; 51 | FUpdateTime : TDateTime; 52 | FDataPoints : TDatapointList; 53 | public 54 | Property &Type : TDataSerieTypeV1 read FType write FType; 55 | Property ProductionGroupID : Integer read FProductionGroupID write FProductionGroupID; 56 | Property UnitType : TUnitTypeV1 read FUnitType write FUnitType; 57 | Property UpdateTime : TDateTime read FUpdateTime write FUpdateTime; 58 | Property DataPoints : TDatapointList read FDataPoints; 59 | Constructor Create; 60 | Destructor Destroy; Override; 61 | End; 62 | 63 | //Exchange name: {Namespace/UnitName}.{ClassName}:{AssemblyName} 64 | // Neas.PowermanApi.Notifications.DTOs.V1.ProductionGroupDataSerieCollectionV1:Neas.PowermanApi.Notifications.DTOs 65 | [AssemblyName('Neas.PowermanApi.Notifications.DTOs')] 66 | ProductionGroupDataSerieCollectionV1 = Class( TObjectList ) 67 | Public 68 | Constructor Create; Reintroduce; 69 | End; 70 | 71 | implementation 72 | 73 | Uses 74 | System.Math; 75 | 76 | { TDatapointList } 77 | 78 | constructor TDatapoint.Create; 79 | begin 80 | FStartTime := 0; 81 | FEndTime := 0; 82 | FStatus := TDataStatus.Undefined; 83 | FValue := NAN; 84 | end; 85 | 86 | { DataSerieV1 } 87 | 88 | constructor ProductionGroupDataSerieV1.Create; 89 | begin 90 | FType := TDataSerieTypeV1.Undefined; 91 | FProductionGroupID := -1; 92 | FUnitType := TUnitTypeV1.Undefined; 93 | FUpdateTime := 0; 94 | FDataPoints := TDatapointList.Create; 95 | end; 96 | 97 | destructor ProductionGroupDataSerieV1.Destroy; 98 | begin 99 | FDataPoints.Free; 100 | inherited; 101 | end; 102 | 103 | { ProductionGroupDataSerieCollectionV1 } 104 | 105 | constructor ProductionGroupDataSerieCollectionV1.Create; 106 | begin 107 | inherited Create( True ); 108 | end; 109 | 110 | end. 111 | -------------------------------------------------------------------------------- /EasyDelphiQ/Testbench/QTestbench.dpr: -------------------------------------------------------------------------------- 1 | // JCL_DEBUG_EXPERT_GENERATEJDBG OFF 2 | // JCL_DEBUG_EXPERT_INSERTJDBG OFF 3 | program QTestbench; 4 | 5 | uses 6 | Vcl.Forms, 7 | MainWin in 'MainWin.pas' {MainForm}, 8 | Some.namespace in 'Some.namespace.pas', 9 | EasyDelphiQ.DTO in '..\EasyDelphiQ.DTO.pas', 10 | EasyDelphiQ in '..\EasyDelphiQ.pas', 11 | AMQP.Channel in '..\..\AMQP\Source\AMQP.Channel.pas', 12 | AMQP.Classes in '..\..\AMQP\Source\AMQP.Classes.pas', 13 | AMQP.Connection in '..\..\AMQP\Source\AMQP.Connection.pas', 14 | AMQP.Frame in '..\..\AMQP\Source\AMQP.Frame.pas', 15 | AMQP.Header in '..\..\AMQP\Source\AMQP.Header.pas', 16 | AMQP.Helper in '..\..\AMQP\Source\AMQP.Helper.pas', 17 | AMQP.Interfaces in '..\..\AMQP\Source\AMQP.Interfaces.pas', 18 | AMQP.Message in '..\..\AMQP\Source\AMQP.Message.pas', 19 | AMQP.MessageProperties in '..\..\AMQP\Source\AMQP.MessageProperties.pas', 20 | AMQP.Method in '..\..\AMQP\Source\AMQP.Method.pas', 21 | AMQP.Payload in '..\..\AMQP\Source\AMQP.Payload.pas', 22 | AMQP.Protocol in '..\..\AMQP\Source\AMQP.Protocol.pas', 23 | AMQP.StreamHelper in '..\..\AMQP\Source\AMQP.StreamHelper.pas', 24 | AMQP.Types in '..\..\AMQP\Source\AMQP.Types.pas', 25 | WinHttp_TLB in '..\..\JSON\WinHttp_TLB.pas', 26 | EasyDelphiQ.Interfaces in '..\EasyDelphiQ.Interfaces.pas', 27 | EasyDelphiQ.Classes in '..\EasyDelphiQ.Classes.pas', 28 | Neas.PowermanApi.Notifications.DTOs.V1 in 'Neas.PowermanApi.Notifications.DTOs.V1.pas', 29 | AMQP.IMessageProperties in '..\..\AMQP\Source\AMQP.IMessageProperties.pas', 30 | DJSON in '..\..\JSON\DJSON.pas', 31 | AMQP.Arguments in '..\..\AMQP\Source\AMQP.Arguments.pas'; 32 | 33 | {$R *.res} 34 | 35 | begin 36 | Application.Initialize; 37 | Application.MainFormOnTaskbar := True; 38 | Application.Title := 'AMQP Testbench'; 39 | Application.CreateForm(TMainForm, MainForm); 40 | Application.Run; 41 | end. 42 | -------------------------------------------------------------------------------- /EasyDelphiQ/Testbench/QTestbench.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/EasyDelphiQ/Testbench/QTestbench.res -------------------------------------------------------------------------------- /EasyDelphiQ/Testbench/Some.namespace.pas: -------------------------------------------------------------------------------- 1 | unit Some.namespace; 2 | 3 | interface 4 | 5 | Uses 6 | EasyDelphiQ.DTO; 7 | 8 | Type 9 | [AssemblyName('MyAssembly')] 10 | TestDTO = Class 11 | private 12 | FName: String; 13 | FID: Integer; 14 | Public 15 | Property ID : Integer read FID write FID; 16 | Property Name : String read FName write FName; 17 | Constructor Create; 18 | End; 19 | 20 | implementation 21 | 22 | { TestDTO } 23 | 24 | constructor TestDTO.Create; 25 | begin 26 | FID := 0; 27 | FName := ''; 28 | end; 29 | 30 | end. 31 | -------------------------------------------------------------------------------- /JSON/DTO.pas: -------------------------------------------------------------------------------- 1 | Unit DTO; 2 | 3 | Interface 4 | 5 | Uses 6 | System.Generics.Collections; 7 | 8 | Type 9 | TDatapointsItem = class 10 | Private 11 | FStartTimeUTC: String; 12 | FEndTimeUTC: String; 13 | FRepresentedCapacity: Integer; 14 | FValueMWh: Double; 15 | Public 16 | Property StartTimeUTC: String read FStartTimeUTC write FStartTimeUTC; 17 | Property EndTimeUTC: String read FEndTimeUTC write FEndTimeUTC; 18 | Property RepresentedCapacity: Integer read FRepresentedCapacity write FRepresentedCapacity; 19 | Property ValueMWh: Double read FValueMWh write FValueMWh; 20 | Constructor Create; 21 | End; 22 | 23 | TDTOItem = class 24 | Private 25 | FProductionGroupId: Integer; 26 | FType: String; 27 | FDatapoints: TObjectList; 28 | Public 29 | Property ProductionGroupId: Integer read FProductionGroupId write FProductionGroupId; 30 | Property &Type: String read FType write FType; 31 | Property Datapoints: TObjectList read FDatapoints; 32 | Constructor Create; 33 | Destructor Destroy; Override; 34 | End; 35 | 36 | Implementation 37 | 38 | { TDatapointsItem } 39 | 40 | Constructor TDatapointsItem.Create; 41 | Begin 42 | FStartTimeUTC := ''; 43 | FEndTimeUTC := ''; 44 | FRepresentedCapacity := 0; 45 | FValueMWh := 0; 46 | End; 47 | 48 | { TDTOItem } 49 | 50 | Constructor TDTOItem.Create; 51 | Begin 52 | FProductionGroupId := 0; 53 | FType := ''; 54 | FDatapoints := TObjectList.Create; 55 | End; 56 | 57 | Destructor TDTOItem.Destroy; 58 | Begin 59 | FDatapoints.Free; 60 | Inherited; 61 | End; 62 | 63 | End. 64 | 65 | -------------------------------------------------------------------------------- /JSON/JSON Samples/Nexus.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/JSON/JSON Samples/Nexus.txt -------------------------------------------------------------------------------- /JSON/JSONProject.groupproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {EF9AC729-89D7-48B7-BD8F-DCE9B2F0641C} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | Default.Personality.12 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /JSON/Project1.dpr: -------------------------------------------------------------------------------- 1 | // JCL_DEBUG_EXPERT_GENERATEJDBG OFF 2 | // JCL_DEBUG_EXPERT_INSERTJDBG OFF 3 | program Project1; 4 | 5 | uses 6 | Vcl.Forms, 7 | Unit1 in 'Unit1.pas' {Form1}, 8 | TimeseriesDTO in 'TimeseriesDTO.pas', 9 | uLkJSON in 'uLkJSON.pas', 10 | JSON in 'JSON.pas'; 11 | 12 | {$R *.res} 13 | 14 | begin 15 | Application.Initialize; 16 | Application.MainFormOnTaskbar := True; 17 | Application.CreateForm(TForm1, Form1); 18 | Application.Run; 19 | end. 20 | -------------------------------------------------------------------------------- /JSON/Project1.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {A081063B-60AA-46AE-B17D-278F14F1C272} 4 | 14.4 5 | VCL 6 | Project1.dpr 7 | True 8 | Debug 9 | Win32 10 | 1 11 | Application 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Cfg_1 34 | true 35 | true 36 | 37 | 38 | true 39 | Base 40 | true 41 | 42 | 43 | true 44 | Cfg_2 45 | true 46 | true 47 | 48 | 49 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) 50 | $(BDS)\bin\delphi_PROJECTICON.ico 51 | .\$(Platform)\$(Config) 52 | .\$(Platform)\$(Config) 53 | false 54 | false 55 | false 56 | false 57 | false 58 | 59 | 60 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= 61 | 1033 62 | true 63 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 64 | frx17;fs17;bindcompfmx;GR32_RSXE3;DBXSqliteDriver;vcldbx;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;TeeDB;bindcomp;inetdb;inetdbbde;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;iosPackage;DataSnapProviderClient;xmlrtl;DBXSybaseASEDriver;ibxpress;DbxCommonDriver;svnui;vclimg;IndyProtocols;DBXMySQLDriver;dbxcds;MetropolisUILiveTile;vclactnband;bindengine;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;GR32_DSGN_RSXE3;DBXDb2Driver;vcltouch;websnap;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;dsnap;DBXInformixDriver;IndyIPServer;Intraweb;fmxase;vcl;DataSnapConnectors;IndyCore;CodeSiteExpressPkg;DBXMSSQLDriver;CloudService;DBXFirebirdDriver;dsnapcon;frxDB17;inet;fsDB17;fmxobj;FmxTeeUI;SynEdit_RXE3;IndyIPCommon;vclx;frxe17;inetdbxpress;webdsnap;svn;DBXSybaseASADriver;fmxdae;MiscCompPck;bdertl;dbexpress;DataSnapIndy10ServerTransport;adortl;IndyIPClient;$(DCC_UsePackage) 65 | $(BDS)\bin\default_app.manifest 66 | 67 | 68 | bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;TeeDB;bindcomp;inetdb;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;DataSnapProviderClient;xmlrtl;DBXSybaseASEDriver;ibxpress;DbxCommonDriver;vclimg;IndyProtocols;DBXMySQLDriver;dbxcds;MetropolisUILiveTile;vclactnband;bindengine;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;DBXDb2Driver;vcltouch;websnap;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;dsnap;DBXInformixDriver;IndyIPServer;Intraweb;fmxase;vcl;DataSnapConnectors;IndyCore;DBXMSSQLDriver;CloudService;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FmxTeeUI;IndyIPCommon;vclx;inetdbxpress;webdsnap;DBXSybaseASADriver;fmxdae;dbexpress;DataSnapIndy10ServerTransport;adortl;IndyIPClient;$(DCC_UsePackage) 69 | 70 | 71 | DEBUG;$(DCC_Define) 72 | true 73 | false 74 | true 75 | true 76 | true 77 | 78 | 79 | true 80 | true 81 | true 82 | false 83 | 84 | 85 | false 86 | RELEASE;$(DCC_Define) 87 | 0 88 | false 89 | 90 | 91 | true 92 | true 93 | true 94 | true 95 | 96 | 97 | 98 | MainSource 99 | 100 | 101 |
Form1
102 | dfm 103 | 104 | 105 | 106 | 107 | 108 | 109 | Cfg_2 110 | Base 111 | 112 | 113 | Base 114 | 115 | 116 | Cfg_1 117 | Base 118 | 119 | 120 | 121 | Delphi.Personality.12 122 | 123 | 124 | 125 | 126 | False 127 | False 128 | 1 129 | 0 130 | 0 131 | 0 132 | False 133 | False 134 | False 135 | False 136 | False 137 | 1030 138 | 1252 139 | 140 | 141 | 142 | 143 | 1.0.0.0 144 | 145 | 146 | 147 | 148 | 149 | 1.0.0.0 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | Project1.dpr 162 | 163 | 164 | 165 | 166 | True 167 | False 168 | 169 | 170 | 12 171 | 172 | 173 | 174 | 175 | -------------------------------------------------------------------------------- /JSON/Sample1.dpr: -------------------------------------------------------------------------------- 1 | // JCL_DEBUG_EXPERT_GENERATEJDBG OFF 2 | // JCL_DEBUG_EXPERT_INSERTJDBG OFF 3 | program Sample1; 4 | 5 | uses 6 | //FastMM4, 7 | Vcl.Forms, 8 | Sample1Form in 'Sample1Form.pas' {Form1}, 9 | TimeseriesDTO in 'TimeseriesDTO.pas', 10 | JSON in 'JSON.pas', 11 | JSON2DTO in 'JSON2DTO.pas', 12 | DTO in 'DTO.pas'; 13 | 14 | {$R *.res} 15 | 16 | begin 17 | ReportMemoryLeaksOnShutdown := True; 18 | Application.Initialize; 19 | Application.MainFormOnTaskbar := True; 20 | Application.CreateForm(TForm1, Form1); 21 | Application.Run; 22 | end. 23 | -------------------------------------------------------------------------------- /JSON/Sample1.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {A081063B-60AA-46AE-B17D-278F14F1C272} 4 | 16.1 5 | VCL 6 | Sample1.dpr 7 | True 8 | Debug 9 | Win32 10 | 1 11 | Application 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Cfg_1 34 | true 35 | true 36 | 37 | 38 | true 39 | Base 40 | true 41 | 42 | 43 | true 44 | Cfg_2 45 | true 46 | true 47 | 48 | 49 | Sample1 50 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) 51 | $(BDS)\bin\delphi_PROJECTICON.ico 52 | .\$(Platform)\$(Config) 53 | .\$(Platform)\$(Config) 54 | false 55 | false 56 | false 57 | false 58 | false 59 | 60 | 61 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= 62 | 1033 63 | true 64 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 65 | frx17;fs17;bindcompfmx;GR32_RSXE3;DBXSqliteDriver;vcldbx;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;TeeDB;bindcomp;inetdb;inetdbbde;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;iosPackage;DataSnapProviderClient;xmlrtl;DBXSybaseASEDriver;ibxpress;DbxCommonDriver;svnui;vclimg;IndyProtocols;DBXMySQLDriver;dbxcds;MetropolisUILiveTile;vclactnband;bindengine;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;GR32_DSGN_RSXE3;DBXDb2Driver;vcltouch;websnap;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;dsnap;DBXInformixDriver;IndyIPServer;Intraweb;fmxase;vcl;DataSnapConnectors;IndyCore;CodeSiteExpressPkg;DBXMSSQLDriver;CloudService;DBXFirebirdDriver;dsnapcon;frxDB17;inet;fsDB17;fmxobj;FmxTeeUI;SynEdit_RXE3;IndyIPCommon;vclx;frxe17;inetdbxpress;webdsnap;svn;DBXSybaseASADriver;fmxdae;MiscCompPck;bdertl;dbexpress;DataSnapIndy10ServerTransport;adortl;IndyIPClient;$(DCC_UsePackage) 66 | $(BDS)\bin\default_app.manifest 67 | 68 | 69 | bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;TeeDB;bindcomp;inetdb;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;DataSnapProviderClient;xmlrtl;DBXSybaseASEDriver;ibxpress;DbxCommonDriver;vclimg;IndyProtocols;DBXMySQLDriver;dbxcds;MetropolisUILiveTile;vclactnband;bindengine;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;DBXDb2Driver;vcltouch;websnap;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;dsnap;DBXInformixDriver;IndyIPServer;Intraweb;fmxase;vcl;DataSnapConnectors;IndyCore;DBXMSSQLDriver;CloudService;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FmxTeeUI;IndyIPCommon;vclx;inetdbxpress;webdsnap;DBXSybaseASADriver;fmxdae;dbexpress;DataSnapIndy10ServerTransport;adortl;IndyIPClient;$(DCC_UsePackage) 70 | 71 | 72 | DEBUG;$(DCC_Define) 73 | true 74 | false 75 | true 76 | true 77 | true 78 | 79 | 80 | true 81 | true 82 | true 83 | false 84 | 85 | 86 | false 87 | RELEASE;$(DCC_Define) 88 | 0 89 | 0 90 | 91 | 92 | true 93 | true 94 | true 95 | true 96 | 97 | 98 | 99 | MainSource 100 | 101 | 102 |
Form1
103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | Cfg_2 111 | Base 112 | 113 | 114 | Base 115 | 116 | 117 | Cfg_1 118 | Base 119 | 120 | 121 | 122 | Delphi.Personality.12 123 | 124 | 125 | 126 | 127 | False 128 | False 129 | 1 130 | 0 131 | 0 132 | 0 133 | False 134 | False 135 | False 136 | False 137 | False 138 | 1030 139 | 1252 140 | 141 | 142 | 143 | 144 | 1.0.0.0 145 | 146 | 147 | 148 | 149 | 150 | 1.0.0.0 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | Sample1.dpr 163 | 164 | 165 | 166 | 167 | True 168 | False 169 | 170 | 171 | C:\Users\Jesper\Documents\RAD Studio\Projects\JSON\Test\Sample1Tests.dproj 172 | 173 | 174 | 12 175 | 176 | 177 | 178 | 179 | -------------------------------------------------------------------------------- /JSON/Sample1.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/JSON/Sample1.res -------------------------------------------------------------------------------- /JSON/Sample1Form.pas: -------------------------------------------------------------------------------- 1 | unit Sample1Form; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.StdCtrls, Vcl.Forms, Vcl.Dialogs, Vcl.Grids, Vcl.ExtCtrls, System.Generics.Collections, 8 | System.Diagnostics, TimeseriesDTO, DJSON; 9 | 10 | type 11 | TStuff = Class 12 | strict private 13 | FName: String; 14 | FNumber: Integer; 15 | FIDList: TList; 16 | FLines: TStringList; 17 | private 18 | FADate: TDatetime; 19 | Public 20 | Property Name: String read FName write FName; 21 | Property Number: Integer read FNumber write FNumber; 22 | Property ADate: TDatetime read FADate write FADate; 23 | Property IDList: TList read FIDList; 24 | Property Lines: TStringList read FLines; 25 | Constructor Create; 26 | Destructor Destroy; Override; 27 | End; 28 | 29 | TEnum = ( eBobby, eThomas, eKurt ); 30 | 31 | TOuter = Class 32 | strict private 33 | FItems: TObjectList; 34 | FKind: Integer; 35 | FContent: String; 36 | private 37 | FSomeBool: Boolean; 38 | FNameEnum: TEnum; 39 | Public 40 | Property Content: String read FContent write FContent; 41 | Property Kind: Integer read FKind write FKind; 42 | Property NameEnum: TEnum read FNameEnum write FNameEnum; 43 | Property SomeBool: Boolean read FSomeBool write FSomeBool; 44 | Property Items: TObjectList read FItems; 45 | Constructor Create; 46 | Destructor Destroy; Override; 47 | End; 48 | 49 | TForm1 = class(TForm) 50 | Memo1: TMemo; 51 | MemoJSON: TMemo; 52 | ButtonJSONToList: TButton; 53 | ButtonParseToObjectSpeed: TButton; 54 | ButtonParseSpeed: TButton; 55 | StringGrid1: TStringGrid; 56 | ButtonJSONToObject: TButton; 57 | Label1: TLabel; 58 | Label2: TLabel; 59 | LabelProductionGroupID: TLabel; 60 | LabelType: TLabel; 61 | ListBox1: TListBox; 62 | ButtonClear: TButton; 63 | Bevel1: TBevel; 64 | Bevel2: TBevel; 65 | ButtonGet: TButton; 66 | EditURL: TEdit; 67 | ButtonURLToObject: TButton; 68 | Button1: TButton; 69 | Button2: TButton; 70 | Button3: TButton; 71 | Button4: TButton; 72 | procedure FormCreate(Sender: TObject); 73 | procedure ButtonJSONToObjectClick(Sender: TObject); 74 | procedure ButtonJSONToListClick(Sender: TObject); 75 | procedure ButtonParseToObjectSpeedClick(Sender: TObject); 76 | procedure ButtonParseSpeedClick(Sender: TObject); 77 | procedure ButtonClearClick(Sender: TObject); 78 | procedure FormDestroy(Sender: TObject); 79 | procedure ListBox1Click(Sender: TObject); 80 | procedure ButtonGetClick(Sender: TObject); 81 | procedure ButtonURLToObjectClick(Sender: TObject); 82 | procedure Button1Click(Sender: TObject); 83 | procedure Button2Click(Sender: TObject); 84 | procedure Button3Click(Sender: TObject); 85 | procedure Button4Click(Sender: TObject); 86 | private 87 | List: TObjectList; 88 | procedure ClearList; 89 | public 90 | Procedure AddTimeseries( TimeSeries: TTimeseries ); 91 | Procedure Show( Timeseries: TTimeseries ); Overload; 92 | end; 93 | 94 | var 95 | Form1: TForm1; 96 | 97 | implementation 98 | 99 | Uses 100 | System.DateUtils, JSON2DTO; 101 | 102 | {$R *.dfm} 103 | 104 | { TForm1 } 105 | 106 | procedure TForm1.AddTimeseries(TimeSeries: TTimeseries); 107 | begin 108 | List.Add( TimeSeries ); 109 | ListBox1.ItemIndex := ListBox1.Items.Add( IntToStr(TimeSeries.ProductionGroupID) + ' : ' + TimeSeries.&Type ); 110 | Show( TimeSeries ); 111 | end; 112 | 113 | procedure TForm1.ButtonJSONToListClick(Sender: TObject); 114 | var 115 | TS: TTimeseries; 116 | Timer: TStopwatch; 117 | begin 118 | ClearList; 119 | Memo1.Lines.Clear; 120 | Timer := TStopwatch.StartNew; 121 | TJSONParser.Parse( MemoJSON.Text, List ); { <--- The magic! } 122 | Memo1.Lines.Add( 'Parsing: ' + IntToStr(Timer.ElapsedMilliseconds) + ' ms.' ); 123 | for TS in List do 124 | ListBox1.Items.Add( IntToStr(TS.ProductionGroupID) + ' : ' + TS.&Type ); 125 | ListBox1.ItemIndex := -1; 126 | end; 127 | 128 | procedure TForm1.ButtonGetClick(Sender: TObject); 129 | begin 130 | MemoJSON.Text := TJSON.Get( EditURL.Text ); 131 | end; 132 | 133 | procedure TForm1.Button1Click(Sender: TObject); 134 | begin 135 | Memo1.Clear; 136 | TDTOGenerator.Parse( MemoJSON.Text, 'Imported', 'DTO.Imported', Memo1.Lines, '' ); 137 | end; 138 | 139 | procedure TForm1.Button2Click(Sender: TObject); 140 | begin 141 | MemoJSON.Clear; 142 | MemoJSON.Lines.Add( '{' ); 143 | MemoJSON.Lines.Add( ' "ID": 45,' ); 144 | MemoJSON.Lines.Add( ' "Source":' ); 145 | MemoJSON.Lines.Add( ' {' ); 146 | MemoJSON.Lines.Add( ' "ID": 14,' ); 147 | MemoJSON.Lines.Add( ' "Value": 0.0,' ); 148 | MemoJSON.Lines.Add( ' "Name": "Jesper",' ); 149 | MemoJSON.Lines.Add( ' "Alias": "Ripper"' ); 150 | MemoJSON.Lines.Add( ' }' ); 151 | // MemoJSON.Lines.Add( ' "Timeseries":' ); 152 | // MemoJSON.Lines.Add( ' [' ); 153 | // MemoJSON.Lines.Add( ' { "Timestamp": "2015-01-01T00:00", "Value": 45.98 },' ); 154 | // MemoJSON.Lines.Add( ' { "Timestamp": "2015-01-01T00:15", "Value": 13.12 }' ); 155 | // MemoJSON.Lines.Add( ' ]' ); 156 | MemoJSON.Lines.Add( '}' ); 157 | end; 158 | 159 | procedure TForm1.Button3Click(Sender: TObject); 160 | var 161 | JSON: TJSON_Element; 162 | begin 163 | MemoJSON.Text := TJSON.Get( 'http://itunes.apple.com/search?term=metallica' ); 164 | //Pretty print 165 | JSON := nil; 166 | Try 167 | JSON := TJSON.ParseText( MemoJSON.Text ); 168 | MemoJSON.Text := JSON.ToJSON; 169 | Finally 170 | JSON.Free; 171 | End; 172 | end; 173 | 174 | procedure TForm1.Button4Click(Sender: TObject); 175 | var 176 | JSON: TJSON_Element; 177 | begin 178 | MemoJSON.Text := TJSON.Get( 'http://lyrics.wikia.com/api.php?artist=Metallica&fmt=json' ); 179 | //Pretty print 180 | JSON := nil; 181 | Try 182 | JSON := TJSON.ParseText( MemoJSON.Text ); 183 | MemoJSON.Text := JSON.ToJSON; 184 | Finally 185 | JSON.Free; 186 | End; 187 | end; 188 | 189 | procedure TForm1.ButtonClearClick(Sender: TObject); 190 | begin 191 | ClearList; 192 | end; 193 | 194 | procedure TForm1.ButtonParseToObjectSpeedClick(Sender: TObject); 195 | Const 196 | Cnt = 100; 197 | Var 198 | i: Integer; 199 | Timeseries: TTimeseries; 200 | Timer: TStopwatch; 201 | begin 202 | Memo1.Lines.Clear; 203 | Timeseries := nil; 204 | Try 205 | Timer := TStopwatch.StartNew; 206 | for i := 1 to Cnt do 207 | Begin 208 | Timeseries.Free; 209 | Timeseries := TTimeseries.Create; 210 | TJSONParser.Parse( MemoJSON.Text, Timeseries ); { <--- The magic! } 211 | End; 212 | Memo1.Lines.Add( 'Parsing: ' + FloatToStrF(Timer.ElapsedMilliseconds/Cnt, ffFixed, 10, 3) + ' ms. (avg.)' ); 213 | Show( Timeseries ); 214 | Finally 215 | Timeseries.Free; 216 | End; 217 | end; 218 | 219 | procedure TForm1.ButtonURLToObjectClick(Sender: TObject); 220 | var 221 | TS: TTimeseries; 222 | begin 223 | ClearList; 224 | TJSON.Get( EditURL.text, List ); 225 | for TS in List do 226 | ListBox1.Items.Add( IntToStr(TS.ProductionGroupID) + ' : ' + TS.&Type ); 227 | ListBox1.ItemIndex := -1; 228 | end; 229 | 230 | procedure TForm1.ButtonParseSpeedClick(Sender: TObject); 231 | Const 232 | Cnt = 1000; 233 | var 234 | J: TJSON_Element; 235 | Timer: TStopwatch; 236 | i: Integer; 237 | JSON: String; 238 | begin 239 | Memo1.Lines.Clear; 240 | JSON := MemoJSON.Text; 241 | J:= nil; 242 | Timer := TStopwatch.StartNew; 243 | for i := 1 to Cnt do 244 | Begin 245 | J.Free; 246 | J := TJSON.ParseText( JSON ); 247 | End; 248 | With Memo1.Lines do 249 | Try 250 | BeginUpdate; 251 | Add( 'JSON Parsing: ' + FloatToStrF(Timer.ElapsedMilliseconds/Cnt, ffFixed, 10, 3) + ' ms. (avg.)' ); 252 | If J.SelfType = jtObject then 253 | Add( 'Object' ) 254 | else If (J.SelfType = jtArray) and 255 | (TJSON_Array(J).Count = 1) and 256 | (TJSON_Array(J).Elements[0].SelfType = jtObject) then 257 | Add( 'Object (in Array)' ) 258 | else If (J.SelfType = jtArray) then 259 | Add( 'Array' ); 260 | Add(''); 261 | Add('Re-serialized:'); 262 | Add( J.ToJSON ); 263 | Finally 264 | EndUpdate; 265 | J.Free; 266 | End; 267 | end; 268 | 269 | procedure TForm1.Show(Timeseries: TTimeseries); 270 | var 271 | Datapoint: TDatapoint; 272 | Row: Integer; 273 | begin 274 | LabelProductionGroupID.Caption := IntToStr(Timeseries.ProductionGroupID); 275 | LabelType.Caption := Timeseries.&Type; 276 | StringGrid1.RowCount := 1 + Timeseries.Datapoints.Count; 277 | Row := 1; 278 | for Datapoint in Timeseries.Datapoints do 279 | Begin 280 | StringGrid1.Cells[0,Row] := DateTimeToStr(Datapoint.StartTimeUTC); 281 | StringGrid1.Cells[1,Row] := DateTimeToStr(Datapoint.EndTimeUTC); 282 | StringGrid1.Cells[2,Row] := FloatToStr(Datapoint.RepresentedCapacity); 283 | StringGrid1.Cells[3,Row] := FloatToStr(Datapoint.ValueMWh); 284 | Inc(Row); 285 | End; 286 | end; 287 | 288 | procedure TForm1.ClearList; 289 | begin 290 | List.Clear; 291 | ListBox1.Clear; 292 | StringGrid1.RowCount := 2; 293 | StringGrid1.Rows[0].CommaText := '"Start time","End time","Capacity","Value (MWh)"'; 294 | StringGrid1.Rows[1].CommaText := ''; 295 | end; 296 | 297 | procedure TForm1.FormCreate(Sender: TObject); 298 | begin 299 | ReportMemoryLeaksOnShutdown := True; 300 | List := TObjectList.Create; 301 | ClearList; 302 | end; 303 | 304 | procedure TForm1.FormDestroy(Sender: TObject); 305 | begin 306 | List.Free; 307 | end; 308 | 309 | procedure TForm1.ListBox1Click(Sender: TObject); 310 | begin 311 | if ListBox1.ItemIndex <> -1 then 312 | Show( List[ ListBox1.ItemIndex ] ); 313 | end; 314 | 315 | procedure TForm1.ButtonJSONToObjectClick(Sender: TObject); 316 | var 317 | TimeSeries: TTimeseries; 318 | begin 319 | TimeSeries := TTimeseries.Create; 320 | TJSONParser.Parse( MemoJSON.Text, TimeSeries ); 321 | AddTimeseries( TimeSeries ); 322 | Show( TimeSeries ); 323 | Memo1.Text := TJSONSerializer.Serialize(TimeSeries); 324 | end; 325 | 326 | { TStuff } 327 | 328 | constructor TStuff.Create; 329 | begin 330 | FName := ''; 331 | FNumber := 0; 332 | FIDList := TList.Create; 333 | FLines := TStringList.Create; 334 | FADate := EncodeDateTime( 2014, 02, 15, 06, 15, 00, 0 ); 335 | end; 336 | 337 | destructor TStuff.Destroy; 338 | begin 339 | FIDList.Free; 340 | FLines.Free; 341 | inherited; 342 | end; 343 | 344 | { TOuter } 345 | 346 | constructor TOuter.Create; 347 | begin 348 | FKind := 0; 349 | FContent := ''; 350 | FItems := TObjectList.Create; 351 | FSomeBool := True; 352 | FNameEnum := eThomas; 353 | end; 354 | 355 | destructor TOuter.Destroy; 356 | begin 357 | FItems.Free; 358 | inherited; 359 | end; 360 | 361 | end. 362 | 363 | -------------------------------------------------------------------------------- /JSON/Test/Sample1Tests.dpr: -------------------------------------------------------------------------------- 1 | program Sample1Tests; 2 | 3 | {$IFDEF CONSOLE_TESTRUNNER} 4 | {$APPTYPE CONSOLE} 5 | {$ENDIF} 6 | 7 | uses 8 | FastMM4, 9 | DUnitTestRunner, 10 | TestJSON in 'TestJSON.pas', 11 | DJSON in '..\DJSON.pas', 12 | TestObjects in 'TestObjects.pas', 13 | WinHttp_TLB in '..\WinHttp_TLB.pas'; 14 | 15 | {R *.RES} 16 | 17 | begin 18 | DUnitTestRunner.RunRegisteredTests; 19 | end. 20 | 21 | -------------------------------------------------------------------------------- /JSON/Test/TestObjects.pas: -------------------------------------------------------------------------------- 1 | unit TestObjects; 2 | 3 | interface 4 | 5 | Uses 6 | System.Generics.Collections, System.Classes; 7 | 8 | Type 9 | TEnum = (First, Middle, Last); 10 | 11 | TSimple = Class 12 | private 13 | FInt: Integer; 14 | FC: Char; 15 | FDay: TDate; 16 | FStr: String; 17 | FTimestamp: TDateTime; 18 | FNumber: Double; 19 | FBool: Boolean; 20 | FInt64: Int64; 21 | FWord: Word; 22 | FByte: Byte; 23 | FEnum: TEnum; 24 | Public 25 | Property Str: String read FStr write FStr; 26 | Property C: Char read FC write FC; 27 | Property Int: Integer read FInt write FInt; 28 | Property Bool: Boolean read FBool write FBool; 29 | Property Number: Double read FNumber write FNumber; 30 | Property Day: TDate read FDay write FDay; 31 | Property Timestamp: TDateTime read FTimestamp write FTimestamp; 32 | Property Enum: TEnum read FEnum write FEnum; 33 | Property AByte: Byte read FByte write FByte; 34 | Property AWord: Word read FWord write FWord; 35 | Property AInt64: Int64 read FInt64 write FInt64; 36 | Constructor Create; 37 | End; 38 | 39 | TSimpleLists = Class 40 | private 41 | FInt : TList; 42 | FC : TList; 43 | FDay : TList; 44 | FStr : TList; 45 | FTimestamp : TList; 46 | FNumber : TList; 47 | FBool : TList; 48 | FStrList : TStringList; 49 | Public 50 | Property Str : TList read FStr; 51 | Property StrList : TStringList read FStrList; 52 | Property C : TList read FC; 53 | Property Int : TList read FInt; 54 | Property Bool : TList read FBool; 55 | Property Number : TList read FNumber; 56 | Property Day : TList read FDay; 57 | Property Timestamp : TList read FTimestamp; 58 | Constructor Create; 59 | Destructor Destroy; Override; 60 | End; 61 | 62 | TSimpleContainer = Class 63 | private 64 | FName: String; 65 | FObjects: TObjectList; 66 | Public 67 | Property Name: String read FName write FName; 68 | Property Objects: TObjectList read FObjects write FObjects; 69 | Constructor Create; 70 | Destructor Destroy; Override; 71 | End; 72 | 73 | implementation 74 | 75 | Uses 76 | System.SysUtils, System.DateUtils; 77 | 78 | { TSimple } 79 | 80 | constructor TSimple.Create; 81 | begin 82 | FInt := 0; 83 | FC := 'A'; 84 | FDay := EncodeDate( 2014, 1, 1 ); 85 | FTimestamp := EncodeDateTime( 2014, 1, 1, 0, 0, 0, 0 ); 86 | FStr := ''; 87 | FNumber := 0; 88 | FBool := False; 89 | FInt64 := 0; 90 | FWord := 0; 91 | FByte := 0; 92 | FEnum := First; 93 | end; 94 | 95 | { TSimpleLists } 96 | 97 | constructor TSimpleLists.Create; 98 | begin 99 | FInt := TList.Create; 100 | FC := TList.Create; 101 | FDay := TList.Create; 102 | FStr := TList.Create; 103 | FStrList := TStringList.Create; 104 | FTimestamp := TList.Create; 105 | FNumber := TList.Create; 106 | FBool := TList.Create; 107 | end; 108 | 109 | destructor TSimpleLists.Destroy; 110 | begin 111 | FInt.Free; 112 | FC.Free; 113 | FDay.Free; 114 | FStr.Free; 115 | FStrList.Free; 116 | FTimestamp.Free; 117 | FNumber.Free; 118 | FBool.Free; 119 | inherited; 120 | end; 121 | 122 | { TSimpleContainer } 123 | 124 | constructor TSimpleContainer.Create; 125 | begin 126 | FName := ''; 127 | FObjects := TObjectList.Create; 128 | end; 129 | 130 | destructor TSimpleContainer.Destroy; 131 | begin 132 | FObjects.Free; 133 | inherited; 134 | end; 135 | 136 | end. 137 | -------------------------------------------------------------------------------- /JSON/TimeseriesDTO.pas: -------------------------------------------------------------------------------- 1 | unit TimeseriesDTO; 2 | 3 | interface 4 | 5 | Uses 6 | System.Classes, System.Generics.Collections; 7 | 8 | Type 9 | TDatapoint = Class 10 | private 11 | FStartTimeUTC: TDateTime; 12 | FEndTimeUTC: TDateTime; 13 | FRepresentedCapacity: Double; 14 | FValueMWh: Double; 15 | Public 16 | Property StartTimeUTC: TDateTime read FStartTimeUTC write FStartTimeUTC; 17 | Property EndTimeUTC: TDateTime read FEndTimeUTC write FEndTimeUTC; 18 | Property RepresentedCapacity: Double read FRepresentedCapacity write FRepresentedCapacity; 19 | Property ValueMWh: Double read FValueMWh write FValueMWh; 20 | Constructor Create; 21 | End; 22 | 23 | TTimeseries = Class 24 | private 25 | FProductionGroupID: Integer; 26 | FType: String; 27 | FDatapoints: TObjectList; 28 | Public 29 | Property ProductionGroupID: Integer read FProductionGroupID write FProductionGroupID; 30 | Property &Type: String read FType write FType; 31 | Property Datapoints: TObjectList read FDatapoints; 32 | Constructor Create; 33 | Destructor Destroy; Override; 34 | End; 35 | 36 | implementation 37 | 38 | Uses 39 | System.Math; 40 | 41 | { TDatapoint } 42 | 43 | constructor TDatapoint.Create; 44 | begin 45 | FStartTimeUTC := 0; 46 | FEndTimeUTC := 0; 47 | FRepresentedCapacity := NAN; 48 | FValueMWh := NAN; 49 | end; 50 | 51 | { TTimeseries } 52 | 53 | constructor TTimeseries.Create; 54 | begin 55 | FType := ''; 56 | FProductionGroupID := 0; 57 | FDatapoints := TObjectList.Create; 58 | end; 59 | 60 | destructor TTimeseries.Destroy; 61 | begin 62 | FDatapoints.Free; 63 | inherited; 64 | end; 65 | 66 | end. 67 | -------------------------------------------------------------------------------- /JSON/Wizard/JSON.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/JSON/Wizard/JSON.bmp -------------------------------------------------------------------------------- /JSON/Wizard/JSON.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/JSON/Wizard/JSON.ico -------------------------------------------------------------------------------- /JSON/Wizard/JSON.rc: -------------------------------------------------------------------------------- 1 | JSONDTOCODE RCDATA JSONDTO.TXT 2 | JSONICON ICON JSONFile.ICO 3 | 4 | -------------------------------------------------------------------------------- /JSON/Wizard/JSONDTO.txt: -------------------------------------------------------------------------------- 1 | program %s; 2 | 3 | uses 4 | Forms; 5 | 6 | {$R *.res} 7 | 8 | begin 9 | Application.Initialize; 10 | Application.Run; 11 | end. 12 | |unit %s; 13 | 14 | interface 15 | 16 | uses 17 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 18 | Dialogs; 19 | 20 | type 21 | T%s = class(T%s) 22 | private 23 | { Private declarations } 24 | public 25 | { Public declarations } 26 | end; 27 | 28 | var 29 | %1:s: T%1:s; 30 | 31 | implementation 32 | 33 | {$R *.dfm} 34 | 35 | 36 | end. 37 | | 38 | | 39 | -------------------------------------------------------------------------------- /JSON/Wizard/JSONDTOExpt.pas: -------------------------------------------------------------------------------- 1 | unit JSONDTOExpt; 2 | 3 | interface 4 | 5 | procedure Register; 6 | 7 | implementation 8 | 9 | uses 10 | System.Classes, System.SysUtils, WinAPI.Windows, VCL.Dialogs, ToolsApi, WizardWin; 11 | 12 | {$R JSON.res} 13 | 14 | type 15 | TGxModuleCreatorWizard = class( TNotifierObject, IOTAWizard, IOTARepositoryWizard, 16 | IOTARepositoryWizard60, IOTARepositoryWizard80, IOTAFormWizard) 17 | public 18 | // IOTAWizard 19 | function GetIDString: string; 20 | function GetName: string; 21 | function GetState: TWizardState; 22 | procedure Execute; 23 | // IOTARepositoryWizard 24 | function GetAuthor: string; 25 | function GetComment: string; 26 | function GetPage: string; 27 | function GetGlyph: Cardinal; 28 | // IOTARepositoryWizard60 29 | function GetDesigner: string; 30 | // IOTARepositoryWizard80 31 | function GetPersonality: string; 32 | function GetGalleryCategory: IOTAGalleryCategory; 33 | end; 34 | 35 | TGxModuleCreator = class(TInterfacedObject, IOTACreator, IOTAModuleCreator) 36 | private 37 | FSource: String; 38 | public 39 | // IOTACreator 40 | function GetCreatorType: string; 41 | function GetExisting: Boolean; 42 | function GetFileSystem: string; 43 | function GetOwner: IOTAModule; 44 | function GetUnnamed: Boolean; 45 | // IOTAModuleCreator 46 | function GetAncestorName: string; 47 | function GetImplFileName: string; 48 | function GetIntfFileName: string; 49 | function GetFormName: string; 50 | function GetMainForm: Boolean; 51 | function GetShowForm: Boolean; 52 | function GetShowSource: Boolean; 53 | function NewFormFile(const FormIdent, AncestorIdent: string): IOTAFile; 54 | function NewImplSource(const ModuleIdent, FormIdent, AncestorIdent: string): IOTAFile; 55 | function NewIntfSource(const ModuleIdent, FormIdent, AncestorIdent: string): IOTAFile; 56 | procedure FormCreated(const FormEditor: IOTAFormEditor); 57 | Constructor Create( ASource: String ); Reintroduce; 58 | end; 59 | 60 | TGxSourceFile = class(TInterfacedObject, IOTAFile) 61 | private 62 | FSource: string; 63 | public 64 | function GetSource: string; 65 | function GetAge: TDateTime; 66 | constructor Create(const Source: string); 67 | end; 68 | 69 | 70 | { TGxModuleCreatorWizard } 71 | 72 | procedure TGxModuleCreatorWizard.Execute; 73 | var 74 | Source: String; 75 | begin 76 | WizardForm := TWizardForm.Create(nil); 77 | Try 78 | Source := WizardForm.Execute; 79 | if Source <> '' then 80 | (BorlandIDEServices as IOTAModuleServices).CreateModule(TGxModuleCreator.Create(Source)); 81 | Finally 82 | WizardForm.Free; 83 | End; 84 | end; 85 | 86 | function TGxModuleCreatorWizard.GetAuthor: string; 87 | begin 88 | Result := 'Jesper B. Christensen'; 89 | end; 90 | 91 | function TGxModuleCreatorWizard.GetComment: string; 92 | begin 93 | Result := 'JSON DTO Importer'; 94 | end; 95 | 96 | function TGxModuleCreatorWizard.GetDesigner: string; 97 | begin 98 | Result := dVCL; 99 | end; 100 | 101 | function TGxModuleCreatorWizard.GetGalleryCategory: IOTAGalleryCategory; 102 | var 103 | Category: IOTAGalleryCategory; 104 | CatManager: IOTAGalleryCategoryManager; 105 | begin 106 | CatManager := (BorlandIDEServices as IOTAGalleryCategoryManager); 107 | Assert(Assigned(CatManager)); 108 | Category := CatManager.FindCategory(sCategoryDelphiNewFiles); 109 | Assert(Assigned(Category)); 110 | Result := Category; 111 | end; 112 | 113 | function TGxModuleCreatorWizard.GetPersonality: string; 114 | begin 115 | Result := sDelphiPersonality; 116 | end; 117 | 118 | function TGxModuleCreatorWizard.GetGlyph: Cardinal; 119 | begin 120 | Result := LoadIcon(HInstance, 'JSONICON'); 121 | end; 122 | 123 | function TGxModuleCreatorWizard.GetIDString: string; 124 | begin 125 | Result := 'JBC.JSONDTOCreatorWizard'; 126 | end; 127 | 128 | function TGxModuleCreatorWizard.GetName: string; 129 | begin 130 | Result := 'JSON DTO Importer'; 131 | end; 132 | 133 | function TGxModuleCreatorWizard.GetPage: string; 134 | begin 135 | Result := 'New'; 136 | end; 137 | 138 | function TGxModuleCreatorWizard.GetState: TWizardState; 139 | begin 140 | Result := [wsEnabled]; 141 | end; 142 | 143 | { TGxModuleCreator } 144 | 145 | constructor TGxModuleCreator.Create( ASource: String ); 146 | begin 147 | inherited Create; 148 | FSource := ASource; 149 | end; 150 | 151 | procedure TGxModuleCreator.FormCreated(const FormEditor: IOTAFormEditor); 152 | begin 153 | // Nothing 154 | end; 155 | 156 | function TGxModuleCreator.GetAncestorName: string; 157 | begin 158 | Result := ''; 159 | end; 160 | 161 | function TGxModuleCreator.GetCreatorType: string; 162 | begin 163 | // Return sUnit or sText as appropriate 164 | Result := sUnit; 165 | end; 166 | 167 | function TGxModuleCreator.GetExisting: Boolean; 168 | begin 169 | Result := False; 170 | end; 171 | 172 | function TGxModuleCreator.GetFileSystem: string; 173 | begin 174 | Result := ''; 175 | end; 176 | 177 | function TGxModuleCreator.GetFormName: string; 178 | begin 179 | Result := ''; 180 | end; 181 | 182 | function TGxModuleCreator.GetImplFileName: string; 183 | begin 184 | // Result := 'NewDTO.pas'; 185 | Result := ''; 186 | end; 187 | 188 | function TGxModuleCreator.GetIntfFileName: string; 189 | begin 190 | Result := ''; 191 | end; 192 | 193 | function TGxModuleCreator.GetMainForm: Boolean; 194 | begin 195 | Result := False; 196 | end; 197 | 198 | function TGxModuleCreator.GetOwner: IOTAModule; 199 | //var 200 | // ModuleServices: IOTAModuleServices; 201 | // Module: IOTAModule; 202 | // NewModule: IOTAModule; 203 | begin 204 | Result := (BorlandIDEServices as IOTAModuleServices).GetActiveProject; 205 | // You may prefer to return the project group's ActiveProject instead 206 | // Result := nil; 207 | // ModuleServices := (BorlandIDEServices as IOTAModuleServices); 208 | // Module := ModuleServices.CurrentModule; 209 | // 210 | // if Module <> nil then 211 | // begin 212 | // if Module.QueryInterface(IOTAProject, NewModule) = S_OK then 213 | // Result := NewModule 214 | // 215 | // else if Module.OwnerModuleCount > 0 then 216 | // begin 217 | // NewModule := Module.OwnerModules[0]; 218 | // if NewModule <> nil then 219 | // if NewModule.QueryInterface(IOTAProject, Result) <> S_OK then 220 | // Result := nil; 221 | // end; 222 | // end; 223 | end; 224 | 225 | function TGxModuleCreator.GetShowForm: Boolean; 226 | begin 227 | Result := False; 228 | end; 229 | 230 | function TGxModuleCreator.GetShowSource: Boolean; 231 | begin 232 | Result := True; 233 | end; 234 | 235 | function TGxModuleCreator.GetUnnamed: Boolean; 236 | begin 237 | Result := True; 238 | end; 239 | 240 | function TGxModuleCreator.NewFormFile(const FormIdent, AncestorIdent: string): IOTAFile; 241 | begin 242 | Result := nil; 243 | end; 244 | 245 | function TGxModuleCreator.NewImplSource(const ModuleIdent, FormIdent, AncestorIdent: string): IOTAFile; 246 | begin 247 | Result := TGxSourceFile.Create(Format(FSource, [ModuleIdent, FormIdent, 248 | AncestorIdent, FormIdent, FormIdent])); 249 | end; 250 | 251 | function TGxModuleCreator.NewIntfSource(const ModuleIdent, FormIdent, AncestorIdent: string): IOTAFile; 252 | begin 253 | Result := nil; 254 | end; 255 | 256 | { TGxSourceFile } 257 | 258 | constructor TGxSourceFile.Create(const Source: string); 259 | begin 260 | FSource := Source; 261 | end; 262 | 263 | function TGxSourceFile.GetAge: TDateTime; 264 | begin 265 | Result := -1; 266 | end; 267 | 268 | function TGxSourceFile.GetSource: string; 269 | begin 270 | Result := FSource; 271 | end; 272 | 273 | procedure Register; 274 | begin 275 | RegisterPackageWizard(TGxModuleCreatorWizard.Create); 276 | end; 277 | 278 | 279 | initialization 280 | // InitModuleSources; 281 | finalization 282 | // DoneModuleSources; 283 | end. 284 | -------------------------------------------------------------------------------- /JSON/Wizard/JSONDTOWiz.dpk: -------------------------------------------------------------------------------- 1 | 2 | //--------------------------------------------------------------------------- 3 | 4 | // This software is Copyright (c) 2011 Embarcadero Technologies, Inc. 5 | // You may only use this software if you are an authorized licensee 6 | // of Delphi, C++Builder or RAD Studio (Embarcadero Products). 7 | // This software is considered a Redistributable as defined under 8 | // the software license agreement that comes with the Embarcadero Products 9 | // and is subject to that software license agreement. 10 | 11 | //--------------------------------------------------------------------------- 12 | // JCL_DEBUG_EXPERT_GENERATEJDBG OFF 13 | // JCL_DEBUG_EXPERT_INSERTJDBG OFF 14 | package JSONDTOWiz; 15 | 16 | {$R *.res} 17 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 18 | {$ALIGN 8} 19 | {$ASSERTIONS ON} 20 | {$BOOLEVAL OFF} 21 | {$DEBUGINFO ON} 22 | {$EXTENDEDSYNTAX ON} 23 | {$IMPORTEDDATA ON} 24 | {$IOCHECKS ON} 25 | {$LOCALSYMBOLS ON} 26 | {$LONGSTRINGS ON} 27 | {$OPENSTRINGS ON} 28 | {$OPTIMIZATION ON} 29 | {$OVERFLOWCHECKS OFF} 30 | {$RANGECHECKS OFF} 31 | {$REFERENCEINFO ON} 32 | {$SAFEDIVIDE OFF} 33 | {$STACKFRAMES OFF} 34 | {$TYPEDADDRESS OFF} 35 | {$VARSTRINGCHECKS ON} 36 | {$WRITEABLECONST OFF} 37 | {$MINENUMSIZE 1} 38 | {$IMAGEBASE $400000} 39 | {$DEFINE DEBUG} 40 | {$ENDIF IMPLICITBUILDING} 41 | {$DESIGNONLY} 42 | {$IMPLICITBUILD OFF} 43 | 44 | requires 45 | rtl, 46 | vcl, 47 | designide, 48 | IndyProtocols, 49 | IndyCore, 50 | IndySystem; 51 | 52 | contains 53 | JSONDTOExpt in 'JSONDTOExpt.pas', 54 | WizardWin in 'WizardWin.pas' {WizardForm}, 55 | JSON2DTO in '..\JSON2DTO.pas', 56 | WinHttp_TLB in '..\WinHttp_TLB.pas', 57 | JSON in '..\JSON.pas'; 58 | 59 | end. 60 | -------------------------------------------------------------------------------- /JSON/Wizard/JSONDTOWiz.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {924ddcca-9772-4b0f-ba7b-b7273fa7b613} 4 | JSONDTOWiz.dpk 5 | Debug 6 | DCC32 7 | ..\..\..\..\..\..\..\..\testuser\My Documents\RAD Studio\Projects\Bpl\XPAppWiz.bpl 8 | 16.1 9 | Debug 10 | VCL 11 | True 12 | Win32 13 | 1 14 | Package 15 | 16 | 17 | true 18 | 19 | 20 | true 21 | Base 22 | true 23 | 24 | 25 | true 26 | Base 27 | true 28 | 29 | 30 | true 31 | Base 32 | true 33 | 34 | 35 | true 36 | Base 37 | true 38 | 39 | 40 | true 41 | Base 42 | true 43 | 44 | 45 | true 46 | Cfg_2 47 | true 48 | true 49 | 50 | 51 | JSONDTOWiz 52 | 1033 53 | Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) 54 | true 55 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= 56 | true 57 | 00400000 58 | C:\trunk\bin\XPAppWiz.bpl 59 | true 60 | true 61 | true 62 | 63 | 64 | rtl;vcl;IndyProtocols;IndyCore;IndySystem;$(DCC_UsePackage) 65 | 1033 66 | true 67 | System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 68 | JSONFile.ico 69 | 70 | 71 | rtl;vcl;IndyProtocols;IndyCore;IndySystem;$(DCC_UsePackage) 72 | JSONFile.ico 73 | 74 | 75 | Debug 76 | package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true 77 | false 78 | 79 | 80 | 7.0 81 | 0 82 | False 83 | 0 84 | RELEASE 85 | 86 | 87 | 7.0 88 | DEBUG 89 | 90 | 91 | 3 92 | 93 | 94 | 95 | MainSource 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 |
WizardForm
106 | dfm 107 | 108 | 109 | 110 | 111 | 112 |
XPAPPRES.res
113 | 114 | 115 | 116 | Cfg_2 117 | Base 118 | 119 | 120 | Base 121 | 122 | 123 | Cfg_1 124 | Base 125 | 126 | 127 | 128 | 129 | Delphi.Personality.12 130 | Package 131 | 132 | 133 | 134 | False 135 | 136 | 137 | 138 | False 139 | True 140 | False 141 | 142 | 143 | True 144 | False 145 | 1 146 | 0 147 | 0 148 | 0 149 | False 150 | False 151 | False 152 | False 153 | False 154 | 1033 155 | 1252 156 | 157 | 158 | 159 | 160 | 1.0.0.0 161 | 162 | 163 | 164 | 165 | 166 | 1.0.0.0 167 | 168 | 169 | 170 | JSONDTOWiz.dpk 171 | 172 | 173 | 174 | False 175 | False 176 | False 177 | True 178 | False 179 | 180 | 181 | 12 182 | 183 | 184 | 185 | -------------------------------------------------------------------------------- /JSON/Wizard/JSONFile.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/JSON/Wizard/JSONFile.ico -------------------------------------------------------------------------------- /JSON/Wizard/WizardWin.dfm: -------------------------------------------------------------------------------- 1 | object WizardForm: TWizardForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'Import JSON DTO' 5 | ClientHeight = 432 6 | ClientWidth = 1005 7 | Color = 14737632 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | Position = poScreenCenter 15 | OnCreate = FormCreate 16 | OnDestroy = FormDestroy 17 | DesignSize = ( 18 | 1005 19 | 432) 20 | PixelsPerInch = 96 21 | TextHeight = 13 22 | object Shape1: TShape 23 | Left = 0 24 | Top = 386 25 | Width = 1005 26 | Height = 46 27 | Align = alBottom 28 | Brush.Color = 16767954 29 | Pen.Color = 5329233 30 | end 31 | object LabelInvalidJSON: TLabel 32 | Left = 97 33 | Top = 404 34 | Width = 61 35 | Height = 13 36 | Anchors = [akLeft, akBottom] 37 | Caption = 'Invalid JSON' 38 | Font.Charset = DEFAULT_CHARSET 39 | Font.Color = clRed 40 | Font.Height = -11 41 | Font.Name = 'Tahoma' 42 | Font.Style = [] 43 | ParentFont = False 44 | Visible = False 45 | end 46 | object Label1: TLabel 47 | Left = 512 48 | Top = 359 49 | Width = 58 50 | Height = 13 51 | Anchors = [akRight, akBottom] 52 | Caption = 'Class name:' 53 | end 54 | object Label2: TLabel 55 | Left = 8 56 | Top = 40 57 | Width = 26 58 | Height = 13 59 | Caption = 'JSON' 60 | end 61 | object Label3: TLabel 62 | Left = 512 63 | Top = 40 64 | Width = 56 65 | Height = 13 66 | Anchors = [akTop, akRight] 67 | Caption = 'DTO source' 68 | end 69 | object ButtonImport: TButton 70 | Left = 11 71 | Top = 397 72 | Width = 75 73 | Height = 25 74 | Anchors = [akLeft, akBottom] 75 | Caption = 'Import' 76 | Enabled = False 77 | TabOrder = 5 78 | OnClick = ButtonImportClick 79 | end 80 | object ButtonCancel: TButton 81 | Left = 919 82 | Top = 397 83 | Width = 75 84 | Height = 25 85 | Anchors = [akRight, akBottom] 86 | Cancel = True 87 | Caption = 'Cancel' 88 | TabOrder = 6 89 | OnClick = ButtonCancelClick 90 | end 91 | object EditURL: TEdit 92 | Left = 8 93 | Top = 11 94 | Width = 907 95 | Height = 20 96 | Anchors = [akLeft, akTop, akRight] 97 | Ctl3D = False 98 | Font.Charset = DEFAULT_CHARSET 99 | Font.Color = clWindowText 100 | Font.Height = 14 101 | Font.Name = 'Consolas' 102 | Font.Style = [] 103 | ParentCtl3D = False 104 | ParentFont = False 105 | TabOrder = 0 106 | Text = 'http://itunes.apple.com/search?term=metallica' 107 | OnKeyDown = EditURLKeyDown 108 | OnKeyPress = EditURLKeyPress 109 | OnKeyUp = EditURLKeyUp 110 | end 111 | object ButtonGet: TButton 112 | Left = 922 113 | Top = 8 114 | Width = 75 115 | Height = 25 116 | Anchors = [akTop, akRight] 117 | Caption = 'Get' 118 | TabOrder = 1 119 | OnClick = ButtonGetClick 120 | end 121 | object EditName: TEdit 122 | Left = 576 123 | Top = 357 124 | Width = 169 125 | Height = 20 126 | Anchors = [akRight, akBottom] 127 | Ctl3D = False 128 | Font.Charset = DEFAULT_CHARSET 129 | Font.Color = clWindowText 130 | Font.Height = 14 131 | Font.Name = 'Consolas' 132 | Font.Style = [] 133 | ParentCtl3D = False 134 | ParentFont = False 135 | TabOrder = 4 136 | Text = 'NewDTO' 137 | OnChange = EditNameChange 138 | end 139 | object PanelJSON: TPanel 140 | Left = 8 141 | Top = 58 142 | Width = 497 143 | Height = 290 144 | Anchors = [akLeft, akTop, akRight, akBottom] 145 | BevelOuter = bvNone 146 | BorderStyle = bsSingle 147 | Caption = 'PanelJSON' 148 | Ctl3D = False 149 | ParentCtl3D = False 150 | ShowCaption = False 151 | TabOrder = 2 152 | object MemoJSON: TMemo 153 | Left = 0 154 | Top = 0 155 | Width = 495 156 | Height = 288 157 | Align = alClient 158 | BevelInner = bvLowered 159 | BevelOuter = bvRaised 160 | BorderStyle = bsNone 161 | Ctl3D = True 162 | Font.Charset = DEFAULT_CHARSET 163 | Font.Color = clWindowText 164 | Font.Height = 14 165 | Font.Name = 'Consolas' 166 | Font.Style = [] 167 | Lines.Strings = ( 168 | '[' 169 | ' {' 170 | ' "Name": "Thomas",' 171 | ' "ID": 1' 172 | ' },' 173 | ' {' 174 | ' "Name": "Maria",' 175 | ' "ID": 2' 176 | ' }' 177 | ']') 178 | ParentCtl3D = False 179 | ParentFont = False 180 | ScrollBars = ssBoth 181 | TabOrder = 0 182 | OnChange = MemoJSONChange 183 | end 184 | end 185 | object PanelSource: TPanel 186 | Left = 511 187 | Top = 58 188 | Width = 486 189 | Height = 290 190 | Anchors = [akTop, akRight, akBottom] 191 | BevelOuter = bvNone 192 | BorderStyle = bsSingle 193 | Caption = 'Panel1' 194 | Ctl3D = False 195 | ParentCtl3D = False 196 | ShowCaption = False 197 | TabOrder = 3 198 | object MemoSource: TMemo 199 | Left = 0 200 | Top = 0 201 | Width = 484 202 | Height = 288 203 | Align = alClient 204 | BevelInner = bvLowered 205 | BevelOuter = bvRaised 206 | BorderStyle = bsNone 207 | Color = 14737632 208 | Ctl3D = True 209 | Font.Charset = DEFAULT_CHARSET 210 | Font.Color = clWindowText 211 | Font.Height = 14 212 | Font.Name = 'Consolas' 213 | Font.Style = [] 214 | ParentCtl3D = False 215 | ParentFont = False 216 | ScrollBars = ssBoth 217 | TabOrder = 0 218 | end 219 | end 220 | object Timer1: TTimer 221 | Enabled = False 222 | Interval = 300 223 | OnTimer = Timer1Timer 224 | Left = 208 225 | Top = 72 226 | end 227 | end 228 | -------------------------------------------------------------------------------- /JSON/Wizard/WizardWin.pas: -------------------------------------------------------------------------------- 1 | unit WizardWin; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls; 8 | 9 | type 10 | TWizardForm = class(TForm) 11 | ButtonImport: TButton; 12 | ButtonCancel: TButton; 13 | EditURL: TEdit; 14 | ButtonGet: TButton; 15 | Timer1: TTimer; 16 | LabelInvalidJSON: TLabel; 17 | Shape1: TShape; 18 | EditName: TEdit; 19 | Label1: TLabel; 20 | PanelJSON: TPanel; 21 | MemoJSON: TMemo; 22 | PanelSource: TPanel; 23 | MemoSource: TMemo; 24 | Label2: TLabel; 25 | Label3: TLabel; 26 | procedure ButtonImportClick(Sender: TObject); 27 | procedure FormCreate(Sender: TObject); 28 | procedure FormDestroy(Sender: TObject); 29 | procedure ButtonCancelClick(Sender: TObject); 30 | procedure ButtonGetClick(Sender: TObject); 31 | procedure MemoJSONChange(Sender: TObject); 32 | procedure Timer1Timer(Sender: TObject); 33 | procedure EditURLKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 34 | procedure EditNameChange(Sender: TObject); 35 | procedure EditURLKeyPress(Sender: TObject; var Key: Char); 36 | procedure EditURLKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); 37 | private 38 | FURL: String; 39 | FDTOSource: TStringList; 40 | Function IsValidJSON: Boolean; 41 | procedure CheckValidJSON; 42 | procedure NeedCheck; 43 | public 44 | Function Execute: String; 45 | end; 46 | 47 | var 48 | WizardForm: TWizardForm; 49 | 50 | implementation 51 | 52 | Uses 53 | JSON, JSON2DTO; 54 | 55 | {$R *.dfm} 56 | 57 | procedure TWizardForm.ButtonImportClick(Sender: TObject); 58 | begin 59 | Close; 60 | ModalResult := mrOk; 61 | end; 62 | 63 | procedure TWizardForm.ButtonGetClick(Sender: TObject); 64 | begin 65 | FURL := Trim( EditURL.Text ); 66 | MemoJSON.Text := TJSON.Get( FURL ); //Will start timer 67 | Timer1.Enabled := False; //Cancel timer 68 | CheckValidJSON; 69 | end; 70 | 71 | procedure TWizardForm.ButtonCancelClick(Sender: TObject); 72 | begin 73 | Close; 74 | end; 75 | 76 | procedure TWizardForm.EditNameChange(Sender: TObject); 77 | Begin 78 | NeedCheck; 79 | End; 80 | 81 | procedure TWizardForm.NeedCheck; 82 | begin 83 | Timer1.Enabled := False; 84 | Timer1.Enabled := True; 85 | end; 86 | 87 | procedure TWizardForm.EditURLKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 88 | begin 89 | if Key = VK_RETURN then 90 | Begin 91 | Key := 0; 92 | ButtonGet.Click; 93 | End; 94 | end; 95 | 96 | procedure TWizardForm.EditURLKeyPress(Sender: TObject; var Key: Char); 97 | begin 98 | if Key = #13 then 99 | Key := #0; 100 | end; 101 | 102 | procedure TWizardForm.EditURLKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); 103 | begin 104 | if Key = VK_RETURN then 105 | Key := 0; 106 | end; 107 | 108 | function TWizardForm.Execute: String; 109 | begin 110 | if (ShowModal = mrOk) and 111 | (FDTOSource.Count > 0) then 112 | Result := FDTOSource.Text 113 | else 114 | Result := ''; 115 | end; 116 | 117 | procedure TWizardForm.FormCreate(Sender: TObject); 118 | begin 119 | FURL := ''; 120 | FDTOSource := TStringList.Create; 121 | CheckValidJSON; 122 | end; 123 | 124 | procedure TWizardForm.FormDestroy(Sender: TObject); 125 | begin 126 | FDTOSource.Free; 127 | end; 128 | 129 | procedure TWizardForm.MemoJSONChange(Sender: TObject); 130 | begin 131 | NeedCheck; 132 | end; 133 | 134 | procedure TWizardForm.Timer1Timer(Sender: TObject); 135 | Begin 136 | Timer1.Enabled := False; 137 | CheckValidJSON; 138 | End; 139 | 140 | function TWizardForm.IsValidJSON: Boolean; 141 | var 142 | JSON: TJSON_Element; 143 | begin 144 | Result := False; 145 | JSON := nil; 146 | Try 147 | JSON := TJSON.ParseText( MemoJSON.Text ); 148 | //Pretty print 149 | MemoJSON.OnChange := nil; 150 | MemoJSON.Text := JSON.ToJSON; 151 | MemoJSON.OnChange := MemoJSONChange; 152 | Result := True; 153 | Except 154 | on E: Exception do 155 | LabelInvalidJSON.Caption := 'Invalid JSON (' + E.Message + ')'; 156 | End; 157 | JSON.Free; 158 | end; 159 | 160 | procedure TWizardForm.CheckValidJSON; 161 | begin 162 | FDTOSource.Clear; 163 | ButtonImport.Enabled := False; 164 | LabelInvalidJSON.Visible := True; 165 | if IsValidJSON then 166 | Try 167 | TDTOGenerator.Parse( MemoJSON.Text, EditName.Text, 'DTO.' + EditName.Text, FDTOSource, FURL ); 168 | MemoSource.Lines.Assign( FDTOSource ); 169 | ButtonImport.Enabled := True; 170 | LabelInvalidJSON.Visible := False; 171 | Except 172 | On E: Exception do 173 | MemoSource.Lines.Text := E.Message; 174 | End; 175 | end; 176 | 177 | end. 178 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # comotobo 2 | The "Code Monkeys ToolBox" (CoMoToBo) is a small collection of useful Delphi classes/APIs. 3 | 4 | ## EasyDelphiQ 5 | An easy-to-use Delphi AIP for RabbitMQ. Inspired by the .Net EasyNetQ client. 6 | Uses the AMQP protocol to send and receive messages. 7 | EasyDelphiQ uses JSON by default for serializing Data Transfer Objects (DTOs) in messages. 8 | DTOs are just simple Delphi classes with standard properties - but they must have a simple, parameterless constructor. 9 | 10 | ### DTOs 11 | 12 | A DTO could look like this: 13 | ```Delphi 14 | unit Some.namespace; 15 | 16 | interface 17 | 18 | Uses 19 | EasyDelphiQ.DTO; 20 | 21 | Type 22 | [AssemblyName('MyAssembly')] 23 | TestDTO = Class 24 | private 25 | FName: String; 26 | FID: Integer; 27 | Public 28 | Property ID : Integer read FID write FID; 29 | Property Name : String read FName write FName; 30 | Constructor Create; 31 | End; 32 | 33 | implementation 34 | 35 | constructor TestDTO.Create; 36 | begin 37 | FID := 0; 38 | FName := ''; 39 | end; 40 | ``` 41 | 42 | The `EasyDelphiQ.DTO` unit in the uses clause is not necessary, but it allows you to use the AssemblyName attribute which makes EasyDelphiQ compatible with EasyNetQ naming conventions. 43 | 44 | ### Publishing messages 45 | 46 | Simple example of how to publish a message: 47 | ```Delphi 48 | Bus := RabbitHutch.CreateBus( 'host=localhost;username=TestUser;password=password' ); 49 | DTO := TestDTO.Create; 50 | Try 51 | DTO.ID := 42; 52 | DTO.Name := 'Zaphod'; 53 | Bus.Publish( DTO ); 54 | Finally 55 | DTO.Free; 56 | Bus.Free; 57 | End; 58 | ``` 59 | 60 | The code above will connect to localhost and publish the DTO to an exchange named `Some.namespace.TestDTO:MyAssembly`. 61 | This exchange naming convention is used by EasyNetQ; [Namespace].[Classname]:[Assemblyname]. 62 | 63 | ### Getting a single message from a queue 64 | 65 | ```Delphi 66 | DTO := Bus.Get( 'MySubscriberID' ); 67 | if DTO = nil then 68 | Memo.Lines.Add( 'No messages in queue' ) 69 | else 70 | Try 71 | Memo.Lines.Add( 'Received:' ); 72 | Memo.Lines.Add( ' DTO.ID: ' + DTO.ID.ToString ); 73 | Memo.Lines.Add( ' DTO.Name: ' + DTO.Name ); 74 | Finally 75 | DTO.Free; 76 | End; 77 | ``` 78 | 79 | 80 | ### Subscribing to a queue 81 | 82 | To subscribe to a RabbitMQ queue, simply do this: 83 | ```Delphi 84 | Subscription := Bus.Subscribe( 'MySubscription', Handler ); 85 | ``` 86 | 87 | The handler method could look like this: 88 | ```Delphi 89 | procedure TMainForm.Handler(var Msg: TestDTO); 90 | begin 91 | DoSomethingInteresting( Msg ); 92 | end; 93 | ``` 94 | 95 | If no exceptions are raised in the Handler method, then the message is acknowledged and removed from the queue. 96 | The `Msg` object in the example will be destroyed automatically by EasyDelphiQ. 97 | If you want to keep the object (put it in a list, for example) then set `Msg` to `nil` in the `Handler`. 98 | It is important to know, however, that the `Handler` method is **NOT** called in the main thread context, so the code here **MUST** be thread safe. 99 | 100 | Here is a simple example of how to use the DTO in the main thread context: 101 | 102 | ```Delphi 103 | procedure TMainForm.Handler(var Msg: TestDTO); 104 | var 105 | DTO: TestDTO; 106 | begin 107 | DTO := Msg; //Necessary to capture the object in the anonymous method below 108 | TThread.Queue( nil, 109 | Procedure 110 | begin 111 | Memo1.Lines.Add( 'Received:' ); 112 | Memo1.Lines.Add( ' DTO.ID: ' + DTO.ID.ToString ); 113 | Memo1.Lines.Add( ' DTO.Name: ' + DTO.Name ); 114 | DTO.Free; //Free the object here - when we are done with it 115 | end ); 116 | Msg := nil; //Don't free the object here 117 | end; 118 | ``` 119 | 120 | 121 | ## AMQP 122 | The implementation of the AMQP protocol which RabbitMQ uses for communication. 123 | EasyDelphiQ is built on top of this library. 124 | 125 | ## DJSON 126 | The DJSON unit makes reading and writing JSON easy (using RTTI). 127 | 128 | For example; parsing JSON array of objects directly into a TObjectList<>: 129 | ```Delphi 130 | JSON := '[ {"ID":4, "Name":"Tom" }, {"ID":7, "Name":"Julia" } ]'; 131 | TJSONParser.Parse( JSON, List ); 132 | ``` 133 | 134 | Serializing an object is equally easy; 135 | ```Delphi 136 | JSON := TJSONSerializer.Serialize( List ); 137 | ``` 138 | 139 | ## XPath 140 | This little unit makes parsing HTML files easy. 141 | 142 | Given this html: 143 | ```Html 144 | 145 |

Not me!

146 |
147 |

Hello

148 |

Cruel

149 |
150 |
151 |

World

152 |
153 | 154 | ``` 155 | 156 | ...is loaded into the Dom viariable (TDom) this line: 157 | ```Delphi 158 | TXPath.Eval( Dom, '/html/div//p' ); 159 | ``` 160 | 161 | Will return an array containing these 3 "p" nodes: 162 | ```Html 163 |

Hello

164 |

Cruel

165 |

World

166 | ``` 167 | 168 | ## Examples 169 | Simple examples are included in the source. 170 | -------------------------------------------------------------------------------- /XPath/TestBench/HtmlTest.dpr: -------------------------------------------------------------------------------- 1 | program HtmlTest; 2 | 3 | uses 4 | Vcl.Forms, 5 | MainWin in 'MainWin.pas' {Form1}, 6 | HtmlParser in '..\HtmlParser.pas', 7 | XPathLexer in '..\XPathLexer.pas', 8 | XPath in '..\XPath.pas'; 9 | 10 | {$R *.res} 11 | 12 | begin 13 | Application.Initialize; 14 | Application.MainFormOnTaskbar := True; 15 | Application.CreateForm(TForm1, Form1); 16 | Application.Run; 17 | end. 18 | -------------------------------------------------------------------------------- /XPath/TestBench/HtmlTest.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/XPath/TestBench/HtmlTest.res -------------------------------------------------------------------------------- /XPath/TestBench/MainWin.dfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 0 3 | Top = 0 4 | Anchors = [akLeft, akTop, akRight, akBottom] 5 | Caption = 'Form1' 6 | ClientHeight = 604 7 | ClientWidth = 1087 8 | Color = clBtnFace 9 | DoubleBuffered = True 10 | Font.Charset = DEFAULT_CHARSET 11 | Font.Color = clWindowText 12 | Font.Height = -11 13 | Font.Name = 'Tahoma' 14 | Font.Style = [] 15 | OldCreateOrder = False 16 | OnCreate = FormCreate 17 | OnDestroy = FormDestroy 18 | DesignSize = ( 19 | 1087 20 | 604) 21 | PixelsPerInch = 96 22 | TextHeight = 13 23 | object ButtonDownload: TButton 24 | Left = 8 25 | Top = 8 26 | Width = 75 27 | Height = 25 28 | Caption = 'Download' 29 | TabOrder = 0 30 | OnClick = ButtonDownloadClick 31 | end 32 | object ButtonParseLastDownload: TButton 33 | Left = 950 34 | Top = 8 35 | Width = 129 36 | Height = 25 37 | Anchors = [akTop, akRight] 38 | Caption = 'Parse last download' 39 | TabOrder = 4 40 | OnClick = ButtonParseLastDownloadClick 41 | end 42 | object ButtonXPath: TButton 43 | Left = 8 44 | Top = 39 45 | Width = 75 46 | Height = 25 47 | Caption = 'XPath' 48 | Default = True 49 | TabOrder = 2 50 | OnClick = ButtonXPathClick 51 | end 52 | object EditXPath: TEdit 53 | Left = 89 54 | Top = 41 55 | Width = 720 56 | Height = 21 57 | Anchors = [akLeft, akTop, akRight] 58 | TabOrder = 3 59 | Text = 60 | '//div[@id='#39'tab_de'#39']/table[3]/tbody/tr[ not(td[ text()='#39'MWh'#39' ] ) ' + 61 | ']' 62 | end 63 | object EditURL: TEdit 64 | Left = 89 65 | Top = 9 66 | Width = 720 67 | Height = 21 68 | Anchors = [akLeft, akTop, akRight] 69 | TabOrder = 1 70 | Text = 71 | 'http://www.epexspot.com/en/market-data/dayaheadauction/auction-t' + 72 | 'able/2015-08-23/DE' 73 | end 74 | object PanelContent: TPanel 75 | Left = 8 76 | Top = 70 77 | Width = 1071 78 | Height = 509 79 | Anchors = [akLeft, akTop, akRight, akBottom] 80 | Caption = 'PanelContent' 81 | ShowCaption = False 82 | TabOrder = 7 83 | object Splitter1: TSplitter 84 | Left = 441 85 | Top = 1 86 | Width = 8 87 | Height = 507 88 | Beveled = True 89 | ResizeStyle = rsUpdate 90 | ExplicitLeft = 290 91 | ExplicitHeight = 383 92 | end 93 | object PageControlRight: TPageControl 94 | Left = 449 95 | Top = 1 96 | Width = 621 97 | Height = 507 98 | ActivePage = TabXPath 99 | Align = alClient 100 | Constraints.MinWidth = 200 101 | TabOrder = 0 102 | object TabDom: TTabSheet 103 | Caption = 'HTML input' 104 | Constraints.MinWidth = 200 105 | ExplicitLeft = 0 106 | ExplicitTop = 0 107 | ExplicitWidth = 0 108 | ExplicitHeight = 0 109 | DesignSize = ( 110 | 613 111 | 479) 112 | object ButtonParseMemo: TButton 113 | Left = 3 114 | Top = 3 115 | Width = 94 116 | Height = 25 117 | Caption = 'Parse memo' 118 | TabOrder = 0 119 | OnClick = ButtonParseMemoClick 120 | end 121 | object MemoHtml: TMemo 122 | Left = 3 123 | Top = 34 124 | Width = 607 125 | Height = 442 126 | Anchors = [akLeft, akTop, akRight, akBottom] 127 | Lines.Strings = ( 128 | '' 129 | '' 130 | '' 131 | '' 132 | '' 133 | '' 134 | '' 135 | '' 136 | '' 137 | ' Helloworld' 138 | '
' 139 | ' I am groot' 140 | '' 141 | '' 142 | '') 145 | TabOrder = 1 146 | end 147 | end 148 | object TabXPath: TTabSheet 149 | Caption = 'XPath Result' 150 | ImageIndex = 1 151 | DesignSize = ( 152 | 613 153 | 479) 154 | object Grid: TStringGrid 155 | Left = 3 156 | Top = 34 157 | Width = 607 158 | Height = 442 159 | Anchors = [akLeft, akTop, akRight, akBottom] 160 | DefaultRowHeight = 18 161 | DrawingStyle = gdsClassic 162 | FixedCols = 0 163 | Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goColSizing, goEditing, goThumbTracking] 164 | TabOrder = 0 165 | end 166 | object Button1: TButton 167 | Left = 3 168 | Top = 3 169 | Width = 94 170 | Height = 25 171 | Caption = 'Copy' 172 | TabOrder = 1 173 | OnClick = Button1Click 174 | end 175 | object CheckBoxTrimTags: TCheckBox 176 | Left = 112 177 | Top = 8 178 | Width = 97 179 | Height = 17 180 | Caption = 'Trim HTML tags' 181 | Checked = True 182 | State = cbChecked 183 | TabOrder = 2 184 | end 185 | end 186 | end 187 | object PageControlLeft: TPageControl 188 | Left = 1 189 | Top = 1 190 | Width = 440 191 | Height = 507 192 | ActivePage = TabSheet1 193 | Align = alLeft 194 | Constraints.MinWidth = 200 195 | TabOrder = 1 196 | object TabSheet1: TTabSheet 197 | Caption = 'DOM' 198 | object TreeViewDOM: TTreeView 199 | Left = 0 200 | Top = 0 201 | Width = 432 202 | Height = 479 203 | Align = alClient 204 | Indent = 19 205 | TabOrder = 0 206 | end 207 | end 208 | object TabSheet2: TTabSheet 209 | Caption = 'XPath Result' 210 | ImageIndex = 1 211 | ExplicitLeft = 0 212 | ExplicitTop = 0 213 | ExplicitWidth = 0 214 | ExplicitHeight = 0 215 | object TreeViewXPath: TTreeView 216 | Left = 0 217 | Top = 0 218 | Width = 432 219 | Height = 479 220 | Align = alClient 221 | Constraints.MinWidth = 200 222 | Indent = 19 223 | TabOrder = 0 224 | end 225 | end 226 | end 227 | end 228 | object StatusBar: TStatusBar 229 | Left = 0 230 | Top = 585 231 | Width = 1087 232 | Height = 19 233 | Panels = <> 234 | SimplePanel = True 235 | end 236 | object ButtonEpexTest: TButton 237 | Left = 950 238 | Top = 39 239 | Width = 129 240 | Height = 25 241 | Anchors = [akTop, akRight] 242 | Caption = 'Epex test' 243 | TabOrder = 6 244 | OnClick = ButtonEpexTestClick 245 | end 246 | object ButtonExaaTest: TButton 247 | Left = 815 248 | Top = 39 249 | Width = 129 250 | Height = 25 251 | Anchors = [akTop, akRight] 252 | Caption = 'EXAA test' 253 | TabOrder = 5 254 | OnClick = ButtonExaaTestClick 255 | end 256 | end 257 | -------------------------------------------------------------------------------- /XPath/TestBench/MainWin.pas: -------------------------------------------------------------------------------- 1 | unit MainWin; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.ExtCtrls, Vcl.Grids, HtmlParser, XPath; 8 | 9 | type 10 | TForm1 = class(TForm) 11 | ButtonDownload: TButton; 12 | ButtonParseLastDownload: TButton; 13 | ButtonXPath: TButton; 14 | EditXPath: TEdit; 15 | EditURL: TEdit; 16 | PanelContent: TPanel; 17 | PageControlRight: TPageControl; 18 | TabDom: TTabSheet; 19 | TabXPath: TTabSheet; 20 | Splitter1: TSplitter; 21 | PageControlLeft: TPageControl; 22 | TabSheet1: TTabSheet; 23 | TabSheet2: TTabSheet; 24 | ButtonParseMemo: TButton; 25 | MemoHtml: TMemo; 26 | TreeViewDOM: TTreeView; 27 | TreeViewXPath: TTreeView; 28 | StatusBar: TStatusBar; 29 | ButtonEpexTest: TButton; 30 | Grid: TStringGrid; 31 | Button1: TButton; 32 | ButtonExaaTest: TButton; 33 | CheckBoxTrimTags: TCheckBox; 34 | procedure ButtonDownloadClick(Sender: TObject); 35 | procedure ButtonParseLastDownloadClick(Sender: TObject); 36 | procedure ButtonParseMemoClick(Sender: TObject); 37 | procedure FormCreate(Sender: TObject); 38 | procedure FormDestroy(Sender: TObject); 39 | procedure ButtonXPathClick(Sender: TObject); 40 | procedure ButtonEpexTestClick(Sender: TObject); 41 | procedure Button1Click(Sender: TObject); 42 | procedure ButtonExaaTestClick(Sender: TObject); 43 | private 44 | FDom: TDom; 45 | FNodeList: TNodeList; 46 | FLastParse: Int64; 47 | FLastXPath: Int64; 48 | FXPathResult: TXValue; 49 | Procedure MakeTree( ATreeView: TTreeView; AParent: TTreeNode; ANode: TNode ); 50 | procedure ShowDom( ATreeView: TTreeView; ANode: TNode ); 51 | procedure ShowXPathTree; 52 | procedure ShowXPathTable; 53 | procedure DownloadURL( AURL: String ); 54 | procedure RunXPath( AXPath: String ); 55 | procedure UpdateStatusBar; 56 | procedure ParseDOM( Fil: TStrings; ARootName: String ); 57 | procedure ParseLastDownloadClick; 58 | end; 59 | 60 | var 61 | Form1: TForm1; 62 | 63 | implementation 64 | 65 | Uses 66 | IdHttp, System.Math, System.Diagnostics, VCL.clipbrd; 67 | 68 | {$R *.dfm} 69 | 70 | procedure TForm1.Button1Click(Sender: TObject); 71 | var 72 | Text: String; 73 | Row: Integer; 74 | begin 75 | Text := ''; 76 | for Row := 0 to Grid.RowCount-1 do 77 | Text := Text + Grid.Rows[Row].CommaText + #13#10; 78 | Clipboard.AsText := Text; 79 | end; 80 | 81 | procedure TForm1.ButtonExaaTestClick(Sender: TObject); 82 | begin 83 | EditURL.Text := 'http://www.exaa.at/de/marktdaten/handelsergebnisse'; 84 | EditXPath.Text := '//div[@class=''pimcore_area_cismo_wysiwyg hourProducts'']/table//tr'; 85 | DownloadURL( EditURL.Text ); 86 | RunXPath( EditXPath.Text ); 87 | end; 88 | 89 | procedure TForm1.ButtonDownloadClick(Sender: TObject); 90 | Begin 91 | DownloadURL( Trim(EditURL.Text) ); 92 | End; 93 | 94 | procedure TForm1.DownloadURL( AURL: String ); 95 | var 96 | Http : TIdHttp; 97 | Stream : TStringStream; 98 | Fil : TStringList; 99 | begin 100 | Http := TIdHttp.Create(nil); 101 | Stream := TStringStream.Create( '', TEncoding.UTF8 ); 102 | Fil := TStringList.Create; 103 | Try 104 | Http.Get( AURL, Stream ); 105 | if Http.ResponseCode = 200 then 106 | Begin 107 | Stream.Position := 0; 108 | Fil.Text := Stream.DataString; //UTF8 --> Unicode 109 | Fil.SaveToFile( 'Download.html' ); 110 | ParseDOM( Fil, AURL ); 111 | End; 112 | Finally 113 | Fil.Free; 114 | Stream.Free; 115 | Http.Free; 116 | End; 117 | end; 118 | 119 | procedure TForm1.ButtonEpexTestClick(Sender: TObject); 120 | begin 121 | EditURL.Text := 'http://www.epexspot.com/en/market-data/dayaheadauction/auction-table/2015-08-23/DE'; 122 | EditXPath.Text := '//div[@id=''tab_de'']/table[3]/tbody/tr[ not(td[ text()=''MWh'' ] ) ]'; 123 | DownloadURL( EditURL.Text ); 124 | RunXPath( EditXPath.Text ); 125 | end; 126 | 127 | procedure TForm1.ButtonParseLastDownloadClick(Sender: TObject); 128 | Begin 129 | ParseLastDownloadClick; 130 | End; 131 | 132 | procedure TForm1.ParseLastDownloadClick; 133 | var 134 | Fil: TStringList; 135 | begin 136 | if FileExists( 'Download.html' ) then 137 | Begin 138 | Fil := TStringList.Create; 139 | Try 140 | Fil.LoadFromFile( 'Download.html' ); 141 | ParseDOM( Fil, 'Download.html' ); 142 | Finally 143 | Fil.Free; 144 | End; 145 | End; 146 | end; 147 | 148 | procedure TForm1.ButtonParseMemoClick(Sender: TObject); 149 | begin 150 | ParseDOM( MemoHtml.Lines, 'Memo' ); 151 | end; 152 | 153 | procedure TForm1.ButtonXPathClick(Sender: TObject); 154 | Begin 155 | RunXPath( Trim(EditXPath.Text) ); 156 | End; 157 | 158 | procedure TForm1.ShowXPathTable; 159 | 160 | Function TrimHtmlTags( S: String ): String; 161 | var 162 | Start, EndTag: Integer; 163 | Begin 164 | Result := S; 165 | Start := Pos( '<', S ); 166 | EndTag := Pos( '>', S ); 167 | while (Start > 0) and (EndTag > 0) and (EndTag > Start) do 168 | Begin 169 | S := Copy( S, 1, Start-1 ) + Copy( S, EndTag+1, MaxInt ); 170 | Start := Pos( '<', S ); 171 | EndTag := Pos( '>', S ); 172 | End; 173 | Result := S; 174 | End; 175 | 176 | Function TrimCellText( S: String ): String; 177 | Begin 178 | Result := S; 179 | if CheckBoxTrimTags.Checked then 180 | Result := TrimHtmlTags( Result ); 181 | Result := Trim( Result ); 182 | End; 183 | 184 | var 185 | ColCount, Col, Row: Integer; 186 | Node, Child: TNode; 187 | begin 188 | if FXPathResult.XType <> xNodelist then 189 | Begin 190 | Grid.ColCount := 1; 191 | Grid.RowCount := 2; 192 | Grid.Rows[0].Text := 'Value'; 193 | case FXPathResult.XType of 194 | xBool : Grid.Rows[1].Text := BoolToStr( FXPathResult.AsBoolean, True ); 195 | xInt : Grid.Rows[1].Text := IntToStr( FXPathResult.AsInt ); 196 | xFloat : Grid.Rows[1].Text := FloatToStr( FXPathResult.AsFloat ); 197 | xString : Grid.Rows[1].Text := FXPathResult.AsString; 198 | end; 199 | End 200 | else 201 | Begin 202 | Grid.RowCount := 1 + Max( 1, FNodeList.Count ); 203 | ColCount := 0; 204 | For Node in FNodeList do 205 | ColCount := Max( ColCount, Node.Count ); 206 | Grid.ColCount := Max( 1, ColCount ); 207 | Grid.Rows[0].Text := ''; 208 | Grid.Rows[1].Text := ''; 209 | 210 | for Col := 0 to Grid.ColCount-1 do 211 | Grid.Cells[ Col, 0 ] := 'Col ' + Col.ToString; 212 | Row := 1; 213 | For Node in FNodeList do 214 | Begin 215 | Col := 0; 216 | if ColCount = 0 then 217 | Grid.Cells[ Col, Row ] := TrimCellText( Node.Text ) 218 | Else 219 | Begin 220 | Grid.Rows[ Row ].Text := ''; 221 | For Child in Node do 222 | Begin 223 | Grid.Cells[ Col, Row ] := TrimCellText( Child.Text ); 224 | Inc( Col ); 225 | End; 226 | End; 227 | Inc( Row ); 228 | End; 229 | End; 230 | end; 231 | 232 | procedure TForm1.ShowXPathTree; 233 | var 234 | Node: TNode; 235 | begin 236 | TreeViewXPath.Items.BeginUpdate; 237 | Try 238 | TreeViewXPath.Items.Clear; 239 | For Node in FNodeList do 240 | MakeTree( TreeViewXPath, nil, Node ); 241 | Finally 242 | TreeViewXPath.Items.EndUpdate; 243 | End; 244 | UpdateStatusBar; 245 | end; 246 | 247 | procedure TForm1.RunXPath( AXPath: String ); 248 | var 249 | StopWatch : TStopWatch; 250 | begin 251 | FNodeList.Clear; 252 | StopWatch := TStopWatch.StartNew; 253 | if AXPath <> '' then 254 | Begin 255 | FXPathResult := TXPath.Eval( FDom, AXPath ); 256 | if FXPathResult.XType = xNodelist then 257 | FNodeList.AddRange( FXPathResult.AsNodes ); 258 | End; 259 | FLastXPath := StopWatch.ElapsedMilliseconds; 260 | ShowXPathTree; 261 | ShowXPathTable; 262 | PageControlLeft.ActivePageIndex := 1; 263 | PageControlRight.ActivePageIndex := 1; 264 | end; 265 | 266 | procedure TForm1.FormCreate(Sender: TObject); 267 | begin 268 | ReportMemoryLeaksOnShutdown := True; 269 | FDom := TDom.Create; 270 | FDom.StrictMode := False; 271 | FLastParse := 0; 272 | FLastXPath := 0; 273 | FNodeList := TNodeList.Create( False ); 274 | PageControlLeft.ActivePageIndex := 0; 275 | PageControlRight.ActivePageIndex := 0; 276 | ParseLastDownloadClick; 277 | end; 278 | 279 | procedure TForm1.FormDestroy(Sender: TObject); 280 | begin 281 | FDom.Free; 282 | FNodeList.Free; 283 | end; 284 | 285 | Procedure TForm1.MakeTree( ATreeView: TTreeView; AParent: TTreeNode; ANode: TNode ); 286 | var 287 | Item: TTreeNode; 288 | Child: TNode; 289 | Text, Value, AttributeText: String; 290 | Attribute: TAttribute; 291 | Begin 292 | AttributeText := ''; 293 | if ANode.Attributes.Count > 0 then 294 | Begin 295 | for Attribute in ANode.Attributes do 296 | begin 297 | if AttributeText <> '' then 298 | AttributeText := AttributeText + ', '; 299 | AttributeText := AttributeText + ' @' + Attribute.Name + ' = "' + Attribute.Value + '"'; 300 | end; 301 | AttributeText := ' [' + AttributeText + ' ]'; 302 | End; 303 | Text := Trim( ANode.Name ) + AttributeText; 304 | Value := Trim( ANode.Text ); 305 | if (Value <> '') and (Value.Length < 50) then 306 | Text := Text + ' :: ' + Value; 307 | 308 | Item := ATreeView.Items.AddChild( AParent, Text ); 309 | for Child in ANode do 310 | MakeTree( ATreeView, Item, Child ); 311 | Item.Expanded := True; 312 | End; 313 | 314 | procedure TForm1.ParseDOM(Fil: TStrings; ARootName: String); 315 | var 316 | StopWatch : TStopWatch; 317 | begin 318 | StopWatch := TStopWatch.StartNew; 319 | FDom.LoadFromStrings( Fil ); 320 | FLastParse := StopWatch.ElapsedMilliseconds; 321 | 322 | FDom.Root.Name := ARootName; 323 | ShowDom( TreeViewDOM, FDom.Root ); 324 | PageControlLeft.ActivePageIndex := 0; 325 | UpdateStatusBar; 326 | end; 327 | 328 | procedure TForm1.ShowDom(ATreeView: TTreeView; ANode: TNode); 329 | begin 330 | ATreeView.Items.BeginUpdate; 331 | Try 332 | ATreeView.Items.Clear; 333 | MakeTree( TreeViewDOM, nil, ANode ); 334 | Finally 335 | ATreeView.Items.EndUpdate; 336 | End; 337 | end; 338 | 339 | procedure TForm1.UpdateStatusBar; 340 | begin 341 | StatusBar.SimpleText := 'Last parse: ' + FLastParse.ToString + ' ms' + 342 | ' ' + 343 | 'Last XPath: ' + FLastXPath.ToString + ' ms'; 344 | end; 345 | 346 | end. 347 | 348 | -------------------------------------------------------------------------------- /XPath/TestBench/Win32/Debug/Download.html: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/XPath/TestBench/Win32/Debug/Download.html -------------------------------------------------------------------------------- /XPath/UnitTest/TestHtmlParser.pas: -------------------------------------------------------------------------------- 1 | unit TestHtmlParser; 2 | 3 | interface 4 | 5 | uses 6 | TestFramework, HtmlParser; 7 | 8 | type 9 | TestTDom = class(TTestCase) 10 | strict private 11 | FDom: TDom; 12 | public 13 | procedure SetUp; override; 14 | procedure TearDown; override; 15 | published 16 | procedure TestLoadFromString; 17 | end; 18 | 19 | implementation 20 | 21 | procedure TestTDom.SetUp; 22 | begin 23 | FDom := TDom.Create; 24 | end; 25 | 26 | procedure TestTDom.TearDown; 27 | begin 28 | FDom.Free; 29 | FDom := nil; 30 | end; 31 | 32 | procedure TestTDom.TestLoadFromString; 33 | var 34 | Node: TNode; 35 | Name: String; 36 | begin 37 | FDom.LoadFromString( ''+ 38 | '

Hello
World

' ); 39 | CheckEquals( 2, FDom.Root.Count ); 40 | Node := FDom.Root[0]; 41 | Name := 'FDom.Root[0]'; 42 | CheckEquals( '', Node.Source, Name + ': Source' ); 43 | CheckEquals( ' a="12"', Node.Text, Name + ': Text' ); 44 | CheckEquals( 0, Node.Attributes.Count, Name + ': Attributes.Count' ); 45 | CheckEquals( 0, Node.Count, Name + ': Count' ); 46 | Node := FDom.Root[1]; 47 | Name := 'FDom.Root[1]'; 48 | CheckEquals( '

Hello
World

', Node.Source, Name + ': Source' ); 49 | CheckEquals( '

Hello
World

', Node.Text, Name + ': Text' ); 50 | CheckEquals( 1, Node.Attributes.Count, Name + ': Attributes.Count' ); 51 | CheckEquals( 'b', Node.Attributes[0].Name, Name + ': Attributes[0].Name' ); 52 | CheckEquals( '12', Node.Attributes[0].Value, Name + ': Attributes[0].Value' ); 53 | CheckEquals( 1, Node.Count, Name + ': Count' ); 54 | Node := FDom.Root[1].Children[0]; 55 | Name := 'FDom.Root[1].Children[0]'; 56 | CheckEquals( '

Hello
World

', Node.Source, Name + ': Source' ); 57 | CheckEquals( '

Hello
World

', Node.Text, Name + ': Text' ); 58 | CheckEquals( 0, Node.Attributes.Count, Name + ': Attributes.Count' ); 59 | CheckEquals( 1, Node.Count, Name + ': Count' ); 60 | Node := FDom.Root[1].Children[0].Children[0]; 61 | Name := 'FDom.Root[1].Children[0].Children[0]'; 62 | CheckEquals( '

Hello
World

', Node.Source, Name + ': Source' ); 63 | CheckEquals( 'Hello
World', Node.Text, Name + ': Text' ); 64 | CheckEquals( 0, Node.Attributes.Count, Name + ': Attributes.Count' ); 65 | CheckEquals( 0, Node.Count, Name + ': Count' ); 66 | end; 67 | 68 | initialization 69 | RegisterTest(TestTDom.Suite); 70 | end. 71 | 72 | -------------------------------------------------------------------------------- /XPath/UnitTest/TestLexer.pas: -------------------------------------------------------------------------------- 1 | unit TestLexer; 2 | 3 | interface 4 | 5 | uses 6 | TestFramework, XPathLexer; 7 | 8 | type 9 | TestTLexer = class(TTestCase) 10 | strict private 11 | FLexer: TLexer; 12 | Procedure CheckToken( ATokenType: TTokenType; AStr: String ); Overload; 13 | Procedure CheckToken( ATokenType: TTokenType ); Overload; 14 | public 15 | procedure SetUp; override; 16 | procedure TearDown; override; 17 | published 18 | procedure TestLexer; 19 | procedure TestLexer_Uppercase; 20 | procedure TestLexer_Identifier_After_Slash; 21 | procedure TestLexer_Identifier_After_DoubleSlash; 22 | procedure TestLexer_Identifier_After_DoubleColon; 23 | procedure TestLexer_Text_After_DoubleColon; 24 | end; 25 | 26 | implementation 27 | 28 | procedure TestTLexer.CheckToken(ATokenType: TTokenType; AStr: String); 29 | begin 30 | CheckTrue( FLexer.Token.TokenType = ATokenType, 'Expected token ' + FLexer.Token.TokenType.AsString + 31 | ', found ' + ATokenType.AsString ); 32 | CheckEquals( AStr, FLexer.Token.Text, 'Text' ); 33 | FLexer.Next; 34 | end; 35 | 36 | procedure TestTLexer.CheckToken(ATokenType: TTokenType); 37 | begin 38 | CheckToken( ATokenType, ATokenType.AsString ); 39 | end; 40 | 41 | procedure TestTLexer.SetUp; 42 | begin 43 | FLexer := nil; 44 | end; 45 | 46 | procedure TestTLexer.TearDown; 47 | begin 48 | FLexer.Free; 49 | end; 50 | 51 | procedure TestTLexer.TestLexer; 52 | begin 53 | FLexer := TLexer.Create( 'Identifier 25 0.25 ''Hello World'' ' + 54 | '()[]' + 55 | '@.::/..//$,' + 56 | '+-*' + 57 | '=!=<><=>=' + 58 | 'or and div idiv mod ' + 59 | 'child.descendant.descendant-or-self.parent.self.' + 60 | 'following-sibling.following.namespace.ancestor.' + 61 | 'preceding-sibling.preceding.ancestor-or-self ' + 62 | 'document-node element attribute schema-element schema-attribute ' + 63 | 'processing-instruction comment text node' ); 64 | CheckToken( ttIdentifier, 'Identifier' ); 65 | CheckToken( ttInteger, '25' ); 66 | CheckToken( ttFloat, '0.25' ); 67 | CheckToken( ttString, 'Hello World' ); 68 | CheckToken( ttParenStart ); 69 | CheckToken( ttParenEnd ); 70 | CheckToken( ttBracketStart ); 71 | CheckToken( ttBracketEnd ); 72 | CheckToken( ttAt ); 73 | CheckToken( ttDot ); 74 | CheckToken( ttColonColon ); 75 | CheckToken( ttSlash ); 76 | CheckToken( ttDotDot ); 77 | CheckToken( ttDoubleSlash ); 78 | CheckToken( ttDollar ); 79 | CheckToken( ttComma ); 80 | CheckToken( ttPlus ); 81 | CheckToken( ttMinus ); 82 | CheckToken( ttMultiply ); 83 | CheckToken( ttEquals ); 84 | CheckToken( ttNotEquals ); 85 | CheckToken( ttLess ); 86 | CheckToken( ttGreater ); 87 | CheckToken( ttLessEqual ); 88 | CheckToken( ttGreaterEqual ); 89 | CheckToken( ttOr ); 90 | CheckToken( ttAnd ); 91 | CheckToken( ttDiv ); 92 | CheckToken( ttIDiv ); 93 | CheckToken( ttMod ); 94 | CheckToken( ttChild ); 95 | CheckToken( ttDot ); 96 | CheckToken( ttDescendant ); 97 | CheckToken( ttDot ); 98 | CheckToken( ttDescendantOrSelf ); 99 | CheckToken( ttDot ); 100 | CheckToken( ttParent ); 101 | CheckToken( ttDot ); 102 | CheckToken( ttSelf ); 103 | CheckToken( ttDot ); 104 | CheckToken( ttFollowingSibling ); 105 | CheckToken( ttDot ); 106 | CheckToken( ttFollowing ); 107 | CheckToken( ttDot ); 108 | CheckToken( ttNamespace ); 109 | CheckToken( ttDot ); 110 | CheckToken( ttAncestor ); 111 | CheckToken( ttDot ); 112 | CheckToken( ttPrecedingSibling ); 113 | CheckToken( ttDot ); 114 | CheckToken( ttPreceding ); 115 | CheckToken( ttDot ); 116 | CheckToken( ttAncestorOrSelf ); 117 | CheckToken( ttDocumentNode ); 118 | CheckToken( ttElement ); 119 | CheckToken( ttAttribute ); 120 | CheckToken( ttSchemaElement ); 121 | CheckToken( ttSchemaAttribute ); 122 | CheckToken( ttProcessingInstruction ); 123 | CheckToken( ttComment ); 124 | CheckToken( ttText ); 125 | CheckToken( ttNode ); 126 | CheckToken( ttEOF ); 127 | end; 128 | 129 | procedure TestTLexer.TestLexer_Identifier_After_DoubleColon; 130 | begin 131 | FLexer := TLexer.Create( '::text/' ); 132 | CheckToken( ttColonColon ); 133 | CheckToken( ttIdentifier, 'text' ); 134 | CheckToken( ttSlash ); 135 | end; 136 | 137 | procedure TestTLexer.TestLexer_Identifier_After_DoubleSlash; 138 | begin 139 | FLexer := TLexer.Create( '//div div' ); 140 | CheckToken( ttDoubleSlash ); 141 | CheckToken( ttIdentifier, 'div' ); 142 | CheckToken( ttDiv ); 143 | end; 144 | 145 | procedure TestTLexer.TestLexer_Identifier_After_Slash; 146 | begin 147 | FLexer := TLexer.Create( '/div div' ); 148 | CheckToken( ttSlash ); 149 | CheckToken( ttIdentifier, 'div' ); 150 | CheckToken( ttDiv ); 151 | end; 152 | 153 | procedure TestTLexer.TestLexer_Text_After_DoubleColon; 154 | begin 155 | FLexer := TLexer.Create( '::text()' ); 156 | CheckToken( ttColonColon ); 157 | CheckToken( ttText ); 158 | end; 159 | 160 | procedure TestTLexer.TestLexer_Uppercase; 161 | begin 162 | FLexer := TLexer.Create( 'IDENTIFIER 25 0.25 ''HELLO WORLD'' ' + 163 | '()[]' + 164 | '@.::/..//$,' + 165 | '+-*' + 166 | '=!=<><=>=' + 167 | 'OR AND DIV IDIV MOD ' + 168 | 'CHILD.DESCENDANT.DESCENDANT-OR-SELF.PARENT.SELF.' + 169 | 'FOLLOWING-SIBLING.FOLLOWING.NAMESPACE.ANCESTOR.' + 170 | 'PRECEDING-SIBLING.PRECEDING.ANCESTOR-OR-SELF ' + 171 | 'DOCUMENT-NODE ELEMENT ATTRIBUTE SCHEMA-ELEMENT SCHEMA-ATTRIBUTE ' + 172 | 'PROCESSING-INSTRUCTION COMMENT TEXT NODE' ); 173 | CheckToken( ttIdentifier, 'IDENTIFIER' ); 174 | CheckToken( ttInteger, '25' ); 175 | CheckToken( ttFloat, '0.25' ); 176 | CheckToken( ttString, 'HELLO WORLD' ); 177 | CheckToken( ttParenStart ); 178 | CheckToken( ttParenEnd ); 179 | CheckToken( ttBracketStart ); 180 | CheckToken( ttBracketEnd ); 181 | CheckToken( ttAt ); 182 | CheckToken( ttDot ); 183 | CheckToken( ttColonColon ); 184 | CheckToken( ttSlash ); 185 | CheckToken( ttDotDot ); 186 | CheckToken( ttDoubleSlash ); 187 | CheckToken( ttDollar ); 188 | CheckToken( ttComma ); 189 | CheckToken( ttPlus ); 190 | CheckToken( ttMinus ); 191 | CheckToken( ttMultiply ); 192 | CheckToken( ttEquals ); 193 | CheckToken( ttNotEquals ); 194 | CheckToken( ttLess ); 195 | CheckToken( ttGreater ); 196 | CheckToken( ttLessEqual ); 197 | CheckToken( ttGreaterEqual ); 198 | CheckToken( ttOr ); 199 | CheckToken( ttAnd ); 200 | CheckToken( ttDiv ); 201 | CheckToken( ttIDiv ); 202 | CheckToken( ttMod ); 203 | CheckToken( ttChild ); 204 | CheckToken( ttDot ); 205 | CheckToken( ttDescendant ); 206 | CheckToken( ttDot ); 207 | CheckToken( ttDescendantOrSelf ); 208 | CheckToken( ttDot ); 209 | CheckToken( ttParent ); 210 | CheckToken( ttDot ); 211 | CheckToken( ttSelf ); 212 | CheckToken( ttDot ); 213 | CheckToken( ttFollowingSibling ); 214 | CheckToken( ttDot ); 215 | CheckToken( ttFollowing ); 216 | CheckToken( ttDot ); 217 | CheckToken( ttNamespace ); 218 | CheckToken( ttDot ); 219 | CheckToken( ttAncestor ); 220 | CheckToken( ttDot ); 221 | CheckToken( ttPrecedingSibling ); 222 | CheckToken( ttDot ); 223 | CheckToken( ttPreceding ); 224 | CheckToken( ttDot ); 225 | CheckToken( ttAncestorOrSelf ); 226 | CheckToken( ttDocumentNode ); 227 | CheckToken( ttElement ); 228 | CheckToken( ttAttribute ); 229 | CheckToken( ttSchemaElement ); 230 | CheckToken( ttSchemaAttribute ); 231 | CheckToken( ttProcessingInstruction ); 232 | CheckToken( ttComment ); 233 | CheckToken( ttText ); 234 | CheckToken( ttNode ); 235 | CheckToken( ttEOF ); 236 | end; 237 | 238 | initialization 239 | RegisterTest(TestTLexer.Suite); 240 | end. 241 | 242 | -------------------------------------------------------------------------------- /XPath/UnitTest/XPathTests.dpr: -------------------------------------------------------------------------------- 1 | program XPathTests; 2 | 3 | {$IFDEF CONSOLE_TESTRUNNER} 4 | {$APPTYPE CONSOLE} 5 | {$ENDIF} 6 | 7 | uses 8 | DUnitTestRunner, 9 | TestLexer in 'TestLexer.pas', 10 | TestHtmlParser in 'TestHtmlParser.pas', 11 | TestXPath in 'TestXPath.pas', 12 | HtmlParser in '..\HtmlParser.pas', 13 | XPathLexer in '..\XPathLexer.pas', 14 | XPath in '..\XPath.pas'; 15 | 16 | {$R *.RES} 17 | 18 | begin 19 | DUnitTestRunner.RunRegisteredTests; 20 | end. 21 | 22 | -------------------------------------------------------------------------------- /XPath/UnitTest/XPathTests.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/delphiripper/comotobo/22a39d8425f07c7a6ddfc0758db309785b67b4d9/XPath/UnitTest/XPathTests.res -------------------------------------------------------------------------------- /XPath/XPath EBNF.txt: -------------------------------------------------------------------------------- 1 | XPath ::= Expr 2 | 3 | Expr ::= AndExpr { "or" AndExpr } 4 | AndExpr ::= ComparisonExpr { "and" ComparisonExpr } 5 | ComparisonExpr ::= AdditiveExpr { ("=" | "!=" | "<" | "<=" | ">" | ">=") AdditiveExpr } 6 | AdditiveExpr ::= MultiplicativeExpr { ("+" | "-") MultiplicativeExpr } 7 | MultiplicativeExpr ::= UnaryExpr { ("*" | "div" | "idiv" | "mod") UnaryExpr } 8 | 9 | UnaryExpr ::= { "-" | "+" } PathExpr 10 | PathExpr ::= [ "/" | "//" ] RelativePathExpr 11 | RelativePathExpr ::= StepExpr { ("/" | "//") StepExpr } 12 | StepExpr ::= ( PrimaryExpr | Step ) { Predicate } 13 | Step ::= (Axis "::" NodeTest) | ([ "@" ] NodeTest) | ".." 14 | NodeTest ::= KindTest | IDENTIFIER | "*" 15 | PrimaryExpr ::= INTEGER | FLOAT | STRING | ( "$" IDENTIFIER ) | ( "(" Expr ")" ) | "." | IDENTIFIER "(" [ ParameterList ] ")" 16 | ParameterList ::= ExprSingle { "," ExprSingle } 17 | KindTest ::= "document-node" DocumentTest 18 | | ElementTest 19 | | "attribute" AttributeTest 20 | | "schema-element" "(" IDENTIFIER ")" 21 | | "schema-attribute" "(" IDENTIFIER ")" 22 | | "processing-instruction" "(" [ NCName | StringLiteral ] ")" 23 | | "comment" "(" ")" 24 | | "text" "(" ")" 25 | | "node" "(" ")" 26 | DocumentTest ::= "(" [ ElementTest ] ")" 27 | AttributeTest ::= "(" [ ( IDENTIFIER | "*" ) [ "," TypeName ] ] ")" 28 | ElementTest ::= "element" "(" [ ( IDENTIFIER | "*" ) [ "," TypeName [ "?" ] ] ] ")" 29 | 30 | TypeName ::= IDENTIFIER 31 | Axis ::= "child" | "descendant" | "attribute" | "self" | "descendant-or-self" | "following-sibling" | "following" | "namespace" | 32 | "parent" | "ancestor" | "preceding-sibling" | "preceding" | "ancestor-or-self" 33 | 34 | 35 | 36 | 37 | /////////////////////////////////////////////////////////////////// 38 | 39 | 40 | 41 | 42 | 43 | 44 | XPath ::= Expr 45 | Expr ::= ExprSingle ("," ExprSingle)* 46 | ExprSingle ::= ForExpr 47 | | QuantifiedExpr 48 | | IfExpr 49 | | OrExpr 50 | ForExpr ::= SimpleForClause "return" ExprSingle 51 | SimpleForClause ::= "for" "$" VarName "in" ExprSingle ("," "$" VarName "in" ExprSingle)* 52 | QuantifiedExpr ::= ("some" | "every") "$" VarName "in" ExprSingle ("," "$" VarName "in" ExprSingle)* "satisfies" ExprSingle 53 | IfExpr ::= "if" "(" Expr ")" "then" ExprSingle "else" ExprSingle 54 | OrExpr ::= AndExpr ( "or" AndExpr )* 55 | AndExpr ::= ComparisonExpr ( "and" ComparisonExpr )* 56 | ComparisonExpr ::= RangeExpr ( (ValueComp 57 | | GeneralComp 58 | | NodeComp) RangeExpr )? 59 | RangeExpr ::= AdditiveExpr ( "to" AdditiveExpr )? 60 | AdditiveExpr ::= MultiplicativeExpr ( ("+" | "-") MultiplicativeExpr )* 61 | MultiplicativeExpr ::= UnionExpr ( ("*" | "div" | "idiv" | "mod") UnionExpr )* 62 | UnionExpr ::= IntersectExceptExpr ( ("union" | "|") IntersectExceptExpr )* 63 | IntersectExceptExpr ::= InstanceofExpr ( ("intersect" | "except") InstanceofExpr )* 64 | InstanceofExpr ::= TreatExpr ( "instance" "of" SequenceType )? 65 | TreatExpr ::= CastableExpr ( "treat" "as" SequenceType )? 66 | CastableExpr ::= CastExpr ( "castable" "as" SingleType )? 67 | CastExpr ::= UnaryExpr ( "cast" "as" SingleType )? 68 | UnaryExpr ::= ("-" | "+")* ValueExpr 69 | ValueExpr ::= PathExpr 70 | GeneralComp ::= "=" | "!=" | "<" | "<=" | ">" | ">=" 71 | ValueComp ::= "eq" | "ne" | "lt" | "le" | "gt" | "ge" 72 | NodeComp ::= "is" | "<<" | ">>" 73 | PathExpr ::= ("/" RelativePathExpr?) 74 | | ("//" RelativePathExpr) 75 | | RelativePathExpr/* xgs: leading-lone-slash */ 76 | RelativePathExpr ::= StepExpr (("/" | "//") StepExpr)* 77 | StepExpr ::= FilterExpr | AxisStep 78 | AxisStep ::= (ReverseStep | ForwardStep) PredicateList 79 | ForwardStep ::= (ForwardAxis NodeTest) | AbbrevForwardStep 80 | ForwardAxis ::= ("child" "::") 81 | | ("descendant" "::") 82 | | ("attribute" "::") 83 | | ("self" "::") 84 | | ("descendant-or-self" "::") 85 | | ("following-sibling" "::") 86 | | ("following" "::") 87 | | ("namespace" "::") 88 | AbbrevForwardStep ::= "@"? NodeTest 89 | ReverseStep ::= (ReverseAxis NodeTest) | AbbrevReverseStep 90 | ReverseAxis ::= ("parent" "::") 91 | | ("ancestor" "::") 92 | | ("preceding-sibling" "::") 93 | | ("preceding" "::") 94 | | ("ancestor-or-self" "::") 95 | AbbrevReverseStep ::= ".." 96 | NodeTest ::= KindTest | NameTest 97 | NameTest ::= QName | Wildcard 98 | Wildcard ::= "*" 99 | | (NCName ":" "*") 100 | | ("*" ":" NCName) /* ws: explicit */ 101 | FilterExpr ::= PrimaryExpr PredicateList 102 | PredicateList ::= Predicate* 103 | Predicate ::= "[" Expr "]" 104 | PrimaryExpr ::= Literal | VarRef | ParenthesizedExpr | ContextItemExpr | FunctionCall 105 | Literal ::= NumericLiteral | StringLiteral 106 | NumericLiteral ::= IntegerLiteral | DecimalLiteral | DoubleLiteral 107 | VarRef ::= "$" VarName 108 | VarName ::= QName 109 | ParenthesizedExpr ::= "(" Expr? ")" 110 | ContextItemExpr ::= "." 111 | FunctionCall ::= QName "(" (ExprSingle ("," ExprSingle)*)? ")"/* xgs: reserved-function-names */ 112 | /* gn: parens */ 113 | SingleType ::= AtomicType "?"? 114 | SequenceType ::= ("empty-sequence" "(" ")") 115 | | (ItemType OccurrenceIndicator?) 116 | OccurrenceIndicator ::= "?" | "*" | "+" /* xgs: occurrence-indicators */ 117 | ItemType ::= KindTest | ("item" "(" ")") | AtomicType 118 | AtomicType ::= QName 119 | KindTest ::= DocumentTest 120 | | ElementTest 121 | | AttributeTest 122 | | SchemaElementTest 123 | | SchemaAttributeTest 124 | | PITest 125 | | CommentTest 126 | | TextTest 127 | | AnyKindTest 128 | AnyKindTest ::= "node" "(" ")" 129 | DocumentTest ::= "document-node" "(" (ElementTest | SchemaElementTest)? ")" 130 | TextTest ::= "text" "(" ")" 131 | CommentTest ::= "comment" "(" ")" 132 | PITest ::= "processing-instruction" "(" (NCName | StringLiteral)? ")" 133 | AttributeTest ::= "attribute" "(" (AttribNameOrWildcard ("," TypeName)?)? ")" 134 | AttribNameOrWildcard ::= AttributeName | "*" 135 | SchemaAttributeTest ::= "schema-attribute" "(" AttributeDeclaration ")" 136 | AttributeDeclaration ::= AttributeName 137 | ElementTest ::= "element" "(" (ElementNameOrWildcard ("," TypeName "?"?)?)? ")" 138 | ElementNameOrWildcard ::= ElementName | "*" 139 | SchemaElementTest ::= "schema-element" "(" ElementDeclaration ")" 140 | ElementDeclaration ::= ElementName 141 | AttributeName ::= QName 142 | ElementName ::= QName 143 | TypeName ::= QName 144 | -------------------------------------------------------------------------------- /XPath/XPathGroup.groupproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {5A0E92E0-2FBC-4546-9210-04C8BD0294CC} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | Default.Personality.12 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | --------------------------------------------------------------------------------