├── .gitignore ├── asn1util.pas ├── blcksock.pas ├── clamsend.pas ├── cryptlib.pas ├── dnssend.pas ├── ftpsend.pas ├── ftptsend.pas ├── httpsend.pas ├── imapsend.pas ├── jedi.inc ├── kylix.inc ├── laz_synapse.pas ├── ldapsend.pas ├── mimeinln.pas ├── mimemess.pas ├── mimepart.pas ├── nntpsend.pas ├── pingsend.pas ├── pop3send.pas ├── slogsend.pas ├── smtpsend.pas ├── snmpsend.pas ├── sntpsend.pas ├── ssdotnet.inc ├── ssfpc.inc ├── ssl_cryptlib.pas ├── ssl_libssh2.pas ├── ssl_openssl.pas ├── ssl_openssl_lib.pas ├── ssl_sbb.pas ├── ssl_streamsec.pas ├── sslinux.inc ├── ssos2ws1.inc ├── ssposix.inc ├── sswin32.inc ├── synachar.pas ├── synacode.pas ├── synacrypt.pas ├── synadbg.pas ├── synafpc.pas ├── synaicnv.pas ├── synaip.pas ├── synamisc.pas ├── synaser.pas ├── synautil.pas ├── synsock.pas ├── tlntsend.pas └── tzutil.pas /.gitignore: -------------------------------------------------------------------------------- 1 | __history/ 2 | *.dcu 3 | *.bak 4 | -------------------------------------------------------------------------------- /asn1util.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 002.001.000 | 3 | |==============================================================================| 4 | | Content: support for ASN.1 BER coding and decoding | 5 | |==============================================================================| 6 | | Copyright (c)1999-2014, 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) 1999-2014 | 37 | | Portions created by Hernan Sanchez are Copyright (c) 2000. | 38 | | All Rights Reserved. | 39 | |==============================================================================| 40 | | Contributor(s): | 41 | | Hernan Sanchez (hernan.sanchez@iname.com) | 42 | |==============================================================================| 43 | | History: see HISTORY.HTM from distribution package | 44 | | (Found at URL: http://www.ararat.cz/synapse/) | 45 | |==============================================================================} 46 | 47 | {: @abstract(Utilities for handling ASN.1 BER encoding) 48 | By this unit you can parse ASN.1 BER encoded data to elements or build back any 49 | elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to 50 | human readable form for easy debugging, too. 51 | 52 | Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL, 53 | ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER, 54 | ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE 55 | 56 | For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class. 57 | } 58 | 59 | {$Q-} 60 | {$H+} 61 | {$IFDEF FPC} 62 | {$MODE DELPHI} 63 | {$ENDIF} 64 | 65 | unit asn1util; 66 | 67 | interface 68 | 69 | uses 70 | SysUtils, Classes, synautil; 71 | 72 | const 73 | ASN1_BOOL = $01; 74 | ASN1_INT = $02; 75 | ASN1_OCTSTR = $04; 76 | ASN1_NULL = $05; 77 | ASN1_OBJID = $06; 78 | ASN1_ENUM = $0a; 79 | ASN1_SEQ = $30; 80 | ASN1_SETOF = $31; 81 | ASN1_IPADDR = $40; 82 | ASN1_COUNTER = $41; 83 | ASN1_GAUGE = $42; 84 | ASN1_TIMETICKS = $43; 85 | ASN1_OPAQUE = $44; 86 | ASN1_COUNTER64 = $46; 87 | 88 | {:Encodes OID item to binary form.} 89 | function ASNEncOIDItem(Value: Int64): AnsiString; 90 | 91 | {:Decodes an OID item of the next element in the "Buffer" from the "Start" 92 | position.} 93 | function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Int64; 94 | 95 | {:Encodes the length of ASN.1 element to binary.} 96 | function ASNEncLen(Len: Integer): AnsiString; 97 | 98 | {:Decodes length of next element in "Buffer" from the "Start" position.} 99 | function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; 100 | 101 | {:Encodes a signed integer to ASN.1 binary} 102 | function ASNEncInt(Value: Int64): AnsiString; 103 | 104 | {:Encodes unsigned integer into ASN.1 binary} 105 | function ASNEncUInt(Value: Integer): AnsiString; 106 | 107 | {:Encodes ASN.1 object to binary form.} 108 | function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; 109 | 110 | {:Beginning with the "Start" position, decode the ASN.1 item of the next element 111 | in "Buffer". Type of item is stored in "ValueType."} 112 | function ASNItem(var Start: Integer; const Buffer: AnsiString; 113 | var ValueType: Integer): AnsiString; 114 | 115 | {:Encodes an MIB OID string to binary form.} 116 | function MibToId(Mib: String): AnsiString; 117 | 118 | {:Decodes MIB OID from binary form to string form.} 119 | function IdToMib(const Id: AnsiString): String; 120 | 121 | {:Encodes an one number from MIB OID to binary form. (used internally from 122 | @link(MibToId))} 123 | function IntMibToStr(const Value: AnsiString): AnsiString; 124 | 125 | {:Convert ASN.1 BER encoded buffer to human readable form for debugging.} 126 | function ASNdump(const Value: AnsiString): AnsiString; 127 | 128 | implementation 129 | 130 | {==============================================================================} 131 | function ASNEncOIDItem(Value: Int64): AnsiString; 132 | var 133 | x: Int64; 134 | xm: Byte; 135 | b: Boolean; 136 | begin 137 | x := Value; 138 | b := False; 139 | Result := ''; 140 | repeat 141 | xm := x mod 128; 142 | x := x div 128; 143 | if b then 144 | xm := xm or $80; 145 | if x > 0 then 146 | b := True; 147 | Result := AnsiChar(xm) + Result; 148 | until x = 0; 149 | end; 150 | 151 | {==============================================================================} 152 | function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Int64; 153 | var 154 | x: Integer; 155 | b: Boolean; 156 | begin 157 | Result := 0; 158 | repeat 159 | Result := Result * 128; 160 | x := Ord(Buffer[Start]); 161 | Inc(Start); 162 | b := x > $7F; 163 | x := x and $7F; 164 | Result := Result + x; 165 | until not b; 166 | end; 167 | 168 | {==============================================================================} 169 | function ASNEncLen(Len: Integer): AnsiString; 170 | var 171 | x, y: Integer; 172 | begin 173 | if Len < $80 then 174 | Result := AnsiChar(Len) 175 | else 176 | begin 177 | x := Len; 178 | Result := ''; 179 | repeat 180 | y := x mod 256; 181 | x := x div 256; 182 | Result := AnsiChar(y) + Result; 183 | until x = 0; 184 | y := Length(Result); 185 | y := y or $80; 186 | Result := AnsiChar(y) + Result; 187 | end; 188 | end; 189 | 190 | {==============================================================================} 191 | function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; 192 | var 193 | x, n: Integer; 194 | begin 195 | x := Ord(Buffer[Start]); 196 | Inc(Start); 197 | if x < $80 then 198 | Result := x 199 | else 200 | begin 201 | Result := 0; 202 | x := x and $7F; 203 | for n := 1 to x do 204 | begin 205 | Result := Result * 256; 206 | x := Ord(Buffer[Start]); 207 | Inc(Start); 208 | Result := Result + x; 209 | end; 210 | end; 211 | end; 212 | 213 | {==============================================================================} 214 | function ASNEncInt(Value: Int64): AnsiString; 215 | var 216 | x: Int64; 217 | y: byte; 218 | neg: Boolean; 219 | begin 220 | neg := Value < 0; 221 | x := Abs(Value); 222 | if neg then 223 | x := x - 1; 224 | Result := ''; 225 | repeat 226 | y := x mod 256; 227 | x := x div 256; 228 | if neg then 229 | y := not y; 230 | Result := AnsiChar(y) + Result; 231 | until x = 0; 232 | if (not neg) and (Result[1] > #$7F) then 233 | Result := #0 + Result; 234 | if (neg) and (Result[1] < #$80) then 235 | Result := #$FF + Result; 236 | end; 237 | 238 | {==============================================================================} 239 | function ASNEncUInt(Value: Integer): AnsiString; 240 | var 241 | x, y: Integer; 242 | neg: Boolean; 243 | begin 244 | neg := Value < 0; 245 | x := Value; 246 | if neg then 247 | x := x and $7FFFFFFF; 248 | Result := ''; 249 | repeat 250 | y := x mod 256; 251 | x := x div 256; 252 | Result := AnsiChar(y) + Result; 253 | until x = 0; 254 | if neg then 255 | Result[1] := AnsiChar(Ord(Result[1]) or $80); 256 | end; 257 | 258 | {==============================================================================} 259 | function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; 260 | begin 261 | Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data; 262 | end; 263 | 264 | {==============================================================================} 265 | function ASNItem(var Start: Integer; const Buffer: AnsiString; 266 | var ValueType: Integer): AnsiString; 267 | var 268 | ASNType: Integer; 269 | ASNSize: Integer; 270 | y: int64; 271 | n: Integer; 272 | x: byte; 273 | s: AnsiString; 274 | c: AnsiChar; 275 | neg: Boolean; 276 | l: Integer; 277 | begin 278 | Result := ''; 279 | ValueType := ASN1_NULL; 280 | l := Length(Buffer); 281 | if l < (Start + 1) then 282 | Exit; 283 | ASNType := Ord(Buffer[Start]); 284 | ValueType := ASNType; 285 | Inc(Start); 286 | ASNSize := ASNDecLen(Start, Buffer); 287 | if (Start + ASNSize - 1) > l then 288 | Exit; 289 | if (ASNType and $20) > 0 then 290 | // Result := '$' + IntToHex(ASNType, 2) 291 | Result := Copy(Buffer, Start, ASNSize) 292 | else 293 | case ASNType of 294 | ASN1_INT, ASN1_ENUM, ASN1_BOOL: 295 | begin 296 | y := 0; 297 | neg := False; 298 | for n := 1 to ASNSize do 299 | begin 300 | x := Ord(Buffer[Start]); 301 | if (n = 1) and (x > $7F) then 302 | neg := True; 303 | if neg then 304 | x := not x; 305 | y := y * 256 + x; 306 | Inc(Start); 307 | end; 308 | if neg then 309 | y := -(y + 1); 310 | Result := IntToStr(y); 311 | end; 312 | ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS, ASN1_COUNTER64: 313 | begin 314 | y := 0; 315 | for n := 1 to ASNSize do 316 | begin 317 | y := y * 256 + Ord(Buffer[Start]); 318 | Inc(Start); 319 | end; 320 | Result := IntToStr(y); 321 | end; 322 | ASN1_OCTSTR, ASN1_OPAQUE: 323 | begin 324 | for n := 1 to ASNSize do 325 | begin 326 | c := AnsiChar(Buffer[Start]); 327 | Inc(Start); 328 | s := s + c; 329 | end; 330 | Result := s; 331 | end; 332 | ASN1_OBJID: 333 | begin 334 | for n := 1 to ASNSize do 335 | begin 336 | c := AnsiChar(Buffer[Start]); 337 | Inc(Start); 338 | s := s + c; 339 | end; 340 | Result := IdToMib(s); 341 | end; 342 | ASN1_IPADDR: 343 | begin 344 | s := ''; 345 | for n := 1 to ASNSize do 346 | begin 347 | if (n <> 1) then 348 | s := s + '.'; 349 | y := Ord(Buffer[Start]); 350 | Inc(Start); 351 | s := s + IntToStr(y); 352 | end; 353 | Result := s; 354 | end; 355 | ASN1_NULL: 356 | begin 357 | Result := ''; 358 | Start := Start + ASNSize; 359 | end; 360 | else // unknown 361 | begin 362 | for n := 1 to ASNSize do 363 | begin 364 | c := AnsiChar(Buffer[Start]); 365 | Inc(Start); 366 | s := s + c; 367 | end; 368 | Result := s; 369 | end; 370 | end; 371 | end; 372 | 373 | {==============================================================================} 374 | function MibToId(Mib: String): AnsiString; 375 | var 376 | x: Integer; 377 | 378 | function WalkInt(var s: String): Integer; 379 | var 380 | x: Integer; 381 | t: AnsiString; 382 | begin 383 | x := Pos('.', s); 384 | if x < 1 then 385 | begin 386 | t := s; 387 | s := ''; 388 | end 389 | else 390 | begin 391 | t := Copy(s, 1, x - 1); 392 | s := Copy(s, x + 1, Length(s) - x); 393 | end; 394 | Result := StrToIntDef(t, 0); 395 | end; 396 | 397 | begin 398 | Result := ''; 399 | x := WalkInt(Mib); 400 | x := x * 40 + WalkInt(Mib); 401 | Result := ASNEncOIDItem(x); 402 | while Mib <> '' do 403 | begin 404 | x := WalkInt(Mib); 405 | Result := Result + ASNEncOIDItem(x); 406 | end; 407 | end; 408 | 409 | {==============================================================================} 410 | function IdToMib(const Id: AnsiString): String; 411 | var 412 | x, y, n: Integer; 413 | begin 414 | Result := ''; 415 | n := 1; 416 | while Length(Id) + 1 > n do 417 | begin 418 | x := ASNDecOIDItem(n, Id); 419 | if (n - 1) = 1 then 420 | begin 421 | y := x div 40; 422 | x := x mod 40; 423 | Result := IntToStr(y); 424 | end; 425 | Result := Result + '.' + IntToStr(x); 426 | end; 427 | end; 428 | 429 | {==============================================================================} 430 | function IntMibToStr(const Value: AnsiString): AnsiString; 431 | var 432 | n, y: Integer; 433 | begin 434 | y := 0; 435 | for n := 1 to Length(Value) - 1 do 436 | y := y * 256 + Ord(Value[n]); 437 | Result := IntToStr(y); 438 | end; 439 | 440 | {==============================================================================} 441 | function ASNdump(const Value: AnsiString): AnsiString; 442 | var 443 | i, at, x, n: integer; 444 | s, indent: AnsiString; 445 | il: TStringList; 446 | begin 447 | il := TStringList.Create; 448 | try 449 | Result := ''; 450 | i := 1; 451 | indent := ''; 452 | while i < Length(Value) do 453 | begin 454 | for n := il.Count - 1 downto 0 do 455 | begin 456 | x := StrToIntDef(il[n], 0); 457 | if x <= i then 458 | begin 459 | il.Delete(n); 460 | Delete(indent, 1, 2); 461 | end; 462 | end; 463 | s := ASNItem(i, Value, at); 464 | Result := Result + indent + '$' + IntToHex(at, 2); 465 | if (at and $20) > 0 then 466 | begin 467 | x := Length(s); 468 | Result := Result + ' constructed: length ' + IntToStr(x); 469 | indent := indent + ' '; 470 | il.Add(IntToStr(x + i - 1)); 471 | end 472 | else 473 | begin 474 | case at of 475 | ASN1_BOOL: 476 | Result := Result + ' BOOL: '; 477 | ASN1_INT: 478 | Result := Result + ' INT: '; 479 | ASN1_ENUM: 480 | Result := Result + ' ENUM: '; 481 | ASN1_COUNTER: 482 | Result := Result + ' COUNTER: '; 483 | ASN1_GAUGE: 484 | Result := Result + ' GAUGE: '; 485 | ASN1_TIMETICKS: 486 | Result := Result + ' TIMETICKS: '; 487 | ASN1_OCTSTR: 488 | Result := Result + ' OCTSTR: '; 489 | ASN1_OPAQUE: 490 | Result := Result + ' OPAQUE: '; 491 | ASN1_OBJID: 492 | Result := Result + ' OBJID: '; 493 | ASN1_IPADDR: 494 | Result := Result + ' IPADDR: '; 495 | ASN1_NULL: 496 | Result := Result + ' NULL: '; 497 | ASN1_COUNTER64: 498 | Result := Result + ' COUNTER64: '; 499 | else // other 500 | Result := Result + ' unknown: '; 501 | end; 502 | if IsBinaryString(s) then 503 | s := DumpExStr(s); 504 | Result := Result + s; 505 | end; 506 | Result := Result + #$0d + #$0a; 507 | end; 508 | finally 509 | il.Free; 510 | end; 511 | end; 512 | 513 | {==============================================================================} 514 | 515 | end. 516 | -------------------------------------------------------------------------------- /clamsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.001 | 3 | |==============================================================================| 4 | | Content: ClamAV-daemon client | 5 | |==============================================================================| 6 | | Copyright (c)2005-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)2005-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( ClamAV-daemon client) 46 | 47 | This unit is capable to do antivirus scan of your data by TCP channel to ClamD 48 | daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net) 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$Q-} 55 | {$H+} 56 | 57 | unit clamsend; 58 | 59 | interface 60 | 61 | uses 62 | SysUtils, Classes, 63 | synsock, blcksock, synautil; 64 | 65 | const 66 | cClamProtocol = '3310'; 67 | 68 | type 69 | 70 | {:@abstract(Implementation of ClamAV-daemon client protocol) 71 | By this class you can scan any your data by ClamAV opensource antivirus. 72 | 73 | This class can connect to ClamD by TCP channel, send your data to ClamD 74 | and read result.} 75 | TClamSend = class(TSynaClient) 76 | private 77 | FSock: TTCPBlockSocket; 78 | FDSock: TTCPBlockSocket; 79 | FSession: boolean; 80 | function Login: boolean; virtual; 81 | function Logout: Boolean; virtual; 82 | function OpenStream: Boolean; virtual; 83 | public 84 | constructor Create; 85 | destructor Destroy; override; 86 | 87 | {:Call any command to ClamD. Used internally by other methods.} 88 | function DoCommand(const Value: AnsiString): AnsiString; virtual; 89 | 90 | {:Return ClamAV version and version of loaded databases.} 91 | function GetVersion: AnsiString; virtual; 92 | 93 | {:Scan content of TStrings.} 94 | function ScanStrings(const Value: TStrings): AnsiString; virtual; 95 | 96 | {:Scan content of TStream.} 97 | function ScanStream(const Value: TStream): AnsiString; virtual; 98 | 99 | {:Scan content of TStrings by new 0.95 API.} 100 | function ScanStrings2(const Value: TStrings): AnsiString; virtual; 101 | 102 | {:Scan content of TStream by new 0.95 API.} 103 | function ScanStream2(const Value: TStream): AnsiString; virtual; 104 | published 105 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 106 | property Sock: TTCPBlockSocket read FSock; 107 | 108 | {:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.} 109 | property DSock: TTCPBlockSocket read FDSock; 110 | 111 | {:Can turn-on session mode of communication with ClamD. Default is @false, 112 | because ClamAV developers design their TCP code very badly and session mode 113 | is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs 114 | and this mode will be possible in future.} 115 | property Session: boolean read FSession write FSession; 116 | end; 117 | 118 | implementation 119 | 120 | constructor TClamSend.Create; 121 | begin 122 | inherited Create; 123 | FSock := TTCPBlockSocket.Create; 124 | FSock.Owner := self; 125 | FDSock := TTCPBlockSocket.Create; 126 | FDSock.Owner := self; 127 | FTimeout := 60000; 128 | FTargetPort := cClamProtocol; 129 | FSession := false; 130 | end; 131 | 132 | destructor TClamSend.Destroy; 133 | begin 134 | Logout; 135 | FDSock.Free; 136 | FSock.Free; 137 | inherited Destroy; 138 | end; 139 | 140 | function TClamSend.DoCommand(const Value: AnsiString): AnsiString; 141 | begin 142 | Result := ''; 143 | if not FSession then 144 | FSock.CloseSocket 145 | else 146 | FSock.SendString(Value + LF); 147 | if not FSession or (FSock.LastError <> 0) then 148 | begin 149 | if Login then 150 | FSock.SendString(Value + LF) 151 | else 152 | Exit; 153 | end; 154 | Result := FSock.RecvTerminated(FTimeout, LF); 155 | end; 156 | 157 | function TClamSend.Login: boolean; 158 | begin 159 | Result := False; 160 | Sock.CloseSocket; 161 | FSock.Bind(FIPInterface, cAnyPort); 162 | if FSock.LastError <> 0 then 163 | Exit; 164 | FSock.Connect(FTargetHost, FTargetPort); 165 | if FSock.LastError <> 0 then 166 | Exit; 167 | if FSession then 168 | FSock.SendString('SESSION' + LF); 169 | Result := FSock.LastError = 0; 170 | end; 171 | 172 | function TClamSend.Logout: Boolean; 173 | begin 174 | FSock.SendString('END' + LF); 175 | Result := FSock.LastError = 0; 176 | FSock.CloseSocket; 177 | end; 178 | 179 | function TClamSend.GetVersion: AnsiString; 180 | begin 181 | Result := DoCommand('nVERSION'); 182 | end; 183 | 184 | function TClamSend.OpenStream: Boolean; 185 | var 186 | S: AnsiString; 187 | begin 188 | Result := False; 189 | s := DoCommand('nSTREAM'); 190 | if (s <> '') and (Copy(s, 1, 4) = 'PORT') then 191 | begin 192 | s := SeparateRight(s, ' '); 193 | FDSock.CloseSocket; 194 | FDSock.Bind(FIPInterface, cAnyPort); 195 | if FDSock.LastError <> 0 then 196 | Exit; 197 | FDSock.Connect(FTargetHost, s); 198 | if FDSock.LastError <> 0 then 199 | Exit; 200 | Result := True; 201 | end; 202 | end; 203 | 204 | function TClamSend.ScanStrings(const Value: TStrings): AnsiString; 205 | begin 206 | Result := ''; 207 | if OpenStream then 208 | begin 209 | DSock.SendString(Value.Text); 210 | DSock.CloseSocket; 211 | Result := FSock.RecvTerminated(FTimeout, LF); 212 | end; 213 | end; 214 | 215 | function TClamSend.ScanStream(const Value: TStream): AnsiString; 216 | begin 217 | Result := ''; 218 | if OpenStream then 219 | begin 220 | DSock.SendStreamRaw(Value); 221 | DSock.CloseSocket; 222 | Result := FSock.RecvTerminated(FTimeout, LF); 223 | end; 224 | end; 225 | 226 | function TClamSend.ScanStrings2(const Value: TStrings): AnsiString; 227 | var 228 | i: integer; 229 | s: AnsiString; 230 | begin 231 | Result := ''; 232 | if not FSession then 233 | FSock.CloseSocket 234 | else 235 | FSock.sendstring('nINSTREAM' + LF); 236 | if not FSession or (FSock.LastError <> 0) then 237 | begin 238 | if Login then 239 | FSock.sendstring('nINSTREAM' + LF) 240 | else 241 | Exit; 242 | end; 243 | s := Value.text; 244 | i := length(s); 245 | FSock.SendString(CodeLongint(i) + s + #0#0#0#0); 246 | Result := FSock.RecvTerminated(FTimeout, LF); 247 | end; 248 | 249 | function TClamSend.ScanStream2(const Value: TStream): AnsiString; 250 | var 251 | i: integer; 252 | begin 253 | Result := ''; 254 | if not FSession then 255 | FSock.CloseSocket 256 | else 257 | FSock.sendstring('nINSTREAM' + LF); 258 | if not FSession or (FSock.LastError <> 0) then 259 | begin 260 | if Login then 261 | FSock.sendstring('nINSTREAM' + LF) 262 | else 263 | Exit; 264 | end; 265 | i := value.Size; 266 | FSock.SendString(CodeLongint(i)); 267 | FSock.SendStreamRaw(Value); 268 | FSock.SendString(#0#0#0#0); 269 | Result := FSock.RecvTerminated(FTimeout, LF); 270 | end; 271 | 272 | end. 273 | -------------------------------------------------------------------------------- /dnssend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 002.007.006 | 3 | |==============================================================================| 4 | | Content: DNS client | 5 | |==============================================================================| 6 | | Copyright (c)1999-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)2000-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 | {: @abstract(DNS client by UDP or TCP) 45 | Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone 46 | transfers too! 47 | 48 | Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$Q-} 55 | {$H+} 56 | 57 | unit dnssend; 58 | 59 | interface 60 | 61 | uses 62 | SysUtils, Classes, 63 | blcksock, synautil, synaip, synsock; 64 | 65 | const 66 | cDnsProtocol = '53'; 67 | 68 | QTYPE_A = 1; 69 | QTYPE_NS = 2; 70 | QTYPE_MD = 3; 71 | QTYPE_MF = 4; 72 | QTYPE_CNAME = 5; 73 | QTYPE_SOA = 6; 74 | QTYPE_MB = 7; 75 | QTYPE_MG = 8; 76 | QTYPE_MR = 9; 77 | QTYPE_NULL = 10; 78 | QTYPE_WKS = 11; // 79 | QTYPE_PTR = 12; 80 | QTYPE_HINFO = 13; 81 | QTYPE_MINFO = 14; 82 | QTYPE_MX = 15; 83 | QTYPE_TXT = 16; 84 | 85 | QTYPE_RP = 17; 86 | QTYPE_AFSDB = 18; 87 | QTYPE_X25 = 19; 88 | QTYPE_ISDN = 20; 89 | QTYPE_RT = 21; 90 | QTYPE_NSAP = 22; 91 | QTYPE_NSAPPTR = 23; 92 | QTYPE_SIG = 24; // RFC-2065 93 | QTYPE_KEY = 25; // RFC-2065 94 | QTYPE_PX = 26; 95 | QTYPE_GPOS = 27; 96 | QTYPE_AAAA = 28; 97 | QTYPE_LOC = 29; // RFC-1876 98 | QTYPE_NXT = 30; // RFC-2065 99 | 100 | QTYPE_SRV = 33; 101 | QTYPE_NAPTR = 35; // RFC-2168 102 | QTYPE_KX = 36; 103 | QTYPE_SPF = 99; 104 | 105 | QTYPE_AXFR = 252; 106 | QTYPE_MAILB = 253; // 107 | QTYPE_MAILA = 254; // 108 | QTYPE_ALL = 255; 109 | 110 | type 111 | {:@abstract(Implementation of DNS protocol by UDP or TCP protocol.) 112 | 113 | Note: Are you missing properties for specify server address and port? Look to 114 | parent @link(TSynaClient) too!} 115 | TDNSSend = class(TSynaClient) 116 | private 117 | FID: Word; 118 | FRCode: Integer; 119 | FBuffer: AnsiString; 120 | FSock: TUDPBlockSocket; 121 | FTCPSock: TTCPBlockSocket; 122 | FUseTCP: Boolean; 123 | FAnswerInfo: TStringList; 124 | FNameserverInfo: TStringList; 125 | FAdditionalInfo: TStringList; 126 | FAuthoritative: Boolean; 127 | FTruncated: Boolean; 128 | function CompressName(const Value: AnsiString): AnsiString; 129 | function CodeHeader: AnsiString; 130 | function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; 131 | function DecodeLabels(var From: Integer): AnsiString; 132 | function DecodeString(var From: Integer): AnsiString; 133 | function DecodeResource(var i: Integer; const Info: TStringList; 134 | QType: Integer): AnsiString; 135 | function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; 136 | function DecodeResponse(const Buf: AnsiString; const Reply: TStrings; 137 | QType: Integer):boolean; 138 | public 139 | constructor Create; 140 | destructor Destroy; override; 141 | 142 | {:Query a DNSHost for QType resources correspond to a name. Supported QType 143 | values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA, 144 | Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO, 145 | Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25, 146 | Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS, 147 | Qtype_KX. 148 | 149 | Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode! 150 | 151 | "Name" is domain name or host name for queried resource. If "name" is 152 | IP address, automatically convert to reverse domain form (.in-addr.arpa). 153 | 154 | If result is @true, Reply contains resource records. One record on one line. 155 | If Resource record have multiple fields, they are stored on line divided by 156 | comma. (example: MX record contains value 'rs.cesnet.cz' with preference 157 | number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address 158 | in resource are converted to string form.} 159 | function DNSQuery(Name: AnsiString; QType: Integer; 160 | const Reply: TStrings): Boolean; 161 | published 162 | 163 | {:Socket object used for UDP operation. Good for seting OnStatus hook, etc.} 164 | property Sock: TUDPBlockSocket read FSock; 165 | 166 | {:Socket object used for TCP operation. Good for seting OnStatus hook, etc.} 167 | property TCPSock: TTCPBlockSocket read FTCPSock; 168 | 169 | {:if @true, then is used TCP protocol instead UDP. It is needed for zone 170 | transfers, etc.} 171 | property UseTCP: Boolean read FUseTCP Write FUseTCP; 172 | 173 | {:After DNS operation contains ResultCode of DNS operation. 174 | Values are: 0-no error, 1-format error, 2-server failure, 3-name error, 175 | 4-not implemented, 5-refused.} 176 | property RCode: Integer read FRCode; 177 | 178 | {:@True, if answer is authoritative.} 179 | property Authoritative: Boolean read FAuthoritative; 180 | 181 | {:@True, if answer is truncated to 512 bytes.} 182 | property Truncated: Boolean read FTRuncated; 183 | 184 | {:Detailed informations from name server reply. One record per line. Record 185 | have comma delimited entries with type number, TTL and data filelds. 186 | This information contains detailed information about query reply.} 187 | property AnswerInfo: TStringList read FAnswerInfo; 188 | 189 | {:Detailed informations from name server reply. One record per line. Record 190 | have comma delimited entries with type number, TTL and data filelds. 191 | This information contains detailed information about nameserver.} 192 | property NameserverInfo: TStringList read FNameserverInfo; 193 | 194 | {:Detailed informations from name server reply. One record per line. Record 195 | have comma delimited entries with type number, TTL and data filelds. 196 | This information contains detailed additional information.} 197 | property AdditionalInfo: TStringList read FAdditionalInfo; 198 | end; 199 | 200 | {:A very useful function, and example of it's use is found in the TDNSSend object. 201 | This function is used to get mail servers for a domain and sort them by 202 | preference numbers. "Servers" contains only the domain names of the mail 203 | servers in the right order (without preference number!). The first domain name 204 | will always be the highest preferenced mail server. Returns boolean @TRUE if 205 | all went well.} 206 | function GetMailServers(const DNSHost, Domain: AnsiString; 207 | const Servers: TStrings): Boolean; 208 | 209 | implementation 210 | 211 | constructor TDNSSend.Create; 212 | begin 213 | inherited Create; 214 | FSock := TUDPBlockSocket.Create; 215 | FSock.Owner := self; 216 | FTCPSock := TTCPBlockSocket.Create; 217 | FTCPSock.Owner := self; 218 | FUseTCP := False; 219 | FTimeout := 10000; 220 | FTargetPort := cDnsProtocol; 221 | FAnswerInfo := TStringList.Create; 222 | FNameserverInfo := TStringList.Create; 223 | FAdditionalInfo := TStringList.Create; 224 | Randomize; 225 | end; 226 | 227 | destructor TDNSSend.Destroy; 228 | begin 229 | FAnswerInfo.Free; 230 | FNameserverInfo.Free; 231 | FAdditionalInfo.Free; 232 | FTCPSock.Free; 233 | FSock.Free; 234 | inherited Destroy; 235 | end; 236 | 237 | function TDNSSend.CompressName(const Value: AnsiString): AnsiString; 238 | var 239 | n: Integer; 240 | s: AnsiString; 241 | begin 242 | Result := ''; 243 | if Value = '' then 244 | Result := #0 245 | else 246 | begin 247 | s := ''; 248 | for n := 1 to Length(Value) do 249 | if Value[n] = '.' then 250 | begin 251 | Result := Result + AnsiChar(Length(s)) + s; 252 | s := ''; 253 | end 254 | else 255 | s := s + Value[n]; 256 | if s <> '' then 257 | Result := Result + AnsiChar(Length(s)) + s; 258 | Result := Result + #0; 259 | end; 260 | end; 261 | 262 | function TDNSSend.CodeHeader: AnsiString; 263 | begin 264 | FID := Random(32767); 265 | Result := CodeInt(FID); // ID 266 | Result := Result + CodeInt($0100); // flags 267 | Result := Result + CodeInt(1); // QDCount 268 | Result := Result + CodeInt(0); // ANCount 269 | Result := Result + CodeInt(0); // NSCount 270 | Result := Result + CodeInt(0); // ARCount 271 | end; 272 | 273 | function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; 274 | begin 275 | Result := CompressName(Name); 276 | Result := Result + CodeInt(QType); 277 | Result := Result + CodeInt(1); // Type INTERNET 278 | end; 279 | 280 | function TDNSSend.DecodeString(var From: Integer): AnsiString; 281 | var 282 | Len: integer; 283 | begin 284 | Len := Ord(FBuffer[From]); 285 | Inc(From); 286 | Result := Copy(FBuffer, From, Len); 287 | Inc(From, Len); 288 | end; 289 | 290 | function TDNSSend.DecodeLabels(var From: Integer): AnsiString; 291 | var 292 | l, f: Integer; 293 | begin 294 | Result := ''; 295 | while True do 296 | begin 297 | if From >= Length(FBuffer) then 298 | Break; 299 | l := Ord(FBuffer[From]); 300 | Inc(From); 301 | if l = 0 then 302 | Break; 303 | if Result <> '' then 304 | Result := Result + '.'; 305 | if (l and $C0) = $C0 then 306 | begin 307 | f := l and $3F; 308 | f := f * 256 + Ord(FBuffer[From]) + 1; 309 | Inc(From); 310 | Result := Result + DecodeLabels(f); 311 | Break; 312 | end 313 | else 314 | begin 315 | Result := Result + Copy(FBuffer, From, l); 316 | Inc(From, l); 317 | end; 318 | end; 319 | end; 320 | 321 | function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList; 322 | QType: Integer): AnsiString; 323 | var 324 | Rname: AnsiString; 325 | RType, Len, j, x, y, z, n: Integer; 326 | R: AnsiString; 327 | t1, t2, ttl: integer; 328 | ip6: TIp6bytes; 329 | begin 330 | Result := ''; 331 | R := ''; 332 | Rname := DecodeLabels(i); 333 | RType := DecodeInt(FBuffer, i); 334 | Inc(i, 4); 335 | t1 := DecodeInt(FBuffer, i); 336 | Inc(i, 2); 337 | t2 := DecodeInt(FBuffer, i); 338 | Inc(i, 2); 339 | ttl := t1 * 65536 + t2; 340 | Len := DecodeInt(FBuffer, i); 341 | Inc(i, 2); // i point to begin of data 342 | j := i; 343 | i := i + len; // i point to next record 344 | if Length(FBuffer) >= (i - 1) then 345 | case RType of 346 | QTYPE_A: 347 | begin 348 | R := IntToStr(Ord(FBuffer[j])); 349 | Inc(j); 350 | R := R + '.' + IntToStr(Ord(FBuffer[j])); 351 | Inc(j); 352 | R := R + '.' + IntToStr(Ord(FBuffer[j])); 353 | Inc(j); 354 | R := R + '.' + IntToStr(Ord(FBuffer[j])); 355 | end; 356 | QTYPE_AAAA: 357 | begin 358 | for n := 0 to 15 do 359 | ip6[n] := ord(FBuffer[j + n]); 360 | R := IP6ToStr(ip6); 361 | end; 362 | QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB, 363 | QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP, 364 | QTYPE_NSAPPTR: 365 | R := DecodeLabels(j); 366 | QTYPE_SOA: 367 | begin 368 | R := DecodeLabels(j); 369 | R := R + ',' + DecodeLabels(j); 370 | for n := 1 to 5 do 371 | begin 372 | x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2); 373 | Inc(j, 4); 374 | R := R + ',' + IntToStr(x); 375 | end; 376 | end; 377 | QTYPE_NULL: 378 | begin 379 | end; 380 | QTYPE_WKS: 381 | begin 382 | end; 383 | QTYPE_HINFO: 384 | begin 385 | R := DecodeString(j); 386 | R := R + ',' + DecodeString(j); 387 | end; 388 | QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN: 389 | begin 390 | R := DecodeLabels(j); 391 | R := R + ',' + DecodeLabels(j); 392 | end; 393 | QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX: 394 | begin 395 | x := DecodeInt(FBuffer, j); 396 | Inc(j, 2); 397 | R := IntToStr(x); 398 | R := R + ',' + DecodeLabels(j); 399 | end; 400 | QTYPE_TXT, QTYPE_SPF: 401 | begin 402 | R := ''; 403 | while j < i do 404 | R := R + DecodeString(j); 405 | end; 406 | QTYPE_GPOS: 407 | begin 408 | R := DecodeLabels(j); 409 | R := R + ',' + DecodeLabels(j); 410 | R := R + ',' + DecodeLabels(j); 411 | end; 412 | QTYPE_PX: 413 | begin 414 | x := DecodeInt(FBuffer, j); 415 | Inc(j, 2); 416 | R := IntToStr(x); 417 | R := R + ',' + DecodeLabels(j); 418 | R := R + ',' + DecodeLabels(j); 419 | end; 420 | QTYPE_SRV: 421 | // Author: Dan 422 | begin 423 | x := DecodeInt(FBuffer, j); 424 | Inc(j, 2); 425 | y := DecodeInt(FBuffer, j); 426 | Inc(j, 2); 427 | z := DecodeInt(FBuffer, j); 428 | Inc(j, 2); 429 | R := IntToStr(x); // Priority 430 | R := R + ',' + IntToStr(y); // Weight 431 | R := R + ',' + IntToStr(z); // Port 432 | R := R + ',' + DecodeLabels(j); // Server DNS Name 433 | end; 434 | end; 435 | if R <> '' then 436 | Info.Add(string(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R)); // cast 437 | //TODO: ansi 438 | if QType = RType then 439 | Result := R; 440 | end; 441 | 442 | function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; 443 | var 444 | l: integer; 445 | begin 446 | Result := ''; 447 | l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout); 448 | if l > 0 then 449 | Result := WorkSock.RecvBufferStr(l, FTimeout); 450 | end; 451 | 452 | function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings; 453 | QType: Integer):boolean; 454 | var 455 | n, i: Integer; 456 | flag, qdcount, ancount, nscount, arcount: Integer; 457 | s: AnsiString; 458 | begin 459 | Result := False; 460 | Reply.Clear; 461 | FAnswerInfo.Clear; 462 | FNameserverInfo.Clear; 463 | FAdditionalInfo.Clear; 464 | FAuthoritative := False; 465 | if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then 466 | begin 467 | Result := True; 468 | flag := DecodeInt(Buf, 3); 469 | FRCode := Flag and $000F; 470 | FAuthoritative := (Flag and $0400) > 0; 471 | FTruncated := (Flag and $0200) > 0; 472 | if FRCode = 0 then 473 | begin 474 | qdcount := DecodeInt(Buf, 5); 475 | ancount := DecodeInt(Buf, 7); 476 | nscount := DecodeInt(Buf, 9); 477 | arcount := DecodeInt(Buf, 11); 478 | i := 13; //begin of body 479 | if (qdcount > 0) and (Length(Buf) > i) then //skip questions 480 | for n := 1 to qdcount do 481 | begin 482 | while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do 483 | Inc(i); 484 | Inc(i, 5); 485 | end; 486 | if (ancount > 0) and (Length(Buf) > i) then // decode reply 487 | for n := 1 to ancount do 488 | begin 489 | s := DecodeResource(i, FAnswerInfo, QType); 490 | if s <> '' then 491 | Reply.Add(string(s)); // cast 492 | //TODO: ansi 493 | end; 494 | if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info 495 | for n := 1 to nscount do 496 | DecodeResource(i, FNameserverInfo, QType); 497 | if (arcount > 0) and (Length(Buf) > i) then // decode additional info 498 | for n := 1 to arcount do 499 | DecodeResource(i, FAdditionalInfo, QType); 500 | end; 501 | end; 502 | end; 503 | 504 | function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer; 505 | const Reply: TStrings): Boolean; 506 | var 507 | WorkSock: TBlockSocket; 508 | t: TStringList; 509 | b: boolean; 510 | begin 511 | Result := False; 512 | if IsIP(Name) then 513 | Name := ReverseIP(Name) + '.in-addr.arpa'; 514 | if IsIP6(Name) then 515 | Name := ReverseIP6(Name) + '.ip6.arpa'; 516 | FBuffer := CodeHeader + CodeQuery(Name, QType); 517 | if FUseTCP then 518 | WorkSock := FTCPSock 519 | else 520 | WorkSock := FSock; 521 | WorkSock.Bind(FIPInterface, cAnyPort); 522 | WorkSock.Connect(FTargetHost, FTargetPort); 523 | if FUseTCP then 524 | FBuffer := Codeint(length(FBuffer)) + FBuffer; 525 | WorkSock.SendString(FBuffer); 526 | if FUseTCP then 527 | FBuffer := RecvTCPResponse(WorkSock) 528 | else 529 | FBuffer := WorkSock.RecvPacket(FTimeout); 530 | if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer 531 | begin 532 | t := TStringList.Create; 533 | try 534 | repeat 535 | b := DecodeResponse(FBuffer, Reply, QType); 536 | if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer 537 | b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]); 538 | if b then 539 | begin 540 | t.AddStrings(AnswerInfo); 541 | FBuffer := RecvTCPResponse(WorkSock); 542 | if FBuffer = '' then 543 | Break; 544 | if WorkSock.LastError <> 0 then 545 | Break; 546 | end; 547 | until not b; 548 | Reply.Assign(t); 549 | Result := True; 550 | finally 551 | t.free; 552 | end; 553 | end 554 | else //normal query 555 | if WorkSock.LastError = 0 then 556 | Result := DecodeResponse(FBuffer, Reply, QType); 557 | end; 558 | 559 | {==============================================================================} 560 | 561 | function GetMailServers(const DNSHost, Domain: AnsiString; 562 | const Servers: TStrings): Boolean; 563 | var 564 | DNS: TDNSSend; 565 | t: TStringList; 566 | n, m, x: Integer; 567 | begin 568 | Result := False; 569 | Servers.Clear; 570 | t := TStringList.Create; 571 | DNS := TDNSSend.Create; 572 | try 573 | DNS.TargetHost := DNSHost; 574 | if DNS.DNSQuery(Domain, QType_MX, t) then 575 | begin 576 | { normalize preference number to 5 digits } 577 | for n := 0 to t.Count - 1 do 578 | begin 579 | //TODO: ansi 580 | x := Pos(',', AnsiString(t[n])); // cast 581 | if x > 0 then 582 | for m := 1 to 6 - x do 583 | t[n] := '0' + t[n]; 584 | end; 585 | { sort server list } 586 | t.Sorted := True; 587 | { result is sorted list without preference numbers } 588 | for n := 0 to t.Count - 1 do 589 | begin 590 | //TODO: ansi 591 | x := Pos(',', AnsiString(t[n])); // cast 592 | Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x)); 593 | end; 594 | Result := True; 595 | end; 596 | finally 597 | DNS.Free; 598 | t.Free; 599 | end; 600 | end; 601 | 602 | end. 603 | -------------------------------------------------------------------------------- /ftptsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.001 | 3 | |==============================================================================| 4 | | Content: Trivial FTP (TFTP) client and server | 5 | |==============================================================================| 6 | | Copyright (c)1999-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)2003-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(TFTP client and server protocol) 46 | 47 | Used RFC: RFC-1350 48 | } 49 | 50 | {$IFDEF FPC} 51 | {$MODE DELPHI} 52 | {$ENDIF} 53 | {$Q-} 54 | {$H+} 55 | 56 | unit ftptsend; 57 | 58 | interface 59 | 60 | uses 61 | SysUtils, Classes, 62 | blcksock, synautil; 63 | 64 | const 65 | cTFTPProtocol = '69'; 66 | 67 | cTFTP_RRQ = word(1); 68 | cTFTP_WRQ = word(2); 69 | cTFTP_DTA = word(3); 70 | cTFTP_ACK = word(4); 71 | cTFTP_ERR = word(5); 72 | 73 | type 74 | {:@abstract(Implementation of TFTP client and server) 75 | Note: Are you missing properties for specify server address and port? Look to 76 | parent @link(TSynaClient) too!} 77 | TTFTPSend = class(TSynaClient) 78 | private 79 | FSock: TUDPBlockSocket; 80 | FErrorCode: integer; 81 | FErrorString: string; 82 | FData: TMemoryStream; 83 | FRequestIP: string; 84 | FRequestPort: string; 85 | function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; 86 | function RecvPacket(Serial: word; var Value: string): Boolean; 87 | public 88 | constructor Create; 89 | destructor Destroy; override; 90 | 91 | {:Upload @link(data) as file to TFTP server.} 92 | function SendFile(const Filename: string): Boolean; 93 | 94 | {:Download file from TFTP server to @link(data).} 95 | function RecvFile(const Filename: string): Boolean; 96 | 97 | {:Acts as TFTP server and wait for client request. When some request 98 | incoming within Timeout, result is @true and parametres is filled with 99 | information from request. You must handle this request, validate it, and 100 | call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply 101 | to TFTP Client.} 102 | function WaitForRequest(var Req: word; var filename: string): Boolean; 103 | 104 | {:send error to TFTP client, when you acts as TFTP server.} 105 | procedure ReplyError(Error: word; Description: string); 106 | 107 | {:Accept uploaded file from TFTP client to @link(data), when you acts as 108 | TFTP server.} 109 | function ReplyRecv: Boolean; 110 | 111 | {:Accept download request file from TFTP client and send content of 112 | @link(data), when you acts as TFTP server.} 113 | function ReplySend: Boolean; 114 | published 115 | {:Code of TFTP error.} 116 | property ErrorCode: integer read FErrorCode; 117 | 118 | {:Human readable decription of TFTP error. (if is sended by remote side)} 119 | property ErrorString: string read FErrorString; 120 | 121 | {:MemoryStream with datas for sending or receiving} 122 | property Data: TMemoryStream read FData; 123 | 124 | {:Address of TFTP remote side.} 125 | property RequestIP: string read FRequestIP write FRequestIP; 126 | 127 | {:Port of TFTP remote side.} 128 | property RequestPort: string read FRequestPort write FRequestPort; 129 | end; 130 | 131 | implementation 132 | 133 | constructor TTFTPSend.Create; 134 | begin 135 | inherited Create; 136 | FSock := TUDPBlockSocket.Create; 137 | FSock.Owner := self; 138 | FTargetPort := cTFTPProtocol; 139 | FData := TMemoryStream.Create; 140 | FErrorCode := 0; 141 | FErrorString := ''; 142 | end; 143 | 144 | destructor TTFTPSend.Destroy; 145 | begin 146 | FSock.Free; 147 | FData.Free; 148 | inherited Destroy; 149 | end; 150 | 151 | function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; 152 | var 153 | s, sh: string; 154 | begin 155 | FErrorCode := 0; 156 | FErrorString := ''; 157 | Result := false; 158 | if Cmd <> 2 then 159 | s := CodeInt(Cmd) + CodeInt(Serial) + Value 160 | else 161 | s := CodeInt(Cmd) + Value; 162 | FSock.SendString(s); 163 | s := FSock.RecvPacket(FTimeout); 164 | if FSock.LastError = 0 then 165 | if length(s) >= 4 then 166 | begin 167 | sh := CodeInt(4) + CodeInt(Serial); 168 | if Pos(sh, s) = 1 then 169 | Result := True 170 | else 171 | if s[1] = #5 then 172 | begin 173 | FErrorCode := DecodeInt(s, 3); 174 | Delete(s, 1, 4); 175 | FErrorString := SeparateLeft(s, #0); 176 | end; 177 | end; 178 | end; 179 | 180 | function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean; 181 | var 182 | s: string; 183 | ser: word; 184 | begin 185 | FErrorCode := 0; 186 | FErrorString := ''; 187 | Result := False; 188 | Value := ''; 189 | s := FSock.RecvPacket(FTimeout); 190 | if FSock.LastError = 0 then 191 | if length(s) >= 4 then 192 | if DecodeInt(s, 1) = 3 then 193 | begin 194 | ser := DecodeInt(s, 3); 195 | if ser = Serial then 196 | begin 197 | Delete(s, 1, 4); 198 | Value := s; 199 | S := CodeInt(4) + CodeInt(ser); 200 | FSock.SendString(s); 201 | Result := FSock.LastError = 0; 202 | end 203 | else 204 | begin 205 | S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0; 206 | FSock.SendString(s); 207 | end; 208 | end; 209 | if DecodeInt(s, 1) = 5 then 210 | begin 211 | FErrorCode := DecodeInt(s, 3); 212 | Delete(s, 1, 4); 213 | FErrorString := SeparateLeft(s, #0); 214 | end; 215 | end; 216 | 217 | function TTFTPSend.SendFile(const Filename: string): Boolean; 218 | var 219 | s: string; 220 | ser: word; 221 | n, n1, n2: integer; 222 | begin 223 | Result := False; 224 | FErrorCode := 0; 225 | FErrorString := ''; 226 | FSock.CloseSocket; 227 | FSock.Connect(FTargetHost, FTargetPort); 228 | try 229 | if FSock.LastError = 0 then 230 | begin 231 | s := Filename + #0 + 'octet' + #0; 232 | if not Sendpacket(2, 0, s) then 233 | Exit; 234 | ser := 1; 235 | FData.Position := 0; 236 | n1 := FData.Size div 512; 237 | n2 := FData.Size mod 512; 238 | for n := 1 to n1 do 239 | begin 240 | s := ReadStrFromStream(FData, 512); 241 | // SetLength(s, 512); 242 | // FData.Read(pointer(s)^, 512); 243 | if not Sendpacket(3, ser, s) then 244 | Exit; 245 | inc(ser); 246 | end; 247 | s := ReadStrFromStream(FData, n2); 248 | // SetLength(s, n2); 249 | // FData.Read(pointer(s)^, n2); 250 | if not Sendpacket(3, ser, s) then 251 | Exit; 252 | Result := True; 253 | end; 254 | finally 255 | FSock.CloseSocket; 256 | end; 257 | end; 258 | 259 | function TTFTPSend.RecvFile(const Filename: string): Boolean; 260 | var 261 | s: string; 262 | ser: word; 263 | begin 264 | Result := False; 265 | FErrorCode := 0; 266 | FErrorString := ''; 267 | FSock.CloseSocket; 268 | FSock.Connect(FTargetHost, FTargetPort); 269 | try 270 | if FSock.LastError = 0 then 271 | begin 272 | s := CodeInt(1) + Filename + #0 + 'octet' + #0; 273 | FSock.SendString(s); 274 | if FSock.LastError <> 0 then 275 | Exit; 276 | FData.Clear; 277 | ser := 1; 278 | repeat 279 | if not RecvPacket(ser, s) then 280 | Exit; 281 | inc(ser); 282 | WriteStrToStream(FData, s); 283 | // FData.Write(pointer(s)^, length(s)); 284 | until length(s) <> 512; 285 | FData.Position := 0; 286 | Result := true; 287 | end; 288 | finally 289 | FSock.CloseSocket; 290 | end; 291 | end; 292 | 293 | function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean; 294 | var 295 | s: string; 296 | begin 297 | Result := False; 298 | FErrorCode := 0; 299 | FErrorString := ''; 300 | FSock.CloseSocket; 301 | FSock.Bind('0.0.0.0', FTargetPort); 302 | if FSock.LastError = 0 then 303 | begin 304 | s := FSock.RecvPacket(FTimeout); 305 | if FSock.LastError = 0 then 306 | if Length(s) >= 4 then 307 | begin 308 | FRequestIP := FSock.GetRemoteSinIP; 309 | FRequestPort := IntToStr(FSock.GetRemoteSinPort); 310 | Req := DecodeInt(s, 1); 311 | delete(s, 1, 2); 312 | filename := Trim(SeparateLeft(s, #0)); 313 | s := SeparateRight(s, #0); 314 | s := SeparateLeft(s, #0); 315 | Result := lowercase(trim(s)) = 'octet'; 316 | end; 317 | end; 318 | end; 319 | 320 | procedure TTFTPSend.ReplyError(Error: word; Description: string); 321 | var 322 | s: string; 323 | begin 324 | FSock.CloseSocket; 325 | FSock.Connect(FRequestIP, FRequestPort); 326 | s := CodeInt(5) + CodeInt(Error) + Description + #0; 327 | FSock.SendString(s); 328 | FSock.CloseSocket; 329 | end; 330 | 331 | function TTFTPSend.ReplyRecv: Boolean; 332 | var 333 | s: string; 334 | ser: integer; 335 | begin 336 | Result := False; 337 | FErrorCode := 0; 338 | FErrorString := ''; 339 | FSock.CloseSocket; 340 | FSock.Connect(FRequestIP, FRequestPort); 341 | try 342 | s := CodeInt(4) + CodeInt(0); 343 | FSock.SendString(s); 344 | FData.Clear; 345 | ser := 1; 346 | repeat 347 | if not RecvPacket(ser, s) then 348 | Exit; 349 | inc(ser); 350 | WriteStrToStream(FData, s); 351 | // FData.Write(pointer(s)^, length(s)); 352 | until length(s) <> 512; 353 | FData.Position := 0; 354 | Result := true; 355 | finally 356 | FSock.CloseSocket; 357 | end; 358 | end; 359 | 360 | function TTFTPSend.ReplySend: Boolean; 361 | var 362 | s: string; 363 | ser: word; 364 | n, n1, n2: integer; 365 | begin 366 | Result := False; 367 | FErrorCode := 0; 368 | FErrorString := ''; 369 | FSock.CloseSocket; 370 | FSock.Connect(FRequestIP, FRequestPort); 371 | try 372 | ser := 1; 373 | FData.Position := 0; 374 | n1 := FData.Size div 512; 375 | n2 := FData.Size mod 512; 376 | for n := 1 to n1 do 377 | begin 378 | s := ReadStrFromStream(FData, 512); 379 | // SetLength(s, 512); 380 | // FData.Read(pointer(s)^, 512); 381 | if not Sendpacket(3, ser, s) then 382 | Exit; 383 | inc(ser); 384 | end; 385 | s := ReadStrFromStream(FData, n2); 386 | // SetLength(s, n2); 387 | // FData.Read(pointer(s)^, n2); 388 | if not Sendpacket(3, ser, s) then 389 | Exit; 390 | Result := True; 391 | finally 392 | FSock.CloseSocket; 393 | end; 394 | end; 395 | 396 | {==============================================================================} 397 | 398 | end. 399 | -------------------------------------------------------------------------------- /kylix.inc: -------------------------------------------------------------------------------- 1 | // 2 | // This is FPC-incompatible code and was excluded from jedi.inc for this reason 3 | // 4 | // Kylix 3/C++ for some reason evaluates CompilerVersion comparisons to False, 5 | // if the constant to compare with is a floating point value - weird. 6 | // The "+" sign prevents Kylix/Delphi from issueing a warning about comparing 7 | // signed and unsigned values. 8 | // 9 | {$IF not Declared(CompilerVersion)} 10 | {$DEFINE KYLIX1} 11 | {$DEFINE COMPILER6} 12 | {$DEFINE DELPHICOMPILER6} 13 | {$DEFINE RTL140_UP} 14 | {$ELSEIF Declared(CompilerVersion) and (CompilerVersion > +14)} 15 | {$DEFINE KYLIX2} 16 | {$DEFINE COMPILER6} 17 | {$DEFINE DELPHICOMPILER6} 18 | {$DEFINE RTL142_UP} 19 | {$ELSEIF Declared(CompilerVersion) and (CompilerVersion < +15)} 20 | {$DEFINE KYLIX3} 21 | {$DEFINE COMPILER6} 22 | {$IFNDEF BCB} 23 | {$DEFINE DELPHICOMPILER6} 24 | {$ENDIF} 25 | {$DEFINE RTL145_UP} 26 | {$ELSE} 27 | Add new Kylix version 28 | {$IFEND} 29 | 30 | 31 | -------------------------------------------------------------------------------- /laz_synapse.pas: -------------------------------------------------------------------------------- 1 | { This file was automatically created by Lazarus. Do not edit! 2 | This source is only used to compile and install the package. 3 | } 4 | 5 | unit laz_synapse; 6 | 7 | interface 8 | 9 | uses 10 | asn1util, blcksock, clamsend, dnssend, ftpsend, ftptsend, httpsend, 11 | imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend, 12 | pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode, 13 | synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil, 14 | synsock, tlntsend; 15 | 16 | implementation 17 | 18 | end. 19 | -------------------------------------------------------------------------------- /mimeinln.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.011 | 3 | |==============================================================================| 4 | | Content: Inline MIME support procedures and functions | 5 | |==============================================================================| 6 | | Copyright (c)1999-2006, 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-2006. | 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(Utilities for inline MIME) 46 | Support for Inline MIME encoding and decoding. 47 | 48 | Used RFC: RFC-2047, RFC-2231 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$H+} 55 | 56 | unit mimeinln; 57 | 58 | interface 59 | 60 | uses 61 | SysUtils, Classes, 62 | synachar, synacode, synautil; 63 | 64 | {:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".} 65 | function InlineDecode(const Value: string; CP: TMimeChar): string; 66 | 67 | {:Encodes string to MIME inline encoding. The source characterset is "CP", and 68 | the target charset is "MimeP".} 69 | function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; 70 | 71 | {:Returns @true, if "Value" contains characters needed for inline coding.} 72 | function NeedInline(const Value: AnsiString): boolean; 73 | 74 | {:Inline mime encoding similar to @link(InlineEncode), but you can specify 75 | source charset, and the target characterset is automatically assigned.} 76 | function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; 77 | 78 | {:Inline MIME encoding similar to @link(InlineEncode), but the source charset 79 | is automatically set to the system default charset, and the target charset is 80 | automatically assigned from set of allowed encoding for MIME.} 81 | function InlineCode(const Value: string): string; 82 | 83 | {:Converts e-mail address to canonical mime form. You can specify source charset.} 84 | function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; 85 | 86 | {:Converts e-mail address to canonical mime form. Source charser it system 87 | default charset.} 88 | function InlineEmail(const Value: string): string; 89 | 90 | implementation 91 | 92 | {==============================================================================} 93 | 94 | function InlineDecode(const Value: string; CP: TMimeChar): string; 95 | var 96 | s, su, v: string; 97 | x, y, z, n: Integer; 98 | ichar: TMimeChar; 99 | c: Char; 100 | 101 | function SearchEndInline(const Value: string; be: Integer): Integer; 102 | var 103 | n, q: Integer; 104 | begin 105 | q := 0; 106 | Result := 0; 107 | for n := be + 2 to Length(Value) - 1 do 108 | if Value[n] = '?' then 109 | begin 110 | Inc(q); 111 | if (q > 2) and (Value[n + 1] = '=') then 112 | begin 113 | Result := n; 114 | Break; 115 | end; 116 | end; 117 | end; 118 | 119 | begin 120 | Result := ''; 121 | v := Value; 122 | x := Pos('=?', v); 123 | y := SearchEndInline(v, x); 124 | //fix for broken coding with begin, but not with end. 125 | if (x > 0) and (y <= 0) then 126 | y := Length(Result); 127 | while (y > x) and (x > 0) do 128 | begin 129 | s := Copy(v, 1, x - 1); 130 | if Trim(s) <> '' then 131 | Result := Result + s; 132 | s := Copy(v, x, y - x + 2); 133 | Delete(v, 1, y + 1); 134 | su := Copy(s, 3, Length(s) - 4); 135 | z := Pos('?', su); 136 | if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then 137 | begin 138 | ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*')); 139 | c := UpperCase(su)[z + 1]; 140 | su := Copy(su, z + 3, Length(su) - z - 2); 141 | if c = 'B' then 142 | begin 143 | s := DecodeBase64(su); 144 | s := CharsetConversion(s, ichar, CP); 145 | end; 146 | if c = 'Q' then 147 | begin 148 | s := ''; 149 | for n := 1 to Length(su) do 150 | if su[n] = '_' then 151 | s := s + ' ' 152 | else 153 | s := s + su[n]; 154 | s := DecodeQuotedPrintable(s); 155 | s := CharsetConversion(s, ichar, CP); 156 | end; 157 | end; 158 | Result := Result + s; 159 | x := Pos('=?', v); 160 | y := SearchEndInline(v, x); 161 | end; 162 | Result := Result + v; 163 | end; 164 | 165 | {==============================================================================} 166 | 167 | function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; 168 | var 169 | s, s1, e: string; 170 | n: Integer; 171 | begin 172 | s := CharsetConversion(Value, CP, MimeP); 173 | s := EncodeSafeQuotedPrintable(s); 174 | e := GetIdFromCP(MimeP); 175 | s1 := ''; 176 | Result := ''; 177 | for n := 1 to Length(s) do 178 | if s[n] = ' ' then 179 | begin 180 | // s1 := s1 + '=20'; 181 | s1 := s1 + '_'; 182 | if Length(s1) > 32 then 183 | begin 184 | if Result <> '' then 185 | Result := Result + ' '; 186 | Result := Result + '=?' + e + '?Q?' + s1 + '?='; 187 | s1 := ''; 188 | end; 189 | end 190 | else 191 | s1 := s1 + s[n]; 192 | if s1 <> '' then 193 | begin 194 | if Result <> '' then 195 | Result := Result + ' '; 196 | Result := Result + '=?' + e + '?Q?' + s1 + '?='; 197 | end; 198 | end; 199 | 200 | {==============================================================================} 201 | 202 | function NeedInline(const Value: AnsiString): boolean; 203 | var 204 | n: Integer; 205 | begin 206 | Result := False; 207 | for n := 1 to Length(Value) do 208 | if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then 209 | begin 210 | Result := True; 211 | Break; 212 | end; 213 | end; 214 | 215 | {==============================================================================} 216 | 217 | function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; 218 | var 219 | c: TMimeChar; 220 | begin 221 | if NeedInline(Value) then 222 | begin 223 | c := IdealCharsetCoding(Value, FromCP, IdealCharsets); 224 | Result := InlineEncode(Value, FromCP, c); 225 | end 226 | else 227 | Result := Value; 228 | end; 229 | 230 | {==============================================================================} 231 | 232 | function InlineCode(const Value: string): string; 233 | begin 234 | Result := InlineCodeEx(Value, GetCurCP); 235 | end; 236 | 237 | {==============================================================================} 238 | 239 | function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; 240 | var 241 | sd, se: string; 242 | begin 243 | sd := GetEmailDesc(Value); 244 | se := GetEmailAddr(Value); 245 | if sd = '' then 246 | Result := se 247 | else 248 | Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>'; 249 | end; 250 | 251 | {==============================================================================} 252 | 253 | function InlineEmail(const Value: string): string; 254 | begin 255 | Result := InlineEmailEx(Value, GetCurCP); 256 | end; 257 | 258 | end. 259 | -------------------------------------------------------------------------------- /nntpsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.005.003 | 3 | |==============================================================================| 4 | | Content: NNTP client | 5 | |==============================================================================| 6 | | Copyright (c)1999-2011, 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) 1999-2011. | 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(NNTP client) 46 | NNTP (network news transfer protocol) 47 | 48 | Used RFC: RFC-977, RFC-2980 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$H+} 55 | 56 | unit nntpsend; 57 | 58 | interface 59 | 60 | uses 61 | SysUtils, Classes, 62 | blcksock, synautil; 63 | 64 | const 65 | cNNTPProtocol = '119'; 66 | 67 | type 68 | 69 | {:abstract(Implementation of Network News Transfer Protocol. 70 | 71 | Note: Are you missing properties for setting Username and Password? Look to 72 | parent @link(TSynaClient) object! 73 | 74 | Are you missing properties for specify server address and port? Look to 75 | parent @link(TSynaClient) too!} 76 | TNNTPSend = class(TSynaClient) 77 | private 78 | FSock: TTCPBlockSocket; 79 | FResultCode: Integer; 80 | FResultString: string; 81 | FData: TStringList; 82 | FDataToSend: TStringList; 83 | FAutoTLS: Boolean; 84 | FFullSSL: Boolean; 85 | FNNTPcap: TStringList; 86 | function ReadResult: Integer; 87 | function ReadData: boolean; 88 | function SendData: boolean; 89 | function Connect: Boolean; 90 | public 91 | constructor Create; 92 | destructor Destroy; override; 93 | 94 | {:Connects to NNTP server and begin session.} 95 | function Login: Boolean; 96 | 97 | {:Logout from NNTP server and terminate session.} 98 | function Logout: Boolean; 99 | 100 | {:By this you can call any NNTP command.} 101 | function DoCommand(const Command: string): boolean; 102 | 103 | {:by this you can call any NNTP command. This variant is used for commands 104 | for download information from server.} 105 | function DoCommandRead(const Command: string): boolean; 106 | 107 | {:by this you can call any NNTP command. This variant is used for commands 108 | for upload information to server.} 109 | function DoCommandWrite(const Command: string): boolean; 110 | 111 | {:Download full message to @link(data) property. Value can be number of 112 | message or message-id (in brackets).} 113 | function GetArticle(const Value: string): Boolean; 114 | 115 | {:Download only body of message to @link(data) property. Value can be number 116 | of message or message-id (in brackets).} 117 | function GetBody(const Value: string): Boolean; 118 | 119 | {:Download only headers of message to @link(data) property. Value can be 120 | number of message or message-id (in brackets).} 121 | function GetHead(const Value: string): Boolean; 122 | 123 | {:Get message status. Value can be number of message or message-id 124 | (in brackets).} 125 | function GetStat(const Value: string): Boolean; 126 | 127 | {:Select given group.} 128 | function SelectGroup(const Value: string): Boolean; 129 | 130 | {:Tell to server 'I have mesage with given message-ID.' If server need this 131 | message, message is uploaded to server.} 132 | function IHave(const MessID: string): Boolean; 133 | 134 | {:Move message pointer to last item in group.} 135 | function GotoLast: Boolean; 136 | 137 | {:Move message pointer to next item in group.} 138 | function GotoNext: Boolean; 139 | 140 | {:Download to @link(data) property list of all groups on NNTP server.} 141 | function ListGroups: Boolean; 142 | 143 | {:Download to @link(data) property list of all groups created after given time.} 144 | function ListNewGroups(Since: TDateTime): Boolean; 145 | 146 | {:Download to @link(data) property list of message-ids in given group since 147 | given time.} 148 | function NewArticles(const Group: string; Since: TDateTime): Boolean; 149 | 150 | {:Upload new article to server. (for new messages by you)} 151 | function PostArticle: Boolean; 152 | 153 | {:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP 154 | server'.} 155 | function SwitchToSlave: Boolean; 156 | 157 | {:Call NNTP XOVER command.} 158 | function Xover(xoStart, xoEnd: string): boolean; 159 | 160 | {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} 161 | function StartTLS: Boolean; 162 | 163 | {:Try to find given capability in extension list. This list is getted after 164 | successful login to NNTP server. If extension capability is not found, 165 | then return is empty string.} 166 | function FindCap(const Value: string): string; 167 | 168 | {:Try get list of server extensions. List is returned in @link(data) property.} 169 | function ListExtensions: Boolean; 170 | published 171 | {:Result code number of last operation.} 172 | property ResultCode: Integer read FResultCode; 173 | 174 | {:String description of last result code from NNTP server.} 175 | property ResultString: string read FResultString; 176 | 177 | {:Readed data. (message, etc.)} 178 | property Data: TStringList read FData; 179 | 180 | {:If is set to @true, then upgrade to SSL/TLS mode after login if remote 181 | server support it.} 182 | property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; 183 | 184 | {:SSL/TLS mode is used from first contact to server. Servers with full 185 | SSL/TLS mode usualy using non-standard TCP port!} 186 | property FullSSL: Boolean read FFullSSL Write FFullSSL; 187 | 188 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 189 | property Sock: TTCPBlockSocket read FSock; 190 | end; 191 | 192 | implementation 193 | 194 | constructor TNNTPSend.Create; 195 | begin 196 | inherited Create; 197 | FSock := TTCPBlockSocket.Create; 198 | FSock.Owner := self; 199 | FData := TStringList.Create; 200 | FDataToSend := TStringList.Create; 201 | FNNTPcap := TStringList.Create; 202 | FSock.ConvertLineEnd := True; 203 | FTimeout := 60000; 204 | FTargetPort := cNNTPProtocol; 205 | FAutoTLS := False; 206 | FFullSSL := False; 207 | end; 208 | 209 | destructor TNNTPSend.Destroy; 210 | begin 211 | FSock.Free; 212 | FDataToSend.Free; 213 | FData.Free; 214 | FNNTPcap.Free; 215 | inherited Destroy; 216 | end; 217 | 218 | function TNNTPSend.ReadResult: Integer; 219 | var 220 | s: string; 221 | begin 222 | Result := 0; 223 | FData.Clear; 224 | s := FSock.RecvString(FTimeout); 225 | FResultString := Copy(s, 5, Length(s) - 4); 226 | if FSock.LastError <> 0 then 227 | Exit; 228 | if Length(s) >= 3 then 229 | Result := StrToIntDef(Copy(s, 1, 3), 0); 230 | FResultCode := Result; 231 | end; 232 | 233 | function TNNTPSend.ReadData: boolean; 234 | var 235 | s: string; 236 | begin 237 | repeat 238 | s := FSock.RecvString(FTimeout); 239 | if s = '.' then 240 | break; 241 | if (s <> '') and (s[1] = '.') then 242 | s := Copy(s, 2, Length(s) - 1); 243 | FData.Add(s); 244 | until FSock.LastError <> 0; 245 | Result := FSock.LastError = 0; 246 | end; 247 | 248 | function TNNTPSend.SendData: boolean; 249 | var 250 | s: string; 251 | n: integer; 252 | begin 253 | for n := 0 to FDataToSend.Count - 1 do 254 | begin 255 | s := FDataToSend[n]; 256 | if (s <> '') and (s[1] = '.') then 257 | s := s + '.'; 258 | FSock.SendString(s + CRLF); 259 | if FSock.LastError <> 0 then 260 | break; 261 | end; 262 | if FDataToSend.Count = 0 then 263 | FSock.SendString(CRLF); 264 | if FSock.LastError = 0 then 265 | FSock.SendString('.' + CRLF); 266 | FDataToSend.Clear; 267 | Result := FSock.LastError = 0; 268 | end; 269 | 270 | function TNNTPSend.Connect: Boolean; 271 | begin 272 | FSock.CloseSocket; 273 | FSock.Bind(FIPInterface, cAnyPort); 274 | if FSock.LastError = 0 then 275 | FSock.Connect(FTargetHost, FTargetPort); 276 | if FSock.LastError = 0 then 277 | if FFullSSL then 278 | FSock.SSLDoConnect; 279 | Result := FSock.LastError = 0; 280 | end; 281 | 282 | function TNNTPSend.Login: Boolean; 283 | begin 284 | Result := False; 285 | FNNTPcap.Clear; 286 | if not Connect then 287 | Exit; 288 | Result := (ReadResult div 100) = 2; 289 | if Result then 290 | begin 291 | ListExtensions; 292 | FNNTPcap.Assign(Fdata); 293 | if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then 294 | Result := StartTLS; 295 | end; 296 | if (FUsername <> '') and Result then 297 | begin 298 | FSock.SendString('AUTHINFO USER ' + FUsername + CRLF); 299 | if (ReadResult div 100) = 3 then 300 | begin 301 | FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF); 302 | Result := (ReadResult div 100) = 2; 303 | end; 304 | end; 305 | end; 306 | 307 | function TNNTPSend.Logout: Boolean; 308 | begin 309 | FSock.SendString('QUIT' + CRLF); 310 | Result := (ReadResult div 100) = 2; 311 | FSock.CloseSocket; 312 | end; 313 | 314 | function TNNTPSend.DoCommand(const Command: string): Boolean; 315 | begin 316 | FSock.SendString(Command + CRLF); 317 | Result := (ReadResult div 100) = 2; 318 | Result := Result and (FSock.LastError = 0); 319 | end; 320 | 321 | function TNNTPSend.DoCommandRead(const Command: string): Boolean; 322 | begin 323 | Result := DoCommand(Command); 324 | if Result then 325 | begin 326 | Result := ReadData; 327 | Result := Result and (FSock.LastError = 0); 328 | end; 329 | end; 330 | 331 | function TNNTPSend.DoCommandWrite(const Command: string): Boolean; 332 | var 333 | x: integer; 334 | begin 335 | FDataToSend.Assign(FData); 336 | FSock.SendString(Command + CRLF); 337 | x := (ReadResult div 100); 338 | if x = 3 then 339 | begin 340 | SendData; 341 | x := (ReadResult div 100); 342 | end; 343 | Result := x = 2; 344 | Result := Result and (FSock.LastError = 0); 345 | end; 346 | 347 | function TNNTPSend.GetArticle(const Value: string): Boolean; 348 | var 349 | s: string; 350 | begin 351 | s := 'ARTICLE'; 352 | if Value <> '' then 353 | s := s + ' ' + Value; 354 | Result := DoCommandRead(s); 355 | end; 356 | 357 | function TNNTPSend.GetBody(const Value: string): Boolean; 358 | var 359 | s: string; 360 | begin 361 | s := 'BODY'; 362 | if Value <> '' then 363 | s := s + ' ' + Value; 364 | Result := DoCommandRead(s); 365 | end; 366 | 367 | function TNNTPSend.GetHead(const Value: string): Boolean; 368 | var 369 | s: string; 370 | begin 371 | s := 'HEAD'; 372 | if Value <> '' then 373 | s := s + ' ' + Value; 374 | Result := DoCommandRead(s); 375 | end; 376 | 377 | function TNNTPSend.GetStat(const Value: string): Boolean; 378 | var 379 | s: string; 380 | begin 381 | s := 'STAT'; 382 | if Value <> '' then 383 | s := s + ' ' + Value; 384 | Result := DoCommand(s); 385 | end; 386 | 387 | function TNNTPSend.SelectGroup(const Value: string): Boolean; 388 | begin 389 | Result := DoCommand('GROUP ' + Value); 390 | end; 391 | 392 | function TNNTPSend.IHave(const MessID: string): Boolean; 393 | begin 394 | Result := DoCommandWrite('IHAVE ' + MessID); 395 | end; 396 | 397 | function TNNTPSend.GotoLast: Boolean; 398 | begin 399 | Result := DoCommand('LAST'); 400 | end; 401 | 402 | function TNNTPSend.GotoNext: Boolean; 403 | begin 404 | Result := DoCommand('NEXT'); 405 | end; 406 | 407 | function TNNTPSend.ListGroups: Boolean; 408 | begin 409 | Result := DoCommandRead('LIST'); 410 | end; 411 | 412 | function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean; 413 | begin 414 | Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT'); 415 | end; 416 | 417 | function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean; 418 | begin 419 | Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT'); 420 | end; 421 | 422 | function TNNTPSend.PostArticle: Boolean; 423 | begin 424 | Result := DoCommandWrite('POST'); 425 | end; 426 | 427 | function TNNTPSend.SwitchToSlave: Boolean; 428 | begin 429 | Result := DoCommand('SLAVE'); 430 | end; 431 | 432 | function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean; 433 | var 434 | s: string; 435 | begin 436 | s := 'XOVER ' + xoStart; 437 | if xoEnd <> xoStart then 438 | s := s + '-' + xoEnd; 439 | Result := DoCommandRead(s); 440 | end; 441 | 442 | function TNNTPSend.StartTLS: Boolean; 443 | begin 444 | Result := False; 445 | if FindCap('STARTTLS') <> '' then 446 | begin 447 | if DoCommand('STARTTLS') then 448 | begin 449 | Fsock.SSLDoConnect; 450 | Result := FSock.LastError = 0; 451 | end; 452 | end; 453 | end; 454 | 455 | function TNNTPSend.ListExtensions: Boolean; 456 | begin 457 | Result := DoCommandRead('LIST EXTENSIONS'); 458 | end; 459 | 460 | function TNNTPSend.FindCap(const Value: string): string; 461 | var 462 | n: Integer; 463 | s: string; 464 | begin 465 | s := UpperCase(Value); 466 | Result := ''; 467 | for n := 0 to FNNTPcap.Count - 1 do 468 | if Pos(s, UpperCase(FNNTPcap[n])) = 1 then 469 | begin 470 | Result := FNNTPcap[n]; 471 | Break; 472 | end; 473 | end; 474 | 475 | {==============================================================================} 476 | 477 | end. 478 | -------------------------------------------------------------------------------- /pop3send.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 002.006.002 | 3 | |==============================================================================| 4 | | Content: POP3 client | 5 | |==============================================================================| 6 | | Copyright (c)1999-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)2001-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(POP3 protocol client) 46 | 47 | Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 48 | } 49 | 50 | {$IFDEF FPC} 51 | {$MODE DELPHI} 52 | {$ENDIF} 53 | {$H+} 54 | {$M+} 55 | 56 | unit pop3send; 57 | 58 | interface 59 | 60 | uses 61 | SysUtils, Classes, 62 | blcksock, synautil, synacode; 63 | 64 | const 65 | cPop3Protocol = '110'; 66 | 67 | type 68 | 69 | {:The three types of possible authorization methods for "logging in" to a POP3 70 | server.} 71 | TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); 72 | 73 | {:@abstract(Implementation of POP3 client protocol.) 74 | 75 | Note: Are you missing properties for setting Username and Password? Look to 76 | parent @link(TSynaClient) object! 77 | 78 | Are you missing properties for specify server address and port? Look to 79 | parent @link(TSynaClient) too!} 80 | TPOP3Send = class(TSynaClient) 81 | private 82 | FSock: TTCPBlockSocket; 83 | FResultCode: Integer; 84 | FResultString: string; 85 | FFullResult: TStringList; 86 | FStatCount: Integer; 87 | FStatSize: Integer; 88 | FListSize: Integer; 89 | FTimeStamp: string; 90 | FAuthType: TPOP3AuthType; 91 | FPOP3cap: TStringList; 92 | FAutoTLS: Boolean; 93 | FFullSSL: Boolean; 94 | function ReadResult(Full: Boolean): Integer; 95 | function Connect: Boolean; 96 | function AuthLogin: Boolean; 97 | function AuthApop: Boolean; 98 | public 99 | constructor Create; 100 | destructor Destroy; override; 101 | 102 | {:You can call any custom by this method. Call Command without trailing CRLF. 103 | If MultiLine parameter is @true, multilined response are expected. 104 | Result is @true on sucess.} 105 | function CustomCommand(const Command: string; MultiLine: Boolean): boolean; 106 | 107 | {:Call CAPA command for get POP3 server capabilites. 108 | note: not all servers support this command!} 109 | function Capability: Boolean; 110 | 111 | {:Connect to remote POP3 host. If all OK, result is @true.} 112 | function Login: Boolean; 113 | 114 | {:Disconnects from POP3 server.} 115 | function Logout: Boolean; 116 | 117 | {:Send RSET command. If all OK, result is @true.} 118 | function Reset: Boolean; 119 | 120 | {:Send NOOP command. If all OK, result is @true.} 121 | function NoOp: Boolean; 122 | 123 | {:Send STAT command and fill @link(StatCount) and @link(StatSize) property. 124 | If all OK, result is @true.} 125 | function Stat: Boolean; 126 | 127 | {:Send LIST command. If Value is 0, LIST is for all messages. After 128 | successful operation is listing in FullResult. If all OK, result is @True.} 129 | function List(Value: Integer): Boolean; 130 | 131 | {:Send RETR command. After successful operation dowloaded message in 132 | @link(FullResult). If all OK, result is @true.} 133 | function Retr(Value: Integer): Boolean; 134 | 135 | {:Send RETR command. After successful operation dowloaded message in 136 | @link(Stream). If all OK, result is @true.} 137 | function RetrStream(Value: Integer; Stream: TStream): Boolean; 138 | 139 | {:Send DELE command for delete specified message. If all OK, result is @true.} 140 | function Dele(Value: Integer): Boolean; 141 | 142 | {:Send TOP command. After successful operation dowloaded headers of message 143 | and maxlines count of message in @link(FullResult). If all OK, result is 144 | @true.} 145 | function Top(Value, Maxlines: Integer): Boolean; 146 | 147 | {:Send UIDL command. If Value is 0, UIDL is for all messages. After 148 | successful operation is listing in FullResult. If all OK, result is @True.} 149 | function Uidl(Value: Integer): Boolean; 150 | 151 | {:Call STLS command for upgrade connection to SSL/TLS mode.} 152 | function StartTLS: Boolean; 153 | 154 | {:Try to find given capabily in capabilty string returned from POP3 server 155 | by CAPA command.} 156 | function FindCap(const Value: string): string; 157 | published 158 | {:Result code of last POP3 operation. 0 - error, 1 - OK.} 159 | property ResultCode: Integer read FResultCode; 160 | 161 | {:Result string of last POP3 operation.} 162 | property ResultString: string read FResultString; 163 | 164 | {:Stringlist with full lines returned as result of POP3 operation. I.e. if 165 | operation is LIST, this property is filled by list of messages. If 166 | operation is RETR, this property have downloaded message.} 167 | property FullResult: TStringList read FFullResult; 168 | 169 | {:After STAT command is there count of messages in inbox.} 170 | property StatCount: Integer read FStatCount; 171 | 172 | {:After STAT command is there size of all messages in inbox.} 173 | property StatSize: Integer read FStatSize; 174 | 175 | {:After LIST 0 command size of all messages on server, After LIST x size of message x on server} 176 | property ListSize: Integer read FListSize; 177 | 178 | {:If server support this, after comnnect is in this property timestamp of 179 | remote server.} 180 | property TimeStamp: string read FTimeStamp; 181 | 182 | {:Type of authorisation for login to POP3 server. Dafault is autodetect one 183 | of possible authorisation. Autodetect do this: 184 | 185 | If remote POP3 server support APOP, try login by APOP method. If APOP is 186 | not supported, or if APOP login failed, try classic USER+PASS login method.} 187 | property AuthType: TPOP3AuthType read FAuthType Write FAuthType; 188 | 189 | {:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.} 190 | property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; 191 | 192 | {:SSL/TLS mode is used from first contact to server. Servers with full 193 | SSL/TLS mode usualy using non-standard TCP port!} 194 | property FullSSL: Boolean read FFullSSL Write FFullSSL; 195 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 196 | property Sock: TTCPBlockSocket read FSock; 197 | end; 198 | 199 | implementation 200 | 201 | constructor TPOP3Send.Create; 202 | begin 203 | inherited Create; 204 | FFullResult := TStringList.Create; 205 | FPOP3cap := TStringList.Create; 206 | FSock := TTCPBlockSocket.Create; 207 | FSock.Owner := self; 208 | FSock.ConvertLineEnd := true; 209 | FTimeout := 60000; 210 | FTargetPort := cPop3Protocol; 211 | FStatCount := 0; 212 | FStatSize := 0; 213 | FListSize := 0; 214 | FAuthType := POP3AuthAll; 215 | FAutoTLS := False; 216 | FFullSSL := False; 217 | end; 218 | 219 | destructor TPOP3Send.Destroy; 220 | begin 221 | FSock.Free; 222 | FPOP3cap.Free; 223 | FullResult.Free; 224 | inherited Destroy; 225 | end; 226 | 227 | function TPOP3Send.ReadResult(Full: Boolean): Integer; 228 | var 229 | s: AnsiString; 230 | begin 231 | Result := 0; 232 | FFullResult.Clear; 233 | s := FSock.RecvString(FTimeout); 234 | if Pos('+OK', s) = 1 then 235 | Result := 1; 236 | FResultString := s; 237 | if Full and (Result = 1) then 238 | repeat 239 | s := FSock.RecvString(FTimeout); 240 | if s = '.' then 241 | Break; 242 | if s <> '' then 243 | if s[1] = '.' then 244 | Delete(s, 1, 1); 245 | FFullResult.Add(s); 246 | until FSock.LastError <> 0; 247 | if not Full and (Result = 1) then 248 | FFullResult.Add(SeparateRight(FResultString, ' ')); 249 | if FSock.LastError <> 0 then 250 | Result := 0; 251 | FResultCode := Result; 252 | end; 253 | 254 | function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean; 255 | begin 256 | FSock.SendString(Command + CRLF); 257 | Result := ReadResult(MultiLine) <> 0; 258 | end; 259 | 260 | function TPOP3Send.AuthLogin: Boolean; 261 | begin 262 | Result := False; 263 | if not CustomCommand('USER ' + FUserName, False) then 264 | exit; 265 | Result := CustomCommand('PASS ' + FPassword, False) 266 | end; 267 | 268 | function TPOP3Send.AuthAPOP: Boolean; 269 | var 270 | s: string; 271 | begin 272 | s := StrToHex(MD5(FTimeStamp + FPassWord)); 273 | Result := CustomCommand('APOP ' + FUserName + ' ' + s, False); 274 | end; 275 | 276 | function TPOP3Send.Connect: Boolean; 277 | begin 278 | // Do not call this function! It is calling by LOGIN method! 279 | FStatCount := 0; 280 | FStatSize := 0; 281 | FSock.CloseSocket; 282 | FSock.LineBuffer := ''; 283 | FSock.Bind(FIPInterface, cAnyPort); 284 | if FSock.LastError = 0 then 285 | FSock.Connect(FTargetHost, FTargetPort); 286 | if FSock.LastError = 0 then 287 | if FFullSSL then 288 | FSock.SSLDoConnect; 289 | Result := FSock.LastError = 0; 290 | end; 291 | 292 | function TPOP3Send.Capability: Boolean; 293 | begin 294 | FPOP3cap.Clear; 295 | Result := CustomCommand('CAPA', True); 296 | if Result then 297 | FPOP3cap.AddStrings(FFullResult); 298 | end; 299 | 300 | function TPOP3Send.Login: Boolean; 301 | var 302 | s, s1: string; 303 | begin 304 | Result := False; 305 | FTimeStamp := ''; 306 | if not Connect then 307 | Exit; 308 | if ReadResult(False) <> 1 then 309 | Exit; 310 | s := SeparateRight(FResultString, '<'); 311 | if s <> FResultString then 312 | begin 313 | s1 := Trim(SeparateLeft(s, '>')); 314 | if s1 <> s then 315 | FTimeStamp := '<' + s1 + '>'; 316 | end; 317 | Result := False; 318 | if Capability then 319 | if FAutoTLS and (Findcap('STLS') <> '') then 320 | if StartTLS then 321 | Capability 322 | else 323 | begin 324 | Result := False; 325 | Exit; 326 | end; 327 | if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then 328 | begin 329 | Result := AuthApop; 330 | if not Result then 331 | begin 332 | if not Connect then 333 | Exit; 334 | if ReadResult(False) <> 1 then 335 | Exit; 336 | end; 337 | end; 338 | if not Result and not (FAuthType = POP3AuthAPOP) then 339 | Result := AuthLogin; 340 | end; 341 | 342 | function TPOP3Send.Logout: Boolean; 343 | begin 344 | Result := CustomCommand('QUIT', False); 345 | FSock.CloseSocket; 346 | end; 347 | 348 | function TPOP3Send.Reset: Boolean; 349 | begin 350 | Result := CustomCommand('RSET', False); 351 | end; 352 | 353 | function TPOP3Send.NoOp: Boolean; 354 | begin 355 | Result := CustomCommand('NOOP', False); 356 | end; 357 | 358 | function TPOP3Send.Stat: Boolean; 359 | var 360 | s: string; 361 | begin 362 | Result := CustomCommand('STAT', False); 363 | if Result then 364 | begin 365 | s := SeparateRight(ResultString, '+OK '); 366 | FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); 367 | FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); 368 | end; 369 | end; 370 | 371 | function TPOP3Send.List(Value: Integer): Boolean; 372 | var 373 | s: string; 374 | n: integer; 375 | begin 376 | if Value = 0 then 377 | s := 'LIST' 378 | else 379 | s := 'LIST ' + IntToStr(Value); 380 | Result := CustomCommand(s, Value = 0); 381 | FListSize := 0; 382 | if Result then 383 | if Value <> 0 then 384 | begin 385 | s := SeparateRight(ResultString, '+OK '); 386 | FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); 387 | end 388 | else 389 | for n := 0 to FFullResult.Count - 1 do 390 | FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); 391 | end; 392 | 393 | function TPOP3Send.Retr(Value: Integer): Boolean; 394 | begin 395 | Result := CustomCommand('RETR ' + IntToStr(Value), True); 396 | end; 397 | 398 | //based on code by Miha Vrhovnik 399 | function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean; 400 | var 401 | s: string; 402 | begin 403 | Result := False; 404 | FFullResult.Clear; 405 | Stream.Size := 0; 406 | FSock.SendString('RETR ' + IntToStr(Value) + CRLF); 407 | 408 | s := FSock.RecvString(FTimeout); 409 | if Pos('+OK', s) = 1 then 410 | Result := True; 411 | FResultString := s; 412 | if Result then begin 413 | repeat 414 | s := FSock.RecvString(FTimeout); 415 | if s = '.' then 416 | Break; 417 | if s <> '' then begin 418 | if s[1] = '.' then 419 | Delete(s, 1, 1); 420 | end; 421 | WriteStrToStream(Stream, s); 422 | WriteStrToStream(Stream, CRLF); 423 | until FSock.LastError <> 0; 424 | end; 425 | 426 | if Result then 427 | FResultCode := 1 428 | else 429 | FResultCode := 0; 430 | end; 431 | 432 | function TPOP3Send.Dele(Value: Integer): Boolean; 433 | begin 434 | Result := CustomCommand('DELE ' + IntToStr(Value), False); 435 | end; 436 | 437 | function TPOP3Send.Top(Value, Maxlines: Integer): Boolean; 438 | begin 439 | Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True); 440 | end; 441 | 442 | function TPOP3Send.Uidl(Value: Integer): Boolean; 443 | var 444 | s: string; 445 | begin 446 | if Value = 0 then 447 | s := 'UIDL' 448 | else 449 | s := 'UIDL ' + IntToStr(Value); 450 | Result := CustomCommand(s, Value = 0); 451 | end; 452 | 453 | function TPOP3Send.StartTLS: Boolean; 454 | begin 455 | Result := False; 456 | if CustomCommand('STLS', False) then 457 | begin 458 | Fsock.SSLDoConnect; 459 | Result := FSock.LastError = 0; 460 | end; 461 | end; 462 | 463 | function TPOP3Send.FindCap(const Value: string): string; 464 | var 465 | n: Integer; 466 | s: string; 467 | begin 468 | s := UpperCase(Value); 469 | Result := ''; 470 | for n := 0 to FPOP3cap.Count - 1 do 471 | if Pos(s, UpperCase(FPOP3cap[n])) = 1 then 472 | begin 473 | Result := FPOP3cap[n]; 474 | Break; 475 | end; 476 | end; 477 | 478 | end. 479 | -------------------------------------------------------------------------------- /slogsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.002.003 | 3 | |==============================================================================| 4 | | Content: SysLog client | 5 | |==============================================================================| 6 | | Copyright (c)1999-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)2001-2010. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | | Christian Brosius | 41 | |==============================================================================| 42 | | History: see HISTORY.HTM from distribution package | 43 | | (Found at URL: http://www.ararat.cz/synapse/) | 44 | |==============================================================================} 45 | 46 | {:@abstract(BSD SYSLOG protocol) 47 | 48 | Used RFC: RFC-3164 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$Q-} 55 | {$H+} 56 | 57 | unit slogsend; 58 | 59 | interface 60 | 61 | uses 62 | SysUtils, Classes, 63 | blcksock, synautil; 64 | 65 | const 66 | cSysLogProtocol = '514'; 67 | 68 | FCL_Kernel = 0; 69 | FCL_UserLevel = 1; 70 | FCL_MailSystem = 2; 71 | FCL_System = 3; 72 | FCL_Security = 4; 73 | FCL_Syslogd = 5; 74 | FCL_Printer = 6; 75 | FCL_News = 7; 76 | FCL_UUCP = 8; 77 | FCL_Clock = 9; 78 | FCL_Authorization = 10; 79 | FCL_FTP = 11; 80 | FCL_NTP = 12; 81 | FCL_LogAudit = 13; 82 | FCL_LogAlert = 14; 83 | FCL_Time = 15; 84 | FCL_Local0 = 16; 85 | FCL_Local1 = 17; 86 | FCL_Local2 = 18; 87 | FCL_Local3 = 19; 88 | FCL_Local4 = 20; 89 | FCL_Local5 = 21; 90 | FCL_Local6 = 22; 91 | FCL_Local7 = 23; 92 | 93 | type 94 | {:@abstract(Define possible priority of Syslog message)} 95 | TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info, 96 | Debug); 97 | 98 | {:@abstract(encoding or decoding of SYSLOG message)} 99 | TSyslogMessage = class(TObject) 100 | private 101 | FFacility:Byte; 102 | FSeverity:TSyslogSeverity; 103 | FDateTime:TDateTime; 104 | FTag:String; 105 | FMessage:String; 106 | FLocalIP:String; 107 | function GetPacketBuf:String; 108 | procedure SetPacketBuf(Value:String); 109 | public 110 | {:Reset values to defaults} 111 | procedure Clear; 112 | published 113 | {:Define facilicity of Syslog message. For specify you may use predefined 114 | FCL_* constants. Default is "FCL_Local0".} 115 | property Facility:Byte read FFacility write FFacility; 116 | 117 | {:Define possible priority of Syslog message. Default is "Debug".} 118 | property Severity:TSyslogSeverity read FSeverity write FSeverity; 119 | 120 | {:date and time of Syslog message} 121 | property DateTime:TDateTime read FDateTime write FDateTime; 122 | 123 | {:This is used for identify process of this message. Default is filename 124 | of your executable file.} 125 | property Tag:String read FTag write FTag; 126 | 127 | {:Text of your message for log.} 128 | property LogMessage:String read FMessage write FMessage; 129 | 130 | {:IP address of message sender.} 131 | property LocalIP:String read FLocalIP write FLocalIP; 132 | 133 | {:This property holds encoded binary SYSLOG packet} 134 | property PacketBuf:String read GetPacketBuf write SetPacketBuf; 135 | end; 136 | 137 | {:@abstract(This object implement BSD SysLog client) 138 | 139 | Note: Are you missing properties for specify server address and port? Look to 140 | parent @link(TSynaClient) too!} 141 | TSyslogSend = class(TSynaClient) 142 | private 143 | FSock: TUDPBlockSocket; 144 | FSysLogMessage: TSysLogMessage; 145 | public 146 | constructor Create; 147 | destructor Destroy; override; 148 | {:Send Syslog UDP packet defined by @link(SysLogMessage).} 149 | function DoIt: Boolean; 150 | published 151 | {:Syslog message for send} 152 | property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage; 153 | end; 154 | 155 | {:Simply send packet to specified Syslog server.} 156 | function ToSysLog(const SyslogServer: string; Facil: Byte; 157 | Sever: TSyslogSeverity; const Content: string): Boolean; 158 | 159 | implementation 160 | 161 | function TSyslogMessage.GetPacketBuf:String; 162 | begin 163 | Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>'; 164 | Result := Result + CDateTime(FDateTime) + ' '; 165 | Result := Result + FLocalIP + ' '; 166 | Result := Result + FTag + ': ' + FMessage; 167 | end; 168 | 169 | procedure TSyslogMessage.SetPacketBuf(Value:String); 170 | var StrBuf:String; 171 | IntBuf,Pos:Integer; 172 | begin 173 | if Length(Value) < 1 then exit; 174 | Pos := 1; 175 | if Value[Pos] <> '<' then exit; 176 | Inc(Pos); 177 | // Facility and Severity 178 | StrBuf := ''; 179 | while (Value[Pos] <> '>')do 180 | begin 181 | StrBuf := StrBuf + Value[Pos]; 182 | Inc(Pos); 183 | end; 184 | IntBuf := StrToInt(StrBuf); 185 | FFacility := IntBuf div 8; 186 | case (IntBuf mod 8)of 187 | 0:FSeverity := Emergency; 188 | 1:FSeverity := Alert; 189 | 2:FSeverity := Critical; 190 | 3:FSeverity := Error; 191 | 4:FSeverity := Warning; 192 | 5:FSeverity := Notice; 193 | 6:FSeverity := Info; 194 | 7:FSeverity := Debug; 195 | end; 196 | // DateTime 197 | Inc(Pos); 198 | StrBuf := ''; 199 | // Month 200 | while (Value[Pos] <> ' ')do 201 | begin 202 | StrBuf := StrBuf + Value[Pos]; 203 | Inc(Pos); 204 | end; 205 | StrBuf := StrBuf + Value[Pos]; 206 | Inc(Pos); 207 | // Day 208 | while (Value[Pos] <> ' ')do 209 | begin 210 | StrBuf := StrBuf + Value[Pos]; 211 | Inc(Pos); 212 | end; 213 | StrBuf := StrBuf + Value[Pos]; 214 | Inc(Pos); 215 | // Time 216 | while (Value[Pos] <> ' ')do 217 | begin 218 | StrBuf := StrBuf + Value[Pos]; 219 | Inc(Pos); 220 | end; 221 | FDateTime := DecodeRFCDateTime(StrBuf); 222 | Inc(Pos); 223 | 224 | // LocalIP 225 | StrBuf := ''; 226 | while (Value[Pos] <> ' ')do 227 | begin 228 | StrBuf := StrBuf + Value[Pos]; 229 | Inc(Pos); 230 | end; 231 | FLocalIP := StrBuf; 232 | Inc(Pos); 233 | // Tag 234 | StrBuf := ''; 235 | while (Value[Pos] <> ':')do 236 | begin 237 | StrBuf := StrBuf + Value[Pos]; 238 | Inc(Pos); 239 | end; 240 | FTag := StrBuf; 241 | // LogMessage 242 | Inc(Pos); 243 | StrBuf := ''; 244 | while (Pos <= Length(Value))do 245 | begin 246 | StrBuf := StrBuf + Value[Pos]; 247 | Inc(Pos); 248 | end; 249 | FMessage := TrimSP(StrBuf); 250 | end; 251 | 252 | procedure TSysLogMessage.Clear; 253 | begin 254 | FFacility := FCL_Local0; 255 | FSeverity := Debug; 256 | FTag := ExtractFileName(ParamStr(0)); 257 | FMessage := ''; 258 | FLocalIP := '0.0.0.0'; 259 | end; 260 | 261 | //------------------------------------------------------------------------------ 262 | 263 | constructor TSyslogSend.Create; 264 | begin 265 | inherited Create; 266 | FSock := TUDPBlockSocket.Create; 267 | FSock.Owner := self; 268 | FSysLogMessage := TSysLogMessage.Create; 269 | FTargetPort := cSysLogProtocol; 270 | end; 271 | 272 | destructor TSyslogSend.Destroy; 273 | begin 274 | FSock.Free; 275 | FSysLogMessage.Free; 276 | inherited Destroy; 277 | end; 278 | 279 | function TSyslogSend.DoIt: Boolean; 280 | var 281 | L: TStringList; 282 | begin 283 | Result := False; 284 | L := TStringList.Create; 285 | try 286 | FSock.ResolveNameToIP(FSock.Localname, L); 287 | if L.Count < 1 then 288 | FSysLogMessage.LocalIP := '0.0.0.0' 289 | else 290 | FSysLogMessage.LocalIP := L[0]; 291 | finally 292 | L.Free; 293 | end; 294 | FSysLogMessage.DateTime := Now; 295 | if Length(FSysLogMessage.PacketBuf) <= 1024 then 296 | begin 297 | FSock.Connect(FTargetHost, FTargetPort); 298 | FSock.SendString(FSysLogMessage.PacketBuf); 299 | Result := FSock.LastError = 0; 300 | end; 301 | end; 302 | 303 | {==============================================================================} 304 | 305 | function ToSysLog(const SyslogServer: string; Facil: Byte; 306 | Sever: TSyslogSeverity; const Content: string): Boolean; 307 | begin 308 | with TSyslogSend.Create do 309 | try 310 | TargetHost :=SyslogServer; 311 | SysLogMessage.Facility := Facil; 312 | SysLogMessage.Severity := Sever; 313 | SysLogMessage.LogMessage := Content; 314 | Result := DoIt; 315 | finally 316 | Free; 317 | end; 318 | end; 319 | 320 | end. 321 | -------------------------------------------------------------------------------- /sntpsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 003.000.003 | 3 | |==============================================================================| 4 | | Content: SNTP client | 5 | |==============================================================================| 6 | | Copyright (c)1999-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)2000-2010. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | | Patrick Chevalley | 41 | |==============================================================================| 42 | | History: see HISTORY.HTM from distribution package | 43 | | (Found at URL: http://www.ararat.cz/synapse/) | 44 | |==============================================================================} 45 | 46 | {:@abstract( NTP and SNTP client) 47 | 48 | Used RFC: RFC-1305, RFC-2030 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$Q-} 55 | {$H+} 56 | 57 | unit sntpsend; 58 | 59 | interface 60 | 61 | uses 62 | SysUtils, 63 | synsock, blcksock, synautil; 64 | 65 | const 66 | cNtpProtocol = '123'; 67 | 68 | type 69 | 70 | {:@abstract(Record containing the NTP packet.)} 71 | TNtp = packed record 72 | mode: Byte; 73 | stratum: Byte; 74 | poll: Byte; 75 | Precision: Byte; 76 | RootDelay: Longint; 77 | RootDisperson: Longint; 78 | RefID: Longint; 79 | Ref1: Longint; 80 | Ref2: Longint; 81 | Org1: Longint; 82 | Org2: Longint; 83 | Rcv1: Longint; 84 | Rcv2: Longint; 85 | Xmit1: Longint; 86 | Xmit2: Longint; 87 | end; 88 | 89 | {:@abstract(Implementation of NTP and SNTP client protocol), 90 | include time synchronisation. It can send NTP or SNTP time queries, or it 91 | can receive NTP broadcasts too. 92 | 93 | Note: Are you missing properties for specify server address and port? Look to 94 | parent @link(TSynaClient) too!} 95 | TSNTPSend = class(TSynaClient) 96 | private 97 | FNTPReply: TNtp; 98 | FNTPTime: TDateTime; 99 | FNTPOffset: double; 100 | FNTPDelay: double; 101 | FMaxSyncDiff: double; 102 | FSyncTime: Boolean; 103 | FSock: TUDPBlockSocket; 104 | FBuffer: AnsiString; 105 | FLi, FVn, Fmode : byte; 106 | function StrToNTP(const Value: AnsiString): TNtp; 107 | function NTPtoStr(const Value: Tntp): AnsiString; 108 | procedure ClearNTP(var Value: Tntp); 109 | public 110 | constructor Create; 111 | destructor Destroy; override; 112 | 113 | {:Decode 128 bit timestamp used in NTP packet to TDateTime type.} 114 | function DecodeTs(Nsec, Nfrac: Longint): TDateTime; 115 | 116 | {:Decode TDateTime type to 128 bit timestamp used in NTP packet.} 117 | procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); 118 | 119 | {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all 120 | is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are 121 | valid.} 122 | function GetSNTP: Boolean; 123 | 124 | {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all 125 | is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are 126 | valid. Result time is after all needed corrections.} 127 | function GetNTP: Boolean; 128 | 129 | {:Wait for broadcast NTP packet. If all OK, result is @true and 130 | @link(NTPReply) and @link(NTPTime) are valid.} 131 | function GetBroadcastNTP: Boolean; 132 | 133 | {:Holds last received NTP packet.} 134 | property NTPReply: TNtp read FNTPReply; 135 | published 136 | {:Date and time of remote NTP or SNTP server. (UTC time!!!)} 137 | property NTPTime: TDateTime read FNTPTime; 138 | 139 | {:Offset between your computer and remote NTP or SNTP server.} 140 | property NTPOffset: Double read FNTPOffset; 141 | 142 | {:Delay between your computer and remote NTP or SNTP server.} 143 | property NTPDelay: Double read FNTPDelay; 144 | 145 | {:Define allowed maximum difference between your time and remote time for 146 | synchronising time. If difference is bigger, your system time is not 147 | changed!} 148 | property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; 149 | 150 | {:If @true, after successfull getting time is local computer clock 151 | synchronised to given time. 152 | For synchronising time you must have proper rights! (Usually Administrator)} 153 | property SyncTime: Boolean read FSyncTime write FSyncTime; 154 | 155 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 156 | property Sock: TUDPBlockSocket read FSock; 157 | end; 158 | 159 | implementation 160 | 161 | constructor TSNTPSend.Create; 162 | begin 163 | inherited Create; 164 | FSock := TUDPBlockSocket.Create; 165 | FSock.Owner := self; 166 | FTimeout := 5000; 167 | FTargetPort := cNtpProtocol; 168 | FMaxSyncDiff := 3600; 169 | FSyncTime := False; 170 | end; 171 | 172 | destructor TSNTPSend.Destroy; 173 | begin 174 | FSock.Free; 175 | inherited Destroy; 176 | end; 177 | 178 | function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp; 179 | begin 180 | if length(FBuffer) >= SizeOf(Result) then 181 | begin 182 | Result.mode := ord(Value[1]); 183 | Result.stratum := ord(Value[2]); 184 | Result.poll := ord(Value[3]); 185 | Result.Precision := ord(Value[4]); 186 | Result.RootDelay := DecodeLongInt(value, 5); 187 | Result.RootDisperson := DecodeLongInt(value, 9); 188 | Result.RefID := DecodeLongInt(value, 13); 189 | Result.Ref1 := DecodeLongInt(value, 17); 190 | Result.Ref2 := DecodeLongInt(value, 21); 191 | Result.Org1 := DecodeLongInt(value, 25); 192 | Result.Org2 := DecodeLongInt(value, 29); 193 | Result.Rcv1 := DecodeLongInt(value, 33); 194 | Result.Rcv2 := DecodeLongInt(value, 37); 195 | Result.Xmit1 := DecodeLongInt(value, 41); 196 | Result.Xmit2 := DecodeLongInt(value, 45); 197 | end; 198 | 199 | end; 200 | 201 | function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString; 202 | begin 203 | SetLength(Result, 4); 204 | Result[1] := AnsiChar(Value.mode); 205 | Result[2] := AnsiChar(Value.stratum); 206 | Result[3] := AnsiChar(Value.poll); 207 | Result[4] := AnsiChar(Value.precision); 208 | Result := Result + CodeLongInt(Value.RootDelay); 209 | Result := Result + CodeLongInt(Value.RootDisperson); 210 | Result := Result + CodeLongInt(Value.RefID); 211 | Result := Result + CodeLongInt(Value.Ref1); 212 | Result := Result + CodeLongInt(Value.Ref2); 213 | Result := Result + CodeLongInt(Value.Org1); 214 | Result := Result + CodeLongInt(Value.Org2); 215 | Result := Result + CodeLongInt(Value.Rcv1); 216 | Result := Result + CodeLongInt(Value.Rcv2); 217 | Result := Result + CodeLongInt(Value.Xmit1); 218 | Result := Result + CodeLongInt(Value.Xmit2); 219 | end; 220 | 221 | procedure TSNTPSend.ClearNTP(var Value: Tntp); 222 | begin 223 | Value.mode := 0; 224 | Value.stratum := 0; 225 | Value.poll := 0; 226 | Value.Precision := 0; 227 | Value.RootDelay := 0; 228 | Value.RootDisperson := 0; 229 | Value.RefID := 0; 230 | Value.Ref1 := 0; 231 | Value.Ref2 := 0; 232 | Value.Org1 := 0; 233 | Value.Org2 := 0; 234 | Value.Rcv1 := 0; 235 | Value.Rcv2 := 0; 236 | Value.Xmit1 := 0; 237 | Value.Xmit2 := 0; 238 | end; 239 | 240 | function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime; 241 | const 242 | maxi = 4294967295.0; 243 | var 244 | d, d1: Double; 245 | begin 246 | d := Nsec; 247 | if d < 0 then 248 | d := maxi + d + 1; 249 | d1 := Nfrac; 250 | if d1 < 0 then 251 | d1 := maxi + d1 + 1; 252 | d1 := d1 / maxi; 253 | d1 := Trunc(d1 * 10000) / 10000; 254 | Result := (d + d1) / 86400; 255 | Result := Result + 2; 256 | end; 257 | 258 | procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); 259 | const 260 | maxi = 4294967295.0; 261 | maxilongint = 2147483647; 262 | var 263 | d, d1: Double; 264 | begin 265 | d := (dt - 2) * 86400; 266 | d1 := frac(d); 267 | if d > maxilongint then 268 | d := d - maxi - 1; 269 | d := trunc(d); 270 | d1 := Trunc(d1 * 10000) / 10000; 271 | d1 := d1 * maxi; 272 | if d1 > maxilongint then 273 | d1 := d1 - maxi - 1; 274 | Nsec:=trunc(d); 275 | Nfrac:=trunc(d1); 276 | end; 277 | 278 | function TSNTPSend.GetBroadcastNTP: Boolean; 279 | var 280 | x: Integer; 281 | begin 282 | Result := False; 283 | FSock.Bind(FIPInterface, FTargetPort); 284 | FBuffer := FSock.RecvPacket(FTimeout); 285 | if FSock.LastError = 0 then 286 | begin 287 | x := Length(FBuffer); 288 | if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then 289 | if x >= SizeOf(NTPReply) then 290 | begin 291 | FNTPReply := StrToNTP(FBuffer); 292 | FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); 293 | if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then 294 | SetUTTime(FNTPTime); 295 | Result := True; 296 | end; 297 | end; 298 | end; 299 | 300 | function TSNTPSend.GetSNTP: Boolean; 301 | var 302 | q: TNtp; 303 | x: Integer; 304 | begin 305 | Result := False; 306 | FSock.CloseSocket; 307 | FSock.Bind(FIPInterface, cAnyPort); 308 | FSock.Connect(FTargetHost, FTargetPort); 309 | ClearNtp(q); 310 | q.mode := $1B; 311 | FBuffer := NTPtoStr(q); 312 | FSock.SendString(FBuffer); 313 | FBuffer := FSock.RecvPacket(FTimeout); 314 | if FSock.LastError = 0 then 315 | begin 316 | x := Length(FBuffer); 317 | if x >= SizeOf(NTPReply) then 318 | begin 319 | FNTPReply := StrToNTP(FBuffer); 320 | FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); 321 | if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then 322 | SetUTTime(FNTPTime); 323 | Result := True; 324 | end; 325 | end; 326 | end; 327 | 328 | function TSNTPSend.GetNTP: Boolean; 329 | var 330 | q: TNtp; 331 | x: Integer; 332 | t1, t2, t3, t4 : TDateTime; 333 | begin 334 | Result := False; 335 | FSock.CloseSocket; 336 | FSock.Bind(FIPInterface, cAnyPort); 337 | FSock.Connect(FTargetHost, FTargetPort); 338 | ClearNtp(q); 339 | q.mode := $1B; 340 | t1 := GetUTTime; 341 | EncodeTs(t1, q.org1, q.org2); 342 | FBuffer := NTPtoStr(q); 343 | FSock.SendString(FBuffer); 344 | FBuffer := FSock.RecvPacket(FTimeout); 345 | if FSock.LastError = 0 then 346 | begin 347 | x := Length(FBuffer); 348 | t4 := GetUTTime; 349 | if x >= SizeOf(NTPReply) then 350 | begin 351 | FNTPReply := StrToNTP(FBuffer); 352 | FLi := (NTPReply.mode and $C0) shr 6; 353 | FVn := (NTPReply.mode and $38) shr 3; 354 | Fmode := NTPReply.mode and $07; 355 | if (Fli < 3) and (Fmode = 4) and 356 | (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and 357 | (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0) 358 | then begin 359 | t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2); 360 | t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); 361 | FNTPDelay := (T4 - T1) - (T2 - T3); 362 | FNTPTime := t3 + FNTPDelay / 2; 363 | FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400; 364 | FNTPDelay := FNTPDelay * 86400; 365 | if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then 366 | SetUTTime(FNTPTime); 367 | Result := True; 368 | end 369 | else result:=false; 370 | end; 371 | end; 372 | end; 373 | 374 | end. 375 | -------------------------------------------------------------------------------- /ssl_libssh2.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.000.000 | 3 | |==============================================================================| 4 | | Content: SSH support by LibSSH2 | 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 Alexey Suhinin. | 36 | | Portions created by Alexey Suhinin are Copyright (c)2012-2013. | 37 | | Portions created by Lukas Gebauer are Copyright (c)2013-2013. | 38 | | All Rights Reserved. | 39 | |==============================================================================| 40 | | Contributor(s): | 41 | |==============================================================================| 42 | | History: see HISTORY.HTM from distribution package | 43 | | (Found at URL: http://www.ararat.cz/synapse/) | 44 | |==============================================================================} 45 | 46 | //requires LibSSH2 libraries! http://libssh2.org 47 | 48 | {:@abstract(SSH plugin for LibSSH2) 49 | 50 | Requires libssh2.dll or libssh2.so. 51 | You can download binaries as part of the CURL project from 52 | http://curl.haxx.se/download.html 53 | 54 | You need Pascal bindings for the library too! You can find one at: 55 | http://www.lazarus.freepascal.org/index.php/topic,15935.msg86465.html#msg86465 56 | 57 | This plugin implements the client part only. 58 | } 59 | 60 | {$IFDEF FPC} 61 | {$MODE DELPHI} 62 | {$ENDIF} 63 | {$H+} 64 | 65 | unit ssl_libssh2; 66 | 67 | interface 68 | 69 | uses 70 | SysUtils, 71 | blcksock, synsock, 72 | libssh2; 73 | 74 | type 75 | {:@abstract(class implementing LibSSH2 SSH plugin.) 76 | Instance of this class will be created for each @link(TTCPBlockSocket). 77 | You not need to create instance of this class, all is done by Synapse itself!} 78 | TSSLLibSSH2 = class(TCustomSSL) 79 | protected 80 | FSession: PLIBSSH2_SESSION; 81 | FChannel: PLIBSSH2_CHANNEL; 82 | function SSHCheck(Value: integer): Boolean; 83 | function DeInit: Boolean; 84 | public 85 | {:See @inherited} 86 | constructor Create(const Value: TTCPBlockSocket); override; 87 | destructor Destroy; override; 88 | {:See @inherited} 89 | function LibVersion: String; override; 90 | {:See @inherited} 91 | function LibName: String; override; 92 | {:See @inherited} 93 | function Connect: boolean; override; 94 | {:See @inherited} 95 | function Shutdown: boolean; override; 96 | {:See @inherited} 97 | function BiShutdown: boolean; override; 98 | {:See @inherited} 99 | function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; 100 | {:See @inherited} 101 | function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; 102 | {:See @inherited} 103 | function WaitingData: Integer; override; 104 | {:See @inherited} 105 | function GetSSLVersion: string; override; 106 | published 107 | end; 108 | 109 | implementation 110 | 111 | {==============================================================================} 112 | function TSSLLibSSH2.SSHCheck(Value: integer): Boolean; 113 | var 114 | PLastError: PAnsiChar; 115 | ErrMsgLen: Integer; 116 | begin 117 | Result := true; 118 | FLastError := 0; 119 | FLastErrorDesc := ''; 120 | if Value<0 then 121 | begin 122 | FLastError := libssh2_session_last_error(FSession, PLastError, ErrMsglen, 0); 123 | FLastErrorDesc := PLastError; 124 | Result := false; 125 | end; 126 | end; 127 | 128 | 129 | function TSSLLibSSH2.DeInit: Boolean; 130 | begin 131 | if Assigned(FChannel) then 132 | begin 133 | libssh2_channel_free(FChannel); 134 | FChannel := nil; 135 | end; 136 | if Assigned(FSession) then 137 | begin 138 | libssh2_session_disconnect(FSession,'Goodbye'); 139 | libssh2_session_free(FSession); 140 | FSession := nil; 141 | end; 142 | FSSLEnabled := False; 143 | Result := true; 144 | end; 145 | 146 | constructor TSSLLibSSH2.Create(const Value: TTCPBlockSocket); 147 | begin 148 | inherited Create(Value); 149 | FSession := nil; 150 | FChannel := nil; 151 | end; 152 | 153 | destructor TSSLLibSSH2.Destroy; 154 | begin 155 | DeInit; 156 | inherited Destroy; 157 | end; 158 | 159 | function TSSLLibSSH2.Connect: boolean; 160 | begin 161 | Result := False; 162 | if SSLEnabled then DeInit; 163 | if (FSocket.Socket <> INVALID_SOCKET) and (FSocket.SSL.SSLType = LT_SSHv2) then 164 | begin 165 | FSession := libssh2_session_init(); 166 | if not Assigned(FSession) then 167 | begin 168 | FLastError := -999; 169 | FLastErrorDesc := 'Cannot initialize SSH session'; 170 | exit; 171 | end; 172 | if not SSHCheck(libssh2_session_startup(FSession, FSocket.Socket)) then 173 | exit; 174 | // Attempt private key authentication, then fall back to username/password but 175 | // do not forget original private key auth error. This avoids giving spurious errors like 176 | // Authentication failed (username/password) 177 | // instead of e.g. 178 | // Unable to extract public key from private key file: Method unimplemented in libgcrypt backend 179 | if FSocket.SSL.PrivateKeyFile<>'' then 180 | if (not SSHCheck(libssh2_userauth_publickey_fromfile(FSession, PChar(FSocket.SSL.Username), nil, PChar(FSocket.SSL.PrivateKeyFile), PChar(FSocket.SSL.KeyPassword)))) 181 | and (libssh2_userauth_password(FSession, PChar(FSocket.SSL.Username), PChar(FSocket.SSL.Password))<0) then 182 | exit; 183 | FChannel := libssh2_channel_open_session(FSession); 184 | if not assigned(FChannel) then 185 | begin 186 | // SSHCheck(-1); 187 | FLastError:=-999; 188 | FLastErrorDesc := 'Cannot open session'; 189 | exit; 190 | end; 191 | if not SSHCheck(libssh2_channel_request_pty(FChannel, 'vanilla')) then 192 | exit; 193 | if not SSHCheck(libssh2_channel_shell(FChannel)) then 194 | exit; 195 | FSSLEnabled := True; 196 | Result := True; 197 | end; 198 | end; 199 | 200 | function TSSLLibSSH2.LibName: String; 201 | begin 202 | Result := 'ssl_libssh2'; 203 | end; 204 | 205 | function TSSLLibSSH2.Shutdown: boolean; 206 | begin 207 | Result := DeInit; 208 | end; 209 | 210 | 211 | function TSSLLibSSH2.BiShutdown: boolean; 212 | begin 213 | Result := DeInit; 214 | end; 215 | 216 | function TSSLLibSSH2.SendBuffer(Buffer: TMemory; Len: Integer): Integer; 217 | begin 218 | Result:=libssh2_channel_write(FChannel, PAnsiChar(Buffer), Len); 219 | SSHCheck(Result); 220 | end; 221 | 222 | function TSSLLibSSH2.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; 223 | begin 224 | result:=libssh2_channel_read(FChannel, PAnsiChar(Buffer), Len); 225 | SSHCheck(Result); 226 | end; 227 | 228 | function TSSLLibSSH2.WaitingData: Integer; 229 | begin 230 | if libssh2_poll_channel_read(FChannel, Result) <> 1 then 231 | Result := 0; 232 | end; 233 | 234 | function TSSLLibSSH2.GetSSLVersion: string; 235 | begin 236 | Result := 'SSH2'; 237 | end; 238 | 239 | function TSSLLibSSH2.LibVersion: String; 240 | begin 241 | Result := libssh2_version(0); 242 | end; 243 | 244 | initialization 245 | if libssh2_init(0)=0 then 246 | SSLImplementation := TSSLLibSSH2; 247 | 248 | finalization 249 | libssh2_exit; 250 | 251 | end. 252 | -------------------------------------------------------------------------------- /ssl_streamsec.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dimmaq/delphi-synapse/0d153dcb87a251751cb5bd238d98fec50a2b0c58/ssl_streamsec.pas -------------------------------------------------------------------------------- /synadbg.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.002 | 3 | |==============================================================================| 4 | | Content: Socket debug tools | 5 | |==============================================================================| 6 | | Copyright (c)2008-2011, 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)2008-2011. | 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(Socket debug tools) 46 | 47 | Routines for help with debugging of events on the Sockets. 48 | } 49 | 50 | unit synadbg; 51 | 52 | interface 53 | 54 | uses 55 | blcksock, synsock, synautil, classes, sysutils, synafpc; 56 | 57 | type 58 | TSynaDebug = class(TObject) 59 | class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); 60 | class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); 61 | end; 62 | 63 | procedure AppendToLog(const value: Ansistring); 64 | 65 | var 66 | LogFile: string; 67 | 68 | implementation 69 | 70 | procedure AppendToLog(const value: Ansistring); 71 | var 72 | st: TFileStream; 73 | s: string; 74 | h, m, ss, ms: word; 75 | dt: Tdatetime; 76 | begin 77 | if fileexists(LogFile) then 78 | st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite) 79 | else 80 | st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite); 81 | try 82 | st.Position := st.Size; 83 | dt := now; 84 | decodetime(dt, h, m, ss, ms); 85 | s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value; 86 | WriteStrToStream(st, s); 87 | finally 88 | st.free; 89 | end; 90 | end; 91 | 92 | class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); 93 | var 94 | s: string; 95 | begin 96 | case Reason of 97 | HR_ResolvingBegin: 98 | s := 'HR_ResolvingBegin'; 99 | HR_ResolvingEnd: 100 | s := 'HR_ResolvingEnd'; 101 | HR_SocketCreate: 102 | s := 'HR_SocketCreate'; 103 | HR_SocketClose: 104 | s := 'HR_SocketClose'; 105 | HR_Bind: 106 | s := 'HR_Bind'; 107 | HR_Connect: 108 | s := 'HR_Connect'; 109 | HR_CanRead: 110 | s := 'HR_CanRead'; 111 | HR_CanWrite: 112 | s := 'HR_CanWrite'; 113 | HR_Listen: 114 | s := 'HR_Listen'; 115 | HR_Accept: 116 | s := 'HR_Accept'; 117 | HR_ReadCount: 118 | s := 'HR_ReadCount'; 119 | HR_WriteCount: 120 | s := 'HR_WriteCount'; 121 | HR_Wait: 122 | s := 'HR_Wait'; 123 | HR_Error: 124 | s := 'HR_Error'; 125 | else 126 | s := '-unknown-'; 127 | end; 128 | s := inttohex(PtrInt(Sender), 8) + s + ': ' + value + CRLF; 129 | AppendToLog(s); 130 | end; 131 | 132 | class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); 133 | var 134 | s, d: Ansistring; 135 | begin 136 | setlength(s, len); 137 | move(Buffer^, pointer(s)^, len); 138 | if writing then 139 | d := '-> ' 140 | else 141 | d := '<- '; 142 | s :=inttohex(PtrInt(Sender), 8) + d + s + CRLF; 143 | AppendToLog(s); 144 | end; 145 | 146 | initialization 147 | begin 148 | Logfile := changefileext(paramstr(0), '.slog'); 149 | end; 150 | 151 | end. 152 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /synaicnv.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.002 | 3 | |==============================================================================| 4 | | Content: ICONV support for Win32, OS/2, Linux and .NET | 5 | |==============================================================================| 6 | | Copyright (c)2004-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)2004-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 | {$IFDEF FPC} 47 | {$MODE DELPHI} 48 | {$ENDIF} 49 | {$H+} 50 | //old Delphi does not have MSWINDOWS define. 51 | {$IFDEF WIN32} 52 | {$IFNDEF MSWINDOWS} 53 | {$DEFINE MSWINDOWS} 54 | {$ENDIF} 55 | {$ENDIF} 56 | 57 | {:@abstract(LibIconv support) 58 | 59 | This unit is Pascal interface to LibIconv library for charset translations. 60 | LibIconv is loaded dynamicly on-demand. If this library is not found in system, 61 | requested LibIconv function just return errorcode. 62 | } 63 | unit synaicnv; 64 | 65 | interface 66 | 67 | uses 68 | {$IFDEF CIL} 69 | System.Runtime.InteropServices, 70 | System.Text, 71 | {$ENDIF} 72 | synafpc, 73 | {$IFNDEF MSWINDOWS} 74 | {$IFNDEF FPC} 75 | Libc, 76 | {$ENDIF} 77 | SysUtils; 78 | {$ELSE} 79 | Windows; 80 | {$ENDIF} 81 | 82 | 83 | const 84 | {$IFNDEF MSWINDOWS} 85 | {$IFDEF OS2} 86 | DLLIconvName = 'iconv.dll'; 87 | {$ELSE OS2} 88 | DLLIconvName = 'libiconv.so'; 89 | {$ENDIF OS2} 90 | {$ELSE} 91 | DLLIconvName = 'iconv.dll'; 92 | {$ENDIF} 93 | 94 | type 95 | size_t = Cardinal; 96 | {$IFDEF CIL} 97 | iconv_t = IntPtr; 98 | {$ELSE} 99 | iconv_t = Pointer; 100 | {$ENDIF} 101 | argptr = iconv_t; 102 | 103 | var 104 | iconvLibHandle: TLibHandle = 0; 105 | 106 | function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t; 107 | function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t; 108 | function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): iconv_t; 109 | function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; 110 | function SynaIconvClose(var cd: iconv_t): integer; 111 | function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer; 112 | 113 | function IsIconvloaded: Boolean; 114 | function InitIconvInterface: Boolean; 115 | function DestroyIconvInterface: Boolean; 116 | 117 | const 118 | ICONV_TRIVIALP = 0; // int *argument 119 | ICONV_GET_TRANSLITERATE = 1; // int *argument 120 | ICONV_SET_TRANSLITERATE = 2; // const int *argument 121 | ICONV_GET_DISCARD_ILSEQ = 3; // int *argument 122 | ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument 123 | 124 | 125 | implementation 126 | 127 | uses SyncObjs; 128 | 129 | {$IFDEF CIL} 130 | [DllImport(DLLIconvName, CharSet = CharSet.Ansi, 131 | SetLastError = False, CallingConvention= CallingConvention.cdecl, 132 | EntryPoint = 'libiconv_open')] 133 | function _iconv_open(tocode: string; fromcode: string): iconv_t; external; 134 | 135 | [DllImport(DLLIconvName, CharSet = CharSet.Ansi, 136 | SetLastError = False, CallingConvention= CallingConvention.cdecl, 137 | EntryPoint = 'libiconv')] 138 | function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t; 139 | var outbuf: IntPtr; var outbytesleft: size_t): size_t; external; 140 | 141 | [DllImport(DLLIconvName, CharSet = CharSet.Ansi, 142 | SetLastError = False, CallingConvention= CallingConvention.cdecl, 143 | EntryPoint = 'libiconv_close')] 144 | function _iconv_close(cd: iconv_t): integer; external; 145 | 146 | [DllImport(DLLIconvName, CharSet = CharSet.Ansi, 147 | SetLastError = False, CallingConvention= CallingConvention.cdecl, 148 | EntryPoint = 'libiconvctl')] 149 | function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external; 150 | 151 | {$ELSE} 152 | type 153 | Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl; 154 | Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t; 155 | var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl; 156 | Ticonv_close = function(cd: iconv_t): integer; cdecl; 157 | Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl; 158 | var 159 | _iconv_open: Ticonv_open = nil; 160 | _iconv: Ticonv = nil; 161 | _iconv_close: Ticonv_close = nil; 162 | _iconvctl: Ticonvctl = nil; 163 | {$ENDIF} 164 | 165 | 166 | var 167 | IconvCS: TCriticalSection; 168 | Iconvloaded: boolean = false; 169 | 170 | function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t; 171 | begin 172 | {$IFDEF CIL} 173 | try 174 | Result := _iconv_open(tocode, fromcode); 175 | except 176 | on Exception do 177 | Result := iconv_t(-1); 178 | end; 179 | {$ELSE} 180 | if InitIconvInterface and Assigned(_iconv_open) then 181 | Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode)) 182 | else 183 | Result := iconv_t(-1); 184 | {$ENDIF} 185 | end; 186 | 187 | function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t; 188 | begin 189 | Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode); 190 | end; 191 | 192 | function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t; 193 | begin 194 | Result := SynaIconvOpen(tocode + '//IGNORE', fromcode); 195 | end; 196 | 197 | function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; 198 | var 199 | {$IFDEF CIL} 200 | ib, ob: IntPtr; 201 | ibsave, obsave: IntPtr; 202 | l: integer; 203 | {$ELSE} 204 | ib, ob: Pointer; 205 | {$ENDIF} 206 | ix, ox: size_t; 207 | begin 208 | {$IFDEF CIL} 209 | l := Length(inbuf) * 4; 210 | ibsave := IntPtr.Zero; 211 | obsave := IntPtr.Zero; 212 | try 213 | ibsave := Marshal.StringToHGlobalAnsi(inbuf); 214 | obsave := Marshal.AllocHGlobal(l); 215 | ib := ibsave; 216 | ob := obsave; 217 | ix := Length(inbuf); 218 | ox := l; 219 | _iconv(cd, ib, ix, ob, ox); 220 | Outbuf := Marshal.PtrToStringAnsi(obsave, l); 221 | setlength(Outbuf, l - ox); 222 | Result := Length(inbuf) - ix; 223 | finally 224 | Marshal.FreeCoTaskMem(ibsave); 225 | Marshal.FreeHGlobal(obsave); 226 | end; 227 | {$ELSE} 228 | if InitIconvInterface and Assigned(_iconv) then 229 | begin 230 | setlength(Outbuf, Length(inbuf) * 4); 231 | ib := Pointer(inbuf); 232 | ob := Pointer(Outbuf); 233 | ix := Length(inbuf); 234 | ox := Length(Outbuf); 235 | _iconv(cd, ib, ix, ob, ox); 236 | setlength(Outbuf, cardinal(Length(Outbuf)) - ox); 237 | Result := Cardinal(Length(inbuf)) - ix; 238 | end 239 | else 240 | begin 241 | Outbuf := ''; 242 | Result := 0; 243 | end; 244 | {$ENDIF} 245 | end; 246 | 247 | function SynaIconvClose(var cd: iconv_t): integer; 248 | begin 249 | if cd = iconv_t(-1) then 250 | begin 251 | Result := 0; 252 | Exit; 253 | end; 254 | {$IFDEF CIL} 255 | try; 256 | Result := _iconv_close(cd) 257 | except 258 | on Exception do 259 | Result := -1; 260 | end; 261 | cd := iconv_t(-1); 262 | {$ELSE} 263 | if InitIconvInterface and Assigned(_iconv_close) then 264 | Result := _iconv_close(cd) 265 | else 266 | Result := -1; 267 | cd := iconv_t(-1); 268 | {$ENDIF} 269 | end; 270 | 271 | function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer; 272 | begin 273 | {$IFDEF CIL} 274 | Result := _iconvctl(cd, request, argument) 275 | {$ELSE} 276 | if InitIconvInterface and Assigned(_iconvctl) then 277 | Result := _iconvctl(cd, request, argument) 278 | else 279 | Result := 0; 280 | {$ENDIF} 281 | end; 282 | 283 | function InitIconvInterface: Boolean; 284 | begin 285 | IconvCS.Enter; 286 | try 287 | if not IsIconvloaded then 288 | begin 289 | {$IFDEF CIL} 290 | IconvLibHandle := 1; 291 | {$ELSE} 292 | IconvLibHandle := LoadLibrary(PChar(DLLIconvName)); 293 | {$ENDIF} 294 | if (IconvLibHandle <> 0) then 295 | begin 296 | {$IFNDEF CIL} 297 | _iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open'))); 298 | _iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv'))); 299 | _iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close'))); 300 | _iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl'))); 301 | {$ENDIF} 302 | Result := True; 303 | Iconvloaded := True; 304 | end 305 | else 306 | begin 307 | //load failed! 308 | if IconvLibHandle <> 0 then 309 | begin 310 | {$IFNDEF CIL} 311 | FreeLibrary(IconvLibHandle); 312 | {$ENDIF} 313 | IconvLibHandle := 0; 314 | end; 315 | Result := False; 316 | end; 317 | end 318 | else 319 | //loaded before... 320 | Result := true; 321 | finally 322 | IconvCS.Leave; 323 | end; 324 | end; 325 | 326 | function DestroyIconvInterface: Boolean; 327 | begin 328 | IconvCS.Enter; 329 | try 330 | Iconvloaded := false; 331 | if IconvLibHandle <> 0 then 332 | begin 333 | {$IFNDEF CIL} 334 | FreeLibrary(IconvLibHandle); 335 | {$ENDIF} 336 | IconvLibHandle := 0; 337 | end; 338 | {$IFNDEF CIL} 339 | _iconv_open := nil; 340 | _iconv := nil; 341 | _iconv_close := nil; 342 | _iconvctl := nil; 343 | {$ENDIF} 344 | finally 345 | IconvCS.Leave; 346 | end; 347 | Result := True; 348 | end; 349 | 350 | function IsIconvloaded: Boolean; 351 | begin 352 | Result := IconvLoaded; 353 | end; 354 | 355 | initialization 356 | begin 357 | IconvCS:= TCriticalSection.Create; 358 | end; 359 | 360 | finalization 361 | begin 362 | {$IFNDEF CIL} 363 | DestroyIconvInterface; 364 | {$ENDIF} 365 | IconvCS.Free; 366 | end; 367 | 368 | end. 369 | -------------------------------------------------------------------------------- /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 | unit synaip; 55 | 56 | interface 57 | 58 | uses 59 | SysUtils, SynaUtil; 60 | 61 | type 62 | {:binary form of IPv6 adress (for string conversion routines)} 63 | TIp6Bytes = array [0..15] of Byte; 64 | {:binary form of IPv6 adress (for string conversion routines)} 65 | TIp6Words = array [0..7] of Word; 66 | 67 | {:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} 68 | function IsIP(const Value: AnsiString): Boolean; 69 | 70 | {:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} 71 | function IsIP6(const Value: AnsiString): Boolean; 72 | 73 | {:Returns a string with the "Host" ip address converted to binary form.} 74 | function IPToID(Host: AnsiString): Ansistring; 75 | 76 | {:Convert IPv6 address from their string form to binary byte array.} 77 | function StrToIp6(value: AnsiString): TIp6Bytes; 78 | 79 | {:Convert IPv6 address from binary byte array to string form.} 80 | function Ip6ToStr(value: TIp6Bytes): AnsiString; 81 | 82 | {:Convert IPv4 address from their string form to binary.} 83 | function StrToIp(value: AnsiString): Cardinal; 84 | 85 | {:Convert IPv4 address from binary to string form.} 86 | function IpToStr(value: Cardinal): AnsiString; 87 | 88 | {:Convert IPv4 address to reverse form.} 89 | function ReverseIP(Value: AnsiString): AnsiString; 90 | 91 | {:Convert IPv6 address to reverse form.} 92 | function ReverseIP6(Value: AnsiString): AnsiString; 93 | 94 | {:Expand short form of IPv6 address to long form.} 95 | function ExpandIP6(Value: AnsiString): AnsiString; 96 | 97 | 98 | implementation 99 | 100 | {==============================================================================} 101 | 102 | function IsIP(const Value: AnsiString): Boolean; 103 | var 104 | TempIP: AnsiString; 105 | function ByteIsOk(const Value: AnsiString): Boolean; 106 | var 107 | x, n: integer; 108 | begin 109 | x := StrToIntDef(Value, -1); 110 | Result := (x >= 0) and (x < 256); 111 | // X may be in correct range, but value still may not be correct value! 112 | // i.e. "$80" 113 | if Result then 114 | for n := 1 to length(Value) do 115 | if not (AnsiChar(Value[n]) in ['0'..'9']) then 116 | begin 117 | Result := False; 118 | Break; 119 | end; 120 | end; 121 | begin 122 | TempIP := Value; 123 | Result := False; 124 | if not ByteIsOk(Fetch(TempIP, '.')) then 125 | Exit; 126 | if not ByteIsOk(Fetch(TempIP, '.')) then 127 | Exit; 128 | if not ByteIsOk(Fetch(TempIP, '.')) then 129 | Exit; 130 | if ByteIsOk(TempIP) then 131 | Result := True; 132 | end; 133 | 134 | {==============================================================================} 135 | 136 | function IsIP6(const Value: AnsiString): Boolean; 137 | var 138 | TempIP: AnsiString; 139 | s,t: AnsiString; 140 | x: integer; 141 | partcount: integer; 142 | zerocount: integer; 143 | First: Boolean; 144 | begin 145 | TempIP := Value; 146 | Result := False; 147 | if Value = '::' then 148 | begin 149 | Result := True; 150 | Exit; 151 | end; 152 | partcount := 0; 153 | zerocount := 0; 154 | First := True; 155 | while tempIP <> '' do 156 | begin 157 | s := fetch(TempIP, ':'); 158 | if not(First) and (s = '') then 159 | Inc(zerocount); 160 | First := False; 161 | if zerocount > 1 then 162 | break; 163 | Inc(partCount); 164 | if s = '' then 165 | Continue; 166 | if partCount > 8 then 167 | break; 168 | if tempIP = '' then 169 | begin 170 | t := SeparateRight(s, '%'); 171 | s := SeparateLeft(s, '%'); 172 | x := StrToIntDef('$' + t, -1); 173 | if (x < 0) or (x > $ffff) then 174 | break; 175 | end; 176 | x := StrToIntDef('$' + s, -1); 177 | if (x < 0) or (x > $ffff) then 178 | break; 179 | if tempIP = '' then 180 | if not((PartCount = 1) and (ZeroCount = 0)) then 181 | Result := True; 182 | end; 183 | end; 184 | 185 | {==============================================================================} 186 | function IPToID(Host: AnsiString): Ansistring; 187 | var 188 | s: AnsiString; 189 | i, x: Integer; 190 | begin 191 | Result := ''; 192 | for x := 0 to 3 do 193 | begin 194 | s := Fetch(Host, '.'); 195 | i := StrToIntDef(s, 0); 196 | Result := Result + AnsiChar(i); 197 | end; 198 | end; 199 | 200 | {==============================================================================} 201 | 202 | function StrToIp(value: AnsiString): Cardinal; 203 | var 204 | s: AnsiString; 205 | i, x: Cardinal; 206 | begin 207 | Result := 0; 208 | for x := 0 to 3 do 209 | begin 210 | s := Fetch(value, '.'); 211 | i := StrToIntDef(s, 0); 212 | Result := (256 * Result) + i; 213 | end; 214 | end; 215 | 216 | {==============================================================================} 217 | 218 | function IpToStr(value: Cardinal): AnsiString; 219 | var 220 | x1, x2: word; 221 | y1, y2: byte; 222 | begin 223 | Result := ''; 224 | x1 := value shr 16; 225 | x2 := value and $FFFF; 226 | y1 := x1 div $100; 227 | y2 := x1 mod $100; 228 | Result := IntToStr(y1) + '.' + IntToStr(y2) + '.'; 229 | y1 := x2 div $100; 230 | y2 := x2 mod $100; 231 | Result := Result + IntToStr(y1) + '.' + IntToStr(y2); 232 | end; 233 | 234 | {==============================================================================} 235 | 236 | function ExpandIP6(Value: AnsiString): AnsiString; 237 | var 238 | n: integer; 239 | s: ansistring; 240 | x: integer; 241 | begin 242 | Result := ''; 243 | if value = '' then 244 | exit; 245 | x := countofchar(value, ':'); 246 | if x > 7 then 247 | exit; 248 | if value[1] = ':' then 249 | value := '0' + value; 250 | if value[length(value)] = ':' then 251 | value := value + '0'; 252 | x := 8 - x; 253 | s := ''; 254 | for n := 1 to x do 255 | s := s + ':0'; 256 | s := s + ':'; 257 | Result := replacestring(value, '::', s); 258 | end; 259 | {==============================================================================} 260 | 261 | function StrToIp6(Value: AnsiString): TIp6Bytes; 262 | var 263 | IPv6: TIp6Words; 264 | Index: Integer; 265 | n: integer; 266 | b1, b2: byte; 267 | s: AnsiString; 268 | x: integer; 269 | begin 270 | for n := 0 to 15 do 271 | Result[n] := 0; 272 | for n := 0 to 7 do 273 | Ipv6[n] := 0; 274 | Index := 0; 275 | Value := ExpandIP6(value); 276 | if value = '' then 277 | exit; 278 | while Value <> '' do 279 | begin 280 | if Index > 7 then 281 | Exit; 282 | s := fetch(value, ':'); 283 | if s = '@' then 284 | break; 285 | if s = '' then 286 | begin 287 | IPv6[Index] := 0; 288 | end 289 | else 290 | begin 291 | x := StrToIntDef('$' + s, -1); 292 | if (x > 65535) or (x < 0) then 293 | Exit; 294 | IPv6[Index] := x; 295 | end; 296 | Inc(Index); 297 | end; 298 | for n := 0 to 7 do 299 | begin 300 | b1 := ipv6[n] div 256; 301 | b2 := ipv6[n] mod 256; 302 | Result[n * 2] := b1; 303 | Result[(n * 2) + 1] := b2; 304 | end; 305 | end; 306 | 307 | {==============================================================================} 308 | //based on routine by the Free Pascal development team 309 | function Ip6ToStr(value: TIp6Bytes): AnsiString; 310 | var 311 | i, x: byte; 312 | zr1,zr2: set of byte; 313 | zc1,zc2: byte; 314 | have_skipped: boolean; 315 | ip6w: TIp6words; 316 | begin 317 | zr1 := []; 318 | zr2 := []; 319 | zc1 := 0; 320 | zc2 := 0; 321 | for i := 0 to 7 do 322 | begin 323 | x := i * 2; 324 | ip6w[i] := value[x] * 256 + value[x + 1]; 325 | if ip6w[i] = 0 then 326 | begin 327 | include(zr2, i); 328 | inc(zc2); 329 | end 330 | else 331 | begin 332 | if zc1 < zc2 then 333 | begin 334 | zc1 := zc2; 335 | zr1 := zr2; 336 | zc2 := 0; 337 | zr2 := []; 338 | end; 339 | end; 340 | end; 341 | if zc1 < zc2 then 342 | begin 343 | zr1 := zr2; 344 | end; 345 | SetLength(Result, 8*5-1); 346 | SetLength(Result, 0); 347 | have_skipped := false; 348 | for i := 0 to 7 do 349 | begin 350 | if not(i in zr1) then 351 | begin 352 | if have_skipped then 353 | begin 354 | if Result = '' then 355 | Result := '::' 356 | else 357 | Result := Result + ':'; 358 | have_skipped := false; 359 | end; 360 | Result := Result + IntToHex(Ip6w[i], 1) + ':'; 361 | end 362 | else 363 | begin 364 | have_skipped := true; 365 | end; 366 | end; 367 | if have_skipped then 368 | if Result = '' then 369 | Result := '::0' 370 | else 371 | Result := Result + ':'; 372 | 373 | if Result = '' then 374 | Result := '::0'; 375 | if not (7 in zr1) then 376 | SetLength(Result, Length(Result)-1); 377 | Result := LowerCase(result); 378 | end; 379 | 380 | {==============================================================================} 381 | function ReverseIP(Value: AnsiString): AnsiString; 382 | var 383 | x: Integer; 384 | begin 385 | Result := ''; 386 | repeat 387 | x := LastDelimiter('.', Value); 388 | Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); 389 | Delete(Value, x, Length(Value) - x + 1); 390 | until x < 1; 391 | if Length(Result) > 0 then 392 | if Result[1] = '.' then 393 | Delete(Result, 1, 1); 394 | end; 395 | 396 | {==============================================================================} 397 | function ReverseIP6(Value: AnsiString): AnsiString; 398 | var 399 | ip6: TIp6bytes; 400 | n: integer; 401 | x, y: integer; 402 | begin 403 | ip6 := StrToIP6(Value); 404 | x := ip6[15] div 16; 405 | y := ip6[15] mod 16; 406 | Result := IntToHex(y, 1) + '.' + IntToHex(x, 1); 407 | for n := 14 downto 0 do 408 | begin 409 | x := ip6[n] div 16; 410 | y := ip6[n] mod 16; 411 | Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1); 412 | end; 413 | end; 414 | 415 | {==============================================================================} 416 | end. 417 | -------------------------------------------------------------------------------- /synamisc.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.003.001 | 3 | |==============================================================================| 4 | | Content: misc. procedures and functions | 5 | |==============================================================================| 6 | | Copyright (c)1999-2014, 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) 2002-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(Miscellaneous network based utilities)} 46 | 47 | {$IFDEF FPC} 48 | {$MODE DELPHI} 49 | {$ENDIF} 50 | {$Q-} 51 | {$H+} 52 | 53 | //Kylix does not known UNIX define 54 | {$IFDEF LINUX} 55 | {$IFNDEF UNIX} 56 | {$DEFINE UNIX} 57 | {$ENDIF} 58 | {$ENDIF} 59 | 60 | {$TYPEDADDRESS OFF} 61 | 62 | unit synamisc; 63 | 64 | interface 65 | 66 | {$IFDEF VER125} 67 | {$DEFINE BCB} 68 | {$ENDIF} 69 | {$IFDEF BCB} 70 | {$ObjExportAll On} 71 | {$HPPEMIT '#pragma comment( lib , "wininet.lib" )'} 72 | {$ENDIF} 73 | 74 | uses 75 | synautil, blcksock, SysUtils, Classes 76 | {$IFDEF UNIX} 77 | {$IFNDEF FPC} 78 | , Libc 79 | {$ENDIF} 80 | {$ELSE} 81 | , Windows 82 | {$ENDIF} 83 | ; 84 | 85 | Type 86 | {:@abstract(This record contains information about proxy settings.)} 87 | TProxySetting = record 88 | Host: string; 89 | Port: string; 90 | Bypass: string; 91 | end; 92 | 93 | {:With this function you can turn on a computer on the network, if this computer 94 | supports Wake-on-LAN feature. You need the MAC address 95 | (network card identifier) of the computer. You can also assign a target IP 96 | addres. If you do not specify it, then broadcast is used to deliver magic 97 | wake-on-LAN packet. 98 | However broadcasts work only on your local network. When you need to wake-up a 99 | computer on another network, you must specify any existing IP addres on same 100 | network segment as targeting computer.} 101 | procedure WakeOnLan(MAC, IP: string); 102 | 103 | {:Autodetect current DNS servers used by the system. If more than one DNS server 104 | is defined, then the result is comma-delimited.} 105 | function GetDNS: string; 106 | 107 | {:Autodetect InternetExplorer proxy setting for given protocol. This function 108 | works only on windows!} 109 | function GetIEProxy(protocol: string): TProxySetting; 110 | 111 | {:Return all known IP addresses on the local system. Addresses are divided by 112 | comma/comma-delimited.} 113 | function GetLocalIPs: string; 114 | 115 | implementation 116 | 117 | {==============================================================================} 118 | procedure WakeOnLan(MAC, IP: string); 119 | var 120 | sock: TUDPBlockSocket; 121 | HexMac: Ansistring; 122 | data: Ansistring; 123 | n: integer; 124 | b: Byte; 125 | begin 126 | if MAC <> '' then 127 | begin 128 | MAC := ReplaceString(MAC, '-', ''); 129 | MAC := ReplaceString(MAC, ':', ''); 130 | if Length(MAC) < 12 then 131 | Exit; 132 | HexMac := ''; 133 | for n := 0 to 5 do 134 | begin 135 | b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0); 136 | HexMac := HexMac + char(b); 137 | end; 138 | if IP = '' then 139 | IP := cBroadcast; 140 | sock := TUDPBlockSocket.Create; 141 | try 142 | sock.CreateSocket; 143 | sock.EnableBroadcast(true); 144 | sock.Connect(IP, '9'); 145 | data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF; 146 | for n := 1 to 16 do 147 | data := data + HexMac; 148 | sock.SendString(data); 149 | finally 150 | sock.Free; 151 | end; 152 | end; 153 | end; 154 | 155 | {==============================================================================} 156 | 157 | {$IFNDEF UNIX} 158 | function GetDNSbyIpHlp: string; 159 | type 160 | PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; 161 | TIP_ADDRESS_STRING = array[0..15] of Ansichar; 162 | PTIP_ADDR_STRING = ^TIP_ADDR_STRING; 163 | TIP_ADDR_STRING = packed record 164 | Next: PTIP_ADDR_STRING; 165 | IpAddress: TIP_ADDRESS_STRING; 166 | IpMask: TIP_ADDRESS_STRING; 167 | Context: DWORD; 168 | end; 169 | PTFixedInfo = ^TFixedInfo; 170 | TFixedInfo = packed record 171 | HostName: array[1..128 + 4] of Ansichar; 172 | DomainName: array[1..128 + 4] of Ansichar; 173 | CurrentDNSServer: PTIP_ADDR_STRING; 174 | DNSServerList: TIP_ADDR_STRING; 175 | NodeType: UINT; 176 | ScopeID: array[1..256 + 4] of Ansichar; 177 | EnableRouting: UINT; 178 | EnableProxy: UINT; 179 | EnableDNS: UINT; 180 | end; 181 | const 182 | IpHlpDLL = 'IPHLPAPI.DLL'; 183 | var 184 | IpHlpModule: THandle; 185 | FixedInfo: PTFixedInfo; 186 | InfoSize: Longint; 187 | PDnsServer: PTIP_ADDR_STRING; 188 | err: integer; 189 | GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall; 190 | begin 191 | InfoSize := 0; 192 | Result := '...'; 193 | IpHlpModule := LoadLibrary(IpHlpDLL); 194 | if IpHlpModule = 0 then 195 | exit; 196 | try 197 | GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams'))); 198 | if @GetNetworkParams = nil then 199 | Exit; 200 | err := GetNetworkParams(Nil, @InfoSize); 201 | if err <> ERROR_BUFFER_OVERFLOW then 202 | Exit; 203 | Result := ''; 204 | GetMem (FixedInfo, InfoSize); 205 | try 206 | err := GetNetworkParams(FixedInfo, @InfoSize); 207 | if err <> ERROR_SUCCESS then 208 | exit; 209 | with FixedInfo^ do 210 | begin 211 | Result := DnsServerList.IpAddress; 212 | PDnsServer := DnsServerList.Next; 213 | while PDnsServer <> Nil do 214 | begin 215 | if Result <> '' then 216 | Result := Result + ','; 217 | Result := Result + PDnsServer^.IPAddress; 218 | PDnsServer := PDnsServer.Next; 219 | end; 220 | end; 221 | finally 222 | FreeMem(FixedInfo); 223 | end; 224 | finally 225 | FreeLibrary(IpHlpModule); 226 | end; 227 | end; 228 | 229 | function ReadReg(SubKey, Vn: PChar): string; 230 | var 231 | OpenKey: HKEY; 232 | DataType, DataSize: integer; 233 | Temp: array [0..2048] of char; 234 | begin 235 | Result := ''; 236 | if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE, 237 | KEY_READ, OpenKey) = ERROR_SUCCESS then 238 | begin 239 | DataType := REG_SZ; 240 | DataSize := SizeOf(Temp); 241 | if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then 242 | SetString(Result, Temp, DataSize div SizeOf(Char) - 1); 243 | RegCloseKey(OpenKey); 244 | end; 245 | end ; 246 | {$ENDIF} 247 | 248 | function GetDNS: string; 249 | {$IFDEF UNIX} 250 | var 251 | l: TStringList; 252 | n: integer; 253 | begin 254 | Result := ''; 255 | l := TStringList.Create; 256 | try 257 | l.LoadFromFile('/etc/resolv.conf'); 258 | for n := 0 to l.Count - 1 do 259 | if Pos('NAMESERVER', uppercase(l[n])) = 1 then 260 | begin 261 | if Result <> '' then 262 | Result := Result + ','; 263 | Result := Result + SeparateRight(l[n], ' '); 264 | end; 265 | finally 266 | l.Free; 267 | end; 268 | end; 269 | {$ELSE} 270 | const 271 | NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary'; 272 | NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters'; 273 | W9xfix = 'System\CurrentControlSet\Services\MSTCP'; 274 | begin 275 | Result := GetDNSbyIpHlp; 276 | if Result = '...' then 277 | begin 278 | if Win32Platform = VER_PLATFORM_WIN32_NT then 279 | begin 280 | Result := ReadReg(NTdyn, 'NameServer'); 281 | if result = '' then 282 | Result := ReadReg(NTfix, 'NameServer'); 283 | if result = '' then 284 | Result := ReadReg(NTfix, 'DhcpNameServer'); 285 | end 286 | else 287 | Result := ReadReg(W9xfix, 'NameServer'); 288 | Result := ReplaceString(trim(Result), ' ', ','); 289 | end; 290 | end; 291 | {$ENDIF} 292 | 293 | {==============================================================================} 294 | 295 | function GetIEProxy(protocol: string): TProxySetting; 296 | {$IFDEF UNIX} 297 | begin 298 | Result.Host := ''; 299 | Result.Port := ''; 300 | Result.Bypass := ''; 301 | end; 302 | {$ELSE} 303 | type 304 | PInternetProxyInfo = ^TInternetProxyInfo; 305 | TInternetProxyInfo = packed record 306 | dwAccessType: DWORD; 307 | lpszProxy: LPCSTR; 308 | lpszProxyBypass: LPCSTR; 309 | end; 310 | const 311 | INTERNET_OPTION_PROXY = 38; 312 | INTERNET_OPEN_TYPE_PROXY = 3; 313 | WininetDLL = 'WININET.DLL'; 314 | var 315 | WininetModule: THandle; 316 | ProxyInfo: PInternetProxyInfo; 317 | Err: Boolean; 318 | Len: DWORD; 319 | Proxy: string; 320 | DefProxy: string; 321 | ProxyList: TStringList; 322 | n: integer; 323 | InternetQueryOption: function (hInet: Pointer; dwOption: DWORD; 324 | lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall; 325 | begin 326 | Result.Host := ''; 327 | Result.Port := ''; 328 | Result.Bypass := ''; 329 | WininetModule := LoadLibrary(WininetDLL); 330 | if WininetModule = 0 then 331 | exit; 332 | try 333 | InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA'))); 334 | if @InternetQueryOption = nil then 335 | Exit; 336 | 337 | if protocol = '' then 338 | protocol := 'http'; 339 | Len := 4096; 340 | GetMem(ProxyInfo, Len); 341 | ProxyList := TStringList.Create; 342 | try 343 | Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len); 344 | if Err then 345 | if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then 346 | begin 347 | ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); 348 | Proxy := ''; 349 | DefProxy := ''; 350 | for n := 0 to ProxyList.Count -1 do 351 | begin 352 | if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then 353 | begin 354 | Proxy := SeparateRight(ProxyList[n], '='); 355 | break; 356 | end; 357 | if Pos('=', ProxyList[n]) < 1 then 358 | DefProxy := ProxyList[n]; 359 | end; 360 | if Proxy = '' then 361 | Proxy := DefProxy; 362 | if Proxy <> '' then 363 | begin 364 | Result.Host := Trim(SeparateLeft(Proxy, ':')); 365 | Result.Port := Trim(SeparateRight(Proxy, ':')); 366 | end; 367 | Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ','); 368 | end; 369 | finally 370 | ProxyList.Free; 371 | FreeMem(ProxyInfo); 372 | end; 373 | finally 374 | FreeLibrary(WininetModule); 375 | end; 376 | end; 377 | {$ENDIF} 378 | 379 | {==============================================================================} 380 | 381 | function GetLocalIPs: string; 382 | var 383 | TcpSock: TTCPBlockSocket; 384 | ipList: TStringList; 385 | begin 386 | Result := ''; 387 | ipList := TStringList.Create; 388 | try 389 | TcpSock := TTCPBlockSocket.create; 390 | try 391 | TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList); 392 | Result := ipList.CommaText; 393 | finally 394 | TcpSock.Free; 395 | end; 396 | finally 397 | ipList.Free; 398 | end; 399 | end; 400 | 401 | {==============================================================================} 402 | 403 | end. 404 | -------------------------------------------------------------------------------- /synautil.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dimmaq/delphi-synapse/0d153dcb87a251751cb5bd238d98fec50a2b0c58/synautil.pas -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /tlntsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.003.001 | 3 | |==============================================================================| 4 | | Content: TELNET and SSH2 client | 5 | |==============================================================================| 6 | | Copyright (c)1999-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)2002-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(Telnet script client) 46 | 47 | Used RFC: RFC-854 48 | } 49 | 50 | {$IFDEF FPC} 51 | {$MODE DELPHI} 52 | {$ENDIF} 53 | {$H+} 54 | 55 | unit tlntsend; 56 | 57 | interface 58 | 59 | uses 60 | SysUtils, Classes, 61 | blcksock, synautil; 62 | 63 | const 64 | cTelnetProtocol = '23'; 65 | cSSHProtocol = '22'; 66 | 67 | TLNT_EOR = #239; 68 | TLNT_SE = #240; 69 | TLNT_NOP = #241; 70 | TLNT_DATA_MARK = #242; 71 | TLNT_BREAK = #243; 72 | TLNT_IP = #244; 73 | TLNT_AO = #245; 74 | TLNT_AYT = #246; 75 | TLNT_EC = #247; 76 | TLNT_EL = #248; 77 | TLNT_GA = #249; 78 | TLNT_SB = #250; 79 | TLNT_WILL = #251; 80 | TLNT_WONT = #252; 81 | TLNT_DO = #253; 82 | TLNT_DONT = #254; 83 | TLNT_IAC = #255; 84 | 85 | type 86 | {:@abstract(State of telnet protocol). Used internaly by TTelnetSend.} 87 | TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT, 88 | tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC); 89 | 90 | {:@abstract(Class with implementation of Telnet/SSH script client.) 91 | 92 | Note: Are you missing properties for specify server address and port? Look to 93 | parent @link(TSynaClient) too!} 94 | TTelnetSend = class(TSynaClient) 95 | private 96 | FSock: TTCPBlockSocket; 97 | FBuffer: Ansistring; 98 | FState: TTelnetState; 99 | FSessionLog: Ansistring; 100 | FSubNeg: Ansistring; 101 | FSubType: Ansichar; 102 | FTermType: Ansistring; 103 | function Connect: Boolean; 104 | function Negotiate(const Buf: Ansistring): Ansistring; 105 | procedure FilterHook(Sender: TObject; var Value: AnsiString); 106 | public 107 | constructor Create; 108 | destructor Destroy; override; 109 | 110 | {:Connects to Telnet server.} 111 | function Login: Boolean; 112 | 113 | {:Connects to SSH2 server and login by Username and Password properties. 114 | 115 | You must use some of SSL plugins with SSH support. For exammple CryptLib.} 116 | function SSHLogin: Boolean; 117 | 118 | {:Logout from telnet server.} 119 | procedure Logout; 120 | 121 | {:Send this data to telnet server.} 122 | procedure Send(const Value: string); 123 | 124 | {:Reading data from telnet server until Value is readed. If it is not readed 125 | until timeout, result is @false. Otherwise result is @true.} 126 | function WaitFor(const Value: string): Boolean; 127 | 128 | {:Read data terminated by terminator from telnet server.} 129 | function RecvTerminated(const Terminator: string): string; 130 | 131 | {:Read string from telnet server.} 132 | function RecvString: string; 133 | published 134 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 135 | property Sock: TTCPBlockSocket read FSock; 136 | 137 | {:all readed datas in this session (from connect) is stored in this large 138 | string.} 139 | property SessionLog: Ansistring read FSessionLog write FSessionLog; 140 | 141 | {:Terminal type indentification. By default is 'SYNAPSE'.} 142 | property TermType: Ansistring read FTermType write FTermType; 143 | end; 144 | 145 | implementation 146 | 147 | constructor TTelnetSend.Create; 148 | begin 149 | inherited Create; 150 | FSock := TTCPBlockSocket.Create; 151 | FSock.Owner := self; 152 | FSock.OnReadFilter := FilterHook; 153 | FTimeout := 60000; 154 | FTargetPort := cTelnetProtocol; 155 | FSubNeg := ''; 156 | FSubType := #0; 157 | FTermType := 'SYNAPSE'; 158 | end; 159 | 160 | destructor TTelnetSend.Destroy; 161 | begin 162 | FSock.Free; 163 | inherited Destroy; 164 | end; 165 | 166 | function TTelnetSend.Connect: Boolean; 167 | begin 168 | // Do not call this function! It is calling by LOGIN method! 169 | FBuffer := ''; 170 | FSessionLog := ''; 171 | FState := tsDATA; 172 | FSock.CloseSocket; 173 | FSock.LineBuffer := ''; 174 | FSock.Bind(FIPInterface, cAnyPort); 175 | FSock.Connect(FTargetHost, FTargetPort); 176 | Result := FSock.LastError = 0; 177 | end; 178 | 179 | function TTelnetSend.RecvTerminated(const Terminator: string): string; 180 | begin 181 | Result := FSock.RecvTerminated(FTimeout, Terminator); 182 | end; 183 | 184 | function TTelnetSend.RecvString: string; 185 | begin 186 | Result := FSock.RecvTerminated(FTimeout, CRLF); 187 | end; 188 | 189 | function TTelnetSend.WaitFor(const Value: string): Boolean; 190 | begin 191 | Result := FSock.RecvTerminated(FTimeout, Value) <> ''; 192 | end; 193 | 194 | procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString); 195 | begin 196 | Value := Negotiate(Value); 197 | FSessionLog := FSessionLog + Value; 198 | end; 199 | 200 | function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring; 201 | var 202 | n: integer; 203 | c: Ansichar; 204 | Reply: Ansistring; 205 | SubReply: Ansistring; 206 | begin 207 | Result := ''; 208 | for n := 1 to Length(Buf) do 209 | begin 210 | c := Buf[n]; 211 | Reply := ''; 212 | case FState of 213 | tsData: 214 | if c = TLNT_IAC then 215 | FState := tsIAC 216 | else 217 | Result := Result + c; 218 | 219 | tsIAC: 220 | case c of 221 | TLNT_IAC: 222 | begin 223 | FState := tsData; 224 | Result := Result + TLNT_IAC; 225 | end; 226 | TLNT_WILL: 227 | FState := tsIAC_WILL; 228 | TLNT_WONT: 229 | FState := tsIAC_WONT; 230 | TLNT_DONT: 231 | FState := tsIAC_DONT; 232 | TLNT_DO: 233 | FState := tsIAC_DO; 234 | TLNT_EOR: 235 | FState := tsDATA; 236 | TLNT_SB: 237 | begin 238 | FState := tsIAC_SB; 239 | FSubType := #0; 240 | FSubNeg := ''; 241 | end; 242 | else 243 | FState := tsData; 244 | end; 245 | 246 | tsIAC_WILL: 247 | begin 248 | case c of 249 | #3: //suppress GA 250 | Reply := TLNT_DO; 251 | else 252 | Reply := TLNT_DONT; 253 | end; 254 | FState := tsData; 255 | end; 256 | 257 | tsIAC_WONT: 258 | begin 259 | Reply := TLNT_DONT; 260 | FState := tsData; 261 | end; 262 | 263 | tsIAC_DO: 264 | begin 265 | case c of 266 | #24: //termtype 267 | Reply := TLNT_WILL; 268 | else 269 | Reply := TLNT_WONT; 270 | end; 271 | FState := tsData; 272 | end; 273 | 274 | tsIAC_DONT: 275 | begin 276 | Reply := TLNT_WONT; 277 | FState := tsData; 278 | end; 279 | 280 | tsIAC_SB: 281 | begin 282 | FSubType := c; 283 | FState := tsIAC_SBDATA; 284 | end; 285 | 286 | tsIAC_SBDATA: 287 | begin 288 | if c = TLNT_IAC then 289 | FState := tsSBDATA_IAC 290 | else 291 | FSubNeg := FSubNeg + c; 292 | end; 293 | 294 | tsSBDATA_IAC: 295 | case c of 296 | TLNT_IAC: 297 | begin 298 | FState := tsIAC_SBDATA; 299 | FSubNeg := FSubNeg + c; 300 | end; 301 | TLNT_SE: 302 | begin 303 | SubReply := ''; 304 | case FSubType of 305 | #24: //termtype 306 | begin 307 | if (FSubNeg <> '') and (FSubNeg[1] = #1) then 308 | SubReply := #0 + FTermType; 309 | end; 310 | end; 311 | Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE); 312 | FState := tsDATA; 313 | end; 314 | else 315 | FState := tsDATA; 316 | end; 317 | 318 | else 319 | FState := tsData; 320 | end; 321 | if Reply <> '' then 322 | Sock.SendString(TLNT_IAC + Reply + c); 323 | end; 324 | 325 | end; 326 | 327 | procedure TTelnetSend.Send(const Value: string); 328 | begin 329 | Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC)); 330 | end; 331 | 332 | function TTelnetSend.Login: Boolean; 333 | begin 334 | Result := False; 335 | if not Connect then 336 | Exit; 337 | Result := True; 338 | end; 339 | 340 | function TTelnetSend.SSHLogin: Boolean; 341 | begin 342 | Result := False; 343 | if Connect then 344 | begin 345 | FSock.SSL.SSLType := LT_SSHv2; 346 | FSock.SSL.Username := FUsername; 347 | FSock.SSL.Password := FPassword; 348 | FSock.SSLDoConnect; 349 | Result := FSock.LastError = 0; 350 | end; 351 | end; 352 | 353 | procedure TTelnetSend.Logout; 354 | begin 355 | FSock.CloseSocket; 356 | end; 357 | 358 | 359 | end. 360 | --------------------------------------------------------------------------------