├── .gitignore ├── LICENSE.md ├── README.md ├── TMQTTClient ├── MQTT.pas └── MQTTReadThread.pas ├── examples ├── embeddedApp │ ├── README.md │ ├── build.sh │ ├── build_debian_amd64.sh │ ├── embeddedApp.lpi │ ├── embeddedApp.pas │ ├── payload.txt │ └── pub.sh └── fpcConsole │ ├── fpcConsoleMQTT.lpi │ └── fpcConsoleMQTT.pas ├── ptop.cfg └── synapse ├── blcksock.pas ├── jedi.inc ├── ssfpc.inc ├── synacode.pas ├── synafpc.pas ├── synaip.pas ├── synautil.pas └── synsock.pas /.gitignore: -------------------------------------------------------------------------------- 1 | *.dcu 2 | *.~*~ 3 | *.local 4 | *.identcache 5 | __history 6 | *.drc 7 | *.map 8 | *.exe 9 | *.dll 10 | bin/* 11 | *.o 12 | *.ppu 13 | *.*~ 14 | examples/embeddedApp/embeddedApp 15 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 Jamie Ingilby 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | mqtt-free-pascal 2 | ================ 3 | 4 | This the MQTT client code for Delphi by Jamie Ingilby with changes to make it useable in Free Pascal. 5 | 6 | http://jamiei.com/blog/code/mqtt-client-library-for-delphi/ 7 | 8 | Changes: 9 | -------- 10 | 11 | 1) Rewrote the reader thread loop so as to make it simpler and faster also fixes a bug whereby the 12 | client would segfault if the server went down and a major bug where timeouts on rx would cause data corruption. 13 | 14 | 2) Replaced the original client demo code with a simpler demo that does not use forms. I am using 15 | this in an embedded system with no display. 16 | 17 | 3) Changed all strings to ansi strings so that it can have topics and payloads longer than 255 bytes. 18 | 19 | 4) Also includes the parts of Ararat Synapse required to build. 20 | 21 | To build the demo: 22 | ------------------ 23 | 24 | $ cd examples/embeddedApp 25 | $ ./build 26 | 27 | 28 | Running embeddedApp out of the box reqires you have access to test.mosquitto.org. 29 | 30 | TODO 31 | ---- 32 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /TMQTTClient/MQTT.pas: -------------------------------------------------------------------------------- 1 | { 2 | ------------------------------------------------- 3 | MQTT.pas - A Library for Publishing and Subscribing to messages from an MQTT Message 4 | broker such as the RSMB (http://alphaworks.ibm.com/tech/rsmb). 5 | 6 | MQTT - http://mqtt.org/ 7 | Spec - http://publib.boulder.ibm.com/infocenter/wmbhelp/v6r0m0/topic/com.ibm.etools.mft.doc/ac10840_.htm 8 | 9 | MIT License - http://www.opensource.org/licenses/mit-license.php 10 | Copyright (c) 2009 Jamie Ingilby 11 | 12 | Permission is hereby granted, free of charge, to any person obtaining a copy 13 | of this software and associated documentation files (the "Software"), to deal 14 | in the Software without restriction, including without limitation the rights 15 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 16 | copies of the Software, and to permit persons to whom the Software is 17 | furnished to do so, subject to the following conditions: 18 | 19 | The above copyright notice and this permission notice shall be included in 20 | all copies or substantial portions of the Software. 21 | 22 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 23 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 24 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 25 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 26 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 27 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 28 | THE SOFTWARE. 29 | ------------------------------------------------- 30 | } 31 | 32 | {$mode objfpc} 33 | 34 | unit MQTT; 35 | 36 | interface 37 | 38 | uses 39 | SysUtils, blcksock, contnrs, MQTTReadThread; 40 | 41 | type 42 | // Message type. 4 Bit unsigned. 43 | TMQTTMessageType = ( 44 | Reserved0, // 0 Reserved 45 | CONNECT, // 1 Client request to connect to Broker 46 | CONNACK, // 2 Connect Acknowledgment 47 | // PUBLISH Control Packet is sent from a Client to a Server or from Server to a Client to transport an Application Message. 48 | PUBLISH, // 3 Publish message 49 | PUBACK, // 4 Publish Acknowledgment 50 | PUBREC, // 5 Publish Received (assured delivery part 1) 51 | PUBREL, // 6 Publish Release (assured delivery part 2) 52 | PUBCOMP, // 7 Publish Complete (assured delivery part 3) 53 | SUBSCRIBE, // 8 Client Subscribe request 54 | SUBACK, // 9 Subscribe Acknowledgment 55 | UNSUBSCRIBE, // 10 Client Unsubscribe request 56 | UNSUBACK, // 11 Unsubscribe Acknowledgment 57 | PINGREQ, // 12 PING Request 58 | PINGRESP, // 13 PING Response 59 | DISCONNECT, // 14 Client is Disconnecting 60 | Reserved15 // 15 Reserved 61 | ); 62 | 63 | // The message class definition 64 | TMQTTMessage = class 65 | private 66 | FTopic: ansistring; 67 | FPayload: ansistring; 68 | FRetain: boolean; 69 | 70 | public 71 | property Topic: ansistring read FTopic; 72 | property PayLoad: ansistring read FPayload; 73 | property Retain: boolean read FRetain; 74 | 75 | constructor Create(const topic_: ansistring; const payload_: ansistring; 76 | const retain_: boolean); 77 | end; 78 | 79 | // The acknowledgement class definition 80 | TMQTTMessageAck = class 81 | private 82 | FMessageType: TMQTTMessageType; 83 | FMessageId: integer; 84 | FReturnCode: integer; 85 | FQos: integer; 86 | public 87 | property messageType: TMQTTMessageType read FMessageType; 88 | property messageId: integer read FMessageId; 89 | property returnCode: integer read FReturnCode; 90 | property qos: integer read FQos; 91 | 92 | constructor Create(const messageType_: TMQTTMessageType; 93 | const messageId_: integer; const returnCode_: integer; const qos_: integer); 94 | end; 95 | 96 | TRemainingLength = array of byte; 97 | TUTF8Text = array of byte; 98 | 99 | PMQTTClient = ^TMQTTClient; 100 | 101 | // Main object - MQTT client implementation 102 | TMQTTClient = class(TObject) 103 | private 104 | FClientID: ansistring; 105 | FHostname: ansistring; 106 | FPort: integer; 107 | FReadThread: TMQTTReadThread; 108 | FMessageID: integer; 109 | FisConnected: boolean; 110 | FReaderThreadRunning: boolean; 111 | 112 | FConnAckEvent: TConnAckEvent; 113 | FPublishEvent: TPublishEvent; 114 | FPingRespEvent: TPingRespEvent; 115 | FSubAckEvent: TSubAckEvent; 116 | FUnSubAckEvent: TUnSubAckEvent; 117 | 118 | FCritical: TRTLCriticalSection; 119 | FMessageQueue: TQueue; 120 | FMessageAckQueue: TQueue; 121 | 122 | // Gets a next Message ID and increases the Message ID Increment 123 | function GetMessageID: TBytes; 124 | function VariableHeaderPublish(topic: ansistring): TBytes; 125 | function VariableHeaderSubscribe: TBytes; 126 | function VariableHeaderUnsubscribe: TBytes; 127 | // Internally Write the provided data to the Socket. Wrapper function. 128 | function SocketWrite(Data: TBytes): boolean; 129 | 130 | // These are chained event handlers from the ReceiveThread. They trigger the 131 | // public TMQTTClient.On*** handlers. 132 | procedure OnRTConnAck(Sender: TObject; ReturnCode: integer); 133 | procedure OnRTPingResp(Sender: TObject); 134 | procedure OnRTSubAck(Sender: TObject; MessageID: integer; GrantedQoS: integer); 135 | procedure OnRTUnSubAck(Sender: TObject; MessageID: integer); 136 | procedure OnRTPublish(Sender: TObject; topic, payload: ansistring; 137 | retain: boolean); 138 | procedure OnRTTerminate(Sender: TObject); 139 | 140 | public 141 | function isConnected: boolean; 142 | procedure Connect; 143 | function Disconnect: boolean; 144 | procedure ForceDisconnect; 145 | function Publish(Topic: ansistring; sPayload: ansistring): boolean; overload; 146 | function Publish(Topic: ansistring; sPayload: ansistring; 147 | Retain: boolean): boolean; overload; 148 | function Subscribe(Topic: ansistring): integer; 149 | function Unsubscribe(Topic: ansistring): integer; 150 | function PingReq: boolean; 151 | function getMessage: TMQTTMessage; 152 | function getMessageAck: TMQTTMessageAck; 153 | constructor Create(Hostname: ansistring; Port: integer); overload; 154 | destructor Destroy; override; 155 | 156 | property ClientID: ansistring read FClientID write FClientID; 157 | property OnConnAck: TConnAckEvent read FConnAckEvent write FConnAckEvent; 158 | property OnPublish: TPublishEvent read FPublishEvent write FPublishEvent; 159 | property OnPingResp: TPingRespEvent read FPingRespEvent write FPingRespEvent; 160 | property OnSubAck: TSubAckEvent read FSubAckEvent write FSubAckEvent; 161 | property OnUnSubAck: TUnSubAckEvent read FUnSubAckEvent write FUnSubAckEvent; 162 | end; 163 | 164 | // Message Component Build helpers 165 | function FixedHeader(MessageType: TMQTTMessageType; Dup, Qos, Retain: byte): byte; 166 | 167 | // Variable Header per command creation funcs 168 | function VariableHeaderConnect(KeepAlive: word): TBytes; 169 | 170 | // Takes a ansistring and converts to An Array of Bytes preceded by 2 Length Bytes. 171 | function StrToBytes(str: ansistring; perpendLength: boolean): TUTF8Text; 172 | 173 | procedure CopyIntoArray(var DestArray: array of byte; SourceArray: array of byte; 174 | StartIndex: integer); 175 | 176 | // Byte Array Helper Functions 177 | procedure AppendArray(var Dest: TUTF8Text; Source: array of byte); 178 | 179 | // Helper Function - Puts the seperate component together into an Array of Bytes for transmission 180 | function BuildCommand(FixedHead: byte; RemainL: TRemainingLength; 181 | VariableHead: TBytes; Payload: array of byte): TBytes; 182 | 183 | // Calculates the Remaining Length bytes of the FixedHeader as per the spec. 184 | function RemainingLength(MessageLength: integer): TRemainingLength; 185 | 186 | 187 | implementation 188 | 189 | 190 | constructor TMQTTMessage.Create(const topic_: ansistring; 191 | const payload_: ansistring; const retain_: boolean); 192 | begin 193 | // Save the passed parameters 194 | FTopic := Topic_; 195 | FPayload := Payload_; 196 | FRetain := retain_; 197 | end; 198 | 199 | constructor TMQTTMessageAck.Create(const messageType_: TMQTTMessageType; 200 | const messageId_: integer; const returnCode_: integer; const qos_: integer); 201 | begin 202 | FMessageType := messageType_; 203 | FMessageId := messageId_; 204 | FReturnCode := returnCode_; 205 | FQos := qos_; 206 | end; 207 | 208 | {*------------------------------------------------------------------------------ 209 | Instructs the Client to try to connect to the server at TMQTTClient.Hostname and 210 | TMQTTClient.Port and then to send the initial CONNECT message as required by the 211 | protocol. Check for a CONACK message to verify successful connection. 212 | ------------------------------------------------------------------------------*} 213 | procedure TMQTTClient.Connect; 214 | begin 215 | if FReaderThreadRunning = False then 216 | begin 217 | // Create and start RX thread 218 | if FReadThread <> nil then 219 | begin 220 | FReadThread.OnTerminate := nil; 221 | FreeAndNil(FReadThread); 222 | end; 223 | FReadThread := TMQTTReadThread.Create(FHostname, FPort); 224 | FReadThread.OnConnAck := @OnRTConnAck; 225 | FReadThread.OnPublish := @OnRTPublish; 226 | FReadThread.OnPublish := @OnRTPublish; 227 | FReadThread.OnPingResp := @OnRTPingResp; 228 | FReadThread.OnSubAck := @OnRTSubAck; 229 | FReadThread.OnTerminate := @OnRTTerminate; 230 | FReadThread.Start; 231 | FReaderThreadRunning := True; 232 | end; 233 | end; 234 | 235 | {*------------------------------------------------------------------------------ 236 | Sends the DISCONNECT packets and then Disconnects gracefully from the server 237 | which it is currently connected to. 238 | @return Returns whether the Data was written successfully to the socket. 239 | ------------------------------------------------------------------------------*} 240 | function TMQTTClient.Disconnect: boolean; 241 | var 242 | Data: TBytes; 243 | begin 244 | writeln('TMQTTClient.Disconnect'); 245 | Result := False; 246 | 247 | SetLength(Data, 2); 248 | Data[0] := FixedHeader(MQTT.DISCONNECT, 0, 0, 0); 249 | Data[1] := 0; 250 | if SocketWrite(Data) then 251 | begin 252 | FisConnected := False; 253 | if FReadThread <> nil then 254 | begin 255 | //todo: collect all terminate code (connect, Disconnect, ForceDisconnect) to one point 256 | FReadThread.OnTerminate := nil; 257 | FReadThread.Terminate; 258 | FReadThread := nil; 259 | //todo: the probability of a hang? 260 | //FReadThread.waitFor; 261 | end; 262 | Result := True; 263 | end 264 | else 265 | Result := False; 266 | end; 267 | 268 | {*------------------------------------------------------------------------------ 269 | Terminate the reader thread and close the socket forcibly. 270 | ------------------------------------------------------------------------------*} 271 | procedure TMQTTClient.ForceDisconnect; 272 | begin 273 | writeln('TMQTTClient.ForceDisconnect'); 274 | if FReadThread <> nil then 275 | begin 276 | FReadThread.OnTerminate := nil; 277 | FReadThread.Terminate; 278 | FReadThread := nil; 279 | end; 280 | FisConnected := False; 281 | end; 282 | 283 | {*------------------------------------------------------------------------------ 284 | Call back for reader thread termination. 285 | ------------------------------------------------------------------------------*} 286 | procedure TMQTTClient.OnRTTerminate(Sender: TObject); 287 | begin 288 | //todo: on terminating - need disable this object 289 | FReadThread := nil; 290 | FReaderThreadRunning := False; 291 | FisConnected := False; 292 | WriteLn('TMQTTClient.OnRTTerminate: Thread.Terminated.'); 293 | end; 294 | 295 | {*------------------------------------------------------------------------------ 296 | Sends a PINGREQ to the server informing it that the client is alice and that it 297 | should send a PINGRESP back in return. 298 | @return Returns whether the Data was written successfully to the socket. 299 | ------------------------------------------------------------------------------*} 300 | function TMQTTClient.PingReq: boolean; 301 | var 302 | FH: byte; 303 | RL: byte; 304 | Data: TBytes; 305 | begin 306 | Result := False; 307 | 308 | SetLength(Data, 2); 309 | FH := FixedHeader(MQTT.PINGREQ, 0, 0, 0); 310 | RL := 0; 311 | Data[0] := FH; 312 | Data[1] := RL; 313 | if SocketWrite(Data) then 314 | Result := True 315 | else 316 | Result := False; 317 | end; 318 | 319 | {*------------------------------------------------------------------------------ 320 | Publishes a message sPayload to the Topic on the remote broker with the retain flag 321 | defined as given in the 3rd parameter. 322 | @param Topic The Topic Name of your message eg /station1/temperature/ 323 | @param sPayload The Actual Payload of the message eg 18 degrees celcius 324 | @param Retain Should this message be retained for clients connecting subsequently 325 | @return Returns whether the Data was written successfully to the socket. 326 | ------------------------------------------------------------------------------*} 327 | function TMQTTClient.Publish(Topic, sPayload: ansistring; Retain: boolean): boolean; 328 | var 329 | Data: TBytes; 330 | FH: byte; 331 | RL: TRemainingLength; 332 | VH: TBytes; 333 | Payload: TUTF8Text; 334 | begin 335 | Result := False; 336 | 337 | FH := FixedHeader(MQTT.PUBLISH, 0, 0, Ord(Retain)); 338 | VH := VariableHeaderPublish(Topic); 339 | SetLength(Payload, 0); 340 | AppendArray(Payload, StrToBytes(sPayload, False)); 341 | RL := RemainingLength(Length(VH) + Length(Payload)); 342 | Data := BuildCommand(FH, RL, VH, Payload); 343 | if SocketWrite(Data) then 344 | Result := True 345 | else 346 | Result := False; 347 | end; 348 | 349 | {*------------------------------------------------------------------------------ 350 | Publishes a message sPayload to the Topic on the remote broker with the retain flag 351 | defined as False. 352 | @param Topic The Topic Name of your message eg /station1/temperature/ 353 | @param sPayload The Actual Payload of the message eg 18 degrees celcius 354 | @return Returns whether the Data was written successfully to the socket. 355 | ------------------------------------------------------------------------------*} 356 | function TMQTTClient.Publish(Topic, sPayload: ansistring): boolean; 357 | begin 358 | Result := Publish(Topic, sPayload, False); 359 | end; 360 | 361 | {*------------------------------------------------------------------------------ 362 | Subscribe to Messages published to the topic specified. Only accepts 1 topic per 363 | call at this point. 364 | @param Topic The Topic that you wish to Subscribe to. 365 | @return Returns the Message ID used to send the message for the purpose of comparing 366 | it to the Message ID used later in the SUBACK event handler. 367 | ------------------------------------------------------------------------------*} 368 | function TMQTTClient.Subscribe(Topic: ansistring): integer; 369 | var 370 | Data: TBytes; 371 | FH: byte; 372 | RL: TRemainingLength; 373 | VH: TBytes; 374 | Payload: TUTF8Text; 375 | begin 376 | FH := FixedHeader(MQTT.SUBSCRIBE, 0, 1, 0); 377 | VH := VariableHeaderSubscribe; 378 | Result := (FMessageID - 1); 379 | SetLength(Payload, 0); 380 | AppendArray(Payload, StrToBytes(Topic, True)); 381 | // Append a new Byte to Add the Requested QoS Level for that Topic 382 | SetLength(Payload, Length(Payload) + 1); 383 | // Always Append Requested QoS Level 0 384 | Payload[Length(Payload) - 1] := $0; 385 | RL := RemainingLength(Length(VH) + Length(Payload)); 386 | Data := BuildCommand(FH, RL, VH, Payload); 387 | SocketWrite(Data); 388 | end; 389 | 390 | {*------------------------------------------------------------------------------ 391 | Unsubscribe to Messages published to the topic specified. Only accepts 1 topic per 392 | call at this point. 393 | @param Topic The Topic that you wish to Unsubscribe to. 394 | @return Returns the Message ID used to send the message for the purpose of comparing 395 | it to the Message ID used later in the UNSUBACK event handler. 396 | ------------------------------------------------------------------------------*} 397 | function TMQTTClient.Unsubscribe(Topic: ansistring): integer; 398 | var 399 | Data: TBytes; 400 | FH: byte; 401 | RL: TRemainingLength; 402 | VH: TBytes; 403 | Payload: TUTF8Text; 404 | begin 405 | FH := FixedHeader(MQTT.UNSUBSCRIBE, 0, 0, 0); 406 | VH := VariableHeaderUnsubscribe; 407 | Result := (FMessageID - 1); 408 | SetLength(Payload, 0); 409 | AppendArray(Payload, StrToBytes(Topic, True)); 410 | RL := RemainingLength(Length(VH) + Length(Payload)); 411 | Data := BuildCommand(FH, RL, VH, Payload); 412 | SocketWrite(Data); 413 | end; 414 | 415 | {*------------------------------------------------------------------------------ 416 | Not Reliable. This is a leaky abstraction. The Core Socket components can only 417 | tell if the connection is truly Connected if they try to read or write to the 418 | socket. Therefore this reflects a boolean flag which is set in the 419 | TMQTTClient.Connect and .Disconnect methods. 420 | @return Returns whether the internal connected flag is set or not. 421 | ------------------------------------------------------------------------------*} 422 | function TMQTTClient.isConnected: boolean; 423 | begin 424 | Result := FisConnected; 425 | end; 426 | 427 | {*------------------------------------------------------------------------------ 428 | Component Constructor, 429 | @param Hostname Hostname of the MQTT Server 430 | @param Port Port of the MQTT Server 431 | @return Instance 432 | ------------------------------------------------------------------------------*} 433 | constructor TMQTTClient.Create(Hostname: ansistring; Port: integer); 434 | begin 435 | inherited Create; 436 | Randomize; 437 | 438 | // Create a Default ClientID as a default. Can be overridden with TMQTTClient.ClientID any time before connection. 439 | FClientID := 'dMQTTClient' + IntToStr(Random(1000) + 1); 440 | FHostname := Hostname; 441 | FPort := Port; 442 | FMessageID := 1; 443 | FReaderThreadRunning := False; 444 | InitCriticalSection(FCritical); 445 | FMessageQueue := TQueue.Create; 446 | FMessageAckQueue := TQueue.Create; 447 | end; 448 | 449 | destructor TMQTTClient.Destroy; 450 | begin 451 | if (isConnected) and (FReadThread <> nil) then 452 | begin 453 | FReadThread.Terminate; 454 | FReadThread.WaitFor; 455 | //note: free is not needed - the FreeOnTerminate mode is enabled 456 | end; 457 | FMessageQueue.Free; 458 | FMessageAckQueue.Free; 459 | DoneCriticalSection(FCritical); 460 | inherited; 461 | end; 462 | 463 | function FixedHeader(MessageType: TMQTTMessageType; Dup, Qos, Retain: byte): byte; 464 | begin 465 | { Fixed Header Spec: 466 | byte 1 bits |7 6 5 4 | 3 | 2 1 | 0 | 467 | fields |Message Type| DUP flag | QoS level| RETAIN| 468 | } 469 | Result := byte(Ord(MessageType) shl 4) or (Dup shl 3) or (Qos shl 1) or 470 | (Retain shl 0); 471 | //todo: OLD code: Result := (Ord(MessageType) * 16) + (Dup * 8) + (Qos * 2) + (Retain * 1); 472 | end; 473 | 474 | function TMQTTClient.GetMessageID: TBytes; 475 | begin 476 | Assert((FMessageID > Low(word)), 'Message ID too low'); 477 | Assert((FMessageID < High(word)), 'Message ID has gotten too big'); 478 | 479 | { FMessageID is initialised to 1 upon TMQTTClient.Create 480 | The Message ID is a 16-bit unsigned integer, which typically increases by exactly 481 | one from one message to the next, but is not required to do so. 482 | The two bytes of the Message ID are ordered as MSB, followed by LSB (big-endian).} 483 | SetLength(Result, 2); 484 | Result[0] := Hi(FMessageID); 485 | Result[1] := Lo(FMessageID); 486 | Inc(FMessageID); 487 | end; 488 | 489 | function TMQTTClient.SocketWrite(Data: TBytes): boolean; 490 | var 491 | sentData: integer; 492 | begin 493 | Result := False; 494 | // Returns whether the Data was successfully written to the socket. 495 | if isConnected then 496 | Result := FReadThread.SocketWrite(Data); 497 | end; 498 | 499 | function StrToBytes(str: ansistring; perpendLength: boolean): TUTF8Text; 500 | var 501 | i, offset: integer; 502 | begin 503 | { This is a UTF-8 hack to give 2 Bytes of Length followed by the string itself. } 504 | if perpendLength then 505 | begin 506 | SetLength(Result, Length(str) + 2); 507 | Result[0] := Length(str) div 256; 508 | Result[1] := Length(str) mod 256; 509 | offset := 1; 510 | end 511 | else 512 | begin 513 | SetLength(Result, Length(str)); 514 | offset := -1; 515 | end; 516 | for I := 1 to Length(str) do 517 | Result[i + offset] := Ord(str[i]); 518 | end; 519 | 520 | function RemainingLength(MessageLength: integer): TRemainingLength; 521 | var 522 | byteindex: integer; 523 | digit: integer; 524 | begin 525 | SetLength(Result, 1); 526 | byteindex := 0; 527 | while (MessageLength > 0) do 528 | begin 529 | digit := MessageLength mod 128; 530 | MessageLength := MessageLength div 128; 531 | if MessageLength > 0 then 532 | begin 533 | digit := digit or $80; 534 | end; 535 | Result[byteindex] := digit; 536 | if MessageLength > 0 then 537 | begin 538 | Inc(byteindex); 539 | SetLength(Result, Length(Result) + 1); 540 | end; 541 | end; 542 | end; 543 | 544 | function VariableHeaderConnect(KeepAlive: word): TBytes; 545 | const 546 | //todo: version update! MQIsdp->MQTT. version 4! 547 | MQTT_PROTOCOL = 'MQIsdp'; 548 | MQTT_VERSION = 3; 549 | var 550 | Qos, Retain: word; 551 | {todo: connect flags 552 | 7 User Name Flag 553 | 6 Password Flag 554 | 5 Will Retain 555 | 4 Will QoS 556 | 3 Will QoS 557 | 2 Will Flag 558 | 1 Clean Session 559 | 0 Reserved } 560 | iByteIndex: integer; 561 | ProtoBytes: TUTF8Text; 562 | begin 563 | // Set the Length of our variable header array. 564 | SetLength(Result, 12); 565 | iByteIndex := 0; 566 | // Put out Protocol string in there. 567 | ProtoBytes := StrToBytes(MQTT_PROTOCOL, True); 568 | CopyIntoArray(Result, ProtoBytes, iByteIndex); 569 | Inc(iByteIndex, Length(ProtoBytes)); 570 | // Version Number = 3 571 | Result[iByteIndex] := MQTT_VERSION; 572 | Inc(iByteIndex); 573 | // Connect Flags 574 | Qos := 0; 575 | Retain := 0; 576 | Result[iByteIndex] := 0; 577 | Result[iByteIndex] := (Retain * 32) + (Qos * 16) + (1 * 4) + (1 * 2); 578 | Inc(iByteIndex); 579 | Result[iByteIndex] := 0; 580 | Inc(iByteIndex); 581 | Result[iByteIndex] := KeepAlive; 582 | end; 583 | 584 | function TMQTTClient.VariableHeaderPublish(topic: ansistring): TBytes; 585 | var 586 | BytesTopic: TUTF8Text; 587 | begin 588 | BytesTopic := StrToBytes(Topic, True); 589 | SetLength(Result, Length(BytesTopic)); 590 | CopyIntoArray(Result, BytesTopic, 0); 591 | end; 592 | 593 | function TMQTTClient.VariableHeaderSubscribe: TBytes; 594 | begin 595 | Result := GetMessageID; 596 | end; 597 | 598 | function TMQTTClient.VariableHeaderUnsubscribe: TBytes; 599 | begin 600 | Result := GetMessageID; 601 | end; 602 | 603 | procedure CopyIntoArray(var DestArray: array of byte; SourceArray: array of byte; 604 | StartIndex: integer); 605 | begin 606 | Assert(StartIndex >= 0); 607 | // WARNING! move causes range check error if source length is zero. 608 | if Length(SourceArray) > 0 then 609 | Move(SourceArray[0], DestArray[StartIndex], Length(SourceArray)); 610 | end; 611 | 612 | procedure AppendArray(var Dest: TUTF8Text; Source: array of byte); 613 | 614 | var 615 | DestLen: integer; 616 | begin 617 | // WARNING: move causes range check error if source length is zero! 618 | if Length(Source) > 0 then 619 | begin 620 | DestLen := Length(Dest); 621 | SetLength(Dest, DestLen + Length(Source)); 622 | Move(Source, Dest[DestLen], Length(Source)); 623 | end; 624 | end; 625 | 626 | function BuildCommand(FixedHead: byte; RemainL: TRemainingLength; 627 | VariableHead: TBytes; Payload: array of byte): TBytes; 628 | var 629 | iNextIndex: integer; 630 | begin 631 | // Attach Fixed Header (1 byte) 632 | iNextIndex := 0; 633 | SetLength(Result, 1); 634 | Result[iNextIndex] := FixedHead; 635 | 636 | // Attach RemainingLength (1-4 bytes) 637 | iNextIndex := Length(Result); 638 | SetLength(Result, Length(Result) + Length(RemainL)); 639 | CopyIntoArray(Result, RemainL, iNextIndex); 640 | 641 | // Attach Variable Head 642 | iNextIndex := Length(Result); 643 | SetLength(Result, Length(Result) + Length(VariableHead)); 644 | CopyIntoArray(Result, VariableHead, iNextIndex); 645 | 646 | // Attach Payload. 647 | iNextIndex := Length(Result); 648 | SetLength(Result, Length(Result) + Length(Payload)); 649 | CopyIntoArray(Result, Payload, iNextIndex); 650 | end; 651 | 652 | procedure TMQTTClient.OnRTConnAck(Sender: TObject; ReturnCode: integer); 653 | begin 654 | if ReturnCode = 0 then 655 | begin 656 | FisConnected := True; 657 | end; 658 | if Assigned(OnConnAck) then 659 | begin 660 | OnConnAck(Self, ReturnCode); 661 | end 662 | else 663 | begin 664 | // Protected code. 665 | EnterCriticalSection(FCritical); 666 | try 667 | FMessageAckQueue.Push(TMQTTMessageAck.Create(CONNACK, 0, ReturnCode, 0)); 668 | finally 669 | LeaveCriticalSection(FCritical); 670 | end; 671 | end; 672 | end; 673 | 674 | procedure TMQTTClient.OnRTPingResp(Sender: TObject); 675 | begin 676 | if Assigned(OnPingResp) then 677 | begin 678 | OnPingResp(Self); 679 | end 680 | else 681 | begin 682 | // Protected code. 683 | EnterCriticalSection(FCritical); 684 | try 685 | FMessageAckQueue.Push(TMQTTMessageAck.Create(PINGRESP, 0, 0, 0)); 686 | finally 687 | LeaveCriticalSection(FCritical); 688 | end; 689 | end; 690 | end; 691 | 692 | procedure TMQTTClient.OnRTPublish(Sender: TObject; topic, payload: ansistring; 693 | retain: boolean); 694 | begin 695 | if Assigned(OnPublish) then 696 | begin 697 | OnPublish(Self, topic, payload, retain); 698 | end 699 | else 700 | begin 701 | // Protected code. 702 | EnterCriticalSection(FCritical); 703 | try 704 | FMessageQueue.Push(TMQTTMessage.Create(topic, payload, retain)); 705 | finally 706 | LeaveCriticalSection(FCritical); 707 | end; 708 | end; 709 | end; 710 | 711 | procedure TMQTTClient.OnRTSubAck(Sender: TObject; MessageID: integer; 712 | GrantedQoS: integer); 713 | begin 714 | if Assigned(OnSubAck) then 715 | begin 716 | OnSubAck(Self, MessageID, GrantedQoS); 717 | end 718 | else 719 | begin 720 | // Protected code. 721 | EnterCriticalSection(FCritical); 722 | try 723 | FMessageAckQueue.Push(TMQTTMessageAck.Create(SUBACK, MessageID, 724 | 0, GrantedQos)); 725 | finally 726 | LeaveCriticalSection(FCritical); 727 | end; 728 | end; 729 | end; 730 | 731 | procedure TMQTTClient.OnRTUnSubAck(Sender: TObject; MessageID: integer); 732 | begin 733 | if Assigned(OnUnSubAck) then 734 | begin 735 | OnUnSubAck(Self, MessageID); 736 | end 737 | else 738 | begin 739 | // Protected code. 740 | EnterCriticalSection(FCritical); 741 | try 742 | FMessageAckQueue.Push(TMQTTMessageAck.Create(SUBACK, MessageID, 0, 0)); 743 | finally 744 | LeaveCriticalSection(FCritical); 745 | end; 746 | end; 747 | end; 748 | 749 | function TMQTTClient.getMessage: TMQTTMessage; 750 | begin 751 | // Protected code. 752 | EnterCriticalSection(FCritical); 753 | try 754 | Result := TMQTTMessage(FMessageQueue.Pop); 755 | finally 756 | LeaveCriticalSection(FCritical); 757 | end; 758 | end; 759 | 760 | function TMQTTClient.getMessageAck: TMQTTMessageAck; 761 | begin 762 | // Protected code. 763 | EnterCriticalSection(FCritical); 764 | try 765 | Result := TMQTTMessageAck(FMessageAckQueue.Pop); 766 | finally 767 | LeaveCriticalSection(FCritical); 768 | end; 769 | end; 770 | 771 | end. 772 | -------------------------------------------------------------------------------- /TMQTTClient/MQTTReadThread.pas: -------------------------------------------------------------------------------- 1 | { 2 | ------------------------------------------------- 3 | MQTTReadThread.pas - Contains the socket receiving thread that is part of the 4 | TMQTTClient library (MQTT.pas). 5 | 6 | MIT License - http://www.opensource.org/licenses/mit-license.php 7 | Copyright (c) 2009 Jamie Ingilby 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the "Software"), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. 26 | ------------------------------------------------- 27 | } 28 | 29 | {$mode objfpc} 30 | 31 | unit MQTTReadThread; 32 | 33 | interface 34 | 35 | uses 36 | SysUtils, Classes, blcksock, synsock; 37 | 38 | type 39 | TBytes = array of byte; 40 | 41 | type 42 | TMQTTMessage = record 43 | FixedHeader: byte; 44 | RL: TBytes; 45 | Data: TBytes; 46 | end; 47 | 48 | type 49 | TRxStates = (RX_START, RX_FIXED_HEADER, RX_LENGTH, RX_DATA, RX_ERROR); 50 | 51 | TRemainingLength = array of byte; 52 | 53 | TUTF8Text = array of byte; 54 | 55 | TConnAckEvent = procedure(Sender: TObject; ReturnCode: integer) of object; 56 | TPublishEvent = procedure(Sender: TObject; topic, payload: ansistring; 57 | retain: boolean) of object; 58 | TPingRespEvent = procedure(Sender: TObject) of object; 59 | TSubAckEvent = procedure(Sender: TObject; MessageID: integer; 60 | GrantedQoS: integer) of object; 61 | TUnSubAckEvent = procedure(Sender: TObject; MessageID: integer) of object; 62 | 63 | TMQTTReadThread = class(TThread) 64 | private 65 | FClientID: ansistring; 66 | FHostname: ansistring; 67 | FPort: integer; 68 | CurrentMessage: TMQTTMessage; 69 | // Events 70 | FConnAckEvent: TConnAckEvent; 71 | FPublishEvent: TPublishEvent; 72 | FPingRespEvent: TPingRespEvent; 73 | FSubAckEvent: TSubAckEvent; 74 | FUnSubAckEvent: TUnSubAckEvent; 75 | 76 | // Takes a 2 Byte Length array and returns the length of the ansistring it preceeds as per the spec. 77 | function BytesToStrLength(LengthBytes: TBytes): integer; 78 | 79 | // This is our data processing and event firing command. 80 | procedure HandleData; 81 | protected 82 | procedure Execute; 83 | override; 84 | public 85 | //todo: change Socket resurse working 86 | FPSocket: TTCPBlockSocket; 87 | function SocketWrite(Data: TBytes): boolean; 88 | 89 | constructor Create(Hostname: ansistring; Port: integer); 90 | property OnConnAck: TConnAckEvent read FConnAckEvent write FConnAckEvent; 91 | property OnPublish: TPublishEvent read FPublishEvent write FPublishEvent; 92 | property OnPingResp: TPingRespEvent read FPingRespEvent write FPingRespEvent; 93 | property OnSubAck: TSubAckEvent read FSubAckEvent write FSubAckEvent; 94 | property OnUnSubAck: TUnSubAckEvent read FUnSubAckEvent write FUnSubAckEvent; 95 | end; 96 | 97 | implementation 98 | 99 | uses 100 | MQTT; 101 | 102 | procedure SetBit(var Value: byte; const Index: byte; const State: boolean); inline; 103 | begin 104 | Value := (Value and ((byte(1) shl Index) xor High(byte))) or 105 | (byte(State) shl Index); 106 | end; 107 | 108 | function GetBit(const Value: byte; const Index: byte): boolean; inline; 109 | begin 110 | Result := ((Value shr Index) and 1) = 1; 111 | end; 112 | 113 | { TMQTTReadThread } 114 | 115 | constructor TMQTTReadThread.Create(HostName: ansistring; Port: integer); 116 | begin 117 | inherited Create(True); 118 | 119 | // Create a Default ClientID as a default. Can be overridden with TMQTTClient.ClientID any time before connection. 120 | FClientID := 'dMQTTClientx' + IntToStr(Random(1000) + 1); 121 | FHostname := Hostname; 122 | FPort := Port; 123 | FreeOnTerminate := True; 124 | end; 125 | 126 | procedure TMQTTReadThread.Execute; 127 | var 128 | rxState: TRxStates; 129 | remainingLengthx: integer; 130 | digit: integer; 131 | multiplier: integer; 132 | Data: TBytes; 133 | RL: TRemainingLength; 134 | VH: TBytes; 135 | FH: byte; 136 | Payload: TUTF8Text; 137 | error: integer; 138 | begin 139 | rxState := RX_START; 140 | try 141 | // Create a socket. 142 | FPSocket := TTCPBlockSocket.Create; 143 | FPSocket.nonBlockMode := True; // We really don't want sending on 144 | FPSocket.NonblockSendTimeout := 1; 145 | // the socket to block our main thread. 146 | while not self.Terminated do 147 | begin 148 | case rxState of 149 | RX_START: 150 | begin 151 | // Make the socket connection 152 | FPSocket.Connect(FHostname, IntToStr(FPort)); 153 | 154 | // Build CONNECT message 155 | FH := FixedHeader(MQTT.CONNECT, 0, 0, 0); 156 | VH := VariableHeaderConnect(40); 157 | SetLength(Payload, 0); 158 | AppendArray(Payload, StrToBytes(FClientID, True)); 159 | AppendArray(Payload, StrToBytes('lwt', True)); 160 | AppendArray(Payload, StrToBytes(FClientID + ' died', True)); 161 | RL := RemainingLength(Length(VH) + Length(Payload)); 162 | Data := BuildCommand(FH, RL, VH, Payload); 163 | 164 | writeln('RX_START: ', FPSocket.LastErrorDesc); 165 | writeln('RX_START: ', FPSocket.LastError); 166 | 167 | //sleep(1); 168 | 169 | // Send CONNECT message 170 | while not self.Terminated do 171 | begin 172 | writeln('loop...'); 173 | SocketWrite(Data); 174 | error := FPSocket.LastError; 175 | writeln('RX_START: ', FPSocket.LastErrorDesc); 176 | writeln('RX_START: ', error); 177 | if error = 0 then 178 | begin 179 | rxState := RX_FIXED_HEADER; 180 | break; 181 | end 182 | else 183 | begin 184 | if error = 110 then 185 | begin 186 | continue; 187 | end; 188 | rxState := RX_ERROR; 189 | break; 190 | end; 191 | end; 192 | end; 193 | RX_FIXED_HEADER: 194 | begin 195 | multiplier := 1; 196 | remainingLengthx := 0; 197 | CurrentMessage.Data := nil; 198 | 199 | CurrentMessage.FixedHeader := FPSocket.RecvByte(1000); 200 | if (FPSocket.LastError = WSAETIMEDOUT) then 201 | continue; 202 | if (FPSocket.LastError <> 0) then 203 | rxState := RX_ERROR 204 | else 205 | rxState := RX_LENGTH; 206 | end; 207 | RX_LENGTH: 208 | begin 209 | digit := FPSocket.RecvByte(1000); 210 | if (FPSocket.LastError = WSAETIMEDOUT) then 211 | continue; 212 | if (FPSocket.LastError <> 0) then 213 | rxState := RX_ERROR 214 | else 215 | begin 216 | remainingLengthx := 217 | remainingLengthx + (digit and 127) * multiplier; 218 | if (digit and 128) > 0 then 219 | begin 220 | multiplier := multiplier * 128; 221 | rxState := RX_LENGTH; 222 | end 223 | else 224 | rxState := RX_DATA; 225 | end; 226 | end; 227 | RX_DATA: 228 | begin 229 | SetLength(CurrentMessage.Data, remainingLengthx); 230 | FPSocket.RecvBufferEx(Pointer(CurrentMessage.Data), 231 | remainingLengthx, 1000); 232 | if (FPSocket.LastError <> 0) then 233 | rxState := RX_ERROR 234 | else 235 | begin 236 | HandleData; 237 | rxState := RX_FIXED_HEADER; 238 | end; 239 | end; 240 | RX_ERROR: 241 | begin 242 | // Quit the loop, terminating the thread. 243 | break; 244 | end; 245 | end; 246 | end; 247 | finally 248 | FPSocket.CloseSocket(); 249 | FreeAndNil(FPSocket); 250 | end; // try 251 | end; 252 | 253 | procedure TMQTTReadThread.HandleData; 254 | var 255 | MessageType: byte; 256 | DataLen: integer; 257 | QoS: integer; 258 | Retain: boolean; 259 | Topic: ansistring; 260 | Payload: ansistring; 261 | ResponseVH: TBytes; 262 | ConnectReturn: integer; 263 | begin 264 | if (CurrentMessage.FixedHeader <> 0) then 265 | begin 266 | MessageType := CurrentMessage.FixedHeader shr 4; 267 | 268 | if (MessageType = Ord(MQTT.CONNACK)) then 269 | begin 270 | // Check if we were given a Connect Return Code. 271 | // Any return code except 0 is an Error 272 | if ((Length(CurrentMessage.Data) > 0) and 273 | (Length(CurrentMessage.Data) < 4)) then 274 | begin 275 | ConnectReturn := CurrentMessage.Data[1]; 276 | if Assigned(OnConnAck) then 277 | OnConnAck(Self, ConnectReturn); 278 | end; 279 | end 280 | else 281 | if (MessageType = Ord(MQTT.PUBLISH)) then 282 | begin 283 | Retain := GetBit(CurrentMessage.FixedHeader, 0); 284 | // Read the Length Bytes 285 | DataLen := BytesToStrLength(Copy(CurrentMessage.Data, 0, 2)); 286 | // Get the Topic 287 | SetString(Topic, PChar(@CurrentMessage.Data[2]), DataLen); 288 | // Get the Payload 289 | SetString(Payload, PChar(@CurrentMessage.Data[2 + DataLen]), 290 | (Length(CurrentMessage.Data) - 2 - DataLen)); 291 | if Assigned(OnPublish) then 292 | OnPublish(Self, Topic, Payload, retain); 293 | end 294 | else 295 | if (MessageType = Ord(MQTT.SUBACK)) then 296 | begin 297 | // Reading the Message ID 298 | ResponseVH := Copy(CurrentMessage.Data, 0, 2); 299 | DataLen := BytesToStrLength(ResponseVH); 300 | // Next Read the Granted QoS 301 | QoS := 0; 302 | if (Length(CurrentMessage.Data) - 2) > 0 then 303 | begin 304 | ResponseVH := Copy(CurrentMessage.Data, 2, 1); 305 | QoS := ResponseVH[0]; 306 | end; 307 | if Assigned(OnSubAck) then 308 | OnSubAck(Self, DataLen, QoS); 309 | end 310 | else 311 | if (MessageType = Ord(MQTT.UNSUBACK)) then 312 | begin 313 | // Read the Message ID for the event handler 314 | ResponseVH := Copy(CurrentMessage.Data, 0, 2); 315 | DataLen := BytesToStrLength(ResponseVH); 316 | if Assigned(OnUnSubAck) then 317 | OnUnSubAck(Self, DataLen); 318 | end 319 | else 320 | if (MessageType = Ord(MQTT.PINGRESP)) then 321 | begin 322 | if Assigned(OnPingResp) then 323 | OnPingResp(Self); 324 | end; 325 | end; 326 | end; 327 | 328 | function TMQTTReadThread.BytesToStrLength(LengthBytes: TBytes): integer; 329 | begin 330 | Assert(Length(LengthBytes) = 2, 331 | 'TMQTTReadThread: UTF-8 Length Bytes preceeding the text must be 2 Bytes in Legnth'); 332 | 333 | Result := 0; 334 | Result := LengthBytes[0] shl 8; 335 | Result := Result + LengthBytes[1]; 336 | end; 337 | 338 | function TMQTTReadThread.SocketWrite(Data: TBytes): boolean; 339 | var 340 | sentData: integer; 341 | begin 342 | Result := False; 343 | // Returns whether the Data was successfully written to the socket. 344 | 345 | while not FPSocket.CanWrite(0) do 346 | begin 347 | sleep(100); 348 | end; 349 | 350 | sentData := FPSocket.SendBuffer(Pointer(Data), Length(Data)); 351 | if sentData = Length(Data) then 352 | Result := True; 353 | end; 354 | 355 | end. 356 | -------------------------------------------------------------------------------- /examples/embeddedApp/README.md: -------------------------------------------------------------------------------- 1 | embeddedApp.pas is an example of using MQTT from a command line program as might be 2 | used in an embedded system. 3 | 4 | Out of the box it requires access to the MQTT server at test.mosquitto.org on port 1883 5 | 6 | Build with: 7 | 8 | $ ./build 9 | 10 | Or or Debian Wheezy for amd64: 11 | 12 | $ build_debian_amd64.sh 13 | 14 | and run as: 15 | 16 | $ ./embeddedApp 17 | 18 | -------------------------------------------------------------------------------- /examples/embeddedApp/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Build the embeddedApp MQTT client example. 4 | 5 | # Debug build 6 | fpc -gl -CR -Or -gh embeddedApp.pas -Fu../../TMQTTClient/ -Fu../../synapse 7 | 8 | # Release build 9 | #fpc -O3 -Or -gh embeddedApp.pas -Fu../../TMQTTClient/ -Fu../../synapse 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /examples/embeddedApp/build_debian_amd64.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Build the embeddedApp MQTT client exapmple on Debian Jessie amd64 4 | 5 | rm ../../TMQTTClient/*.ppu 6 | rm ../../TMQTTClient/*.o 7 | rm *.ppu 8 | rm *.o 9 | rm embeddedapp 10 | 11 | # For some reason the linker needs to know where to find crti.o 12 | # on Debian amd64 13 | fpc embeddedApp.pas -Fl/usr/lib/x86_64-linux-gnu/ -Fu../../TMQTTClient/ -Fu../../synapse 14 | 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /examples/embeddedApp/embeddedApp.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | <UseAppBundle Value="False"/> 16 | <ResourceType Value="res"/> 17 | </General> 18 | <BuildModes Count="2"> 19 | <Item1 Name="debug" Default="True"/> 20 | <Item2 Name="release"> 21 | <CompilerOptions> 22 | <Version Value="11"/> 23 | <PathDelim Value="\"/> 24 | <Target> 25 | <Filename Value="embeddedApp"/> 26 | </Target> 27 | <SearchPaths> 28 | <OtherUnitFiles Value="..\..\TMQTTClient"/> 29 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 30 | </SearchPaths> 31 | <Linking> 32 | <Debugging> 33 | <GenerateDebugInfo Value="False"/> 34 | </Debugging> 35 | </Linking> 36 | <Other> 37 | <CustomOptions Value="-dUseCThreads"/> 38 | </Other> 39 | </CompilerOptions> 40 | </Item2> 41 | </BuildModes> 42 | <PublishOptions> 43 | <Version Value="2"/> 44 | </PublishOptions> 45 | <RunParams> 46 | <local> 47 | <FormatVersion Value="1"/> 48 | </local> 49 | </RunParams> 50 | <RequiredPackages Count="1"> 51 | <Item1> 52 | <PackageName Value="laz_synapse"/> 53 | </Item1> 54 | </RequiredPackages> 55 | <Units Count="3"> 56 | <Unit0> 57 | <Filename Value="embeddedApp.pas"/> 58 | <IsPartOfProject Value="True"/> 59 | </Unit0> 60 | <Unit1> 61 | <Filename Value="..\..\TMQTTClient\MQTT.pas"/> 62 | <IsPartOfProject Value="True"/> 63 | </Unit1> 64 | <Unit2> 65 | <Filename Value="..\..\TMQTTClient\MQTTReadThread.pas"/> 66 | <IsPartOfProject Value="True"/> 67 | </Unit2> 68 | </Units> 69 | </ProjectOptions> 70 | <CompilerOptions> 71 | <Version Value="11"/> 72 | <PathDelim Value="\"/> 73 | <Target> 74 | <Filename Value="embeddedApp"/> 75 | </Target> 76 | <SearchPaths> 77 | <OtherUnitFiles Value="..\..\TMQTTClient"/> 78 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 79 | </SearchPaths> 80 | <Parsing> 81 | <SyntaxOptions> 82 | <IncludeAssertionCode Value="True"/> 83 | </SyntaxOptions> 84 | </Parsing> 85 | <CodeGeneration> 86 | <Checks> 87 | <IOChecks Value="True"/> 88 | <RangeChecks Value="True"/> 89 | <OverflowChecks Value="True"/> 90 | </Checks> 91 | <VerifyObjMethodCallValidity Value="True"/> 92 | </CodeGeneration> 93 | <Linking> 94 | <Debugging> 95 | <UseHeaptrc Value="True"/> 96 | <TrashVariables Value="True"/> 97 | </Debugging> 98 | </Linking> 99 | <Other> 100 | <CustomOptions Value="-dUseCThreads"/> 101 | </Other> 102 | </CompilerOptions> 103 | <Debugging> 104 | <Exceptions Count="3"> 105 | <Item1> 106 | <Name Value="EAbort"/> 107 | </Item1> 108 | <Item2> 109 | <Name Value="ECodetoolError"/> 110 | </Item2> 111 | <Item3> 112 | <Name Value="EFOpenError"/> 113 | </Item3> 114 | </Exceptions> 115 | </Debugging> 116 | </CONFIG> 117 | -------------------------------------------------------------------------------- /examples/embeddedApp/embeddedApp.pas: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | { 5 | ------------------------------------------------- 6 | embeddedApp.pas - An example of using the MQTT Client from a command line program 7 | as might be used in an embedded system. 8 | 9 | MQTT - http://mqtt.org/ 10 | Spec - http://publib.boulder.ibm.com/infocenter/wmbhelp/v6r0m0/topic/com.ibm.etools.mft.doc/ac10840_.htm 11 | 12 | MIT License - http://www.opensource.org/licenses/mit-license.php 13 | Copyright (c) 2009 RSM Ltd. 14 | 15 | Permission is hereby granted, free of charge, to any person obtaining a copy 16 | of this software and associated documentation files (the "Software"), to deal 17 | in the Software without restriction, including without limitation the rights 18 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 19 | copies of the Software, and to permit persons to whom the Software is 20 | furnished to do so, subject to the following conditions: 21 | 22 | The above copyright notice and this permission notice shall be included in 23 | all copies or substantial portions of the Software. 24 | 25 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 26 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 27 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 28 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 29 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 30 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 31 | THE SOFTWARE. 32 | ------------------------------------------------- 33 | } 34 | 35 | {$mode objfpc} 36 | 37 | program embeddedApp; 38 | 39 | // cthreads is required to get the MQTTReadThread working. 40 | 41 | uses 42 | {$IFDEF UNIX} {$IFDEF UseCThreads} 43 | cthreads, {$ENDIF} {$ENDIF} 44 | Classes, MQTT, laz_synapse, sysutils; 45 | 46 | // The major states of the application. 47 | 48 | const 49 | pubTimerInterval = 60*10; // 60 - 1 minute 50 | pingTimerInterval = 10*10; // 10 - ping every 10 sec 51 | MQTT_Server = '192.168.1.19'; 52 | MQTT_Topic = '/jack/says'; 53 | //MQTT_Server = '192.168.0.26'; 54 | 55 | type TembeddedAppStates = ( 56 | CONNECT, 57 | WAIT_CONNECT, 58 | RUNNING, 59 | FAILING 60 | ); 61 | 62 | type 63 | // Define class for the embedded application 64 | TembeddedApp = object 65 | strict 66 | private 67 | MQTTClient: TMQTTClient; 68 | pingCounter : integer; 69 | pingTimer : integer; 70 | state : TembeddedAppStates; 71 | message : ansistring; 72 | pubTimer : integer; 73 | connectTimer : integer; 74 | public 75 | terminate: boolean; 76 | procedure run (); 77 | end; 78 | 79 | procedure TembeddedApp.run(); 80 | 81 | var 82 | msg : TMQTTMessage; 83 | ack : TMQTTMessageAck; 84 | begin 85 | writeln ('embeddedApp MQTT Client.'); 86 | state := CONNECT; 87 | 88 | message := 89 | 'All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy.' 90 | ; 91 | 92 | MQTTClient := TMQTTClient.Create(MQTT_Server, 1883); 93 | 94 | while not terminate do 95 | begin 96 | case state of 97 | CONNECT : 98 | begin 99 | // Connect to MQTT server 100 | pingCounter := 0; 101 | pingTimer := 0; 102 | pubTimer := 0; 103 | connectTimer := 0; 104 | MQTTClient.Connect; 105 | state := WAIT_CONNECT; 106 | end; 107 | WAIT_CONNECT : 108 | begin 109 | // Can only move to RUNNING state on recieving ConnAck 110 | connectTimer := connectTimer + 1; 111 | if connectTimer > 300 then 112 | begin 113 | Writeln('embeddedApp: Error: ConnAck time out.'); 114 | state := FAILING; 115 | end; 116 | end; 117 | RUNNING : 118 | begin 119 | // Publish stuff 120 | if pubTimer mod pubTimerInterval = 0 then 121 | begin 122 | if not MQTTClient.Publish(MQTT_Topic, message) then 123 | begin 124 | writeln ('embeddedApp: Error: Publish Failed.'); 125 | state := FAILING; 126 | end; 127 | end; 128 | pubTimer := pubTimer + 1; 129 | 130 | // Ping the MQTT server occasionally 131 | if (pingTimer mod 100) = 0 then 132 | begin 133 | // Time to PING ! 134 | if not MQTTClient.PingReq then 135 | begin 136 | writeln ('embeddedApp: Error: PingReq Failed.'); 137 | state := FAILING; 138 | end; 139 | pingCounter := pingCounter + 1; 140 | // Check that pings are being answered 141 | if pingCounter > 3 then 142 | begin 143 | writeln ('embeddedApp: Error: Ping timeout.'); 144 | state := FAILING; 145 | end; 146 | end; 147 | pingTimer := pingTimer + 1; 148 | end; 149 | FAILING : 150 | begin 151 | MQTTClient.ForceDisconnect; 152 | state := CONNECT; 153 | end; 154 | end; 155 | 156 | // Read incomming MQTT messages. 157 | repeat 158 | msg := MQTTClient.getMessage; 159 | if Assigned(msg) then 160 | begin 161 | writeln ('getMessage: ' + msg.topic + ' Payload: ' + msg.payload); 162 | 163 | if msg.PayLoad = 'stop' then 164 | terminate := true; 165 | 166 | // Important to free messages here. 167 | msg.free; 168 | end; 169 | until not Assigned(msg); 170 | 171 | // Read incomming MQTT message acknowledgments 172 | repeat 173 | ack := MQTTClient.getMessageAck; 174 | if Assigned(ack) then 175 | begin 176 | case ack.messageType of 177 | CONNACK : 178 | begin 179 | if ack.returnCode = 0 then 180 | begin 181 | // Make subscriptions 182 | MQTTClient.Subscribe(MQTT_Topic); 183 | // Enter the running state 184 | state := RUNNING; 185 | end 186 | else 187 | state := FAILING; 188 | end; 189 | PINGRESP : 190 | begin 191 | writeln ('PING! PONG!'); 192 | // Reset ping counter to indicate all is OK. 193 | pingCounter := 0; 194 | end; 195 | SUBACK : 196 | begin 197 | write ('SUBACK: '); 198 | write (ack.messageId); 199 | write (', '); 200 | writeln (ack.qos); 201 | end; 202 | UNSUBACK : 203 | begin 204 | write ('UNSUBACK: '); 205 | writeln (ack.messageId); 206 | end; 207 | end; 208 | end; 209 | // Important to free messages here. 210 | ack.free; 211 | until not Assigned(ack); 212 | 213 | // Main application loop must call this else we leak threads! 214 | CheckSynchronize; 215 | 216 | // Yawn. 217 | sleep(100); 218 | end; 219 | 220 | MQTTClient.ForceDisconnect; 221 | FreeAndNil(MQTTClient); 222 | end; 223 | 224 | var 225 | app : TembeddedApp; 226 | 227 | // main 228 | begin 229 | app.run; 230 | end. 231 | -------------------------------------------------------------------------------- /examples/embeddedApp/payload.txt: -------------------------------------------------------------------------------- 1 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 2 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 3 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 4 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 5 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 6 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 7 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 8 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 9 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 10 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 11 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 12 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 13 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 14 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 15 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 16 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 17 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 18 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 19 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 20 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 21 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 22 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 23 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 24 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 25 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 26 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 27 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 28 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 29 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 30 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 31 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 32 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 33 | All work and no play makes Jack a dull boy. All work and no play makes Jack a dull boy. 34 | -------------------------------------------------------------------------------- /examples/embeddedApp/pub.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | 4 | while true 5 | do 6 | mosquitto_pub -h test.mosquitto.org -t /jack/says -f payload.txt 7 | sleep 1 8 | done 9 | -------------------------------------------------------------------------------- /examples/fpcConsole/fpcConsoleMQTT.lpi: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectOptions> 4 | <Version Value="10"/> 5 | <PathDelim Value="\"/> 6 | <General> 7 | <Flags> 8 | <MainUnitHasCreateFormStatements Value="False"/> 9 | <MainUnitHasScaledStatement Value="False"/> 10 | </Flags> 11 | <SessionStorage Value="InProjectDir"/> 12 | <MainUnit Value="0"/> 13 | <Title Value="fpcConsoleMQTT"/> 14 | <UseAppBundle Value="False"/> 15 | <ResourceType Value="res"/> 16 | </General> 17 | <BuildModes Count="2"> 18 | <Item1 Name="debug_wnd_x86" Default="True"/> 19 | <Item2 Name="debug_lnx_arm"> 20 | <CompilerOptions> 21 | <Version Value="11"/> 22 | <PathDelim Value="\"/> 23 | <Target> 24 | <Filename Value="fpcConsoleMQTT"/> 25 | </Target> 26 | <SearchPaths> 27 | <IncludeFiles Value="$(ProjOutDir)"/> 28 | <OtherUnitFiles Value="..\..\TMQTTClient"/> 29 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 30 | </SearchPaths> 31 | <Parsing> 32 | <SyntaxOptions> 33 | <IncludeAssertionCode Value="True"/> 34 | </SyntaxOptions> 35 | </Parsing> 36 | <CodeGeneration> 37 | <Checks> 38 | <IOChecks Value="True"/> 39 | <RangeChecks Value="True"/> 40 | <OverflowChecks Value="True"/> 41 | </Checks> 42 | <VerifyObjMethodCallValidity Value="True"/> 43 | <TargetCPU Value="arm"/> 44 | <TargetOS Value="linux"/> 45 | </CodeGeneration> 46 | <Linking> 47 | <Debugging> 48 | <UseHeaptrc Value="True"/> 49 | <TrashVariables Value="True"/> 50 | </Debugging> 51 | </Linking> 52 | <Other> 53 | <CustomOptions Value="-dUseCThreads"/> 54 | </Other> 55 | </CompilerOptions> 56 | </Item2> 57 | </BuildModes> 58 | <PublishOptions> 59 | <Version Value="2"/> 60 | </PublishOptions> 61 | <RunParams> 62 | <local> 63 | <FormatVersion Value="1"/> 64 | </local> 65 | </RunParams> 66 | <RequiredPackages Count="1"> 67 | <Item1> 68 | <PackageName Value="laz_synapse"/> 69 | </Item1> 70 | </RequiredPackages> 71 | <Units Count="3"> 72 | <Unit0> 73 | <Filename Value="fpcConsoleMQTT.pas"/> 74 | <IsPartOfProject Value="True"/> 75 | </Unit0> 76 | <Unit1> 77 | <Filename Value="..\..\TMQTTClient\MQTT.pas"/> 78 | <IsPartOfProject Value="True"/> 79 | </Unit1> 80 | <Unit2> 81 | <Filename Value="..\..\TMQTTClient\MQTTReadThread.pas"/> 82 | <IsPartOfProject Value="True"/> 83 | </Unit2> 84 | </Units> 85 | </ProjectOptions> 86 | <CompilerOptions> 87 | <Version Value="11"/> 88 | <PathDelim Value="\"/> 89 | <Target> 90 | <Filename Value="fpcConsoleMQTT"/> 91 | </Target> 92 | <SearchPaths> 93 | <IncludeFiles Value="$(ProjOutDir)"/> 94 | <OtherUnitFiles Value="..\..\TMQTTClient"/> 95 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 96 | </SearchPaths> 97 | <Parsing> 98 | <SyntaxOptions> 99 | <IncludeAssertionCode Value="True"/> 100 | </SyntaxOptions> 101 | </Parsing> 102 | <CodeGeneration> 103 | <Checks> 104 | <IOChecks Value="True"/> 105 | <RangeChecks Value="True"/> 106 | <OverflowChecks Value="True"/> 107 | </Checks> 108 | <VerifyObjMethodCallValidity Value="True"/> 109 | </CodeGeneration> 110 | <Linking> 111 | <Debugging> 112 | <UseHeaptrc Value="True"/> 113 | <TrashVariables Value="True"/> 114 | </Debugging> 115 | </Linking> 116 | <Other> 117 | <CustomOptions Value="-dUseCThreads"/> 118 | </Other> 119 | </CompilerOptions> 120 | <Debugging> 121 | <Exceptions Count="3"> 122 | <Item1> 123 | <Name Value="EAbort"/> 124 | </Item1> 125 | <Item2> 126 | <Name Value="ECodetoolError"/> 127 | </Item2> 128 | <Item3> 129 | <Name Value="EFOpenError"/> 130 | </Item3> 131 | </Exceptions> 132 | </Debugging> 133 | </CONFIG> 134 | -------------------------------------------------------------------------------- /examples/fpcConsole/fpcConsoleMQTT.pas: -------------------------------------------------------------------------------- 1 | program fpcConsoleMQTT; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses {$IFDEF UNIX} {$IFDEF UseCThreads} 6 | cthreads, {$ENDIF} {$ENDIF} 7 | Classes, 8 | SysUtils, 9 | CustApp { you can add units after this }, 10 | //old: CRT, 11 | MQTT, 12 | syncobjs, // TCriticalSection 13 | fptimer; 14 | 15 | const 16 | MQTT_Server = 'orangepi.lan'; 17 | 18 | type 19 | { TMQTTGate } 20 | 21 | TMQTTGate = class(TCustomApplication) 22 | protected 23 | MQTTClient: TMQTTClient; 24 | 25 | SyncCode: TCriticalSection; 26 | TimerTick: TFPTimer; 27 | cnt: integer; 28 | 29 | // Unsafe events! Called from MQTT thread (TMQTTReadThread) 30 | procedure OnConnAck(Sender: TObject; ReturnCode: integer); 31 | procedure OnPingResp(Sender: TObject); 32 | procedure OnSubAck(Sender: TObject; MessageID: integer; GrantedQoS: integer); 33 | procedure OnUnSubAck(Sender: TObject); 34 | procedure OnPublish(Sender: TObject; topic, payload: ansistring; isRetain: boolean); 35 | 36 | procedure OnTimerTick(Sender: TObject); 37 | procedure DoRun; override; 38 | public 39 | procedure WriteHelp; virtual; 40 | end; 41 | 42 | {old: const 43 | { ^C } 44 | //ContrBreakSIG = ^C; // yes, its valid string! (OMG!) 45 | //ContrBreakSIG = #$03; 46 | } 47 | 48 | function NewTimer(Intr: integer; Proc: TNotifyEvent; AEnable: boolean = false): TFPTimer; 49 | begin 50 | Result := TFPTimer.Create(nil); 51 | Result.UseTimerThread:=false; 52 | Result.Interval := Intr; 53 | Result.OnTimer := Proc; 54 | Result.Enabled := AEnable; 55 | end; 56 | 57 | { TMQTTGate } 58 | 59 | procedure TMQTTGate.OnConnAck(Sender: TObject; ReturnCode: integer); 60 | begin 61 | SyncCode.Enter; 62 | writeln('ConnAck'); 63 | SyncCode.Leave; 64 | end; 65 | 66 | procedure TMQTTGate.OnPingResp(Sender: TObject); 67 | begin 68 | SyncCode.Enter; 69 | writeln('PingResp'); 70 | SyncCode.Leave; 71 | end; 72 | 73 | procedure TMQTTGate.OnSubAck(Sender: TObject; MessageID: integer; GrantedQoS: integer); 74 | begin 75 | SyncCode.Enter; 76 | writeln('SubAck'); 77 | SyncCode.Leave; 78 | end; 79 | 80 | procedure TMQTTGate.OnUnSubAck(Sender: TObject); 81 | begin 82 | SyncCode.Enter; 83 | writeln('UnSubAck'); 84 | SyncCode.Leave; 85 | end; 86 | 87 | procedure TMQTTGate.OnPublish(Sender: TObject; topic, payload: ansistring; 88 | isRetain: boolean); 89 | begin 90 | SyncCode.Enter; 91 | writeln('Publish', ' topic=', topic, ' payload=', payload); 92 | SyncCode.Leave; 93 | end; 94 | 95 | procedure TMQTTGate.OnTimerTick(Sender: TObject); 96 | begin 97 | SyncCode.Enter; 98 | cnt := cnt + 1; 99 | writeln('Tick. N='+IntToStr(cnt)); 100 | MQTTClient.PingReq; 101 | MQTTClient.Publish('test', IntToStr(cnt)); 102 | SyncCode.Leave; 103 | end; 104 | 105 | procedure TMQTTGate.DoRun; 106 | var 107 | ErrorMsg: string; 108 | begin 109 | StopOnException := True; 110 | SyncCode := TCriticalSection.Create(); 111 | 112 | // quick check parameters 113 | ErrorMsg := CheckOptions('h', 'help'); 114 | if ErrorMsg <> '' then 115 | begin 116 | ShowException(Exception.Create(ErrorMsg)); 117 | Terminate; 118 | Exit; 119 | end; 120 | 121 | // parse parameters 122 | if HasOption('h', 'help') then 123 | begin 124 | WriteHelp; 125 | Terminate; 126 | Exit; 127 | end; 128 | 129 | // begin main program 130 | MQTTClient := TMQTTClient.Create(MQTT_Server, 1883); 131 | MQTTClient.OnConnAck := @OnConnAck; 132 | MQTTClient.OnPingResp := @OnPingResp; 133 | MQTTClient.OnPublish := @OnPublish; 134 | MQTTClient.OnSubAck := @OnSubAck; 135 | MQTTClient.Connect(); 136 | 137 | //todo: wait 'OnConnAck' 138 | Sleep(1000); 139 | if not MQTTClient.isConnected then 140 | begin 141 | writeln('connect FAIL'); 142 | exit; 143 | end; 144 | 145 | // mqtt subscribe to all topics 146 | MQTTClient.Subscribe('#'); 147 | 148 | cnt := 0; 149 | TimerTick := NewTimer(5000, @OnTimerTick, true); 150 | try 151 | while (not Terminated) and (MQTTClient.isConnected) do 152 | begin 153 | // wait other thread 154 | CheckSynchronize(1000); 155 | 156 | //old: Check for ctrl-c 157 | {if KeyPressed then // <--- CRT function to test key press 158 | if ReadKey = ContrBreakSIG then // read the key pressed 159 | begin 160 | writeln('Ctrl-C pressed.'); 161 | Terminate; 162 | end;} 163 | end; 164 | 165 | MQTTClient.Unsubscribe('#'); 166 | MQTTClient.Disconnect; 167 | Sleep(100); 168 | MQTTClient.ForceDisconnect; 169 | finally 170 | FreeAndNil(TimerTick); 171 | FreeAndNil(MQTTClient); 172 | FreeAndNil(SyncCode); 173 | Sleep(2000); // wait thread dies 174 | end; 175 | // stop program loop 176 | Terminate; 177 | end; 178 | 179 | procedure TMQTTGate.WriteHelp; 180 | begin 181 | { add your help code here } 182 | writeln('Usage: ', ExeName, ' -h'); 183 | end; 184 | 185 | var 186 | Application: TMQTTGate; 187 | 188 | function MyCtrlBreakHandler(CtrlBr: boolean): boolean; 189 | begin 190 | writeln('CtrlBreak pressed. Terminating.'); 191 | Application.Terminate; 192 | Result := true; 193 | end; 194 | 195 | begin 196 | SysSetCtrlBreakHandler(@MyCtrlBreakHandler); 197 | Application := TMQTTGate.Create(nil); 198 | Application.Run; 199 | Application.Free; 200 | end. 201 | 202 | -------------------------------------------------------------------------------- /ptop.cfg: -------------------------------------------------------------------------------- 1 | end=crbefore,dindonkey,dindent,crafter,lower 2 | [end]=if,then,else,while,with,for,record,try,finally,except,class,object,private 3 | ,public,protected,published,casevar,colon,equals 4 | begin=crbefore,dindonkey,inbytab,crafter,lower 5 | [begin]=var,label,const,type 6 | if=spaft,gobsym,inbytab,lower 7 | then=lower 8 | else=crbefore,dindonkey,inbytab,lower 9 | [else]=if,then,else 10 | proc=dindonkey,spaft,lower 11 | [proc]=var,label,const,type 12 | var=blinbefore,dindonkey,spaft,inbytab,lower 13 | [var]=var,label,const,type 14 | of=crsupp,spbef,spaft,lower 15 | while=spaft,gobsym,inbytab,crafter,lower 16 | do=crsupp,spbef,lower 17 | case=spaft,gobsym,inbytab,crafter,lower 18 | with=spaft,gobsym,inbytab,crafter,lower 19 | for=spaft,gobsym,inbytab,crafter,lower 20 | repeat=inbytab,crafter,lower 21 | until=crbefore,dindonkey,dindent,spaft,gobsym,crafter,lower 22 | [until]=if,then,else,while,with,for,colon,equals 23 | func=dindonkey,spaft,lower 24 | [func]=var,label,const,type 25 | label=blinbefore,spaft,inbytab,lower 26 | const=blinbefore,dindonkey,spaft,inbytab,lower 27 | [const]=var,label,const,type 28 | type=blinbefore,dindonkey,spaft,inbytab,lower 29 | [type]=var,label,const,type 30 | record=inbyindent,crafter,lower 31 | [record]=end 32 | string= 33 | prog=blinbefore,spaft,lower 34 | asm= 35 | try=crbefore,inbytab,crafter,lower 36 | finally=crbefore,dindent,inbytab,crafter,lower 37 | [finally]=try 38 | except=crbefore,dindent,inbytab,crafter,lower 39 | [except]=try 40 | raise= 41 | class=inbyindent,lower 42 | object=inbyindent,lower 43 | constructor= 44 | destructor= 45 | inherited= 46 | property= 47 | private=crbefore,dindonkey,spaft,inbytab,lower 48 | [private]=end,private,public,protected,published 49 | public=crbefore,dindonkey,spaft,inbytab,lower 50 | [public]=end,private,public,protected,published 51 | protected=crbefore,dindonkey,spaft,inbytab,lower 52 | [protected]=end,private,public,protected,published 53 | published=crbefore,dindonkey,spaft,inbytab,lower 54 | [published]=end,private,public,protected,published 55 | initialization= 56 | finalization= 57 | inline= 58 | library=blinbefore,spaft,lower 59 | interface=blinbefore,crafter,lower 60 | implementation=blinbefore,dindonkey,crafter,lower 61 | [implementation]=end,var,label,const,type,property 62 | read= 63 | write= 64 | unit=blinbefore,spaft,lower 65 | and= 66 | arr= 67 | div= 68 | down= 69 | file= 70 | goto= 71 | in= 72 | mod= 73 | not= 74 | nil= 75 | or= 76 | set= 77 | to= 78 | virtual= 79 | uses=blinbefore,spaft,lower 80 | casevar=spaft,gobsym,inbytab,crafter,lower 81 | ofobject= 82 | becomes=spbef,spaft,gobsym,lower 83 | delphicomment=crafter 84 | dopencomment= 85 | dclosecomment= 86 | opencomment=crsupp,lower 87 | closecomment=crsupp,lower 88 | semicolon=crsupp,dindonkey,crafter,lower 89 | [semicolon]=if,then,else,while,with,for,colon,equals 90 | colon=inbytab,lower 91 | equals=spbef,spaft,inbytab,lower 92 | openparen=gobsym,lower 93 | closeparen= 94 | period=crsupp,lower 95 | endoffile= 96 | other= 97 | -------------------------------------------------------------------------------- /synapse/ssfpc.inc: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.005 | 3 | |==============================================================================| 4 | | Content: Socket Independent Platform Layer - FreePascal definition include | 5 | |==============================================================================| 6 | | Copyright (c)2006-2013, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2006-2013. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@exclude} 46 | 47 | {$IFDEF FPC} 48 | {For FreePascal 2.x.x} 49 | 50 | //{$DEFINE FORCEOLDAPI} 51 | {Note about define FORCEOLDAPI: 52 | If you activate this compiler directive, then is allways used old socket API 53 | for name resolution. If you leave this directive inactive, then the new API 54 | is used, when running system allows it. 55 | 56 | For IPv6 support you must have new API! 57 | } 58 | 59 | {$IFDEF FPC} 60 | {$MODE DELPHI} 61 | {$ENDIF} 62 | {$H+} 63 | 64 | {$ifdef FreeBSD} 65 | {$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr 66 | {$endif} 67 | {$ifdef darwin} 68 | {$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr 69 | {$endif} 70 | 71 | interface 72 | 73 | uses 74 | SyncObjs, SysUtils, Classes, 75 | synafpc, BaseUnix, Unix, termio, sockets, netdb; 76 | 77 | function InitSocketInterface(stack: string): Boolean; 78 | function DestroySocketInterface: Boolean; 79 | 80 | const 81 | DLLStackName = ''; 82 | WinsockLevel = $0202; 83 | 84 | cLocalHost = '127.0.0.1'; 85 | cAnyHost = '0.0.0.0'; 86 | c6AnyHost = '::0'; 87 | c6Localhost = '::1'; 88 | cLocalHostStr = 'localhost'; 89 | 90 | type 91 | TSocket = longint; 92 | TAddrFamily = integer; 93 | 94 | TMemory = pointer; 95 | 96 | 97 | type 98 | TFDSet = Baseunix.TFDSet; 99 | PFDSet = ^TFDSet; 100 | Ptimeval = Baseunix.ptimeval; 101 | Ttimeval = Baseunix.ttimeval; 102 | 103 | const 104 | FIONREAD = termio.FIONREAD; 105 | FIONBIO = termio.FIONBIO; 106 | FIOASYNC = termio.FIOASYNC; 107 | 108 | const 109 | IPPROTO_IP = 0; { Dummy } 110 | IPPROTO_ICMP = 1; { Internet Control Message Protocol } 111 | IPPROTO_IGMP = 2; { Internet Group Management Protocol} 112 | IPPROTO_TCP = 6; { TCP } 113 | IPPROTO_UDP = 17; { User Datagram Protocol } 114 | IPPROTO_IPV6 = 41; 115 | IPPROTO_ICMPV6 = 58; 116 | IPPROTO_RM = 113; 117 | 118 | IPPROTO_RAW = 255; 119 | IPPROTO_MAX = 256; 120 | 121 | type 122 | PInAddr = ^TInAddr; 123 | TInAddr = sockets.in_addr; 124 | 125 | PSockAddrIn = ^TSockAddrIn; 126 | TSockAddrIn = sockets.TInetSockAddr; 127 | 128 | 129 | TIP_mreq = record 130 | imr_multiaddr: TInAddr; // IP multicast address of group 131 | imr_interface: TInAddr; // local IP address of interface 132 | end; 133 | 134 | 135 | PInAddr6 = ^TInAddr6; 136 | TInAddr6 = sockets.Tin6_addr; 137 | 138 | PSockAddrIn6 = ^TSockAddrIn6; 139 | TSockAddrIn6 = sockets.TInetSockAddr6; 140 | 141 | 142 | TIPv6_mreq = record 143 | ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. 144 | ipv6mr_interface: integer; // Interface index. 145 | end; 146 | 147 | const 148 | INADDR_ANY = $00000000; 149 | INADDR_LOOPBACK = $7F000001; 150 | INADDR_BROADCAST = $FFFFFFFF; 151 | INADDR_NONE = $FFFFFFFF; 152 | ADDR_ANY = INADDR_ANY; 153 | INVALID_SOCKET = TSocket(NOT(0)); 154 | SOCKET_ERROR = -1; 155 | 156 | Const 157 | IP_TOS = sockets.IP_TOS; { int; IP type of service and precedence. } 158 | IP_TTL = sockets.IP_TTL; { int; IP time to live. } 159 | IP_HDRINCL = sockets.IP_HDRINCL; { int; Header is included with data. } 160 | IP_OPTIONS = sockets.IP_OPTIONS; { ip_opts; IP per-packet options. } 161 | // IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool } 162 | IP_RECVOPTS = sockets.IP_RECVOPTS; { bool } 163 | IP_RETOPTS = sockets.IP_RETOPTS; { bool } 164 | // IP_PKTINFO = sockets.IP_PKTINFO; { bool } 165 | // IP_PKTOPTIONS = sockets.IP_PKTOPTIONS; 166 | // IP_PMTUDISC = sockets.IP_PMTUDISC; { obsolete name? } 167 | // IP_MTU_DISCOVER = sockets.IP_MTU_DISCOVER; { int; see below } 168 | // IP_RECVERR = sockets.IP_RECVERR; { bool } 169 | // IP_RECVTTL = sockets.IP_RECVTTL; { bool } 170 | // IP_RECVTOS = sockets.IP_RECVTOS; { bool } 171 | IP_MULTICAST_IF = sockets.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f } 172 | IP_MULTICAST_TTL = sockets.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl } 173 | IP_MULTICAST_LOOP = sockets.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback } 174 | IP_ADD_MEMBERSHIP = sockets.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership } 175 | IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership } 176 | 177 | SOL_SOCKET = sockets.SOL_SOCKET; 178 | 179 | SO_DEBUG = sockets.SO_DEBUG; 180 | SO_REUSEADDR = sockets.SO_REUSEADDR; 181 | SO_TYPE = sockets.SO_TYPE; 182 | SO_ERROR = sockets.SO_ERROR; 183 | SO_DONTROUTE = sockets.SO_DONTROUTE; 184 | SO_BROADCAST = sockets.SO_BROADCAST; 185 | SO_SNDBUF = sockets.SO_SNDBUF; 186 | SO_RCVBUF = sockets.SO_RCVBUF; 187 | SO_KEEPALIVE = sockets.SO_KEEPALIVE; 188 | SO_OOBINLINE = sockets.SO_OOBINLINE; 189 | // SO_NO_CHECK = sockets.SO_NO_CHECK; 190 | // SO_PRIORITY = sockets.SO_PRIORITY; 191 | SO_LINGER = sockets.SO_LINGER; 192 | // SO_BSDCOMPAT = sockets.SO_BSDCOMPAT; 193 | // SO_REUSEPORT = sockets.SO_REUSEPORT; 194 | // SO_PASSCRED = sockets.SO_PASSCRED; 195 | // SO_PEERCRED = sockets.SO_PEERCRED; 196 | SO_RCVLOWAT = sockets.SO_RCVLOWAT; 197 | SO_SNDLOWAT = sockets.SO_SNDLOWAT; 198 | SO_RCVTIMEO = sockets.SO_RCVTIMEO; 199 | SO_SNDTIMEO = sockets.SO_SNDTIMEO; 200 | { Security levels - as per NRL IPv6 - don't actually do anything } 201 | // SO_SECURITY_AUTHENTICATION = sockets.SO_SECURITY_AUTHENTICATION; 202 | // SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT; 203 | // SO_SECURITY_ENCRYPTION_NETWORK = sockets.SO_SECURITY_ENCRYPTION_NETWORK; 204 | // SO_BINDTODEVICE = sockets.SO_BINDTODEVICE; 205 | { Socket filtering } 206 | // SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER; 207 | // SO_DETACH_FILTER = sockets.SO_DETACH_FILTER; 208 | 209 | {$IFDEF DARWIN} 210 | SO_NOSIGPIPE = $1022; 211 | {$ENDIF} 212 | 213 | SOMAXCONN = 1024; 214 | 215 | IPV6_UNICAST_HOPS = sockets.IPV6_UNICAST_HOPS; 216 | IPV6_MULTICAST_IF = sockets.IPV6_MULTICAST_IF; 217 | IPV6_MULTICAST_HOPS = sockets.IPV6_MULTICAST_HOPS; 218 | IPV6_MULTICAST_LOOP = sockets.IPV6_MULTICAST_LOOP; 219 | IPV6_JOIN_GROUP = sockets.IPV6_JOIN_GROUP; 220 | IPV6_LEAVE_GROUP = sockets.IPV6_LEAVE_GROUP; 221 | 222 | const 223 | SOCK_STREAM = 1; { stream socket } 224 | SOCK_DGRAM = 2; { datagram socket } 225 | SOCK_RAW = 3; { raw-protocol interface } 226 | SOCK_RDM = 4; { reliably-delivered message } 227 | SOCK_SEQPACKET = 5; { sequenced packet stream } 228 | 229 | { TCP options. } 230 | TCP_NODELAY = $0001; 231 | 232 | { Address families. } 233 | 234 | AF_UNSPEC = 0; { unspecified } 235 | AF_INET = 2; { internetwork: UDP, TCP, etc. } 236 | AF_INET6 = 10; { Internetwork Version 6 } 237 | AF_MAX = 24; 238 | 239 | { Protocol families, same as address families for now. } 240 | PF_UNSPEC = AF_UNSPEC; 241 | PF_INET = AF_INET; 242 | PF_INET6 = AF_INET6; 243 | PF_MAX = AF_MAX; 244 | 245 | type 246 | { Structure used for manipulating linger option. } 247 | PLinger = ^TLinger; 248 | TLinger = packed record 249 | l_onoff: integer; 250 | l_linger: integer; 251 | end; 252 | 253 | const 254 | 255 | MSG_OOB = sockets.MSG_OOB; // Process out-of-band data. 256 | MSG_PEEK = sockets.MSG_PEEK; // Peek at incoming messages. 257 | {$ifdef DARWIN} 258 | MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE. 259 | // Works under MAC OS X, but is undocumented, 260 | // So FPC doesn't include it 261 | {$else} 262 | MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE. 263 | {$endif} 264 | 265 | const 266 | WSAEINTR = ESysEINTR; 267 | WSAEBADF = ESysEBADF; 268 | WSAEACCES = ESysEACCES; 269 | WSAEFAULT = ESysEFAULT; 270 | WSAEINVAL = ESysEINVAL; 271 | WSAEMFILE = ESysEMFILE; 272 | WSAEWOULDBLOCK = ESysEWOULDBLOCK; 273 | WSAEINPROGRESS = ESysEINPROGRESS; 274 | WSAEALREADY = ESysEALREADY; 275 | WSAENOTSOCK = ESysENOTSOCK; 276 | WSAEDESTADDRREQ = ESysEDESTADDRREQ; 277 | WSAEMSGSIZE = ESysEMSGSIZE; 278 | WSAEPROTOTYPE = ESysEPROTOTYPE; 279 | WSAENOPROTOOPT = ESysENOPROTOOPT; 280 | WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT; 281 | WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT; 282 | WSAEOPNOTSUPP = ESysEOPNOTSUPP; 283 | WSAEPFNOSUPPORT = ESysEPFNOSUPPORT; 284 | WSAEAFNOSUPPORT = ESysEAFNOSUPPORT; 285 | WSAEADDRINUSE = ESysEADDRINUSE; 286 | WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL; 287 | WSAENETDOWN = ESysENETDOWN; 288 | WSAENETUNREACH = ESysENETUNREACH; 289 | WSAENETRESET = ESysENETRESET; 290 | WSAECONNABORTED = ESysECONNABORTED; 291 | WSAECONNRESET = ESysECONNRESET; 292 | WSAENOBUFS = ESysENOBUFS; 293 | WSAEISCONN = ESysEISCONN; 294 | WSAENOTCONN = ESysENOTCONN; 295 | WSAESHUTDOWN = ESysESHUTDOWN; 296 | WSAETOOMANYREFS = ESysETOOMANYREFS; 297 | WSAETIMEDOUT = ESysETIMEDOUT; 298 | WSAECONNREFUSED = ESysECONNREFUSED; 299 | WSAELOOP = ESysELOOP; 300 | WSAENAMETOOLONG = ESysENAMETOOLONG; 301 | WSAEHOSTDOWN = ESysEHOSTDOWN; 302 | WSAEHOSTUNREACH = ESysEHOSTUNREACH; 303 | WSAENOTEMPTY = ESysENOTEMPTY; 304 | WSAEPROCLIM = -1; 305 | WSAEUSERS = ESysEUSERS; 306 | WSAEDQUOT = ESysEDQUOT; 307 | WSAESTALE = ESysESTALE; 308 | WSAEREMOTE = ESysEREMOTE; 309 | WSASYSNOTREADY = -2; 310 | WSAVERNOTSUPPORTED = -3; 311 | WSANOTINITIALISED = -4; 312 | WSAEDISCON = -5; 313 | WSAHOST_NOT_FOUND = 1; 314 | WSATRY_AGAIN = 2; 315 | WSANO_RECOVERY = 3; 316 | WSANO_DATA = -6; 317 | 318 | const 319 | WSADESCRIPTION_LEN = 256; 320 | WSASYS_STATUS_LEN = 128; 321 | type 322 | PWSAData = ^TWSAData; 323 | TWSAData = packed record 324 | wVersion: Word; 325 | wHighVersion: Word; 326 | szDescription: array[0..WSADESCRIPTION_LEN] of Char; 327 | szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; 328 | iMaxSockets: Word; 329 | iMaxUdpDg: Word; 330 | lpVendorInfo: PChar; 331 | end; 332 | 333 | function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; 334 | function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; 335 | function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; 336 | function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; 337 | function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; 338 | function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; 339 | procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); 340 | procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); 341 | 342 | var 343 | in6addr_any, in6addr_loopback : TInAddr6; 344 | 345 | procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); 346 | function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; 347 | procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); 348 | procedure FD_ZERO(var FDSet: TFDSet); 349 | 350 | {=============================================================================} 351 | 352 | var 353 | SynSockCS: SyncObjs.TCriticalSection; 354 | SockEnhancedApi: Boolean; 355 | SockWship6Api: Boolean; 356 | 357 | type 358 | TVarSin = packed record 359 | {$ifdef SOCK_HAS_SINLEN} 360 | sin_len : cuchar; 361 | {$endif} 362 | case integer of 363 | 0: (AddressFamily: sa_family_t); 364 | 1: ( 365 | case sin_family: sa_family_t of 366 | AF_INET: (sin_port: word; 367 | sin_addr: TInAddr; 368 | sin_zero: array[0..7] of Char); 369 | AF_INET6: (sin6_port: word; 370 | sin6_flowinfo: longword; 371 | sin6_addr: TInAddr6; 372 | sin6_scope_id: longword); 373 | ); 374 | end; 375 | 376 | function SizeOfVarSin(sin: TVarSin): integer; 377 | 378 | function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; 379 | function WSACleanup: Integer; 380 | function WSAGetLastError: Integer; 381 | function GetHostName: string; 382 | function Shutdown(s: TSocket; how: Integer): Integer; 383 | function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; 384 | optlen: Integer): Integer; 385 | function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; 386 | var optlen: Integer): Integer; 387 | function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; 388 | function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; 389 | function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; 390 | function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; 391 | function ntohs(netshort: word): word; 392 | function ntohl(netlong: longword): longword; 393 | function Listen(s: TSocket; backlog: Integer): Integer; 394 | function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; 395 | function htons(hostshort: word): word; 396 | function htonl(hostlong: longword): longword; 397 | function GetSockName(s: TSocket; var name: TVarSin): Integer; 398 | function GetPeerName(s: TSocket; var name: TVarSin): Integer; 399 | function Connect(s: TSocket; const name: TVarSin): Integer; 400 | function CloseSocket(s: TSocket): Integer; 401 | function Bind(s: TSocket; const addr: TVarSin): Integer; 402 | function Accept(s: TSocket; var addr: TVarSin): TSocket; 403 | function Socket(af, Struc, Protocol: Integer): TSocket; 404 | function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; 405 | timeout: PTimeVal): Longint; 406 | 407 | function IsNewApi(Family: integer): Boolean; 408 | function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; 409 | function GetSinIP(Sin: TVarSin): string; 410 | function GetSinPort(Sin: TVarSin): Integer; 411 | procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); 412 | function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; 413 | function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; 414 | 415 | 416 | {==============================================================================} 417 | implementation 418 | 419 | 420 | function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; 421 | begin 422 | Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and 423 | (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); 424 | end; 425 | 426 | function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; 427 | begin 428 | Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and 429 | (a^.u6_addr32[2] = 0) and 430 | (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and 431 | (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); 432 | end; 433 | 434 | function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; 435 | begin 436 | Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); 437 | end; 438 | 439 | function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; 440 | begin 441 | Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); 442 | end; 443 | 444 | function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; 445 | begin 446 | Result := (a^.u6_addr8[0] = $FF); 447 | end; 448 | 449 | function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; 450 | begin 451 | Result := (CompareMem( a, b, sizeof(TInAddr6))); 452 | end; 453 | 454 | procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); 455 | begin 456 | FillChar(a^, sizeof(TInAddr6), 0); 457 | end; 458 | 459 | procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); 460 | begin 461 | FillChar(a^, sizeof(TInAddr6), 0); 462 | a^.u6_addr8[15] := 1; 463 | end; 464 | 465 | {=============================================================================} 466 | 467 | function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; 468 | begin 469 | with WSData do 470 | begin 471 | wVersion := wVersionRequired; 472 | wHighVersion := $202; 473 | szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; 474 | szSystemStatus := 'Running on Unix/Linux by FreePascal'; 475 | iMaxSockets := 32768; 476 | iMaxUdpDg := 8192; 477 | end; 478 | Result := 0; 479 | end; 480 | 481 | function WSACleanup: Integer; 482 | begin 483 | Result := 0; 484 | end; 485 | 486 | function WSAGetLastError: Integer; 487 | begin 488 | Result := fpGetErrno; 489 | end; 490 | 491 | function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; 492 | begin 493 | Result := fpFD_ISSET(socket, fdset) <> 0; 494 | end; 495 | 496 | procedure FD_SET(Socket: TSocket; var fdset: TFDSet); 497 | begin 498 | fpFD_SET(Socket, fdset); 499 | end; 500 | 501 | procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); 502 | begin 503 | fpFD_CLR(Socket, fdset); 504 | end; 505 | 506 | procedure FD_ZERO(var fdset: TFDSet); 507 | begin 508 | fpFD_ZERO(fdset); 509 | end; 510 | 511 | {=============================================================================} 512 | 513 | function SizeOfVarSin(sin: TVarSin): integer; 514 | begin 515 | case sin.sin_family of 516 | AF_INET: 517 | Result := SizeOf(TSockAddrIn); 518 | AF_INET6: 519 | Result := SizeOf(TSockAddrIn6); 520 | else 521 | Result := 0; 522 | end; 523 | end; 524 | 525 | {=============================================================================} 526 | 527 | function Bind(s: TSocket; const addr: TVarSin): Integer; 528 | begin 529 | if fpBind(s, @addr, SizeOfVarSin(addr)) = 0 then 530 | Result := 0 531 | else 532 | Result := SOCKET_ERROR; 533 | end; 534 | 535 | function Connect(s: TSocket; const name: TVarSin): Integer; 536 | begin 537 | if fpConnect(s, @name, SizeOfVarSin(name)) = 0 then 538 | Result := 0 539 | else 540 | Result := SOCKET_ERROR; 541 | end; 542 | 543 | function GetSockName(s: TSocket; var name: TVarSin): Integer; 544 | var 545 | len: integer; 546 | begin 547 | len := SizeOf(name); 548 | FillChar(name, len, 0); 549 | Result := fpGetSockName(s, @name, @Len); 550 | end; 551 | 552 | function GetPeerName(s: TSocket; var name: TVarSin): Integer; 553 | var 554 | len: integer; 555 | begin 556 | len := SizeOf(name); 557 | FillChar(name, len, 0); 558 | Result := fpGetPeerName(s, @name, @Len); 559 | end; 560 | 561 | function GetHostName: string; 562 | begin 563 | Result := unix.GetHostName; 564 | end; 565 | 566 | function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; 567 | begin 568 | Result := fpSend(s, pointer(Buf), len, flags); 569 | end; 570 | 571 | function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; 572 | begin 573 | Result := fpRecv(s, pointer(Buf), len, flags); 574 | end; 575 | 576 | function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; 577 | begin 578 | Result := fpSendTo(s, pointer(Buf), len, flags, @addrto, SizeOfVarSin(addrto)); 579 | end; 580 | 581 | function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; 582 | var 583 | x: integer; 584 | begin 585 | x := SizeOf(from); 586 | Result := fpRecvFrom(s, pointer(Buf), len, flags, @from, @x); 587 | end; 588 | 589 | function Accept(s: TSocket; var addr: TVarSin): TSocket; 590 | var 591 | x: integer; 592 | begin 593 | x := SizeOf(addr); 594 | Result := fpAccept(s, @addr, @x); 595 | end; 596 | 597 | function Shutdown(s: TSocket; how: Integer): Integer; 598 | begin 599 | Result := fpShutdown(s, how); 600 | end; 601 | 602 | function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; 603 | optlen: Integer): Integer; 604 | begin 605 | Result := fpsetsockopt(s, level, optname, pointer(optval), optlen); 606 | end; 607 | 608 | function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; 609 | var optlen: Integer): Integer; 610 | begin 611 | Result := fpgetsockopt(s, level, optname, pointer(optval), @optlen); 612 | end; 613 | 614 | function ntohs(netshort: word): word; 615 | begin 616 | Result := sockets.ntohs(NetShort); 617 | end; 618 | 619 | function ntohl(netlong: longword): longword; 620 | begin 621 | Result := sockets.ntohl(NetLong); 622 | end; 623 | 624 | function Listen(s: TSocket; backlog: Integer): Integer; 625 | begin 626 | if fpListen(s, backlog) = 0 then 627 | Result := 0 628 | else 629 | Result := SOCKET_ERROR; 630 | end; 631 | 632 | function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; 633 | begin 634 | Result := fpIoctl(s, cmd, @arg); 635 | end; 636 | 637 | function htons(hostshort: word): word; 638 | begin 639 | Result := sockets.htons(Hostshort); 640 | end; 641 | 642 | function htonl(hostlong: longword): longword; 643 | begin 644 | Result := sockets.htonl(HostLong); 645 | end; 646 | 647 | function CloseSocket(s: TSocket): Integer; 648 | begin 649 | Result := sockets.CloseSocket(s); 650 | end; 651 | 652 | function Socket(af, Struc, Protocol: Integer): TSocket; 653 | {$IFDEF DARWIN} 654 | var 655 | on_off: integer; 656 | {$ENDIF} 657 | begin 658 | Result := fpSocket(af, struc, protocol); 659 | // ##### Patch for Mac OS to avoid "Project XXX raised exception class 'External: SIGPIPE'" error. 660 | {$IFDEF DARWIN} 661 | if Result <> INVALID_SOCKET then 662 | begin 663 | on_off := 1; 664 | synsock.SetSockOpt(Result, integer(SOL_SOCKET), integer(SO_NOSIGPIPE), @on_off, SizeOf(integer)); 665 | end; 666 | {$ENDIF} 667 | end; 668 | 669 | function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; 670 | timeout: PTimeVal): Longint; 671 | begin 672 | Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout); 673 | end; 674 | 675 | {=============================================================================} 676 | function IsNewApi(Family: integer): Boolean; 677 | begin 678 | Result := SockEnhancedApi; 679 | if not Result then 680 | Result := (Family = AF_INET6) and SockWship6Api; 681 | end; 682 | 683 | function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; 684 | var 685 | TwoPass: boolean; 686 | f1, f2: integer; 687 | 688 | function GetAddr(f:integer): integer; 689 | var 690 | a4: array [1..1] of in_addr; 691 | a6: array [1..1] of Tin6_addr; 692 | he: THostEntry; 693 | begin 694 | Result := WSAEPROTONOSUPPORT; 695 | case f of 696 | AF_INET: 697 | begin 698 | if IP = cAnyHost then 699 | begin 700 | Sin.sin_family := AF_INET; 701 | Result := 0; 702 | end 703 | else 704 | begin 705 | if lowercase(IP) = cLocalHostStr then 706 | a4[1].s_addr := htonl(INADDR_LOOPBACK) 707 | else 708 | begin 709 | a4[1].s_addr := 0; 710 | Result := WSAHOST_NOT_FOUND; 711 | a4[1] := StrTonetAddr(IP); 712 | if a4[1].s_addr = INADDR_ANY then 713 | if GetHostByName(ip, he) then 714 | a4[1]:=HostToNet(he.Addr) 715 | else 716 | Resolvename(ip, a4); 717 | end; 718 | if a4[1].s_addr <> INADDR_ANY then 719 | begin 720 | Sin.sin_family := AF_INET; 721 | sin.sin_addr := a4[1]; 722 | Result := 0; 723 | end; 724 | end; 725 | end; 726 | AF_INET6: 727 | begin 728 | if IP = c6AnyHost then 729 | begin 730 | Sin.sin_family := AF_INET6; 731 | Result := 0; 732 | end 733 | else 734 | begin 735 | if lowercase(IP) = cLocalHostStr then 736 | SET_LOOPBACK_ADDR6(@a6[1]) 737 | else 738 | begin 739 | Result := WSAHOST_NOT_FOUND; 740 | SET_IN6_IF_ADDR_ANY(@a6[1]); 741 | a6[1] := StrTonetAddr6(IP); 742 | if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then 743 | Resolvename6(ip, a6); 744 | end; 745 | if not IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then 746 | begin 747 | Sin.sin_family := AF_INET6; 748 | sin.sin6_addr := a6[1]; 749 | Result := 0; 750 | end; 751 | end; 752 | end; 753 | end; 754 | end; 755 | begin 756 | Result := 0; 757 | FillChar(Sin, Sizeof(Sin), 0); 758 | Sin.sin_port := Resolveport(port, family, SockProtocol, SockType); 759 | TwoPass := False; 760 | if Family = AF_UNSPEC then 761 | begin 762 | if PreferIP4 then 763 | begin 764 | f1 := AF_INET; 765 | f2 := AF_INET6; 766 | TwoPass := True; 767 | end 768 | else 769 | begin 770 | f2 := AF_INET; 771 | f1 := AF_INET6; 772 | TwoPass := True; 773 | end; 774 | end 775 | else 776 | f1 := Family; 777 | Result := GetAddr(f1); 778 | if Result <> 0 then 779 | if TwoPass then 780 | Result := GetAddr(f2); 781 | end; 782 | 783 | function GetSinIP(Sin: TVarSin): string; 784 | begin 785 | Result := ''; 786 | case sin.AddressFamily of 787 | AF_INET: 788 | begin 789 | result := NetAddrToStr(sin.sin_addr); 790 | end; 791 | AF_INET6: 792 | begin 793 | result := NetAddrToStr6(sin.sin6_addr); 794 | end; 795 | end; 796 | end; 797 | 798 | function GetSinPort(Sin: TVarSin): Integer; 799 | begin 800 | if (Sin.sin_family = AF_INET6) then 801 | Result := synsock.ntohs(Sin.sin6_port) 802 | else 803 | Result := synsock.ntohs(Sin.sin_port); 804 | end; 805 | 806 | procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); 807 | var 808 | x, n: integer; 809 | a4: array [1..255] of in_addr; 810 | a6: array [1..255] of Tin6_addr; 811 | he: THostEntry; 812 | begin 813 | IPList.Clear; 814 | if (family = AF_INET) or (family = AF_UNSPEC) then 815 | begin 816 | if lowercase(name) = cLocalHostStr then 817 | IpList.Add(cLocalHost) 818 | else 819 | begin 820 | a4[1] := StrTonetAddr(name); 821 | if a4[1].s_addr = INADDR_ANY then 822 | if GetHostByName(name, he) then 823 | begin 824 | a4[1]:=HostToNet(he.Addr); 825 | x := 1; 826 | end 827 | else 828 | x := Resolvename(name, a4) 829 | else 830 | x := 1; 831 | for n := 1 to x do 832 | IpList.Add(netaddrToStr(a4[n])); 833 | end; 834 | end; 835 | 836 | if (family = AF_INET6) or (family = AF_UNSPEC) then 837 | begin 838 | if lowercase(name) = cLocalHostStr then 839 | IpList.Add(c6LocalHost) 840 | else 841 | begin 842 | a6[1] := StrTonetAddr6(name); 843 | if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then 844 | x := Resolvename6(name, a6) 845 | else 846 | x := 1; 847 | for n := 1 to x do 848 | IpList.Add(netaddrToStr6(a6[n])); 849 | end; 850 | end; 851 | 852 | if IPList.Count = 0 then 853 | IPList.Add(cLocalHost); 854 | end; 855 | 856 | function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; 857 | var 858 | ProtoEnt: TProtocolEntry; 859 | ServEnt: TServiceEntry; 860 | begin 861 | Result := synsock.htons(StrToIntDef(Port, 0)); 862 | if Result = 0 then 863 | begin 864 | ProtoEnt.Name := ''; 865 | GetProtocolByNumber(SockProtocol, ProtoEnt); 866 | ServEnt.port := 0; 867 | GetServiceByName(Port, ProtoEnt.Name, ServEnt); 868 | Result := ServEnt.port; 869 | end; 870 | end; 871 | 872 | function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; 873 | var 874 | n: integer; 875 | a4: array [1..1] of in_addr; 876 | a6: array [1..1] of Tin6_addr; 877 | a: array [1..1] of string; 878 | begin 879 | Result := IP; 880 | a4[1] := StrToNetAddr(IP); 881 | if a4[1].s_addr <> INADDR_ANY then 882 | begin 883 | //why ResolveAddress need address in HOST order? :-O 884 | n := ResolveAddress(nettohost(a4[1]), a); 885 | if n > 0 then 886 | Result := a[1]; 887 | end 888 | else 889 | begin 890 | a6[1] := StrToNetAddr6(IP); 891 | n := ResolveAddress6(a6[1], a); 892 | if n > 0 then 893 | Result := a[1]; 894 | end; 895 | end; 896 | 897 | {=============================================================================} 898 | 899 | function InitSocketInterface(stack: string): Boolean; 900 | begin 901 | SockEnhancedApi := False; 902 | SockWship6Api := False; 903 | // Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); 904 | Result := True; 905 | end; 906 | 907 | function DestroySocketInterface: Boolean; 908 | begin 909 | Result := True; 910 | end; 911 | 912 | initialization 913 | begin 914 | SynSockCS := SyncObjs.TCriticalSection.Create; 915 | SET_IN6_IF_ADDR_ANY (@in6addr_any); 916 | SET_LOOPBACK_ADDR6 (@in6addr_loopback); 917 | end; 918 | 919 | finalization 920 | begin 921 | SynSockCS.Free; 922 | end; 923 | 924 | {$ENDIF} 925 | 926 | -------------------------------------------------------------------------------- /synapse/synacode.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 002.002.003 | 3 | |==============================================================================| 4 | | Content: Coding and decoding support | 5 | |==============================================================================| 6 | | Copyright (c)1999-2013, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2000-2013. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(Various encoding and decoding support)} 46 | {$IFDEF FPC} 47 | {$MODE DELPHI} 48 | {$ENDIF} 49 | {$Q-} 50 | {$R-} 51 | {$H+} 52 | {$TYPEDADDRESS OFF} 53 | 54 | {$IFDEF CIL} 55 | {$DEFINE SYNACODE_NATIVE} 56 | {$ENDIF} 57 | {$IFDEF FPC_BIG_ENDIAN} 58 | {$DEFINE SYNACODE_NATIVE} 59 | {$ENDIF} 60 | 61 | {$IFDEF UNICODE} 62 | {$WARN IMPLICIT_STRING_CAST OFF} 63 | {$WARN IMPLICIT_STRING_CAST_LOSS OFF} 64 | {$WARN SUSPICIOUS_TYPECAST OFF} 65 | {$ENDIF} 66 | 67 | unit synacode; 68 | 69 | interface 70 | 71 | uses 72 | SysUtils; 73 | 74 | type 75 | TSpecials = set of AnsiChar; 76 | 77 | const 78 | 79 | SpecialChar: TSpecials = 80 | ['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\', 81 | '"', '_']; 82 | NonAsciiChar: TSpecials = 83 | [#0..#31, #127..#255]; 84 | URLFullSpecialChar: TSpecials = 85 | [';', '/', '?', ':', '@', '=', '&', '#', '+']; 86 | URLSpecialChar: TSpecials = 87 | [#$00..#$20, '<', '>', '"', '%', '{', '}', '|', '\', '^', '[', ']', '`', #$7F..#$FF]; 88 | TableBase64 = 89 | 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; 90 | TableBase64mod = 91 | 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,='; 92 | TableUU = 93 | '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'; 94 | TableXX = 95 | '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; 96 | ReTablebase64 = 97 | #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40 98 | +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C 99 | +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03 100 | +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F 101 | +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40 102 | +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 103 | +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D 104 | +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; 105 | ReTableUU = 106 | #$01 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C 107 | +#$0D +#$0E +#$0F +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 108 | +#$19 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 109 | +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D +#$2E +#$2F +#$30 110 | +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C 111 | +#$3D +#$3E +#$3F +#$00 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 112 | +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 113 | +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; 114 | ReTableXX = 115 | #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$40 116 | +#$01 +#$40 +#$40 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A 117 | +#$0B +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$0C +#$0D +#$0E +#$0F 118 | +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$1A +#$1B 119 | +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 +#$25 +#$40 +#$40 120 | +#$40 +#$40 +#$40 +#$40 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D 121 | +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 122 | +#$3A +#$3B +#$3C +#$3D +#$3E +#$3F +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; 123 | 124 | {:Decodes triplet encoding with a given character delimiter. It is used for 125 | decoding quoted-printable or URL encoding.} 126 | function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; 127 | 128 | {:Decodes a string from quoted printable form. (also decodes triplet sequences 129 | like '=7F')} 130 | function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; 131 | 132 | {:Decodes a string of URL encoding. (also decodes triplet sequences like '%7F')} 133 | function DecodeURL(const Value: AnsiString): AnsiString; 134 | 135 | {:Performs triplet encoding with a given character delimiter. Used for encoding 136 | quoted-printable or URL encoding.} 137 | function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; 138 | Specials: TSpecials): AnsiString; 139 | 140 | {:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) 141 | are encoded.} 142 | function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; 143 | 144 | {:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) and 145 | @link(SpecialChar) are encoded.} 146 | function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; 147 | 148 | {:Encodes a string to URL format. Used for encoding data from a form field in 149 | HTTP, etc. (Encodes all critical characters including characters used as URL 150 | delimiters ('/',':', etc.)} 151 | function EncodeURLElement(const Value: AnsiString): AnsiString; 152 | 153 | {:Encodes a string to URL format. Used to encode critical characters in all 154 | URLs.} 155 | function EncodeURL(const Value: AnsiString): AnsiString; 156 | 157 | {:Decode 4to3 encoding with given table. If some element is not found in table, 158 | first item from table is used. This is good for buggy coded items by Microsoft 159 | Outlook. This software sometimes using wrong table for UUcode, where is used 160 | ' ' instead '`'.} 161 | function Decode4to3(const Value, Table: AnsiString): AnsiString; 162 | 163 | {:Decode 4to3 encoding with given REVERSE table. Using this function with 164 | reverse table is much faster then @link(Decode4to3). This function is used 165 | internally for Base64, UU or XX decoding.} 166 | function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; 167 | 168 | {:Encode by system 3to4 (used by Base64, UU coding, etc) by given table.} 169 | function Encode3to4(const Value, Table: AnsiString): AnsiString; 170 | 171 | {:Decode string from base64 format.} 172 | function DecodeBase64(const Value: AnsiString): AnsiString; 173 | 174 | {:Encodes a string to base64 format.} 175 | function EncodeBase64(const Value: AnsiString): AnsiString; 176 | 177 | {:Decode string from modified base64 format. (used in IMAP, for example.)} 178 | function DecodeBase64mod(const Value: AnsiString): AnsiString; 179 | 180 | {:Encodes a string to modified base64 format. (used in IMAP, for example.)} 181 | function EncodeBase64mod(const Value: AnsiString): AnsiString; 182 | 183 | {:Decodes a string from UUcode format.} 184 | function DecodeUU(const Value: AnsiString): AnsiString; 185 | 186 | {:encode UUcode. it encode only datas, you must also add header and footer for 187 | proper encode.} 188 | function EncodeUU(const Value: AnsiString): AnsiString; 189 | 190 | {:Decodes a string from XXcode format.} 191 | function DecodeXX(const Value: AnsiString): AnsiString; 192 | 193 | {:decode line with Yenc code. This code is sometimes used in newsgroups.} 194 | function DecodeYEnc(const Value: AnsiString): AnsiString; 195 | 196 | {:Returns a new CRC32 value after adding a new byte of data.} 197 | function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; 198 | 199 | {:return CRC32 from a value string.} 200 | function Crc32(const Value: AnsiString): Integer; 201 | 202 | {:Returns a new CRC16 value after adding a new byte of data.} 203 | function UpdateCrc16(Value: Byte; Crc16: Word): Word; 204 | 205 | {:return CRC16 from a value string.} 206 | function Crc16(const Value: AnsiString): Word; 207 | 208 | {:Returns a binary string with a RSA-MD5 hashing of "Value" string.} 209 | function MD5(const Value: AnsiString): AnsiString; 210 | 211 | {:Returns a binary string with HMAC-MD5 hash.} 212 | function HMAC_MD5(Text, Key: AnsiString): AnsiString; 213 | 214 | {:Returns a binary string with a RSA-MD5 hashing of string what is constructed 215 | by repeating "value" until length is "Len".} 216 | function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; 217 | 218 | {:Returns a binary string with a SHA-1 hashing of "Value" string.} 219 | function SHA1(const Value: AnsiString): AnsiString; 220 | 221 | {:Returns a binary string with HMAC-SHA1 hash.} 222 | function HMAC_SHA1(Text, Key: AnsiString): AnsiString; 223 | 224 | {:Returns a binary string with a SHA-1 hashing of string what is constructed 225 | by repeating "value" until length is "Len".} 226 | function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; 227 | 228 | {:Returns a binary string with a RSA-MD4 hashing of "Value" string.} 229 | function MD4(const Value: AnsiString): AnsiString; 230 | 231 | implementation 232 | 233 | const 234 | 235 | Crc32Tab: array[0..255] of Integer = ( 236 | Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA), 237 | Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3), 238 | Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988), 239 | Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91), 240 | Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE), 241 | Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7), 242 | Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC), 243 | Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5), 244 | Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172), 245 | Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B), 246 | Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940), 247 | Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59), 248 | Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116), 249 | Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F), 250 | Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924), 251 | Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D), 252 | Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A), 253 | Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433), 254 | Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818), 255 | Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01), 256 | Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E), 257 | Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457), 258 | Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C), 259 | Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65), 260 | Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2), 261 | Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB), 262 | Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0), 263 | Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9), 264 | Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086), 265 | Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F), 266 | Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4), 267 | Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD), 268 | Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A), 269 | Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683), 270 | Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8), 271 | Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1), 272 | Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE), 273 | Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7), 274 | Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC), 275 | Integer($F9B9DF6F), Integer($8EBEEFF9), Integer($17B7BE43), Integer($60B08ED5), 276 | Integer($D6D6A3E8), Integer($A1D1937E), Integer($38D8C2C4), Integer($4FDFF252), 277 | Integer($D1BB67F1), Integer($A6BC5767), Integer($3FB506DD), Integer($48B2364B), 278 | Integer($D80D2BDA), Integer($AF0A1B4C), Integer($36034AF6), Integer($41047A60), 279 | Integer($DF60EFC3), Integer($A867DF55), Integer($316E8EEF), Integer($4669BE79), 280 | Integer($CB61B38C), Integer($BC66831A), Integer($256FD2A0), Integer($5268E236), 281 | Integer($CC0C7795), Integer($BB0B4703), Integer($220216B9), Integer($5505262F), 282 | Integer($C5BA3BBE), Integer($B2BD0B28), Integer($2BB45A92), Integer($5CB36A04), 283 | Integer($C2D7FFA7), Integer($B5D0CF31), Integer($2CD99E8B), Integer($5BDEAE1D), 284 | Integer($9B64C2B0), Integer($EC63F226), Integer($756AA39C), Integer($026D930A), 285 | Integer($9C0906A9), Integer($EB0E363F), Integer($72076785), Integer($05005713), 286 | Integer($95BF4A82), Integer($E2B87A14), Integer($7BB12BAE), Integer($0CB61B38), 287 | Integer($92D28E9B), Integer($E5D5BE0D), Integer($7CDCEFB7), Integer($0BDBDF21), 288 | Integer($86D3D2D4), Integer($F1D4E242), Integer($68DDB3F8), Integer($1FDA836E), 289 | Integer($81BE16CD), Integer($F6B9265B), Integer($6FB077E1), Integer($18B74777), 290 | Integer($88085AE6), Integer($FF0F6A70), Integer($66063BCA), Integer($11010B5C), 291 | Integer($8F659EFF), Integer($F862AE69), Integer($616BFFD3), Integer($166CCF45), 292 | Integer($A00AE278), Integer($D70DD2EE), Integer($4E048354), Integer($3903B3C2), 293 | Integer($A7672661), Integer($D06016F7), Integer($4969474D), Integer($3E6E77DB), 294 | Integer($AED16A4A), Integer($D9D65ADC), Integer($40DF0B66), Integer($37D83BF0), 295 | Integer($A9BCAE53), Integer($DEBB9EC5), Integer($47B2CF7F), Integer($30B5FFE9), 296 | Integer($BDBDF21C), Integer($CABAC28A), Integer($53B39330), Integer($24B4A3A6), 297 | Integer($BAD03605), Integer($CDD70693), Integer($54DE5729), Integer($23D967BF), 298 | Integer($B3667A2E), Integer($C4614AB8), Integer($5D681B02), Integer($2A6F2B94), 299 | Integer($B40BBE37), Integer($C30C8EA1), Integer($5A05DF1B), Integer($2D02EF8D) 300 | ); 301 | 302 | Crc16Tab: array[0..255] of Word = ( 303 | $0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF, 304 | $8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7, 305 | $1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E, 306 | $9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876, 307 | $2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD, 308 | $AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5, 309 | $3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C, 310 | $BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974, 311 | $4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB, 312 | $CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3, 313 | $5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A, 314 | $DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72, 315 | $6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9, 316 | $EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1, 317 | $7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738, 318 | $FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70, 319 | $8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7, 320 | $0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF, 321 | $9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036, 322 | $18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E, 323 | $A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5, 324 | $2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD, 325 | $B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134, 326 | $39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C, 327 | $C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3, 328 | $4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB, 329 | $D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232, 330 | $5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A, 331 | $E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1, 332 | $6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9, 333 | $F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330, 334 | $7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78 335 | ); 336 | 337 | procedure ArrByteToLong(var ArByte: Array of byte; var ArLong: Array of Integer); 338 | {$IFDEF SYNACODE_NATIVE} 339 | var 340 | n: integer; 341 | {$ENDIF} 342 | begin 343 | if (High(ArByte) + 1) > ((High(ArLong) + 1) * 4) then 344 | Exit; 345 | {$IFDEF SYNACODE_NATIVE} 346 | for n := 0 to ((high(ArByte) + 1) div 4) - 1 do 347 | ArLong[n] := ArByte[n * 4 + 0] 348 | + (ArByte[n * 4 + 1] shl 8) 349 | + (ArByte[n * 4 + 2] shl 16) 350 | + (ArByte[n * 4 + 3] shl 24); 351 | {$ELSE} 352 | Move(ArByte[0], ArLong[0], High(ArByte) + 1); 353 | {$ENDIF} 354 | end; 355 | 356 | procedure ArrLongToByte(var ArLong: Array of Integer; var ArByte: Array of byte); 357 | {$IFDEF SYNACODE_NATIVE} 358 | var 359 | n: integer; 360 | {$ENDIF} 361 | begin 362 | if (High(ArByte) + 1) < ((High(ArLong) + 1) * 4) then 363 | Exit; 364 | {$IFDEF SYNACODE_NATIVE} 365 | for n := 0 to high(ArLong) do 366 | begin 367 | ArByte[n * 4 + 0] := ArLong[n] and $000000FF; 368 | ArByte[n * 4 + 1] := (ArLong[n] shr 8) and $000000FF; 369 | ArByte[n * 4 + 2] := (ArLong[n] shr 16) and $000000FF; 370 | ArByte[n * 4 + 3] := (ArLong[n] shr 24) and $000000FF; 371 | end; 372 | {$ELSE} 373 | Move(ArLong[0], ArByte[0], High(ArByte) + 1); 374 | {$ENDIF} 375 | end; 376 | 377 | type 378 | TMDCtx = record 379 | State: array[0..3] of Integer; 380 | Count: array[0..1] of Integer; 381 | BufAnsiChar: array[0..63] of Byte; 382 | BufLong: array[0..15] of Integer; 383 | end; 384 | TSHA1Ctx= record 385 | Hi, Lo: integer; 386 | Buffer: array[0..63] of byte; 387 | Index: integer; 388 | Hash: array[0..4] of Integer; 389 | HashByte: array[0..19] of byte; 390 | end; 391 | 392 | TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt); 393 | 394 | {==============================================================================} 395 | 396 | function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; 397 | var 398 | x, l, lv: Integer; 399 | c: AnsiChar; 400 | b: Byte; 401 | bad: Boolean; 402 | begin 403 | lv := Length(Value); 404 | SetLength(Result, lv); 405 | x := 1; 406 | l := 1; 407 | while x <= lv do 408 | begin 409 | c := Value[x]; 410 | Inc(x); 411 | if c <> Delimiter then 412 | begin 413 | Result[l] := c; 414 | Inc(l); 415 | end 416 | else 417 | if x < lv then 418 | begin 419 | Case Value[x] Of 420 | #13: 421 | if (Value[x + 1] = #10) then 422 | Inc(x, 2) 423 | else 424 | Inc(x); 425 | #10: 426 | if (Value[x + 1] = #13) then 427 | Inc(x, 2) 428 | else 429 | Inc(x); 430 | else 431 | begin 432 | bad := False; 433 | Case Value[x] Of 434 | '0'..'9': b := (Byte(Value[x]) - 48) Shl 4; 435 | 'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4; 436 | else 437 | begin 438 | b := 0; 439 | bad := True; 440 | end; 441 | end; 442 | Case Value[x + 1] Of 443 | '0'..'9': b := b Or (Byte(Value[x + 1]) - 48); 444 | 'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9); 445 | else 446 | bad := True; 447 | end; 448 | if bad then 449 | begin 450 | Result[l] := c; 451 | Inc(l); 452 | end 453 | else 454 | begin 455 | Inc(x, 2); 456 | Result[l] := AnsiChar(b); 457 | Inc(l); 458 | end; 459 | end; 460 | end; 461 | end 462 | else 463 | break; 464 | end; 465 | Dec(l); 466 | SetLength(Result, l); 467 | end; 468 | 469 | {==============================================================================} 470 | 471 | function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; 472 | begin 473 | Result := DecodeTriplet(Value, '='); 474 | end; 475 | 476 | {==============================================================================} 477 | 478 | function DecodeURL(const Value: AnsiString): AnsiString; 479 | begin 480 | Result := DecodeTriplet(Value, '%'); 481 | end; 482 | 483 | {==============================================================================} 484 | 485 | function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; 486 | Specials: TSpecials): AnsiString; 487 | var 488 | n, l: Integer; 489 | s: AnsiString; 490 | c: AnsiChar; 491 | begin 492 | SetLength(Result, Length(Value) * 3); 493 | l := 1; 494 | for n := 1 to Length(Value) do 495 | begin 496 | c := Value[n]; 497 | if c in Specials then 498 | begin 499 | Result[l] := Delimiter; 500 | Inc(l); 501 | s := IntToHex(Ord(c), 2); 502 | Result[l] := s[1]; 503 | Inc(l); 504 | Result[l] := s[2]; 505 | Inc(l); 506 | end 507 | else 508 | begin 509 | Result[l] := c; 510 | Inc(l); 511 | end; 512 | end; 513 | Dec(l); 514 | SetLength(Result, l); 515 | end; 516 | 517 | {==============================================================================} 518 | 519 | function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; 520 | begin 521 | Result := EncodeTriplet(Value, '=', ['='] + NonAsciiChar); 522 | end; 523 | 524 | {==============================================================================} 525 | 526 | function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; 527 | begin 528 | Result := EncodeTriplet(Value, '=', SpecialChar + NonAsciiChar); 529 | end; 530 | 531 | {==============================================================================} 532 | 533 | function EncodeURLElement(const Value: AnsiString): AnsiString; 534 | begin 535 | Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar); 536 | end; 537 | 538 | {==============================================================================} 539 | 540 | function EncodeURL(const Value: AnsiString): AnsiString; 541 | begin 542 | Result := EncodeTriplet(Value, '%', URLSpecialChar); 543 | end; 544 | 545 | {==============================================================================} 546 | 547 | function Decode4to3(const Value, Table: AnsiString): AnsiString; 548 | var 549 | x, y, n, l: Integer; 550 | d: array[0..3] of Byte; 551 | begin 552 | SetLength(Result, Length(Value)); 553 | x := 1; 554 | l := 1; 555 | while x <= Length(Value) do 556 | begin 557 | for n := 0 to 3 do 558 | begin 559 | if x > Length(Value) then 560 | d[n] := 64 561 | else 562 | begin 563 | y := Pos(Value[x], Table); 564 | if y < 1 then 565 | y := 1; 566 | d[n] := y - 1; 567 | end; 568 | Inc(x); 569 | end; 570 | Result[l] := AnsiChar((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); 571 | Inc(l); 572 | if d[2] <> 64 then 573 | begin 574 | Result[l] := AnsiChar((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); 575 | Inc(l); 576 | if d[3] <> 64 then 577 | begin 578 | Result[l] := AnsiChar((D[2] and $03) shl 6 + (D[3] and $3F)); 579 | Inc(l); 580 | end; 581 | end; 582 | end; 583 | Dec(l); 584 | SetLength(Result, l); 585 | end; 586 | 587 | {==============================================================================} 588 | function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; 589 | var 590 | x, y, lv: Integer; 591 | d: integer; 592 | dl: integer; 593 | c: byte; 594 | p: integer; 595 | begin 596 | lv := Length(Value); 597 | SetLength(Result, lv); 598 | x := 1; 599 | dl := 4; 600 | d := 0; 601 | p := 1; 602 | while x <= lv do 603 | begin 604 | y := Ord(Value[x]); 605 | if y in [33..127] then 606 | c := Ord(Table[y - 32]) 607 | else 608 | c := 64; 609 | Inc(x); 610 | if c > 63 then 611 | continue; 612 | d := (d shl 6) or c; 613 | dec(dl); 614 | if dl <> 0 then 615 | continue; 616 | Result[p] := AnsiChar((d shr 16) and $ff); 617 | inc(p); 618 | Result[p] := AnsiChar((d shr 8) and $ff); 619 | inc(p); 620 | Result[p] := AnsiChar(d and $ff); 621 | inc(p); 622 | d := 0; 623 | dl := 4; 624 | end; 625 | case dl of 626 | 1: 627 | begin 628 | d := d shr 2; 629 | Result[p] := AnsiChar((d shr 8) and $ff); 630 | inc(p); 631 | Result[p] := AnsiChar(d and $ff); 632 | inc(p); 633 | end; 634 | 2: 635 | begin 636 | d := d shr 4; 637 | Result[p] := AnsiChar(d and $ff); 638 | inc(p); 639 | end; 640 | end; 641 | SetLength(Result, p - 1); 642 | end; 643 | 644 | {==============================================================================} 645 | 646 | function Encode3to4(const Value, Table: AnsiString): AnsiString; 647 | var 648 | c: Byte; 649 | n, l: Integer; 650 | Count: Integer; 651 | DOut: array[0..3] of Byte; 652 | begin 653 | setlength(Result, ((Length(Value) + 2) div 3) * 4); 654 | l := 1; 655 | Count := 1; 656 | while Count <= Length(Value) do 657 | begin 658 | c := Ord(Value[Count]); 659 | Inc(Count); 660 | DOut[0] := (c and $FC) shr 2; 661 | DOut[1] := (c and $03) shl 4; 662 | if Count <= Length(Value) then 663 | begin 664 | c := Ord(Value[Count]); 665 | Inc(Count); 666 | DOut[1] := DOut[1] + (c and $F0) shr 4; 667 | DOut[2] := (c and $0F) shl 2; 668 | if Count <= Length(Value) then 669 | begin 670 | c := Ord(Value[Count]); 671 | Inc(Count); 672 | DOut[2] := DOut[2] + (c and $C0) shr 6; 673 | DOut[3] := (c and $3F); 674 | end 675 | else 676 | begin 677 | DOut[3] := $40; 678 | end; 679 | end 680 | else 681 | begin 682 | DOut[2] := $40; 683 | DOut[3] := $40; 684 | end; 685 | for n := 0 to 3 do 686 | begin 687 | if (DOut[n] + 1) <= Length(Table) then 688 | begin 689 | Result[l] := Table[DOut[n] + 1]; 690 | Inc(l); 691 | end; 692 | end; 693 | end; 694 | SetLength(Result, l - 1); 695 | end; 696 | 697 | {==============================================================================} 698 | 699 | function DecodeBase64(const Value: AnsiString): AnsiString; 700 | begin 701 | Result := Decode4to3Ex(Value, ReTableBase64); 702 | end; 703 | 704 | {==============================================================================} 705 | 706 | function EncodeBase64(const Value: AnsiString): AnsiString; 707 | begin 708 | Result := Encode3to4(Value, TableBase64); 709 | end; 710 | 711 | {==============================================================================} 712 | 713 | function DecodeBase64mod(const Value: AnsiString): AnsiString; 714 | begin 715 | Result := Decode4to3(Value, TableBase64mod); 716 | end; 717 | 718 | {==============================================================================} 719 | 720 | function EncodeBase64mod(const Value: AnsiString): AnsiString; 721 | begin 722 | Result := Encode3to4(Value, TableBase64mod); 723 | end; 724 | 725 | {==============================================================================} 726 | 727 | function DecodeUU(const Value: AnsiString): AnsiString; 728 | var 729 | s: AnsiString; 730 | uut: AnsiString; 731 | x: Integer; 732 | begin 733 | Result := ''; 734 | uut := TableUU; 735 | s := trim(UpperCase(Value)); 736 | if s = '' then Exit; 737 | if Pos('BEGIN', s) = 1 then 738 | Exit; 739 | if Pos('END', s) = 1 then 740 | Exit; 741 | if Pos('TABLE', s) = 1 then 742 | Exit; //ignore Table yet (set custom UUT) 743 | //begin decoding 744 | x := Pos(Value[1], uut) - 1; 745 | case (x mod 3) of 746 | 0: x :=(x div 3)* 4; 747 | 1: x :=((x div 3) * 4) + 2; 748 | 2: x :=((x div 3) * 4) + 3; 749 | end; 750 | //x - lenght UU line 751 | s := Copy(Value, 2, x); 752 | if s = '' then 753 | Exit; 754 | s := s + StringOfChar(' ', x - length(s)); 755 | Result := Decode4to3(s, uut); 756 | end; 757 | 758 | {==============================================================================} 759 | 760 | function EncodeUU(const Value: AnsiString): AnsiString; 761 | begin 762 | Result := ''; 763 | if Length(Value) < Length(TableUU) then 764 | Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU); 765 | end; 766 | 767 | {==============================================================================} 768 | 769 | function DecodeXX(const Value: AnsiString): AnsiString; 770 | var 771 | s: AnsiString; 772 | x: Integer; 773 | begin 774 | Result := ''; 775 | s := trim(UpperCase(Value)); 776 | if s = '' then 777 | Exit; 778 | if Pos('BEGIN', s) = 1 then 779 | Exit; 780 | if Pos('END', s) = 1 then 781 | Exit; 782 | //begin decoding 783 | x := Pos(Value[1], TableXX) - 1; 784 | case (x mod 3) of 785 | 0: x :=(x div 3)* 4; 786 | 1: x :=((x div 3) * 4) + 2; 787 | 2: x :=((x div 3) * 4) + 3; 788 | end; 789 | //x - lenght XX line 790 | s := Copy(Value, 2, x); 791 | if s = '' then 792 | Exit; 793 | s := s + StringOfChar(' ', x - length(s)); 794 | Result := Decode4to3(s, TableXX); 795 | end; 796 | 797 | {==============================================================================} 798 | 799 | function DecodeYEnc(const Value: AnsiString): AnsiString; 800 | var 801 | C : Byte; 802 | i: integer; 803 | begin 804 | Result := ''; 805 | i := 1; 806 | while i <= Length(Value) do 807 | begin 808 | c := Ord(Value[i]); 809 | Inc(i); 810 | if c = Ord('=') then 811 | begin 812 | c := Ord(Value[i]); 813 | Inc(i); 814 | Dec(c, 64); 815 | end; 816 | Dec(C, 42); 817 | Result := Result + AnsiChar(C); 818 | end; 819 | end; 820 | 821 | {==============================================================================} 822 | 823 | function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; 824 | begin 825 | Result := (Crc32 shr 8) 826 | xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))]; 827 | end; 828 | 829 | {==============================================================================} 830 | 831 | function Crc32(const Value: AnsiString): Integer; 832 | var 833 | n: Integer; 834 | begin 835 | Result := Integer($FFFFFFFF); 836 | for n := 1 to Length(Value) do 837 | Result := UpdateCrc32(Ord(Value[n]), Result); 838 | Result := not Result; 839 | end; 840 | 841 | {==============================================================================} 842 | 843 | function UpdateCrc16(Value: Byte; Crc16: Word): Word; 844 | begin 845 | Result := ((Crc16 shr 8) and $00FF) xor 846 | crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)]; 847 | end; 848 | 849 | {==============================================================================} 850 | 851 | function Crc16(const Value: AnsiString): Word; 852 | var 853 | n: Integer; 854 | begin 855 | Result := $FFFF; 856 | for n := 1 to Length(Value) do 857 | Result := UpdateCrc16(Ord(Value[n]), Result); 858 | end; 859 | 860 | {==============================================================================} 861 | 862 | procedure MDInit(var MDContext: TMDCtx); 863 | var 864 | n: integer; 865 | begin 866 | MDContext.Count[0] := 0; 867 | MDContext.Count[1] := 0; 868 | for n := 0 to high(MDContext.BufAnsiChar) do 869 | MDContext.BufAnsiChar[n] := 0; 870 | for n := 0 to high(MDContext.BufLong) do 871 | MDContext.BufLong[n] := 0; 872 | MDContext.State[0] := Integer($67452301); 873 | MDContext.State[1] := Integer($EFCDAB89); 874 | MDContext.State[2] := Integer($98BADCFE); 875 | MDContext.State[3] := Integer($10325476); 876 | end; 877 | 878 | procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); 879 | var 880 | A, B, C, D: LongInt; 881 | 882 | procedure Round1(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); 883 | begin 884 | Inc(W, (Z xor (X and (Y xor Z))) + Data); 885 | W := (W shl S) or (W shr (32 - S)); 886 | Inc(W, X); 887 | end; 888 | 889 | procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); 890 | begin 891 | Inc(W, (Y xor (Z and (X xor Y))) + Data); 892 | W := (W shl S) or (W shr (32 - S)); 893 | Inc(W, X); 894 | end; 895 | 896 | procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); 897 | begin 898 | Inc(W, (X xor Y xor Z) + Data); 899 | W := (W shl S) or (W shr (32 - S)); 900 | Inc(W, X); 901 | end; 902 | 903 | procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); 904 | begin 905 | Inc(W, (Y xor (X or not Z)) + Data); 906 | W := (W shl S) or (W shr (32 - S)); 907 | Inc(W, X); 908 | end; 909 | begin 910 | A := Buf[0]; 911 | B := Buf[1]; 912 | C := Buf[2]; 913 | D := Buf[3]; 914 | 915 | Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7); 916 | Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12); 917 | Round1(C, D, A, B, Data[2] + Longint($242070DB), 17); 918 | Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22); 919 | Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7); 920 | Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12); 921 | Round1(C, D, A, B, Data[6] + Longint($A8304613), 17); 922 | Round1(B, C, D, A, Data[7] + Longint($FD469501), 22); 923 | Round1(A, B, C, D, Data[8] + Longint($698098D8), 7); 924 | Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12); 925 | Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17); 926 | Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22); 927 | Round1(A, B, C, D, Data[12] + Longint($6B901122), 7); 928 | Round1(D, A, B, C, Data[13] + Longint($FD987193), 12); 929 | Round1(C, D, A, B, Data[14] + Longint($A679438E), 17); 930 | Round1(B, C, D, A, Data[15] + Longint($49B40821), 22); 931 | 932 | Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5); 933 | Round2(D, A, B, C, Data[6] + Longint($C040B340), 9); 934 | Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14); 935 | Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20); 936 | Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5); 937 | Round2(D, A, B, C, Data[10] + Longint($02441453), 9); 938 | Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14); 939 | Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20); 940 | Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5); 941 | Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9); 942 | Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14); 943 | Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20); 944 | Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5); 945 | Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9); 946 | Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14); 947 | Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20); 948 | 949 | Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4); 950 | Round3(D, A, B, C, Data[8] + Longint($8771F681), 11); 951 | Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16); 952 | Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23); 953 | Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4); 954 | Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11); 955 | Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16); 956 | Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23); 957 | Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4); 958 | Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11); 959 | Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16); 960 | Round3(B, C, D, A, Data[6] + Longint($04881D05), 23); 961 | Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4); 962 | Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11); 963 | Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16); 964 | Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23); 965 | 966 | Round4(A, B, C, D, Data[0] + Longint($F4292244), 6); 967 | Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10); 968 | Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15); 969 | Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21); 970 | Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6); 971 | Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10); 972 | Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15); 973 | Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21); 974 | Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6); 975 | Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10); 976 | Round4(C, D, A, B, Data[6] + Longint($A3014314), 15); 977 | Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21); 978 | Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6); 979 | Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10); 980 | Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15); 981 | Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21); 982 | 983 | Inc(Buf[0], A); 984 | Inc(Buf[1], B); 985 | Inc(Buf[2], C); 986 | Inc(Buf[3], D); 987 | end; 988 | 989 | //fixed by James McAdams 990 | procedure MDUpdate(var MDContext: TMDCtx; const Data: AnsiString; transform: TMDTransform); 991 | var 992 | Index, partLen, InputLen, I: integer; 993 | {$IFDEF SYNACODE_NATIVE} 994 | n: integer; 995 | {$ENDIF} 996 | begin 997 | InputLen := Length(Data); 998 | with MDContext do 999 | begin 1000 | Index := (Count[0] shr 3) and $3F; 1001 | Inc(Count[0], InputLen shl 3); 1002 | if Count[0] < (InputLen shl 3) then 1003 | Inc(Count[1]); 1004 | Inc(Count[1], InputLen shr 29); 1005 | partLen := 64 - Index; 1006 | if InputLen >= partLen then 1007 | begin 1008 | ArrLongToByte(BufLong, BufAnsiChar); 1009 | {$IFDEF SYNACODE_NATIVE} 1010 | for n := 1 to partLen do 1011 | BufAnsiChar[index - 1 + n] := Ord(Data[n]); 1012 | {$ELSE} 1013 | Move(Data[1], BufAnsiChar[Index], partLen); 1014 | {$ENDIF} 1015 | ArrByteToLong(BufAnsiChar, BufLong); 1016 | Transform(State, Buflong); 1017 | I := partLen; 1018 | while I + 63 < InputLen do 1019 | begin 1020 | ArrLongToByte(BufLong, BufAnsiChar); 1021 | {$IFDEF SYNACODE_NATIVE} 1022 | for n := 1 to 64 do 1023 | BufAnsiChar[n - 1] := Ord(Data[i + n]); 1024 | {$ELSE} 1025 | Move(Data[I+1], BufAnsiChar, 64); 1026 | {$ENDIF} 1027 | ArrByteToLong(BufAnsiChar, BufLong); 1028 | Transform(State, Buflong); 1029 | inc(I, 64); 1030 | end; 1031 | Index := 0; 1032 | end 1033 | else 1034 | I := 0; 1035 | ArrLongToByte(BufLong, BufAnsiChar); 1036 | {$IFDEF SYNACODE_NATIVE} 1037 | for n := 1 to InputLen-I do 1038 | BufAnsiChar[Index + n - 1] := Ord(Data[i + n]); 1039 | {$ELSE} 1040 | Move(Data[I+1], BufAnsiChar[Index], InputLen-I); 1041 | {$ENDIF} 1042 | ArrByteToLong(BufAnsiChar, BufLong); 1043 | end 1044 | end; 1045 | 1046 | function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): AnsiString; 1047 | var 1048 | Cnt: Word; 1049 | P: Byte; 1050 | digest: array[0..15] of Byte; 1051 | i: Integer; 1052 | n: integer; 1053 | begin 1054 | for I := 0 to 15 do 1055 | Digest[I] := I + 1; 1056 | with MDContext do 1057 | begin 1058 | Cnt := (Count[0] shr 3) and $3F; 1059 | P := Cnt; 1060 | BufAnsiChar[P] := $80; 1061 | Inc(P); 1062 | Cnt := 64 - 1 - Cnt; 1063 | if Cnt < 8 then 1064 | begin 1065 | for n := 0 to cnt - 1 do 1066 | BufAnsiChar[P + n] := 0; 1067 | ArrByteToLong(BufAnsiChar, BufLong); 1068 | // FillChar(BufAnsiChar[P], Cnt, #0); 1069 | Transform(State, BufLong); 1070 | ArrLongToByte(BufLong, BufAnsiChar); 1071 | for n := 0 to 55 do 1072 | BufAnsiChar[n] := 0; 1073 | ArrByteToLong(BufAnsiChar, BufLong); 1074 | // FillChar(BufAnsiChar, 56, #0); 1075 | end 1076 | else 1077 | begin 1078 | for n := 0 to Cnt - 8 - 1 do 1079 | BufAnsiChar[p + n] := 0; 1080 | ArrByteToLong(BufAnsiChar, BufLong); 1081 | // FillChar(BufAnsiChar[P], Cnt - 8, #0); 1082 | end; 1083 | BufLong[14] := Count[0]; 1084 | BufLong[15] := Count[1]; 1085 | Transform(State, BufLong); 1086 | ArrLongToByte(State, Digest); 1087 | // Move(State, Digest, 16); 1088 | Result := ''; 1089 | for i := 0 to 15 do 1090 | Result := Result + AnsiChar(digest[i]); 1091 | end; 1092 | // FillChar(MD5Context, SizeOf(TMD5Ctx), #0) 1093 | end; 1094 | 1095 | {==============================================================================} 1096 | 1097 | function MD5(const Value: AnsiString): AnsiString; 1098 | var 1099 | MDContext: TMDCtx; 1100 | begin 1101 | MDInit(MDContext); 1102 | MDUpdate(MDContext, Value, @MD5Transform); 1103 | Result := MDFinal(MDContext, @MD5Transform); 1104 | end; 1105 | 1106 | {==============================================================================} 1107 | 1108 | function HMAC_MD5(Text, Key: AnsiString): AnsiString; 1109 | var 1110 | ipad, opad, s: AnsiString; 1111 | n: Integer; 1112 | MDContext: TMDCtx; 1113 | begin 1114 | if Length(Key) > 64 then 1115 | Key := md5(Key); 1116 | ipad := StringOfChar(#$36, 64); 1117 | opad := StringOfChar(#$5C, 64); 1118 | for n := 1 to Length(Key) do 1119 | begin 1120 | ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); 1121 | opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); 1122 | end; 1123 | MDInit(MDContext); 1124 | MDUpdate(MDContext, ipad, @MD5Transform); 1125 | MDUpdate(MDContext, Text, @MD5Transform); 1126 | s := MDFinal(MDContext, @MD5Transform); 1127 | MDInit(MDContext); 1128 | MDUpdate(MDContext, opad, @MD5Transform); 1129 | MDUpdate(MDContext, s, @MD5Transform); 1130 | Result := MDFinal(MDContext, @MD5Transform); 1131 | end; 1132 | 1133 | {==============================================================================} 1134 | 1135 | function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; 1136 | var 1137 | cnt, rest: integer; 1138 | l: integer; 1139 | n: integer; 1140 | MDContext: TMDCtx; 1141 | begin 1142 | l := length(Value); 1143 | cnt := Len div l; 1144 | rest := Len mod l; 1145 | MDInit(MDContext); 1146 | for n := 1 to cnt do 1147 | MDUpdate(MDContext, Value, @MD5Transform); 1148 | if rest > 0 then 1149 | MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform); 1150 | Result := MDFinal(MDContext, @MD5Transform); 1151 | end; 1152 | 1153 | {==============================================================================} 1154 | // SHA1 is based on sources by Dave Barton (davebarton@bigfoot.com) 1155 | 1156 | procedure SHA1init( var SHA1Context: TSHA1Ctx ); 1157 | var 1158 | n: integer; 1159 | begin 1160 | SHA1Context.Hi := 0; 1161 | SHA1Context.Lo := 0; 1162 | SHA1Context.Index := 0; 1163 | for n := 0 to High(SHA1Context.Buffer) do 1164 | SHA1Context.Buffer[n] := 0; 1165 | for n := 0 to High(SHA1Context.HashByte) do 1166 | SHA1Context.HashByte[n] := 0; 1167 | // FillChar(SHA1Context, SizeOf(TSHA1Ctx), #0); 1168 | SHA1Context.Hash[0] := integer($67452301); 1169 | SHA1Context.Hash[1] := integer($EFCDAB89); 1170 | SHA1Context.Hash[2] := integer($98BADCFE); 1171 | SHA1Context.Hash[3] := integer($10325476); 1172 | SHA1Context.Hash[4] := integer($C3D2E1F0); 1173 | end; 1174 | 1175 | //****************************************************************************** 1176 | function RB(A: integer): integer; 1177 | begin 1178 | Result := (A shr 24) or ((A shr 8) and $FF00) or ((A shl 8) and $FF0000) or (A shl 24); 1179 | end; 1180 | 1181 | procedure SHA1Compress(var Data: TSHA1Ctx); 1182 | var 1183 | A, B, C, D, E, T: integer; 1184 | W: array[0..79] of integer; 1185 | i: integer; 1186 | n: integer; 1187 | 1188 | function F1(x, y, z: integer): integer; 1189 | begin 1190 | Result := z xor (x and (y xor z)); 1191 | end; 1192 | function F2(x, y, z: integer): integer; 1193 | begin 1194 | Result := x xor y xor z; 1195 | end; 1196 | function F3(x, y, z: integer): integer; 1197 | begin 1198 | Result := (x and y) or (z and (x or y)); 1199 | end; 1200 | function LRot32(X: integer; c: integer): integer; 1201 | begin 1202 | result := (x shl c) or (x shr (32 - c)); 1203 | end; 1204 | begin 1205 | ArrByteToLong(Data.Buffer, W); 1206 | // Move(Data.Buffer, W, Sizeof(Data.Buffer)); 1207 | for i := 0 to 15 do 1208 | W[i] := RB(W[i]); 1209 | for i := 16 to 79 do 1210 | W[i] := LRot32(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16], 1); 1211 | A := Data.Hash[0]; 1212 | B := Data.Hash[1]; 1213 | C := Data.Hash[2]; 1214 | D := Data.Hash[3]; 1215 | E := Data.Hash[4]; 1216 | for i := 0 to 19 do 1217 | begin 1218 | T := LRot32(A, 5) + F1(B, C, D) + E + W[i] + integer($5A827999); 1219 | E := D; 1220 | D := C; 1221 | C := LRot32(B, 30); 1222 | B := A; 1223 | A := T; 1224 | end; 1225 | for i := 20 to 39 do 1226 | begin 1227 | T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($6ED9EBA1); 1228 | E := D; 1229 | D := C; 1230 | C := LRot32(B, 30); 1231 | B := A; 1232 | A := T; 1233 | end; 1234 | for i := 40 to 59 do 1235 | begin 1236 | T := LRot32(A, 5) + F3(B, C, D) + E + W[i] + integer($8F1BBCDC); 1237 | E := D; 1238 | D := C; 1239 | C := LRot32(B, 30); 1240 | B := A; 1241 | A := T; 1242 | end; 1243 | for i := 60 to 79 do 1244 | begin 1245 | T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($CA62C1D6); 1246 | E := D; 1247 | D := C; 1248 | C := LRot32(B, 30); 1249 | B := A; 1250 | A := T; 1251 | end; 1252 | Data.Hash[0] := Data.Hash[0] + A; 1253 | Data.Hash[1] := Data.Hash[1] + B; 1254 | Data.Hash[2] := Data.Hash[2] + C; 1255 | Data.Hash[3] := Data.Hash[3] + D; 1256 | Data.Hash[4] := Data.Hash[4] + E; 1257 | for n := 0 to high(w) do 1258 | w[n] := 0; 1259 | // FillChar(W, Sizeof(W), 0); 1260 | for n := 0 to high(Data.Buffer) do 1261 | Data.Buffer[n] := 0; 1262 | // FillChar(Data.Buffer, Sizeof(Data.Buffer), 0); 1263 | end; 1264 | 1265 | //****************************************************************************** 1266 | procedure SHA1Update(var Context: TSHA1Ctx; const Data: AnsiString); 1267 | var 1268 | Len: integer; 1269 | n: integer; 1270 | i, k: integer; 1271 | begin 1272 | Len := Length(data); 1273 | for k := 0 to 7 do 1274 | begin 1275 | i := Context.Lo; 1276 | Inc(Context.Lo, Len); 1277 | if Context.Lo < i then 1278 | Inc(Context.Hi); 1279 | end; 1280 | for n := 1 to len do 1281 | begin 1282 | Context.Buffer[Context.Index] := byte(Data[n]); 1283 | Inc(Context.Index); 1284 | if Context.Index = 64 then 1285 | begin 1286 | Context.Index := 0; 1287 | SHA1Compress(Context); 1288 | end; 1289 | end; 1290 | end; 1291 | 1292 | //****************************************************************************** 1293 | function SHA1Final(var Context: TSHA1Ctx): AnsiString; 1294 | type 1295 | Pinteger = ^integer; 1296 | var 1297 | i: integer; 1298 | procedure ItoArr(var Ar: Array of byte; I, value: Integer); 1299 | begin 1300 | Ar[i + 0] := Value and $000000FF; 1301 | Ar[i + 1] := (Value shr 8) and $000000FF; 1302 | Ar[i + 2] := (Value shr 16) and $000000FF; 1303 | Ar[i + 3] := (Value shr 24) and $000000FF; 1304 | end; 1305 | begin 1306 | Context.Buffer[Context.Index] := $80; 1307 | if Context.Index >= 56 then 1308 | SHA1Compress(Context); 1309 | ItoArr(Context.Buffer, 56, RB(Context.Hi)); 1310 | ItoArr(Context.Buffer, 60, RB(Context.Lo)); 1311 | // Pinteger(@Context.Buffer[56])^ := RB(Context.Hi); 1312 | // Pinteger(@Context.Buffer[60])^ := RB(Context.Lo); 1313 | SHA1Compress(Context); 1314 | Context.Hash[0] := RB(Context.Hash[0]); 1315 | Context.Hash[1] := RB(Context.Hash[1]); 1316 | Context.Hash[2] := RB(Context.Hash[2]); 1317 | Context.Hash[3] := RB(Context.Hash[3]); 1318 | Context.Hash[4] := RB(Context.Hash[4]); 1319 | ArrLongToByte(Context.Hash, Context.HashByte); 1320 | Result := ''; 1321 | for i := 0 to 19 do 1322 | Result := Result + AnsiChar(Context.HashByte[i]); 1323 | end; 1324 | 1325 | function SHA1(const Value: AnsiString): AnsiString; 1326 | var 1327 | SHA1Context: TSHA1Ctx; 1328 | begin 1329 | SHA1Init(SHA1Context); 1330 | SHA1Update(SHA1Context, Value); 1331 | Result := SHA1Final(SHA1Context); 1332 | end; 1333 | 1334 | {==============================================================================} 1335 | 1336 | function HMAC_SHA1(Text, Key: AnsiString): AnsiString; 1337 | var 1338 | ipad, opad, s: AnsiString; 1339 | n: Integer; 1340 | SHA1Context: TSHA1Ctx; 1341 | begin 1342 | if Length(Key) > 64 then 1343 | Key := SHA1(Key); 1344 | ipad := StringOfChar(#$36, 64); 1345 | opad := StringOfChar(#$5C, 64); 1346 | for n := 1 to Length(Key) do 1347 | begin 1348 | ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); 1349 | opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); 1350 | end; 1351 | SHA1Init(SHA1Context); 1352 | SHA1Update(SHA1Context, ipad); 1353 | SHA1Update(SHA1Context, Text); 1354 | s := SHA1Final(SHA1Context); 1355 | SHA1Init(SHA1Context); 1356 | SHA1Update(SHA1Context, opad); 1357 | SHA1Update(SHA1Context, s); 1358 | Result := SHA1Final(SHA1Context); 1359 | end; 1360 | 1361 | {==============================================================================} 1362 | 1363 | function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; 1364 | var 1365 | cnt, rest: integer; 1366 | l: integer; 1367 | n: integer; 1368 | SHA1Context: TSHA1Ctx; 1369 | begin 1370 | l := length(Value); 1371 | cnt := Len div l; 1372 | rest := Len mod l; 1373 | SHA1Init(SHA1Context); 1374 | for n := 1 to cnt do 1375 | SHA1Update(SHA1Context, Value); 1376 | if rest > 0 then 1377 | SHA1Update(SHA1Context, Copy(Value, 1, rest)); 1378 | Result := SHA1Final(SHA1Context); 1379 | end; 1380 | 1381 | {==============================================================================} 1382 | 1383 | procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt); 1384 | var 1385 | A, B, C, D: LongInt; 1386 | function LRot32(a, b: longint): longint; 1387 | begin 1388 | Result:= (a shl b) or (a shr (32 - b)); 1389 | end; 1390 | begin 1391 | A := Buf[0]; 1392 | B := Buf[1]; 1393 | C := Buf[2]; 1394 | D := Buf[3]; 1395 | 1396 | A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3); 1397 | D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7); 1398 | C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11); 1399 | B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19); 1400 | A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3); 1401 | D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7); 1402 | C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11); 1403 | B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19); 1404 | A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3); 1405 | D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7); 1406 | C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11); 1407 | B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19); 1408 | A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3); 1409 | D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7); 1410 | C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11); 1411 | B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19); 1412 | 1413 | A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3); 1414 | D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5); 1415 | C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9); 1416 | B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13); 1417 | A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3); 1418 | D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5); 1419 | C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9); 1420 | B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13); 1421 | A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3); 1422 | D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5); 1423 | C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9); 1424 | B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13); 1425 | A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3); 1426 | D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5); 1427 | C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9); 1428 | B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13); 1429 | 1430 | A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3); 1431 | D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9); 1432 | C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11); 1433 | B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15); 1434 | A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3); 1435 | D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9); 1436 | C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11); 1437 | B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15); 1438 | A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3); 1439 | D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9); 1440 | C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11); 1441 | B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15); 1442 | A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3); 1443 | D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9); 1444 | C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11); 1445 | B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15); 1446 | 1447 | Inc(Buf[0], A); 1448 | Inc(Buf[1], B); 1449 | Inc(Buf[2], C); 1450 | Inc(Buf[3], D); 1451 | end; 1452 | 1453 | {==============================================================================} 1454 | 1455 | function MD4(const Value: AnsiString): AnsiString; 1456 | var 1457 | MDContext: TMDCtx; 1458 | begin 1459 | MDInit(MDContext); 1460 | MDUpdate(MDContext, Value, @MD4Transform); 1461 | Result := MDFinal(MDContext, @MD4Transform); 1462 | end; 1463 | 1464 | {==============================================================================} 1465 | 1466 | 1467 | end. 1468 | -------------------------------------------------------------------------------- /synapse/synafpc.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.003.001 | 3 | |==============================================================================| 4 | | Content: Utils for FreePascal compatibility | 5 | |==============================================================================| 6 | | Copyright (c)1999-2013, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2003-2013. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | | Tomas Hajny (OS2 support) | 41 | |==============================================================================| 42 | | History: see HISTORY.HTM from distribution package | 43 | | (Found at URL: http://www.ararat.cz/synapse/) | 44 | |==============================================================================} 45 | 46 | {:@exclude} 47 | 48 | {$IFDEF FPC} 49 | {$MODE DELPHI} 50 | {$ENDIF} 51 | {$H+} 52 | //old Delphi does not have MSWINDOWS define. 53 | {$IFDEF WIN32} 54 | {$IFNDEF MSWINDOWS} 55 | {$DEFINE MSWINDOWS} 56 | {$ENDIF} 57 | {$ENDIF} 58 | 59 | unit synafpc; 60 | 61 | interface 62 | 63 | uses 64 | {$IFDEF FPC} 65 | dynlibs, sysutils; 66 | {$ELSE} 67 | {$IFDEF MSWINDOWS} 68 | Windows; 69 | {$ELSE} 70 | SysUtils; 71 | {$ENDIF} 72 | {$ENDIF} 73 | 74 | {$IFDEF FPC} 75 | type 76 | TLibHandle = dynlibs.TLibHandle; 77 | 78 | function LoadLibrary(ModuleName: PChar): TLibHandle; 79 | function FreeLibrary(Module: TLibHandle): LongBool; 80 | function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; 81 | function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; 82 | {$ELSE} //not FPC 83 | type 84 | {$IFDEF CIL} 85 | TLibHandle = Integer; 86 | PtrInt = Integer; 87 | {$ELSE} 88 | TLibHandle = HModule; 89 | {$IFDEF WIN64} 90 | PtrInt = NativeInt; 91 | {$ELSE} 92 | PtrInt = Integer; 93 | {$ENDIF} 94 | {$ENDIF} 95 | {$IFDEF VER100} 96 | LongWord = DWord; 97 | {$ENDIF} 98 | {$ENDIF} 99 | 100 | procedure Sleep(milliseconds: Cardinal); 101 | 102 | 103 | implementation 104 | 105 | {==============================================================================} 106 | {$IFDEF FPC} 107 | function LoadLibrary(ModuleName: PChar): TLibHandle; 108 | begin 109 | Result := dynlibs.LoadLibrary(Modulename); 110 | end; 111 | 112 | function FreeLibrary(Module: TLibHandle): LongBool; 113 | begin 114 | Result := dynlibs.UnloadLibrary(Module); 115 | end; 116 | 117 | function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; 118 | begin 119 | {$IFDEF OS2GCC} 120 | Result := dynlibs.GetProcedureAddress(Module, '_' + Proc); 121 | {$ELSE OS2GCC} 122 | Result := dynlibs.GetProcedureAddress(Module, Proc); 123 | {$ENDIF OS2GCC} 124 | end; 125 | 126 | function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; 127 | begin 128 | Result := 0; 129 | end; 130 | 131 | {$ELSE} 132 | {$ENDIF} 133 | 134 | procedure Sleep(milliseconds: Cardinal); 135 | begin 136 | {$IFDEF MSWINDOWS} 137 | {$IFDEF FPC} 138 | sysutils.sleep(milliseconds); 139 | {$ELSE} 140 | windows.sleep(milliseconds); 141 | {$ENDIF} 142 | {$ELSE} 143 | sysutils.sleep(milliseconds); 144 | {$ENDIF} 145 | 146 | end; 147 | 148 | end. 149 | -------------------------------------------------------------------------------- /synapse/synaip.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.002.001 | 3 | |==============================================================================| 4 | | Content: IP address support procedures and functions | 5 | |==============================================================================| 6 | | Copyright (c)2006-2010, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c) 2006-2010. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(IP adress support procedures and functions)} 46 | 47 | {$IFDEF FPC} 48 | {$MODE DELPHI} 49 | {$ENDIF} 50 | {$Q-} 51 | {$R-} 52 | {$H+} 53 | 54 | {$IFDEF UNICODE} 55 | {$WARN IMPLICIT_STRING_CAST OFF} 56 | {$WARN IMPLICIT_STRING_CAST_LOSS OFF} 57 | {$WARN SUSPICIOUS_TYPECAST OFF} 58 | {$ENDIF} 59 | 60 | unit synaip; 61 | 62 | interface 63 | 64 | uses 65 | SysUtils, SynaUtil; 66 | 67 | type 68 | {:binary form of IPv6 adress (for string conversion routines)} 69 | TIp6Bytes = array [0..15] of Byte; 70 | {:binary form of IPv6 adress (for string conversion routines)} 71 | TIp6Words = array [0..7] of Word; 72 | 73 | {:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} 74 | function IsIP(const Value: string): Boolean; 75 | 76 | {:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} 77 | function IsIP6(const Value: string): Boolean; 78 | 79 | {:Returns a string with the "Host" ip address converted to binary form.} 80 | function IPToID(Host: string): Ansistring; 81 | 82 | {:Convert IPv6 address from their string form to binary byte array.} 83 | function StrToIp6(value: string): TIp6Bytes; 84 | 85 | {:Convert IPv6 address from binary byte array to string form.} 86 | function Ip6ToStr(value: TIp6Bytes): string; 87 | 88 | {:Convert IPv4 address from their string form to binary.} 89 | function StrToIp(value: string): integer; 90 | 91 | {:Convert IPv4 address from binary to string form.} 92 | function IpToStr(value: integer): string; 93 | 94 | {:Convert IPv4 address to reverse form.} 95 | function ReverseIP(Value: AnsiString): AnsiString; 96 | 97 | {:Convert IPv6 address to reverse form.} 98 | function ReverseIP6(Value: AnsiString): AnsiString; 99 | 100 | {:Expand short form of IPv6 address to long form.} 101 | function ExpandIP6(Value: AnsiString): AnsiString; 102 | 103 | 104 | implementation 105 | 106 | {==============================================================================} 107 | 108 | function IsIP(const Value: string): Boolean; 109 | var 110 | TempIP: string; 111 | function ByteIsOk(const Value: string): Boolean; 112 | var 113 | x, n: integer; 114 | begin 115 | x := StrToIntDef(Value, -1); 116 | Result := (x >= 0) and (x < 256); 117 | // X may be in correct range, but value still may not be correct value! 118 | // i.e. "$80" 119 | if Result then 120 | for n := 1 to length(Value) do 121 | if not (AnsiChar(Value[n]) in ['0'..'9']) then 122 | begin 123 | Result := False; 124 | Break; 125 | end; 126 | end; 127 | begin 128 | TempIP := Value; 129 | Result := False; 130 | if not ByteIsOk(Fetch(TempIP, '.')) then 131 | Exit; 132 | if not ByteIsOk(Fetch(TempIP, '.')) then 133 | Exit; 134 | if not ByteIsOk(Fetch(TempIP, '.')) then 135 | Exit; 136 | if ByteIsOk(TempIP) then 137 | Result := True; 138 | end; 139 | 140 | {==============================================================================} 141 | 142 | function IsIP6(const Value: string): Boolean; 143 | var 144 | TempIP: string; 145 | s,t: string; 146 | x: integer; 147 | partcount: integer; 148 | zerocount: integer; 149 | First: Boolean; 150 | begin 151 | TempIP := Value; 152 | Result := False; 153 | if Value = '::' then 154 | begin 155 | Result := True; 156 | Exit; 157 | end; 158 | partcount := 0; 159 | zerocount := 0; 160 | First := True; 161 | while tempIP <> '' do 162 | begin 163 | s := fetch(TempIP, ':'); 164 | if not(First) and (s = '') then 165 | Inc(zerocount); 166 | First := False; 167 | if zerocount > 1 then 168 | break; 169 | Inc(partCount); 170 | if s = '' then 171 | Continue; 172 | if partCount > 8 then 173 | break; 174 | if tempIP = '' then 175 | begin 176 | t := SeparateRight(s, '%'); 177 | s := SeparateLeft(s, '%'); 178 | x := StrToIntDef('$' + t, -1); 179 | if (x < 0) or (x > $ffff) then 180 | break; 181 | end; 182 | x := StrToIntDef('$' + s, -1); 183 | if (x < 0) or (x > $ffff) then 184 | break; 185 | if tempIP = '' then 186 | if not((PartCount = 1) and (ZeroCount = 0)) then 187 | Result := True; 188 | end; 189 | end; 190 | 191 | {==============================================================================} 192 | function IPToID(Host: string): Ansistring; 193 | var 194 | s: string; 195 | i, x: Integer; 196 | begin 197 | Result := ''; 198 | for x := 0 to 3 do 199 | begin 200 | s := Fetch(Host, '.'); 201 | i := StrToIntDef(s, 0); 202 | Result := Result + AnsiChar(i); 203 | end; 204 | end; 205 | 206 | {==============================================================================} 207 | 208 | function StrToIp(value: string): integer; 209 | var 210 | s: string; 211 | i, x: Integer; 212 | begin 213 | Result := 0; 214 | for x := 0 to 3 do 215 | begin 216 | s := Fetch(value, '.'); 217 | i := StrToIntDef(s, 0); 218 | Result := (256 * Result) + i; 219 | end; 220 | end; 221 | 222 | {==============================================================================} 223 | 224 | function IpToStr(value: integer): string; 225 | var 226 | x1, x2: word; 227 | y1, y2: byte; 228 | begin 229 | Result := ''; 230 | x1 := value shr 16; 231 | x2 := value and $FFFF; 232 | y1 := x1 div $100; 233 | y2 := x1 mod $100; 234 | Result := inttostr(y1) + '.' + inttostr(y2) + '.'; 235 | y1 := x2 div $100; 236 | y2 := x2 mod $100; 237 | Result := Result + inttostr(y1) + '.' + inttostr(y2); 238 | end; 239 | 240 | {==============================================================================} 241 | 242 | function ExpandIP6(Value: AnsiString): AnsiString; 243 | var 244 | n: integer; 245 | s: ansistring; 246 | x: integer; 247 | begin 248 | Result := ''; 249 | if value = '' then 250 | exit; 251 | x := countofchar(value, ':'); 252 | if x > 7 then 253 | exit; 254 | if value[1] = ':' then 255 | value := '0' + value; 256 | if value[length(value)] = ':' then 257 | value := value + '0'; 258 | x := 8 - x; 259 | s := ''; 260 | for n := 1 to x do 261 | s := s + ':0'; 262 | s := s + ':'; 263 | Result := replacestring(value, '::', s); 264 | end; 265 | {==============================================================================} 266 | 267 | function StrToIp6(Value: string): TIp6Bytes; 268 | var 269 | IPv6: TIp6Words; 270 | Index: Integer; 271 | n: integer; 272 | b1, b2: byte; 273 | s: string; 274 | x: integer; 275 | begin 276 | for n := 0 to 15 do 277 | Result[n] := 0; 278 | for n := 0 to 7 do 279 | Ipv6[n] := 0; 280 | Index := 0; 281 | Value := ExpandIP6(value); 282 | if value = '' then 283 | exit; 284 | while Value <> '' do 285 | begin 286 | if Index > 7 then 287 | Exit; 288 | s := fetch(value, ':'); 289 | if s = '@' then 290 | break; 291 | if s = '' then 292 | begin 293 | IPv6[Index] := 0; 294 | end 295 | else 296 | begin 297 | x := StrToIntDef('$' + s, -1); 298 | if (x > 65535) or (x < 0) then 299 | Exit; 300 | IPv6[Index] := x; 301 | end; 302 | Inc(Index); 303 | end; 304 | for n := 0 to 7 do 305 | begin 306 | b1 := ipv6[n] div 256; 307 | b2 := ipv6[n] mod 256; 308 | Result[n * 2] := b1; 309 | Result[(n * 2) + 1] := b2; 310 | end; 311 | end; 312 | 313 | {==============================================================================} 314 | //based on routine by the Free Pascal development team 315 | function Ip6ToStr(value: TIp6Bytes): string; 316 | var 317 | i, x: byte; 318 | zr1,zr2: set of byte; 319 | zc1,zc2: byte; 320 | have_skipped: boolean; 321 | ip6w: TIp6words; 322 | begin 323 | zr1 := []; 324 | zr2 := []; 325 | zc1 := 0; 326 | zc2 := 0; 327 | for i := 0 to 7 do 328 | begin 329 | x := i * 2; 330 | ip6w[i] := value[x] * 256 + value[x + 1]; 331 | if ip6w[i] = 0 then 332 | begin 333 | include(zr2, i); 334 | inc(zc2); 335 | end 336 | else 337 | begin 338 | if zc1 < zc2 then 339 | begin 340 | zc1 := zc2; 341 | zr1 := zr2; 342 | zc2 := 0; 343 | zr2 := []; 344 | end; 345 | end; 346 | end; 347 | if zc1 < zc2 then 348 | begin 349 | zr1 := zr2; 350 | end; 351 | SetLength(Result, 8*5-1); 352 | SetLength(Result, 0); 353 | have_skipped := false; 354 | for i := 0 to 7 do 355 | begin 356 | if not(i in zr1) then 357 | begin 358 | if have_skipped then 359 | begin 360 | if Result = '' then 361 | Result := '::' 362 | else 363 | Result := Result + ':'; 364 | have_skipped := false; 365 | end; 366 | Result := Result + IntToHex(Ip6w[i], 1) + ':'; 367 | end 368 | else 369 | begin 370 | have_skipped := true; 371 | end; 372 | end; 373 | if have_skipped then 374 | if Result = '' then 375 | Result := '::0' 376 | else 377 | Result := Result + ':'; 378 | 379 | if Result = '' then 380 | Result := '::0'; 381 | if not (7 in zr1) then 382 | SetLength(Result, Length(Result)-1); 383 | Result := LowerCase(result); 384 | end; 385 | 386 | {==============================================================================} 387 | function ReverseIP(Value: AnsiString): AnsiString; 388 | var 389 | x: Integer; 390 | begin 391 | Result := ''; 392 | repeat 393 | x := LastDelimiter('.', Value); 394 | Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); 395 | Delete(Value, x, Length(Value) - x + 1); 396 | until x < 1; 397 | if Length(Result) > 0 then 398 | if Result[1] = '.' then 399 | Delete(Result, 1, 1); 400 | end; 401 | 402 | {==============================================================================} 403 | function ReverseIP6(Value: AnsiString): AnsiString; 404 | var 405 | ip6: TIp6bytes; 406 | n: integer; 407 | x, y: integer; 408 | begin 409 | ip6 := StrToIP6(Value); 410 | x := ip6[15] div 16; 411 | y := ip6[15] mod 16; 412 | Result := IntToHex(y, 1) + '.' + IntToHex(x, 1); 413 | for n := 14 downto 0 do 414 | begin 415 | x := ip6[n] div 16; 416 | y := ip6[n] mod 16; 417 | Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1); 418 | end; 419 | end; 420 | 421 | {==============================================================================} 422 | end. 423 | -------------------------------------------------------------------------------- /synapse/synautil.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ZiCog/mqtt-free-pascal/4d54b6c2e5e664d76a415d56f6ecdac387ac4f0d/synapse/synautil.pas -------------------------------------------------------------------------------- /synapse/synsock.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 005.002.003 | 3 | |==============================================================================| 4 | | Content: Socket Independent Platform Layer | 5 | |==============================================================================| 6 | | Copyright (c)1999-2013, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2001-2013. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | | Tomas Hajny (OS2 support) | 41 | |==============================================================================| 42 | | History: see HISTORY.HTM from distribution package | 43 | | (Found at URL: http://www.ararat.cz/synapse/) | 44 | |==============================================================================} 45 | 46 | {:@exclude} 47 | 48 | unit synsock; 49 | 50 | {$MINENUMSIZE 4} 51 | 52 | //old Delphi does not have MSWINDOWS define. 53 | {$IFDEF WIN32} 54 | {$IFNDEF MSWINDOWS} 55 | {$DEFINE MSWINDOWS} 56 | {$ENDIF} 57 | {$ENDIF} 58 | 59 | {$IFDEF CIL} 60 | {$I ssdotnet.inc} 61 | {$ELSE} 62 | {$IFDEF MSWINDOWS} 63 | {$I sswin32.inc} 64 | {$ELSE} 65 | {$IFDEF WINCE} 66 | {$I sswin32.inc} //not complete yet! 67 | {$ELSE} 68 | {$IFDEF FPC} 69 | {$IFDEF OS2} 70 | {$I ssos2ws1.inc} 71 | {$ELSE OS2} 72 | {$I ssfpc.inc} 73 | {$ENDIF OS2} 74 | {$ELSE} 75 | {$I sslinux.inc} 76 | {$ENDIF} 77 | {$ENDIF} 78 | {$ENDIF} 79 | {$ENDIF} 80 | {$IFDEF POSIX} 81 | //Posix.SysSocket 82 | {$I ssposix.inc} //experimental! 83 | {$ENDIF} 84 | 85 | end. 86 | 87 | --------------------------------------------------------------------------------